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 _ = ();;
38 ?(use_hint_callback: hint -> unit = do_nothing)
39 ?(describe_hint_callback: hint -> unit = do_nothing)
40 ?(destroy_callback: unit -> unit = do_nothing)
44 let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
45 let port_of_http_url url =
47 let subs = Pcre.extract ~rex:http_url_RE url in
48 int_of_string subs.(3)
49 with e -> raise (Invalid_URL url)
54 val mainWindow = new Hbugs_client_gui.hbugsMainWindow ()
55 val subscribeWindow = new Hbugs_client_gui.subscribeWindow ()
56 val messageDialog = new Hbugs_client_gui.messageDialog ()
57 val myOwnId = Hbugs_id_generator.new_client_id ()
58 val mutable use_hint_callback = use_hint_callback
59 val mutable myOwnUrl = "localhost:49082"
60 val mutable brokerUrl = "localhost:49081"
61 val mutable brokerId: broker_id option = None
62 (* all available tutors, saved last time a List_tutors message was sent to
64 val mutable availableTutors: tutor_dsc list = []
65 (* id of highlighted tutors in tutor subscription window *)
66 val mutable selectedTutors: tutor_id list = []
67 val mutable statusContext = None
68 val mutable subscribeWindowStatusContext = None
69 val mutable debug = false (* enable/disable debugging buttons *)
70 val mutable hints = [] (* actually available hints *)
74 self#startLocalHttpDaemon ();
75 self#testLocalHttpDaemon ();
77 self#registerToBroker ();
78 self#reconfigDebuggingButtons
80 method show = mainWindow#hbugsMainWindow#show
81 method hide = mainWindow#hbugsMainWindow#misc#hide
83 method setUseHintCallback callback =
84 use_hint_callback <- callback
86 method private debugButtons =
88 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
89 [ mainWindow#startLocalHttpDaemonButton;
90 mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ]
92 method private initGui =
94 (* GUI: main window *)
96 (* ignore delete events so that hbugs window is closable only using
97 menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked
100 ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true));
101 ignore (mainWindow#hbugsMainWindow#event#connect#destroy
102 (fun _ -> self#quit (); false));
104 (* GUI main window's menu *)
105 mainWindow#toggleDebuggingMenuItem#set_active debug;
106 ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
109 (* GUI: local HTTP daemon settings *)
110 ignore (mainWindow#clientUrlEntry#connect#changed
111 (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
112 mainWindow#clientUrlEntry#set_text myOwnUrl;
113 ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
114 self#startLocalHttpDaemon);
115 ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
116 self#testLocalHttpDaemon);
118 (* GUI: broker choice *)
119 ignore (mainWindow#brokerUrlEntry#connect#changed
120 (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
121 mainWindow#brokerUrlEntry#set_text brokerUrl;
122 ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
123 mainWindow#clientIdLabel#set_text myOwnId;
125 (* GUI: client registration *)
126 ignore (mainWindow#registerClientButton#connect#clicked
127 self#registerToBroker);
129 (* GUI: subscriptions *)
130 ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
133 subscribeWindow#subscribeWindow#show ()));
135 (* GUI: hints list *)
136 ignore (mainWindow#hintsCList#connect#select_row
137 (fun ~row ~column ~event ->
139 | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS ->
140 use_hint_callback (self#hint row)
142 describe_hint_callback (self#hint row)
145 (* GUI: main status bar *)
146 let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
147 statusContext <- Some ctxt;
148 ignore (ctxt#push "Ready");
150 (* GUI: subscription window *)
151 ignore (subscribeWindow#subscribeWindow#event#connect#delete
152 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
153 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
154 let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
155 ignore (subscribeWindow#tutorsCList#connect#select_row
156 (fun ~row ~column ~event ->
157 let new_id = tutor_id_of_row row in
158 match selectedTutors with
159 | hd :: _ when hd = new_id -> () (* avoid double select events *)
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 subscribeWindow#tutorsCList#set_column ~visibility:false 0;
170 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
171 subscribeWindowStatusContext <- Some ctxt;
172 ignore (ctxt#push "Ready");
174 (* GUI: message dialog *)
175 ignore (messageDialog#messageDialog#event#connect#delete
176 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
177 ignore (messageDialog#okDialogButton#connect#clicked
178 (fun _ -> messageDialog#messageDialog#misc#hide ()))
180 (* accessory methods *)
182 (** pop up a (modal) dialog window showing msg to the user *)
183 method private showDialog msg =
184 messageDialog#dialogLabel#set_text msg;
185 messageDialog#messageDialog#show ()
186 (** use showDialog to display an hbugs message to the user *)
187 method private showMsgInDialog msg =
188 self#showDialog (Hbugs_messages.string_of_msg msg)
190 (** create a new thread which sends msg to broker, wait for an answer and
191 invoke callback passing response message as argument *)
192 method private sendReq ?(wait = false) ~msg callback =
195 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
197 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
200 "Parse_error, unable to fullfill request. Details follow.
203 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
204 | (Unix.Unix_error _) as e ->
207 "Can't connect to HBugs Broker
210 brokerUrl (Printexc.to_string e))
213 (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
214 (Printexc.to_string e))
216 let th = Thread.create thread () in
221 (** check if a broker is authenticated using its broker_id
222 [ Background: during client registration, client save broker_id of its
223 broker, further messages from broker are accepted only if they carry the
225 method private isAuthenticated id =
228 | Some broker_id -> (id = broker_id)
232 method private startLocalHttpDaemon =
233 (* flatten an hint tree to an hint list *)
234 let rec flatten_hint = function
235 | Hints hints -> List.concat (List.map flatten_hint hints)
239 let callback req outchan =
241 (match Hbugs_messages.msg_of_string req#body with
243 Hbugs_messages.respond_msg
244 (Usage "Local Http Daemon up and running!") outchan
245 | Hint (broker_id, hint) ->
246 if self#isAuthenticated broker_id then begin
247 let received_hints = flatten_hint hint in
250 (match h with Hints _ -> assert false | _ -> ());
251 ignore (mainWindow#hintsCList#append [string_of_hint h]))
253 hints <- hints @ received_hints;
254 Hbugs_messages.respond_msg (Wow myOwnId) outchan
255 end else (* msg from unauthorized broker *)
256 Hbugs_messages.respond_exc "forbidden" broker_id outchan
258 Hbugs_messages.respond_exc
259 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
260 with (Hbugs_messages.Parse_error _) as e ->
261 Hbugs_messages.respond_exc
262 "parse_error" (Printexc.to_string e) outchan
264 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
265 only as a value to be sent to broker, local HTTP
266 daemon will listen on "0.0.0.0", port is parsed
267 from My URL though *)
268 let httpDaemonThread () =
271 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
273 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
275 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
276 (Printexc.to_string e))
278 ignore (Thread.create httpDaemonThread ())
280 method private testLocalHttpDaemon () =
283 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
287 (* self#showDialog msg *)
289 | Hbugs_misc.Malformed_URL url ->
292 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
294 | Hbugs_misc.Malformed_HTTP_response res ->
297 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
299 | (Unix.Unix_error _) as e ->
302 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
303 (Printexc.to_string e))
305 method private testBroker () =
306 self#sendReq ~msg:Help
312 "Handshake with HBugs Broker failed, unexpected message:\n%s"
313 (Hbugs_messages.string_of_msg unexpected_msg)))
315 method registerToBroker () =
316 (match brokerId with (* undo previous registration, if any *)
317 | Some id -> self#unregisterFromBroker ()
319 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
321 | Client_registered broker_id -> (brokerId <- Some 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)
330 | Client_unregistered _ -> (brokerId <- None)
331 | unexpected_msg -> ())
334 (sprintf "Client NOT unregistered, unexpected message:\n%s"
335 (Hbugs_messages.string_of_msg unexpected_msg)))
338 method stateChange new_state =
339 mainWindow#hintsCList#clear ();
342 ~msg:(State_change (myOwnId, new_state))
344 | State_accepted _ -> ()
347 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
348 (Hbugs_messages.string_of_msg unexpected_msg)))
350 method hint = List.nth hints
352 method private listTutors () =
353 (* wait is set to true just to make sure that after invoking listTutors
354 "availableTutors" is correctly filled *)
355 self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
357 | Tutor_list (_, descriptions) ->
358 availableTutors <- (* sort accordingly to tutor description *)
359 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
360 selectedTutors <- [];
361 subscribeWindow#tutorsCList#clear ();
364 ignore (subscribeWindow#tutorsCList#append [id; dsc]))
368 (sprintf "Can't list tutors, unexpected message:\n%s"
369 (Hbugs_messages.string_of_msg unexpected_msg)))
371 (* low level used by subscribeSelected and subscribeAll *)
372 method private subscribe' tutors_id =
373 self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
375 | (Subscribed (_, subscribedTutors)) as msg ->
376 let sort = List.sort compare in
377 mainWindow#subscriptionCList#clear ();
381 (mainWindow#subscriptionCList#append
383 List.assoc tutor_id availableTutors;
384 with Not_found -> assert false ]))
386 subscribeWindow#subscribeWindow#misc#hide ();
387 if sort subscribedTutors <> sort tutors_id then
389 (sprintf "Subscription mismatch\n: %s"
390 (Hbugs_messages.string_of_msg msg))
392 mainWindow#subscriptionCList#clear ();
394 (sprintf "Subscription FAILED, unexpected message:\n%s"
395 (Hbugs_messages.string_of_msg unexpected_msg)))
397 method private subscribeSelected () = self#subscribe' selectedTutors
399 method subscribeAll () =
400 self#listTutors (); (* this fills 'availableTutors' field *)
401 self#subscribe' (List.map fst availableTutors)
403 method private quit () =
404 self#unregisterFromBroker ();
407 (** enable/disable debugging *)
408 method private setDebug value = debug <- value
410 method private reconfigDebuggingButtons =
411 List.iter (* debug value changed, reconfigure buttons *)
412 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
415 method private toggleDebug () =
416 self#setDebug (not debug);
417 self#reconfigDebuggingButtons