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     val mainWindow = new Gui.hbugsMainWindow ()
  49     val subscribeWindow = new Gui.subscribeWindow ()
  50     val messageDialog = new Gui.messageDialog ()
  51     val myOwnId = Hbugs_id_generator.new_client_id ()
  52     val mutable myOwnUrl = "localhost:49082"
  53     val mutable brokerUrl = "localhost:49081"
  54     val mutable brokerId: broker_id option = None
  55     val mutable selectedTutors: tutor_id list = []
  56     val mutable statusContext = None
  57     val mutable subscribeWindowStatusContext = None
  58     val mutable debug = false (* enable/disable debugging buttons *)
  59
  60     initializer
  61       self#initGui;
  62       self#startLocalHttpDaemon ();
  63       self#testLocalHttpDaemon ();
  64       self#testBroker ();
  65       self#registerClient ();
  66       self#reconfigDebuggingButtons
  67
  68     method show = mainWindow#hbugsMainWindow#show
  69     method hide = mainWindow#hbugsMainWindow#misc#hide
  70
  71     method private debugButtons =
  72       List.map
  73         (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
  74         [ mainWindow#startLocalHttpDaemonButton;
  75         mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton;
  76         mainWindow#registerClientButton; mainWindow#unregisterClientButton ]
  77
  78     method private initGui =
  79
  80         (* GUI: main window *)
  81       ignore (mainWindow#hbugsMainWindow#connect#destroy self#quit);
  82
  83         (* GUI main window's menu *)
  84       mainWindow#toggleDebuggingMenuItem#set_active debug;
  85       ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
  86         self#toggleDebug);
  87
  88         (* GUI: local HTTP daemon settings *)
  89       ignore (mainWindow#clientUrlEntry#connect#changed
  90         (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
  91       mainWindow#clientUrlEntry#set_text myOwnUrl;
  92       ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
  93         self#startLocalHttpDaemon);
  94       ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
  95         self#testLocalHttpDaemon);
  96
  97         (* GUI: broker choice *)
  98       ignore (mainWindow#brokerUrlEntry#connect#changed
  99         (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
 100       mainWindow#brokerUrlEntry#set_text brokerUrl;
 101       ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
 102       mainWindow#clientIdLabel#set_text myOwnId;
 103
 104         (* GUI: client registration *)
 105       ignore (mainWindow#registerClientButton#connect#clicked
 106         self#registerClient);
 107       ignore (mainWindow#unregisterClientButton#connect#clicked
 108         self#unregisterClient);
 109
 110         (* GUI: subscriptions *)
 111       ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
 112         (fun () ->
 113           self#listTutors ();
 114           subscribeWindow#subscribeWindow#show ()));
 115
 116         (* GUI: DEBUG state change *)
 117       ignore (mainWindow#stateChangeButton#connect#clicked self#stateChange);
 118
 119         (* GUI: hints list *)
 120       ignore (mainWindow#useHintButton#connect#clicked self#useHint);
 121
 122         (* GUI: main status bar *)
 123       let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
 124       statusContext <- Some ctxt;
 125       ignore (ctxt#push "Ready");
 126
 127         (* GUI: subscription window *)
 128       ignore (subscribeWindow#subscribeWindow#event#connect#delete
 129         (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
 130       ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
 131       let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
 132       ignore (subscribeWindow#tutorsCList#connect#select_row
 133         (fun ~row ~column ~event ->
 134           selectedTutors <- tutor_id_of_row row :: selectedTutors));
 135       ignore (subscribeWindow#tutorsCList#connect#unselect_row
 136         (fun ~row ~column ~event ->
 137           selectedTutors <-
 138             List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
 139       ignore (subscribeWindow#subscribeButton#connect#clicked self#subscribe);
 140       let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
 141       subscribeWindowStatusContext <- Some ctxt;
 142       ignore (ctxt#push "Ready");
 143
 144         (* GUI: message dialog *)
 145       ignore (messageDialog#messageDialog#event#connect#delete
 146         (fun _ -> messageDialog#messageDialog#misc#hide (); true));
 147       ignore (messageDialog#okDialogButton#connect#clicked
 148         (fun _ -> messageDialog#messageDialog#misc#hide ()))
 149
 150     (* accessory methods *)
 151
 152       (** pop up a (modal) dialog window showing msg to the user *)
 153     method private showDialog msg =
 154       messageDialog#dialogLabel#set_text msg;
 155       messageDialog#messageDialog#show ()
 156       (** use showDialog to display an hbugs message to the user *)
 157     method private showMsgInDialog msg =
 158       self#showDialog (Hbugs_messages.string_of_msg msg)
 159
 160       (** create a new thread which sends msg to broker, wait for an answer and
 161       invoke callback passing response message as argument *)
 162     method private sendReq ~msg callback =
 163       let thread () =
 164         try
 165           callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
 166         with
 167         | (Hbugs_messages.Parse_error (subj, reason)) as e ->
 168             self#showDialog
 169               (sprintf
 170 "Parse_error, unable to fullfill request. Details follow.
 171 Request: %s
 172 Error: %s"
 173                 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e))
 174         | (Unix.Unix_error _) as e ->
 175             self#showDialog
 176               (sprintf
 177 "Can't connect to HBugs Broker
 178 Url: %s
 179 Error: %s"
 180                 brokerUrl (Printexc.to_string e))
 181       in
 182       ignore (Thread.create thread ())
 183
 184       (** check if a broker is authenticated using its broker_id
 185       [ Background: during client registration, client save broker_id of its
 186       broker, further messages from broker are accepted only if they carry the
 187       same broker id ] *)
 188     method private isAuthenticated id =
 189       match brokerId with
 190       | None -> false
 191       | Some broker_id -> (id = broker_id)
 192
 193     (* actions *)
 194
 195     method startLocalHttpDaemon () =
 196       let callback req outchan =
 197         try
 198           (match Hbugs_messages.msg_of_string req#body with
 199           | Help ->
 200               Hbugs_messages.respond_msg
 201                 (Usage "Local Http Daemon up and running!") outchan
 202           | Hint (broker_id, hint) ->
 203               if self#isAuthenticated broker_id then
 204                 ignore (mainWindow#hintsCList#append [hint])
 205               else
 206                 Hbugs_messages.respond_exc "forbidden" broker_id outchan
 207           | msg ->
 208               Hbugs_messages.respond_exc
 209                 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 210         with (Hbugs_messages.Parse_error _) as e ->
 211           Hbugs_messages.respond_exc
 212             "parse_error" (Printexc.to_string e) outchan
 213       in
 214       let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
 215                               only as a value to be sent to broker, local HTTP
 216                               daemon will listen on "0.0.0.0", port is parsed
 217                               from My URL though *)
 218       let thread () =
 219         try
 220           Http_daemon.start'
 221             ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
 222         with
 223         | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
 224         | e ->
 225             self#showDialog (sprintf "Can't start local HTTP daemon: %s"
 226               (Printexc.to_string e))
 227       in
 228       ignore (Thread.create thread ())
 229
 230     method testLocalHttpDaemon () =
 231       try
 232         let msg =
 233           Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
 234             myOwnUrl
 235         in
 236         ignore msg
 237 (*         self#showDialog msg *)
 238       with
 239       | Hbugs_misc.Malformed_URL url ->
 240           self#showDialog
 241             (sprintf
 242               "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
 243               url)
 244       | Hbugs_misc.Malformed_HTTP_response res ->
 245           self#showDialog
 246             (sprintf
 247     "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
 248               res)
 249       | (Unix.Unix_error _) as e ->
 250           self#showDialog
 251             (sprintf
 252               "Handshake with local HTTP daemon failed, can't connect: \"%s\""
 253               (Printexc.to_string e))
 254
 255     method testBroker () =
 256       self#sendReq ~msg:Help
 257         (function
 258           | Usage _ -> ()
 259           | unexpected_msg ->
 260               self#showDialog
 261                 (sprintf
 262                   "Handshake with HBugs Broker failed, unexpected message:\n%s"
 263                   (Hbugs_messages.string_of_msg unexpected_msg)))
 264
 265     method registerClient () =
 266       self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
 267         (function
 268           | Client_registered broker_id ->
 269               brokerId <- Some broker_id;
 270 (*
 271               self#showDialog
 272                 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
 273 *)
 274           | unexpected_msg ->
 275               self#showDialog
 276                 (sprintf "Client NOT registered, unexpected message:\n%s"
 277                   (Hbugs_messages.string_of_msg unexpected_msg)))
 278
 279     method unregisterClient () =
 280       self#sendReq ~msg:(Unregister_client myOwnId)
 281         self#showMsgInDialog
 282
 283     method stateChange () =
 284       let state = (* TODO fill with a real state representation! *)
 285         mainWindow#stateText#get_chars 0 (mainWindow#stateText#length)
 286       in
 287       self#sendReq ~msg:(State_change (myOwnId, state))
 288         self#showMsgInDialog
 289
 290     method private listTutors () =
 291       self#sendReq ~msg:(List_tutors myOwnId)
 292         (function
 293           | Tutor_list (_, descriptions) ->
 294               selectedTutors <- [];
 295               subscribeWindow#tutorsCList#clear ();
 296               List.iter
 297                 (fun (id, dsc) ->
 298                   ignore (subscribeWindow#tutorsCList#append [id; dsc]))
 299                 descriptions
 300           | unexpected_msg ->
 301               self#showDialog
 302                 (sprintf "Can't list tutors, unexpected message:\n%s"
 303                   (Hbugs_messages.string_of_msg unexpected_msg)))
 304
 305     method private subscribe () =
 306       let selectedTutors = List.sort compare selectedTutors in
 307       self#sendReq ~msg:(Subscribe (myOwnId, selectedTutors))
 308         (function
 309           | (Subscribed (_, tutors)) as msg ->
 310               let msg_string = Hbugs_messages.string_of_msg msg in
 311               let subscribedTutors = List.sort compare tutors in
 312               let msg =
 313                 if subscribedTutors = selectedTutors then
 314                   sprintf "Subscription OK\n: %s" msg_string
 315                 else
 316                   sprintf "Subscription mismatch\n: %s" msg_string
 317               in
 318               self#showDialog msg;
 319               subscribeWindow#subscribeWindow#misc#hide ()
 320           | unexpected_msg ->
 321               self#showDialog
 322                 (sprintf "Subscription FAILED, unexpected message:\n%s"
 323                   (Hbugs_messages.string_of_msg unexpected_msg)))
 324
 325     method useHint () = failwith "useHint: TODO not implemented"  (* TODO *)
 326
 327     method private quit () =
 328       self#unregisterClient ();
 329       GMain.Main.quit ()
 330
 331       (** enable/disable debugging *)
 332     method private setDebug value = debug <- value
 333
 334     method private reconfigDebuggingButtons =
 335       List.iter (* debug value changed, reconfigure buttons *)
 336         (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
 337         self#debugButtons;
 338
 339     method private toggleDebug () =
 340       self#setDebug (not debug);
 341       self#reconfigDebuggingButtons
 342
 343   end
 344 ;;
 345
 346 let client = new hbugsClient in
 347 client#show ();
 348 GtkThread.main ()
 349