helm/hbugs/client/hbugs_client.ml

   1 (*
   2  * Copyright (C) 2003:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 open Hbugs_types;;
  30 open Printf;;
  31
  32 exception Invalid_URL of string;;
  33
  34 let global_debug = true;;
  35
  36 class hbugsClient =
  37
  38   let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
  39   let port_of_http_url url =
  40     try
  41       let subs = Pcre.extract ~rex:http_url_RE url in
  42       int_of_string subs.(3)
  43     with e -> raise (Invalid_URL url)
  44   in
  45
  46   object (self)
  47
  48     inherit Gui.hbugsMainWindow ()
  49
  50     val subscribeWindow = new Gui.subscribeWindow ()
  51     val messageDialog = new Gui.messageDialog ()
  52     val myOwnId = Hbugs_id_generator.new_client_id ()
  53     val mutable myOwnUrl = "localhost:49082"
  54     val mutable brokerUrl = "localhost:49081"
  55     val mutable brokerId: broker_id option = None
  56     val mutable selectedTutors: tutor_id list = []
  57     val mutable statusContext = None
  58     val mutable subscribeWindowStatusContext = None
  59     val mutable debug = false (* enable/disable debugging buttons *)
  60
  61     initializer
  62 (*       self#setDebug global_debug; *)
  63       self#initGui;
  64       self#startLocalHttpDaemon ();
  65       self#testLocalHttpDaemon ();
  66       self#testBroker ();
  67       self#registerClient ();
  68       self#reconfigDebuggingButtons
  69
  70     method debugButtons =
  71       List.map
  72         (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
  73         [ self#startLocalHttpDaemonButton; self#testLocalHttpDaemonButton;
  74         self#testBrokerButton; self#registerClientButton;
  75         self#unregisterClientButton ]
  76
  77     method private initGui =
  78
  79         (* GUI: main window *)
  80       ignore (self#hbugsMainWindow#connect#destroy self#quit);
  81
  82         (* GUI main window's menu *)
  83       self#toggleDebuggingMenuItem#set_active debug;
  84       ignore (self#toggleDebuggingMenuItem#connect#toggled self#toggleDebug);
  85
  86         (* GUI: local HTTP daemon settings *)
  87       ignore (self#clientUrlEntry#connect#changed
  88         (fun _ -> myOwnUrl <- self#clientUrlEntry#text));
  89       self#clientUrlEntry#set_text myOwnUrl;
  90       ignore (self#startLocalHttpDaemonButton#connect#clicked
  91         self#startLocalHttpDaemon);
  92       ignore (self#testLocalHttpDaemonButton#connect#clicked
  93         self#testLocalHttpDaemon);
  94
  95         (* GUI: broker choice *)
  96       ignore (self#brokerUrlEntry#connect#changed
  97         (fun _ -> brokerUrl <- self#brokerUrlEntry#text));
  98       self#brokerUrlEntry#set_text brokerUrl;
  99       ignore (self#testBrokerButton#connect#clicked self#testBroker);
 100       self#clientIdLabel#set_text myOwnId;
 101
 102         (* GUI: client registration *)
 103       ignore (self#registerClientButton#connect#clicked self#registerClient);
 104       ignore (self#unregisterClientButton#connect#clicked
 105         self#unregisterClient);
 106
 107         (* GUI: subscriptions *)
 108       ignore (self#showSubscriptionWindowButton#connect#clicked
 109         (fun () ->
 110           self#listTutors ();
 111           subscribeWindow#subscribeWindow#show ()));
 112
 113         (* GUI: DEBUG state change *)
 114       ignore (self#stateChangeButton#connect#clicked self#stateChange);
 115
 116         (* GUI: hints list *)
 117       ignore (self#useHintButton#connect#clicked self#useHint);
 118
 119         (* GUI: main status bar *)
 120       let ctxt = self#mainWindowStatusBar#new_context "0" in
 121       statusContext <- Some ctxt;
 122       ignore (ctxt#push "Ready");
 123
 124         (* GUI: subscription window *)
 125       ignore (subscribeWindow#subscribeWindow#event#connect#delete
 126         (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
 127       ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
 128       let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
 129       ignore (subscribeWindow#tutorsCList#connect#select_row
 130         (fun ~row ~column ~event ->
 131           selectedTutors <- tutor_id_of_row row :: selectedTutors));
 132       ignore (subscribeWindow#tutorsCList#connect#unselect_row
 133         (fun ~row ~column ~event ->
 134           selectedTutors <-
 135             List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
 136       ignore (subscribeWindow#subscribeButton#connect#clicked self#subscribe);
 137       let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
 138       subscribeWindowStatusContext <- Some ctxt;
 139       ignore (ctxt#push "Ready");
 140
 141         (* GUI: message dialog *)
 142       ignore (messageDialog#messageDialog#event#connect#delete
 143         (fun _ -> messageDialog#messageDialog#misc#hide (); true));
 144       ignore (messageDialog#okDialogButton#connect#clicked
 145         (fun _ -> messageDialog#messageDialog#misc#hide ()))
 146
 147     (* accessory methods *)
 148
 149       (** pop up a (modal) dialog window showing msg to the user *)
 150     method private showDialog msg =
 151       messageDialog#dialogLabel#set_text msg;
 152       messageDialog#messageDialog#show ()
 153       (** use showDialog to display an hbugs message to the user *)
 154     method private showMsgInDialog msg =
 155       self#showDialog (Hbugs_messages.string_of_msg msg)
 156
 157       (** create a new thread which sends msg to broker, wait for an answer and
 158       invoke callback passing response message as argument *)
 159     method private sendReq ~msg callback =
 160       let thread () =
 161         try
 162           callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
 163         with
 164         | (Hbugs_messages.Parse_error (subj, reason)) as e ->
 165             self#showDialog
 166               (sprintf
 167 "Parse_error, unable to fullfill request. Details follow.
 168 Request: %s
 169 Error: %s"
 170                 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e))
 171         | (Unix.Unix_error _) as e ->
 172             self#showDialog
 173               (sprintf
 174 "Can't connect to HBugs Broker
 175 Url: %s
 176 Error: %s"
 177                 brokerUrl (Printexc.to_string e))
 178       in
 179       ignore (Thread.create thread ())
 180
 181       (** check if a broker is authenticated using its broker_id
 182       [ Background: during client registration, client save broker_id of its
 183       broker, further messages from broker are accepted only if they carry the
 184       same broker id ] *)
 185     method private isAuthenticated id =
 186       match brokerId with
 187       | None -> false
 188       | Some broker_id -> (id = broker_id)
 189
 190     (* actions *)
 191
 192     method startLocalHttpDaemon () =
 193       let callback req outchan =
 194         try
 195           (match Hbugs_messages.msg_of_string req#body with
 196           | Help ->
 197               Hbugs_messages.respond_msg
 198                 (Usage "Local Http Daemon up and running!") outchan
 199           | Hint (broker_id, hint) ->
 200               if self#isAuthenticated broker_id then
 201                 ignore (self#hintsCList#append [hint])
 202               else
 203                 Hbugs_messages.respond_exc "forbidden" broker_id outchan
 204           | msg ->
 205               Hbugs_messages.respond_exc
 206                 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 207         with (Hbugs_messages.Parse_error _) as e ->
 208           Hbugs_messages.respond_exc
 209             "parse_error" (Printexc.to_string e) outchan
 210       in
 211       let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
 212                               only as a value to be sent to broker, local HTTP
 213                               daemon will listen on "0.0.0.0", port is parsed
 214                               from My URL though *)
 215       let thread () =
 216         try
 217           Http_daemon.start'
 218             ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
 219         with
 220         | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
 221         | e ->
 222             self#showDialog (sprintf "Can't start local HTTP daemon: %s"
 223               (Printexc.to_string e))
 224       in
 225       ignore (Thread.create thread ())
 226
 227     method testLocalHttpDaemon () =
 228       try
 229         let msg =
 230           Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
 231             myOwnUrl
 232         in
 233         ignore msg
 234 (*         self#showDialog msg *)
 235       with
 236       | Hbugs_misc.Malformed_URL url ->
 237           self#showDialog
 238             (sprintf
 239               "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
 240               url)
 241       | Hbugs_misc.Malformed_HTTP_response res ->
 242           self#showDialog
 243             (sprintf
 244     "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
 245               res)
 246       | (Unix.Unix_error _) as e ->
 247           self#showDialog
 248             (sprintf
 249               "Handshake with local HTTP daemon failed, can't connect: \"%s\""
 250               (Printexc.to_string e))
 251
 252     method testBroker () =
 253       self#sendReq ~msg:Help
 254         (function
 255           | Usage _ -> ()
 256           | unexpected_msg ->
 257               self#showDialog
 258                 (sprintf
 259                   "Handshake with HBugs Broker failed, unexpected message:\n%s"
 260                   (Hbugs_messages.string_of_msg unexpected_msg)))
 261
 262     method registerClient () =
 263       self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
 264         (function
 265           | Client_registered broker_id ->
 266               brokerId <- Some broker_id;
 267 (*
 268               self#showDialog
 269                 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
 270 *)
 271           | unexpected_msg ->
 272               self#showDialog
 273                 (sprintf "Client NOT registered, unexpected message:\n%s"
 274                   (Hbugs_messages.string_of_msg unexpected_msg)))
 275
 276     method unregisterClient () =
 277       self#sendReq ~msg:(Unregister_client myOwnId)
 278         self#showMsgInDialog
 279
 280     method stateChange () =
 281       let state = (* TODO fill with a real state representation! *)
 282         self#stateText#get_chars 0 (self#stateText#length)
 283       in
 284       self#sendReq ~msg:(State_change (myOwnId, state))
 285         self#showMsgInDialog
 286
 287     method listTutors () =
 288       self#sendReq ~msg:(List_tutors myOwnId)
 289         (function
 290           | Tutor_list (_, descriptions) ->
 291               selectedTutors <- [];
 292               subscribeWindow#tutorsCList#clear ();
 293               List.iter
 294                 (fun (id, dsc) ->
 295                   ignore (subscribeWindow#tutorsCList#append [id; dsc]))
 296                 descriptions
 297           | unexpected_msg ->
 298               self#showDialog
 299                 (sprintf "Can't list tutors, unexpected message:\n%s"
 300                   (Hbugs_messages.string_of_msg unexpected_msg)))
 301
 302     method subscribe () =
 303       let selectedTutors = List.sort compare selectedTutors in
 304       self#sendReq ~msg:(Subscribe (myOwnId, selectedTutors))
 305         (function
 306           | (Subscribed (_, tutors)) as msg ->
 307               let msg_string = Hbugs_messages.string_of_msg msg in
 308               let subscribedTutors = List.sort compare tutors in
 309               let msg =
 310                 if subscribedTutors = selectedTutors then
 311                   sprintf "Subscription OK\n: %s" msg_string
 312                 else
 313                   sprintf "Subscription mismatch\n: %s" msg_string
 314               in
 315               self#showDialog msg;
 316               subscribeWindow#subscribeWindow#misc#hide ()
 317           | unexpected_msg ->
 318               self#showDialog
 319                 (sprintf "Subscription FAILED, unexpected message:\n%s"
 320                   (Hbugs_messages.string_of_msg unexpected_msg)))
 321
 322     method useHint () = failwith "useHint: TODO not implemented"  (* TODO *)
 323
 324     method private quit () =
 325       self#unregisterClient ();
 326       GMain.Main.quit ()
 327
 328       (** enable/disable debugging buttons *)
 329     method setDebug ?(force = false) value =
 330       if (debug <> value) || force then
 331       debug <- value
 332
 333     method private reconfigDebuggingButtons =
 334       List.iter (* debug value changed, reconfigure buttons *)
 335         (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
 336         self#debugButtons;
 337
 338     method toggleDebug () =
 339       self#setDebug (not debug);
 340       self#reconfigDebuggingButtons
 341
 342   end
 343 ;;
 344
 345 ignore (new hbugsClient);
 346 GtkThread.main ()
 347