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_common;;
  30 open Hbugs_types;;
  31 open Printf;;
  32
  33 exception Invalid_URL of string;;
  34
  35 let global_debug = true;;
  36
  37 let do_nothing _ = ();;
  38
  39   (**
  40   @param on_use_hint function invoked when an hint is used, argumnet is the hint
  41   to use
  42   @param on_exit function invoked when client is exiting (e.g. window is
  43   destroyed, if it's None "self#quit" is invoked
  44   *)
  45 class hbugsClient
  46   ?(use_hint_callback: hint -> unit = do_nothing)
  47   ?(destroy_callback: unit -> unit = do_nothing)
  48   ()
  49   =
  50
  51   let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
  52   let port_of_http_url url =
  53     try
  54       let subs = Pcre.extract ~rex:http_url_RE url in
  55       int_of_string subs.(3)
  56     with e -> raise (Invalid_URL url)
  57   in
  58
  59   object (self)
  60
  61     val mainWindow = new Hbugs_client_gui.hbugsMainWindow ()
  62     val subscribeWindow = new Hbugs_client_gui.subscribeWindow ()
  63     val messageDialog = new Hbugs_client_gui.messageDialog ()
  64     val myOwnId = Hbugs_id_generator.new_client_id ()
  65     val mutable use_hint_callback = use_hint_callback
  66     val mutable myOwnUrl = "localhost:49082"
  67     val mutable brokerUrl = "localhost:49081"
  68     val mutable brokerId: broker_id option = None
  69       (* all available tutors, saved last time a List_tutors message was sent to
  70       broker *)
  71     val mutable availableTutors: tutor_dsc list = []
  72      (* id of highlighted tutors in tutor subscription window *)
  73     val mutable selectedTutors: tutor_id list = []
  74     val mutable statusContext = None
  75     val mutable subscribeWindowStatusContext = None
  76     val mutable debug = false (* enable/disable debugging buttons *)
  77     val mutable hints = []  (* actually available hints *)
  78
  79     initializer
  80       self#initGui;
  81       self#startLocalHttpDaemon ();
  82       self#testLocalHttpDaemon ();
  83       self#testBroker ();
  84       self#registerToBroker ();
  85       self#reconfigDebuggingButtons
  86
  87     method show = mainWindow#hbugsMainWindow#show
  88     method hide = mainWindow#hbugsMainWindow#misc#hide
  89
  90     method setUseHintCallback callback =
  91      use_hint_callback <- callback
  92
  93     method private debugButtons =
  94       List.map
  95         (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
  96         [ mainWindow#startLocalHttpDaemonButton;
  97         mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton;
  98         mainWindow#registerClientButton; mainWindow#unregisterClientButton ]
  99
 100     method private initGui =
 101
 102         (* GUI: main window *)
 103
 104           (* ignore delete events so that hbugs window is closable only using
 105           menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked
 106           *)
 107
 108       ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true));
 109       ignore (mainWindow#hbugsMainWindow#event#connect#destroy
 110         (fun _ -> self#quit (); false));
 111
 112         (* GUI main window's menu *)
 113       mainWindow#toggleDebuggingMenuItem#set_active debug;
 114       ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
 115         self#toggleDebug);
 116
 117         (* GUI: local HTTP daemon settings *)
 118       ignore (mainWindow#clientUrlEntry#connect#changed
 119         (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
 120       mainWindow#clientUrlEntry#set_text myOwnUrl;
 121       ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
 122         self#startLocalHttpDaemon);
 123       ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
 124         self#testLocalHttpDaemon);
 125
 126         (* GUI: broker choice *)
 127       ignore (mainWindow#brokerUrlEntry#connect#changed
 128         (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
 129       mainWindow#brokerUrlEntry#set_text brokerUrl;
 130       ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
 131       mainWindow#clientIdLabel#set_text myOwnId;
 132
 133         (* GUI: client registration *)
 134       ignore (mainWindow#registerClientButton#connect#clicked
 135         self#registerToBroker);
 136       ignore (mainWindow#unregisterClientButton#connect#clicked
 137         self#unregisterFromBroker);
 138
 139         (* GUI: subscriptions *)
 140       ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
 141         (fun () ->
 142           self#listTutors ();
 143           subscribeWindow#subscribeWindow#show ()));
 144
 145         (* GUI: hints list *)
 146       ignore (mainWindow#hintsCList#connect#select_row
 147         (fun ~row ~column ~event ->
 148           match event with
 149           | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS ->
 150               use_hint_callback (self#hint row)
 151           | _ -> ()));
 152
 153         (* GUI: main status bar *)
 154       let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
 155       statusContext <- Some ctxt;
 156       ignore (ctxt#push "Ready");
 157
 158         (* GUI: subscription window *)
 159       ignore (subscribeWindow#subscribeWindow#event#connect#delete
 160         (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
 161       ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
 162       let tutor_id_of_row row = subscribeWindow#tutorsCList#cell_text row 0 in
 163       ignore (subscribeWindow#tutorsCList#connect#select_row
 164         (fun ~row ~column ~event ->
 165           selectedTutors <- tutor_id_of_row row :: selectedTutors));
 166       ignore (subscribeWindow#tutorsCList#connect#unselect_row
 167         (fun ~row ~column ~event ->
 168           selectedTutors <-
 169             List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
 170       ignore (subscribeWindow#subscribeButton#connect#clicked
 171         self#subscribeSelected);
 172       ignore (subscribeWindow#subscribeAllButton#connect#clicked
 173         self#subscribeAll);
 174       let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
 175       subscribeWindowStatusContext <- Some ctxt;
 176       ignore (ctxt#push "Ready");
 177
 178         (* GUI: message dialog *)
 179       ignore (messageDialog#messageDialog#event#connect#delete
 180         (fun _ -> messageDialog#messageDialog#misc#hide (); true));
 181       ignore (messageDialog#okDialogButton#connect#clicked
 182         (fun _ -> messageDialog#messageDialog#misc#hide ()))
 183
 184     (* accessory methods *)
 185
 186       (** pop up a (modal) dialog window showing msg to the user *)
 187     method private showDialog msg =
 188       messageDialog#dialogLabel#set_text msg;
 189       messageDialog#messageDialog#show ()
 190       (** use showDialog to display an hbugs message to the user *)
 191     method private showMsgInDialog msg =
 192       self#showDialog (Hbugs_messages.string_of_msg msg)
 193
 194       (** create a new thread which sends msg to broker, wait for an answer and
 195       invoke callback passing response message as argument *)
 196     method private sendReq ?(wait = false) ~msg callback =
 197       let thread () =
 198         try
 199           callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
 200         with
 201         | (Hbugs_messages.Parse_error (subj, reason)) as e ->
 202             self#showDialog
 203               (sprintf
 204 "Parse_error, unable to fullfill request. Details follow.
 205 Request: %s
 206 Error: %s"
 207                 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
 208         | (Unix.Unix_error _) as e ->
 209             self#showDialog
 210               (sprintf
 211 "Can't connect to HBugs Broker
 212 Url: %s
 213 Error: %s"
 214                 brokerUrl (Printexc.to_string e))
 215         | e ->
 216             self#showDialog
 217               (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
 218                 (Printexc.to_string e))
 219       in
 220       let th = Thread.create thread () in
 221       if wait then
 222         Thread.join th
 223       else ()
 224
 225       (** check if a broker is authenticated using its broker_id
 226       [ Background: during client registration, client save broker_id of its
 227       broker, further messages from broker are accepted only if they carry the
 228       same broker id ] *)
 229     method private isAuthenticated id =
 230       match brokerId with
 231       | None -> false
 232       | Some broker_id -> (id = broker_id)
 233
 234     (* actions *)
 235
 236     method private startLocalHttpDaemon =
 237         (* flatten an hint tree to an hint list *)
 238       let rec flatten_hint = function
 239         | Hints hints -> List.concat (List.map flatten_hint hints)
 240         | hint -> [hint]
 241       in
 242       fun () ->
 243       let callback req outchan =
 244         try
 245           (match Hbugs_messages.msg_of_string req#body with
 246           | Help ->
 247               Hbugs_messages.respond_msg
 248                 (Usage "Local Http Daemon up and running!") outchan
 249           | Hint (broker_id, hint) ->
 250               if self#isAuthenticated broker_id then begin
 251                 let received_hints = flatten_hint hint in
 252                 List.iter
 253                   (fun h ->
 254                     (match h with Hints _ -> assert false | _ -> ());
 255                     ignore (mainWindow#hintsCList#append [string_of_hint h]))
 256                   received_hints;
 257                 hints <- hints @ received_hints;
 258                 Hbugs_messages.respond_msg (Wow myOwnId) outchan
 259               end else  (* msg from unauthorized broker *)
 260                 Hbugs_messages.respond_exc "forbidden" broker_id outchan
 261           | msg ->
 262               Hbugs_messages.respond_exc
 263                 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 264         with (Hbugs_messages.Parse_error _) as e ->
 265           Hbugs_messages.respond_exc
 266             "parse_error" (Printexc.to_string e) outchan
 267       in
 268       let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
 269                               only as a value to be sent to broker, local HTTP
 270                               daemon will listen on "0.0.0.0", port is parsed
 271                               from My URL though *)
 272       let httpDaemonThread () =
 273         try
 274           Http_daemon.start'
 275             ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
 276         with
 277         | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
 278         | e ->
 279             self#showDialog (sprintf "Can't start local HTTP daemon: %s"
 280               (Printexc.to_string e))
 281       in
 282       ignore (Thread.create httpDaemonThread ())
 283
 284     method private testLocalHttpDaemon () =
 285       try
 286         let msg =
 287           Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
 288             myOwnUrl
 289         in
 290         ignore msg
 291 (*         self#showDialog msg *)
 292       with
 293       | Hbugs_misc.Malformed_URL url ->
 294           self#showDialog
 295             (sprintf
 296               "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
 297               url)
 298       | Hbugs_misc.Malformed_HTTP_response res ->
 299           self#showDialog
 300             (sprintf
 301     "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
 302               res)
 303       | (Unix.Unix_error _) as e ->
 304           self#showDialog
 305             (sprintf
 306               "Handshake with local HTTP daemon failed, can't connect: \"%s\""
 307               (Printexc.to_string e))
 308
 309     method private testBroker () =
 310       self#sendReq ~msg:Help
 311         (function
 312           | Usage _ -> ()
 313           | unexpected_msg ->
 314               self#showDialog
 315                 (sprintf
 316                   "Handshake with HBugs Broker failed, unexpected message:\n%s"
 317                   (Hbugs_messages.string_of_msg unexpected_msg)))
 318
 319     method registerToBroker () =
 320       self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
 321         (function
 322           | Client_registered broker_id ->
 323               brokerId <- Some broker_id;
 324 (*
 325               self#showDialog
 326                 (sprintf "Client %s registered @ broker %s" myOwnId broker_id)
 327 *)
 328           | unexpected_msg ->
 329               self#showDialog
 330                 (sprintf "Client NOT registered, unexpected message:\n%s"
 331                   (Hbugs_messages.string_of_msg unexpected_msg)))
 332
 333     method unregisterFromBroker () =
 334       self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
 335         self#showMsgInDialog
 336
 337     method stateChange new_state =
 338       self#sendReq
 339         ~msg:(State_change (myOwnId, new_state))
 340         (function
 341           | State_accepted _ ->
 342               mainWindow#hintsCList#clear ();
 343               hints <- []
 344           | unexpected_msg ->
 345               self#showDialog
 346                 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
 347                   (Hbugs_messages.string_of_msg unexpected_msg)))
 348
 349     method hint = List.nth hints
 350
 351     method private listTutors () =
 352         (* wait is set to true just to make sure that after invoking listTutors
 353         "availableTutors" is correctly filled *)
 354       self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
 355         (function
 356           | Tutor_list (_, descriptions) ->
 357               availableTutors <-  (* sort accordingly to tutor description *)
 358                 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
 359               selectedTutors <- [];
 360               subscribeWindow#tutorsCList#clear ();
 361               List.iter
 362                 (fun (id, dsc) ->
 363                   ignore (subscribeWindow#tutorsCList#append [id; dsc]))
 364                 availableTutors
 365           | unexpected_msg ->
 366               self#showDialog
 367                 (sprintf "Can't list tutors, unexpected message:\n%s"
 368                   (Hbugs_messages.string_of_msg unexpected_msg)))
 369
 370       (* low level used by subscribeSelected and subscribeAll *)
 371     method private subscribe' tutors_id =
 372       self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
 373         (function
 374           | (Subscribed (_, subscribedTutors)) as msg ->
 375               let sort = List.sort compare in
 376               mainWindow#subscriptionCList#clear ();
 377               List.iter
 378                 (fun tutor_id ->
 379                   ignore
 380                     (mainWindow#subscriptionCList#append
 381                       [ try
 382                           List.assoc tutor_id availableTutors;
 383                         with Not_found -> assert false ]))
 384                 tutors_id;
 385               subscribeWindow#subscribeWindow#misc#hide ();
 386               if sort subscribedTutors <> sort tutors_id then
 387                 self#showDialog
 388                   (sprintf "Subscription mismatch\n: %s"
 389                     (Hbugs_messages.string_of_msg msg))
 390           | unexpected_msg ->
 391               mainWindow#subscriptionCList#clear ();
 392               self#showDialog
 393                 (sprintf "Subscription FAILED, unexpected message:\n%s"
 394                   (Hbugs_messages.string_of_msg unexpected_msg)))
 395
 396     method private subscribeSelected () = self#subscribe' selectedTutors
 397
 398     method subscribeAll () =
 399       self#listTutors ();  (* this fills 'availableTutors' field *)
 400       self#subscribe' (List.map fst availableTutors)
 401
 402     method private quit () =
 403       self#unregisterFromBroker ();
 404       destroy_callback ()
 405
 406       (** enable/disable debugging *)
 407     method private setDebug value = debug <- value
 408
 409     method private reconfigDebuggingButtons =
 410       List.iter (* debug value changed, reconfigure buttons *)
 411         (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
 412         self#debugButtons;
 413
 414     method private toggleDebug () =
 415       self#setDebug (not debug);
 416       self#reconfigDebuggingButtons
 417
 418   end
 419 ;;
 420