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/
32 exception Invalid_URL of string;;
34 let global_debug = true;;
38 let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
39 let port_of_http_url url =
41 let subs = Pcre.extract ~rex:http_url_RE url in
42 int_of_string subs.(3)
43 with e -> raise (Invalid_URL url)
48 inherit Gui.hbugsMainWindow ()
50 val subscribeWindow = new Gui.subscribeWindow ()
51 val messageDialog = new Gui.messageDialog ()
52 val myOwnId = Hbugs_id_generator.new_client_id ()
53 val mutable myOwnUrl = "localhost:49082"
54 val mutable brokerUrl = "localhost:49081"
55 val mutable brokerId: broker_id option = None
56 val mutable selectedTutors: tutor_id list = []
57 val mutable statusContext = None
58 val mutable subscribeWindowStatusContext = None
59 val mutable debug = false (* enable/disable debugging buttons *)
62 (* self#setDebug global_debug; *)
64 self#startLocalHttpDaemon ();
65 self#testLocalHttpDaemon ();
67 self#registerClient ();
68 self#reconfigDebuggingButtons
72 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
73 [ self#startLocalHttpDaemonButton; self#testLocalHttpDaemonButton;
74 self#testBrokerButton; self#registerClientButton;
75 self#unregisterClientButton ]
77 method private initGui =
79 (* GUI: main window *)
80 ignore (self#hbugsMainWindow#connect#destroy self#quit);
82 (* GUI main window's menu *)
83 self#toggleDebuggingMenuItem#set_active debug;
84 ignore (self#toggleDebuggingMenuItem#connect#toggled self#toggleDebug);
86 (* GUI: local HTTP daemon settings *)
87 ignore (self#clientUrlEntry#connect#changed
88 (fun _ -> myOwnUrl <- self#clientUrlEntry#text));
89 self#clientUrlEntry#set_text myOwnUrl;
90 ignore (self#startLocalHttpDaemonButton#connect#clicked
91 self#startLocalHttpDaemon);
92 ignore (self#testLocalHttpDaemonButton#connect#clicked
93 self#testLocalHttpDaemon);
95 (* GUI: broker choice *)
96 ignore (self#brokerUrlEntry#connect#changed
97 (fun _ -> brokerUrl <- self#brokerUrlEntry#text));
98 self#brokerUrlEntry#set_text brokerUrl;
99 ignore (self#testBrokerButton#connect#clicked self#testBroker);
100 self#clientIdLabel#set_text myOwnId;
102 (* GUI: client registration *)
103 ignore (self#registerClientButton#connect#clicked self#registerClient);
104 ignore (self#unregisterClientButton#connect#clicked
105 self#unregisterClient);
107 (* GUI: subscriptions *)
108 ignore (self#showSubscriptionWindowButton#connect#clicked
111 subscribeWindow#subscribeWindow#show ()));
113 (* GUI: DEBUG state change *)
114 ignore (self#stateChangeButton#connect#clicked self#stateChange);
116 (* GUI: hints list *)
117 ignore (self#useHintButton#connect#clicked self#useHint);
119 (* GUI: main status bar *)
120 let ctxt = self#mainWindowStatusBar#new_context "0" in
121 statusContext <- Some ctxt;
122 ignore (ctxt#push "Ready");
124 (* GUI: subscription window *)
125 ignore (subscribeWindow#subscribeWindow#event#connect#delete
126 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
127 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
128 let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
129 ignore (subscribeWindow#tutorsCList#connect#select_row
130 (fun ~row ~column ~event ->
131 selectedTutors <- tutor_id_of_row row :: selectedTutors));
132 ignore (subscribeWindow#tutorsCList#connect#unselect_row
133 (fun ~row ~column ~event ->
135 List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
136 ignore (subscribeWindow#subscribeButton#connect#clicked self#subscribe);
137 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
138 subscribeWindowStatusContext <- Some ctxt;
139 ignore (ctxt#push "Ready");
141 (* GUI: message dialog *)
142 ignore (messageDialog#messageDialog#event#connect#delete
143 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
144 ignore (messageDialog#okDialogButton#connect#clicked
145 (fun _ -> messageDialog#messageDialog#misc#hide ()))
147 (* accessory methods *)
149 (** pop up a (modal) dialog window showing msg to the user *)
150 method private showDialog msg =
151 messageDialog#dialogLabel#set_text msg;
152 messageDialog#messageDialog#show ()
153 (** use showDialog to display an hbugs message to the user *)
154 method private showMsgInDialog msg =
155 self#showDialog (Hbugs_messages.string_of_msg msg)
157 (** create a new thread which sends msg to broker, wait for an answer and
158 invoke callback passing response message as argument *)
159 method private sendReq ~msg callback =
162 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
164 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
167 "Parse_error, unable to fullfill request. Details follow.
170 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e))
171 | (Unix.Unix_error _) as e ->
174 "Can't connect to HBugs Broker
177 brokerUrl (Printexc.to_string e))
179 ignore (Thread.create thread ())
181 (** check if a broker is authenticated using its broker_id
182 [ Background: during client registration, client save broker_id of its
183 broker, further messages from broker are accepted only if they carry the
185 method private isAuthenticated id =
188 | Some broker_id -> (id = broker_id)
192 method startLocalHttpDaemon () =
193 let callback req outchan =
195 (match Hbugs_messages.msg_of_string req#body with
197 Hbugs_messages.respond_msg
198 (Usage "Local Http Daemon up and running!") outchan
199 | Hint (broker_id, hint) ->
200 if self#isAuthenticated broker_id then
201 ignore (self#hintsCList#append [hint])
203 Hbugs_messages.respond_exc "forbidden" broker_id outchan
205 Hbugs_messages.respond_exc
206 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
207 with (Hbugs_messages.Parse_error _) as e ->
208 Hbugs_messages.respond_exc
209 "parse_error" (Printexc.to_string e) outchan
211 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
212 only as a value to be sent to broker, local HTTP
213 daemon will listen on "0.0.0.0", port is parsed
214 from My URL though *)
218 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
220 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
222 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
223 (Printexc.to_string e))
225 ignore (Thread.create thread ())
227 method testLocalHttpDaemon () =
230 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
234 (* self#showDialog msg *)
236 | Hbugs_misc.Malformed_URL url ->
239 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
241 | Hbugs_misc.Malformed_HTTP_response res ->
244 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
246 | (Unix.Unix_error _) as e ->
249 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
250 (Printexc.to_string e))
252 method testBroker () =
253 self#sendReq ~msg:Help
259 "Handshake with HBugs Broker failed, unexpected message:\n%s"
260 (Hbugs_messages.string_of_msg unexpected_msg)))
262 method registerClient () =
263 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
265 | Client_registered broker_id ->
266 brokerId <- Some broker_id;
269 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
273 (sprintf "Client NOT registered, unexpected message:\n%s"
274 (Hbugs_messages.string_of_msg unexpected_msg)))
276 method unregisterClient () =
277 self#sendReq ~msg:(Unregister_client myOwnId)
280 method stateChange () =
281 let state = (* TODO fill with a real state representation! *)
282 self#stateText#get_chars 0 (self#stateText#length)
284 self#sendReq ~msg:(State_change (myOwnId, state))
287 method listTutors () =
288 self#sendReq ~msg:(List_tutors myOwnId)
290 | Tutor_list (_, descriptions) ->
291 selectedTutors <- [];
292 subscribeWindow#tutorsCList#clear ();
295 ignore (subscribeWindow#tutorsCList#append [id; dsc]))
299 (sprintf "Can't list tutors, unexpected message:\n%s"
300 (Hbugs_messages.string_of_msg unexpected_msg)))
302 method subscribe () =
303 let selectedTutors = List.sort compare selectedTutors in
304 self#sendReq ~msg:(Subscribe (myOwnId, selectedTutors))
306 | (Subscribed (_, tutors)) as msg ->
307 let msg_string = Hbugs_messages.string_of_msg msg in
308 let subscribedTutors = List.sort compare tutors in
310 if subscribedTutors = selectedTutors then
311 sprintf "Subscription OK\n: %s" msg_string
313 sprintf "Subscription mismatch\n: %s" msg_string
316 subscribeWindow#subscribeWindow#misc#hide ()
319 (sprintf "Subscription FAILED, unexpected message:\n%s"
320 (Hbugs_messages.string_of_msg unexpected_msg)))
322 method useHint () = failwith "useHint: TODO not implemented" (* TODO *)
324 method private quit () =
325 self#unregisterClient ();
328 (** enable/disable debugging buttons *)
329 method setDebug ?(force = false) value =
330 if (debug <> value) || force then
333 method private reconfigDebuggingButtons =
334 List.iter (* debug value changed, reconfigure buttons *)
335 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
338 method toggleDebug () =
339 self#setDebug (not debug);
340 self#reconfigDebuggingButtons
345 ignore (new hbugsClient);