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 global_debug = true;;
37 let do_nothing _ = ();;
40 @param on_use_hint function invoked when an hint is used, argumnet is the hint
42 @param on_exit function invoked when client is exiting (e.g. window is
43 destroyed, if it's None "self#quit" is invoked
46 ?(use_hint_callback: hint -> unit = do_nothing)
47 ?(destroy_callback: unit -> unit = do_nothing)
51 let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
52 let port_of_http_url url =
54 let subs = Pcre.extract ~rex:http_url_RE url in
55 int_of_string subs.(3)
56 with e -> raise (Invalid_URL url)
61 val mainWindow = new Hbugs_client_gui.hbugsMainWindow ()
62 val subscribeWindow = new Hbugs_client_gui.subscribeWindow ()
63 val messageDialog = new Hbugs_client_gui.messageDialog ()
64 val myOwnId = Hbugs_id_generator.new_client_id ()
65 val mutable use_hint_callback = use_hint_callback
66 val mutable myOwnUrl = "localhost:49082"
67 val mutable brokerUrl = "localhost:49081"
68 val mutable brokerId: broker_id option = None
69 (* all available tutors, saved last time a List_tutors message was sent to
71 val mutable availableTutors: tutor_dsc list = []
72 (* id of highlighted tutors in tutor subscription window *)
73 val mutable selectedTutors: tutor_id list = []
74 val mutable statusContext = None
75 val mutable subscribeWindowStatusContext = None
76 val mutable debug = false (* enable/disable debugging buttons *)
77 val mutable hints = [] (* actually available hints *)
81 self#startLocalHttpDaemon ();
82 self#testLocalHttpDaemon ();
84 self#registerToBroker ();
85 self#reconfigDebuggingButtons
87 method show = mainWindow#hbugsMainWindow#show
88 method hide = mainWindow#hbugsMainWindow#misc#hide
90 method setUseHintCallback callback =
91 use_hint_callback <- callback
93 method private debugButtons =
95 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
96 [ mainWindow#startLocalHttpDaemonButton;
97 mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton;
98 mainWindow#registerClientButton; mainWindow#unregisterClientButton ]
100 method private initGui =
102 (* GUI: main window *)
104 (* ignore delete events so that hbugs window is closable only using
105 menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked
108 ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true));
109 ignore (mainWindow#hbugsMainWindow#event#connect#destroy
110 (fun _ -> self#quit (); false));
112 (* GUI main window's menu *)
113 mainWindow#toggleDebuggingMenuItem#set_active debug;
114 ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
117 (* GUI: local HTTP daemon settings *)
118 ignore (mainWindow#clientUrlEntry#connect#changed
119 (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
120 mainWindow#clientUrlEntry#set_text myOwnUrl;
121 ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
122 self#startLocalHttpDaemon);
123 ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
124 self#testLocalHttpDaemon);
126 (* GUI: broker choice *)
127 ignore (mainWindow#brokerUrlEntry#connect#changed
128 (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
129 mainWindow#brokerUrlEntry#set_text brokerUrl;
130 ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
131 mainWindow#clientIdLabel#set_text myOwnId;
133 (* GUI: client registration *)
134 ignore (mainWindow#registerClientButton#connect#clicked
135 self#registerToBroker);
136 ignore (mainWindow#unregisterClientButton#connect#clicked
137 self#unregisterFromBroker);
139 (* GUI: subscriptions *)
140 ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
143 subscribeWindow#subscribeWindow#show ()));
145 (* GUI: hints list *)
146 ignore (mainWindow#hintsCList#connect#select_row
147 (fun ~row ~column ~event ->
149 | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS ->
150 use_hint_callback (self#hint row)
153 (* GUI: main status bar *)
154 let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
155 statusContext <- Some ctxt;
156 ignore (ctxt#push "Ready");
158 (* GUI: subscription window *)
159 ignore (subscribeWindow#subscribeWindow#event#connect#delete
160 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
161 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
162 let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
163 ignore (subscribeWindow#tutorsCList#connect#select_row
164 (fun ~row ~column ~event ->
165 selectedTutors <- tutor_id_of_row row :: selectedTutors));
166 ignore (subscribeWindow#tutorsCList#connect#unselect_row
167 (fun ~row ~column ~event ->
169 List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
170 ignore (subscribeWindow#subscribeButton#connect#clicked
171 self#subscribeSelected);
172 ignore (subscribeWindow#subscribeAllButton#connect#clicked
174 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
175 subscribeWindowStatusContext <- Some ctxt;
176 ignore (ctxt#push "Ready");
178 (* GUI: message dialog *)
179 ignore (messageDialog#messageDialog#event#connect#delete
180 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
181 ignore (messageDialog#okDialogButton#connect#clicked
182 (fun _ -> messageDialog#messageDialog#misc#hide ()))
184 (* accessory methods *)
186 (** pop up a (modal) dialog window showing msg to the user *)
187 method private showDialog msg =
188 messageDialog#dialogLabel#set_text msg;
189 messageDialog#messageDialog#show ()
190 (** use showDialog to display an hbugs message to the user *)
191 method private showMsgInDialog msg =
192 self#showDialog (Hbugs_messages.string_of_msg msg)
194 (** create a new thread which sends msg to broker, wait for an answer and
195 invoke callback passing response message as argument *)
196 method private sendReq ?(wait = false) ~msg callback =
199 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
201 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
204 "Parse_error, unable to fullfill request. Details follow.
207 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
208 | (Unix.Unix_error _) as e ->
211 "Can't connect to HBugs Broker
214 brokerUrl (Printexc.to_string e))
217 (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
218 (Printexc.to_string e))
220 let th = Thread.create thread () in
225 (** check if a broker is authenticated using its broker_id
226 [ Background: during client registration, client save broker_id of its
227 broker, further messages from broker are accepted only if they carry the
229 method private isAuthenticated id =
232 | Some broker_id -> (id = broker_id)
236 method private startLocalHttpDaemon =
237 (* flatten an hint tree to an hint list *)
238 let rec flatten_hint = function
239 | Hints hints -> List.concat (List.map flatten_hint hints)
243 let callback req outchan =
245 (match Hbugs_messages.msg_of_string req#body with
247 Hbugs_messages.respond_msg
248 (Usage "Local Http Daemon up and running!") outchan
249 | Hint (broker_id, hint) ->
250 if self#isAuthenticated broker_id then begin
251 let received_hints = flatten_hint hint in
254 (match h with Hints _ -> assert false | _ -> ());
255 ignore (mainWindow#hintsCList#append [string_of_hint h]))
257 hints <- hints @ received_hints;
258 Hbugs_messages.respond_msg (Wow myOwnId) outchan
259 end else (* msg from unauthorized broker *)
260 Hbugs_messages.respond_exc "forbidden" broker_id outchan
262 Hbugs_messages.respond_exc
263 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
264 with (Hbugs_messages.Parse_error _) as e ->
265 Hbugs_messages.respond_exc
266 "parse_error" (Printexc.to_string e) outchan
268 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
269 only as a value to be sent to broker, local HTTP
270 daemon will listen on "0.0.0.0", port is parsed
271 from My URL though *)
272 let httpDaemonThread () =
275 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
277 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
279 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
280 (Printexc.to_string e))
282 ignore (Thread.create httpDaemonThread ())
284 method private testLocalHttpDaemon () =
287 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
291 (* self#showDialog msg *)
293 | Hbugs_misc.Malformed_URL url ->
296 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
298 | Hbugs_misc.Malformed_HTTP_response res ->
301 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
303 | (Unix.Unix_error _) as e ->
306 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
307 (Printexc.to_string e))
309 method private testBroker () =
310 self#sendReq ~msg:Help
316 "Handshake with HBugs Broker failed, unexpected message:\n%s"
317 (Hbugs_messages.string_of_msg unexpected_msg)))
319 method registerToBroker () =
320 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
322 | Client_registered broker_id ->
323 brokerId <- Some broker_id;
326 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
330 (sprintf "Client NOT registered, unexpected message:\n%s"
331 (Hbugs_messages.string_of_msg unexpected_msg)))
333 method unregisterFromBroker () =
334 self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
337 method stateChange new_state =
339 ~msg:(State_change (myOwnId, new_state))
341 | State_accepted _ ->
342 mainWindow#hintsCList#clear ();
346 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
347 (Hbugs_messages.string_of_msg unexpected_msg)))
349 method hint = List.nth hints
351 method private listTutors () =
352 (* wait is set to true just to make sure that after invoking listTutors
353 "availableTutors" is correctly filled *)
354 self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
356 | Tutor_list (_, descriptions) ->
357 availableTutors <- (* sort accordingly to tutor description *)
358 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
359 selectedTutors <- [];
360 subscribeWindow#tutorsCList#clear ();
363 ignore (subscribeWindow#tutorsCList#append [id; dsc]))
367 (sprintf "Can't list tutors, unexpected message:\n%s"
368 (Hbugs_messages.string_of_msg unexpected_msg)))
370 (* low level used by subscribeSelected and subscribeAll *)
371 method private subscribe' tutors_id =
372 self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
374 | (Subscribed (_, subscribedTutors)) as msg ->
375 let sort = List.sort compare in
376 mainWindow#subscriptionCList#clear ();
380 (mainWindow#subscriptionCList#append
382 List.assoc tutor_id availableTutors;
383 with Not_found -> assert false ]))
385 subscribeWindow#subscribeWindow#misc#hide ();
386 if sort subscribedTutors <> sort tutors_id then
388 (sprintf "Subscription mismatch\n: %s"
389 (Hbugs_messages.string_of_msg msg))
391 mainWindow#subscriptionCList#clear ();
393 (sprintf "Subscription FAILED, unexpected message:\n%s"
394 (Hbugs_messages.string_of_msg unexpected_msg)))
396 method private subscribeSelected () = self#subscribe' selectedTutors
398 method subscribeAll () =
399 self#listTutors (); (* this fills 'availableTutors' field *)
400 self#subscribe' (List.map fst availableTutors)
402 method private quit () =
403 self#unregisterFromBroker ();
406 (** enable/disable debugging *)
407 method private setDebug value = debug <- value
409 method private reconfigDebuggingButtons =
410 List.iter (* debug value changed, reconfigure buttons *)
411 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
414 method private toggleDebug () =
415 self#setDebug (not debug);
416 self#reconfigDebuggingButtons