(* * 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 ~(on_use_hint: hint -> unit) ?(on_exit: (unit -> unit) option) () = 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 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 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 = match on_exit with | None -> (fun () -> self#quit (); false) | Some f -> (fun () -> f (); true) 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 -> on_use_hint (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 ;;