src/networks/direct_connect/dcServers.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Printf2
  21 open BasicSocket
  22 open TcpBufferedSocket
  23 open Options
  24 open CommonOptions
  25 open CommonUser
  26 open CommonServer
  27 open CommonTypes
  28 open CommonGlobals
  29
  30 open DcTypes
  31 open DcOptions
  32 open DcGlobals
  33 open DcProtocol
  34
  35 let log_prefix = "[dcSer]"
  36
  37 let lprintf_nl fmt =
  38   lprintf_nl2 log_prefix fmt
  39
  40 (*let rec remove_short list list2 =
  41   match list with
  42     [] -> List.rev list2
  43   | s :: list ->
  44       if String.length s < 5 then
  45         remove_short list list2
  46       else
  47         remove_short list (s :: list2) *)
  48
  49 (*let stem s =
  50   let s = String.lowercase (String.copy s) in
  51   for i = 0 to String.length s - 1 do
  52     let c = s.[i] in
  53     match c with
  54       'a'..'z' | '0' .. '9' -> ()
  55     | _ -> s.[i] <- ' ';
  56   done;
  57   remove_short (String2.split s ' ') [] *)
  58
  59 let server_addr s = Ip.string_of_addr s.server_addr
  60
  61 (* disconnect from DC hub *)
  62 let disconnect_server s reason =
  63   (match s.server_sock with
  64   | NoConnection -> ()
  65   | ConnectionWaiting token ->
  66       cancel_token token;
  67       s.server_sock <- NoConnection
  68   | Connection sock ->
  69       if !verbose_msg_servers then
  70         lprintf_nl "Server (%s:%d) CLOSED connection for reason (%s)"
  71             (server_addr s) s.server_port (BasicSocket.string_of_reason reason);
  72       (try TcpBufferedSocket.close sock reason with _ -> () );
  73       connection_failed (s.server_connection_control);
  74       s.server_sock <- NoConnection;
  75       s.server_hub_state <- Waiting;
  76       set_server_state s (NotConnected (reason, -1));
  77       remove_connected_server s )
  78
  79 (* Server connection handler *)
  80 let server_handler s sock event =
  81   (match event with
  82   | BASIC_EVENT (CLOSED r) ->
  83       disconnect_server s r
  84   | _ -> () )
  85
  86 (* Get MyInfo Hubs information of connected servers atm *)
  87 let get_myhubs_info () =
  88   let n_hubs = ref 0 in (* how many servers has sent $Hello *)
  89   let r_hubs = ref 0 in (* how many servers we have sent $MyPass *)
  90   let o_hubs = ref 0 in (* how many servers has sent $LogedIn *)
  91   List.iter (fun server ->
  92     (match server.server_sock with
  93     | Connection _ ->
  94       (match server.server_hub_state with
  95       | Opped -> incr o_hubs
  96       | Vipped -> incr r_hubs
  97       | User -> incr n_hubs
  98       | _ -> () )
  99     | _ -> () )
 100   ) !connected_servers;
 101   !n_hubs,!r_hubs,!o_hubs
 102
 103 (* MyInfo record sending *)
 104 let create_myinfo s = (* every server is sent its own info (nick) (uptime) *)
 105   (* <++ V:x,M:x,H:x/y/z,S:x[,O:x]>
 106      V(ersion) x = client version
 107      M(ode) x = mode (A = Active, P = Passive, 5 = SOCKS5)
 108      H(ubs) x = number of hubs connected to where you're not a registered user
 109             y = number of hubs you're registered in
 110             z = number of hubs you're registered as an operator
 111      S(lots) x = number of upload slots you have open (note that they may be in use already)
 112      O(pen an extra slot if speed is below)
 113              x = if total upload is below this value DC++ will open another slot
 114                  This part of the tag is only shown when the option for it is enabled.
 115
 116      <flag> User status as ascii char (byte)
 117         1 normal - 2,3 away - 4,5 server - 6,7 server away - 8,9 fireball - 10,11 fireball away
 118         * The server icon is used when the client has uptime > 2 hours, > 2 GB shared, upload > 200 MB.
 119         * The fireball icon is used when the client has had an upload > 100 kB/s. *)
 120    let version = Autoconf.current_version in
 121    let uptime = current_time () -. s.server_connection_time in
 122    let mode = ref ( if (!!firewalled = true) then 'P' else 'A') in
 123    let own_brand = "MLDC" in
 124    let norm_hubs,reg_hubs,opped_hubs = get_myhubs_info () in
 125    let time_flag =
 126      if (uptime > 7200.) &&
 127         (!nshared_bytes > (Int64.mul (Int64.of_int 2) int64_gbyte)) &&
 128         (!dc_total_uploaded > (Int64.mul (Int64.of_int 200) int64_mbyte)) then 5
 129      else 1
 130    in
 131    {
 132      dest = "$ALL";
 133      nick = s.server_last_nick;
 134      client_brand = own_brand;
 135      version = version;
 136      mode = !mode;
 137      hubs = norm_hubs, reg_hubs, opped_hubs ;
 138      slots = open_slots ();
 139      open_upload_slot = 0; (*TODO Automatically open an extra slot if speed is below kB/s*)
 140      description =
 141        Printf.sprintf "<%s V:%s,M:%c,H:%d/%d/%d,S:%d>" own_brand version !mode
 142          norm_hubs reg_hubs opped_hubs (open_slots ());
 143      conn_speed = !!client_speed;
 144      flag = time_flag;
 145      email = "";
 146      sharesize = DcShared.dc_updatesharesize ();
 147      bwlimit = !!max_hard_upload_rate;
 148    }
 149
 150 (* Send to all connected servers *)
 151 let send_myinfo_connected_servers () =
 152   List.iter (fun s -> (* send myinfo to all servers *)
 153     (match s.server_sock with
 154     | Connection sock ->
 155         let dc_myinfo = create_myinfo s in
 156         dc_send_msg sock (MyInfoReq (dc_myinfo))
 157     | _ -> () )
 158   ) !connected_servers
 159
 160 (* Server message handler *)
 161 let client_to_server s m sock =
 162
 163   (match m with
 164
 165   | BadPassReq ->
 166       if !verbose_msg_servers then
 167         lprintf_nl "Bad password for %S on %s" s.server_last_nick (Ip.string_of_addr s.server_addr);
 168       s.server_hub_state <- User
 169
 170   | ConnectToMeReq t ->  (* client is unknown at this moment until $MyNick is received *)
 171       (try
 172         if !verbose_msg_clients then
 173           lprintf_nl "$ConnectToMe (%s:%d) (%s) (%s:%d)"
 174             (server_addr s) s.server_port t.ConnectToMe.nick (Ip.to_string t.ConnectToMe.ip)
 175             t.ConnectToMe.port;
 176         let c = new_client () in
 177         c.client_name <- Some t.ConnectToMe.nick; (* unknown *)
 178         c.client_addr <- Some (t.ConnectToMe.ip, t.ConnectToMe.port);
 179         c.client_state <- DcConnectionStyle (ClientActive (Upload 0)); (* level is set later*)
 180         DcClients.connect_client c
 181       with e ->
 182           if !verbose_unexpected_messages then lprintf_nl "%s in ConnectToMe sending" (Printexc2.to_string e) )
 183
 184   | ForceMoveReq t ->
 185       lprintf_nl "Received ForceMove(%S) from %s" t (Ip.string_of_addr s.server_addr);
 186       disconnect_server s (Closed_for_error "Forcemove command received")
 187
 188   | GetPassReq -> (* After password request from hub ... *)
 189       let addr = Ip.string_of_addr s.server_addr in
 190       let nick = s.server_last_nick in
 191       let rec loop i =
 192         (match i with
 193         | [] -> dc_send_msg sock ( MyPassReq "IDontKnowThePass" ) (* What to do when have no pass ? *)
 194         | (a , n, p) :: tl ->
 195             if (a = addr) && (n = nick) then begin (* Send pass from .ini if present for this hub *)
 196               s.server_hub_state <- Vipped;
 197               dc_send_msg sock ( MyPassReq p );
 198             end else loop tl )
 199       in
 200       loop !!hubs_passwords
 201
 202   | HelloReq n ->
 203       if n = s.server_last_nick then begin (* if the $Hello is for me :) *)
 204         (match s.server_hub_state with
 205         | Waiting | Opped | Vipped ->
 206           if !verbose_msg_servers then lprintf_nl "Connected to Hub: %s" s.server_name;
 207           add_connected_server s;
 208           set_server_state s (Connected (-1));
 209           dc_send_msg sock (VersionReq Autoconf.current_version);
 210           dc_send_msg sock (GetNickListReq); (* Send even if we don't need *)
 211           set_rtimeout sock (float_of_int Date.half_day_in_secs);        (* set read socket timeout big enough *)
 212           if s.server_hub_state = Waiting then s.server_hub_state <- User; (* set state with hub to User *)
 213           ignore (new_user (Some s) s.server_last_nick);                   (* add myself to this serverlist for sure *)
 214           let dc_myinfo = create_myinfo s in
 215           dc_send_msg sock (MyInfoReq (dc_myinfo))
 216         | User -> (* We have already passed servers negotiations once and are inside... *)
 217             set_rtimeout sock (float_of_int Date.half_day_in_secs))
 218       end else    (* $Hello from hub is not for me so it is a new user *)
 219         ignore (new_user (Some s) n)
 220
 221   | HubIsFullReq ->
 222      disconnect_server s (Closed_for_error (Printf.sprintf "Hub %s is full" (Ip.string_of_addr s.server_addr) ) )
 223
 224   | HubNameReq name ->
 225       s.server_name <- name;
 226       server_must_update s
 227
 228   | HubTopicReq topic ->
 229       s.server_topic <- topic
 230
 231   | LockReq lock -> (* After $Lock from hub, answer with possible $Supports followed by $Key and $ValidateNick *)
 232       if (lock.Lock.extended_protocol = true) then (* if EXTENDEDPROTOCOL sent from hub, send own $Supports *)
 233         dc_send_msg sock ( SupportsReq (HubSupports mldonkey_dc_hub_supports) );
 234
 235       dc_send_msg sock ( KeyReq { Key.key = DcKey.calculate_key lock.Lock.key } ); (* Send $Key *)
 236       let addr = Ip.string_of_addr s.server_addr in (* current server ip as string *)
 237         let rec loop passline =
 238           match passline with
 239           | [] ->                  (* end of !!hubs_passwords option list *)
 240               let my_nick = local_login () in (* use global or local nick if nick/pass pair not set in .ini *)
 241               s.server_last_nick <- my_nick;
 242               dc_send_msg sock (ValidateNickReq my_nick )
 243           | (a , n, _) :: tl -> (* on every line in !!hubs_passwords list check for match *)
 244               if (a = addr) then begin
 245                 s.server_last_nick <- n;
 246                 dc_send_msg sock ( ValidateNickReq n ) (* send a nick that has password match in .ini *)
 247               end else loop tl
 248         in
 249         loop !!hubs_passwords
 250
 251   | LogedInReq n ->
 252       if n = s.server_last_nick then begin (* if we are really opped *)
 253         if !verbose_msg_servers then lprintf_nl "Opped to server %s" (Ip.string_of_addr s.server_addr);
 254         s.server_hub_state <- Opped;
 255         (*let dc_myinfo = create_myinfo s in
 256         dc_send_msg sock (MyInfoReq (dc_myinfo)) *)
 257       end
 258
 259   | MessageReq t ->
 260       s.server_messages <- s.server_messages @ [
 261         (int_of_float (current_time ()), t.Message.from, PublicMessage (0,t.Message.message))];
 262
 263   | MyInfoReq t ->
 264       let u = new_user (Some s) t.nick in
 265       (* some hubs send empty info fields, so son't update user if already info filled *)
 266       if (t.description = empty_string) && (u.user_myinfo.description <> empty_string) then ()
 267       else u.user_myinfo <- t;
 268       (*if u.user_myinfo.conn_speed = "" then u.user_type <- Bot;*)
 269       user_must_update (as_user u.user_user);
 270       ignore (DcClients.ask_user_for_download u) (* start downloading pending load immediately *)
 271
 272   | NickListReq list ->
 273       List.iter (fun nick ->
 274         let u = new_user (Some s) nick in
 275           user_must_update (as_user u.user_user)
 276       ) list
 277
 278   | OpListReq list ->
 279       List.iter (fun nick ->
 280         let u = new_user (Some s) nick in
 281         (*u.user_type <- if u.user_myinfo.conn_speed = "" then Bot*)
 282         u.user_type <- Op;
 283           user_must_update (as_user u.user_user)
 284       ) list
 285
 286   | QuitReq t ->
 287       remove_user s (search_user_by_name t);
 288
 289   | RevConnectToMeReq t ->
 290       let orig = t.RevConnectToMe.orig in
 291       if !verbose_msg_clients then lprintf_nl "Received RevConnectToMe (%s)" orig;
 292       if not !!firewalled then begin (* we are in active mode, send $ConnectToMe *)
 293         (match !dc_tcp_listen_sock with
 294         | Some lsock -> (* our listenin socket is active, so send ConnectToMe *)
 295             (try
 296               let u = search_user_by_name orig in
 297               if (u.user_state = UserIdle) then begin
 298                 u.user_state <- UserPassiveUserInitiating (current_time() );
 299                 dc_send_msg sock (
 300                   let module C = ConnectToMe in
 301                   ConnectToMeReq {
 302                     C.nick = orig;
 303                     C.ip = CommonOptions.client_ip (Some sock);
 304                     C.port = !!dc_port;
 305                   }
 306                 )
 307               end (*else lprintf_nl "Reveived Revconnect: User not UserIdle. Cannot send $ConnectToMe %s - " u.user_nick*)
 308             with _ -> if !verbose_msg_clients then lprintf_nl "  No user by name: %s" orig )
 309         | _ -> () )
 310       end else
 311         if !verbose_msg_clients then lprintf_nl "  We are in passive mode and client seems to be also"
 312
 313   | SearchReq t ->
 314       (try
 315         let find () =
 316           let amount = if t.Search.passive then 5 else 10 in
 317           (match t.Search.filetype with
 318           | 9 ->
 319               let dcsh = Hashtbl.find dc_shared_files_by_hash t.Search.words_or_tth in
 320               [dcsh]
 321           | 1 ->
 322               let results = ref [] in
 323               let words =
 324                 (match String2.split_simplify t.Search.words_or_tth ' ' with
 325                 | [] -> raise Not_found
 326                 | words -> words )
 327               in
 328               let all_match = ref true in
 329               let count = ref 0 in
 330               (try
 331                 Hashtbl.iter (fun _ dcsh ->
 332                   all_match := true;
 333                   let rec search list =
 334                     (match list with
 335                     | [] -> ()
 336                     | word :: tail ->
 337                         if String2.contains dcsh.dc_shared_searchname word then search tail
 338                         else all_match := false )
 339                   in
 340                   search words;
 341                   if !all_match then begin
 342                     results := dcsh :: !results;
 343                     incr count;
 344                     if !count = amount then raise BreakIter (* lets stop the search if enough found already *)
 345                   end
 346                 ) dc_shared_files_by_hash
 347               with BreakIter -> () );
 348               !results
 349           | _ ->
 350               [] )
 351           (*if t.Search.filetype = 9 then begin
 352             (try
 353               let dcsh = Hashtbl.find dc_shared_files_by_hash t.Search.words_or_tth in
 354               let sh = CommonUploads.find_by_name dcsh.dc_shared_codedname in
 355               let index = Hashtbl.find CommonUploads.infos_by_name dcsh.dc_shared_fullname in
 356               let info = IndexedSharedFiles.get_result index in
 357               [(sh,info)]
 358             with _ -> raise Not_found )
 359           end else begin
 360             CommonUploads.query (
 361                       let q =
 362                 (match String2.split_simplify t.Search.words_or_tth ' ' with
 363                 | [] -> raise Not_found
 364                 | s :: tail -> List.fold_left (fun q s -> QAnd (q, (QHasWord s))) (QHasWord s) tail )
 365                       in
 366               (match t.Search.sizelimit with
 367                       | NoLimit -> q
 368               | AtMost n -> QAnd (QHasMaxVal (Field_Size, n),q)
 369               | AtLeast n -> QAnd (QHasMinVal (Field_Size, n),q) )
 370             )
 371           end *)
 372         in
 373         let send_sr_messages files =      (* function to send both active and passive messages *)
 374           (*lprintf_nl "Results %d" (List.length files);*)
 375           List.iter (fun dcsh ->
 376             let codedname = String2.replace dcsh.dc_shared_codedname '/' (String2.of_char char92) in
 377             (*let length = String.length codedname in*)
 378             let directory,filename =
 379               (try
 380                 let pos = String.rindex codedname char92 in
 381                 (String2.before codedname pos), (String2.after codedname (pos+1))
 382               with _ ->
 383                 if !verbose_unknown_messages then lprintf_nl "Codedname was wrong in Search receiving";
 384                 raise Not_found )
 385             in
 386             let message =                 (* message structure for both active and passive messages *)
 387               let module S = SR in {
 388                 S.owner = s.server_last_nick;
 389                 S.directory = directory;
 390                 S.filename = filename;
 391                 S.filesize = dcsh.dc_shared_size;
 392                 S.open_slots = current_slots ();
 393                 S.all_slots = open_slots ();
 394                 S.tth = dcsh.dc_shared_tiger_root;
 395                 S.server_name = s.server_name;
 396                 S.server_ip = Printf.sprintf "%s" (Ip.to_string (Ip.ip_of_addr s.server_addr));
 397                 S.server_port = Printf.sprintf "%d" s.server_port;
 398                 S.to_nick = if t.Search.passive then Some t.Search.nick else None;
 399                         }
 400             in
 401             if !verbose_msg_clients then begin
 402               let mode = if t.Search.passive then 'P' else 'A' in
 403               lprintf_nl "Sending $SR: (%s)(%c)(%s)(%s)(%s)" t.Search.nick mode directory filename
 404                 dcsh.dc_shared_tiger_root
 405         end;
 406             if t.Search.passive then
 407               dc_send_msg sock (SRReq ( message ))
 408             else
 409               DcClients.udp_send (Ip.of_string t.Search.ip) (int_of_string t.Search.port) (SRReq ( message ))
 410           ) files
 411         in
 412
 413         if t.Search.passive then begin                          (* if passive search received *)
 414           if not !!firewalled then begin                        (* and we are in active mode  *)
 415             if (t.Search.nick <> s.server_last_nick) then begin (* if search is not from ourself ... *)
 416               ignore (new_user (Some s) t.Search.nick);
 417               let files = find () in
 418               send_sr_messages files
 419             end
 420           end                                                   (* passive search to passive user, do nothing *)
 421         end else begin                                          (* active search received ... *)
 422           if (t.Search.ip <> Ip.to_string (CommonOptions.client_ip (Some sock))) ||
 423              (t.Search.port <> string_of_int(!!dc_port)) then begin (* check that ip & port is not ours *)
 424                 let files = find () in
 425                 send_sr_messages files
 426       end
 427         end
 428       with _ -> () (*lprintf_nl "Exception %s in SEARCH receiving" (Printexc2.to_string e)*) )
 429
 430   | SRReq t -> (* download is resumed automatically, if file is found already to be in file list *)
 431       DcClients.received_new_search_result s t
 432
 433   | SupportsReq t -> (* After EXTENDEDPROTOCOL support list from hub ... *)
 434       (match t with
 435       | HubSupports t -> s.server_supports <- Some t (* Save supports into serverdata *)
 436       | _ -> () )
 437
 438   | ToReq t ->
 439       if !verbose_msg_clients then lprintf_nl "Received $To: from %s (%s)" t.To.from t.To.message;
 440       let u = new_user (Some s) t.To.from in
 441       u.user_messages <- u.user_messages @ [
 442         (int_of_float (current_time ()), t.To.from, PrivateMessage (0, t.To.message))];
 443
 444   | UnknownReq m ->
 445       if m <> "" then
 446         if !verbose_unexpected_messages || !verbose_msg_servers then
 447           let l = String.length m in
 448           let txt = Printf.sprintf "Unknown server message: (%s)" (shorten_string s.server_name 20)in
 449           if l > 50 then lprintf_nl "%s (%s...%d chars)" txt (shorten_string m 50) l
 450           else lprintf_nl "%s (%s)" txt m
 451
 452   | UserCommandReq -> () (* Not supported atm *)
 453
 454   | UserIPReq st -> (* CHECK *)
 455       if !verbose_msg_servers then lprintf_nl "Received $UserIP";
 456       let st = UserIP.parse_nameip st in
 457       List.iter begin fun (name,addr) ->
 458         lprintf_nl "UserIP: %s %s" name (Ip.string_of_addr addr);
 459         try
 460           if name = s.server_last_nick then
 461           begin
 462             match addr with
 463             | Ip.AddrIp ip -> lprintf_nl "Received self IP: %s" (Ip.to_string ip); last_high_id := ip
 464             | Ip.AddrName _ -> ()
 465           end;
 466           let u = search_user_by_name name in
 467           u.user_ip <- addr;
 468           lprintf_nl "Added ip %s to user %s" (Ip.string_of_addr u.user_ip) u.user_nick
 469         with _ ->
 470           if !verbose_unexpected_messages then lprintf_nl "No user by name %s" name
 471       end st
 472
 473   | ValidateDenideReq n ->
 474       let errortxt = Printf.sprintf "Nick %s is already in use" n in
 475       if !verbose_unexpected_messages || !verbose_msg_servers then
 476         lprintf_nl "%s" errortxt;
 477       disconnect_server s (Closed_for_error errortxt )
 478
 479   | VersionReq v -> ()
 480
 481   | _ ->
 482     lprintf_nl "--> Unhandled server message. Implement ?:";
 483     DcProtocol.dc_print m )
 484
 485 (* connect to DC server *)
 486 let connect_server s =
 487   if can_open_connection connection_manager then
 488     (match s.server_sock with
 489     | NoConnection ->
 490         let token = add_pending_connection connection_manager (fun token ->
 491           (*s.server_sock <- NoConnection;*)
 492           (try
 493             connection_try s.server_connection_control;
 494             (*printf_char 's'; *)
 495             let sock = TcpBufferedSocket.connect token "directconnect to server"
 496                        (Ip.to_inet_addr (Ip.ip_of_addr s.server_addr)) s.server_port (server_handler s) in
 497               set_server_state s Connecting;
 498               TcpBufferedSocket.set_read_controler sock download_control; (* CommonGlobals.download_control *)
 499               TcpBufferedSocket.set_write_controler sock upload_control;
 500               (*s.server_search_timeout <- last_time () + 30;*)
 501               TcpBufferedSocket.set_reader sock (dc_handler_server (client_to_server s));
 502               TcpBufferedSocket.set_rtimeout sock !!server_connection_timeout (*60.*);
 503               TcpBufferedSocket.set_handler sock (BASIC_EVENT RTIMEOUT) (fun s -> close s Closed_for_timeout);
 504                     s.server_sock <- Connection sock;
 505               s.server_ip <- Ip.ip_of_addr s.server_addr;
 506               s.server_connection_time <- current_time ();
 507                   with e ->
 508             disconnect_server s (Closed_for_exception e) )
 509         ) in
 510             s.server_sock <- ConnectionWaiting token
 511     | _ -> () )
 512
 513 let try_connect_server s =
 514   if connection_can_try s.server_connection_control &&
 515     s.server_sock = NoConnection then
 516     connect_server s
 517
 518 (* Make hublist from file f, return hublist *)
 519 let make_hublist_from_file f =
 520   let s = File.to_string f in
 521   let hublist = ref [] in
 522   let counter = ref 0 in
 523   let lines = String2.split s '\n' in
 524   List.iter (fun l ->
 525     (match String2.split l '|' with
 526     | server_name :: server_addr :: server_info :: server_nusers :: _ ->
 527         let ap = String2.split server_addr ':' in
 528         let port = ref 411 in
 529         let addr = ref "" in
 530         let ll = List.length ap in
 531         if ll > 0 then begin
 532           addr := List.hd ap;
 533           if ll = 2 then begin
 534             (try
 535               port := int_of_string (List.nth ap 1)
 536             with e -> () )
 537           end;
 538           if (ll < 3) && ((String.length !addr) > 2) && (!port > 0) && (!port < 65536) then begin
 539             let nusers = ref 0 in begin
 540               try
 541                 nusers := int_of_string server_nusers
 542               with _ -> ()
 543             end;
 544             incr counter;
 545             let r = {
 546               dc_name = Charset.Locale.to_utf8 server_name;
 547               dc_ip = Ip.addr_of_string !addr;
 548               dc_port = !port;
 549               dc_info = Charset.Locale.to_utf8 server_info;
 550               dc_nusers = !nusers;
 551             } in
 552             hublist := r :: !hublist
 553           end
 554         end
 555     | _ -> () )
 556   ) lines;
 557   if !verbose_msg_servers then lprintf_nl "Found %d valid servers from hublist" !counter;
 558   !hublist
 559
 560 let xml_tag name = let name = String.lowercase name in fun x -> String.lowercase (Xml.tag x) = name
 561
 562 let rec xml_select names xs =
 563   match names with
 564   | [] -> xs
 565   | [name] -> List.filter (xml_tag name) xs
 566   | name::t ->
 567     let l = List.filter (xml_tag name) xs in
 568     xml_select t (List.concat (List.map Xml.children l))
 569
 570 let ssplit s sub =
 571   try
 572     let n = String2.search_from s 0 sub in
 573     Some (String2.before s n, String2.after s (n + String.length sub))
 574   with
 575     _ -> None
 576
 577 exception ADC_not_supported
 578
 579 let parse_address s =
 580   let s = match ssplit (String.lowercase s) "://" with
 581   | Some ("dchub",s) -> s
 582   | None -> s
 583   | Some (("adc"|"adcs"),_) -> raise ADC_not_supported
 584   | Some (proto,_) -> failwith (Printf.sprintf "Unsupported protocol in %S" s)
 585   in
 586   try Scanf.sscanf s "%s@:%u" (fun s n -> s,n) with _ -> s,411
 587
 588 let make_hublist_from_xml x =
 589   let make_hub x =
 590     let name = Charset.Locale.to_utf8 (Xml.attrib x "Name") in
 591     let (address,port) = parse_address (Xml.attrib x "Address") in
 592     let info = Charset.Locale.to_utf8 (Xml.attrib x "Description") in
 593     let nusers = int_of_string (Xml.attrib x "Users") in
 594     {
 595       dc_name = name;
 596       dc_ip = Ip.addr_of_string address;
 597       dc_port = port;
 598       dc_info = info;
 599       dc_nusers = nusers;
 600     }
 601   in
 602   let l = xml_select ["hublist";"hubs";"hub"] [x] in
 603   let adc = ref 0 in
 604   let add_hub acc x =
 605     try
 606       make_hub x :: acc
 607     with
 608     | ADC_not_supported -> incr adc; acc
 609     | exn -> lprintf_nl "Skipping hublist entry : %s" (Printexc2.to_string exn); acc
 610   in
 611   let l' = List.fold_left add_hub [] l in
 612   if !verbose_msg_servers then
 613     lprintf_nl "Servers in hublist : %u total, %u valid, %u adc" (List.length l) (List.length l') !adc;
 614   l'
 615
 616 (* Connect to all autoconnect servers once *)
 617 let autoconnect_to_servers () =
 618   Hashtbl.iter (fun _ s ->
 619     if s.server_autoconnect then begin                    (* only if server is marked as autoconnect *)
 620       if not (List.memq s !connected_servers) then begin  (* and not already connected               *)
 621         if s.server_sock = NoConnection then begin        (* and not in connection state             *)
 622           try_connect_server s;
 623         end
 624       end
 625     end
 626  ) servers_by_ip;
 627
 628 module P = GuiTypes
 629
 630 (* register server operations *)
 631 let _ =
 632   server_ops.op_server_connect <- (fun s -> connect_server s);
 633   server_ops.op_server_disconnect <- (fun s -> disconnect_server s Closed_by_user);
 634   server_ops.op_server_query_users <- (fun s ->
 635     do_if_connected s.server_sock (fun sock ->
 636       dc_send_msg sock (GetNickListReq)
 637     )
 638   );
 639   server_ops.op_server_users <- (fun s ->
 640     let list = ref [] in
 641     List.iter (fun u ->
 642        list := (as_user u.user_user) :: !list
 643     ) s.server_users;
 644     !list
 645   );
 646   server_ops.op_server_remove <- (fun s ->
 647     disconnect_server s Closed_by_user;
 648     server_remove s
 649   );
 650   server_ops.op_server_info <- (fun s ->
 651         { (impl_server_info s.server_server) with
 652           P.server_num = (server_num s);
 653           P.server_network = network.network_num;
 654           P.server_addr = s.server_addr;
 655           P.server_port = s.server_port;
 656           P.server_realport = 0;
 657           P.server_score = 0;
 658           P.server_tags = [];
 659           P.server_nusers = Int64.of_int (List.length s.server_users);
 660           P.server_state = server_state s;
 661           P.server_name = s.server_name;
 662           P.server_description = s.server_info;
 663           P.server_preferred = false;
 664         }
 665   );
 666   server_ops.op_server_set_preferred <- (fun s preferred ->
 667     s.server_autoconnect <- preferred;
 668     if !verbose_msg_servers then lprintf_nl "Server autoconnection state set to (%s)" (if preferred then "true" else "false")
 669 )
 670
 671 (*
 672     mutable op_server_network : network;
 673     mutable op_server_find_user : ('a -> string -> unit);
 674     mutable op_server_cid : ('a -> Ip.t);
 675     mutable op_server_low_id : ('a -> bool);
 676     mutable op_server_rename : ('a -> string -> unit);
 677 *)
 678
 679
 680