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