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