helm/ocaml/hbugs/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 module SmartHbugs_client_gui =
  38  struct
  39   class ['a] oneColumnCList gtree_view ~column_type ~column_title
  40   =
  41    let obj =
  42     ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in
  43    let columns = new GTree.column_list in
  44    let col = columns#add column_type in
  45    let vcol = GTree.view_column ~title:column_title ()
  46     ~renderer:(GTree.cell_renderer_text[], ["text",col]) in
  47    let store = GTree.list_store columns in
  48    object(self)
  49     inherit GTree.view obj
  50     method clear = store#clear
  51     method append (v : 'a) =
  52      let row = store#append () in
  53       store#set ~row ~column:col v;
  54     method column = col
  55     initializer
  56      self#set_model (Some (store :> GTree.model)) ;
  57      ignore (self#append_column vcol)
  58    end
  59
  60   class ['a,'b] twoColumnsCList gtree_view ~column1_type ~column2_type
  61    ~column1_title ~column2_title
  62   =
  63    let obj =
  64     ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in
  65    let columns = new GTree.column_list in
  66    let col1 = columns#add column1_type in
  67    let vcol1 = GTree.view_column ~title:column1_title ()
  68     ~renderer:(GTree.cell_renderer_text[], ["text",col1]) in
  69    let col2 = columns#add column2_type in
  70    let vcol2 = GTree.view_column ~title:column2_title ()
  71     ~renderer:(GTree.cell_renderer_text[], ["text",col2]) in
  72    let store = GTree.list_store columns in
  73    object(self)
  74     inherit GTree.view obj
  75     method clear = store#clear
  76     method append (v1 : 'a) (v2 : 'b) =
  77      let row = store#append () in
  78       store#set ~row ~column:col1 v1;
  79       store#set ~row ~column:col2 v2
  80     method column1 = col1
  81     method column2 = col2
  82     initializer
  83      self#set_model (Some (store :> GTree.model)) ;
  84      ignore (self#append_column vcol1) ;
  85      ignore (self#append_column vcol2) ;
  86    end
  87
  88   class subscribeWindow () =
  89    object(self)
  90     inherit Hbugs_client_gui.subscribeWindow ()
  91     val mutable tutorsSmartCList = None
  92     method tutorsSmartCList =
  93      match tutorsSmartCList with
  94         None -> assert false
  95       | Some w -> w
  96     initializer
  97      tutorsSmartCList <-
  98       Some
  99        (new twoColumnsCList self#tutorsCList
 100          ~column1_type:Gobject.Data.string ~column2_type:Gobject.Data.string
 101          ~column1_title:"Id" ~column2_title:"Description")
 102    end
 103
 104   class hbugsMainWindow () =
 105    object(self)
 106     inherit Hbugs_client_gui.hbugsMainWindow ()
 107     val mutable subscriptionSmartCList = None
 108     val mutable hintsSmartCList = None
 109     method subscriptionSmartCList =
 110      match subscriptionSmartCList with
 111         None -> assert false
 112       | Some w -> w
 113     method hintsSmartCList =
 114      match hintsSmartCList with
 115         None -> assert false
 116       | Some w -> w
 117     initializer
 118      subscriptionSmartCList <-
 119       Some
 120        (new oneColumnCList self#subscriptionCList
 121          ~column_type:Gobject.Data.string ~column_title:"Description")
 122     initializer
 123      hintsSmartCList <-
 124       Some
 125        (new oneColumnCList self#hintsCList
 126          ~column_type:Gobject.Data.string ~column_title:"Description")
 127    end
 128
 129  end
 130 ;;
 131
 132 class hbugsClient
 133   ?(use_hint_callback: hint -> unit = do_nothing)
 134   ?(describe_hint_callback: hint -> unit = do_nothing)
 135   ?(destroy_callback: unit -> unit = do_nothing)
 136   ()
 137   =
 138
 139   let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in
 140   let port_of_http_url url =
 141     try
 142       let subs = Pcre.extract ~rex:http_url_RE url in
 143       int_of_string subs.(3)
 144     with e -> raise (Invalid_URL url)
 145   in
 146
 147   object (self)
 148
 149     val mainWindow = new SmartHbugs_client_gui.hbugsMainWindow ()
 150     val subscribeWindow = new SmartHbugs_client_gui.subscribeWindow ()
 151     val messageDialog = new Hbugs_client_gui.messageDialog ()
 152     val myOwnId = Hbugs_id_generator.new_client_id ()
 153     val mutable use_hint_callback = use_hint_callback
 154     val mutable myOwnUrl = "localhost:49082"
 155     val mutable brokerUrl = "localhost:49081"
 156     val mutable brokerId: broker_id option = None
 157       (* all available tutors, saved last time a List_tutors message was sent to
 158       broker *)
 159     val mutable availableTutors: tutor_dsc list = []
 160     val mutable statusContext = None
 161     val mutable subscribeWindowStatusContext = None
 162     val mutable debug = false (* enable/disable debugging buttons *)
 163     val mutable hints = []  (* actually available hints *)
 164
 165     initializer
 166       self#initGui;
 167       self#startLocalHttpDaemon ();
 168       self#testLocalHttpDaemon ();
 169       self#testBroker ();
 170       self#registerToBroker ();
 171       self#reconfigDebuggingButtons
 172
 173     method show = mainWindow#hbugsMainWindow#show
 174     method hide = mainWindow#hbugsMainWindow#misc#hide
 175
 176     method setUseHintCallback callback =
 177      use_hint_callback <- callback
 178
 179     method private debugButtons =
 180       List.map
 181         (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget)
 182         [ mainWindow#startLocalHttpDaemonButton;
 183         mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ]
 184
 185     method private initGui =
 186
 187         (* GUI: main window *)
 188
 189           (* ignore delete events so that hbugs window is closable only using
 190           menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked
 191           *)
 192
 193       ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true));
 194       ignore (mainWindow#hbugsMainWindow#event#connect#destroy
 195         (fun _ -> self#quit (); false));
 196
 197         (* GUI main window's menu *)
 198       mainWindow#toggleDebuggingMenuItem#set_active debug;
 199       ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled
 200         self#toggleDebug);
 201
 202         (* GUI: local HTTP daemon settings *)
 203       ignore (mainWindow#clientUrlEntry#connect#changed
 204         (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text));
 205       mainWindow#clientUrlEntry#set_text myOwnUrl;
 206       ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked
 207         self#startLocalHttpDaemon);
 208       ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked
 209         self#testLocalHttpDaemon);
 210
 211         (* GUI: broker choice *)
 212       ignore (mainWindow#brokerUrlEntry#connect#changed
 213         (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text));
 214       mainWindow#brokerUrlEntry#set_text brokerUrl;
 215       ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker);
 216       mainWindow#clientIdLabel#set_text myOwnId;
 217
 218         (* GUI: client registration *)
 219       ignore (mainWindow#registerClientButton#connect#clicked
 220         self#registerToBroker);
 221
 222         (* GUI: subscriptions *)
 223       ignore (mainWindow#showSubscriptionWindowButton#connect#clicked
 224         (fun () ->
 225           self#listTutors ();
 226           subscribeWindow#subscribeWindow#show ()));
 227
 228       let get_selected_row_index () =
 229        match mainWindow#hintsCList#selection#get_selected_rows with
 230           [path] ->
 231             (match GTree.Path.get_indices path with
 232                 [|n|] -> n
 233               | _ -> assert false)
 234         | _ -> assert false
 235       in
 236         (* GUI: hints list *)
 237       ignore (
 238        let event_ops = new GObj.event_ops mainWindow#hintsCList#as_widget in
 239         event_ops#connect#button_press
 240          (fun event ->
 241            if GdkEvent.get_type event = `TWO_BUTTON_PRESS then
 242             use_hint_callback (self#hint (get_selected_row_index ())) ;
 243            false));
 244
 245       ignore (mainWindow#hintsCList#selection#connect#changed
 246        (fun () ->
 247          describe_hint_callback (self#hint (get_selected_row_index ())))) ;
 248
 249         (* GUI: main status bar *)
 250       let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in
 251       statusContext <- Some ctxt;
 252       ignore (ctxt#push "Ready");
 253
 254         (* GUI: subscription window *)
 255       subscribeWindow#tutorsCList#selection#set_mode `MULTIPLE;
 256       ignore (subscribeWindow#subscribeWindow#event#connect#delete
 257         (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true));
 258       ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors);
 259       ignore (subscribeWindow#subscribeButton#connect#clicked
 260         self#subscribeSelected);
 261       ignore (subscribeWindow#subscribeAllButton#connect#clicked
 262         self#subscribeAll);
 263       (subscribeWindow#tutorsCList#get_column 0)#set_visible false;
 264       let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in
 265       subscribeWindowStatusContext <- Some ctxt;
 266       ignore (ctxt#push "Ready");
 267
 268         (* GUI: message dialog *)
 269       ignore (messageDialog#messageDialog#event#connect#delete
 270         (fun _ -> messageDialog#messageDialog#misc#hide (); true));
 271       ignore (messageDialog#okDialogButton#connect#clicked
 272         (fun _ -> messageDialog#messageDialog#misc#hide ()))
 273
 274     (* accessory methods *)
 275
 276       (** pop up a (modal) dialog window showing msg to the user *)
 277     method private showDialog msg =
 278       messageDialog#dialogLabel#set_text msg;
 279       messageDialog#messageDialog#show ()
 280       (** use showDialog to display an hbugs message to the user *)
 281     method private showMsgInDialog msg =
 282       self#showDialog (Hbugs_messages.string_of_msg msg)
 283
 284       (** create a new thread which sends msg to broker, wait for an answer and
 285       invoke callback passing response message as argument *)
 286     method private sendReq ?(wait = false) ~msg callback =
 287       let thread () =
 288         try
 289           callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg)
 290         with
 291         | (Hbugs_messages.Parse_error (subj, reason)) as e ->
 292             self#showDialog
 293               (sprintf
 294 "Parse_error, unable to fullfill request. Details follow.
 295 Request: %s
 296 Error: %s"
 297                 (Hbugs_messages.string_of_msg msg) (Printexc.to_string e));
 298         | (Unix.Unix_error _) as e ->
 299             self#showDialog
 300               (sprintf
 301 "Can't connect to HBugs Broker
 302 Url: %s
 303 Error: %s"
 304                 brokerUrl (Printexc.to_string e))
 305         | e ->
 306             self#showDialog
 307               (sprintf "hbugsClient#sendReq: Uncaught exception: %s"
 308                 (Printexc.to_string e))
 309       in
 310       let th = Thread.create thread () in
 311       if wait then
 312         Thread.join th
 313       else ()
 314
 315       (** check if a broker is authenticated using its broker_id
 316       [ Background: during client registration, client save broker_id of its
 317       broker, further messages from broker are accepted only if they carry the
 318       same broker id ] *)
 319     method private isAuthenticated id =
 320       match brokerId with
 321       | None -> false
 322       | Some broker_id -> (id = broker_id)
 323
 324     (* actions *)
 325
 326     method private startLocalHttpDaemon =
 327         (* flatten an hint tree to an hint list *)
 328       let rec flatten_hint = function
 329         | Hints hints -> List.concat (List.map flatten_hint hints)
 330         | hint -> [hint]
 331       in
 332       fun () ->
 333       let callback req outchan =
 334         try
 335           (match Hbugs_messages.msg_of_string req#body with
 336           | Help ->
 337               Hbugs_messages.respond_msg
 338                 (Usage "Local Http Daemon up and running!") outchan
 339           | Hint (broker_id, hint) ->
 340               if self#isAuthenticated broker_id then begin
 341                 let received_hints = flatten_hint hint in
 342                 List.iter
 343                   (fun h ->
 344                     (match h with Hints _ -> assert false | _ -> ());
 345                     ignore(mainWindow#hintsSmartCList#append(string_of_hint h)))
 346                   received_hints;
 347                 hints <- hints @ received_hints;
 348                 Hbugs_messages.respond_msg (Wow myOwnId) outchan
 349               end else  (* msg from unauthorized broker *)
 350                 Hbugs_messages.respond_exc "forbidden" broker_id outchan
 351           | msg ->
 352               Hbugs_messages.respond_exc
 353                 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 354         with (Hbugs_messages.Parse_error _) as e ->
 355           Hbugs_messages.respond_exc
 356             "parse_error" (Printexc.to_string e) outchan
 357       in
 358       let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used
 359                               only as a value to be sent to broker, local HTTP
 360                               daemon will listen on "0.0.0.0", port is parsed
 361                               from My URL though *)
 362       let httpDaemonThread () =
 363         try
 364           Http_daemon.start'
 365             ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback
 366         with
 367         | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url)
 368         | e ->
 369             self#showDialog (sprintf "Can't start local HTTP daemon: %s"
 370               (Printexc.to_string e))
 371       in
 372       ignore (Thread.create httpDaemonThread ())
 373
 374     method private testLocalHttpDaemon () =
 375       try
 376         let msg =
 377           Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help)
 378             myOwnUrl
 379         in
 380         ignore msg
 381 (*         self#showDialog msg *)
 382       with
 383       | Hbugs_misc.Malformed_URL url ->
 384           self#showDialog
 385             (sprintf
 386               "Handshake with local HTTP daemon failed, Invalid URL: \"%s\""
 387               url)
 388       | Hbugs_misc.Malformed_HTTP_response res ->
 389           self#showDialog
 390             (sprintf
 391     "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\""
 392               res)
 393       | (Unix.Unix_error _) as e ->
 394           self#showDialog
 395             (sprintf
 396               "Handshake with local HTTP daemon failed, can't connect: \"%s\""
 397               (Printexc.to_string e))
 398
 399     method private testBroker () =
 400       self#sendReq ~msg:Help
 401         (function
 402           | Usage _ -> ()
 403           | unexpected_msg ->
 404               self#showDialog
 405                 (sprintf
 406                   "Handshake with HBugs Broker failed, unexpected message:\n%s"
 407                   (Hbugs_messages.string_of_msg unexpected_msg)))
 408
 409     method registerToBroker () =
 410       (match brokerId with  (* undo previous registration, if any *)
 411       | Some id -> self#unregisterFromBroker ()
 412       | _ -> ());
 413       self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl))
 414         (function
 415           | Client_registered broker_id -> (brokerId <- Some broker_id)
 416           | unexpected_msg ->
 417               self#showDialog
 418                 (sprintf "Client NOT registered, unexpected message:\n%s"
 419                   (Hbugs_messages.string_of_msg unexpected_msg)))
 420
 421     method unregisterFromBroker () =
 422       self#sendReq ~wait:true ~msg:(Unregister_client myOwnId)
 423         (function
 424           | Client_unregistered _ -> (brokerId <- None)
 425           | unexpected_msg -> ())
 426 (*
 427               self#showDialog
 428                 (sprintf "Client NOT unregistered, unexpected message:\n%s"
 429                   (Hbugs_messages.string_of_msg unexpected_msg)))
 430 *)
 431
 432     method stateChange new_state =
 433       mainWindow#hintsSmartCList#clear ();
 434       hints <- [];
 435       self#sendReq
 436         ~msg:(State_change (myOwnId, new_state))
 437         (function
 438           | State_accepted _ -> ()
 439           | unexpected_msg ->
 440               self#showDialog
 441                 (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s"
 442                   (Hbugs_messages.string_of_msg unexpected_msg)))
 443
 444     method hint = List.nth hints
 445
 446     method private listTutors () =
 447         (* wait is set to true just to make sure that after invoking listTutors
 448         "availableTutors" is correctly filled *)
 449       self#sendReq ~wait:true ~msg:(List_tutors myOwnId)
 450         (function
 451           | Tutor_list (_, descriptions) ->
 452               availableTutors <-  (* sort accordingly to tutor description *)
 453                 List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions;
 454               subscribeWindow#tutorsSmartCList#clear ();
 455               List.iter
 456                 (fun (id, dsc) ->
 457                   ignore (subscribeWindow#tutorsSmartCList#append id dsc))
 458                 availableTutors
 459           | unexpected_msg ->
 460               self#showDialog
 461                 (sprintf "Can't list tutors, unexpected message:\n%s"
 462                   (Hbugs_messages.string_of_msg unexpected_msg)))
 463
 464       (* low level used by subscribeSelected and subscribeAll *)
 465     method private subscribe' tutors_id =
 466       self#sendReq ~msg:(Subscribe (myOwnId, tutors_id))
 467         (function
 468           | (Subscribed (_, subscribedTutors)) as msg ->
 469               let sort = List.sort compare in
 470               mainWindow#subscriptionSmartCList#clear ();
 471               List.iter
 472                 (fun tutor_id ->
 473                   ignore
 474                     (mainWindow#subscriptionSmartCList#append
 475                       ( try
 476                           List.assoc tutor_id availableTutors
 477                         with Not_found -> assert false )))
 478                 tutors_id;
 479               subscribeWindow#subscribeWindow#misc#hide ();
 480               if sort subscribedTutors <> sort tutors_id then
 481                 self#showDialog
 482                   (sprintf "Subscription mismatch\n: %s"
 483                     (Hbugs_messages.string_of_msg msg))
 484           | unexpected_msg ->
 485               mainWindow#subscriptionSmartCList#clear ();
 486               self#showDialog
 487                 (sprintf "Subscription FAILED, unexpected message:\n%s"
 488                   (Hbugs_messages.string_of_msg unexpected_msg)))
 489
 490     method private subscribeSelected () =
 491      let tutorsSmartCList = subscribeWindow#tutorsSmartCList in
 492      let selectedTutors =
 493        List.map
 494         (fun p ->
 495           tutorsSmartCList#model#get
 496            ~row:(tutorsSmartCList#model#get_iter p)
 497            ~column:tutorsSmartCList#column1)
 498         tutorsSmartCList#selection#get_selected_rows
 499      in
 500       self#subscribe' selectedTutors
 501
 502     method subscribeAll () =
 503       self#listTutors ();  (* this fills 'availableTutors' field *)
 504       self#subscribe' (List.map fst availableTutors)
 505
 506     method private quit () =
 507       self#unregisterFromBroker ();
 508       destroy_callback ()
 509
 510       (** enable/disable debugging *)
 511     method private setDebug value = debug <- value
 512
 513     method private reconfigDebuggingButtons =
 514       List.iter (* debug value changed, reconfigure buttons *)
 515         (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ())
 516         self#debugButtons;
 517
 518     method private toggleDebug () =
 519       self#setDebug (not debug);
 520       self#reconfigDebuggingButtons
 521
 522   end
 523 ;;
 524