X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhbugs%2Fclient%2Fhbugs_client.ml;h=4613dbf0d57ddeabe071b299d1576c30cb6cf052;hb=1fb8d0192e1f7ee891c53dc282c9c9f111e63e3c;hp=c7df9e10780838bb09172b62864a46809f3cf5ea;hpb=2db12b2fb1b0846ae2140273aec5ed8df27c9201;p=helm.git diff --git a/helm/hbugs/client/hbugs_client.ml b/helm/hbugs/client/hbugs_client.ml index c7df9e107..4613dbf0d 100644 --- a/helm/hbugs/client/hbugs_client.ml +++ b/helm/hbugs/client/hbugs_client.ml @@ -26,14 +26,115 @@ * http://helm.cs.unibo.it/ *) +open Hbugs_common;; open Hbugs_types;; open Printf;; exception Invalid_URL of string;; -let global_debug = true;; +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 = +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 = @@ -45,95 +146,121 @@ class hbugsClient = object (self) - inherit Gui.hbugsMainWindow () - - val subscribeWindow = new Gui.subscribeWindow () - val messageDialog = new Gui.messageDialog () + 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 - val mutable selectedTutors: tutor_id list = [] + (* 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#setDebug global_debug; *) self#initGui; self#startLocalHttpDaemon (); self#testLocalHttpDaemon (); self#testBroker (); - self#registerClient (); + self#registerToBroker (); self#reconfigDebuggingButtons - method debugButtons = + 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) - [ self#startLocalHttpDaemonButton; self#testLocalHttpDaemonButton; - self#testBrokerButton; self#registerClientButton; - self#unregisterClientButton ] + [ mainWindow#startLocalHttpDaemonButton; + mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ] method private initGui = (* GUI: main window *) - ignore (self#hbugsMainWindow#connect#destroy self#quit); + + (* 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 *) - self#toggleDebuggingMenuItem#set_active debug; - ignore (self#toggleDebuggingMenuItem#connect#toggled self#toggleDebug); + mainWindow#toggleDebuggingMenuItem#set_active debug; + ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled + self#toggleDebug); (* GUI: local HTTP daemon settings *) - ignore (self#clientUrlEntry#connect#changed - (fun _ -> myOwnUrl <- self#clientUrlEntry#text)); - self#clientUrlEntry#set_text myOwnUrl; - ignore (self#startLocalHttpDaemonButton#connect#clicked + ignore (mainWindow#clientUrlEntry#connect#changed + (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text)); + mainWindow#clientUrlEntry#set_text myOwnUrl; + ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked self#startLocalHttpDaemon); - ignore (self#testLocalHttpDaemonButton#connect#clicked + ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked self#testLocalHttpDaemon); (* GUI: broker choice *) - ignore (self#brokerUrlEntry#connect#changed - (fun _ -> brokerUrl <- self#brokerUrlEntry#text)); - self#brokerUrlEntry#set_text brokerUrl; - ignore (self#testBrokerButton#connect#clicked self#testBroker); - self#clientIdLabel#set_text myOwnId; + 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 (self#registerClientButton#connect#clicked self#registerClient); - ignore (self#unregisterClientButton#connect#clicked - self#unregisterClient); + ignore (mainWindow#registerClientButton#connect#clicked + self#registerToBroker); (* GUI: subscriptions *) - ignore (self#showSubscriptionWindowButton#connect#clicked + ignore (mainWindow#showSubscriptionWindowButton#connect#clicked (fun () -> self#listTutors (); subscribeWindow#subscribeWindow#show ())); - (* GUI: DEBUG state change *) - ignore (self#stateChangeButton#connect#clicked self#stateChange); - + 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 (self#useHintButton#connect#clicked self#useHint); + 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 = self#mainWindowStatusBar#new_context "0" in + 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); - 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#subscribe); + 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"); @@ -156,7 +283,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) @@ -167,7 +294,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 @@ -175,8 +302,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 @@ -189,7 +323,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 @@ -197,9 +337,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 (self#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#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 @@ -212,7 +359,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 @@ -222,9 +369,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) @@ -249,7 +396,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 _ -> () @@ -259,89 +406,119 @@ Error: %s" "Handshake with HBugs Broker failed, unexpected message:\n%s" (Hbugs_messages.string_of_msg unexpected_msg))) - method registerClient () = + 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; + | 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 %s registered @ broker %s" myOwnId broker_id) + (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 "Client NOT registered, unexpected message:\n%s" + (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s" (Hbugs_messages.string_of_msg unexpected_msg))) - method unregisterClient () = - self#sendReq ~msg:(Unregister_client myOwnId) - self#showMsgInDialog + method hint = List.nth hints - method stateChange () = - let state = (* TODO fill with a real state representation! *) - self#stateText#get_chars 0 (self#stateText#length) - in - self#sendReq ~msg:(State_change (myOwnId, state)) - self#showMsgInDialog - - method listTutors () = - self#sendReq ~msg:(List_tutors myOwnId) + 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) -> - selectedTutors <- []; - subscribeWindow#tutorsCList#clear (); + 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#tutorsCList#append [id; dsc])) - descriptions + 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))) - method 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#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 useHint () = failwith "useHint: TODO not implemented" (* TODO *) + 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#unregisterClient (); - GMain.Main.quit () + self#unregisterFromBroker (); + destroy_callback () - (** enable/disable debugging buttons *) - method setDebug ?(force = false) value = - if (debug <> value) || force then - debug <- value + (** 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 toggleDebug () = + method private toggleDebug () = self#setDebug (not debug); self#reconfigDebuggingButtons end ;; -ignore (new hbugsClient); -GtkThread.main () -