# HG changeset patch # User address@hidden # Date 1159908156 -7200 # Node ID a66569eaf6b1cb505fde6a058e55dce1185cd14a # Parent eb62ed1a54f11cc48bc934e023d3be3b9a8e62bb Rewrite of wdialog based web-client. Highlights: * register through webinterface (without verification) * browse / edit / vote all on the same page * some dirty hacks and assumptions since this was done mostly as a demonstration and review of the demexp architecture. diff -r eb62ed1a54f1 -r a66569eaf6b1 config/Makefile.inc --- a/config/Makefile.inc Sun Oct 01 17:31:20 2006 +0200 +++ b/config/Makefile.inc Tue Oct 03 22:42:36 2006 +0200 @@ -218,19 +218,11 @@ WEB_SRC:=lib/misc.ml.nw \ lib/time.ml.nw \ lib/cache.ml.nw \ web/serverConnection.ml.nw \ - web/registry.ml.nw \ - web/session.ui.nw \ - web/session.ml.nw \ + web/variables.ui.nw \ + web/templates.ui.nw \ + web/pages.ml.nw \ web/login.ui.nw \ - web/login.ml.nw \ web/browse.ui.nw \ - web/browse.ml.nw \ - web/addResponse.ui.nw \ - web/addResponse.ml.nw \ - web/addQuestion.ui.nw \ - web/addQuestion.ml.nw \ - web/voteWeb.ui.nw \ - web/voteWeb.ml.nw \ web/demexpweb.ui.nw \ web/demexpweb.ml.nw diff -r eb62ed1a54f1 -r a66569eaf6b1 web/browse.ui.nw --- a/web/browse.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ b/web/browse.ui.nw Tue Oct 03 22:42:36 2006 +0200 @@ -7,145 +7,217 @@ @ -Four variables are making the browse dialog state (two are comming from -the [[session]] dialog variable): -\begin{itemize} -\item [[tags]]: the set of tags displayed in the tag selector; -\item [[session.selected-tag]]: the tag chosen by the user in the tag - selector; -\item [[questions]]: the set of question selected by the chosen tags in - the tag selector; -\item [[session.selected-question]]: the question chosen by the user in - the question selector. -\end{itemize} - -Moreover, variable [[new-response]] is used to store a new response -added by a user and variable [[responses]] is used to display the set of -possible responses to a question. - <>= - - - - - - - - - - + + + + + + Invalid format + + + + + Invalid format + + + + + + +
+ + + + + + + + + +
Response ${int}: + + +
With this link: + + +
+
+
+ + + + $ext (rem)
+ + + +

+ + +
+ Tags: (add new)
+
+ 		+ Questions: + (add new) +
+
+

+ + + + Add a new response:
+
+ With this link:
+
+ + + + + + + + + + +
+ Your vote(s):
+ + 		+ +
+
+ + +
+ + + + + + Browse position base + Navigation dans la base des positions + + +

+ Logged in as $[session.login] + +

+ + +
+ Navigation area + + + (hide) + + + + (show)

+ + +
+ + + +

+ Name of new tag:
+ + + +

+ - - - - - - + +

+ Title: + (#) + + (direktlänk) +
+ Limit date:
+ + + + + + + + + + + + + + + + + + +
Tags: + + - + - + - + + (manage tags) +
Applied tags:
Available tags: + + + +
+ Responses: (add new)
+ + + + + + +
+
    + +
+ 		+ + + + + + + +
+ Winning response(s): +
+ Number of votes: +
+

+ + + + +

+

New question

+ Your question: +
+
+ + + + +

+ + + + + + @ -The browse dialog is divided into four areas: -\begin{itemize} -\item the error area, displaying error messages if necessary; -\item the tag selection area, where the user can select a tag; -\item the question selection area, where the list of questions - corresponding to the selected tag is displayed. The user can chose one - question from this list; -\item the question details area, where information about the selected - questions are displayed. -\end{itemize} - -The two latter areas are displayed only if the user has used the -previous one (cf. use of [[ui:ifvar]] construct). - -<>= - - - - - Browse position base - - - - - - -

Navigation dans la base des positions

- - -

Browse position base

- - - - - - - -

- Logged as - -

- -

- - -

- -

- - -

- Tags:
-
-
-

- - - -

- Questions:
-
-
-

- - - - -

- Title: - (#) -
- Limit date:
- Tags:
- Responses:
-

    - -
- Winning response(s): -
- Number of votes: -
-

- -

- - -

- - - - - - - - - -@ - diff -r eb62ed1a54f1 -r a66569eaf6b1 web/demexpweb.ml.nw --- a/web/demexpweb.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ b/web/demexpweb.ml.nw Tue Oct 03 22:42:36 2006 +0200 @@ -5,19 +5,60 @@ handler. <>= open Wd_dialog +open Wd_types open Wd_run_cgi +open Pages + +let main universe name env = object (self : dialog) + inherit dialog universe name env + + initializer Pages.Var.dlg := Some self + + method prepare_page () = + (*self#set_variable "debug" (String_value self#session#session_id);*) + (match self#dialog_variable "session" with + | None -> + let init dlg_name = + let dlg = universe#create env dlg_name in + self#set_variable dlg_name (Dialog_value (Some dlg)) + in init "session"; + init "tag"; + init "question"; + init "vote"; + init "bool" + | Some _ -> () + ); + let lang = env.cgi#argument_value ~default:"en" "lang" in + self#set_variable "lang" (String_value lang); + + let q_id = env.cgi#argument_value "question_id" in + + let cur_page = try + let _ = int_of_string q_id in + self#set_variable "session.selected-question" (String_value q_id); + self#set_variable "bool.nav" (String_value "0"); + "browse" + with Failure "int_of_string" -> self#string_variable "cur-page" in + match cur_page with + | "login" -> Login.prepare self + | "browse" -> Browse.prepare self + | "register" -> Register.prepare self + | _ -> Login.prepare self + + + method handle () = + match self#string_variable "cur-page" with + | "login" -> Login.handle self + | "browse" -> Browse.handle self + | "register" -> Register.handle self + | _ -> () + +end let _ = run ~charset:`Enc_utf8 - ~reg:(fun universe -> - universe#register "session" (new Session.session); - universe#register "browse" (new Browse.browse); - universe#register "vote" (new VoteWeb.vote); - universe#register "add-response" (new AddResponse.add_response); - universe#register "add-question" (new AddQuestion.add_question); - universe#register "login" (new Login.login) - ) + ~reg:(fun universe -> universe#register "main" main) ~uifile:"demexpweb.ui" () @ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/demexpweb.ui.nw --- a/web/demexpweb.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ b/web/demexpweb.ui.nw Tue Oct 03 22:42:36 2006 +0200 @@ -13,25 +13,51 @@ This file includes all the other dialogs + + - - - + +0"> +1"> ]> - + + - &include_session; + &include_variables; + &include_templates; &include_login; &include_browse; - &include_add_response; - &include_add_question; - &include_vote; + + + + $body + + + + + + + + + + + + + + + + + + + + + + @ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/login.ui.nw --- a/web/login.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ b/web/login.ui.nw Tue Oct 03 22:42:36 2006 +0200 @@ -9,61 +9,54 @@ This dialog handles user login et settin @ -The dialog display an error message in case the variable -[[error-message]] is not empty through a call to [[display-error]] -template. +<>= + + + +

Please enter your desired login and password:

+

+ Login:
+ Password:
+ Repeat password:
+ +

+ + +

Account creation was successfull. + You can now go back to the login page to login.

+ + + + -\nextchunklabel{code:login.ui:login} -<>= - + + +

+ Veuillez entrer votre identifiant et mot de passe : + Please enter your login and password: +

+

+ Identifiant : + Login: +
+ Mot de passe : + Password: +
+ + + + + + + +

- - - +

+ fr + en +

+ + - - - - - demexp login - - - -

demexp login

- - - - - -

Veuillez entrer votre identifiant et mot de passe :

-

- Identifiant :
- Mot de passe : -
- -

- - - -

Please enter your login and password:

-

- Login:
- Password:
- -

- - - -

- fr - en -

- - - - - - - @ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/serverConnection.ml.nw --- a/web/serverConnection.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ b/web/serverConnection.ml.nw Tue Oct 03 22:42:36 2006 +0200 @@ -10,10 +10,15 @@ open Messages_clnt open Messages_clnt @ -Right now, the server to connect to is statically defined. +Right now, the server to connect to is read from the file "demexp_server". <>= -let web_default_server = Config.default_server_name +let web_default_server = + if Sys.file_exists "demexp_server" then ( + let ch = open_in "demexp_server" in + input_line ch + ) else Config.default_server_name + let web_default_port = Config.default_server_port @ @@ -75,3 +80,96 @@ let cache_filename = "/tmp/demexp-web-cache-" ^ web_default_server ^ ":" ^ (string_of_int web_default_port) @ + +Bla bla, bla? + +<>= +open Messages_aux +open Messages_clnt + +type server = + < question_info : int -> int -> question_t array + > + +let chk_rc rc errfunc = + if rc <> Messages_aux.rt_ok then ( + let msg = Misc.string_of_return_code rc in + errfunc msg + ) + +let server_of_ccc client cookie cache errfunc = + let chk rc = chk_rc rc errfunc in + object + (* Is this safe? *) (* well... it is ugly *) + method client = client method cookie = cookie method cache = cache + + method question_info id quantity : question_t array = + let r = Cache.question_info cache client (cookie, id, quantity) in + chk r.question_info_rc; + r.question_info + method get_question_tags id : int array = + let r = Demexp.V1.get_question_tags client (cookie, id) in + r + method tag_info id quantity : info_on_tag_t array = + let r = Demexp.V1.tag_info client (cookie, id, quantity) in + chk r.tag_info_rc; + r.tag_info + method get_vote id login : int array = + let r = Demexp.V1.get_vote client (cookie, id, login) in + chk r.get_vote_rc; + r.get_vote + method vote q_id ans_ids = + let r = Demexp.V1.vote client (cookie, q_id, ans_ids) in + chk r; + Cache.invalidate cache (Cache.Question q_id) + method tag_question q_id tag_id = + let r = Demexp.V1.tag_question client (cookie, q_id, tag_id) in + chk r + method untag_question q_id tag_id = + let r = Demexp.V1.untag_question client (cookie, q_id, tag_id) in + chk r + method create_tag label : int = + let r = Demexp.V1.create_tag client (cookie, label) in + chk r.create_tag_rc; + r.create_tag_id + method add_response q_id desc link = + let r = Demexp.V1.add_response client (cookie, q_id, desc, link) in + chk r; + Cache.invalidate cache (Cache.Question q_id) + method new_question question : int = + let r = Demexp.V1.new_question client (cookie, question) in + chk r.question_id_return_code; + r.question_id_id + method set_question_status q_id status = + let status = Rtypes.int4_of_int status in + let r = Demexp.V1.set_question_status client (cookie, q_id, status) in + chk r + method max_question_id = + let r = Demexp.V1.max_question_id client cookie in + chk r.max_question_id_rc; + r.max_question_id + method add_participant login pass groups = + let r = Demexp.V1.add_participant client (cookie, login, pass, groups) in + chk r.add_participant_rc; + r + end + +exception Server_error of string + +let default_error_func err = raise (Server_error err) + +let do_in_server + ?(url=web_default_server) ?(port=web_default_port) ?(on_error=default_error_func) + login pass f = + let client, cookie = login_on_server url port login pass in + let cache = Cache.create cache_filename client cookie in + try + let x = f (server_of_ccc client cookie cache on_error) in + Cache.save cache; + close_connection_to_server client cookie; + x + with e -> + Cache.save cache; + close_connection_to_server client cookie; + raise e + diff -r eb62ed1a54f1 -r a66569eaf6b1 web/pages.ml.nw --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/web/pages.ml.nw Tue Oct 03 22:42:36 2006 +0200 @@ -0,0 +1,500 @@ +<>= +open Wd_dialog +open Wd_types +open Messages_aux +open Messages_clnt + +exception Display_error = Misc.Display_error + +let ppe msg f x = (* prepend error *) + try f x with Display_error err -> raise (Display_error (msg^err)) + +let raise_if b exc = if b then raise exc + +module Var = struct + let dlg = ref (None : dialog option) + let d () = match !dlg with Some d -> d | None -> assert false + type 'a var = { get : unit -> 'a ; set : 'a -> unit } + let objify var = object method get = var.get () method set = var.set end + let bug n f x = try f x with e -> prerr_endline ("Hint: "^n); raise e + let mkvar f1 f2 name = objify + { get = (fun () -> bug name (f1 (d())) name); + set = fun x -> bug name ((d())#set_variable name) (f2 x) } + let string_var = mkvar (fun d -> d#string_variable) + (fun x -> String_value x) + let bool_var = mkvar (fun d n -> int_of_string (d#string_variable n) <> 0) + (function true -> String_value "1" | false -> String_value "0") + let int_var = mkvar (fun d n -> int_of_string (d#string_variable n)) + (fun x -> String_value (string_of_int x)) + let dyn_enum_var = mkvar (fun d -> d#dyn_enum_variable) + (fun x -> Dyn_enum_value x) + let assert_string = function String_value x -> x | _ -> assert false + let string_alist_var = + mkvar (fun d n -> List.map (fun (a,b) -> a, assert_string b) (d#alist_variable n)) + (fun x -> Alist_value (List.map (fun (a,b) -> a, String_value b) x)) + (* variables: *) + let login = string_var "session.login" + let password = string_var "session.password" + let password_confirm = string_var "session.password-confirm" + let cur_page = string_var "cur-page" + let error_message = string_var "error-message" + module Bool = struct + let nav = bool_var "bool.nav" + let new_tag = bool_var "bool.new-tag" + let new_ans = bool_var "bool.new-ans" + let new_question = bool_var "bool.new-question" + let tag_question = bool_var "bool.tag-question" + let reg_success = bool_var "bool.reg-success" + end + module T = struct (* tag *) + let list = dyn_enum_var "tag.list" + let selected = string_var "tag.selected" + let previous = string_var "tag.previous" + let for_addition = string_var "tag.new" + end + module Q = struct (* question *) + let list = dyn_enum_var "question.list" + let selected = string_var "question.selected" + let previous = string_var "question.previous" + let title = string_var "question.title" + let responses = dyn_enum_var "question.responses" + let limit_date = string_var "question.limit-date" + let tags = dyn_enum_var "question.tags" + let winning_responses = string_var "question.winning-responses" + let number_of_votes = int_var "question.number-of-votes" + end + module V = struct (* vote *) + let list = dyn_enum_var "vote.list" + let selected = string_var "vote.selected" + end + module Add = struct (* values for addition *) + let tag = T.for_addition + let q_desc = string_var "question.new" + let ans_desc = string_var "question.new-ans" + let ans_url = string_var "question.new-ans-url" + let ans_desc_list = string_alist_var "question.new-ans-list" + let ans_url_list = string_alist_var "question.new-ans-url-list" + end + module Err = struct (* error variables *) + let general = error_message + let q_desc = string_var "question.error-new" + let ans_desc_list = string_alist_var "question.new-ans-error" + let ans_url_list = string_alist_var "question.new-ans-url-error" + end +end + +let do_in_server ?(login=Var.login#get) ?(pass=Var.password#get) f = + let on_error x = raise (Display_error x) in + ServerConnection.do_in_server ~on_error login pass f + +let error x = Var.error_message#set x + +type page = Login | Register | Browse + +let change_page pagename = + Var.Err.general#set ""; + (function + | Login -> Var.cur_page#set "login" + | Register -> Var.cur_page#set "register" + | Browse -> Var.cur_page#set "browse") pagename + +@ + + +Helper function [[fill_tag_selector]] get tags from the server and put +them into the tag selector. It returns a hash table [[tags]] mapping tag +id to label. + +\todo{The [[List.sort]] should handle UTF-8 encoded strings with + a correct locale.} + +<>= +let fill_tag_list dlg srv = + let tags = Hashtbl.create 3 in + Cache.update_tags_hash tags srv#client srv#cookie srv#cache; + let aggregate_non_question_tags id label tag_list = + if not (Norm.is_question_specific_tag label) then + (id, label) :: tag_list + else tag_list in + let tags_dyn_val = + let raw_tags = Hashtbl.fold aggregate_non_question_tags tags [] in + let sorted = List.sort (fun (_, l1) (_, l2) -> compare l1 l2) raw_tags in + List.map (fun (id, label) -> + (string_of_int id, Printf.sprintf "%s" label)) sorted in + Var.T.list#set tags_dyn_val +@ + + +<>= + +let fill_question_list dlg srv = + let max_question_id = + ppe "Unable to get max_question_id :" (fun () -> srv#max_question_id) () in + let questions = Hashtbl.create 3 in + Cache.update_questions_hash + questions max_question_id srv#client srv#cookie srv#cache; + try + let chosen_tag = int_of_string (Var.T.selected#get) in + let select_question id (desc, tags) selection = + if List.exists (fun tag_id -> tag_id = chosen_tag) tags then + (string_of_int id, desc) :: selection + else + selection in + Var.Q.list#set (Hashtbl.fold select_question questions []) + with Failure "int_of_string" -> () + +let fill_question_details q_id dlg srv = + let q_info = + let x = ppe "Unable to load question information: " srv#question_info q_id 1 in + assert (Array.length x = 1); x.(0) + in + try + Var.Q.title#set q_info.q_desc; + (* limit date *) + Var.Q.limit_date#set + (match q_info.q_info_limit_date with + | x when x = Int64.zero -> "no limit date" + | x -> (* transform limit date in local time *) + let offset = Int64.to_float x in + Time.time_as_localtime_iso_string offset); + (* tags *) + let tag_set = srv#get_question_tags q_id in + let tag_pair id = + let arr = srv#tag_info id 1 in + (string_of_int id, arr.(0).a_tag_label) + in + let tag_pairs = List.map tag_pair (Array.to_list tag_set) in + let f (_, s) = String.length s < 9 || String.sub s 0 9 <> "question " in + Var.Q.tags#set (List.filter f tag_pairs); + (* responses *) + let make_url link = "" ^ link ^ "" in + let string_of_response i r = + let link = + if r.r_info_link <> "" then ("[" ^ (make_url r.r_info_link) ^ "]") + else "" in + (string_of_int i, + Printf.sprintf "%d. %s %s\n" i r.r_info_desc link) in + (*let descr_of_response i r = + (string_of_int i, r.r_info_desc) in*) + let str_responses = + Array.to_list (Array.mapi string_of_response + q_info.q_info_responses) in + Var.Q.responses#set str_responses; + Var.Q.number_of_votes#set q_info.q_info_num_votes; + (* winning response(s) *) + let response_desc r_id = + let desc = q_info.q_info_responses.(r_id).r_info_desc in + Printf.sprintf "%d. %s" r_id desc in + let str = + Array.fold_left + (fun str r_id -> str ^ (response_desc r_id) ^ " ") "" + q_info.q_info_elected_responses in + Var.Q.winning_responses#set str; + (* get own vote *) + let vote = ppe "Cannot get own vote: " (srv#get_vote q_id) Var.login#get in + let vote = Array.to_list vote in + let responses = + Array.to_list (Array.mapi (fun i r -> (i, r.r_info_desc)) + q_info.q_info_responses) in + let votes_with_desc,_ = Misc.split_responses vote responses in + let string_id (id, desc) = (string_of_int id, desc) in + dlg#set_variable "vote.selected" (String_value ""); + dlg#set_variable "vote.list" + (Dyn_enum_value (List.map string_id votes_with_desc)) + with Display_error str -> error str + +let fill_question_area dlg srv = + fill_question_list dlg srv; + + let q_id = Var.Q.selected#get in + let last_q_id = Var.Q.previous#get in + if q_id <> last_q_id then ( + Var.Q.previous#set q_id; + Var.Bool.new_ans#set false; + Var.Bool.tag_question#set false; + if q_id <> "" then (Var.Bool.new_question#set false); + try + let q_id = int_of_string Var.Q.selected#get in + fill_question_details q_id dlg srv + with Failure("int_of_string") -> () + ) +@ + + +<>= +let submit_vote dlg = + let votes = dlg#dyn_enum_variable "vote.list" in + let vote_ids = List.map (fun (id,_) -> int_of_string id) votes in + try do_in_server (fun srv -> + let q_id = int_of_string Var.Q.selected#get in + ppe "Vote failed: " (srv#vote q_id) (Array.of_list vote_ids); + fill_question_details q_id dlg srv) + with Display_error msg -> error msg + +let submit_tags dlg = + let tags = List.map (fun (x,_) -> int_of_string x) Var.Q.tags#get in + let q_id = int_of_string Var.Q.selected#get in + try do_in_server (fun srv -> + let tag id = ppe "Cannot tag question: " (srv#tag_question q_id) id in + let untag id = ppe "Cannot untag question: " (srv#untag_question q_id) id in + let old_tags = srv#get_question_tags q_id in + Array.iter untag old_tags; + List.iter tag tags) + with Display_error msg -> error msg + + +let prepare_question_addition dlg = + let change_assoc key v al = + let rec f = function + | [] -> assert false + | (k,x)::tl -> if k = key then (k,v) :: tl else (k,x) :: f tl + in f al + in + let get var n = + match List.assoc (string_of_int n) (dlg#alist_variable var) with + | String_value s -> s + | _ -> assert false + in + let set var n v = + let al = dlg#alist_variable var in + let nl = change_assoc (string_of_int n) (String_value v) al in + dlg#set_variable var (Alist_value nl) in + let desc = "question.new-ans-list" in + let url = "question.new-ans-url-list" in + let desc_error = "question.new-ans-error" in + let url_error = "question.new-ans-url-error" in + let ids = List.map (fun (i,_) -> int_of_string i) (dlg#alist_variable desc) in + let f id = + let a = Norm.normalize_response (get desc id) in + let u = Norm.normalize_link (get url id) in + set desc_error id ""; set url_error id ""; error ""; + let check f v errvar = + try f v with Norm.Invalid_format -> + set errvar id "E"; + error "Invalid response or link format" + in + if a <> "" then check (fun x -> Norm.check_response x) a desc_error; + check Norm.check_link u url_error; + (a, u) + in + let question = Norm.normalize_question (dlg#string_variable "question.new") in + (try Norm.check_question question with Norm.Invalid_format -> + dlg#set_variable "question.error-new" (String_value "E"); + error "Invalid question format"); + (question, List.map f ids) + +@ + +<>= +module Login = struct + let prepare dlg = + change_page Login + + let handle dlg = + match dlg#event with + + | Button "login" -> + (try + do_in_server ignore; + change_page Browse + with + | ServerConnection.Protocol_warning (_, _, _) -> + (* todo: we don't display warning message. We should show it *) + change_page Browse + | ServerConnection.Login_error (msg, _, _) -> error msg; + | other_exception -> + let msg = + Printf.sprintf "Unknown error message (%s). Please report it to address@hidden" + (Printexc.to_string other_exception) in + error msg + ) + + | Button "new_user" -> + Var.login#set ""; + Var.password#set ""; + Var.password_confirm#set ""; + Var.Bool.reg_success#set false; + change_page Register + + | _ -> () +end + + +module Register = struct + let prepare dlg = () + + let handle dlg = + match dlg#event with + + | Button "register" -> + error ""; + (try do_in_server ~login:"root" ~pass:"demexp" (fun srv -> + raise_if (Var.password#get <> Var.password_confirm#get) + (Display_error "The passwords are not identical."); + srv#add_participant Var.login#get Var.password#get [|"classifier"|]; + Var.Bool.reg_success#set true) + with Display_error msg -> error msg) + + + | Button "back" -> + dlg#unset_variable "session.login"; + dlg#unset_variable "session.password"; + change_page Login + + | _ -> () +end + + +module Browse = struct + let prepare dlg = + do_in_server (fun srv -> + fill_tag_list dlg srv; + fill_question_area dlg srv) + + let handle dlg = + match dlg#event with + + | Button("new_question") -> + Var.Add.q_desc#set ""; + Var.Err.q_desc#set ""; + Var.Q.selected#set ""; (* ugly *) + + let x = ["1",""; "2",""; "3",""] in + Var.Add.ans_desc_list#set x; + Var.Add.ans_url_list#set x; + Var.Err.ans_desc_list#set x; + Var.Err.ans_url_list#set x; + + Var.Bool.new_question#set true + + | Button("add_response") -> + Var.Add.ans_desc#set ""; + Var.Add.ans_url#set ""; + Var.Bool.new_ans#set true + + | Button("new_tag") -> + Var.T.for_addition#set ""; + Var.Bool.new_tag#set true + + | Button("submit_tag") -> + (try do_in_server (fun srv -> srv#create_tag Var.T.for_addition#get); + Var.Bool.new_tag#set false + with Display_error msg -> error msg) + + | Button("cancel_new_tag") -> Var.Bool.new_tag#set false + + | Button("logout") -> change_page Login + + | Button "move_up" -> + let id = Var.V.selected#get in + let rec f = function + | [] -> assert false + | v::[] -> [v] + | v::(i,desc)::tl when i = id -> (i,desc)::v::tl + | v::tl -> v :: f tl + in Var.V.list#set (f Var.V.list#get); + submit_vote dlg + + | Button "move_down" -> + let id = Var.V.selected#get in + let rec f = function + | [] -> assert false + | v::[] -> [v] + | (i,desc)::v::tl when i = id -> v::(i,desc)::tl + | v::tl -> v :: f tl + in Var.V.list#set (f Var.V.list#get); + submit_vote dlg + + | Button "remove" -> + let id = Var.V.selected#get in + Var.V.list#set (List.filter (fun (x,_) -> x<>id) Var.V.list#get); + Var.V.selected#set ""; + submit_vote dlg + + | Button "ans_submit" -> + let desc = Var.Add.ans_desc#get in + let link = Var.Add.ans_url#get in + let q_id = int_of_string Var.Q.selected#get in + (try + do_in_server (fun srv -> srv#add_response q_id desc link); + Var.Bool.new_ans#set false; + Var.Add.ans_desc#set ""; + Var.Add.ans_url#set ""; + Var.Q.previous#set ""; (* ugly *) + with Display_error msg -> + error ("Error while adding a new response: "^msg) + ) + + | Button "ans_cancel" -> + dlg#set_variable "question.new-ans" (String_value ""); + Var.Bool.new_ans#set false + + | Button "nav_tgl" -> Var.Bool.nav#set (not Var.Bool.nav#get) + | Button "cancel_new_question" -> Var.Bool.new_question#set false + | Button "manage_tags" -> Var.Bool.tag_question#set true + | Button "tag_question_done" -> Var.Bool.tag_question#set false + + | Button "another_ans" -> + let f x = x#set (x#get @ [string_of_int (List.length x#get + 1), ""]) in + List.iter f [Var.Add.ans_desc_list; Var.Add.ans_url_list; + Var.Err.ans_desc_list; Var.Err.ans_url_list] + + | Button "submit_question" -> + let question, answers = prepare_question_addition dlg in + let tag_id = int_of_string Var.T.selected#get in + (try + if Var.Err.general#get <> "" then raise (Failure "won't commit this"); + do_in_server (fun srv -> + let q_id = ppe "Cannot add question: " srv#new_question question in + let f (desc, url) = + if desc <> "" then + ppe "Cannot add response: " (srv#add_response q_id desc) url + in List.iter f answers; + ppe "Cannot set question status: " (srv#set_question_status q_id) 2; + ppe "Cannot tag question: " (srv#tag_question q_id) tag_id; + ); + Var.Bool.new_question#set false + with Misc.Display_error msg -> error msg; + | Failure "won't commit this" -> () + ) + + | Indexed_button ("remove_tag", id) -> + let applied = Var.Q.tags#get in + if not (List.exists (fun (x,_) -> x = id) applied) then + error ("Can't remove tag #"^id); + Var.Q.tags#set (List.filter (fun (x,_) -> x <> id) applied); + submit_tags dlg + + | Button "tag_question_add" -> + (* TODO: use Add.tag instead of question.new-tag *) + let applied = Var.Q.tags#get in + let selected = dlg#string_variable "question.new-tag" in + let available = Var.T.list#get in + if List.exists (fun (x,_) -> x = selected) applied then + error "Tag already in use." + else ( + let name = List.assoc selected available in + Var.Q.tags#set (applied @ [selected, name]); + submit_tags dlg + ) + + | Button str when String.sub str 0 5 = "vote_" -> + let vote_id = String.sub str 5 (String.length str - 5) in + let responses = Var.Q.responses#get in + let votes = Var.V.list#get in + let vote = List.find (fun (id,_) -> id = vote_id) responses in + let rec f = function + | [] -> [vote] + | v::[] -> if v = vote then [v] else v::[vote] + | v1::v2::tl -> if v1 = vote then v1::v2::tl else + if v2 = vote then v2::v1::tl else + v1 :: f (v2::tl) + in + Var.V.list#set (f votes); + Var.V.selected#set vote_id; + submit_vote dlg + + | _ -> + () +end +@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/templates.ui.nw --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/web/templates.ui.nw Tue Oct 03 22:42:36 2006 +0200 @@ -0,0 +1,60 @@ +<>= + + +@ + +The [[display-a-response]] template is used to print one question's +response. It is used when displaying the set of responses to a +question. + +<>= + +
  • $ext (vote)
    • +     +@ + +Template [[display-error]] is used to display the +[[session.error-message]] at the top of each web page of the web +interface. + +<>= + + + + Error: + + + +@ + +Template [[make-hyperlink]] prints the hyperlink [[href]] and made it +clickable. + +<>= + + $href + +@ + +<>= + + + + $title + + + +

    $title

    + + + $body +     + + +     + +@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/variables.ui.nw --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/web/variables.ui.nw Tue Oct 03 22:42:36 2006 +0200 @@ -0,0 +1,72 @@ +\chapter{\texttt{session} dialog} + +The [[session]] dialogs contains the variables used by all other +dialogs. It allows to have persistency of the state between the dialogs. + +\section{\texttt{session} dialog definition} + +<>= + + +@ + +<>= + + + demo + + + demo + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + &true; + &false; + &false; + &false; + &false; + &false; + &false; + + +@ + diff -r eb62ed1a54f1 -r a66569eaf6b1 web/addQuestion.ml.nw --- a/web/addQuestion.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -\section{\texttt{addQuestion} backend code} - -<>= -(* copyright 2005-2006 David MENTRE *) -(* this software is under GNU GPL. See COPYING.GPL file for details *) - -open Wd_dialog -open Wd_types -open Messages_aux -open Messages_clnt -open Norm -@ - -Function [[prepare_question_addition]] normalizes question, responses -and links, checks their correctness and asks the user for confirmation -(through use of the [[ifvar]] mechanism in the [[add-question]] dialog). - -<>= -let prepare_question_addition add_q_obj = - let set_err_var var = add_q_obj#set_variable var (String_value "E") in - let unset_err_var var = add_q_obj#set_variable var (String_value "") in - let question = - normalize_question (add_q_obj#string_variable "new-question") in - let response1 = - normalize_response (add_q_obj#string_variable "new-response1") in - let response2 = - normalize_response (add_q_obj#string_variable "new-response2") in - let response3 = - normalize_response (add_q_obj#string_variable "new-response3") in - let link1 = normalize_link (add_q_obj#string_variable "new-link1") in - let link2 = normalize_link (add_q_obj#string_variable "new-link2") in - let link3 = normalize_link (add_q_obj#string_variable "new-link3") in - try - check_question question; - try - if response1 <> "" then check_response response1; - if response2 <> "" then check_response response2; - if response3 <> "" then check_response response3; - check_link link1; - check_link link2; - check_link link3; - add_q_obj#set_variable "question-to-add" (String_value question); - add_q_obj#set_variable "response1-to-add" (String_value response1); - add_q_obj#set_variable "response2-to-add" (String_value response2); - add_q_obj#set_variable "response3-to-add" (String_value response3); - add_q_obj#set_variable "link1-to-add" (String_value link1); - add_q_obj#set_variable "link2-to-add" (String_value link2); - add_q_obj#set_variable "link3-to-add" (String_value link3); - (* clear possible error message *) - unset_err_var "error-question"; - unset_err_var "error-response1"; unset_err_var "error-response2"; - unset_err_var "error-response3"; - unset_err_var "error-link1"; unset_err_var "error-link2"; - unset_err_var "error-link3"; - Session.display_error_message add_q_obj "" - with Invalid_format -> - Session.display_error_message add_q_obj - "Invalid response or link format"; - if not (is_valid_response response1) then set_err_var "error-response1"; - if not (is_valid_response response2) then set_err_var "error-response2"; - if not (is_valid_response response3) then set_err_var "error-response3"; - if not (is_valid_link link1) then set_err_var "error-link1"; - if not (is_valid_link link2) then set_err_var "error-link2"; - if not (is_valid_link link3) then set_err_var "error-link3"; - (* avoid displaying Confirm button *) - add_q_obj#set_variable "question-to-add" (String_value "") - with Invalid_format -> - set_err_var "error-question"; - Session.display_error_message add_q_obj "Invalid question format"; - (* avoid displaying Confirm button *) - add_q_obj#set_variable "question-to-add" (String_value "") -@ - -Function [[add_question]] adds a new question (and its set of responses -and link) on the server. - -<>= -let add_question_to_server add_q_obj = - let question = add_q_obj#string_variable "question-to-add" in - let response1 = add_q_obj#string_variable "response1-to-add" in - let response2 = add_q_obj#string_variable "response2-to-add" in - let response3 = add_q_obj#string_variable "response3-to-add" in - let link1 = add_q_obj#string_variable "link1-to-add" in - let link2 = add_q_obj#string_variable "link2-to-add" in - let link3 = add_q_obj#string_variable "link3-to-add" in - let client, cookie = Session.connect_to_server add_q_obj in - try - let ret = Demexp.V1.new_question client (cookie, question) in - if ret.question_id_return_code <> rt_ok then ( - let msg = - Printf.sprintf "Cannot add question '%s': %s" - question - (Misc.string_of_return_code ret.question_id_return_code) in - raise (Misc.Display_error msg) - ); - let q_id = ret.question_id_id in - (* add responses *) - let register_response response link = - let ret = - Demexp.V1.add_response client (cookie, q_id, response, link) in - if ret <> rt_ok then - let msg = - Printf.sprintf "Cannot add response '%s': %s" - response (Misc.string_of_return_code ret) in - raise (Misc.Display_error msg) in - if response1 <> "" then register_response response1 link1; - if response2 <> "" then register_response response2 link2; - if response3 <> "" then register_response response3 link3; - ServerConnection.close_connection_to_server client cookie - with Misc.Display_error str -> - Session.display_error_message add_q_obj str; - ServerConnection.close_connection_to_server client cookie -@ - -The [[add_question]] class defines handling of events for the -[[add-question]] dialog. - -<>= -class add_question universe name env = - object (self) - inherit dialog universe name env - - method prepare_page () = - self#set_variable "lang" - (String_value (self#string_variable "session.lang")) - - method handle () = - match self#event with - | Button("add") -> prepare_question_addition self - - | Button("confirm") -> - add_question_to_server self; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) - - | Button("cancel") -> - Session.display_error_message self ""; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) - - | _ -> - () - end -@ - - -At module start, we register creation function into the Registry. - -<>= -let _ = - Registry.new_add_question := - fun universe env session -> - let dlg = universe#create env "add-question" in - dlg#set_variable "session" (Dialog_value session); - dlg -@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/addQuestion.ui.nw --- a/web/addQuestion.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,171 +0,0 @@ -\chapter{\texttt{addQuestion} dialog} - -\section{\texttt{addQuestion} dialog definition} - -<>= - - -@ - - -Template [[print-error]] displays a [[Format error]] message on web page -if [[var]] variable is not empty. This template is used to display an -error information for each input field. - -<>= - - - Invalid format - - -@ - -Variables [[new-*]] are filled in by the user on the web page. Once the -user clicks on [[Add your question]], their content are normalized and -put into corresponding [[*-to-add]] variables. This is the content of -the latter variables that are used when registering the new question on -the server. - -<>= - - - - - - - - - - - - - - - - - - - - - - -@ - -The variables [[error-*]] are used to display an error message next to -the corresponding field when not empty. - -<>= - - - - - - - - -@ - -The content of the web page: all the user input fields. - -<>= - - - - - New question - - - -

    New question

    - - - - - -

    - Your question:
    -
    -

    - -

    - Response 1:
    -
    - With this link:
    -
    -

    - -

    - Response 2:
    -
    - With this link:
    -
    -

    - -

    - Response 3:
    -
    - With this link:
    -
    -

    - - - - -

    -@ - -When all the field contents have been validated, they are printed for -confirmation. We only print fields that are not empty. - -<>= - - - Confirm to add question: -
    - With responses:
    -

      - -
    1. - - [] -
      2. -       - - -
    2. - - [] -
      3. -       - - -
    3. - - [] -
      4. -       -
    - - You won't be able to modify it afterward!
    - -
    -     - -

    - - - - - - - - -@ - diff -r eb62ed1a54f1 -r a66569eaf6b1 web/addResponse.ml.nw --- a/web/addResponse.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -\section{\texttt{addReponse} backend code} - -<>= -(* copyright 2005-2006 David MENTRE *) -(* this software is under GNU GPL. See COPYING.GPL file for details *) - -open Wd_dialog -open Wd_types -open Messages_aux -open Messages_clnt -@ - -Function [[prepare_response_addition]] normalizes response and link -correctness and ask the user for confirmation (through use of the -[[ifvar]] mechanism in the [[add-response]] dialog). - -<>= -let prepare_response_addition add_resp_obj = - let response = - Norm.normalize_response (add_resp_obj#string_variable "new-response") in - let link = - Norm.normalize_link (add_resp_obj#string_variable "new-link") in - try - Norm.check_response response; - try - if link <> "" then Norm.check_link link; - add_resp_obj#set_variable "response-to-add" (String_value response); - add_resp_obj#set_variable "link-to-add" (String_value link); - (* clear possible error message *) - Session.display_error_message add_resp_obj "" - with Norm.Invalid_format -> - Session.display_error_message add_resp_obj "Invalid link format"; - add_resp_obj#set_variable "response-to-add" (String_value ""); - add_resp_obj#set_variable "link-to-add" (String_value "") - with Norm.Invalid_format -> - Session.display_error_message add_resp_obj "Invalid response format"; - add_resp_obj#set_variable "response-to-add" (String_value ""); - add_resp_obj#set_variable "link-to-add" (String_value "") -@ - -Function [[add_response]] adds a new reponse to currently selected -question. - -<>= -let add_response_to_server add_resp_obj = - let response = add_resp_obj#string_variable "response-to-add" in - let link = add_resp_obj#string_variable "link-to-add" in - let client, cookie = Session.connect_to_server add_resp_obj in - try - let q_id = int_of_string - (add_resp_obj#string_variable "session.selected-question") in - let ret = Demexp.V1.add_response client (cookie, q_id, response, link) in - if ret <> rt_ok then ( - let msg = Printf.sprintf "Error while adding a new reponse: %s" - (Misc.string_of_return_code ret) in - raise (Misc.Display_error msg) - ); - (* invalidate this entry in the cache *) - let cache = Cache.create ServerConnection.cache_filename client cookie in - Cache.invalidate cache (Cache.Question q_id); - Cache.save cache; - ServerConnection.close_connection_to_server client cookie - with Misc.Display_error str -> - Session.display_error_message add_resp_obj str; - ServerConnection.close_connection_to_server client cookie -@ - -The [[add_response]] class defines handling of events for the -[[add-response]] dialog. - -<>= -class add_response universe name env = - object (self) - inherit dialog universe name env - - method prepare_page () = - self#set_variable "lang" - (String_value (self#string_variable "session.lang")) - - method handle () = - match self#event with - | Button("add") -> prepare_response_addition self - - | Button("confirm") -> - add_response_to_server self; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) - - | Button("cancel") -> - Session.display_error_message self ""; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) - - | _ -> - () - end -@ - - -At module start, we register creation function into the Registry. - -<>= -let _ = - Registry.new_add_response := - fun universe env session title responses -> - let dlg = universe#create env "add-response" in - dlg#set_variable "session" (Dialog_value session); - dlg#set_variable "title" title; - dlg#set_variable "responses" responses; - dlg -@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/addResponse.ui.nw --- a/web/addResponse.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -\chapter{\texttt{addResponse} dialog} - -\section{\texttt{addResponse} dialog definition} - -<>= - - -@ - -The variables [[title]] and [[responses]] respectively store the -question title and its current responses. Those variables are -initialized at [[add-response]] dialog creation. - -Variables [[new-response]] and [[new-link]] are filled in by the user on -the web page. Once the user clicks on [[Add your response]], their -content is normalized and put into [[response-to-add]] and -[[link-to-add]]. This is the content of the latter two variables that is -used when registering the new response on the server. - -<>= - - - - - - - - - - - - - - -@ - -We use template [[display-a-reponse]] defined in [[session]] dialog (cf. -\codechunkref{code:template-display-a-reponse}). - -<>= - - - - - - New response to - (#<ui:dynamic variable="session.selected-question"/>) - <ui:dynamic variable="title"/> - - - - -

    - Add a new response to question - (#) - -

    - - - - - -

    - To question: - (#) -
    - With responses:
    -

      - -
    -

    - -

    - Add a new reponse:
    -
    - With this link:
    -
    -

    - - - -

    - - - - Confirm to add response: - - []
    - - You won't be able to modify it afterward!
    - -
    -     - -

    - - - - - - - - -@ - diff -r eb62ed1a54f1 -r a66569eaf6b1 web/browse.ml.nw --- a/web/browse.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,212 +0,0 @@ -\section{browse backend code} - -<>= -(* copyright 2005-2006 David MENTRE *) -(* this software is under GNU GPL. See COPYING.GPL file for details *) - -open Wd_dialog -open Wd_types -open Messages_aux -open Messages_clnt -@ - -Helper function [[fill_tag_selector]] get tags from the server and put -them into the tag selector. It returns a hash table [[tags]] mapping tag -id to label. - -\todo{The [[List.sort]] should handle UTF-8 encoded strings with - a correct locale.} - -<>= -let fill_tag_selector browse_object client cookie cache = - let tags = Hashtbl.create 3 in - Cache.update_tags_hash tags client cookie cache; - let aggregate_non_question_tags id label tag_list = - if not (Norm.is_question_specific_tag label) then - (id, label) :: tag_list - else tag_list in - let tags_dyn_val = - let raw_tags = Hashtbl.fold aggregate_non_question_tags tags [] in - let sorted = List.sort (fun (_, l1) (_, l2) -> compare l1 l2) raw_tags in - List.map (fun (id, label) -> - (string_of_int id, Printf.sprintf "%s" label)) sorted in - browse_object#set_variable "tags" (Dyn_enum_value tags_dyn_val); - tags -@ - -Helper function [[fill_question_area]] selects the questions having the -chosen tag. Moreover, if one of them is selected, it displays this -question details. - -<>= -let fill_question_area browse_object tags client cookie cache = - (* get maximum question number *) - let ret = Demexp.V1.max_question_id client cookie in - if ret.max_question_id_rc <> rt_ok then - raise (Misc.Display_error - (Printf.sprintf "unable to get max_question_id (%s)" - (Misc.string_of_return_code ret.max_question_id_rc))); - (* get classification *) - let questions = Hashtbl.create 3 in - Cache.update_questions_hash - questions ret.max_question_id client cookie cache; - try - let chosen_tag = - int_of_string (browse_object#string_variable "session.selected-tag") in - let select_question id (desc, tags) selection = - if List.exists (fun tag_id -> tag_id = chosen_tag) tags then - (string_of_int id, desc) :: selection - else - selection in - let selected_questions = Hashtbl.fold select_question questions [] in - browse_object#set_variable "questions" - (Dyn_enum_value selected_questions); - - (* fill the question details *) - try - let q_id = int_of_string (browse_object#string_variable - "session.selected-question") in - let ret = Cache.question_info cache client (cookie, q_id, 1) in - if ret.question_info_rc <> rt_ok then - raise (Misc.Display_error - (Printf.sprintf - "Unable to load information on question:%d : %s" - q_id (Misc.string_of_return_code ret.question_info_rc))) - else if Array.length ret.question_info <> 1 then - raise (Misc.Display_error - (Printf.sprintf - "Invalid array length for question_info:%d : %d" - q_id (Array.length ret.question_info))) - else ( - (* question descriptor *) - browse_object#set_variable "title" - (String_value ret.question_info.(0).q_desc); - (* limit date *) - let limit_date = - match ret.question_info.(0).q_info_limit_date with - | x when x = Int64.zero -> "no limit date" - | x -> (* transform limit date in local time *) - let offset = Int64.to_float x in - Time.time_as_localtime_iso_string offset in - browse_object#set_variable "limit-date" (String_value limit_date); - (* tags *) - let _, q_tags = Hashtbl.find questions q_id in - let q_label_tags = List.map (fun id -> Hashtbl.find tags id) q_tags in - let str = - List.fold_left (fun str e -> str ^ e ^ " - ") - " - " q_label_tags in - browse_object#set_variable "question-tags" (String_value str); - (* responses *) - let make_url link = - "" ^ link ^ "" in - let string_of_response i r = - let link = - if r.r_info_link <> "" then ("[" ^ (make_url r.r_info_link) ^ "]") - else "" in - (string_of_int i, - Printf.sprintf "%d. %s %s\n" i r.r_info_desc link) in - let str_responses = - Array.to_list (Array.mapi string_of_response - ret.question_info.(0).q_info_responses) in - browse_object#set_variable "responses" (Dyn_enum_value str_responses); - (* number of votes *) - browse_object#set_variable "number-of-votes" - (String_value - (string_of_int ret.question_info.(0).q_info_num_votes)); - (* winning response(s) *) - let response_desc r_id = - let desc = - ret.question_info.(0).q_info_responses.(r_id).r_info_desc in - Printf.sprintf "%d. %s" r_id desc in - let str = - Array.fold_left - (fun str r_id -> str ^ (response_desc r_id) ^ ". ") "" - ret.question_info.(0).q_info_elected_responses in - browse_object#set_variable "winning-responses" (String_value str) - ) - with Failure("int_of_string") -> () - with - Failure("int_of_string") -> () - | Misc.Display_error str -> Session.display_error_message browse_object str -@ - -Helper function [[setup_dialog]] is used to prepare the browse dialog -contained in [[browse_object]]. - -\nextchunklabel{code:browse.ml:setup_dialog} -<>= -let setup_dialog browse_object = - let client, cookie = Session.connect_to_server browse_object in - - let cache = Cache.create ServerConnection.cache_filename client cookie in - - let tags = fill_tag_selector browse_object client cookie cache in - fill_question_area browse_object tags client cookie cache; - - Cache.save cache; - - ServerConnection.close_connection_to_server client cookie; - - browse_object#set_variable "lang" - (String_value (browse_object#string_variable "session.lang")) -@ - -The [[browse]] class defines handling of events for the [[browse]] dialog. - -<>= -class browse universe name env = - object (self) - inherit dialog universe name env - - method prepare_page() = setup_dialog self - - method handle() = - match self#event with - | Button("reset") -> - self#set_variable "session.selected-tag" (String_value ""); - self#set_variable "questions" (Dyn_enum_value []); - self#set_variable "session.selected-question" (String_value "") - - | Button("new_question") -> - let session = self#dialog_variable "session" in - let new_dlg = - !Registry.new_add_question universe env session in - raise(Change_dialog new_dlg) - - | Button("get-questions") -> - self#set_variable "session.selected-question" (String_value "") - - | Button("add_response") -> - let session = self#dialog_variable "session" in - let new_dlg = - !Registry.new_add_response universe env session - (self#variable "title") (self#variable "responses") in - raise(Change_dialog new_dlg) - - | Button("logout") -> - let new_dlg = !Registry.new_login universe env in - raise(Change_dialog new_dlg) - - | Button("vote_on_question") -> - let session = self#dialog_variable "session" in - let new_dlg = - !Registry.new_vote universe env session - (self#variable "title") in - raise(Change_dialog new_dlg) - - | _ -> - () - end -@ - - -At module start, we register creation function into the Registry. - -<>= -let _ = - Registry.new_browse := - fun universe env session -> - let dlg = universe#create env "browse" in - dlg#set_variable "session" (Dialog_value session); - dlg -@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/login.ml.nw --- a/web/login.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -\section{login backend code} - -<>= -(* copyright 2005-2006 David MENTRE *) -(* this software is under GNU GPL. See COPYING.GPL file for details *) - -open Wd_dialog -open Wd_types -open ServerConnection -@ - -Class [[login]] connects to the server and checks the given login is -valid. If not, we stay on the same dialog, otherwise we go to browsing -dialog. - -\fixme{RPC errors are not handled.} - -\nextchunklabel{code:login.ml:login} -<>= -class login universe name env = - object (self) - inherit dialog universe name env - - method prepare_page() = - let session = new Session.session universe "session" env in - self#set_variable "session" (Dialog_value (Some session)); - (* get requested lang and set it for the session and current dialog *) - let lang = env.cgi#argument_value ~default:"en" "lang" in - self#set_variable "lang" (String_value lang); - self#set_variable "session.lang" (String_value lang) - - method handle() = - let switch_to_browse_dialog client cookie = - close_connection_to_server client cookie; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) in - - match self # event with - Button("login") -> - (try - let login = self#string_variable "session.login" - and password = self#string_variable "session.password" in - let client, cookie = - login_on_server web_default_server web_default_port - login password in - (* no exception raised until here, login has succeeded *) - switch_to_browse_dialog client cookie - with - | Change_dialog d -> - raise (Change_dialog d) - | Change_page p -> - raise (Change_page p) - | Protocol_warning (_, client, cookie) -> - (* todo: we don't display warning message. We should show it *) - switch_to_browse_dialog client cookie - | Login_error (msg, client, cookie) -> - self#set_variable "session.error-message" (String_value msg); - close_connection_to_server client cookie; - raise(Change_page "login-page") - | other_exception -> - let msg = - Printf.sprintf "Unknown error message (%s). Please report it to address@hidden" - (Printexc.to_string other_exception) in - self#set_variable "session.error-message" (String_value msg); - raise(Change_page "login-page") - ) - - | _ -> - () - end -@ - -At module start, we register creation function into the Registry. - -<>= -let _ = - Registry.new_login := - fun universe env -> - let dlg = universe#create env "login" in - dlg -@ - -\section{Setting of session language} - -In order to handle translation of dialogs, each dialog has a [[lang]] -variable defined as [[lang-variable]] in the [[]] tag (see -\codechunkref{code:login.ui:login}). Its value is set at dialog setup -time in the [[prepare_page]] method by reading a session wide -[[session.lang]] variable (see for example -\codechunkref{code:browse.ml:setup_dialog}). - -The value of [[session.lang]] variable is set in the login dialog, by -reading the value of [[?lang=]] CGI parameter (see -\codechunkref{code:login.ml:login}). - diff -r eb62ed1a54f1 -r a66569eaf6b1 web/registry.ml.nw --- a/web/registry.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -\chapter{\texttt{Registry} module} - -Module [[Registry]] is a simple stub code to store a creation function -for each dialog. Its purpose is to break circular dependencies between -modules defining each dialog. Each creation function is stored in -[[Registry]] at the end of each module containing the code of the -corresponding dialog. - -<>= -open Wd_types - -let new_session = - ref (fun _ _ -> assert false - : universe_type -> environment -> dialog_type) - -let new_login = - ref (fun _ _ -> assert false - : universe_type -> environment -> dialog_type) - -let new_browse = - ref (fun _ _ _ -> assert false - : universe_type -> environment -> dialog_type option -> dialog_type) - -let new_vote = - ref (fun _ _ _ -> assert false - : universe_type -> environment -> dialog_type option - -> var_value -> dialog_type) - -let new_add_response = - ref (fun _ _ _ _ _ -> assert false - : universe_type -> environment -> dialog_type option - -> var_value -> var_value -> dialog_type) - -let new_add_question = - ref (fun _ _ _ -> assert false - : universe_type -> environment -> dialog_type option -> dialog_type) - -@ - diff -r eb62ed1a54f1 -r a66569eaf6b1 web/session.ml.nw --- a/web/session.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -\section{session backend code} - -<>= -(* copyright 2005 David MENTRE *) -(* this software is under GNU GPL. See COPYING.GPL file for details *) - -open Wd_dialog -open Wd_types -open ServerConnection -@ - - -Function [[display_error_message]] update the [[session.error-message]] -variable of dialog [[dialog_obj]] with [[str]] message. - -<>= -let display_error_message dialog_obj str = - dialog_obj#set_variable "session.error-message" (String_value str) -@ - -Helper function [[connect_to_server]] opens a new connection to the -server and login onto it, using current session login and password. It -returns client and cookie identifiying the connection. - -<>= -let connect_to_server dialog_object = - let login = dialog_object#string_variable "session.login" - and password = dialog_object#string_variable "session.password" in - login_on_server web_default_server web_default_port login password -@ - -The session backend code does nothing except creation of [[session]] -dialog. - -<>= -class session universe name env = - object (self) - inherit dialog universe name env - - method prepare_page () = () - - method handle () = () - end - -let _ = - Registry.new_session := - fun universe env -> - universe#create env "session" -@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/session.ui.nw --- a/web/session.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -\chapter{\texttt{session} dialog} - -The [[session]] dialogs contains the variables used by all other -dialogs. It allows to have persistency of the state between the dialogs. - -\section{\texttt{session} dialog definition} - -<>= - - -@ - -The [[display-a-response]] template is used to print one question's -response. It is used when displaying the set of responses to a -question. - -The [[ui:special]] tag is used in the [[display-a-response]] template so -that generated hyperlinks are not escaped. - -\nextchunklabel{code:template-display-a-reponse} -<>= - - -

  • $ext
    • - - -@ - -Template [[display-error]] is used to display the -[[session.error-message]] at the top of each web page of the web -interface. - -<>= - - - - Error: - - - -@ - -Template [[make-hyperlink]] prints the hyperlink [[href]] and made it -clickable. - -<>= - - $href - -@ - -We finally define the session variables themselves. - -<>= - - - - - - - - - - - demo - - - - demo - - - - - - - - - - - - - - - -@ - diff -r eb62ed1a54f1 -r a66569eaf6b1 web/voteWeb.ml.nw --- a/web/voteWeb.ml.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,197 +0,0 @@ -\section{[[voteWeb]] backend code} - -<>= -(* copyright 2005-2006 David MENTRE *) -(* this software is under GNU GPL. See COPYING.GPL file for details *) - -open Wd_dialog -open Wd_types -open Messages_aux -open Messages_clnt -@ - -Function [[initialize_selectors]] is called systematically at each -dialog creation. If both the selectors of available and chosen answers -are empty then the dialog has never been initialized. In that case, the -set of available answers and the user vote are drawn from the server and -the selectors are initialized accordingly. - -<>= -let initialize_selectors vote_obj = - let available = vote_obj#dyn_enum_variable "available" in - let chosen = vote_obj#dyn_enum_variable "chosen" in - if available = [] && chosen = [] then ( - (* dialog never initialized, so do it now *) - let client, cookie = Session.connect_to_server vote_obj in - try - let cache = Cache.create ServerConnection.cache_filename client cookie in - let q_id = int_of_string (vote_obj#string_variable - "session.selected-question") in - let ret = Cache.question_info cache client (cookie, q_id, 1) in - if ret.question_info_rc <> rt_ok then - raise (Misc.Display_error - (Printf.sprintf - "Unable to load information on question:%d : %s" - q_id (Misc.string_of_return_code ret.question_info_rc))) - else if Array.length ret.question_info <> 1 then - raise (Misc.Display_error - (Printf.sprintf - "Invalid array length for question_info:%d : %d" - q_id (Array.length ret.question_info))); - (* we have information about our question, so now get our vote *) - let login = vote_obj#string_variable "session.login" in - let vote = Demexp.V1.get_vote client (cookie, q_id, login) in - if vote.get_vote_rc <> rt_ok then - raise (Misc.Display_error - (Printf.sprintf "Cannot get my own vote. Error: %s" - (Misc.string_of_return_code vote.get_vote_rc))); - let my_vote = Array.to_list vote.get_vote in - let q_responses = - Array.to_list (Array.mapi (fun i r -> (i, r.r_info_desc)) - ret.question_info.(0).q_info_responses) in - let my_vote_with_desc, others_with_desc = - Misc.split_responses my_vote q_responses in - let string_id (id, desc) = (string_of_int id, desc) in - vote_obj#set_variable "available" - (Dyn_enum_value (List.map string_id others_with_desc)); - vote_obj#set_variable "chosen" - (Dyn_enum_value (List.map string_id my_vote_with_desc)); - ServerConnection.close_connection_to_server client cookie - with Misc.Display_error str -> - Session.display_error_message vote_obj str; - ServerConnection.close_connection_to_server client cookie - ) -@ - -Function [[up_selected_item]] moves the selected item in the vote -selector one item up. - -<>= -let up_selected_item vote_obj = - let selected_id = vote_obj#string_variable "selected-chosen" in - let chosen = vote_obj#dyn_enum_variable "chosen" in - let rec move_up_selected selected_id previous remaining = - match remaining with - | [] -> previous - | item :: (id, desc) :: tail when id = selected_id -> - previous @ ((id, desc) :: item :: tail) - | item :: tail -> - move_up_selected selected_id (previous @ [item]) tail in - vote_obj#set_variable "chosen" - (Dyn_enum_value (move_up_selected selected_id [] chosen)) -@ - -Function [[down_selected_item]] moves the selected item in the vote -selector one item down. - -<>= -let down_selected_item vote_obj = - let selected_id = vote_obj#string_variable "selected-chosen" in - let chosen = vote_obj#dyn_enum_variable "chosen" in - let rec move_down_selected selected_id previous remaining = - match remaining with - | [] -> previous - | (id, desc) :: item :: tail when id = selected_id -> - previous @ (item :: (id, desc) :: tail) - | item :: tail -> - move_down_selected selected_id (previous @ [item]) tail in - vote_obj#set_variable "chosen" - (Dyn_enum_value (move_down_selected selected_id [] chosen)) -@ - -Function [[move_from_a_to_b]] moves selected [[item]] from selector -[[a]] to selector [[b]]. - -<>= -let move_from_a_to_b vote_obj ~item ~a ~b = - let selected_id = vote_obj#string_variable item in - let a_items = vote_obj#dyn_enum_variable a in - let b_items = vote_obj#dyn_enum_variable b in - let removed, new_a_items = - List.partition (fun (id, desc) -> id = selected_id) a_items in - vote_obj#set_variable a (Dyn_enum_value new_a_items); - vote_obj#set_variable b (Dyn_enum_value (b_items @ removed)) -@ - -Function [[do_vote]] get the vote from the [[chosen]] selector and send -it to the server. It invalidates the cache entry to take into account -the new vote. - -<>= -let do_vote vote_obj = - let chosen_items = vote_obj#dyn_enum_variable "chosen" in - let vote = List.map (fun (id, _) -> int_of_string id) chosen_items in - let client, cookie = Session.connect_to_server vote_obj in - try - let cache = Cache.create ServerConnection.cache_filename client cookie in - let q_id = int_of_string (vote_obj#string_variable - "session.selected-question") in - let ret = Demexp.V1.vote client (cookie, q_id, Array.of_list vote) in - if ret <> rt_ok then - raise (Misc.Display_error - (Printf.sprintf - "Vote as user failed on question #%d. Error: %s." - q_id (Misc.string_of_return_code ret))); - Cache.invalidate cache (Cache.Question q_id); - Cache.save cache; - ServerConnection.close_connection_to_server client cookie - with Misc.Display_error msg -> - Session.display_error_message vote_obj msg; - ServerConnection.close_connection_to_server client cookie -@ - -Class [[vote]] handles event dispatch. - -<>= -class vote universe name env = - object (self) - inherit dialog universe name env - - method prepare_page() = - self#set_variable "lang" - (String_value (self#string_variable "session.lang")); - initialize_selectors self - - method handle() = - match self#event with - | Button("cancel_vote") -> - Session.display_error_message self ""; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) - - | Button("to_chosen") -> - move_from_a_to_b self - ~item:"selected-available" ~a:"available" ~b:"chosen" - - | Button("to_available") -> - move_from_a_to_b self - ~item:"selected-chosen" ~a:"chosen" ~b:"available" - - | Button("preferred") -> up_selected_item self - - | Button("disliked") -> down_selected_item self - - | Button("do_vote") -> - do_vote self; - let session = self#dialog_variable "session" in - let new_dlg = !Registry.new_browse universe env session in - raise(Change_dialog new_dlg) - - | _ -> - () - end -@ - -At module start, we register creation function into the Registry. - -\nextchunklabel{code:voteWeb.ml:registering} -<>= -let _ = - Registry.new_vote := - fun universe env session title -> - let dlg = universe#create env "vote" in - dlg#set_variable "session" (Dialog_value session); - dlg#set_variable "title" title; - dlg -@ diff -r eb62ed1a54f1 -r a66569eaf6b1 web/voteWeb.ui.nw --- a/web/voteWeb.ui.nw Sun Oct 01 17:31:20 2006 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -\chapter{\texttt{voteWeb} dialog} - - -\section{\texttt{voteWeb} dialog definition} - -<>= - - -@ - -The variable [[title]] stores the description of question we are voting -on. Its content is set at dialog creation (cf. -\codechunkref{code:voteWeb.ml:registering}). - -The four remaining variables are used to handle the two selection boxes. -[[available]] and [[chosen]] contain the available and chosen choices, -[[selected-available]] and [[selected-chosen]] contain the user -selection in those selectors. - - -<>= - - - - - - - - - - - - - -@ - -<>= - - - - - - Vote on question - (#<ui:dynamic variable="session.selected-question"/>) - <ui:dynamic variable="title"/> - - - - -

    - Vote on question - (#) - -

    - - - - - -

    - Available responses:
    - - -

    - -

    - Your vote:
    - - - - -

    - -

    - - -

    - -     - - -     - -     -@ -