src/networks/direct_connect/dcGlobals.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 open Int64ops
  20 open Printf2
  21 open Md4
  22
  23 open CommonFile
  24 open CommonOptions
  25 open CommonSearch
  26 open CommonResult
  27 open BasicSocket
  28 open TcpBufferedSocket
  29 open CommonGlobals
  30 open CommonTypes
  31 open CommonClient
  32 open CommonComplexOptions
  33 open GuiProto
  34 open Options
  35 open CommonUser
  36 open CommonRoom
  37 open CommonTypes
  38 open CommonShared
  39 open CommonServer
  40 open CommonUploads
  41 open CommonInteractive
  42 open CommonNetwork
  43
  44 open DcTypes
  45 open DcOptions
  46
  47 let log_prefix = "[dcGlo]"
  48
  49 let lprintf_nl fmt =
  50   lprintf_nl2 log_prefix fmt
  51
  52 exception Found_client of DcTypes.client
  53 exception Found_server of DcTypes.server
  54 exception Found_file of DcTypes.file
  55 exception Found_user of DcTypes.user
  56 exception Wrong_file_size of Int64.t * Int64.t
  57 exception BreakIter
  58
  59 let network = new_network "DC" "Direct Connect"
  60     [
  61     NetworkHasServers;
  62     (*NetworkHasRooms;*)
  63     NetworkHasChat;
  64     NetworkHasSearch;
  65     NetworkHasUpload;
  66     ]
  67
  68 let connection_manager = network.network_connection_manager
  69
  70 let (server_ops : server CommonServer.server_ops) =
  71   CommonServer.new_server_ops network
  72
  73 let (user_ops : user CommonUser.user_ops) =
  74   CommonUser.new_user_ops network
  75
  76 let (file_ops : file CommonFile.file_ops) =
  77   CommonFile.new_file_ops network
  78
  79 let (client_ops : client CommonClient.client_ops) =
  80   CommonClient.new_client_ops network
  81
  82 let (shared_ops : CommonUploads.shared_file CommonShared.shared_ops) =
  83   CommonShared.new_shared_ops network
  84
  85 let once_create_filelist = ref false    (* filelist creation one time on start     *)
  86 let once_connect_to_servers = ref false (* autoconnection done to servers on start *)
  87
  88 let file_disk_name file = file_disk_name (as_file file.file_file)
  89 let dc_tcp_listen_sock = ref (None : TcpServerSocket.t option)
  90 let dc_udp_sock = ref (None : UdpSocket.t option)
  91 (*let nservers = ref 0  *)                        (* connected servers count *)
  92 let connected_servers = ref ([]: server list) (* list of connected servers (servers that have sent $Hello to us)*)
  93 let servers_by_ip : (string , server) Hashtbl.t = Hashtbl.create 10
  94 let users_by_name = Hashtbl.create 113
  95 let current_files = ref ([]: file list)
  96 let dc_files_by_unchecked_hash : (string , file) Hashtbl.t = Hashtbl.create 47
  97 let dc_files_by_key = Hashtbl.create 47
  98 let dc_tiger_computing = ref false
  99 let dc_get_nchunks size = Int64.to_int (size // CommonUploads.tiger_block_size) + 1
 100 let dc_shared_files_by_fullname : (string , dc_shared_file) Hashtbl.t = Hashtbl.create 30
 101 let dc_shared_files_by_codedname : (string , dc_shared_file) Hashtbl.t = Hashtbl.create 30
 102 let dc_shared_files_by_hash : (string , dc_shared_file) Hashtbl.t = Hashtbl.create 30
 103 let dc_result_info : (int , dc_result) Hashtbl.t = Hashtbl.create 30
 104 let dc_results_by_file : ((string * string * int64), CommonTypes.result) Hashtbl.t = Hashtbl.create 30
 105 let dc_files_to_hash = ref ([] : dc_shared_file list)
 106 let dc_last_manual_search = ref 0.
 107 let dc_last_autosearch = ref (None : CommonTypes.search option)
 108 let dc_last_autosearch_time = ref 0.
 109 let dc_total_uploaded = ref Int64.zero
 110 (*let current_open_slots = ref 0*)
 111 (*let clients_by_name = Hashtbl.create 113*)
 112 let clients_list = ref ([] : client list)
 113 let dc_hublist = ref ([] : dc_hub list) (* list for DC servers *)
 114 let temp_nick = ref "unknown"
 115 let temp_nick_num = ref 0 (* this is used to name temporary users always with different name *)
 116 let used_slots = ref 0
 117 let dc_download_preread = ref 128 (* max (int64_kbyte-1) atm. Used to make simple check of file corruption *)
 118 let dc_config_files_loaded = ref false
 119 let char5 = char_of_int 5   (* /005 *)
 120 let char13 = char_of_int 13 (* \r *)
 121 let char32 = char_of_int 32 (* "space" *)
 122 let char38 = char_of_int 38 (* & *)
 123 let char39 = char_of_int 39 (* ' *)
 124 let char42 = char_of_int 42 (* * *)
 125 let char43 = char_of_int 43 (* + *)
 126 let char58 = char_of_int 58 (* : *)
 127 let char60 = char_of_int 60 (* < *)
 128 let char62 = char_of_int 62 (* > *)
 129 let char92 = char_of_int 92 (* slash \ *)
 130 let char129 = char_of_int 129 (* extended ASCII *)
 131 let char154 = char_of_int 154 (* extended ASCII *)
 132 let char160 = char_of_int 160 (* extended ASCII *)
 133 let char165 = char_of_int 165 (* extended ASCII *)
 134 let empty_string = ""
 135 let int64_kbyte = Int64.of_int 1024
 136 let int64_mbyte = Int64.mul int64_kbyte int64_kbyte
 137 let int64_gbyte = Int64.mul int64_mbyte int64_kbyte
 138 let int64_64kbytes = Int64.mul int64_kbyte (Int64.of_int 64)
 139 let random_port = (Random.int 60000) + 1025
 140 let mylist_ext = ".DcLst"
 141 let bz2_ext = ".bz2"
 142 let xml_ext = ".xml"
 143 let mylistxmlbz2_ext = xml_ext ^ bz2_ext
 144 let mylist = "MyList" ^ mylist_ext
 145 let mylistxmlbz2 = "files" ^  mylistxmlbz2_ext
 146 let directconnect_directory = "direct_connect"
 147 let filelist_directory = Filename.concat directconnect_directory "filelists"
 148 let last_share_size = ref 0
 149
 150 (* These are the $Supports commands that MLDonkey understands at the moment *)
 151 let mldonkey_dc_hub_supports = {
 152   nogetinfo = true;    (* Hub doesn't need to receive a $GetINFO from a client to send out $MyINFO *)
 153   nohello = true;      (* Client doesn't need either $Hello or $NickList to be sent *)
 154   userip2 = false;     (* Support for v2 of the $UserIP command *)
 155   usercommand = false; (* Support for $UserCommand, which is a standard way of adding hub-specific shortcuts to the client *)
 156   tthsearch = true;
 157   opplus = false;
 158   feed = false;
 159   mcto = false;
 160   hubtopic = true;
 161 }
 162
 163 let mldonkey_dc_client_supports = {
 164   bzlist = false;        (* Support for a bzip2 compressed file list *)
 165   minislots = true;      (* Support for the concept of a "mini-slot" *) (* off not supported *)
 166   getzblock = false;     (* Instead of $Get and $Send, use $GetZBlock *)
 167   xmlbzlist = true;      (* Support for UTF-8 XML file lists, includes also support for $UGetBlock *)
 168   adcget = true;         (* Support for $ADCGET, a file retrieval command backported from the ADC draft *)
 169   tthl = false;          (* Support for the "tthl" namespace for $ADCGET *)
 170   tthf = true;           (* Support for the retrieving a file by its TTH through $ADCGET *)
 171   zlig = false;          (* Support for compressing the stream of data sent by $ADCGET with the ZLib library *)
 172   clientid = false;      (* Support for the $ClientID command *)
 173   chunk = false;         (* Extension by Valknut that allows retrieval of sections of a file through a modified $Get syntax *)
 174   gettestzblock = false; (* Support for compressed transfers with commands $GetTestZBlock and $Sending *)
 175   getcid = false;
 176 }
 177 (* DC++ 0674 Supports to hubs:  UserCommand NoGetINFO NoHello UserIP2 TTHSearch GetZBlock *)
 178 (* DC++ 0674 Supports to clients: MiniSlots XmlBZList ADCGet TTHL TTHF GetZBlock ZLIG *)
 179 (* Verlihub supports: OpPlus NoGetINFO NoHello UserIP2 *)
 180
 181 let init_myinfo = {
 182   dest = empty_string;
 183   nick = empty_string;
 184   description = empty_string;
 185   client_brand = empty_string;
 186   version = empty_string;
 187   mode = 'P';
 188   hubs = (0 , 0 , 0);
 189   slots = 0;
 190   conn_speed = empty_string;
 191   open_upload_slot = 0;
 192   flag = 1;
 193   sharesize = Int64.zero;
 194   email = empty_string;
 195   bwlimit = 0;
 196 }
 197
 198 (*             FUNCTIONS          *)
 199 let set_server_state s state =
 200   set_server_state (as_server s.server_server) state
 201 (*let set_room_state s state =
 202   set_room_state (as_room s.server_room) state *)
 203 let server_num s = server_num (as_server s.server_server)
 204 let file_num s = file_num (as_file s.file_file)
 205 let server_state s = server_state (as_server s.server_server)
 206 let file_state s = file_state (as_file s.file_file)
 207 let server_must_update s = server_must_update (as_server s.server_server)
 208 let file_must_update s = file_must_update (as_file s.file_file)
 209
 210 let dc_new_shared_dir dirname = {
 211     shared_dirname = dirname;
 212     shared_files = [];
 213     shared_dirs = [];
 214   }
 215
 216 let dc_shared_tree = dc_new_shared_dir ""
 217
 218 (* Copy from CommonUploads... *)
 219 let rec dc_add_shared_file node dcsh dir_list =
 220   match dir_list with
 221     [] -> assert false
 222   | [filename] ->
 223       node.shared_files <- dcsh :: node.shared_files
 224   | dirname :: dir_tail ->
 225       let node =
 226         try
 227           List.assoc dirname node.shared_dirs
 228         with _ ->
 229             let new_node = dc_new_shared_dir dirname in
 230             node.shared_dirs <- (dirname, new_node) :: node.shared_dirs;
 231             new_node
 232       in
 233       dc_add_shared_file node dcsh dir_tail
 234
 235 let open_slots () = !!dc_open_slots
 236 let current_slots () = open_slots () - !used_slots
 237
 238 let dc_remove_uploader () =
 239   if !used_slots < 1 then begin
 240     used_slots := 0;
 241     if !verbose_upload then lprintf_nl "Slot internal counting error: already 0"
 242   end else begin
 243     decr used_slots;
 244     if !verbose_upload then lprintf_nl "Decreased used slots to (%d)" !used_slots
 245   end
 246
 247 let dc_insert_uploader () =
 248   if !used_slots >= open_slots () then begin
 249     used_slots := open_slots ();
 250     if !verbose_upload then lprintf_nl "Slot internal counting error: already at maximum"
 251   end else begin
 252     incr used_slots;
 253     if !verbose_upload then lprintf_nl "Increased used slots to (%d)" !used_slots
 254   end
 255
 256 let dc_can_upload () =
 257   if !used_slots >= open_slots () then false else true
 258
 259 let counts_as_minislot size = size < int64_64kbytes
 260
 261 let is_even_to_hundreds x = (x > 0) && ((x mod 100) = 0)
 262
 263 let is_even_to_tenths x = (x > 0) && ((x mod 10) = 0)
 264
 265 let is_even_to_twos x = (x > 0) && ((x mod 2) = 0)
 266
 267 let is_valid_tiger_hash hash =
 268   if String.length hash = 39 then begin
 269     if (String.contains hash char32) || (String.contains hash char92) ||
 270        (String.contains hash '/') then false
 271     else true
 272   end else false
 273
 274 let find_sockets_client sock =
 275   (try
 276     List.iter (fun c ->
 277       (match c.client_sock with
 278       | Connection csock ->  if csock == sock then raise (Found_client c)
 279       | _ -> () )
 280     ) !clients_list;
 281     None
 282   with
 283   | Found_client c -> Some c
 284   | _ -> None )
 285
 286 (* set our nick for hubs from .ini or global *)
 287 let local_login () =
 288   if !!login = "" then !!CommonOptions.global_login else !!login
 289
 290 (* Shorten string to some maximum length *)
 291 let shorten_string s length =
 292   if length < String.length s then
 293     try
 294       let n = Charset.utf8_nth s length in
 295       String.sub s 0 n
 296     with
 297       _ -> s (* relies on bounds checking! FIXME? *)
 298   else s
 299
 300 (* Replace one string to another string from string *)
 301 let dc_replace_str_to_str s find_str to_str =
 302   if find_str = to_str then failwith "dc_replace_str_to_str find_str = to_str";
 303   let flen = String.length find_str in
 304   let str = ref "" in
 305   let rest = ref "" in
 306   let index = ref 0 in
 307   let rec replace s =
 308     let ok =
 309       (try
 310         index := String2.search_from s 0 find_str
 311       with
 312       | Not_found -> index := -1 );
 313       if (!index = -1) then begin
 314         str := !str ^ s; true
 315       end else begin
 316         str := !str ^ String2.before s !index ^ to_str;
 317         rest := String2.after s (!index+flen);
 318         false
 319       end
 320     in
 321     if not ok then replace !rest
 322     else !str
 323   in
 324   replace s
 325
 326 (* Strip all unnecessary characters from string (CHECK not perfect) *)
 327 let clean_string str =
 328   (* DC++ static const char* badChars = "$|.[]()-_+"; *)
 329   let s = ref "" in
 330   let batch = ref "" in
 331   let last_was_space = ref false in
 332   let add_to_s () =
 333     if (String.length !batch) > 2 then begin
 334       s := !s ^ !batch;
 335       true
 336     end else false
 337   in
 338   String.iter (fun c ->
 339     (match c with (* TODO 1..9 *)
 340     | c when ((c >= 'a') && (c <= 'z')) ||
 341              ((c >= 'A') && (c <= 'Z')) ||
 342              ((c >= char129) && (c <= char154)) ||
 343              ((c >= char160) && (c <= char165)) ||
 344              ((c >= '0') && (c <= '9')) ->
 345                 last_was_space := false;
 346                 batch := !batch ^ String2.of_char c
 347     | ' ' | '.' | '-' | '_' ->
 348         if !last_was_space then ()
 349         else begin
 350           if add_to_s () then s := !s ^ String2.of_char char32;
 351           batch := "";
 352           last_was_space := true;
 353         end
 354     | _ -> () )
 355   ) str;
 356   ignore (add_to_s ());
 357   !s
 358
 359 (* Create temporary nickname for client connection *)
 360 let create_temp_nick () =
 361   let s = "Unknown" ^ (string_of_int !temp_nick_num) in
 362   if !temp_nick_num == max_int then temp_nick_num := 0
 363   else temp_nick_num := succ !temp_nick_num;
 364   s
 365
 366 (* Add user to server and vice versa *)
 367 let add_user_to_server u s =
 368   if not (List.memq s u.user_servers) then u.user_servers <- s :: u.user_servers; (* add server to users list *)
 369   if not (List.memq u s.server_users) then begin
 370     s.server_users <- u :: s.server_users;                                        (* add user to servers list *)
 371     server_new_user (as_server s.server_server) (as_user u.user_user);
 372   end
 373
 374 (* Add new user to hubs userlist *)
 375 (* PROBLEM ?  There can possibly be users from different servers with same names,      *)
 376 (*            and atm. this is not checked in any way. So if on different servers      *)
 377 (*            has users with same name, they are hereafter treated as one              *)
 378 let new_user server name =
 379   let u =
 380     (try
 381       Hashtbl.find users_by_name name
 382     with _ ->
 383         let rec user = {
 384             user_nick = name;
 385         user_ip = Ip.addr_of_ip Ip.null;
 386             user_servers = [];
 387         user_clients = [];
 388             user_user = user_impl;
 389         user_uploaded = Int64.zero;
 390         user_downloaded = Int64.zero;
 391         user_link = empty_string;
 392         user_myinfo = init_myinfo;
 393             user_data = 0.0;
 394         user_type = Normal;
 395         user_state = UserIdle;
 396         user_messages = [];
 397         user_read_messages = 0;
 398           } and user_impl = {
 399             dummy_user_impl with
 400             impl_user_ops = user_ops;
 401             impl_user_val = user;
 402       } in
 403         Hashtbl.add users_by_name name user;
 404         user_add user_impl;
 405       (*lprintf_nl "New user: %s" user.user_nick;*)
 406       user )
 407   in
 408   ignore (match server with
 409          | Some s -> add_user_to_server u s
 410          | None -> () );
 411       u
 412
 413 (* Check if user has some of my nicks = is me *)
 414 let has_my_nick u =
 415   let rec iter slist =
 416     (match slist with
 417     | first :: tail ->
 418         if first.server_last_nick = u.user_nick then true
 419         else iter tail
 420     | [] -> false )
 421   in iter !connected_servers
 422
 423 (* Find user by name *)
 424 let search_user_by_name nick =
 425   try
 426       Hashtbl.find users_by_name nick
 427     with _ -> raise Not_found
 428
 429 (* Remove server from users serverlist *)
 430 let remove_server_from_user s u =
 431   if (List.memq s u.user_servers) then begin
 432     u.user_servers <- List2.removeq s u.user_servers (* remove server from user *)
 433   end
 434
 435 (* Remove user from servers userlist *)
 436 let remove_user_from_server u s =
 437   if (List.memq u s.server_users) then begin
 438     s.server_users <- List2.removeq u s.server_users (* remove user frim server *)
 439   end
 440
 441 (* Remove user from servers userlist and if not any pending downloads, from Hashtbl userlist also *)
 442 let remove_user s u =
 443   remove_user_from_server u s;
 444   remove_server_from_user s u;
 445   if (List.length u.user_servers < 1) then begin
 446     if u.user_clients = [] then begin (* if user has no clients *)
 447       Hashtbl.remove users_by_name u.user_nick;
 448       u.user_messages <- [];
 449       u.user_read_messages <- 0;
 450     end(* else begin
 451       lprintf_nl "User (%s) has clients, not removed" u.user_nick
 452     end*)
 453   end
 454
 455 (* Is user active ? *)
 456 let user_active u =
 457   u.user_myinfo.mode = 'A'
 458
 459 (* Check is filelist downloading from this user already on queue or loaded *)
 460 let filelist_already_downloading u =
 461   (try
 462     List.iter (fun cl ->
 463       (match cl.client_state with
 464       | DcDownloadListWaiting | DcDownloadListConnecting _ | DcDownloadList _ -> raise BreakIter
 465       | _ -> () )
 466     ) u.user_clients;
 467     false
 468   with _ -> true )
 469
 470 (* true if user has new messages *)
 471 let user_has_new_messages user = (List.length user.user_messages) > user.user_read_messages
 472
 473 (* file impl for uploading clients *)
 474 let new_upfile dcsh fd user =
 475   let filename,directory =
 476     (match dcsh with
 477     | Some dcsh ->
 478         Filename.basename dcsh.dc_shared_fullname, Filename.dirname dcsh.dc_shared_fullname
 479     | None ->
 480         let filename = Unix32.filename fd in
 481         Filename.basename filename, Filename.dirname filename )
 482   in
 483   let rec file = {
 484     file_file = impl;
 485     file_unchecked_tiger_root = "";
 486     file_directory = directory;
 487     file_name = filename;
 488     file_clients = [];
 489     file_search = None;
 490     (*file_tiger_array = [||];*)
 491     file_autosearch_count = 0;
 492   } and impl = {
 493     (dummy_file_impl ()) with
 494     impl_file_fd = Some fd;
 495     impl_file_size = Unix32.getsize64 fd;
 496     impl_file_downloaded = Int64.zero;
 497     impl_file_received = Int64.zero;
 498     impl_file_val = file;
 499     impl_file_ops = file_ops;
 500     impl_file_age = last_time ();
 501     impl_file_best_name = filename;
 502     impl_file_owner = user;
 503     impl_file_group = user.user_default_group;
 504   } in
 505   file
 506
 507 (* Return existing file or create new one *)
 508 let new_file tiger_root (directory:string) (filename:string) (file_size:int64) user group =
 509   (try
 510     let f = Hashtbl.find dc_files_by_unchecked_hash tiger_root in
 511     if !verbose_download then
 512       lprintf_nl "File with hash exists: (%s) (%s) (%s)" tiger_root f.file_directory f.file_name;
 513     f
 514   with _ ->
 515     let key = (directory, filename, file_size) in
 516     (try
 517       let f = Hashtbl.find dc_files_by_key key in (* Then try to find by key (dir,name,size) *)
 518       if !verbose_download then lprintf_nl "File exists: (%s) (%s)" f.file_directory f.file_name;
 519       f
 520   with _ ->
 521       let temp_filename =
 522         (match tiger_root with
 523         | "" -> Printf.sprintf "DC_%s_%s" directory filename
 524         | _ -> Printf.sprintf "DC_%s" tiger_root)
 525       in
 526       let fullname = CommonFile.concat_file !!temp_directory temp_filename in
 527       let temp_file = Unix32.create_rw fullname in
 528       let current_size =
 529         (try
 530           Unix32.getsize fullname
 531         with e ->
 532             if !verbose_unexpected_messages then
 533               lprintf_nl "Exception (%s) in current_size of (%s)" (Printexc2.to_string e) fullname;
 534             Int64.zero )
 535       in
 536       let rec file = {
 537         file_file = impl;
 538         file_unchecked_tiger_root = tiger_root;
 539         file_directory = directory;
 540         file_name = filename;
 541         file_clients = [];
 542         file_search = None;
 543         (*file_tiger_array = [||];*)
 544         file_autosearch_count = 0;
 545         } and impl = {
 546           (dummy_file_impl ()) with
 547           impl_file_fd = Some temp_file;
 548           impl_file_size = file_size;
 549           impl_file_downloaded = current_size;
 550           impl_file_received = current_size;
 551           impl_file_val = file;
 552           impl_file_ops = file_ops;
 553           impl_file_age = last_time ();
 554           impl_file_best_name = filename;
 555           impl_file_owner = user;
 556           impl_file_group = group;
 557         } in
 558       file_add impl FileNew;  (* CommonInteractive.file_add *)
 559       current_files := file :: !current_files;
 560       if tiger_root <> empty_string then Hashtbl.add dc_files_by_unchecked_hash tiger_root file;
 561       Hashtbl.add dc_files_by_key key file;
 562       if !verbose_download then
 563         lprintf_nl "New File:(%s) (%s) (%s) (%Ld)" tiger_root file.file_directory file.file_name file_size;
 564       file
 565     )
 566   )
 567
 568 (* Some shortcuts to CommonFile... *)
 569 let file_size file = file.file_file.impl_file_size
 570 let file_downloaded file = file_downloaded (as_file file.file_file)
 571 let file_age file = file.file_file.impl_file_age
 572 let file_fd file = file_fd (as_file file.file_file)
 573
 574 (* Add new client, return client*)
 575 let new_client () =
 576       let rec c = {
 577           client_client = impl;
 578           client_sock = NoConnection;
 579           client_name = None;
 580           client_addr = None;
 581           client_supports = None;
 582           client_lock = "";
 583           client_file = None; (* (file, filename) *)
 584           client_state = DcIdle;
 585           client_error = NoError;
 586           client_error_count = 0;
 587           client_preread_bytes_left = 0;
 588           client_pos = Int64.zero;
 589           client_endpos = Int64.zero; (* atm. upload end position *)
 590           client_receiving = Int64.zero;
 591           client_user = None;
 592           client_connect_time = last_time ();
 593           client_connection_control = new_connection_control ();
 594           client_downloaded = Int64.zero;
 595           client_uploaded = Int64.zero;
 596         } and impl = {
 597           dummy_client_impl with
 598           impl_client_val = c;
 599           impl_client_ops = client_ops;
 600           impl_client_upload = None;
 601         } in
 602       (*lprintf_nl "New client";     *)
 603       CommonClient.new_client impl;
 604       clients_list := c :: !clients_list;
 605       c
 606
 607 (* add client to file & vice versa *)
 608 let add_client_to_file client file = (* TODO  we never empty files clients list so implement some kind of size control *)
 609   if not (List.memq client file.file_clients) then begin       (* if client is not on file's contact list... *)
 610     file.file_clients <- client :: file.file_clients;          (* then add this new client to file contact list *)
 611     client.client_file <- Some file;
 612     (*file_add_source (as_file file.file_file) (as_client client.client_client)*) (* CommonFile.file_add_source *)
 613   end
 614
 615 (* add client to user & vice versa *)
 616 let add_client_to_user client user =
 617   if not (List.memq client user.user_clients) then begin
 618     user.user_clients <- user.user_clients @ [ client ];                  (* add client to userlist *)
 619     client.client_user <- Some user
 620   end
 621
 622 (* New client to user with file *)
 623 let new_client_to_user_with_file u f =
 624   let c = new_client () in
 625   c.client_name <- Some u.user_nick;
 626   add_client_to_user c u;
 627   add_client_to_file c f;
 628   c
 629
 630 let client_type c =
 631   client_type (as_client c.client_client)
 632
 633 (* Find clients by name, return list of all matching clients *)
 634 (*let find_clients_by_name name =
 635   let result = ref [] in
 636     List.iter (fun c ->
 637       (match c.client_user with
 638       | Some u -> if u.user_nick = name then result := c :: !result; ()
 639       | _ -> () )
 640     ) !clients_list;
 641   !result *)
 642
 643 (* Print client state to string *)
 644 let client_state_to_string c =
 645   let get_direction dir =
 646     (match dir with
 647     | Upload i -> Printf.sprintf "Upload %d" i
 648     | Download i -> Printf.sprintf "Download %d" i )
 649   in
 650   (match c.client_state with
 651   | DcIdle -> "DcIdle"
 652   | DcDownloadWaiting _ -> "DcDownloadWaiting"
 653   | DcDownloadConnecting _ -> "DcDownloadConnecting"
 654   | DcDownloadListWaiting -> "DcDownloadListWaiting"
 655   | DcDownloadListConnecting _ -> "DcDownloadListConnecting"
 656   | DcConnectionStyle style ->
 657       (match style with
 658       | ClientActive dir -> Printf.sprintf "DcConnectionStyle ClientActive %s" (get_direction dir)
 659       | MeActive dir -> Printf.sprintf "DcConnectionStyle MeActive %s" (get_direction dir) )
 660   | DcDownload _ -> "DcDownload"
 661   | DcDownloadList _ -> "DcDownloadList"
 662   | DcUpload _ -> "DcUpload"
 663   | DcUploadStarting _ -> "DcUploadStarting"
 664   | DcUploadList _ -> "DcUploadList"
 665   | DcUploadListStarting _ -> "DcUploadListStarting"
 666   | DcUploadDoneWaitingForMore -> "DcUploadDoneWaitingForMore" )
 667
 668 (* Copy client data to another *)
 669 let new_copy_client c =
 670   {
 671     (new_client ()) with
 672     (*client_sock = c.client_sock;*)
 673     client_name = c.client_name;
 674     client_addr = c.client_addr;
 675     client_supports = c.client_supports;
 676     client_lock = c.client_lock;
 677     client_file = c.client_file;
 678     (*client_state = c.client_state;*)
 679     client_pos = c.client_pos;
 680     client_receiving = c.client_receiving;
 681     client_user = c.client_user;
 682     client_error = c.client_error;
 683     client_error_count = c.client_error_count;
 684     client_endpos = c.client_endpos;
 685     client_connect_time = c.client_connect_time;
 686     client_downloaded = c.client_downloaded;
 687     client_uploaded = c.client_uploaded;
 688   }
 689
 690 (* Get clients username *)
 691 let clients_username client =
 692   let name =
 693     (match client.client_user with
 694     | Some user -> user.user_nick
 695     | _ -> "NO USER" )
 696   in name
 697
 698 (* Remove clients files and all references from files to this client *)
 699 let remove_client_from_clients_file c =
 700   (match c.client_file with
 701   | Some f ->
 702       f.file_clients <- List2.removeq c f.file_clients;
 703       c.client_file <- None
 704   | None -> () )
 705
 706 (* Remove clients references from users *)
 707 let remove_client c =
 708   (match c.client_user with
 709   | Some u ->
 710       u.user_clients <- List2.removeq c u.user_clients
 711       (*lprintf_nl "Removed one client from user %s clientlist" u.user_nick;*)
 712   | None -> () );
 713   c.client_user <- None;
 714   remove_client_from_clients_file c;
 715   clients_list := List2.removeq c !clients_list;
 716   client_remove (as_client c.client_client);
 717   ()
 718
 719 (* Remove file from current filelist *)
 720 let remove_file_from_filelist file =
 721   (try
 722     current_files := List2.removeq file !current_files;
 723     with _ ->
 724      if !verbose_unexpected_messages then
 725        lprintf_nl "Could not remove file from !current_files - %s" file.file_name )
 726
 727 (* Remove file from hashtbl dc_files_by_unchecked_hash *)
 728 let remove_file_from_hashes file =
 729     if file.file_unchecked_tiger_root <> empty_string then begin
 730       (try
 731         Hashtbl.remove dc_files_by_unchecked_hash file.file_unchecked_tiger_root;
 732       with _ ->
 733           if !verbose_unexpected_messages then
 734             lprintf_nl "Could not remove file from hashtable dc_files_unchecked_hash - %s" file.file_name )
 735     end
 736
 737 (* Remove file from hashtab dc_files_by_key *)
 738 let remove_file_from_files file =
 739   (try
 740     Hashtbl.remove dc_files_by_key (file.file_directory, file.file_name, file.file_file.impl_file_size);
 741   with _ ->
 742       if !verbose_unexpected_messages then
 743         lprintf_nl "Could not remove file from hashtable dc_files_by_key - %s" file.file_name )
 744
 745 (* remove all clients of file *)
 746 let remove_files_clients file =
 747   List.iter (fun c ->
 748     remove_client c;
 749   ) file.file_clients;
 750   file.file_clients <- []
 751
 752 (* remove file from file list *)
 753 let remove_file_with_clients file =
 754   remove_files_clients file;
 755   remove_file_from_hashes file;
 756   remove_file_from_files file;
 757   remove_file_from_filelist file
 758
 759 (* remove file from file list *)
 760 let remove_file_not_clients file =
 761   List.iter (fun c ->
 762     c.client_file <- None;
 763   ) file.file_clients;
 764   file.file_clients <- [];
 765   remove_file_from_hashes file;
 766   remove_file_from_files file;
 767   remove_file_from_filelist file
 768
 769 let set_client_state c state =
 770   set_client_state (as_client c.client_client) state
 771
 772 let dc_set_client_disconnected c =
 773   set_client_disconnected (as_client c.client_client)
 774
 775 let set_clients_upload c sh =
 776   set_client_upload (as_client c.client_client) sh; (*(as_file c.client_file);*)
 777   set_client_has_a_slot (as_client c.client_client) NormalSlot;
 778   client_enter_upload_queue (as_client c.client_client)
 779
 780 (* Print closing reason to string *)
 781 let closing_reason_to_text reason =
 782   (match reason with
 783   | Closed_for_error text -> Printf.sprintf "Error: Reason (%s)" text
 784   | Closed_for_timeout -> "Timeout"
 785   | Closed_for_lifetime -> "Lifetime"
 786   | Closed_by_peer -> "By peer"
 787   | Closed_by_user -> "By user (us - operation complete)"
 788   | Closed_for_overflow -> "Overflow"
 789   | Closed_connect_failed -> "Connect failed"
 790   | Closed_for_exception _ -> "Exception"  )
 791
 792 (* Can client start downloading *)
 793 let is_client_waiting c =
 794   (match c.client_state with                              (* check user clients states *)
 795   | DcIdle | DcDownloadWaiting _ | DcDownloadListWaiting -> true
 796   | DcUpload _ | DcUploadStarting _ | DcUploadListStarting _ | DcUploadList _
 797   | DcDownloadListConnecting _ | DcDownloadConnecting _ | DcDownload _
 798   | DcDownloadList _ | DcConnectionStyle _ | DcUploadDoneWaitingForMore -> false )
 799
 800 (* Can client start downloading clients file *)
 801 let is_client_blocking_downloading c =
 802   (match c.client_state with
 803   | DcIdle | DcUpload _ | DcUploadStarting _ | DcUploadListStarting _
 804   | DcUploadList _ | DcDownloadWaiting _ | DcDownloadListWaiting
 805   | DcUploadDoneWaitingForMore -> false
 806   | DcDownloadListConnecting _ | DcDownloadConnecting _ | DcDownload _
 807   | DcDownloadList _ | DcConnectionStyle _ -> true )
 808
 809 (* Check user, that has sent RevConnectToMe and we have sent ConnectToMe and we are waiting *)
 810 let check_passive_user u =
 811   (match u.user_state with
 812   | UserPassiveUserInitiating time ->
 813       if (current_time () -. time) > float_of_int !!client_timeout then begin
 814         if !verbose_msg_clients then
 815           lprintf_nl "Resetted passive user (%s) waiting state " u.user_nick;
 816         u.user_state <- UserIdle;
 817       end
 818   | _ -> () )
 819
 820 (* Check all clients, that have sent RevConnectToMe and we have sent ConnectToMe and we are waiting *)
 821 let check_all_passive_users () =
 822   Hashtbl.iter (fun _ u ->
 823      check_passive_user u
 824   ) users_by_name
 825
 826 (* Check that user has no downloads and is not in conversation state *)
 827 let can_user_start_downloading u =
 828   (try
 829     List.iter (fun c ->
 830       if (is_client_blocking_downloading c) then raise BreakIter
 831     ) u.user_clients;
 832     (match u.user_state with            (* check user state/timeouts *)
 833     | UserIdle -> ()
 834     | UserPassiveUserInitiating time -> (* passive users wait check *)
 835         if (current_time () -. time) > float_of_int !!client_timeout then begin
 836           if !verbose_msg_clients then lprintf_nl "Resetted RevConnect Passive user waiting (%s)" u.user_nick;
 837           u.user_state <- UserIdle;
 838         end else raise BreakIter
 839     | _ -> raise BreakIter );
 840     true
 841   with _ -> false )
 842
 843 (* Find a connected client by ip *)
 844 (*let find_connected_client_by_ip ip port =
 845   (try
 846     List.iter (fun c ->
 847           (match c.client_sock with
 848           | Connection sock ->
 849               (match c.client_addr with
 850               | None -> failwith "Client connected but no ip address"
 851               | Some (cip , cport) -> begin
 852                   lprintf_nl "Client match found: checking real ips";
 853                   let rip = Ip.to_string (TcpBufferedSocket.peer_ip sock) in
 854                   let rport = TcpBufferedSocket.peer_port sock in
 855                   lprintf_nl "  From socket:        rip= %s  rport= %d" rip rport;
 856                   lprintf_nl "  From c.client_addr: cip= %s  cport= %d" (Ip.to_string cip) cport;
 857                   lprintf_nl "  From ConnectToMe  : ip = %s  port = %d" (Ip.to_string ip) port;
 858                   if (Ip.equal cip ip) then raise (Found_client c)
 859                 end )
 860           | _ -> () )
 861     ) !clients_list;
 862     raise Not_found
 863   with
 864   | Found_client c -> Some c
 865   | Failure e -> lprintf_nl "In ( find_connected_client_by_ip): %s" e; None
 866   | Not_found -> None ) *)
 867
 868 (* Find any client with known ip *)
 869 (*let find_client_by_ip ip =
 870   (try
 871     List.iter (fun c ->
 872       (match c.client_addr with
 873       | None -> failwith "No ip on client!"
 874       | Some (cip , _ ) ->
 875           if (Ip.equal cip ip) then begin
 876             (match c.client_user with
 877             | Some u -> lprintf_nl "  Found matching client from user %s with ip: %s" u.user_nick
 878                (Ip.to_string cip); ()
 879             | _ -> failwith "find_client_by_ip: No user in client !" );
 880             raise (Found_client c)
 881           end )
 882     ) !clients_list;
 883     raise Not_found
 884   with
 885   | Found_client c -> Some c
 886   | Failure e -> lprintf_nl "In (find_client_by_ip): %s" e; None
 887   | Not_found -> None ) *)
 888
 889 (* Add needed dc-info fields to result by number *)
 890 let add_info_to_result r user tiger_root directory =
 891     let result_info = {
 892       user = user;
 893       tth = tiger_root;
 894       directory = directory;
 895     } in
 896     try
 897       Hashtbl.find dc_result_info r.stored_result_num (* if result number exists in hashtable result_sources *)
 898                                                       (* return existing result's info (user & directory)  *)
 899     with _ ->
 900         Hashtbl.add dc_result_info r.stored_result_num result_info;  (* ...add the new result's info to hashtable *)
 901         result_info
 902
 903 (* add new server/hub by address and port if not exist - return server/hub*)
 904 let new_server addr ip port =
 905   let ips = Ip.to_string ip in
 906   try
 907     Hashtbl.find servers_by_ip ips
 908   with _ ->
 909       let rec h = {
 910           server_server = server_impl;
 911           server_name = "<unknown>";
 912           server_addr = addr;
 913           server_ip = ip;
 914           server_info = "";
 915           server_supports = None;
 916           server_connection_time = nan; (* Stands for ``not a number' *)
 917           server_hub_state = Waiting;
 918           server_connection_control = new_connection_control ();
 919           server_sock = NoConnection;
 920           server_autoconnect = false;
 921           server_port = port;
 922           server_last_nick = "";
 923           server_search = None;
 924           server_search_timeout = 0;
 925           server_users = [];
 926           server_topic = "";
 927           server_messages = [];
 928           server_read_messages = 0;
 929         } and
 930         server_impl = {
 931           dummy_server_impl with
 932           impl_server_val = h;
 933           impl_server_ops = server_ops;
 934         }
 935       in
 936       server_add server_impl;
 937       Hashtbl.add servers_by_ip ips h;
 938       h
 939
 940 (* Add server to connected servers *)
 941 let add_connected_server s =
 942   (*incr nservers;*)
 943   if not (List.memq s !connected_servers) then
 944     connected_servers := s :: !connected_servers
 945
 946 (* Remove servers contacts to users and from connected servers *)
 947 let remove_connected_server s =
 948   (*decr nservers;*)
 949   connected_servers := List2.removeq s !connected_servers;
 950   List.iter (fun u ->
 951     remove_user s u
 952   ) s.server_users;
 953   s.server_hub_state <- Waiting;
 954   s.server_search <- None;
 955   s.server_users <- []
 956
 957 (* Remove server from known servers list *)
 958 let server_remove s =
 959   server_remove (as_server s.server_server);
 960   Hashtbl.remove servers_by_ip (Ip.to_string s.server_ip)
 961   (*decr nknown_servers;*)
 962   (*servers_list := List2.removeq s !servers_list*)
 963
 964 (* Iter all servers in connected list *)
 965 let dc_with_connected_servers f =
 966   List.iter (fun s ->
 967     f s
 968   ) !connected_servers
 969
 970 (* Return hub state text *)
 971 let dc_hubstate_to_text s =
 972   (match s.server_hub_state with
 973   | Waiting -> "Not connected"
 974   | User -> "User"
 975   | Vipped -> "Vip"
 976   | Opped -> "Op" )
 977
 978 (* Search server by ip and port *)
 979 (*let search_server_by_addr addr port =
 980   try
 981     Hashtbl.find servers_by_addr (addr, port)
 982   with _ ->
 983     raise Not_found *)
 984
 985 (* add new result to results-hashtable - return the found or new result *)
 986 let new_result user tiger_root (directory:string) (filename:string) (filesize:int64) =
 987   let basename = Filename2.basename filename in
 988   let key = (directory, basename, filesize) in
 989   (*let r_username = "......" ^ user.user_nick in*)
 990   (try
 991     Hashtbl.find dc_results_by_file key (* if result with dir&name&size exists, return the found result *)
 992   with _ ->                             (* otherwise... *)
 993       let result_names =
 994         if tiger_root <> "" then begin
 995           let found =
 996             (try
 997               ignore (Hashtbl.find dc_shared_files_by_hash tiger_root);
 998               true
 999             with _ -> false )
1000           in
1001           if found then [filename;"ALREADY DOWNLOADED"]
1002           else begin
1003             let found =
1004               (try
1005                 ignore (Hashtbl.find dc_files_by_unchecked_hash tiger_root);
1006                 true
1007               with _ -> false )
1008             in
1009             if found then [filename;"FILE DOWNLOADING..."]
1010             else [filename]
1011           end
1012         end else [filename]
1013       in
1014       let rec r = {                  (* add new result *)
1015           dummy_result with
1016         result_names = result_names;
1017         result_tags = [ {tag_name = Field_UNKNOWN user.user_nick; tag_value = String ""} ];
1018           result_size = filesize;
1019         result_source_network = network.network_num;
1020         } in
1021       let rs = update_result_num r in  (* CommonResult.update_result_num, returns Commontypes.result *)
1022       Hashtbl.add dc_results_by_file key rs;
1023       rs )
1024
1025 (*let hash_file () =
1026   let dcsh = List.hd !dc_shared_files in
1027   let info = CommonUploads.IndexedSharedFiles.get_result dcsh.dc_shared_shared.shared_info in
1028   if dcsh.dc_shared_chunk <> dc_get_nchunks info.shared_size then compute_tigertree_chunk dcsh*)
1029
1030
1031 (*  Hashtbl.iter (fun n sh ->
1032     lprintf_nl "(%s)" sh.shared_codedname;
1033     let info = CommonUploads.IndexedSharedFiles.get_result sh.shared_info in
1034     lprintf_nl "(%s)" info.shared_fullname
1035
1036   ) CommonUploads.shared_files*)
1037
1038 (*
1039 /** We don't keep leaves for blocks smaller than this... */
1040         static const int64_t MIN_BLOCK_SIZE = 64*1024;
1041 *)
1042 (*CommonHasher.compute_tiger :
1043   string -> int64 -> int64 -> (Md4.TigerTree.t job -> unit) -> unit
1044 *)
1045
1046 (* DC++ blocksize
1047                 int64_t bl = 1024;
1048                 while(bl * (int64_t)d->getTigerTree().getLeaves().size() < d->getTigerTree().getFileSize())
1049                         bl *= 2;
1050                 d->getTigerTree().setBlockSize(bl);
1051                 d->getTigerTree().calcRoot();
1052 *)
1053 (*
1054 AdcCommand Download::getCommand(bool zlib, bool tthf) {
1055         AdcCommand cmd(AdcCommand::CMD_GET);
1056         if(isSet(FLAG_TREE_DOWNLOAD)) {
1057                 cmd.addParam("tthl");
1058         } else if(isSet(FLAG_PARTIAL_LIST)) {
1059                 cmd.addParam("list");
1060         } else {
1061                 cmd.addParam("file");
1062         }
1063         if(tthf && getTTH() != NULL) {
1064                 cmd.addParam("TTH/" + getTTH()->toBase32());
1065         } else {
1066                 cmd.addParam(Util::toAdcFile(getSource()));
1067         }
1068         cmd.addParam(Util::toString(getPos()));
1069         cmd.addParam(Util::toString(getSize() - getPos()));
1070
1071         if(zlib && getSize() != -1 && BOOLSETTING(COMPRESS_TRANSFERS)) {
1072                 cmd.addParam("ZL1");
1073         }
1074 *)