3 * Stefano Zacchiroli <zack@cs.unibo.it>
4 * for the HELM Team http://helm.cs.unibo.it/
6 * This file is part of HELM, an Hypertextual, Electronic
7 * Library of Mathematics, developed at the Computer Science
8 * Department, University of Bologna, Italy.
10 * HELM is free software; you can redistribute it and/or
11 * modify it under the terms of the GNU General Public License
12 * as published by the Free Software Foundation; either version 2
13 * of the License, or (at your option) any later version.
15 * HELM is distributed in the hope that it will be useful,
16 * but WITHOUT ANY WARRANTY; without even the implied warranty of
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 * GNU General Public License for more details.
20 * You should have received a copy of the GNU General Public License
21 * along with HELM; if not, write to the Free Software
22 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
25 * For details, see the HELM World-Wide-Web page,
26 * http://helm.cs.unibo.it/
33 exception Invalid_URL of string;;
35 let do_nothing _ = ();;
37 module SmartHbugs_client_gui =
39 class ['a] oneColumnCList gtree_view ~column_type ~column_title
42 ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in
43 let columns = new GTree.column_list in
44 let col = columns#add column_type in
45 let vcol = GTree.view_column ~title:column_title ()
46 ~renderer:(GTree.cell_renderer_text[], ["text",col]) in
47 let store = GTree.list_store columns in
49 inherit GTree.view obj
50 method clear = store#clear
51 method append (v : 'a) =
52 let row = store#append () in
53 store#set ~row ~column:col v;
56 self#set_model (Some (store :> GTree.model)) ;
57 ignore (self#append_column vcol)
60 class ['a,'b] twoColumnsCList gtree_view ~column1_type ~column2_type
61 ~column1_title ~column2_title
64 ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in
65 let columns = new GTree.column_list in
66 let col1 = columns#add column1_type in
67 let vcol1 = GTree.view_column ~title:column1_title ()
68 ~renderer:(GTree.cell_renderer_text[], ["text",col1]) in
69 let col2 = columns#add column2_type in
70 let vcol2 = GTree.view_column ~title:column2_title ()
71 ~renderer:(GTree.cell_renderer_text[], ["text",col2]) in
72 let store = GTree.list_store columns in
74 inherit GTree.view obj
75 method clear = store#clear
76 method append (v1 : 'a) (v2 : 'b) =
77 let row = store#append () in
78 store#set ~row ~column:col1 v1;
79 store#set ~row ~column:col2 v2
83 self#set_model (Some (store :> GTree.model)) ;
84 ignore (self#append_column vcol1) ;
85 ignore (self#append_column vcol2) ;
88 class subscribeWindow () =
90 inherit Hbugs_client_gui.subscribeWindow ()
91 val mutable tutorsSmartCList = None
92 method tutorsSmartCList =
93 match tutorsSmartCList with
99 (new twoColumnsCList self#tutorsCList
100 ~column1_type:Gobject.Data.string ~column2_type:Gobject.Data.string
101 ~column1_title:"Id" ~column2_title:"Description")
104 class hbugsMainWindow () =
106 inherit Hbugs_client_gui.hbugsMainWindow ()
107 val mutable subscriptionSmartCList = None
108 val mutable hintsSmartCList = None
109 method subscriptionSmartCList =
110 match subscriptionSmartCList with
113 method hintsSmartCList =
114 match hintsSmartCList with
118 subscriptionSmartCList <-
120 (new oneColumnCList self#subscriptionCList
121 ~column_type:Gobject.Data.string ~column_title:"Description")
125 (new oneColumnCList self#hintsCList
126 ~column_type:Gobject.Data.string ~column_title:"Description")
133 ?(use_hint_callback: hint -> unit = do_nothing)
134 ?(describe_hint_callback: hint -> unit = do_nothing)
135 ?(destroy_callback: unit -> unit = do_nothing)
139 let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
140 let port_of_http_url url =
142 let subs = Pcre.extract ~rex:http_url_RE url in
143 int_of_string subs.(3)
144 with e -> raise (Invalid_URL url)
149 val mainWindow = new SmartHbugs_client_gui.hbugsMainWindow ()
150 val subscribeWindow = new SmartHbugs_client_gui.subscribeWindow ()
151 val messageDialog = new Hbugs_client_gui.messageDialog ()
152 val myOwnId = Hbugs_id_generator.new_client_id ()
153 val mutable use_hint_callback = use_hint_callback
154 val mutable myOwnUrl = "localhost:49082"
155 val mutable brokerUrl = "localhost:49081"
156 val mutable brokerId: broker_id option = None
157 (* all available tutors, saved last time a List_tutors message was sent to
159 val mutable availableTutors: tutor_dsc list = []
160 val mutable statusContext = None
161 val mutable subscribeWindowStatusContext = None
162 val mutable debug = false (* enable/disable debugging buttons *)
163 val mutable hints = [] (* actually available hints *)
167 self#startLocalHttpDaemon ();
168 self#testLocalHttpDaemon ();
170 self#registerToBroker ();
171 self#reconfigDebuggingButtons
173 method show = mainWindow#hbugsMainWindow#show
174 method hide = mainWindow#hbugsMainWindow#misc#hide
176 method setUseHintCallback callback =
177 use_hint_callback <- callback
179 method private debugButtons =
181 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
182 [ mainWindow#startLocalHttpDaemonButton;
183 mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ]
185 method private initGui =
187 (* GUI: main window *)
189 (* ignore delete events so that hbugs window is closable only using
190 menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked
193 ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true));
194 ignore (mainWindow#hbugsMainWindow#event#connect#destroy
195 (fun _ -> self#quit (); false));
197 (* GUI main window's menu *)
198 mainWindow#toggleDebuggingMenuItem#set_active debug;
199 ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
202 (* GUI: local HTTP daemon settings *)
203 ignore (mainWindow#clientUrlEntry#connect#changed
204 (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
205 mainWindow#clientUrlEntry#set_text myOwnUrl;
206 ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
207 self#startLocalHttpDaemon);
208 ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
209 self#testLocalHttpDaemon);
211 (* GUI: broker choice *)
212 ignore (mainWindow#brokerUrlEntry#connect#changed
213 (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
214 mainWindow#brokerUrlEntry#set_text brokerUrl;
215 ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
216 mainWindow#clientIdLabel#set_text myOwnId;
218 (* GUI: client registration *)
219 ignore (mainWindow#registerClientButton#connect#clicked
220 self#registerToBroker);
222 (* GUI: subscriptions *)
223 ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
226 subscribeWindow#subscribeWindow#show ()));
228 (* GUI: hints list *)
229 ignore (mainWindow#hintsCList#selection#set_select_function
230 (fun path already_selected ->
232 prerr_endline ("**** BEFORE CRASH: " ^ if already_selected then "yes" else "no") ;
233 match GTree.Path.get_indices path with
237 prerr_endline ("**** AFTER CRASH: " ^ string_of_int row) ;
238 (*CSC: there used to be an event whose type was checked against *)
239 (*CSC: `TWO_BUTTON_PRESS. This is just a bad approximation. *)
240 if already_selected then
241 use_hint_callback (self#hint row)
243 describe_hint_callback (self#hint row) ;
246 (* GUI: main status bar *)
247 let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
248 statusContext <- Some ctxt;
249 ignore (ctxt#push "Ready");
251 (* GUI: subscription window *)
252 subscribeWindow#tutorsCList#selection#set_mode `MULTIPLE;
253 ignore (subscribeWindow#subscribeWindow#event#connect#delete
254 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
255 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
256 ignore (subscribeWindow#subscribeButton#connect#clicked
257 self#subscribeSelected);
258 ignore (subscribeWindow#subscribeAllButton#connect#clicked
260 (subscribeWindow#tutorsCList#get_column 0)#set_visible false;
261 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
262 subscribeWindowStatusContext <- Some ctxt;
263 ignore (ctxt#push "Ready");
265 (* GUI: message dialog *)
266 ignore (messageDialog#messageDialog#event#connect#delete
267 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
268 ignore (messageDialog#okDialogButton#connect#clicked
269 (fun _ -> messageDialog#messageDialog#misc#hide ()))
271 (* accessory methods *)
273 (** pop up a (modal) dialog window showing msg to the user *)
274 method private showDialog msg =
275 messageDialog#dialogLabel#set_text msg;
276 messageDialog#messageDialog#show ()
277 (** use showDialog to display an hbugs message to the user *)
278 method private showMsgInDialog msg =
279 self#showDialog (Hbugs_messages.string_of_msg msg)
281 (** create a new thread which sends msg to broker, wait for an answer and
282 invoke callback passing response message as argument *)
283 method private sendReq ?(wait = false) ~msg callback =
286 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
288 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
291 "Parse_error, unable to fullfill request. Details follow.
294 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
295 | (Unix.Unix_error _) as e ->
298 "Can't connect to HBugs Broker
301 brokerUrl (Printexc.to_string e))
304 (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
305 (Printexc.to_string e))
307 let th = Thread.create thread () in
312 (** check if a broker is authenticated using its broker_id
313 [ Background: during client registration, client save broker_id of its
314 broker, further messages from broker are accepted only if they carry the
316 method private isAuthenticated id =
319 | Some broker_id -> (id = broker_id)
323 method private startLocalHttpDaemon =
324 (* flatten an hint tree to an hint list *)
325 let rec flatten_hint = function
326 | Hints hints -> List.concat (List.map flatten_hint hints)
330 let callback req outchan =
332 (match Hbugs_messages.msg_of_string req#body with
334 Hbugs_messages.respond_msg
335 (Usage "Local Http Daemon up and running!") outchan
336 | Hint (broker_id, hint) ->
337 if self#isAuthenticated broker_id then begin
338 let received_hints = flatten_hint hint in
341 (match h with Hints _ -> assert false | _ -> ());
342 ignore(mainWindow#hintsSmartCList#append(string_of_hint h)))
344 hints <- hints @ received_hints;
345 Hbugs_messages.respond_msg (Wow myOwnId) outchan
346 end else (* msg from unauthorized broker *)
347 Hbugs_messages.respond_exc "forbidden" broker_id outchan
349 Hbugs_messages.respond_exc
350 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
351 with (Hbugs_messages.Parse_error _) as e ->
352 Hbugs_messages.respond_exc
353 "parse_error" (Printexc.to_string e) outchan
355 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
356 only as a value to be sent to broker, local HTTP
357 daemon will listen on "0.0.0.0", port is parsed
358 from My URL though *)
359 let httpDaemonThread () =
362 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
364 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
366 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
367 (Printexc.to_string e))
369 ignore (Thread.create httpDaemonThread ())
371 method private testLocalHttpDaemon () =
374 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
378 (* self#showDialog msg *)
380 | Hbugs_misc.Malformed_URL url ->
383 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
385 | Hbugs_misc.Malformed_HTTP_response res ->
388 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
390 | (Unix.Unix_error _) as e ->
393 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
394 (Printexc.to_string e))
396 method private testBroker () =
397 self#sendReq ~msg:Help
403 "Handshake with HBugs Broker failed, unexpected message:\n%s"
404 (Hbugs_messages.string_of_msg unexpected_msg)))
406 method registerToBroker () =
407 (match brokerId with (* undo previous registration, if any *)
408 | Some id -> self#unregisterFromBroker ()
410 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
412 | Client_registered broker_id -> (brokerId <- Some broker_id)
415 (sprintf "Client NOT registered, unexpected message:\n%s"
416 (Hbugs_messages.string_of_msg unexpected_msg)))
418 method unregisterFromBroker () =
419 self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
421 | Client_unregistered _ -> (brokerId <- None)
422 | unexpected_msg -> ())
425 (sprintf "Client NOT unregistered, unexpected message:\n%s"
426 (Hbugs_messages.string_of_msg unexpected_msg)))
429 method stateChange new_state =
430 mainWindow#hintsSmartCList#clear ();
433 ~msg:(State_change (myOwnId, new_state))
435 | State_accepted _ -> ()
438 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
439 (Hbugs_messages.string_of_msg unexpected_msg)))
441 method hint = List.nth hints
443 method private listTutors () =
444 (* wait is set to true just to make sure that after invoking listTutors
445 "availableTutors" is correctly filled *)
446 self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
448 | Tutor_list (_, descriptions) ->
449 availableTutors <- (* sort accordingly to tutor description *)
450 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
451 subscribeWindow#tutorsSmartCList#clear ();
454 ignore (subscribeWindow#tutorsSmartCList#append id dsc))
458 (sprintf "Can't list tutors, unexpected message:\n%s"
459 (Hbugs_messages.string_of_msg unexpected_msg)))
461 (* low level used by subscribeSelected and subscribeAll *)
462 method private subscribe' tutors_id =
463 self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
465 | (Subscribed (_, subscribedTutors)) as msg ->
466 let sort = List.sort compare in
467 mainWindow#subscriptionSmartCList#clear ();
471 (mainWindow#subscriptionSmartCList#append
473 List.assoc tutor_id availableTutors
474 with Not_found -> assert false )))
476 subscribeWindow#subscribeWindow#misc#hide ();
477 if sort subscribedTutors <> sort tutors_id then
479 (sprintf "Subscription mismatch\n: %s"
480 (Hbugs_messages.string_of_msg msg))
482 mainWindow#subscriptionSmartCList#clear ();
484 (sprintf "Subscription FAILED, unexpected message:\n%s"
485 (Hbugs_messages.string_of_msg unexpected_msg)))
487 method private subscribeSelected () =
488 let tutorsSmartCList = subscribeWindow#tutorsSmartCList in
492 tutorsSmartCList#model#get
493 ~row:(tutorsSmartCList#model#get_iter p)
494 ~column:tutorsSmartCList#column1)
495 tutorsSmartCList#selection#get_selected_rows
497 self#subscribe' selectedTutors
499 method subscribeAll () =
500 self#listTutors (); (* this fills 'availableTutors' field *)
501 self#subscribe' (List.map fst availableTutors)
503 method private quit () =
504 self#unregisterFromBroker ();
507 (** enable/disable debugging *)
508 method private setDebug value = debug <- value
510 method private reconfigDebuggingButtons =
511 List.iter (* debug value changed, reconfigure buttons *)
512 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
515 method private toggleDebug () =
516 self#setDebug (not debug);
517 self#reconfigDebuggingButtons