* 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 _ = ();;
-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 =
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 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#registerClient ();
+ 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 ]
+ mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ]
method private initGui =
(* GUI: main window *)
- ignore (mainWindow#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 *)
mainWindow#toggleDebuggingMenuItem#set_active debug;
(* GUI: client registration *)
ignore (mainWindow#registerClientButton#connect#clicked
- self#registerClient);
- ignore (mainWindow#unregisterClientButton#connect#clicked
- self#unregisterClient);
+ self#registerToBroker);
(* GUI: subscriptions *)
ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
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 ->
+ use_hint_callback (self#hint row)
+ | Some event ->
+ describe_hint_callback (self#hint row)
+ | _ -> ()));
(* GUI: main status bar *)
let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
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));
+ let new_id = tutor_id_of_row row in
+ match selectedTutors with
+ | hd :: _ when hd = new_id -> () (* avoid double select events *)
+ | _ -> 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#set_column ~visibility:false 0;
let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
subscribeWindowStatusContext <- Some ctxt;
ignore (ctxt#push "Ready");
(** 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)
"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
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
(* 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
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
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
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)
"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 _ -> ()
"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#hintsCList#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 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 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 ();
- GMain.Main.quit ()
+ self#unregisterFromBroker ();
+ destroy_callback ()
(** enable/disable debugging *)
method private setDebug value = debug <- value
end
;;
-let client = new hbugsClient in
-client#show ();
-GtkThread.main ()
-