--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * 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
+;;
+
projects / helm.git / blobdiff