src/networks/donkey/donkeyPandora.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 Int64ops
  21 open Options
  22 open Queues
  23 open Printf2
  24 open Md4
  25 open BasicSocket
  26 open TcpBufferedSocket
  27
  28 open AnyEndian
  29 open LittleEndian
  30
  31 open CommonOptions
  32 open CommonSearch
  33 open CommonServer
  34 open CommonComplexOptions
  35 open CommonFile
  36 open CommonDownloads
  37 open CommonTypes
  38 open CommonGlobals
  39
  40 open DonkeyTypes
  41 open DonkeyProtoClient
  42 open DonkeyOptions
  43
  44 type t = UDP | TCP
  45
  46 type cnx = {
  47     ip1 : string;
  48     port1 : int;
  49     ip2 : string;
  50     port2 : int;
  51     packets_in : Buffer.t;
  52     packets_out : Buffer.t;
  53   }
  54
  55 type client = {
  56     client_proto : emule_proto;
  57     mutable client_comp : compressed_parts option;
  58   }
  59
  60 let extendedrequest e = e.emule_extendedrequest
  61
  62 let connections = Hashtbl.create 13
  63 let udp_packets = ref []
  64
  65 let first_message parse b =
  66   let pos = ref 0 in
  67   let len = String.length b in
  68   if len - !pos >= 5 then
  69     let opcode = get_uint8 b !pos in
  70     let msg_len = get_int b (!pos+1) in
  71     if len - !pos >= 5 + msg_len then
  72       begin
  73         let s = String.sub b (!pos+5) msg_len in
  74         pos := !pos +  msg_len + 5;
  75         parse opcode s
  76       end
  77     else raise Not_found
  78   else
  79     raise Not_found
  80
  81 let cut_messages parse b =
  82   let pos = ref 0 in
  83   let len = String.length b in
  84   try
  85     while len - !pos >= 5 do
  86       let opcode = get_uint8 b !pos in
  87       let msg_len = get_int b (!pos+1) in
  88       if len - !pos >= 5 + msg_len then
  89         begin
  90           let s = String.sub b (!pos+5) msg_len in
  91           pos := !pos +  msg_len + 5;
  92           parse opcode s
  93         end
  94       else raise Not_found
  95     done
  96   with Not_found -> ()
  97
  98 let update_emule_proto_from_tags e tags =
  99   List.iter (fun tag ->
 100       match tag.tag_name with
 101       | Field_KNOWN "compression" ->
 102           for_int_tag tag (fun i ->
 103               e.emule_compression <- i)
 104       | Field_KNOWN "udpver" ->
 105           for_int_tag tag (fun i ->
 106               e.emule_udpver <- i)
 107       | Field_KNOWN "udpport" -> ()
 108       | Field_KNOWN "sourceexchange" ->
 109           for_int_tag tag (fun i ->
 110               e.emule_sourceexchange <- i)
 111       | Field_KNOWN "comments" ->
 112           for_int_tag tag (fun i ->
 113               e.emule_comments <- i)
 114       | Field_KNOWN "extendedrequest" ->
 115           for_int_tag tag (fun i ->
 116               e.emule_extendedrequest <- i)
 117       | Field_KNOWN "features" ->
 118           for_int_tag tag (fun i ->
 119               e.emule_secident <- i land 0x3)
 120       | s ->
 121           if !verbose_msg_clients then
 122             lprintf "Unknown Emule tag: [%s]\n" (string_of_field s)
 123   ) tags
 124
 125 let client_parse c opcode s =
 126   let emule = c.client_proto in
 127   if extendedrequest emule >= 0 then begin
 128       let module P = DonkeyProtoClient in
 129       let t = P.parse emule opcode s in
 130       (match t with
 131           P.EmuleClientInfoReq info
 132         | P.EmuleClientInfoReplyReq info ->
 133             let tags = info.P.EmuleClientInfo.tags in
 134             update_emule_proto_from_tags emule tags;
 135
 136         | P.ConnectReq { P.Connect.tags = tags }
 137         | P.ConnectReplyReq { P.Connect.tags = tags } ->
 138
 139             begin
 140               try
 141                 let options = find_tag (Field_KNOWN "emule_miscoptions1") tags in
 142                 (
 143                 match options with
 144                 | Uint64 v | Fint64 v ->
 145                     update_emule_proto_from_miscoptions1 emule v
 146                 | _ ->
 147                     lprintf "CANNOT INTERPRETE EMULE OPTIONS\n"
 148                 );
 149
 150                 let options2 = find_tag (Field_KNOWN "emule_miscoptions2") tags in
 151                 (
 152                 match options2 with
 153                 | Uint64 v | Fint64 v ->
 154                     update_emule_proto_from_miscoptions2 emule v
 155                 | _ ->
 156                     lprintf "CANNOT INTERPRETE EMULE OPTIONS2\n"
 157                 );
 158
 159               with _ -> ()
 160             end;
 161
 162         | P.UnknownReq (227,_) ->
 163             emule.emule_extendedrequest <-  -1
 164
 165         | P.EmuleCompressedPart t ->
 166
 167             let comp = match c.client_comp with
 168                 None ->
 169                   let comp = {
 170                       comp_md4 = t.EmuleCompressedPart.md4;
 171                       comp_pos = t.EmuleCompressedPart.statpos;
 172                       comp_total = Int64.to_int t.EmuleCompressedPart.newsize;
 173                       comp_len = 0;
 174                       comp_blocs = [];
 175                     } in
 176                   c.client_comp <- Some comp;
 177                   comp
 178               | Some comp -> comp
 179             in
 180             comp.comp_blocs <- t.EmuleCompressedPart.bloc :: comp.comp_blocs;
 181             comp.comp_len <- comp.comp_len + String.length t.EmuleCompressedPart.bloc;
 182
 183 (*            lprintf "Comp bloc: %d/%d\n" comp.comp_len comp.comp_total; *)
 184             if comp.comp_len = comp.comp_total then begin
 185                 lprintf "Compressed bloc received !!!!!!\n";
 186
 187                 let s = String.create comp.comp_len in
 188                 let rec iter list =
 189                   match list with
 190                     [] -> 0
 191                   | b :: tail ->
 192                       let pos = iter tail in
 193                       let len = String.length b in
 194                       String.blit b 0 s pos len;
 195                       pos + len
 196                 in
 197                 let pos = iter comp.comp_blocs in
 198                 assert (pos = comp.comp_len);
 199                   let s = Zlib.uncompress_string2 s in
 200                   lprintf "Decompressed: %d/%d\n" (String.length s) comp.comp_len;
 201
 202                 c.client_comp <- None;
 203               end else
 204             if comp.comp_len > comp.comp_total then begin
 205                 lprintf "ERROR: more data than compressed!!!\n";
 206                 c.client_comp <- None;
 207               end
 208
 209         | _ -> ());
 210       P.print t; lprintf "\n";
 211
 212
 213       let b = Buffer.create 100 in
 214       let _ = DonkeyProtoClient.write emule b t in
 215       let ss = Buffer.contents b in
 216       if ss <> s then begin
 217           if opcode = 212 then begin
 218             let tt = P.parse emule 0xc5 ss in
 219             if t <> tt then begin
 220                 lprintf "======= Parsing/Unparsing differs!!\n";
 221                 P.print tt;
 222                 lprintf "\n---------->\n";
 223                 end
 224
 225           end else begin
 226               lprintf "<---------- %d \n" (String.length ss) ;
 227               dump ss;
 228               lprintf "=========== %d %d\n" opcode (String.length s);
 229               dump s;
 230               lprintf "---------->\n";
 231             end
 232         end
 233     end;
 234   if extendedrequest emule < 0 then
 235     let module P = DonkeyProtoServer in
 236     let t = P.parse opcode s in
 237     P.print t; print_newline ();
 238     match t with
 239       P.UnknownReq _ -> emule.emule_extendedrequest <- 100
 240     | _ -> ()
 241
 242
 243
 244 let commit () =
 245   Unix2.tryopen_write "trace.out" (fun oc -> output_value oc connections)
 246
 247 exception ServerConnection
 248
 249 let read_trace () =
 250   let connections =
 251     Unix2.tryopen_read "trace.out" (fun ic -> input_value ic) in
 252
 253   mldonkey_emule_proto.emule_sourceexchange <- 5;
 254
 255   Hashtbl.iter (fun _ cnx ->
 256       try
 257
 258         let emule = { dummy_emule_proto with
 259             emule_version = 0;
 260             emule_extendedrequest = 2; } in
 261
 262         let c = {
 263             client_proto = emule;
 264             client_comp = None;
 265           } in
 266
 267         let buffer = Buffer.contents cnx.packets_in in
 268         (try
 269             let module D = DonkeyProtoClient in
 270             let t = first_message
 271               (D.parse emule) buffer in
 272             (match t with
 273               | D.EmuleClientInfoReplyReq _
 274               | D.EmuleClientInfoReq _
 275               | D.ConnectReq _
 276               | D.ConnectReplyReq _ ->
 277                   lprintf "CLIENT CONNECTION\n"
 278
 279               | D.UnknownReq _ ->
 280                   D.print t; print_newline ();
 281                   raise ServerConnection
 282
 283               | _ ->
 284                   D.print t; print_newline ();
 285                   lprintf "COULD NOT RECOGNIZE CONNECTION\n"
 286             );
 287           with
 288           | ServerConnection ->
 289               lprintf "PROBABLY A SERVER CONNECTION\n"
 290           | Not_found ->
 291               lprintf "EMPTY CONNECTION (%d)\n" (String.length buffer)
 292         );
 293
 294         lprintf "CONNECTION %s:%d --> %s:%d"
 295           cnx.ip1 cnx.port1 cnx.ip2 cnx.port2; print_newline ();
 296         lprintf "  INCOMING:\n";
 297         cut_messages (client_parse c) buffer;
 298         lprintf "  OUTGOING:\n";
 299         cut_messages (client_parse c)
 300         (Buffer.contents cnx.packets_out);
 301
 302       with
 303       | e ->
 304           lprintf "Exception %s\n" (Printexc2.to_string e)
 305   ) connections
 306
 307 let new_packet (kind:t) (number:int) ip1 port1 ip2 port2 data =
 308   match kind with
 309     UDP ->
 310       begin
 311         try
 312           udp_packets := (ip1,port1,ip2,port2,data) :: !udp_packets;
 313 (*              lprintf "New packet:\n%s\n" (String.escaped data);           *)
 314           ()
 315         with e ->
 316 (*                lprintf "Could not parse UDP packet:\n"; *)
 317             ()
 318       end
 319   | TCP ->
 320       let out_packet = (ip1, port1, ip2, port2) in
 321       let in_packet = (ip2, port2, ip1, port1) in
 322
 323       try
 324         let cnx =  Hashtbl.find connections out_packet in
 325         Buffer.add_string cnx.packets_out data;
 326         ()
 327       with _ ->
 328           try
 329             let cnx =  Hashtbl.find connections in_packet in
 330             Buffer.add_string cnx.packets_in data
 331           with _ ->
 332               let cnx = {
 333                   ip1 = ip1;
 334                   port1 = port1;
 335                   ip2 = ip2;
 336                   port2 = port2;
 337                   packets_out = Buffer.create 100;
 338                   packets_in = Buffer.create 100;
 339                 } in
 340               Hashtbl.add connections out_packet cnx;
 341               Buffer.add_string cnx.packets_out data
 342
 343
 344
 345