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 (*CSC: per farlo compilare
 137       ignore (mainWindow#hintsCList#connect#select_row
 138         (fun ~row ~column ~event ->
 139           match event with
 140           | Some event when GdkEvent.get_type event = `TWO_BUTTON_PRESS ->
 141               use_hint_callback (self#hint row)
 142           | Some event ->
 143               describe_hint_callback (self#hint row)
 144           | _ -> ()));
 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 = (*CSC: per farlo compilare subscribeWindow#tutorsCList#cell_text row 0*) "Kaboom" in
 157 (*CSC: per farlo compilare
 158       ignore (subscribeWindow#tutorsCList#connect#select_row
 159         (fun ~row ~column ~event ->
 160           let new_id = tutor_id_of_row row in
 161           match selectedTutors with
 162           | hd :: _ when hd = new_id -> ()  (* avoid double select events *)
 163           | _ -> selectedTutors <- tutor_id_of_row row :: selectedTutors));
 164       ignore (subscribeWindow#tutorsCList#connect#unselect_row
 165         (fun ~row ~column ~event ->
 166           selectedTutors <-
 167             List.filter ((<>) (tutor_id_of_row row)) selectedTutors));
 168 *)
 169       ignore (subscribeWindow#subscribeButton#connect#clicked
 170         self#subscribeSelected);
 171       ignore (subscribeWindow#subscribeAllButton#connect#clicked
 172         self#subscribeAll);
 173       (subscribeWindow#tutorsCList#get_column 0)#set_visible false;
 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 (*CSC: per farlo compilare
 256                     ignore (mainWindow#hintsCList#append [string_of_hint h])*))
 257                   received_hints;
 258                 hints <- hints @ received_hints;
 259                 Hbugs_messages.respond_msg (Wow myOwnId) outchan
 260               end else  (* msg from unauthorized broker *)
 261                 Hbugs_messages.respond_exc "forbidden" broker_id outchan
 262           | msg ->
 263               Hbugs_messages.respond_exc
 264                 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 265         with (Hbugs_messages.Parse_error _) as e ->
 266           Hbugs_messages.respond_exc
 267             "parse_error" (Printexc.to_string e) outchan
 268       in
 269       let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
 270                               only as a value to be sent to broker, local HTTP
 271                               daemon will listen on "0.0.0.0", port is parsed
 272                               from My URL though *)
 273       let httpDaemonThread () =
 274         try
 275           Http_daemon.start'
 276             ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
 277         with
 278         | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
 279         | e ->
 280             self#showDialog (sprintf "Can't start local HTTP daemon: %s"
 281               (Printexc.to_string e))
 282       in
 283       ignore (Thread.create httpDaemonThread ())
 284
 285     method private testLocalHttpDaemon () =
 286       try
 287         let msg =
 288           Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
 289             myOwnUrl
 290         in
 291         ignore msg
 292 (*         self#showDialog msg *)
 293       with
 294       | Hbugs_misc.Malformed_URL url ->
 295           self#showDialog
 296             (sprintf
 297               "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
 298               url)
 299       | Hbugs_misc.Malformed_HTTP_response res ->
 300           self#showDialog
 301             (sprintf
 302     "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
 303               res)
 304       | (Unix.Unix_error _) as e ->
 305           self#showDialog
 306             (sprintf
 307               "Handshake with local HTTP daemon failed, can't connect: \"%s\""
 308               (Printexc.to_string e))
 309
 310     method private testBroker () =
 311       self#sendReq ~msg:Help
 312         (function
 313           | Usage _ -> ()
 314           | unexpected_msg ->
 315               self#showDialog
 316                 (sprintf
 317                   "Handshake with HBugs Broker failed, unexpected message:\n%s"
 318                   (Hbugs_messages.string_of_msg unexpected_msg)))
 319
 320     method registerToBroker () =
 321       (match brokerId with  (* undo previous registration, if any *)
 322       | Some id -> self#unregisterFromBroker ()
 323       | _ -> ());
 324       self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
 325         (function
 326           | Client_registered broker_id -> (brokerId <- Some broker_id)
 327           | unexpected_msg ->
 328               self#showDialog
 329                 (sprintf "Client NOT registered, unexpected message:\n%s"
 330                   (Hbugs_messages.string_of_msg unexpected_msg)))
 331
 332     method unregisterFromBroker () =
 333       self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
 334         (function
 335           | Client_unregistered _ -> (brokerId <- None)
 336           | unexpected_msg -> ())
 337 (*
 338               self#showDialog
 339                 (sprintf "Client NOT unregistered, unexpected message:\n%s"
 340                   (Hbugs_messages.string_of_msg unexpected_msg)))
 341 *)
 342
 343     method stateChange new_state =
 344 (*CSC: per farlo compilare
 345       mainWindow#hintsCList#clear ();
 346 *)
 347       hints <- [];
 348       self#sendReq
 349         ~msg:(State_change (myOwnId, new_state))
 350         (function
 351           | State_accepted _ -> ()
 352           | unexpected_msg ->
 353               self#showDialog
 354                 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
 355                   (Hbugs_messages.string_of_msg unexpected_msg)))
 356
 357     method hint = List.nth hints
 358
 359     method private listTutors () =
 360         (* wait is set to true just to make sure that after invoking listTutors
 361         "availableTutors" is correctly filled *)
 362       self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
 363         (function
 364           | Tutor_list (_, descriptions) ->
 365               availableTutors <-  (* sort accordingly to tutor description *)
 366                 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
 367               selectedTutors <- [];
 368 (*CSC: per farlo compilare
 369               subscribeWindow#tutorsCList#clear ();
 370 *)
 371               List.iter
 372                 (fun (id, dsc) ->
 373                   (*CSC: per farlo compilare ignore (subscribeWindow#tutorsCList#append [id; dsc])*)())
 374                 availableTutors
 375           | unexpected_msg ->
 376               self#showDialog
 377                 (sprintf "Can't list tutors, unexpected message:\n%s"
 378                   (Hbugs_messages.string_of_msg unexpected_msg)))
 379
 380       (* low level used by subscribeSelected and subscribeAll *)
 381     method private subscribe' tutors_id =
 382       self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
 383         (function
 384           | (Subscribed (_, subscribedTutors)) as msg ->
 385               let sort = List.sort compare in
 386 (*CSC: per farlo compilare
 387               mainWindow#subscriptionCList#clear ();
 388 *)
 389               List.iter
 390                 (fun tutor_id ->
 391 (*CSC: per farlo compilare
 392                   ignore
 393                     (mainWindow#subscriptionCList#append
 394                       [ try
 395                           List.assoc tutor_id availableTutors;
 396                         with Not_found -> assert false ])*)())
 397                 tutors_id;
 398               subscribeWindow#subscribeWindow#misc#hide ();
 399               if sort subscribedTutors <> sort tutors_id then
 400                 self#showDialog
 401                   (sprintf "Subscription mismatch\n: %s"
 402                     (Hbugs_messages.string_of_msg msg))
 403           | unexpected_msg ->
 404 (*CSC: per farlo compilare
 405               mainWindow#subscriptionCList#clear ();
 406 *)
 407               self#showDialog
 408                 (sprintf "Subscription FAILED, unexpected message:\n%s"
 409                   (Hbugs_messages.string_of_msg unexpected_msg)))
 410
 411     method private subscribeSelected () = self#subscribe' selectedTutors
 412
 413     method subscribeAll () =
 414       self#listTutors ();  (* this fills 'availableTutors' field *)
 415       self#subscribe' (List.map fst availableTutors)
 416
 417     method private quit () =
 418       self#unregisterFromBroker ();
 419       destroy_callback ()
 420
 421       (** enable/disable debugging *)
 422     method private setDebug value = debug <- value
 423
 424     method private reconfigDebuggingButtons =
 425       List.iter (* debug value changed, reconfigure buttons *)
 426         (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
 427         self#debugButtons;
 428
 429     method private toggleDebug () =
 430       self#setDebug (not debug);
 431       self#reconfigDebuggingButtons
 432
 433   end
 434 ;;
 435