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