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 =
 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   } in
 503   file
 504
 505 (* FIXME review *)
 506 let safe_filename s =
 507   let s = String.copy s in
 508   for i = 0 to String.length s - 1 do
 509     match s.[i] with
 510     | c when Char.code c < 32 -> s.[i] <- '_'
 511     | '.' | '/' | '\\' | ':' -> s.[i] <- '_'
 512     | _ -> ()
 513   done;
 514   s
 515
 516 (* Return existing file or create new one *)
 517 let new_file tiger_root (directory:string) (filename:string) (file_size:int64) =
 518   (try
 519     let f = Hashtbl.find dc_files_by_unchecked_hash tiger_root in
 520     if !verbose_download then
 521       lprintf_nl "File with hash exists: (%s) (%s) (%s)" tiger_root f.file_directory f.file_name;
 522     f
 523   with _ ->
 524     let key = (directory, filename, file_size) in
 525     (try
 526       let f = Hashtbl.find dc_files_by_key key in (* Then try to find by key (dir,name,size) *)
 527       if !verbose_download then lprintf_nl "File exists: (%s) (%s)" f.file_directory f.file_name;
 528       f
 529   with _ ->
 530       let temp_filename = safe_filename
 531         (match tiger_root with
 532         | "" -> Printf.sprintf "DC_%s_%s" directory filename
 533         | _ -> Printf.sprintf "DC_%s" tiger_root)
 534       in
 535       let fullname = Filename.concat !!temp_directory temp_filename in
 536       let temp_file = Unix32.create_rw fullname in
 537       let current_size =
 538         (try
 539           Unix32.getsize fullname
 540         with e ->
 541             if !verbose_unexpected_messages then
 542               lprintf_nl "Exception (%s) in current_size of (%s)" (Printexc2.to_string e) fullname;
 543             Int64.zero )
 544       in
 545       let rec file = {
 546           file_file = impl;
 547         file_unchecked_tiger_root = tiger_root;
 548         file_directory = directory;
 549         file_name = filename;
 550           file_clients = [];
 551         file_search = None;
 552         (*file_tiger_array = [||];*)
 553         file_autosearch_count = 0;
 554         } and impl = {
 555           dummy_file_impl with
 556         impl_file_fd = Some temp_file;
 557           impl_file_size = file_size;
 558           impl_file_downloaded = current_size;
 559         impl_file_received = current_size;
 560           impl_file_val = file;
 561           impl_file_ops = file_ops;
 562           impl_file_age = last_time ();
 563         impl_file_best_name = filename;
 564         } in
 565       file_add impl FileNew;  (* CommonInteractive.file_add *)
 566             current_files := file :: !current_files;
 567       if tiger_root <> empty_string then Hashtbl.add dc_files_by_unchecked_hash tiger_root file;
 568       Hashtbl.add dc_files_by_key key file;
 569       if !verbose_download then
 570         lprintf_nl "New File:(%s) (%s) (%s) (%Ld)" tiger_root file.file_directory file.file_name file_size;
 571       file
 572     )
 573   )
 574
 575 (* Some shortcuts to CommonFile... *)
 576 let file_size file = file.file_file.impl_file_size
 577 let file_downloaded file = file_downloaded (as_file file.file_file)
 578 let file_age file = file.file_file.impl_file_age
 579 let file_fd file = file_fd (as_file file.file_file)
 580
 581 (* Add new client, return client*)
 582 let new_client () =
 583       let rec c = {
 584           client_client = impl;
 585           client_sock = NoConnection;
 586           client_name = None;
 587           client_addr = None;
 588           client_supports = None;
 589           client_lock = "";
 590           client_file = None; (* (file, filename) *)
 591           client_state = DcIdle;
 592           client_error = NoError;
 593           client_error_count = 0;
 594           client_preread_bytes_left = 0;
 595           client_pos = Int64.zero;
 596           client_endpos = Int64.zero; (* atm. upload end position *)
 597           client_receiving = Int64.zero;
 598           client_user = None;
 599           client_connect_time = last_time ();
 600           client_connection_control = new_connection_control ();
 601           client_downloaded = Int64.zero;
 602           client_uploaded = Int64.zero;
 603         } and impl = {
 604           dummy_client_impl with
 605           impl_client_val = c;
 606           impl_client_ops = client_ops;
 607           impl_client_upload = None;
 608         } in
 609       (*lprintf_nl "New client";     *)
 610       CommonClient.new_client impl;
 611       clients_list := c :: !clients_list;
 612       c
 613
 614 (* add client to file & vice versa *)
 615 let add_client_to_file client file = (* TODO  we never empty files clients list so implement some kind of size control *)
 616   if not (List.memq client file.file_clients) then begin       (* if client is not on file's contact list... *)
 617     file.file_clients <- client :: file.file_clients;          (* then add this new client to file contact list *)
 618     client.client_file <- Some file;
 619     (*file_add_source (as_file file.file_file) (as_client client.client_client)*) (* CommonFile.file_add_source *)
 620   end
 621
 622 (* add client to user & vice versa *)
 623 let add_client_to_user client user =
 624   if not (List.memq client user.user_clients) then begin
 625     user.user_clients <- user.user_clients @ [ client ];                  (* add client to userlist *)
 626     client.client_user <- Some user
 627   end
 628
 629 (* New client to user with file *)
 630 let new_client_to_user_with_file u f =
 631   let c = new_client () in
 632   c.client_name <- Some u.user_nick;
 633   add_client_to_user c u;
 634   add_client_to_file c f;
 635   c
 636
 637 let client_type c =
 638   client_type (as_client c.client_client)
 639
 640 (* Find clients by name, return list of all matching clients *)
 641 (*let find_clients_by_name name =
 642   let result = ref [] in
 643     List.iter (fun c ->
 644       (match c.client_user with
 645       | Some u -> if u.user_nick = name then result := c :: !result; ()
 646       | _ -> () )
 647     ) !clients_list;
 648   !result *)
 649
 650 (* Print client state to string *)
 651 let client_state_to_string c =
 652   let get_direction dir =
 653     (match dir with
 654     | Upload i -> Printf.sprintf "Upload %d" i
 655     | Download i -> Printf.sprintf "Download %d" i )
 656   in
 657   (match c.client_state with
 658   | DcIdle -> "DcIdle"
 659   | DcDownloadWaiting _ -> "DcDownloadWaiting"
 660   | DcDownloadConnecting _ -> "DcDownloadConnecting"
 661   | DcDownloadListWaiting -> "DcDownloadListWaiting"
 662   | DcDownloadListConnecting _ -> "DcDownloadListConnecting"
 663   | DcConnectionStyle style ->
 664       (match style with
 665       | ClientActive dir -> Printf.sprintf "DcConnectionStyle ClientActive %s" (get_direction dir)
 666       | MeActive dir -> Printf.sprintf "DcConnectionStyle MeActive %s" (get_direction dir) )
 667   | DcDownload _ -> "DcDownload"
 668   | DcDownloadList _ -> "DcDownloadList"
 669   | DcUpload _ -> "DcUpload"
 670   | DcUploadStarting _ -> "DcUploadStarting"
 671   | DcUploadList _ -> "DcUploadList"
 672   | DcUploadListStarting _ -> "DcUploadListStarting"
 673   | DcUploadDoneWaitingForMore -> "DcUploadDoneWaitingForMore" )
 674
 675 (* Copy client data to another *)
 676 let new_copy_client c =
 677   {
 678     (new_client ()) with
 679     (*client_sock = c.client_sock;*)
 680     client_name = c.client_name;
 681     client_addr = c.client_addr;
 682     client_supports = c.client_supports;
 683     client_lock = c.client_lock;
 684     client_file = c.client_file;
 685     (*client_state = c.client_state;*)
 686     client_pos = c.client_pos;
 687     client_receiving = c.client_receiving;
 688     client_user = c.client_user;
 689     client_error = c.client_error;
 690     client_error_count = c.client_error_count;
 691     client_endpos = c.client_endpos;
 692     client_connect_time = c.client_connect_time;
 693     client_downloaded = c.client_downloaded;
 694     client_uploaded = c.client_uploaded;
 695   }
 696
 697 (* Get clients username *)
 698 let clients_username client =
 699   let name =
 700     (match client.client_user with
 701     | Some user -> user.user_nick
 702     | _ -> "NO USER" )
 703   in name
 704
 705 (* Remove clients files and all references from files to this client *)
 706 let remove_client_from_clients_file c =
 707   (match c.client_file with
 708   | Some f ->
 709       f.file_clients <- List2.removeq c f.file_clients;
 710       c.client_file <- None
 711   | None -> () )
 712
 713 (* Remove clients references from users *)
 714 let remove_client c =
 715   (match c.client_user with
 716   | Some u ->
 717       u.user_clients <- List2.removeq c u.user_clients
 718       (*lprintf_nl "Removed one client from user %s clientlist" u.user_nick;*)
 719   | None -> () );
 720   c.client_user <- None;
 721   remove_client_from_clients_file c;
 722   clients_list := List2.removeq c !clients_list;
 723   client_remove (as_client c.client_client);
 724   ()
 725
 726 (* Remove file from current filelist *)
 727 let remove_file_from_filelist file =
 728   (try
 729     current_files := List2.removeq file !current_files;
 730     with _ ->
 731      if !verbose_unexpected_messages then
 732        lprintf_nl "Could not remove file from !current_files - %s" file.file_name )
 733
 734 (* Remove file from hashtbl dc_files_by_unchecked_hash *)
 735 let remove_file_from_hashes file =
 736     if file.file_unchecked_tiger_root <> empty_string then begin
 737       (try
 738         Hashtbl.remove dc_files_by_unchecked_hash file.file_unchecked_tiger_root;
 739       with _ ->
 740           if !verbose_unexpected_messages then
 741             lprintf_nl "Could not remove file from hashtable dc_files_unchecked_hash - %s" file.file_name )
 742     end
 743
 744 (* Remove file from hashtab dc_files_by_key *)
 745 let remove_file_from_files file =
 746   (try
 747     Hashtbl.remove dc_files_by_key (file.file_directory, file.file_name, file.file_file.impl_file_size);
 748   with _ ->
 749       if !verbose_unexpected_messages then
 750         lprintf_nl "Could not remove file from hashtable dc_files_by_key - %s" file.file_name )
 751
 752 (* remove all clients of file *)
 753 let remove_files_clients file =
 754   List.iter (fun c ->
 755     remove_client c;
 756   ) file.file_clients;
 757   file.file_clients <- []
 758
 759 (* remove file from file list *)
 760 let remove_file_with_clients file =
 761   remove_files_clients file;
 762   remove_file_from_hashes file;
 763   remove_file_from_files file;
 764   remove_file_from_filelist file
 765
 766 (* remove file from file list *)
 767 let remove_file_not_clients file =
 768   List.iter (fun c ->
 769     c.client_file <- None;
 770   ) file.file_clients;
 771   file.file_clients <- [];
 772   remove_file_from_hashes file;
 773   remove_file_from_files file;
 774   remove_file_from_filelist file
 775
 776 let set_client_state c state =
 777   set_client_state (as_client c.client_client) state
 778
 779 let dc_set_client_disconnected c =
 780   set_client_disconnected (as_client c.client_client)
 781
 782 let set_clients_upload c sh =
 783   set_client_upload (as_client c.client_client) sh; (*(as_file c.client_file);*)
 784   set_client_has_a_slot (as_client c.client_client) NormalSlot;
 785   client_enter_upload_queue (as_client c.client_client)
 786
 787 (* Print closing reason to string *)
 788 let closing_reason_to_text reason =
 789   (match reason with
 790   | Closed_for_error text -> Printf.sprintf "Error: Reason (%s)" text
 791   | Closed_for_timeout -> "Timeout"
 792   | Closed_for_lifetime -> "Lifetime"
 793   | Closed_by_peer -> "By peer"
 794   | Closed_by_user -> "By user (us - operation complete)"
 795   | Closed_for_overflow -> "Overflow"
 796   | Closed_connect_failed -> "Connect failed"
 797   | Closed_for_exception _ -> "Exception"  )
 798
 799 (* Can client start downloading *)
 800 let is_client_waiting c =
 801   (match c.client_state with                              (* check user clients states *)
 802   | DcIdle | DcDownloadWaiting _ | DcDownloadListWaiting -> true
 803   | DcUpload _ | DcUploadStarting _ | DcUploadListStarting _ | DcUploadList _
 804   | DcDownloadListConnecting _ | DcDownloadConnecting _ | DcDownload _
 805   | DcDownloadList _ | DcConnectionStyle _ | DcUploadDoneWaitingForMore -> false )
 806
 807 (* Can client start downloading clients file *)
 808 let is_client_blocking_downloading c =
 809   (match c.client_state with
 810   | DcIdle | DcUpload _ | DcUploadStarting _ | DcUploadListStarting _
 811   | DcUploadList _ | DcDownloadWaiting _ | DcDownloadListWaiting
 812   | DcUploadDoneWaitingForMore -> false
 813   | DcDownloadListConnecting _ | DcDownloadConnecting _ | DcDownload _
 814   | DcDownloadList _ | DcConnectionStyle _ -> true )
 815
 816 (* Check user, that has sent RevConnectToMe and we have sent ConnectToMe and we are waiting *)
 817 let check_passive_user u =
 818   (match u.user_state with
 819   | UserPassiveUserInitiating time ->
 820       if (current_time () -. time) > float_of_int !!client_timeout then begin
 821         if !verbose_msg_clients then
 822           lprintf_nl "Resetted passive user (%s) waiting state " u.user_nick;
 823         u.user_state <- UserIdle;
 824       end
 825   | _ -> () )
 826
 827 (* Check all clients, that have sent RevConnectToMe and we have sent ConnectToMe and we are waiting *)
 828 let check_all_passive_users () =
 829   Hashtbl.iter (fun _ u ->
 830      check_passive_user u
 831   ) users_by_name
 832
 833 (* Check that user has no downloads and is not in conversation state *)
 834 let can_user_start_downloading u =
 835   (try
 836     List.iter (fun c ->
 837       if (is_client_blocking_downloading c) then raise BreakIter
 838     ) u.user_clients;
 839     (match u.user_state with            (* check user state/timeouts *)
 840     | UserIdle -> ()
 841     | UserPassiveUserInitiating time -> (* passive users wait check *)
 842         if (current_time () -. time) > float_of_int !!client_timeout then begin
 843           if !verbose_msg_clients then lprintf_nl "Resetted RevConnect Passive user waiting (%s)" u.user_nick;
 844           u.user_state <- UserIdle;
 845         end else raise BreakIter
 846     | _ -> raise BreakIter );
 847     true
 848   with _ -> false )
 849
 850 (* Find a connected client by ip *)
 851 (*let find_connected_client_by_ip ip port =
 852   (try
 853     List.iter (fun c ->
 854           (match c.client_sock with
 855           | Connection sock ->
 856               (match c.client_addr with
 857               | None -> failwith "Client connected but no ip address"
 858               | Some (cip , cport) -> begin
 859                   lprintf_nl "Client match found: checking real ips";
 860                   let rip = Ip.to_string (TcpBufferedSocket.peer_ip sock) in
 861                   let rport = TcpBufferedSocket.peer_port sock in
 862                   lprintf_nl "  From socket:        rip= %s  rport= %d" rip rport;
 863                   lprintf_nl "  From c.client_addr: cip= %s  cport= %d" (Ip.to_string cip) cport;
 864                   lprintf_nl "  From ConnectToMe  : ip = %s  port = %d" (Ip.to_string ip) port;
 865                   if (Ip.equal cip ip) then raise (Found_client c)
 866                 end )
 867           | _ -> () )
 868     ) !clients_list;
 869     raise Not_found
 870   with
 871   | Found_client c -> Some c
 872   | Failure e -> lprintf_nl "In ( find_connected_client_by_ip): %s" e; None
 873   | Not_found -> None ) *)
 874
 875 (* Find any client with known ip *)
 876 (*let find_client_by_ip ip =
 877   (try
 878     List.iter (fun c ->
 879       (match c.client_addr with
 880       | None -> failwith "No ip on client!"
 881       | Some (cip , _ ) ->
 882           if (Ip.equal cip ip) then begin
 883             (match c.client_user with
 884             | Some u -> lprintf_nl "  Found matching client from user %s with ip: %s" u.user_nick
 885                (Ip.to_string cip); ()
 886             | _ -> failwith "find_client_by_ip: No user in client !" );
 887             raise (Found_client c)
 888           end )
 889     ) !clients_list;
 890     raise Not_found
 891   with
 892   | Found_client c -> Some c
 893   | Failure e -> lprintf_nl "In (find_client_by_ip): %s" e; None
 894   | Not_found -> None ) *)
 895
 896 (* Add needed dc-info fields to result by number *)
 897 let add_info_to_result r user tiger_root directory =
 898     let result_info = {
 899       user = user;
 900       tth = tiger_root;
 901       directory = directory;
 902     } in
 903     try
 904       Hashtbl.find dc_result_info r.stored_result_num (* if result number exists in hashtable result_sources *)
 905                                                       (* return existing result's info (user & directory)  *)
 906     with _ ->
 907         Hashtbl.add dc_result_info r.stored_result_num result_info;  (* ...add the new result's info to hashtable *)
 908         result_info
 909
 910 (* add new server/hub by address and port if not exist - return server/hub*)
 911 let new_server addr ip port =
 912   let ips = Ip.to_string ip in
 913   try
 914     Hashtbl.find servers_by_ip ips
 915   with _ ->
 916       let rec h = {
 917           server_server = server_impl;
 918           server_name = "<unknown>";
 919           server_addr = addr;
 920           server_ip = ip;
 921           server_info = "";
 922           server_supports = None;
 923           server_connection_time = nan; (* Stands for ``not a number' *)
 924           server_hub_state = Waiting;
 925           server_connection_control = new_connection_control ();
 926           server_sock = NoConnection;
 927           server_autoconnect = false;
 928           server_port = port;
 929           server_last_nick = "";
 930           server_search = None;
 931           server_search_timeout = 0;
 932           server_users = [];
 933           server_topic = "";
 934           server_messages = [];
 935           server_read_messages = 0;
 936         } and
 937         server_impl = {
 938           dummy_server_impl with
 939           impl_server_val = h;
 940           impl_server_ops = server_ops;
 941         }
 942       in
 943       server_add server_impl;
 944       Hashtbl.add servers_by_ip ips h;
 945       h
 946
 947 (* Add server to connected servers *)
 948 let add_connected_server s =
 949   (*incr nservers;*)
 950   if not (List.memq s !connected_servers) then
 951     connected_servers := s :: !connected_servers
 952
 953 (* Remove servers contacts to users and from connected servers *)
 954 let remove_connected_server s =
 955   (*decr nservers;*)
 956   connected_servers := List2.removeq s !connected_servers;
 957   List.iter (fun u ->
 958     remove_user s u
 959   ) s.server_users;
 960   s.server_hub_state <- Waiting;
 961   s.server_search <- None;
 962   s.server_users <- []
 963
 964 (* Remove server from known servers list *)
 965 let server_remove s =
 966   server_remove (as_server s.server_server);
 967   Hashtbl.remove servers_by_ip (Ip.to_string s.server_ip)
 968   (*decr nknown_servers;*)
 969   (*servers_list := List2.removeq s !servers_list*)
 970
 971 (* Iter all servers in connected list *)
 972 let dc_with_connected_servers f =
 973   List.iter (fun s ->
 974     f s
 975   ) !connected_servers
 976
 977 (* Return hub state text *)
 978 let dc_hubstate_to_text s =
 979   (match s.server_hub_state with
 980   | Waiting -> "Not connected"
 981   | User -> "User"
 982   | Vipped -> "Vip"
 983   | Opped -> "Op" )
 984
 985 (* Search server by ip and port *)
 986 (*let search_server_by_addr addr port =
 987   try
 988     Hashtbl.find servers_by_addr (addr, port)
 989   with _ ->
 990     raise Not_found *)
 991
 992 (* add new result to results-hashtable - return the found or new result *)
 993 let new_result user tiger_root (directory:string) (filename:string) (filesize:int64) =
 994   let basename = Filename2.basename filename in
 995   let key = (directory, basename, filesize) in
 996   (*let r_username = "......" ^ user.user_nick in*)
 997   (try
 998     Hashtbl.find dc_results_by_file key (* if result with dir&name&size exists, return the found result *)
 999   with _ ->                             (* otherwise... *)
1000       let result_names =
1001         if tiger_root <> "" then begin
1002           let found =
1003             (try
1004               ignore (Hashtbl.find dc_shared_files_by_hash tiger_root);
1005               true
1006             with _ -> false )
1007           in
1008           if found then [filename;"ALREADY DOWNLOADED"]
1009           else begin
1010             let found =
1011               (try
1012                 ignore (Hashtbl.find dc_files_by_unchecked_hash tiger_root);
1013                 true
1014               with _ -> false )
1015             in
1016             if found then [filename;"FILE DOWNLOADING..."]
1017             else [filename]
1018           end
1019         end else [filename]
1020       in
1021       let rec r = {                  (* add new result *)
1022           dummy_result with
1023         result_names = result_names;
1024         result_tags = [ {tag_name = Field_UNKNOWN user.user_nick; tag_value = String ""} ];
1025           result_size = filesize;
1026         result_source_network = network.network_num;
1027         } in
1028       let rs = update_result_num r in  (* CommonResult.update_result_num, returns Commontypes.result *)
1029       Hashtbl.add dc_results_by_file key rs;
1030       rs )
1031
1032 (*let hash_file () =
1033   let dcsh = List.hd !dc_shared_files in
1034   let info = CommonUploads.IndexedSharedFiles.get_result dcsh.dc_shared_shared.shared_info in
1035   if dcsh.dc_shared_chunk <> dc_get_nchunks info.shared_size then compute_tigertree_chunk dcsh*)
1036
1037
1038 (*  Hashtbl.iter (fun n sh ->
1039     lprintf_nl "(%s)" sh.shared_codedname;
1040     let info = CommonUploads.IndexedSharedFiles.get_result sh.shared_info in
1041     lprintf_nl "(%s)" info.shared_fullname
1042
1043   ) CommonUploads.shared_files*)
1044
1045 (*
1046 /** We don't keep leaves for blocks smaller than this... */
1047         static const int64_t MIN_BLOCK_SIZE = 64*1024;
1048 *)
1049 (*CommonHasher.compute_tiger :
1050   string -> int64 -> int64 -> (Md4.TigerTree.t job -> unit) -> unit
1051 *)
1052
1053 (* DC++ blocksize
1054                 int64_t bl = 1024;
1055                 while(bl * (int64_t)d->getTigerTree().getLeaves().size() < d->getTigerTree().getFileSize())
1056                         bl *= 2;
1057                 d->getTigerTree().setBlockSize(bl);
1058                 d->getTigerTree().calcRoot();
1059 *)
1060 (*
1061 AdcCommand Download::getCommand(bool zlib, bool tthf) {
1062         AdcCommand cmd(AdcCommand::CMD_GET);
1063         if(isSet(FLAG_TREE_DOWNLOAD)) {
1064                 cmd.addParam("tthl");
1065         } else if(isSet(FLAG_PARTIAL_LIST)) {
1066                 cmd.addParam("list");
1067         } else {
1068                 cmd.addParam("file");
1069         }
1070         if(tthf && getTTH() != NULL) {
1071                 cmd.addParam("TTH/" + getTTH()->toBase32());
1072         } else {
1073                 cmd.addParam(Util::toAdcFile(getSource()));
1074         }
1075         cmd.addParam(Util::toString(getPos()));
1076         cmd.addParam(Util::toString(getSize() - getPos()));
1077
1078         if(zlib && getSize() != -1 && BOOLSETTING(COMPRESS_TRANSFERS)) {
1079                 cmd.addParam("ZL1");
1080         }
1081 *)