From 594ea125d8bdd2c0a210e4b2170b0c725075d597 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Wed, 19 Feb 2003 13:59:06 +0000 Subject: [PATCH] - added callbacks parameters to hbugsClient constructor (on_exit, on_use_hint) - hid methods used to handle local http daemon - added and exposed methods registerToBroker, unregisterFromBroker, subscribeAll - removed useHint, hint are returned on request by "hint" new method - remeber availableTutors from last List_tutor message and use them to show tutors name instead of tutor id in main window - handle double click on hint name to use an hint - added wait parameter sendReq method to be able to wait the answer of a request - added support for multiple hints received from broker - clear old hints on state change - subscribe to all available tutors on creation - added subscribeSelected method --- helm/hbugs/client/hbugs_client.ml | 176 ++++++++++++++++++++--------- helm/hbugs/client/hbugs_client.mli | 26 +++-- 2 files changed, 136 insertions(+), 66 deletions(-) diff --git a/helm/hbugs/client/hbugs_client.ml b/helm/hbugs/client/hbugs_client.ml index f4fb94dd4..4a31f9a13 100644 --- a/helm/hbugs/client/hbugs_client.ml +++ b/helm/hbugs/client/hbugs_client.ml @@ -26,6 +26,7 @@ * http://helm.cs.unibo.it/ *) +open Hbugs_common;; open Hbugs_types;; open Printf;; @@ -33,7 +34,17 @@ exception Invalid_URL of string;; let global_debug = true;; -class hbugsClient = + (** + @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 = @@ -45,24 +56,29 @@ class hbugsClient = object (self) - val mainWindow = new Gui.hbugsMainWindow () - val subscribeWindow = new Gui.subscribeWindow () - val messageDialog = new Gui.messageDialog () + 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#registerClient (); + self#registerToBroker (); self#reconfigDebuggingButtons method show = mainWindow#hbugsMainWindow#show @@ -78,7 +94,15 @@ class hbugsClient = method private initGui = (* GUI: main window *) - ignore (mainWindow#hbugsMainWindow#connect#destroy self#quit); + 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; @@ -103,9 +127,9 @@ class hbugsClient = (* GUI: client registration *) ignore (mainWindow#registerClientButton#connect#clicked - self#registerClient); + self#registerToBroker); ignore (mainWindow#unregisterClientButton#connect#clicked - self#unregisterClient); + self#unregisterFromBroker); (* GUI: subscriptions *) ignore (mainWindow#showSubscriptionWindowButton#connect#clicked @@ -113,11 +137,13 @@ class hbugsClient = self#listTutors (); subscribeWindow#subscribeWindow#show ())); - (* GUI: DEBUG state change *) - ignore (mainWindow#stateChangeButton#connect#clicked self#stateChange); - (* GUI: hints list *) - ignore (mainWindow#useHintButton#connect#clicked self#useHint); + 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 @@ -136,7 +162,10 @@ class hbugsClient = (fun ~row ~column ~event -> selectedTutors <- List.filter ((<>) (tutor_id_of_row row)) selectedTutors)); - ignore (subscribeWindow#subscribeButton#connect#clicked self#subscribe); + 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"); @@ -159,7 +188,7 @@ class hbugsClient = (** create a new thread which sends msg to broker, wait for an answer and invoke callback passing response message as argument *) - method private sendReq ~msg callback = + method private sendReq ?(wait = false) ~msg callback = let thread () = try callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg) @@ -170,7 +199,7 @@ class hbugsClient = "Parse_error, unable to fullfill request. Details follow. Request: %s Error: %s" - (Hbugs_messages.string_of_msg msg) (Printexc.to_string e)) + (Hbugs_messages.string_of_msg msg) (Printexc.to_string e)); | (Unix.Unix_error _) as e -> self#showDialog (sprintf @@ -178,8 +207,15 @@ Error: %s" Url: %s Error: %s" brokerUrl (Printexc.to_string e)) + | e -> + self#showDialog + (sprintf "hbugsClient#sendReq: Uncaught exception: %s" + (Printexc.to_string e)) in - ignore (Thread.create thread ()) + 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 @@ -192,7 +228,13 @@ Error: %s" (* actions *) - method startLocalHttpDaemon () = + 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 @@ -200,9 +242,16 @@ Error: %s" Hbugs_messages.respond_msg (Usage "Local Http Daemon up and running!") outchan | Hint (broker_id, hint) -> - if self#isAuthenticated broker_id then - ignore (mainWindow#hintsCList#append [hint]) - else + 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 @@ -215,7 +264,7 @@ Error: %s" 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 thread () = + let httpDaemonThread () = try Http_daemon.start' ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback @@ -225,9 +274,9 @@ Error: %s" self#showDialog (sprintf "Can't start local HTTP daemon: %s" (Printexc.to_string e)) in - ignore (Thread.create thread ()) + ignore (Thread.create httpDaemonThread ()) - method testLocalHttpDaemon () = + method private testLocalHttpDaemon () = try let msg = Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help) @@ -252,7 +301,7 @@ Error: %s" "Handshake with local HTTP daemon failed, can't connect: \"%s\"" (Printexc.to_string e)) - method testBroker () = + method private testBroker () = self#sendReq ~msg:Help (function | Usage _ -> () @@ -262,7 +311,7 @@ Error: %s" "Handshake with HBugs Broker failed, unexpected message:\n%s" (Hbugs_messages.string_of_msg unexpected_msg))) - method registerClient () = + method registerToBroker () = self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl)) (function | Client_registered broker_id -> @@ -276,56 +325,77 @@ Error: %s" (sprintf "Client NOT registered, unexpected message:\n%s" (Hbugs_messages.string_of_msg unexpected_msg))) - method unregisterClient () = - self#sendReq ~msg:(Unregister_client myOwnId) + method unregisterFromBroker () = + self#sendReq ~wait:true ~msg:(Unregister_client myOwnId) self#showMsgInDialog - method stateChange () = - let state = (* TODO fill with a real state representation! *) - mainWindow#stateText#get_chars 0 (mainWindow#stateText#length) - in - self#sendReq ~msg:(State_change (myOwnId, state)) - 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 () = - self#sendReq ~msg:(List_tutors myOwnId) + (* 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])) - descriptions + availableTutors | unexpected_msg -> self#showDialog (sprintf "Can't list tutors, unexpected message:\n%s" (Hbugs_messages.string_of_msg unexpected_msg))) - method private subscribe () = - let selectedTutors = List.sort compare selectedTutors in - self#sendReq ~msg:(Subscribe (myOwnId, selectedTutors)) + (* low level used by subscribeSelected and subscribeAll *) + method private subscribe' tutors_id = + self#sendReq ~msg:(Subscribe (myOwnId, tutors_id)) (function - | (Subscribed (_, tutors)) as msg -> - let msg_string = Hbugs_messages.string_of_msg msg in - let subscribedTutors = List.sort compare tutors in - let msg = - if subscribedTutors = selectedTutors then - sprintf "Subscription OK\n: %s" msg_string - else - sprintf "Subscription mismatch\n: %s" msg_string - in - self#showDialog msg; - subscribeWindow#subscribeWindow#misc#hide () + | (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 useHint () = failwith "useHint: TODO not implemented" (* TODO *) + method private subscribeSelected () = self#subscribe' selectedTutors + + method subscribeAll () = + self#listTutors (); (* this fills 'availableTutors' field *) + self#subscribe' (List.map fst availableTutors) method private quit () = - self#unregisterClient (); + self#unregisterFromBroker (); GMain.Main.quit () (** enable/disable debugging *) @@ -343,7 +413,3 @@ Error: %s" end ;; -let client = new hbugsClient in -client#show (); -GtkThread.main () - diff --git a/helm/hbugs/client/hbugs_client.mli b/helm/hbugs/client/hbugs_client.mli index edf0127bd..3bc34a8e2 100644 --- a/helm/hbugs/client/hbugs_client.mli +++ b/helm/hbugs/client/hbugs_client.mli @@ -1,21 +1,25 @@ +open Hbugs_types + exception Invalid_URL of string class hbugsClient : - object + on_use_hint: (hint -> unit) -> + ?on_exit: (unit -> unit) -> + unit -> + object - method show : unit -> unit - method hide : unit -> unit + method show : unit -> unit + method hide : unit -> unit - method startLocalHttpDaemon : unit -> unit - method testLocalHttpDaemon : unit -> unit + method registerToBroker : unit -> unit + method unregisterFromBroker : unit -> unit + method subscribeAll : unit -> unit - method registerClient : unit -> unit - method unregisterClient : unit -> unit - method testBroker : unit -> unit + method stateChange : state -> unit - method stateChange : unit -> unit - method useHint : unit -> unit + (** @return an hint by index *) + method hint : int -> hint - end + end -- 2.39.2