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