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;;
38 @param on_use_hint function invoked when an hint is used, argumnet is the hint
40 @param on_exit function invoked when client is exiting (e.g. window is
41 destroyed, if it's None "self#quit" is invoked
44 ~(on_use_hint: hint -> unit)
45 ?(on_exit: (unit -> unit) option)
49 let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
50 let port_of_http_url url =
52 let subs = Pcre.extract ~rex:http_url_RE url in
53 int_of_string subs.(3)
54 with e -> raise (Invalid_URL url)
59 val mainWindow = new Hbugs_client_gui.hbugsMainWindow ()
60 val subscribeWindow = new Hbugs_client_gui.subscribeWindow ()
61 val messageDialog = new Hbugs_client_gui.messageDialog ()
62 val myOwnId = Hbugs_id_generator.new_client_id ()
63 val mutable myOwnUrl = "localhost:49082"
64 val mutable brokerUrl = "localhost:49081"
65 val mutable brokerId: broker_id option = None
66 (* all available tutors, saved last time a List_tutors message was sent to
68 val mutable availableTutors: tutor_dsc list = []
69 (* id of highlighted tutors in tutor subscription window *)
70 val mutable selectedTutors: tutor_id list = []
71 val mutable statusContext = None
72 val mutable subscribeWindowStatusContext = None
73 val mutable debug = false (* enable/disable debugging buttons *)
74 val mutable hints = [] (* actually available hints *)
78 self#startLocalHttpDaemon ();
79 self#testLocalHttpDaemon ();
81 self#registerToBroker ();
82 self#reconfigDebuggingButtons
84 method show = mainWindow#hbugsMainWindow#show
85 method hide = mainWindow#hbugsMainWindow#misc#hide
87 method private debugButtons =
89 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
90 [ mainWindow#startLocalHttpDaemonButton;
91 mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton;
92 mainWindow#registerClientButton; mainWindow#unregisterClientButton ]
94 method private initGui =
96 (* GUI: main window *)
99 | None -> (fun () -> self#quit (); false)
100 | Some f -> (fun () -> f (); true)
102 ignore (mainWindow#hbugsMainWindow#event#connect#destroy
103 (fun _ -> on_exit ()));
104 ignore (mainWindow#hbugsMainWindow#event#connect#delete
105 (fun _ -> on_exit ()));
107 (* GUI main window's menu *)
108 mainWindow#toggleDebuggingMenuItem#set_active debug;
109 ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
112 (* GUI: local HTTP daemon settings *)
113 ignore (mainWindow#clientUrlEntry#connect#changed
114 (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
115 mainWindow#clientUrlEntry#set_text myOwnUrl;
116 ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
117 self#startLocalHttpDaemon);
118 ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
119 self#testLocalHttpDaemon);
121 (* GUI: broker choice *)
122 ignore (mainWindow#brokerUrlEntry#connect#changed
123 (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
124 mainWindow#brokerUrlEntry#set_text brokerUrl;
125 ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
126 mainWindow#clientIdLabel#set_text myOwnId;
128 (* GUI: client registration *)
129 ignore (mainWindow#registerClientButton#connect#clicked
130 self#registerToBroker);
131 ignore (mainWindow#unregisterClientButton#connect#clicked
132 self#unregisterFromBroker);
134 (* GUI: subscriptions *)
135 ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
138 subscribeWindow#subscribeWindow#show ()));
140 (* GUI: hints list *)
141 ignore (mainWindow#hintsCList#connect#select_row
142 (fun ~row ~column ~event ->
144 | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS ->
145 on_use_hint (self#hint row)
148 (* GUI: main status bar *)
149 let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
150 statusContext <- Some ctxt;
151 ignore (ctxt#push "Ready");
153 (* GUI: subscription window *)
154 ignore (subscribeWindow#subscribeWindow#event#connect#delete
155 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
156 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
157 let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
158 ignore (subscribeWindow#tutorsCList#connect#select_row
159 (fun ~row ~column ~event ->
160 selectedTutors <- tutor_id_of_row row :: selectedTutors));
161 ignore (subscribeWindow#tutorsCList#connect#unselect_row
162 (fun ~row ~column ~event ->
164 List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
165 ignore (subscribeWindow#subscribeButton#connect#clicked
166 self#subscribeSelected);
167 ignore (subscribeWindow#subscribeAllButton#connect#clicked
169 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
170 subscribeWindowStatusContext <- Some ctxt;
171 ignore (ctxt#push "Ready");
173 (* GUI: message dialog *)
174 ignore (messageDialog#messageDialog#event#connect#delete
175 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
176 ignore (messageDialog#okDialogButton#connect#clicked
177 (fun _ -> messageDialog#messageDialog#misc#hide ()))
179 (* accessory methods *)
181 (** pop up a (modal) dialog window showing msg to the user *)
182 method private showDialog msg =
183 messageDialog#dialogLabel#set_text msg;
184 messageDialog#messageDialog#show ()
185 (** use showDialog to display an hbugs message to the user *)
186 method private showMsgInDialog msg =
187 self#showDialog (Hbugs_messages.string_of_msg msg)
189 (** create a new thread which sends msg to broker, wait for an answer and
190 invoke callback passing response message as argument *)
191 method private sendReq ?(wait = false) ~msg callback =
194 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
196 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
199 "Parse_error, unable to fullfill request. Details follow.
202 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
203 | (Unix.Unix_error _) as e ->
206 "Can't connect to HBugs Broker
209 brokerUrl (Printexc.to_string e))
212 (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
213 (Printexc.to_string e))
215 let th = Thread.create thread () in
220 (** check if a broker is authenticated using its broker_id
221 [ Background: during client registration, client save broker_id of its
222 broker, further messages from broker are accepted only if they carry the
224 method private isAuthenticated id =
227 | Some broker_id -> (id = broker_id)
231 method private startLocalHttpDaemon =
232 (* flatten an hint tree to an hint list *)
233 let rec flatten_hint = function
234 | Hints hints -> List.concat (List.map flatten_hint hints)
238 let callback req outchan =
240 (match Hbugs_messages.msg_of_string req#body with
242 Hbugs_messages.respond_msg
243 (Usage "Local Http Daemon up and running!") outchan
244 | Hint (broker_id, hint) ->
245 if self#isAuthenticated broker_id then begin
246 let received_hints = flatten_hint hint in
249 (match h with Hints _ -> assert false | _ -> ());
250 ignore (mainWindow#hintsCList#append [string_of_hint h]))
252 hints <- hints @ received_hints;
253 Hbugs_messages.respond_msg (Wow myOwnId) outchan
254 end else (* msg from unauthorized broker *)
255 Hbugs_messages.respond_exc "forbidden" broker_id outchan
257 Hbugs_messages.respond_exc
258 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
259 with (Hbugs_messages.Parse_error _) as e ->
260 Hbugs_messages.respond_exc
261 "parse_error" (Printexc.to_string e) outchan
263 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
264 only as a value to be sent to broker, local HTTP
265 daemon will listen on "0.0.0.0", port is parsed
266 from My URL though *)
267 let httpDaemonThread () =
270 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
272 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
274 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
275 (Printexc.to_string e))
277 ignore (Thread.create httpDaemonThread ())
279 method private testLocalHttpDaemon () =
282 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
286 (* self#showDialog msg *)
288 | Hbugs_misc.Malformed_URL url ->
291 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
293 | Hbugs_misc.Malformed_HTTP_response res ->
296 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
298 | (Unix.Unix_error _) as e ->
301 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
302 (Printexc.to_string e))
304 method private testBroker () =
305 self#sendReq ~msg:Help
311 "Handshake with HBugs Broker failed, unexpected message:\n%s"
312 (Hbugs_messages.string_of_msg unexpected_msg)))
314 method registerToBroker () =
315 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
317 | Client_registered broker_id ->
318 brokerId <- Some broker_id;
321 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
325 (sprintf "Client NOT registered, unexpected message:\n%s"
326 (Hbugs_messages.string_of_msg unexpected_msg)))
328 method unregisterFromBroker () =
329 self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
332 method stateChange new_state =
334 ~msg:(State_change (myOwnId, new_state))
336 | State_accepted _ ->
337 mainWindow#hintsCList#clear ();
341 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
342 (Hbugs_messages.string_of_msg unexpected_msg)))
344 method hint = List.nth hints
346 method private listTutors () =
347 (* wait is set to true just to make sure that after invoking listTutors
348 "availableTutors" is correctly filled *)
349 self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
351 | Tutor_list (_, descriptions) ->
352 availableTutors <- (* sort accordingly to tutor description *)
353 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
354 selectedTutors <- [];
355 subscribeWindow#tutorsCList#clear ();
358 ignore (subscribeWindow#tutorsCList#append [id; dsc]))
362 (sprintf "Can't list tutors, unexpected message:\n%s"
363 (Hbugs_messages.string_of_msg unexpected_msg)))
365 (* low level used by subscribeSelected and subscribeAll *)
366 method private subscribe' tutors_id =
367 self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
369 | (Subscribed (_, subscribedTutors)) as msg ->
370 let sort = List.sort compare in
371 mainWindow#subscriptionCList#clear ();
375 (mainWindow#subscriptionCList#append
377 List.assoc tutor_id availableTutors;
378 with Not_found -> assert false ]))
380 subscribeWindow#subscribeWindow#misc#hide ();
381 if sort subscribedTutors <> sort tutors_id then
383 (sprintf "Subscription mismatch\n: %s"
384 (Hbugs_messages.string_of_msg msg))
386 mainWindow#subscriptionCList#clear ();
388 (sprintf "Subscription FAILED, unexpected message:\n%s"
389 (Hbugs_messages.string_of_msg unexpected_msg)))
391 method private subscribeSelected () = self#subscribe' selectedTutors
393 method subscribeAll () =
394 self#listTutors (); (* this fills 'availableTutors' field *)
395 self#subscribe' (List.map fst availableTutors)
397 method private quit () =
398 self#unregisterFromBroker ();
401 (** enable/disable debugging *)
402 method private setDebug value = debug <- value
404 method private reconfigDebuggingButtons =
405 List.iter (* debug value changed, reconfigure buttons *)
406 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
409 method private toggleDebug () =
410 self#setDebug (not debug);
411 self#reconfigDebuggingButtons