src/gtk/gui/gui_main.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Printf2
  21 open Options
  22 open Gettext
  23 open Gui_global
  24 module O = Gui_options
  25 module M = Gui_messages
  26 module Com = Gui_com
  27 module G = Gui_global
  28 module Mi = Gui_misc
  29
  30 (*module Gui_rooms = Gui_rooms2*)
  31
  32 let _ =
  33   (try Options.load O.mldonkey_gui_ini with
  34       Sys_error _ ->
  35         (try Options.save O.mldonkey_gui_ini with _ -> ())
  36      | e ->
  37         lprintf "Exception %s in load options %s\n"
  38          (Printexc2.to_string e)
  39          (Options.options_file_name O.mldonkey_gui_ini);
  40
  41   );
  42   let args =
  43     ("-dump_msg", Arg.Unit (fun _ ->
  44           Options.save Gui_messages.message_file
  45       ), ": update internationalisation message file")::
  46     Options.simple_args "" O.mldonkey_gui_ini in
  47   Arg.parse args (Arg.usage args)  "mlgui: the GUI to use with mldonkey"
  48
  49 (* Check bindings *)
  50 let _ =
  51   if !!O.keymap_global = [] then
  52     (
  53      let a = O.add_binding O.keymap_global in
  54      a "A-s" M.a_page_servers;
  55      a "A-d" M.a_page_downloads;
  56      a "A-f" M.a_page_friends;
  57      a "A-q" M.a_page_queries;
  58      a "A-r" M.a_page_results;
  59      a "A-m" M.a_page_rooms ;
  60      a "A-u" M.a_page_uploads;
  61      a "A-o" M.a_page_options;
  62      a "A-c" M.a_page_console;
  63      a "A-h" M.a_page_help;
  64      a "A-Left" M.a_previous_page;
  65      a "A-Right" M.a_next_page;
  66      a "C-r" M.a_reconnect;
  67      a "C-q" M.a_exit ;
  68     );
  69   if !!O.keymap_servers = [] then
  70     (
  71      let a = O.add_binding O.keymap_servers in
  72      a "C-c" M.a_connect;
  73      a "C-m" M.a_connect_more;
  74      a "C-a" M.a_select_all;
  75     );
  76   if !!O.keymap_downloads = [] then
  77     (
  78      let a = O.add_binding O.keymap_downloads in
  79      a "C-c" M.a_cancel_download;
  80      a "CS-s" M.a_save_all_files;
  81      a "C-s" M.a_menu_save_file;
  82      a "C-a" M.a_select_all;
  83     );
  84   if !!O.keymap_friends = [] then
  85     (
  86      let a = O.add_binding O.keymap_friends in
  87      a "C-d" M.a_download_selection;
  88      a "C-x" M.a_remove_friend;
  89      a "C-a" M.a_select_all;
  90     );
  91   if !!O.keymap_queries = [] then
  92     (
  93      let a = O.add_binding O.keymap_queries in
  94      ()
  95     );
  96   if !!O.keymap_results = [] then
  97     (
  98      let a = O.add_binding O.keymap_results in
  99      ()
 100     );
 101   if !!O.keymap_console = [] then
 102     (
 103      let a = O.add_binding O.keymap_console in
 104      ()
 105     )
 106
 107 (** {2 Handling core messages} *)
 108
 109 open CommonTypes
 110 open GuiTypes
 111 open GuiProto
 112
 113 let canon_client gui c =
 114   let box_file_locs = gui#tab_downloads#box_locations in
 115   let box_friends = gui#tab_friends#box_friends in
 116   let box_downloads = gui#tab_downloads in
 117   let c =
 118     try
 119       let cc = Hashtbl.find G.locations c.client_num in
 120
 121       let is_in_locations =
 122         try
 123           ignore (box_file_locs#find_client c.client_num);
 124           true
 125         with _ -> false
 126       in
 127       if is_in_locations then
 128         gui#tab_downloads#h_update_location c;
 129
 130       cc.client_state <- c.client_state;
 131
 132       if c.client_state = RemovedHost then begin
 133 (*          lprintf "Removing client %d" c.client_num; lprint_newline ();
 134 *)
 135           Hashtbl.remove G.locations c.client_num;
 136 (*          gui#tab_downloads#box_downloads#remove_client cc.client_num *)
 137         end;
 138
 139       begin
 140         if c.client_type <> cc.client_type then begin
 141             if c.client_type = 0 then
 142                 box_friends#h_remove_friend c.client_num
 143             else
 144                 box_friends#h_update_friend cc
 145           end
 146       end;
 147
 148       cc.client_type <- c.client_type;
 149       cc.client_rating <- c.client_rating;
 150       cc.client_name <- c.client_name;
 151
 152       cc.client_kind <- c.client_kind;
 153       cc.client_tags <- c.client_tags;
 154       begin
 155         if c.client_type <> 0 then
 156           box_friends#h_update_friend cc;
 157       end;
 158
 159       cc
 160     with _ ->
 161 (*        lprintf "Adding client %d" c.client_num; lprint_newline ();  *)
 162         Hashtbl.add G.locations c.client_num c;
 163         begin
 164           if c.client_type <> 0 then
 165             box_friends#h_update_friend c;
 166         end;
 167         c
 168   in
 169   c
 170
 171 let verbose_gui_messages = ref false
 172
 173 let value_reader gui t =
 174   try
 175
 176     if !verbose_gui_messages then begin
 177         lprintf "MESSAGE RECEIVED: %s"
 178           (string_of_to_gui t);
 179         lprint_newline ();
 180
 181       end;
 182
 183
 184     match t with
 185     | Console text ->
 186         gui#tab_console#insert text
 187
 188     | Network_info n ->
 189         begin
 190           try
 191             let nn = Hashtbl.find Gui_global.networks n.network_netnum
 192             in
 193             nn.net_enabled <- n.network_enabled;
 194             nn.net_menu_item#set_active n.network_enabled
 195           with _ ->
 196               let display_menu_item =
 197                 GMenu.check_menu_item ~label: n.network_netname ~active:true
 198                 ~packing:gui#menu_display#add ()
 199               in
 200               let network_menu_item =
 201                 GMenu.check_menu_item ~label: n.network_netname
 202                   ~active:n.network_enabled
 203                   ~packing:gui#menu_networks#add ()
 204               in
 205               let nn = {
 206                   net_num = n.network_netnum;
 207                   net_name = n.network_netname;
 208                   net_enabled = n.network_enabled;
 209                   net_menu_item = network_menu_item;
 210                   net_displayed = true;
 211                 } in
 212               ignore (network_menu_item#connect#toggled ~callback:(fun _ ->
 213                     nn.net_enabled <- not nn.net_enabled;
 214                     Com.send (EnableNetwork (n.network_netnum,
 215                         network_menu_item#active)
 216                     )));
 217               ignore (display_menu_item#connect#toggled ~callback:(fun _ ->
 218                     nn.net_displayed <- not nn.net_displayed;
 219                     networks_filtered := (if nn.net_displayed then
 220                         List2.removeq nn.net_num !networks_filtered
 221                       else nn.net_num :: !networks_filtered);
 222                     gui#tab_servers#h_server_filter_networks;
 223                     gui#tab_queries#h_search_filter_networks;
 224                 ));
 225               Hashtbl.add Gui_global.networks n.network_netnum nn;
 226               ()
 227         end
 228
 229     | Client_stats s ->
 230         gui#tab_uploads#wl_status#set_text
 231           (Printf.sprintf "Shared: %5d/%-12s   U/D bytes/s: %7d[%5d]/%-7d[%5d]"
 232             s.nshared_files
 233             (Gui_misc.size_of_int64 s.upload_counter)
 234           (s.tcp_upload_rate + s.udp_upload_rate) s.udp_upload_rate
 235             (s.tcp_download_rate + s.udp_download_rate) s.udp_download_rate
 236         )
 237
 238     | CoreProtocol (v, _, _) ->
 239
 240         let version = min v GuiProto.best_gui_version in
 241         for i = 0 to to_gui_last_opcode do
 242           Gui_com.to_gui_protocol_used.(i) <- version;
 243         done;
 244         for i = 0 to from_gui_last_opcode do
 245           Gui_com.from_gui_protocol_used.(i) <- version;
 246         done;
 247         lprintf "Using protocol %d for communications\n" version;
 248         gui#label_connect_status#set_text (gettext M.connected);
 249         Com.send (Password (!!O.login, !!O.password))
 250
 251     | Search_result (num,r,_) ->
 252         begin try
 253             let r = Hashtbl.find G.results r in
 254             gui#tab_queries#h_search_result num r
 255           with _ ->
 256               lprintf "Exception in Search_result %d %d\n" num r;
 257         end
 258
 259     | Search_waiting (num,waiting) ->
 260         gui#tab_queries#h_search_waiting num waiting
 261
 262     | File_add_source (num, src) ->
 263         gui#tab_downloads#h_file_location num src;
 264
 265     | File_remove_source (num, src) ->
 266         gui#tab_downloads#h_file_remove_location num src;
 267
 268     | File_downloaded (num, downloaded, rate, last_seen) ->
 269         gui#tab_downloads#h_file_downloaded num downloaded rate;
 270         gui#tab_downloads#h_file_last_seen num last_seen
 271
 272     | File_update_availability (file_num, client_num, avail) ->
 273         gui#tab_downloads#h_file_availability file_num client_num avail;
 274
 275     | File_info f ->
 276 (*        lprintf "FILE INFO"; lprint_newline (); *)
 277         gui#tab_downloads#h_file_info f;
 278
 279     | Server_info s ->
 280 (*        lprintf "server info"; lprint_newline (); *)
 281         gui#tab_servers#h_server_info s
 282
 283     | Server_state (key,state) ->
 284         gui#tab_servers#h_server_state key state
 285
 286     | Server_busy (key,nusers, nfiles) ->
 287         gui#tab_servers#h_server_busy key nusers nfiles
 288
 289     | Server_user (key, user) ->
 290 (*        lprintf "server user %d %d" key user; lprint_newline (); *)
 291         if not (Hashtbl.mem G.users user) then begin
 292 (*            lprintf "Unknown user %d" user; lprint_newline ();*)
 293             Gui_com.send (GetUser_info user);
 294           end else
 295           begin
 296             gui#tab_servers#h_server_user key user
 297           end
 298
 299     | Room_info room ->
 300 (*        lprintf "Room info %d" room.room_num; lprint_newline (); *)
 301         gui#tab_rooms#room_info room
 302
 303     | User_info user ->
 304         let user = try
 305             let u = Hashtbl.find G.users user.user_num  in
 306             u.user_tags <- user.user_tags;
 307             u
 308           with Not_found ->
 309               Hashtbl.add G.users user.user_num user;
 310               user
 311         in
 312 (*        lprintf "user_info %s/%d" user.user_name user.user_server; lprint_newline (); *)
 313         gui#tab_servers#h_server_user user.user_server user.user_num;
 314         Gui_rooms.user_info user
 315
 316     | Room_add_user (num, user_num) ->
 317
 318         begin try
 319             gui#tab_rooms#add_room_user num user_num
 320           with e ->
 321               lprintf "Exception in Room_user %d %d" num user_num;
 322               lprint_newline ();
 323         end
 324
 325     | Room_remove_user (num, user_num) ->
 326
 327         begin try
 328             gui#tab_rooms#remove_room_user num user_num
 329           with e ->
 330               lprintf "Exception in Room_user %d %d" num user_num;
 331               lprint_newline ();
 332         end
 333
 334     | Options_info list ->
 335 (*        lprintf "Options_info"; lprint_newline ();*)
 336         let module M = Options in
 337         let rec iter list =
 338           match list with
 339             [] -> ()
 340           | o :: tail ->
 341               (
 342                 try
 343                   let reference =
 344                     List.assoc o.M.option_name Gui_options.client_options_assocs
 345                   in
 346                   reference := o.M.option_value;
 347                   Gui_config.add_option_value o.M.option_name reference
 348                 with _ ->
 349                     Gui_config.add_option_value o.M.option_name (ref o.M.option_value)
 350               );
 351               iter tail
 352         in
 353         iter list
 354
 355     | Add_section_option (section, o) ->
 356         let optype = match o.option_type with
 357             "Bool" -> BoolEntry
 358           | "Filename" -> FileEntry
 359           | _ -> StringEntry in
 360         let line = o.option_desc, optype, o.option_name in
 361         (try
 362             let options = List.assoc section !client_sections in
 363             if not (List.mem line !options) then
 364               options := !options @ [line]
 365           with _ ->
 366               client_sections := !client_sections  @[section, ref [line]]
 367         )
 368
 369     | Add_plugin_option (section, o) ->
 370         let optype = match o.option_type with
 371             "Bool" -> BoolEntry
 372           | "Filename" -> FileEntry
 373           | _ -> StringEntry in
 374         let line = o.option_desc, optype, o.option_name in
 375         (try
 376             let options = List.assoc section !plugins_sections in
 377             if not (List.mem line !options) then
 378               options := !options @ [line]
 379         with _ ->
 380             plugins_sections := !plugins_sections  @[section, ref [line]]
 381         )
 382
 383     | DefineSearches l ->
 384         gui#tab_queries#h_define_searches l
 385
 386     | Client_state (num, state) ->
 387 (*
 388         lprintf "Client_state" ; lprint_newline ();
 389 *)
 390         (
 391           try
 392             let c = Hashtbl.find G.locations num in
 393             ignore (canon_client gui { c with client_state = state })
 394           with _ ->
 395               Com.send (GetClient_info num)
 396         )
 397
 398     | Client_friend (num, friend_kind) ->
 399         (
 400           try
 401             let c = Hashtbl.find G.locations num in
 402             ignore (canon_client gui { c with client_type = friend_kind });
 403           with _ ->
 404               Com.send (GetClient_info num)
 405         )
 406
 407     | Result_info r ->
 408
 409         if not (Hashtbl.mem G.results r.result_num) then
 410           Hashtbl.add G.results r.result_num r
 411
 412     | Client_file (num , dirname, file_num) ->
 413 (* Here, the dirname is forgotten: it should be used to build a tree
 414   when possible... *)
 415
 416         (
 417           try
 418             let file = Hashtbl.find G.results file_num in
 419             try
 420               let c = Hashtbl.find G.locations num in
 421               try
 422                 let tree = { file_tree_list = []; file_tree_name = "" } in
 423                 add_file tree dirname file;
 424 (*
 425                 ignore (canon_client gui { c with client_files = Some tree })
 426 *)
 427
 428               with _ ->
 429 (*                  lprintf "File already there"; lprint_newline (); *)
 430                   ()
 431             with _ ->
 432 (*                lprintf "Unknown client %d" num; lprint_newline (); *)
 433                 Com.send (GetClient_info num);
 434           with _ ->
 435 (*              lprintf "Unknown file %d" file_num;
 436               lprint_newline (); *)
 437               ()
 438         )
 439
 440     | Client_info c ->
 441 (*        lprintf "Client_info"; lprint_newline (); *)
 442         (
 443          try
 444            ignore (canon_client gui c) ;
 445          with _ -> ()
 446         )
 447 (* A VOIR : Ca sert à quoi le bouzin ci-dessous ?
 448 ben, ca sert a mettre a jour la liste des locations affichees pour un
 449 fichier selectionne. Si ca marche toujours dans ton interface, pas de
 450   probleme ...
 451         begin
 452           match !current_file with
 453             None -> ()
 454           | Some file ->
 455               let num = c.client_num in
 456               match file.file_more_info with
 457                 None -> ()
 458               | Some fmi ->
 459                   if array_memq num fmi.file_known_locations ||
 460                     array_memq num fmi.file_indirect_locations then
 461                     let c = Hashtbl.find locations c.client_num in
 462                     if is_connected c.client_state then incr nclocations;
 463                     MyCList.update clist_file_locations c.client_num c
 464         end
 465 *)
 466
 467
 468     | Room_message (_, PrivateMessage(num, mes) )
 469     | Room_message (0, PublicMessage(num, mes) )
 470     | MessageFromClient (num, mes) ->
 471         (
 472          try
 473            let c = Hashtbl.find G.locations num in
 474            let d = gui#tab_friends#get_dialog c in
 475            d#handle_message mes
 476          with
 477             Not_found ->
 478               try
 479                 match t with
 480                   Room_message (num, msg) ->
 481                     gui#tab_rooms#add_room_message num msg
 482                 | _ -> raise Not_found
 483               with Not_found ->
 484                   lprintf "Client %d not found in reader.MessageFromClient" num;
 485                   lprint_newline ()
 486         )
 487
 488     | Room_message (num, msg) ->
 489         begin try
 490             gui#tab_rooms#add_room_message num msg
 491           with e ->
 492               lprintf "Exception in Room_message %d" num;
 493               lprint_newline ();
 494         end
 495
 496     | (DownloadedFiles _|DownloadFiles _|ConnectedServers _) -> assert false
 497
 498     | Shared_file_info si ->
 499         gui#tab_uploads#h_shared_file_info si
 500
 501     | CleanTables (clients, servers) ->
 502         gui#tab_servers#clean_table servers;
 503         gui#tab_downloads#clean_table clients
 504
 505     | Shared_file_upload (num,size,requests) ->
 506         gui#tab_uploads#h_shared_file_upload num size requests
 507     | Shared_file_unshared _ ->  ()
 508     | BadPassword ->
 509         GToolbox.message_box ~title: "Bad Password"
 510         "Authorization Failed\nPlease, open the File->Settings menu and
 511           enter a valid password"
 512     | GiftServerAttach _
 513     | GiftServerStats _ -> assert false
 514     | Uploaders l -> ()
 515     | Pending l -> ()
 516
 517     | Search s -> ()
 518     | Version _ -> ()
 519     | Stats (_, _) -> ()
 520
 521   with e ->
 522       lprintf "Exception %s in reader\n" (Printexc2.to_string e)
 523
 524
 525 let generate_connect_menu gui =
 526   let add_item hostname port =
 527     let menu_item =
 528       let label = Printf.sprintf "%s:%d" hostname port in
 529       GMenu.menu_item ~label: label
 530       ~packing:gui#cores_menu#add ()
 531       in
 532     ignore (menu_item#connect#activate ~callback:(fun _ ->
 533           O.hostname =:= hostname;
 534           O.port =:= port;
 535           Com.reconnect gui value_reader BasicSocket.Closed_by_user
 536       ));
 537   in
 538   List.iter (fun child -> child#destroy ()) gui#cores_menu#children;
 539   List.iter (fun (h,port) ->  add_item h port) !!O.history;
 540   let _ = GMenu.menu_item ~packing:(gui#cores_menu#add) () in
 541  List.iter (fun (h,port) ->  add_item h port) !G.scanned_ports
 542
 543 let main () =
 544   let gui = new Gui_window.window () in
 545   let w = gui#window in
 546   let quit () =
 547     CommonGlobals.exit_properly 0
 548   in
 549   Gui_config.update_toolbars_style gui;
 550   List.iter (fun (menu, init) ->
 551       let _Menu = GMenu.menu_item ~label:menu  ~packing:(gui#menubar#add) ()
 552       in
 553       let _menu = GMenu.menu ~packing:(_Menu#set_submenu) () in
 554       init _menu
 555   ) !Gui_global.top_menus;
 556   ignore (w#connect#destroy quit);
 557
 558   console_message := (fun s ->
 559
 560 (*
 561       lprintf "to primary"; lprint_newline ();
 562       let e = gui#tab_console#text in
 563
 564       ignore (GtkBase.Selection.owner_set e#as_widget `PRIMARY 0);
 565 (*      ignore(e#misc#grab_selection `PRIMARY); *)
 566 (*      e#misc#add_selection_target ~target:"string" `PRIMARY;
 567       ignore (e#misc#connect#selection_get (fun sel ~info ~time ->
 568             lprintf "request selection"; lprint_newline ();
 569             sel#return s
 570         )); *)
 571       ignore (e#event#connect#selection_clear  (fun sel ->
 572             lprintf "selection cleared"; lprint_newline ();
 573             true
 574         ));
 575       ignore (e#event#connect#selection_request (fun sel ->
 576             lprintf "Selection request"; lprint_newline ();
 577             true
 578         ));
 579       ignore (e#event#connect#selection_notify (fun sel ->
 580             lprintf "Selection notify"; lprint_newline ();
 581             true
 582 ));
 583   *)
 584       gui#tab_console#insert s);
 585
 586   CommonGlobals.do_at_exit (fun _ ->
 587       Gui_misc.save_gui_options gui;
 588       Gui_com.disconnect gui BasicSocket.Closed_by_user);
 589 (** menu actions *)
 590   ignore (gui#itemQuit#connect#activate (fun () ->
 591         CommonGlobals.exit_properly 0)) ;
 592   ignore (gui#itemKill#connect#activate (fun () -> Com.send KillServer));
 593   ignore (gui#itemReconnect#connect#activate
 594       (fun () ->Com.reconnect gui value_reader BasicSocket.Closed_by_user));
 595   ignore (gui#itemDisconnect#connect#activate
 596             (fun () -> Com.disconnect gui BasicSocket.Closed_by_user));
 597   ignore (gui#itemServers#connect#activate (fun () -> gui#notebook#goto_page 0));
 598   ignore (gui#itemDownloads#connect#activate (fun () -> gui#notebook#goto_page 1));
 599   ignore (gui#itemFriends#connect#activate (fun () -> gui#notebook#goto_page 2));
 600   ignore (gui#itemResults#connect#activate (fun () -> gui#notebook#goto_page 3));
 601   ignore (gui#itemRooms#connect#activate (fun () -> gui#notebook#goto_page 4));
 602   ignore (gui#itemUploads#connect#activate (fun () -> gui#notebook#goto_page 5));
 603   ignore (gui#itemConsole#connect#activate (fun () -> gui#notebook#goto_page 6));
 604   ignore (gui#itemHelp#connect#activate (fun () -> gui#notebook#goto_page 7));
 605
 606   ignore (gui#itemOptions#connect#activate (fun () -> Gui_config.edit_options gui));
 607
 608   ignore (gui#itemScanPorts#connect#activate (fun _ ->
 609         Com.scan_ports ()
 610     ));
 611
 612   (************ Some hooks ***************)
 613   option_hook Gui_options.notebook_tab (fun _ ->
 614       gui#notebook#set_tab_pos !!Gui_options.notebook_tab
 615   );
 616
 617   (** connection with core *)
 618   Com.reconnect gui value_reader BasicSocket.Closed_by_user ;
 619 (*  BasicSocket.add_timer 2.0 update_sizes;*)
 620   let never_connected = ref true in
 621   BasicSocket.add_timer 1.0 (fun timer ->
 622       if !G.new_scanned_port then begin
 623           generate_connect_menu gui
 624         end;
 625
 626       if !never_connected && not (Com.connected ()) then  begin
 627           BasicSocket.reactivate_timer timer;
 628           Com.reconnect gui value_reader BasicSocket.Closed_by_user
 629         end else
 630         never_connected := false
 631   )
 632
 633 let _ =
 634   CommonGlobals.gui_included := true;
 635   main ()