]> matita.cs.unibo.it Git - helm.git/blob - helm/software/components/hbugs/hbugs_client.ml
handles bad Appl
[helm.git] / helm / software / components / hbugs / hbugs_client.ml
1 (*
2  * Copyright (C) 2003:
3  *    Stefano Zacchiroli <zack@cs.unibo.it>
4  *    for the HELM Team http://helm.cs.unibo.it/
5  *
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.
9  *
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.
14  *
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.
19  *
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,
23  *  MA  02111-1307, USA.
24  *
25  *  For details, see the HELM World-Wide-Web page,
26  *  http://helm.cs.unibo.it/
27  *)
28
29 (* $Id$ *)
30
31 open Hbugs_common;;
32 open Hbugs_types;;
33 open Printf;;
34
35 exception Invalid_URL of string;;
36
37 let do_nothing _ = ();;
38
39 module SmartHbugs_client_gui =
40  struct
41   class ['a] oneColumnCList gtree_view ~column_type ~column_title
42   =
43    let obj =
44     ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in
45    let columns = new GTree.column_list in
46    let col = columns#add column_type in
47    let vcol = GTree.view_column ~title:column_title ()
48     ~renderer:(GTree.cell_renderer_text[], ["text",col]) in
49    let store = GTree.list_store columns in
50    object(self)
51     inherit GTree.view obj
52     method clear = store#clear
53     method append (v : 'a) =
54      let row = store#append () in
55       store#set ~row ~column:col v;
56     method column = col
57     initializer
58      self#set_model (Some (store :> GTree.model)) ;
59      ignore (self#append_column vcol)
60    end
61
62   class ['a,'b] twoColumnsCList gtree_view ~column1_type ~column2_type
63    ~column1_title ~column2_title
64   =
65    let obj =
66     ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in
67    let columns = new GTree.column_list in
68    let col1 = columns#add column1_type in
69    let vcol1 = GTree.view_column ~title:column1_title ()
70     ~renderer:(GTree.cell_renderer_text[], ["text",col1]) in
71    let col2 = columns#add column2_type in
72    let vcol2 = GTree.view_column ~title:column2_title ()
73     ~renderer:(GTree.cell_renderer_text[], ["text",col2]) in
74    let store = GTree.list_store columns in
75    object(self)
76     inherit GTree.view obj
77     method clear = store#clear
78     method append (v1 : 'a) (v2 : 'b) =
79      let row = store#append () in
80       store#set ~row ~column:col1 v1;
81       store#set ~row ~column:col2 v2
82     method column1 = col1
83     method column2 = col2
84     initializer
85      self#set_model (Some (store :> GTree.model)) ;
86      ignore (self#append_column vcol1) ;
87      ignore (self#append_column vcol2) ;
88    end
89
90   class subscribeWindow () =
91    object(self)
92     inherit Hbugs_client_gui.subscribeWindow ()
93     val mutable tutorsSmartCList = None
94     method tutorsSmartCList =
95      match tutorsSmartCList with
96         None -> assert false
97       | Some w -> w
98     initializer
99      tutorsSmartCList <-
100       Some
101        (new twoColumnsCList self#tutorsCList
102          ~column1_type:Gobject.Data.string ~column2_type:Gobject.Data.string
103          ~column1_title:"Id" ~column2_title:"Description")
104    end
105
106   class hbugsMainWindow () =
107    object(self)
108     inherit Hbugs_client_gui.hbugsMainWindow ()
109     val mutable subscriptionSmartCList = None
110     val mutable hintsSmartCList = None
111     method subscriptionSmartCList =
112      match subscriptionSmartCList with
113         None -> assert false
114       | Some w -> w
115     method hintsSmartCList =
116      match hintsSmartCList with
117         None -> assert false
118       | Some w -> w
119     initializer
120      subscriptionSmartCList <-
121       Some
122        (new oneColumnCList self#subscriptionCList
123          ~column_type:Gobject.Data.string ~column_title:"Description")
124     initializer
125      hintsSmartCList <-
126       Some
127        (new oneColumnCList self#hintsCList
128          ~column_type:Gobject.Data.string ~column_title:"Description")
129    end
130
131  end
132 ;;
133
134 class hbugsClient
135   ?(use_hint_callback: hint -> unit = do_nothing)
136   ?(describe_hint_callback: hint -> unit = do_nothing)
137   ?(destroy_callback: unit -> unit = do_nothing)
138   ()
139   =
140
141   let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
142   let port_of_http_url url =
143     try
144       let subs = Pcre.extract ~rex:http_url_RE url in
145       int_of_string subs.(3)
146     with e -> raise (Invalid_URL url)
147   in
148
149   object (self)
150
151     val mainWindow = new SmartHbugs_client_gui.hbugsMainWindow ()
152     val subscribeWindow = new SmartHbugs_client_gui.subscribeWindow ()
153     val messageDialog = new Hbugs_client_gui.messageDialog ()
154     val myOwnId = Hbugs_id_generator.new_client_id ()
155     val mutable use_hint_callback = use_hint_callback
156     val mutable myOwnUrl = "localhost:49082"
157     val mutable brokerUrl = "localhost:49081"
158     val mutable brokerId: broker_id option = None
159       (* all available tutors, saved last time a List_tutors message was sent to
160       broker *)
161     val mutable availableTutors: tutor_dsc list = []
162     val mutable statusContext = None
163     val mutable subscribeWindowStatusContext = None
164     val mutable debug = false (* enable/disable debugging buttons *)
165     val mutable hints = []  (* actually available hints *)
166
167     initializer
168       self#initGui;
169       self#startLocalHttpDaemon ();
170       self#testLocalHttpDaemon ();
171       self#testBroker ();
172       self#registerToBroker ();
173       self#reconfigDebuggingButtons
174
175     method show = mainWindow#hbugsMainWindow#show
176     method hide = mainWindow#hbugsMainWindow#misc#hide
177
178     method setUseHintCallback callback =
179      use_hint_callback <- callback
180
181     method private debugButtons =
182       List.map
183         (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
184         [ mainWindow#startLocalHttpDaemonButton;
185         mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ]
186
187     method private initGui =
188
189         (* GUI: main window *)
190
191           (* ignore delete events so that hbugs window is closable only using
192           menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked
193           *)
194
195       ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true));
196       ignore (mainWindow#hbugsMainWindow#event#connect#destroy
197         (fun _ -> self#quit (); false));
198
199         (* GUI main window's menu *)
200       mainWindow#toggleDebuggingMenuItem#set_active debug;
201       ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
202         self#toggleDebug);
203
204         (* GUI: local HTTP daemon settings *)
205       ignore (mainWindow#clientUrlEntry#connect#changed
206         (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
207       mainWindow#clientUrlEntry#set_text myOwnUrl;
208       ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
209         self#startLocalHttpDaemon);
210       ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
211         self#testLocalHttpDaemon);
212
213         (* GUI: broker choice *)
214       ignore (mainWindow#brokerUrlEntry#connect#changed
215         (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
216       mainWindow#brokerUrlEntry#set_text brokerUrl;
217       ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
218       mainWindow#clientIdLabel#set_text myOwnId;
219
220         (* GUI: client registration *)
221       ignore (mainWindow#registerClientButton#connect#clicked
222         self#registerToBroker);
223
224         (* GUI: subscriptions *)
225       ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
226         (fun () ->
227           self#listTutors ();
228           subscribeWindow#subscribeWindow#show ()));
229
230       let get_selected_row_index () =
231        match mainWindow#hintsCList#selection#get_selected_rows with
232           [path] ->
233             (match GTree.Path.get_indices path with
234                 [|n|] -> n
235               | _ -> assert false)
236         | _ -> assert false
237       in
238         (* GUI: hints list *)
239       ignore (
240        let event_ops = new GObj.event_ops mainWindow#hintsCList#as_widget in
241         event_ops#connect#button_press
242          (fun event ->
243            if GdkEvent.get_type event = `TWO_BUTTON_PRESS then
244             use_hint_callback (self#hint (get_selected_row_index ())) ;
245            false));
246
247       ignore (mainWindow#hintsCList#selection#connect#changed
248        (fun () ->
249          describe_hint_callback (self#hint (get_selected_row_index ())))) ;
250
251         (* GUI: main status bar *)
252       let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
253       statusContext <- Some ctxt;
254       ignore (ctxt#push "Ready");
255
256         (* GUI: subscription window *)
257       subscribeWindow#tutorsCList#selection#set_mode `MULTIPLE;
258       ignore (subscribeWindow#subscribeWindow#event#connect#delete
259         (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
260       ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
261       ignore (subscribeWindow#subscribeButton#connect#clicked
262         self#subscribeSelected);
263       ignore (subscribeWindow#subscribeAllButton#connect#clicked
264         self#subscribeAll);
265       (subscribeWindow#tutorsCList#get_column 0)#set_visible false;
266       let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
267       subscribeWindowStatusContext <- Some ctxt;
268       ignore (ctxt#push "Ready");
269
270         (* GUI: message dialog *)
271       ignore (messageDialog#messageDialog#event#connect#delete
272         (fun _ -> messageDialog#messageDialog#misc#hide (); true));
273       ignore (messageDialog#okDialogButton#connect#clicked
274         (fun _ -> messageDialog#messageDialog#misc#hide ()))
275
276     (* accessory methods *)
277
278       (** pop up a (modal) dialog window showing msg to the user *)
279     method private showDialog msg =
280       messageDialog#dialogLabel#set_text msg;
281       messageDialog#messageDialog#show ()
282       (** use showDialog to display an hbugs message to the user *)
283     method private showMsgInDialog msg =
284       self#showDialog (Hbugs_messages.string_of_msg msg)
285
286       (** create a new thread which sends msg to broker, wait for an answer and
287       invoke callback passing response message as argument *)
288     method private sendReq ?(wait = false) ~msg callback =
289       let thread () =
290         try
291           callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
292         with 
293         | (Hbugs_messages.Parse_error (subj, reason)) as e ->
294             self#showDialog
295               (sprintf
296 "Parse_error, unable to fullfill request. Details follow.
297 Request: %s
298 Error: %s"
299                 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
300         | (Unix.Unix_error _) as e ->
301             self#showDialog
302               (sprintf
303 "Can't connect to HBugs Broker
304 Url: %s
305 Error: %s"
306                 brokerUrl (Printexc.to_string e))
307         | e ->
308             self#showDialog
309               (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
310                 (Printexc.to_string e))
311       in
312       let th = Thread.create thread () in
313       if wait then
314         Thread.join th
315       else ()
316
317       (** check if a broker is authenticated using its broker_id
318       [ Background: during client registration, client save broker_id of its
319       broker, further messages from broker are accepted only if they carry the
320       same broker id ] *)
321     method private isAuthenticated id =
322       match brokerId with
323       | None -> false
324       | Some broker_id -> (id = broker_id)
325
326     (* actions *)
327
328     method private startLocalHttpDaemon =
329         (* flatten an hint tree to an hint list *)
330       let rec flatten_hint = function
331         | Hints hints -> List.concat (List.map flatten_hint hints)
332         | hint -> [hint]
333       in
334       fun () ->
335       let callback req outchan =
336         try
337           (match Hbugs_messages.msg_of_string req#body with
338           | Help ->
339               Hbugs_messages.respond_msg
340                 (Usage "Local Http Daemon up and running!") outchan
341           | Hint (broker_id, hint) ->
342               if self#isAuthenticated broker_id then begin
343                 let received_hints = flatten_hint hint in
344                 List.iter
345                   (fun h ->
346                     (match h with Hints _ -> assert false | _ -> ());
347                     ignore(mainWindow#hintsSmartCList#append(string_of_hint h)))
348                   received_hints;
349                 hints <- hints @ received_hints;
350                 Hbugs_messages.respond_msg (Wow myOwnId) outchan
351               end else  (* msg from unauthorized broker *)
352                 Hbugs_messages.respond_exc "forbidden" broker_id outchan
353           | msg ->
354               Hbugs_messages.respond_exc
355                 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
356         with (Hbugs_messages.Parse_error _) as e ->
357           Hbugs_messages.respond_exc
358             "parse_error" (Printexc.to_string e) outchan
359       in
360       let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
361                               only as a value to be sent to broker, local HTTP
362                               daemon will listen on "0.0.0.0", port is parsed
363                               from My URL though *)
364       let httpDaemonThread () =
365         try
366           Http_daemon.start'
367             ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
368         with
369         | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
370         | e ->
371             self#showDialog (sprintf "Can't start local HTTP daemon: %s"
372               (Printexc.to_string e))
373       in
374       ignore (Thread.create httpDaemonThread ())
375
376     method private testLocalHttpDaemon () =
377       try
378         let msg =
379           Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
380             myOwnUrl
381         in
382         ignore msg
383 (*         self#showDialog msg *)
384       with
385       | Hbugs_misc.Malformed_URL url ->
386           self#showDialog
387             (sprintf
388               "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
389               url)
390       | Hbugs_misc.Malformed_HTTP_response res ->
391           self#showDialog
392             (sprintf
393     "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
394               res)
395       | (Unix.Unix_error _) as e ->
396           self#showDialog
397             (sprintf
398               "Handshake with local HTTP daemon failed, can't connect: \"%s\""
399               (Printexc.to_string e))
400
401     method private testBroker () =
402       self#sendReq ~msg:Help
403         (function
404           | Usage _ -> ()
405           | unexpected_msg ->
406               self#showDialog
407                 (sprintf
408                   "Handshake with HBugs Broker failed, unexpected message:\n%s"
409                   (Hbugs_messages.string_of_msg unexpected_msg)))
410
411     method registerToBroker () =
412       (match brokerId with  (* undo previous registration, if any *)
413       | Some id -> self#unregisterFromBroker ()
414       | _ -> ());
415       self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
416         (function
417           | Client_registered broker_id -> (brokerId <- Some broker_id)
418           | unexpected_msg ->
419               self#showDialog
420                 (sprintf "Client NOT registered, unexpected message:\n%s"
421                   (Hbugs_messages.string_of_msg unexpected_msg)))
422
423     method unregisterFromBroker () =
424       self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
425         (function
426           | Client_unregistered _ -> (brokerId <- None)
427           | unexpected_msg -> ())
428 (*
429               self#showDialog
430                 (sprintf "Client NOT unregistered, unexpected message:\n%s"
431                   (Hbugs_messages.string_of_msg unexpected_msg)))
432 *)
433
434     method stateChange new_state =
435       mainWindow#hintsSmartCList#clear ();
436       hints <- [];
437       self#sendReq
438         ~msg:(State_change (myOwnId, new_state))
439         (function
440           | State_accepted _ -> ()
441           | unexpected_msg ->
442               self#showDialog
443                 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
444                   (Hbugs_messages.string_of_msg unexpected_msg)))
445
446     method hint = List.nth hints
447
448     method private listTutors () =
449         (* wait is set to true just to make sure that after invoking listTutors
450         "availableTutors" is correctly filled *)
451       self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
452         (function
453           | Tutor_list (_, descriptions) ->
454               availableTutors <-  (* sort accordingly to tutor description *)
455                 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
456               subscribeWindow#tutorsSmartCList#clear ();
457               List.iter
458                 (fun (id, dsc) ->
459                   ignore (subscribeWindow#tutorsSmartCList#append id dsc))
460                 availableTutors
461           | unexpected_msg ->
462               self#showDialog
463                 (sprintf "Can't list tutors, unexpected message:\n%s"
464                   (Hbugs_messages.string_of_msg unexpected_msg)))
465
466       (* low level used by subscribeSelected and subscribeAll *)
467     method private subscribe' tutors_id =
468       self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
469         (function
470           | (Subscribed (_, subscribedTutors)) as msg ->
471               let sort = List.sort compare in
472               mainWindow#subscriptionSmartCList#clear ();
473               List.iter
474                 (fun tutor_id ->
475                   ignore
476                     (mainWindow#subscriptionSmartCList#append
477                       ( try
478                           List.assoc tutor_id availableTutors
479                         with Not_found -> assert false )))
480                 tutors_id;
481               subscribeWindow#subscribeWindow#misc#hide ();
482               if sort subscribedTutors <> sort tutors_id then
483                 self#showDialog
484                   (sprintf "Subscription mismatch\n: %s"
485                     (Hbugs_messages.string_of_msg msg))
486           | unexpected_msg ->
487               mainWindow#subscriptionSmartCList#clear ();
488               self#showDialog
489                 (sprintf "Subscription FAILED, unexpected message:\n%s"
490                   (Hbugs_messages.string_of_msg unexpected_msg)))
491
492     method private subscribeSelected () =
493      let tutorsSmartCList = subscribeWindow#tutorsSmartCList in
494      let selectedTutors =
495        List.map
496         (fun p ->
497           tutorsSmartCList#model#get
498            ~row:(tutorsSmartCList#model#get_iter p)
499            ~column:tutorsSmartCList#column1)
500         tutorsSmartCList#selection#get_selected_rows
501      in
502       self#subscribe' selectedTutors
503
504     method subscribeAll () =
505       self#listTutors ();  (* this fills 'availableTutors' field *)
506       self#subscribe' (List.map fst availableTutors)
507
508     method private quit () =
509       self#unregisterFromBroker ();
510       destroy_callback ()
511
512       (** enable/disable debugging *)
513     method private setDebug value = debug <- value
514
515     method private reconfigDebuggingButtons =
516       List.iter (* debug value changed, reconfigure buttons *)
517         (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
518         self#debugButtons;
519     
520     method private toggleDebug () =
521       self#setDebug (not debug);
522       self#reconfigDebuggingButtons
523
524   end
525 ;;
526