From 2db12b2fb1b0846ae2140273aec5ed8df27c9201 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Fri, 10 Jan 2003 09:06:22 +0000 Subject: [PATCH] first client implementation as a standalone application --- helm/hbugs/client/.cvsignore | 9 + helm/hbugs/client/Makefile | 26 ++ helm/hbugs/client/hbugs_client.ml | 347 +++++++++++++++ helm/hbugs/client/hbugs_gui.glade | 704 ++++++++++++++++++++++++++++++ 4 files changed, 1086 insertions(+) create mode 100644 helm/hbugs/client/.cvsignore create mode 100644 helm/hbugs/client/Makefile create mode 100644 helm/hbugs/client/hbugs_client.ml create mode 100644 helm/hbugs/client/hbugs_gui.glade diff --git a/helm/hbugs/client/.cvsignore b/helm/hbugs/client/.cvsignore new file mode 100644 index 000000000..b2aeedb7d --- /dev/null +++ b/helm/hbugs/client/.cvsignore @@ -0,0 +1,9 @@ +*.cmi +*.cmo +*.cma +*.cmx +*.o +*.a +gui.ml +hbugs_client +hbugs_client.opt diff --git a/helm/hbugs/client/Makefile b/helm/hbugs/client/Makefile new file mode 100644 index 000000000..e96695dbe --- /dev/null +++ b/helm/hbugs/client/Makefile @@ -0,0 +1,26 @@ +NAME = hbugs_client +METADIR = ../meta +REQUIRES = lablgtk threads hbugs-common +PREDICATES = glade init +COMMONOPTS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" +OCAMLC = OCAMLPATH="$(METADIR)" ocamlfind ocamlc $(COMMONOPTS) +OCAMLOPT = OCAMLPATH="$(METADIR)" ocamlfind ocamlopt $(COMMONOPTS) + +all: byte +world: byte opt +byte: $(NAME) +opt: $(NAME).opt + +gui.ml: hbugs_gui.glade + lablgladecc $< > $@ +gui.cmo: gui.ml + $(OCAMLC) -c $< +gui.cmx: gui.ml + $(OCAMLOPT) -c $< +$(NAME): gui.cmo $(NAME).ml + $(OCAMLC) -thread -package threads -linkpkg -o $@ $^ +$(NAME).opt: gui.cmx $(NAME).ml + $(OCAMLOPT) -thread -package threads -linkpkg -o $@ $^ +clean: + rm -f *.cm[aixo] *.cmxa *.[oa] $(NAME){,.opt} gui.ml +.PHONY: all world byte opt clean diff --git a/helm/hbugs/client/hbugs_client.ml b/helm/hbugs/client/hbugs_client.ml new file mode 100644 index 000000000..c7df9e107 --- /dev/null +++ b/helm/hbugs/client/hbugs_client.ml @@ -0,0 +1,347 @@ +(* + * 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_types;; +open Printf;; + +exception Invalid_URL of string;; + +let global_debug = true;; + +class hbugsClient = + + 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) + + inherit Gui.hbugsMainWindow () + + val subscribeWindow = new Gui.subscribeWindow () + val messageDialog = new 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 + val mutable selectedTutors: tutor_id list = [] + val mutable statusContext = None + val mutable subscribeWindowStatusContext = None + val mutable debug = false (* enable/disable debugging buttons *) + + initializer +(* self#setDebug global_debug; *) + self#initGui; + self#startLocalHttpDaemon (); + self#testLocalHttpDaemon (); + self#testBroker (); + self#registerClient (); + self#reconfigDebuggingButtons + + method debugButtons = + List.map + (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget) + [ self#startLocalHttpDaemonButton; self#testLocalHttpDaemonButton; + self#testBrokerButton; self#registerClientButton; + self#unregisterClientButton ] + + method private initGui = + + (* GUI: main window *) + ignore (self#hbugsMainWindow#connect#destroy self#quit); + + (* GUI main window's menu *) + self#toggleDebuggingMenuItem#set_active debug; + ignore (self#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 + self#startLocalHttpDaemon); + ignore (self#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; + + (* GUI: client registration *) + ignore (self#registerClientButton#connect#clicked self#registerClient); + ignore (self#unregisterClientButton#connect#clicked + self#unregisterClient); + + (* GUI: subscriptions *) + ignore (self#showSubscriptionWindowButton#connect#clicked + (fun () -> + self#listTutors (); + subscribeWindow#subscribeWindow#show ())); + + (* GUI: DEBUG state change *) + ignore (self#stateChangeButton#connect#clicked self#stateChange); + + (* GUI: hints list *) + ignore (self#useHintButton#connect#clicked self#useHint); + + (* GUI: main status bar *) + let ctxt = self#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#subscribe); + 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 ~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)) + in + ignore (Thread.create thread ()) + + (** 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 startLocalHttpDaemon () = + 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 + ignore (self#hintsCList#append [hint]) + else + 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 thread () = + 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 thread ()) + + method 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 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 registerClient () = + 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 unregisterClient () = + self#sendReq ~msg:(Unregister_client myOwnId) + self#showMsgInDialog + + 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) + (function + | Tutor_list (_, descriptions) -> + selectedTutors <- []; + subscribeWindow#tutorsCList#clear (); + List.iter + (fun (id, dsc) -> + ignore (subscribeWindow#tutorsCList#append [id; dsc])) + descriptions + | 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)) + (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 () + | unexpected_msg -> + 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 quit () = + self#unregisterClient (); + GMain.Main.quit () + + (** enable/disable debugging buttons *) + method setDebug ?(force = false) value = + if (debug <> value) || force then + 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 () = + self#setDebug (not debug); + self#reconfigDebuggingButtons + + end +;; + +ignore (new hbugsClient); +GtkThread.main () + diff --git a/helm/hbugs/client/hbugs_gui.glade b/helm/hbugs/client/hbugs_gui.glade new file mode 100644 index 000000000..ff2d99cb2 --- /dev/null +++ b/helm/hbugs/client/hbugs_gui.glade @@ -0,0 +1,704 @@ + + + + + hbugs_gui + hbugs_gui + + src + pixmaps + C + False + False + + + + GtkWindow + hbugsMainWindow + Hbugs: your personal proof trainer! + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + False + True + False + + + GtkVBox + vbox1 + False + 0 + + + GtkMenuBar + menubar + GTK_SHADOW_OUT + + 0 + False + False + + + + GtkMenuItem + toolsMenu + + False + + + GtkMenu + toolsMenu_menu + + + GtkCheckMenuItem + toggleDebuggingMenuItem + + False + True + + + + + + + GtkHBox + hbox4 + False + 2 + + 0 + False + False + + + + GtkLabel + label11 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + 0 + False + False + + + + + GtkEntry + clientUrlEntry + Local HTTP daemon URL + True + False + True + 0 + + + 0 + True + True + + + + + GtkButton + startLocalHttpDaemonButton + Start the local HTTP daemon listening on the specified URL + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + GtkButton + testLocalHttpDaemonButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + + GtkVBox + vbox4 + False + 0 + + 0 + False + True + + + + GtkHBox + hbox1 + False + 2 + + 0 + False + False + + + + GtkLabel + label1 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + 0 + False + False + + + + + GtkEntry + brokerUrlEntry + HBugs broker URL + True + False + True + 0 + + + 0 + True + True + + + + + GtkButton + testBrokerButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + + GtkHBox + hbox2 + False + 2 + + 0 + False + False + + + + GtkLabel + label2 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + 0 + False + False + + + + + GtkLabel + clientIdLabel + + GTK_JUSTIFY_LEFT + False + 0.5 + 0.5 + 0 + 0 + + 0 + True + True + + + + + GtkButton + registerClientButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + GtkButton + unregisterClientButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + + + GtkVBox + vbox5 + True + 0 + + 0 + True + True + + + + GtkFrame + frame3 + 4 + + 0 + GTK_SHADOW_ETCHED_IN + + 0 + True + True + + + + GtkVBox + vbox7 + False + 0 + + + GtkScrolledWindow + scrolledwindow3 + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_UPDATE_CONTINUOUS + GTK_UPDATE_CONTINUOUS + + 0 + True + True + + + + GtkCList + subscriptionCList + True + 1 + 80 + GTK_SELECTION_SINGLE + False + GTK_SHADOW_IN + + + GtkLabel + CList:title + label7 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + + + + + GtkButton + showSubscriptionWindowButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + + + GtkFrame + frame4 + 8 + + 0 + GTK_SHADOW_ETCHED_IN + + 0 + True + True + + + + GtkHBox + hbox3 + False + 0 + + + GtkScrolledWindow + scrolledwindow5 + GTK_POLICY_NEVER + GTK_POLICY_ALWAYS + GTK_UPDATE_CONTINUOUS + GTK_UPDATE_CONTINUOUS + + 0 + True + True + + + + GtkText + stateText + True + True + + + + + + GtkButton + stateChangeButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + + + GtkFrame + frame2 + 4 + + 0 + GTK_SHADOW_ETCHED_IN + + 0 + True + True + + + + GtkVBox + vbox6 + False + 0 + + + GtkScrolledWindow + scrolledwindow2 + 400 + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_UPDATE_CONTINUOUS + GTK_UPDATE_CONTINUOUS + + 0 + True + True + + + + GtkCList + hintsCList + True + 1 + 80 + GTK_SELECTION_SINGLE + False + GTK_SHADOW_IN + + + GtkLabel + CList:title + label6 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + + + + + GtkButton + useHintButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + + + + GtkStatusbar + mainWindowStatusBar + + 0 + False + False + + + + + + + GtkWindow + subscribeWindow + False + Hbugs: subscribe ... + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + False + True + False + + + GtkVBox + vbox8 + False + 0 + + + GtkButton + listTutorsButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + GtkScrolledWindow + scrolledwindow4 + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_UPDATE_CONTINUOUS + GTK_UPDATE_CONTINUOUS + + 0 + True + True + + + + GtkCList + tutorsCList + 600 + 300 + True + 2 + 205,80 + GTK_SELECTION_EXTENDED + True + GTK_SHADOW_IN + + + GtkLabel + CList:title + label12 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + + + GtkLabel + CList:title + label13 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + + + + + GtkButton + subscribeButton + True + + GTK_RELIEF_NORMAL + + 0 + False + False + + + + + GtkStatusbar + subscribeWindowStatusBar + + 0 + False + False + + + + + + + GtkDialog + messageDialog + False + Message + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER + True + 220 + 150 + True + True + False + + + GtkVBox + Dialog:vbox + dialogVbox1 + False + 0 + + + GtkHBox + Dialog:action_area + dialogAction_area1 + 2 + True + 5 + + 0 + False + True + GTK_PACK_END + + + + GtkButton + okDialogButton + True + + GTK_RELIEF_NORMAL + + 0 + False + True + + + + + + GtkTable + table1 + 5 + 1 + 1 + False + 0 + 0 + + 0 + True + True + + + + GtkLabel + dialogLabel + + GTK_JUSTIFY_CENTER + True + 0.5 + 0.5 + 0 + 0 + + 0 + 1 + 0 + 1 + 0 + 0 + True + True + False + False + True + True + + + + + + + -- 2.39.2