+++ /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/
- *)
-
-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