X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=components%2Fhbugs%2Fhbugs_client.ml;fp=components%2Fhbugs%2Fhbugs_client.ml;h=c7b5fae75dcdf1b888bc0aa2b815c3447b3d9eff;hp=0000000000000000000000000000000000000000;hb=f61af501fb4608cc4fb062a0864c774e677f0d76;hpb=58ae1809c352e71e7b5530dc41e2bfc834e1aef1 diff --git a/components/hbugs/hbugs_client.ml b/components/hbugs/hbugs_client.ml new file mode 100644 index 000000000..c7b5fae75 --- /dev/null +++ b/components/hbugs/hbugs_client.ml @@ -0,0 +1,526 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * for the HELM Team http://helm.cs.unibo.it/ + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Hbugs_common;; +open Hbugs_types;; +open Printf;; + +exception Invalid_URL of string;; + +let do_nothing _ = ();; + +module SmartHbugs_client_gui = + struct + class ['a] oneColumnCList gtree_view ~column_type ~column_title + = + let obj = + ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in + let columns = new GTree.column_list in + let col = columns#add column_type in + let vcol = GTree.view_column ~title:column_title () + ~renderer:(GTree.cell_renderer_text[], ["text",col]) in + let store = GTree.list_store columns in + object(self) + inherit GTree.view obj + method clear = store#clear + method append (v : 'a) = + let row = store#append () in + store#set ~row ~column:col v; + method column = col + initializer + self#set_model (Some (store :> GTree.model)) ; + ignore (self#append_column vcol) + end + + class ['a,'b] twoColumnsCList gtree_view ~column1_type ~column2_type + ~column1_title ~column2_title + = + let obj = + ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in + let columns = new GTree.column_list in + let col1 = columns#add column1_type in + let vcol1 = GTree.view_column ~title:column1_title () + ~renderer:(GTree.cell_renderer_text[], ["text",col1]) in + let col2 = columns#add column2_type in + let vcol2 = GTree.view_column ~title:column2_title () + ~renderer:(GTree.cell_renderer_text[], ["text",col2]) in + let store = GTree.list_store columns in + object(self) + inherit GTree.view obj + method clear = store#clear + method append (v1 : 'a) (v2 : 'b) = + let row = store#append () in + store#set ~row ~column:col1 v1; + store#set ~row ~column:col2 v2 + method column1 = col1 + method column2 = col2 + initializer + self#set_model (Some (store :> GTree.model)) ; + ignore (self#append_column vcol1) ; + ignore (self#append_column vcol2) ; + end + + class subscribeWindow () = + object(self) + inherit Hbugs_client_gui.subscribeWindow () + val mutable tutorsSmartCList = None + method tutorsSmartCList = + match tutorsSmartCList with + None -> assert false + | Some w -> w + initializer + tutorsSmartCList <- + Some + (new twoColumnsCList self#tutorsCList + ~column1_type:Gobject.Data.string ~column2_type:Gobject.Data.string + ~column1_title:"Id" ~column2_title:"Description") + end + + class hbugsMainWindow () = + object(self) + inherit Hbugs_client_gui.hbugsMainWindow () + val mutable subscriptionSmartCList = None + val mutable hintsSmartCList = None + method subscriptionSmartCList = + match subscriptionSmartCList with + None -> assert false + | Some w -> w + method hintsSmartCList = + match hintsSmartCList with + None -> assert false + | Some w -> w + initializer + subscriptionSmartCList <- + Some + (new oneColumnCList self#subscriptionCList + ~column_type:Gobject.Data.string ~column_title:"Description") + initializer + hintsSmartCList <- + Some + (new oneColumnCList self#hintsCList + ~column_type:Gobject.Data.string ~column_title:"Description") + end + + end +;; + +class hbugsClient + ?(use_hint_callback: hint -> unit = do_nothing) + ?(describe_hint_callback: hint -> unit = do_nothing) + ?(destroy_callback: unit -> unit = do_nothing) + () + = + + let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in + let port_of_http_url url = + try + let subs = Pcre.extract ~rex:http_url_RE url in + int_of_string subs.(3) + with e -> raise (Invalid_URL url) + in + + object (self) + + val mainWindow = new SmartHbugs_client_gui.hbugsMainWindow () + val subscribeWindow = new SmartHbugs_client_gui.subscribeWindow () + val messageDialog = new Hbugs_client_gui.messageDialog () + val myOwnId = Hbugs_id_generator.new_client_id () + val mutable use_hint_callback = use_hint_callback + val mutable myOwnUrl = "localhost:49082" + val mutable brokerUrl = "localhost:49081" + val mutable brokerId: broker_id option = None + (* all available tutors, saved last time a List_tutors message was sent to + broker *) + val mutable availableTutors: tutor_dsc list = [] + val mutable statusContext = None + val mutable subscribeWindowStatusContext = None + val mutable debug = false (* enable/disable debugging buttons *) + val mutable hints = [] (* actually available hints *) + + initializer + self#initGui; + self#startLocalHttpDaemon (); + self#testLocalHttpDaemon (); + self#testBroker (); + self#registerToBroker (); + self#reconfigDebuggingButtons + + method show = mainWindow#hbugsMainWindow#show + method hide = mainWindow#hbugsMainWindow#misc#hide + + method setUseHintCallback callback = + use_hint_callback <- callback + + method private debugButtons = + List.map + (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget) + [ mainWindow#startLocalHttpDaemonButton; + mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ] + + method private initGui = + + (* GUI: main window *) + + (* ignore delete events so that hbugs window is closable only using + menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked + *) + + ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true)); + ignore (mainWindow#hbugsMainWindow#event#connect#destroy + (fun _ -> self#quit (); false)); + + (* GUI main window's menu *) + mainWindow#toggleDebuggingMenuItem#set_active debug; + ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled + self#toggleDebug); + + (* GUI: local HTTP daemon settings *) + ignore (mainWindow#clientUrlEntry#connect#changed + (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text)); + mainWindow#clientUrlEntry#set_text myOwnUrl; + ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked + self#startLocalHttpDaemon); + ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked + self#testLocalHttpDaemon); + + (* GUI: broker choice *) + ignore (mainWindow#brokerUrlEntry#connect#changed + (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text)); + mainWindow#brokerUrlEntry#set_text brokerUrl; + ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker); + mainWindow#clientIdLabel#set_text myOwnId; + + (* GUI: client registration *) + ignore (mainWindow#registerClientButton#connect#clicked + self#registerToBroker); + + (* GUI: subscriptions *) + ignore (mainWindow#showSubscriptionWindowButton#connect#clicked + (fun () -> + self#listTutors (); + subscribeWindow#subscribeWindow#show ())); + + let get_selected_row_index () = + match mainWindow#hintsCList#selection#get_selected_rows with + [path] -> + (match GTree.Path.get_indices path with + [|n|] -> n + | _ -> assert false) + | _ -> assert false + in + (* GUI: hints list *) + ignore ( + let event_ops = new GObj.event_ops mainWindow#hintsCList#as_widget in + event_ops#connect#button_press + (fun event -> + if GdkEvent.get_type event = `TWO_BUTTON_PRESS then + use_hint_callback (self#hint (get_selected_row_index ())) ; + false)); + + ignore (mainWindow#hintsCList#selection#connect#changed + (fun () -> + describe_hint_callback (self#hint (get_selected_row_index ())))) ; + + (* GUI: main status bar *) + let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in + statusContext <- Some ctxt; + ignore (ctxt#push "Ready"); + + (* GUI: subscription window *) + subscribeWindow#tutorsCList#selection#set_mode `MULTIPLE; + ignore (subscribeWindow#subscribeWindow#event#connect#delete + (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true)); + ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors); + ignore (subscribeWindow#subscribeButton#connect#clicked + self#subscribeSelected); + ignore (subscribeWindow#subscribeAllButton#connect#clicked + self#subscribeAll); + (subscribeWindow#tutorsCList#get_column 0)#set_visible false; + let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in + subscribeWindowStatusContext <- Some ctxt; + ignore (ctxt#push "Ready"); + + (* GUI: message dialog *) + ignore (messageDialog#messageDialog#event#connect#delete + (fun _ -> messageDialog#messageDialog#misc#hide (); true)); + ignore (messageDialog#okDialogButton#connect#clicked + (fun _ -> messageDialog#messageDialog#misc#hide ())) + + (* accessory methods *) + + (** pop up a (modal) dialog window showing msg to the user *) + method private showDialog msg = + messageDialog#dialogLabel#set_text msg; + messageDialog#messageDialog#show () + (** use showDialog to display an hbugs message to the user *) + method private showMsgInDialog msg = + self#showDialog (Hbugs_messages.string_of_msg msg) + + (** create a new thread which sends msg to broker, wait for an answer and + invoke callback passing response message as argument *) + method private sendReq ?(wait = false) ~msg callback = + let thread () = + try + callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg) + with + | (Hbugs_messages.Parse_error (subj, reason)) as e -> + self#showDialog + (sprintf +"Parse_error, unable to fullfill request. Details follow. +Request: %s +Error: %s" + (Hbugs_messages.string_of_msg msg) (Printexc.to_string e)); + | (Unix.Unix_error _) as e -> + self#showDialog + (sprintf +"Can't connect to HBugs Broker +Url: %s +Error: %s" + brokerUrl (Printexc.to_string e)) + | e -> + self#showDialog + (sprintf "hbugsClient#sendReq: Uncaught exception: %s" + (Printexc.to_string e)) + in + let th = Thread.create thread () in + if wait then + Thread.join th + else () + + (** check if a broker is authenticated using its broker_id + [ Background: during client registration, client save broker_id of its + broker, further messages from broker are accepted only if they carry the + same broker id ] *) + method private isAuthenticated id = + match brokerId with + | None -> false + | Some broker_id -> (id = broker_id) + + (* actions *) + + method private startLocalHttpDaemon = + (* flatten an hint tree to an hint list *) + let rec flatten_hint = function + | Hints hints -> List.concat (List.map flatten_hint hints) + | hint -> [hint] + in + fun () -> + let callback req outchan = + try + (match Hbugs_messages.msg_of_string req#body with + | Help -> + Hbugs_messages.respond_msg + (Usage "Local Http Daemon up and running!") outchan + | Hint (broker_id, hint) -> + if self#isAuthenticated broker_id then begin + let received_hints = flatten_hint hint in + List.iter + (fun h -> + (match h with Hints _ -> assert false | _ -> ()); + ignore(mainWindow#hintsSmartCList#append(string_of_hint h))) + received_hints; + hints <- hints @ received_hints; + Hbugs_messages.respond_msg (Wow myOwnId) outchan + end else (* msg from unauthorized broker *) + Hbugs_messages.respond_exc "forbidden" broker_id outchan + | msg -> + Hbugs_messages.respond_exc + "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan) + with (Hbugs_messages.Parse_error _) as e -> + Hbugs_messages.respond_exc + "parse_error" (Printexc.to_string e) outchan + in + let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used + only as a value to be sent to broker, local HTTP + daemon will listen on "0.0.0.0", port is parsed + from My URL though *) + let httpDaemonThread () = + try + Http_daemon.start' + ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback + with + | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url) + | e -> + self#showDialog (sprintf "Can't start local HTTP daemon: %s" + (Printexc.to_string e)) + in + ignore (Thread.create httpDaemonThread ()) + + method private testLocalHttpDaemon () = + try + let msg = + Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help) + myOwnUrl + in + ignore msg +(* self#showDialog msg *) + with + | Hbugs_misc.Malformed_URL url -> + self#showDialog + (sprintf + "Handshake with local HTTP daemon failed, Invalid URL: \"%s\"" + url) + | Hbugs_misc.Malformed_HTTP_response res -> + self#showDialog + (sprintf + "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\"" + res) + | (Unix.Unix_error _) as e -> + self#showDialog + (sprintf + "Handshake with local HTTP daemon failed, can't connect: \"%s\"" + (Printexc.to_string e)) + + method private testBroker () = + self#sendReq ~msg:Help + (function + | Usage _ -> () + | unexpected_msg -> + self#showDialog + (sprintf + "Handshake with HBugs Broker failed, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method registerToBroker () = + (match brokerId with (* undo previous registration, if any *) + | Some id -> self#unregisterFromBroker () + | _ -> ()); + self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl)) + (function + | Client_registered broker_id -> (brokerId <- Some broker_id) + | unexpected_msg -> + self#showDialog + (sprintf "Client NOT registered, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method unregisterFromBroker () = + self#sendReq ~wait:true ~msg:(Unregister_client myOwnId) + (function + | Client_unregistered _ -> (brokerId <- None) + | unexpected_msg -> ()) +(* + self#showDialog + (sprintf "Client NOT unregistered, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) +*) + + method stateChange new_state = + mainWindow#hintsSmartCList#clear (); + hints <- []; + self#sendReq + ~msg:(State_change (myOwnId, new_state)) + (function + | State_accepted _ -> () + | unexpected_msg -> + self#showDialog + (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method hint = List.nth hints + + method private listTutors () = + (* wait is set to true just to make sure that after invoking listTutors + "availableTutors" is correctly filled *) + self#sendReq ~wait:true ~msg:(List_tutors myOwnId) + (function + | Tutor_list (_, descriptions) -> + availableTutors <- (* sort accordingly to tutor description *) + List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions; + subscribeWindow#tutorsSmartCList#clear (); + List.iter + (fun (id, dsc) -> + ignore (subscribeWindow#tutorsSmartCList#append id dsc)) + availableTutors + | unexpected_msg -> + self#showDialog + (sprintf "Can't list tutors, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + (* low level used by subscribeSelected and subscribeAll *) + method private subscribe' tutors_id = + self#sendReq ~msg:(Subscribe (myOwnId, tutors_id)) + (function + | (Subscribed (_, subscribedTutors)) as msg -> + let sort = List.sort compare in + mainWindow#subscriptionSmartCList#clear (); + List.iter + (fun tutor_id -> + ignore + (mainWindow#subscriptionSmartCList#append + ( try + List.assoc tutor_id availableTutors + with Not_found -> assert false ))) + tutors_id; + subscribeWindow#subscribeWindow#misc#hide (); + if sort subscribedTutors <> sort tutors_id then + self#showDialog + (sprintf "Subscription mismatch\n: %s" + (Hbugs_messages.string_of_msg msg)) + | unexpected_msg -> + mainWindow#subscriptionSmartCList#clear (); + self#showDialog + (sprintf "Subscription FAILED, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method private subscribeSelected () = + let tutorsSmartCList = subscribeWindow#tutorsSmartCList in + let selectedTutors = + List.map + (fun p -> + tutorsSmartCList#model#get + ~row:(tutorsSmartCList#model#get_iter p) + ~column:tutorsSmartCList#column1) + tutorsSmartCList#selection#get_selected_rows + in + self#subscribe' selectedTutors + + method subscribeAll () = + self#listTutors (); (* this fills 'availableTutors' field *) + self#subscribe' (List.map fst availableTutors) + + method private quit () = + self#unregisterFromBroker (); + destroy_callback () + + (** enable/disable debugging *) + method private setDebug value = debug <- value + + method private reconfigDebuggingButtons = + List.iter (* debug value changed, reconfigure buttons *) + (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ()) + self#debugButtons; + + method private toggleDebug () = + self#setDebug (not debug); + self#reconfigDebuggingButtons + + end +;; +