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