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 val mainWindow = new Gui.hbugsMainWindow ()
49 val subscribeWindow = new Gui.subscribeWindow ()
50 val messageDialog = new Gui.messageDialog ()
51 val myOwnId = Hbugs_id_generator.new_client_id ()
52 val mutable myOwnUrl = "localhost:49082"
53 val mutable brokerUrl = "localhost:49081"
54 val mutable brokerId: broker_id option = None
55 val mutable selectedTutors: tutor_id list = []
56 val mutable statusContext = None
57 val mutable subscribeWindowStatusContext = None
58 val mutable debug = false (* enable/disable debugging buttons *)
62 self#startLocalHttpDaemon ();
63 self#testLocalHttpDaemon ();
65 self#registerClient ();
66 self#reconfigDebuggingButtons
68 method show = mainWindow#hbugsMainWindow#show
69 method hide = mainWindow#hbugsMainWindow#misc#hide
71 method private debugButtons =
73 (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
74 [ mainWindow#startLocalHttpDaemonButton;
75 mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton;
76 mainWindow#registerClientButton; mainWindow#unregisterClientButton ]
78 method private initGui =
80 (* GUI: main window *)
81 ignore (mainWindow#hbugsMainWindow#connect#destroy self#quit);
83 (* GUI main window's menu *)
84 mainWindow#toggleDebuggingMenuItem#set_active debug;
85 ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
88 (* GUI: local HTTP daemon settings *)
89 ignore (mainWindow#clientUrlEntry#connect#changed
90 (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
91 mainWindow#clientUrlEntry#set_text myOwnUrl;
92 ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
93 self#startLocalHttpDaemon);
94 ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
95 self#testLocalHttpDaemon);
97 (* GUI: broker choice *)
98 ignore (mainWindow#brokerUrlEntry#connect#changed
99 (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
100 mainWindow#brokerUrlEntry#set_text brokerUrl;
101 ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
102 mainWindow#clientIdLabel#set_text myOwnId;
104 (* GUI: client registration *)
105 ignore (mainWindow#registerClientButton#connect#clicked
106 self#registerClient);
107 ignore (mainWindow#unregisterClientButton#connect#clicked
108 self#unregisterClient);
110 (* GUI: subscriptions *)
111 ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
114 subscribeWindow#subscribeWindow#show ()));
116 (* GUI: DEBUG state change *)
117 ignore (mainWindow#stateChangeButton#connect#clicked self#stateChange);
119 (* GUI: hints list *)
120 ignore (mainWindow#useHintButton#connect#clicked self#useHint);
122 (* GUI: main status bar *)
123 let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
124 statusContext <- Some ctxt;
125 ignore (ctxt#push "Ready");
127 (* GUI: subscription window *)
128 ignore (subscribeWindow#subscribeWindow#event#connect#delete
129 (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
130 ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
131 let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
132 ignore (subscribeWindow#tutorsCList#connect#select_row
133 (fun ~row ~column ~event ->
134 selectedTutors <- tutor_id_of_row row :: selectedTutors));
135 ignore (subscribeWindow#tutorsCList#connect#unselect_row
136 (fun ~row ~column ~event ->
138 List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
139 ignore (subscribeWindow#subscribeButton#connect#clicked self#subscribe);
140 let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
141 subscribeWindowStatusContext <- Some ctxt;
142 ignore (ctxt#push "Ready");
144 (* GUI: message dialog *)
145 ignore (messageDialog#messageDialog#event#connect#delete
146 (fun _ -> messageDialog#messageDialog#misc#hide (); true));
147 ignore (messageDialog#okDialogButton#connect#clicked
148 (fun _ -> messageDialog#messageDialog#misc#hide ()))
150 (* accessory methods *)
152 (** pop up a (modal) dialog window showing msg to the user *)
153 method private showDialog msg =
154 messageDialog#dialogLabel#set_text msg;
155 messageDialog#messageDialog#show ()
156 (** use showDialog to display an hbugs message to the user *)
157 method private showMsgInDialog msg =
158 self#showDialog (Hbugs_messages.string_of_msg msg)
160 (** create a new thread which sends msg to broker, wait for an answer and
161 invoke callback passing response message as argument *)
162 method private sendReq ~msg callback =
165 callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
167 | (Hbugs_messages.Parse_error (subj, reason)) as e ->
170 "Parse_error, unable to fullfill request. Details follow.
173 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e))
174 | (Unix.Unix_error _) as e ->
177 "Can't connect to HBugs Broker
180 brokerUrl (Printexc.to_string e))
182 ignore (Thread.create thread ())
184 (** check if a broker is authenticated using its broker_id
185 [ Background: during client registration, client save broker_id of its
186 broker, further messages from broker are accepted only if they carry the
188 method private isAuthenticated id =
191 | Some broker_id -> (id = broker_id)
195 method startLocalHttpDaemon () =
196 let callback req outchan =
198 (match Hbugs_messages.msg_of_string req#body with
200 Hbugs_messages.respond_msg
201 (Usage "Local Http Daemon up and running!") outchan
202 | Hint (broker_id, hint) ->
203 if self#isAuthenticated broker_id then
204 ignore (mainWindow#hintsCList#append [hint])
206 Hbugs_messages.respond_exc "forbidden" broker_id outchan
208 Hbugs_messages.respond_exc
209 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
210 with (Hbugs_messages.Parse_error _) as e ->
211 Hbugs_messages.respond_exc
212 "parse_error" (Printexc.to_string e) outchan
214 let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
215 only as a value to be sent to broker, local HTTP
216 daemon will listen on "0.0.0.0", port is parsed
217 from My URL though *)
221 ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
223 | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
225 self#showDialog (sprintf "Can't start local HTTP daemon: %s"
226 (Printexc.to_string e))
228 ignore (Thread.create thread ())
230 method testLocalHttpDaemon () =
233 Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
237 (* self#showDialog msg *)
239 | Hbugs_misc.Malformed_URL url ->
242 "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
244 | Hbugs_misc.Malformed_HTTP_response res ->
247 "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
249 | (Unix.Unix_error _) as e ->
252 "Handshake with local HTTP daemon failed, can't connect: \"%s\""
253 (Printexc.to_string e))
255 method testBroker () =
256 self#sendReq ~msg:Help
262 "Handshake with HBugs Broker failed, unexpected message:\n%s"
263 (Hbugs_messages.string_of_msg unexpected_msg)))
265 method registerClient () =
266 self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
268 | Client_registered broker_id ->
269 brokerId <- Some broker_id;
272 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
276 (sprintf "Client NOT registered, unexpected message:\n%s"
277 (Hbugs_messages.string_of_msg unexpected_msg)))
279 method unregisterClient () =
280 self#sendReq ~msg:(Unregister_client myOwnId)
283 method stateChange () =
284 let state = (* TODO fill with a real state representation! *)
285 mainWindow#stateText#get_chars 0 (mainWindow#stateText#length)
287 self#sendReq ~msg:(State_change (myOwnId, state))
290 method private listTutors () =
291 self#sendReq ~msg:(List_tutors myOwnId)
293 | Tutor_list (_, descriptions) ->
294 selectedTutors <- [];
295 subscribeWindow#tutorsCList#clear ();
298 ignore (subscribeWindow#tutorsCList#append [id; dsc]))
302 (sprintf "Can't list tutors, unexpected message:\n%s"
303 (Hbugs_messages.string_of_msg unexpected_msg)))
305 method private subscribe () =
306 let selectedTutors = List.sort compare selectedTutors in
307 self#sendReq ~msg:(Subscribe (myOwnId, selectedTutors))
309 | (Subscribed (_, tutors)) as msg ->
310 let msg_string = Hbugs_messages.string_of_msg msg in
311 let subscribedTutors = List.sort compare tutors in
313 if subscribedTutors = selectedTutors then
314 sprintf "Subscription OK\n: %s" msg_string
316 sprintf "Subscription mismatch\n: %s" msg_string
319 subscribeWindow#subscribeWindow#misc#hide ()
322 (sprintf "Subscription FAILED, unexpected message:\n%s"
323 (Hbugs_messages.string_of_msg unexpected_msg)))
325 method useHint () = failwith "useHint: TODO not implemented" (* TODO *)
327 method private quit () =
328 self#unregisterClient ();
331 (** enable/disable debugging *)
332 method private setDebug value = debug <- value
334 method private reconfigDebuggingButtons =
335 List.iter (* debug value changed, reconfigure buttons *)
336 (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
339 method private toggleDebug () =
340 self#setDebug (not debug);
341 self#reconfigDebuggingButtons
346 let client = new hbugsClient in