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 ?(use_hint_callback: hint -> unit = (fun _ -> ()))
48 let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
49 let port_of_http_url url =
51 let subs = Pcre.extract ~rex:http_url_RE url in
52 int_of_string subs.(3)
53 with e -> raise (Invalid_URL url)
58 val mainWindow = new Hbugs_client_gui.hbugsMainWindow ()
59 val subscribeWindow = new Hbugs_client_gui.subscribeWindow ()
60 val messageDialog = new Hbugs_client_gui.messageDialog ()
61 val myOwnId = Hbugs_id_generator.new_client_id ()
62 val mutable use_hint_callback = use_hint_callback
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 setUseHintCallback callback =
88 use_hint_callback <- callback
90 method private debugButtons =
92 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
93 [ mainWindow#startLocalHttpDaemonButton;
94 mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton;
95 mainWindow#registerClientButton; mainWindow#unregisterClientButton ]
97 method private initGui =
99 (* GUI: main window *)
100 let on_exit = fun () -> self#quit (); false in
101 ignore (mainWindow#hbugsMainWindow#event#connect#destroy
102 (fun _ -> on_exit ()));
103 ignore (mainWindow#hbugsMainWindow#event#connect#delete
104 (fun _ -> on_exit ()));
106 (* GUI main window's menu *)
107 mainWindow#toggleDebuggingMenuItem#set_active debug;
108 ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
111 (* GUI: local HTTP daemon settings *)
112 ignore (mainWindow#clientUrlEntry#connect#changed
113 (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
114 mainWindow#clientUrlEntry#set_text myOwnUrl;
115 ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
116 self#startLocalHttpDaemon);
117 ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
118 self#testLocalHttpDaemon);
120 (* GUI: broker choice *)
121 ignore (mainWindow#brokerUrlEntry#connect#changed
122 (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
123 mainWindow#brokerUrlEntry#set_text brokerUrl;
124 ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
125 mainWindow#clientIdLabel#set_text myOwnId;
127 (* GUI: client registration *)
128 ignore (mainWindow#registerClientButton#connect#clicked
129 self#registerToBroker);
130 ignore (mainWindow#unregisterClientButton#connect#clicked
131 self#unregisterFromBroker);
133 (* GUI: subscriptions *)
134 ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
137 subscribeWindow#subscribeWindow#show ()));
139 (* GUI: hints list *)
140 ignore (mainWindow#hintsCList#connect#select_row
141 (fun ~row ~column ~event ->
143 | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS ->
144 use_hint_callback (self#hint row)
147 (* GUI: main status bar *)
148 let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
149 statusContext <- Some ctxt;
150 ignore (ctxt#push "Ready");
152 (* GUI: subscription window *)
153 ignore (subscribeWindow#subscribeWindow#event#connect#delete
154 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
155 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
156 let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
157 ignore (subscribeWindow#tutorsCList#connect#select_row
158 (fun ~row ~column ~event ->
159 selectedTutors <- tutor_id_of_row row :: selectedTutors));
160 ignore (subscribeWindow#tutorsCList#connect#unselect_row
161 (fun ~row ~column ~event ->
163 List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
164 ignore (subscribeWindow#subscribeButton#connect#clicked
165 self#subscribeSelected);
166 ignore (subscribeWindow#subscribeAllButton#connect#clicked
168 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
169 subscribeWindowStatusContext <- Some ctxt;
170 ignore (ctxt#push "Ready");
172 (* GUI: message dialog *)
173 ignore (messageDialog#messageDialog#event#connect#delete
174 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
175 ignore (messageDialog#okDialogButton#connect#clicked
176 (fun _ -> messageDialog#messageDialog#misc#hide ()))
178 (* accessory methods *)
180 (** pop up a (modal) dialog window showing msg to the user *)
181 method private showDialog msg =
182 messageDialog#dialogLabel#set_text msg;
183 messageDialog#messageDialog#show ()
184 (** use showDialog to display an hbugs message to the user *)
185 method private showMsgInDialog msg =
186 self#showDialog (Hbugs_messages.string_of_msg msg)
188 (** create a new thread which sends msg to broker, wait for an answer and
189 invoke callback passing response message as argument *)
190 method private sendReq ?(wait = false) ~msg callback =
193 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
195 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
198 "Parse_error, unable to fullfill request. Details follow.
201 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
202 | (Unix.Unix_error _) as e ->
205 "Can't connect to HBugs Broker
208 brokerUrl (Printexc.to_string e))
211 (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
212 (Printexc.to_string e))
214 let th = Thread.create thread () in
219 (** check if a broker is authenticated using its broker_id
220 [ Background: during client registration, client save broker_id of its
221 broker, further messages from broker are accepted only if they carry the
223 method private isAuthenticated id =
226 | Some broker_id -> (id = broker_id)
230 method private startLocalHttpDaemon =
231 (* flatten an hint tree to an hint list *)
232 let rec flatten_hint = function
233 | Hints hints -> List.concat (List.map flatten_hint hints)
237 let callback req outchan =
239 (match Hbugs_messages.msg_of_string req#body with
241 Hbugs_messages.respond_msg
242 (Usage "Local Http Daemon up and running!") outchan
243 | Hint (broker_id, hint) ->
244 if self#isAuthenticated broker_id then begin
245 let received_hints = flatten_hint hint in
248 (match h with Hints _ -> assert false | _ -> ());
249 ignore (mainWindow#hintsCList#append [string_of_hint h]))
251 hints <- hints @ received_hints;
252 Hbugs_messages.respond_msg (Wow myOwnId) outchan
253 end else (* msg from unauthorized broker *)
254 Hbugs_messages.respond_exc "forbidden" broker_id outchan
256 Hbugs_messages.respond_exc
257 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
258 with (Hbugs_messages.Parse_error _) as e ->
259 Hbugs_messages.respond_exc
260 "parse_error" (Printexc.to_string e) outchan
262 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
263 only as a value to be sent to broker, local HTTP
264 daemon will listen on "0.0.0.0", port is parsed
265 from My URL though *)
266 let httpDaemonThread () =
269 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
271 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
273 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
274 (Printexc.to_string e))
276 ignore (Thread.create httpDaemonThread ())
278 method private testLocalHttpDaemon () =
281 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
285 (* self#showDialog msg *)
287 | Hbugs_misc.Malformed_URL url ->
290 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
292 | Hbugs_misc.Malformed_HTTP_response res ->
295 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
297 | (Unix.Unix_error _) as e ->
300 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
301 (Printexc.to_string e))
303 method private testBroker () =
304 self#sendReq ~msg:Help
310 "Handshake with HBugs Broker failed, unexpected message:\n%s"
311 (Hbugs_messages.string_of_msg unexpected_msg)))
313 method registerToBroker () =
314 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
316 | Client_registered broker_id ->
317 brokerId <- Some broker_id;
320 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
324 (sprintf "Client NOT registered, unexpected message:\n%s"
325 (Hbugs_messages.string_of_msg unexpected_msg)))
327 method unregisterFromBroker () =
328 self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
331 method stateChange new_state =
333 ~msg:(State_change (myOwnId, new_state))
335 | State_accepted _ ->
336 mainWindow#hintsCList#clear ();
340 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
341 (Hbugs_messages.string_of_msg unexpected_msg)))
343 method hint = List.nth hints
345 method private listTutors () =
346 (* wait is set to true just to make sure that after invoking listTutors
347 "availableTutors" is correctly filled *)
348 self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
350 | Tutor_list (_, descriptions) ->
351 availableTutors <- (* sort accordingly to tutor description *)
352 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
353 selectedTutors <- [];
354 subscribeWindow#tutorsCList#clear ();
357 ignore (subscribeWindow#tutorsCList#append [id; dsc]))
361 (sprintf "Can't list tutors, unexpected message:\n%s"
362 (Hbugs_messages.string_of_msg unexpected_msg)))
364 (* low level used by subscribeSelected and subscribeAll *)
365 method private subscribe' tutors_id =
366 self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
368 | (Subscribed (_, subscribedTutors)) as msg ->
369 let sort = List.sort compare in
370 mainWindow#subscriptionCList#clear ();
374 (mainWindow#subscriptionCList#append
376 List.assoc tutor_id availableTutors;
377 with Not_found -> assert false ]))
379 subscribeWindow#subscribeWindow#misc#hide ();
380 if sort subscribedTutors <> sort tutors_id then
382 (sprintf "Subscription mismatch\n: %s"
383 (Hbugs_messages.string_of_msg msg))
385 mainWindow#subscriptionCList#clear ();
387 (sprintf "Subscription FAILED, unexpected message:\n%s"
388 (Hbugs_messages.string_of_msg unexpected_msg)))
390 method private subscribeSelected () = self#subscribe' selectedTutors
392 method subscribeAll () =
393 self#listTutors (); (* this fills 'availableTutors' field *)
394 self#subscribe' (List.map fst availableTutors)
396 method private quit () =
397 self#unregisterFromBroker ();
400 (** enable/disable debugging *)
401 method private setDebug value = debug <- value
403 method private reconfigDebuggingButtons =
404 List.iter (* debug value changed, reconfigure buttons *)
405 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
408 method private toggleDebug () =
409 self#setDebug (not debug);
410 self#reconfigDebuggingButtons