X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Fhbugs%2Fclient%2Fhbugs_client.ml;fp=helm%2Fhbugs%2Fclient%2Fhbugs_client.ml;h=0000000000000000000000000000000000000000;hp=d9512d26cfcbf732dc7ec2ab194837fdf58d0a2a;hb=3ef089a4c58fbe429dd539af6215991ecbe11ee2;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff diff --git a/helm/hbugs/client/hbugs_client.ml b/helm/hbugs/client/hbugs_client.ml deleted file mode 100644 index d9512d26c..000000000 --- a/helm/hbugs/client/hbugs_client.ml +++ /dev/null @@ -1,414 +0,0 @@ -(* - * 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/ - *) - -open Hbugs_common;; -open Hbugs_types;; -open Printf;; - -exception Invalid_URL of string;; - -let global_debug = true;; - - (** - @param on_use_hint function invoked when an hint is used, argumnet is the hint - to use - @param on_exit function invoked when client is exiting (e.g. window is - destroyed, if it's None "self#quit" is invoked - *) -class hbugsClient - ?(use_hint_callback: hint -> unit = (fun _ -> ())) - () - = - - 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 Hbugs_client_gui.hbugsMainWindow () - val subscribeWindow = new Hbugs_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 = [] - (* id of highlighted tutors in tutor subscription window *) - val mutable selectedTutors: tutor_id 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; - mainWindow#registerClientButton; mainWindow#unregisterClientButton ] - - method private initGui = - - (* GUI: main window *) - let on_exit = fun () -> self#quit (); false in - ignore (mainWindow#hbugsMainWindow#event#connect#destroy - (fun _ -> on_exit ())); - ignore (mainWindow#hbugsMainWindow#event#connect#delete - (fun _ -> on_exit ())); - - (* 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); - ignore (mainWindow#unregisterClientButton#connect#clicked - self#unregisterFromBroker); - - (* GUI: subscriptions *) - ignore (mainWindow#showSubscriptionWindowButton#connect#clicked - (fun () -> - self#listTutors (); - subscribeWindow#subscribeWindow#show ())); - - (* GUI: hints list *) - ignore (mainWindow#hintsCList#connect#select_row - (fun ~row ~column ~event -> - match event with - | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS -> - use_hint_callback (self#hint row) - | _ -> ())); - - (* GUI: main status bar *) - let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in - statusContext <- Some ctxt; - ignore (ctxt#push "Ready"); - - (* GUI: subscription window *) - ignore (subscribeWindow#subscribeWindow#event#connect#delete - (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true)); - ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors); - let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in - ignore (subscribeWindow#tutorsCList#connect#select_row - (fun ~row ~column ~event -> - selectedTutors <- tutor_id_of_row row :: selectedTutors)); - ignore (subscribeWindow#tutorsCList#connect#unselect_row - (fun ~row ~column ~event -> - selectedTutors <- - List.filter ((<>) (tutor_id_of_row row)) selectedTutors)); - ignore (subscribeWindow#subscribeButton#connect#clicked - self#subscribeSelected); - ignore (subscribeWindow#subscribeAllButton#connect#clicked - self#subscribeAll); - 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#hintsCList#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 () = - self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl)) - (function - | Client_registered broker_id -> - brokerId <- Some broker_id; -(* - self#showDialog - (sprintf "Client %s registered @ broker %s" myOwnId 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) - self#showMsgInDialog - - method stateChange new_state = - self#sendReq - ~msg:(State_change (myOwnId, new_state)) - (function - | State_accepted _ -> - mainWindow#hintsCList#clear (); - hints <- [] - | 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; - selectedTutors <- []; - subscribeWindow#tutorsCList#clear (); - List.iter - (fun (id, dsc) -> - ignore (subscribeWindow#tutorsCList#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#subscriptionCList#clear (); - List.iter - (fun tutor_id -> - ignore - (mainWindow#subscriptionCList#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#subscriptionCList#clear (); - self#showDialog - (sprintf "Subscription FAILED, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) - - method private subscribeSelected () = self#subscribe' selectedTutors - - method subscribeAll () = - self#listTutors (); (* this fills 'availableTutors' field *) - self#subscribe' (List.map fst availableTutors) - - method private quit () = - self#unregisterFromBroker (); - GMain.Main.quit () - - (** 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 -;; -