src/networks/donkey/donkeyProtoClient.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 AnyEndian
  22 open Printf2
  23 open Md4
  24 open CommonTypes
  25 open LittleEndian
  26 open CommonGlobals
  27 open CommonOptions
  28
  29 open DonkeyTypes
  30 open DonkeyMftp
  31
  32 let compatibleclient = ref 10
  33
  34 let get_emule_version () =
  35     (!compatibleclient lsl 24) lor
  36     (int_of_string(Autoconf.major_version) lsl 17) lor
  37     (int_of_string(Autoconf.minor_version) lsl 10) lor
  38     (int_of_string(Autoconf.sub_version) lsl 7)
  39
  40 let mldonkey_emule_proto =
  41   {
  42     emule_version = get_emule_version ();
  43     emule_release = "";
  44     emule_osinfosupport = 1;
  45     emule_features = 3;
  46
  47 (* emule_miscoptions1 *)
  48     received_miscoptions1 = false;
  49     emule_aich = 0;
  50     emule_unicode = 0;
  51     emule_udpver = 0;
  52     emule_compression = 1;
  53     emule_secident = 3; (* Emule uses v1 if advertising both, v2 if only advertising 2 *)
  54     emule_sourceexchange = 2; (* 2 : +client_md4 3 : +IdHybrid (emule Kademlia?)*)
  55     emule_extendedrequest = 1; (* 1: +file_status 2: +ncomplete_sources*)
  56     emule_comments = 1;
  57     emule_peercache = 0;
  58     emule_noviewshared = 0;
  59     emule_multipacket = 0;
  60     emule_supportpreview = 0;
  61
  62 (* emule_miscoptions2 *)
  63     received_miscoptions2 = false;
  64     emule_require_crypt = 0;
  65     emule_request_crypt = 0;
  66     emule_support_crypt = 0;
  67     emule_extmultipacket = 0;
  68     emule_largefiles = 1;
  69     emule_kad_version = 0;
  70     emule_support_captcha = 1;
  71   }
  72
  73 let emule_miscoptions1 m =
  74   let o =
  75     (m.emule_aich lsl 29) lor
  76     (m.emule_unicode lsl 28) lor
  77     (m.emule_udpver lsl 24) lor
  78     (m.emule_compression lsl 20) lor
  79     (m.emule_secident lsl 16) lor
  80     (m.emule_sourceexchange lsl 12) lor
  81     (m.emule_extendedrequest lsl 8) lor
  82     (m.emule_comments lsl 4) lor
  83     (m.emule_peercache lsl 3) lor
  84     (m.emule_noviewshared lsl 2) lor
  85     (m.emule_multipacket lsl 1) lor
  86     (m.emule_supportpreview lsl 0)
  87   in
  88   Int64.of_int o
  89
  90 let update_emule_proto_from_miscoptions1 m o =
  91   let o = Int64.to_int o in
  92   m.emule_aich            <- (o lsr 29) land 0x7;
  93   m.emule_unicode         <- (o lsr 28) land 0xf;
  94   m.emule_udpver          <- (o lsr 24) land 0xf;
  95   m.emule_compression     <- (o lsr 20) land 0xf;
  96   m.emule_secident        <- (o lsr 16) land 0xf;
  97   m.emule_sourceexchange  <- (o lsr 12) land 0xf;
  98   m.emule_extendedrequest <- (o lsr  8) land 0xf;
  99   m.emule_comments        <- (o lsr  4) land 0xf;
 100   m.emule_peercache       <- (o lsr  3) land 0x1;
 101   m.emule_noviewshared    <- (o lsr  2) land 0x1;
 102   m.emule_multipacket     <- (o lsr  1) land 0x1;
 103   m.emule_supportpreview  <- (o lsr  0) land 0x1
 104
 105 let print_emule_proto_miscoptions1 m =
 106   let buf = Buffer.create 50 in
 107   if m.emule_aich <> 0 then Printf.bprintf buf " aich %d\n" m.emule_aich;
 108   if m.emule_unicode <> 0 then Printf.bprintf buf " unicode %d\n" m.emule_unicode;
 109   if m.emule_udpver <> 0 then Printf.bprintf buf " udpver %d\n" m.emule_udpver;
 110   if m.emule_compression <> 0 then Printf.bprintf buf " compression %d\n" m.emule_compression;
 111   if m.emule_secident <> 0 then Printf.bprintf buf " secident %d\n" m.emule_secident;
 112   if m.emule_sourceexchange <> 0 then Printf.bprintf buf " sourceexchange %d\n" m.emule_sourceexchange;
 113   if m.emule_extendedrequest <> 0 then Printf.bprintf buf " extendedrequest %d\n" m.emule_extendedrequest;
 114   if m.emule_comments <> 0 then Printf.bprintf buf " comments %d\n" m.emule_comments;
 115   if m.emule_peercache <> 0 then Printf.bprintf buf " peercache %d\n" m.emule_peercache;
 116   if m.emule_noviewshared <> 0 then Printf.bprintf buf " noviewshared %d\n" m.emule_noviewshared;
 117   if m.emule_multipacket <> 0 then Printf.bprintf buf " multipacket %d\n" m.emule_multipacket;
 118   if m.emule_supportpreview <> 0 then Printf.bprintf buf " supportpreview %d\n" m.emule_supportpreview;
 119   Buffer.contents buf
 120
 121 let emule_miscoptions2 m =
 122   let o =
 123     (m.emule_support_captcha lsl 11) lor
 124     (m.emule_largefiles lsl 4)
 125   in
 126   Int64.of_int o
 127
 128 let update_emule_proto_from_miscoptions2 m o =
 129   let o = Int64.to_int o in
 130   m.emule_support_captcha <- (o lsr 11) land 0x1;
 131   m.emule_require_crypt   <- (o lsr 9)  land 0x1;
 132   m.emule_request_crypt   <- (o lsr 8)  land 0x1;
 133   m.emule_support_crypt   <- (o lsr 7)  land 0x1;
 134   m.emule_extmultipacket  <- (o lsr 5)  land 0x1;
 135   m.emule_largefiles      <- (o lsr 4)  land 0x1;
 136   m.emule_kad_version     <- (o lsr 0)  land 0xf
 137
 138 let print_emule_proto_miscoptions2 m =
 139   let buf = Buffer.create 50 in
 140   if m.emule_require_crypt <> 0 then Printf.bprintf buf " require_crypt %d\n" m.emule_require_crypt;
 141   if m.emule_request_crypt <> 0 then Printf.bprintf buf " request_crypt %d\n" m.emule_request_crypt;
 142   if m.emule_support_crypt <> 0 then Printf.bprintf buf " support_crypt %d\n" m.emule_support_crypt;
 143   if m.emule_extmultipacket <> 0 then Printf.bprintf buf " extmultipacket %d\n" m.emule_extmultipacket;
 144   if m.emule_largefiles <> 0 then Printf.bprintf buf " largefiles %d\n" m.emule_largefiles;
 145   if m.emule_kad_version <> 0 then Printf.bprintf buf " kad_version %d\n" m.emule_kad_version;
 146   if m.emule_support_captcha <> 0 then Printf.bprintf buf " support_captcha %d\n" m.emule_support_captcha;
 147   Buffer.contents buf
 148
 149 let emule_compatoptions m =
 150   (m.emule_osinfosupport lsl 0)
 151
 152 let update_emule_proto_from_compatoptions m o =
 153   m.emule_osinfosupport <- (o lsr 0) land 0x1
 154
 155 let extendedrequest e =
 156   min e.emule_extendedrequest mldonkey_emule_proto.emule_extendedrequest
 157
 158 let sourceexchange e =
 159   min e.emule_sourceexchange mldonkey_emule_proto.emule_sourceexchange
 160
 161 (*
 162 BAD MESSAGE FROM CONNECTING CLIENT
 163 UnknownReq:
 164 ascii: [(1)(16)(231)(129)(131)(26) O(247)(154)(145)(251)(253)(167) G }(207) j(146)(140) { l(139) F(18)(0)(0)(0)(0)(0)(0)(0)(0)(0)(0)]
 165 dec: [
 166 (1)
 167 (16)
 168 (231)(129)(131)(26)(79)(247)(154)(145)(251)(253)(167)(71)(125)(207)(106)(146)
 169 (140)(123)(108)(139)
 170 (70)(18)
 171 (0)(0)(0)(0)
 172 (0)(0)(0)(0)(0)(0)
 173 ]
 174   *)
 175 let rec lbprint_tags buf tags =
 176   match tags with
 177   [] -> Printf.bprintf buf ""
 178   | tag :: tags ->
 179    Printf.bprintf buf " (%s)=(%s)" (escaped_string_of_field tag)
 180    (string_of_tag_value tag.tag_value);
 181     lbprint_tags buf tags
 182
 183 module Connect  = struct
 184     type t = {
 185         hash_len : int;
 186         md4 : Md4.t;
 187         ip: Ip.t;
 188         port: int;
 189         tags : tag list;
 190         server_info : (Ip.t * int) option;
 191         left_bytes : string;
 192       }
 193
 194     let names_of_tag = client_common_tags
 195
 196     let names_of_tag =
 197       List.map (fun (v, name) -> (v, Field_KNOWN name)) names_of_tag
 198
 199     let parse reply len s =
 200       let hash_len, pos = if not reply then get_uint8 s 1, 2 else -1, 1 in
 201       let md4 = get_md4 s pos in
 202       let ip = get_ip s (pos+16) in
 203       let port = get_port s (pos+20) in
 204       let tags, pos = get_tags s (pos+22) names_of_tag in
 205       let server_info = Some (get_ip s pos, get_port s (pos+4)) in
 206       let left_bytes = String.sub s (pos+6) (String.length s - pos - 6) in
 207       {
 208         hash_len = hash_len;
 209         md4 = md4;
 210         ip = ip;
 211         port = port;
 212         tags = tags;
 213         server_info = server_info;
 214         left_bytes = left_bytes;
 215       }
 216
 217
 218     let print t =
 219       let b1 = Buffer.create 50 in
 220       let b2 = Buffer.create 5 in
 221       lbprint_tags b1 t.tags;
 222       String.iter (fun c -> Printf.bprintf b2 "(%d)" (int_of_char c)) t.left_bytes;
 223       lprintf_nl "Connect [hl: %d] [md4: %s] [ip: %s:%d] [server: %s] [left: %s] [tags:%s]"
 224         t.hash_len
 225         (Md4.to_string t.md4)
 226         (Ip.to_string t.ip) t.port
 227         (match t.server_info with
 228           None -> "None"
 229         | Some (ip, port) -> Printf.sprintf "%s:%d" (Ip.to_string ip) port)
 230         (if String.length t.left_bytes <> 0 then (Buffer.contents b2) else "None")
 231         (Buffer.contents b1)
 232
 233
 234     let write reply buf t =
 235       if not reply then
 236         buf_int8 buf 16;
 237
 238       buf_md4 buf t.md4;
 239       buf_ip buf t.ip;
 240       buf_port buf t.port;
 241       buf_tags buf t.tags names_of_tag;
 242       begin
 243         match t.server_info with
 244           None ->
 245             buf_ip buf Ip.null;
 246             buf_port buf 0
 247         | Some (ip, port) ->
 248             buf_ip buf ip;
 249             buf_port buf port;
 250       end
 251
 252   end
 253
 254 module Say = struct
 255     type t = string
 256
 257     let parse len s =
 258       let (s, p) = get_string s 1 in
 259       s
 260
 261     let print t =
 262       lprintf_nl "SAY %s" t
 263
 264     let write buf t =
 265       buf_string buf t
 266   end
 267
 268 module OneMd4 = functor(M: sig val m : string end) -> (struct
 269     type t = Md4.t
 270
 271     let parse len s =
 272       get_md4 s 1
 273
 274     let print t =
 275           lprintf_nl "OneMd4: %s OF %s" M.m (Md4.to_string t)
 276
 277     let write buf t =
 278       buf_md4 buf t
 279
 280   end)
 281
 282 module JoinQueue = struct
 283     type t = Md4.t option
 284
 285     let parse len s =
 286       if len >= 17 then
 287         Some (get_md4 s 1)
 288       else None
 289
 290     let print t =
 291       lprintf_nl "JOIN QUEUE %s"
 292       (match t with None -> "" | Some md4 ->
 293             Printf.sprintf "OF %s" (Md4.to_string md4))
 294
 295     let write emule buf t =
 296       if extendedrequest emule > 0 then
 297         match t with
 298           None -> ()
 299         | Some md4 ->
 300             buf_md4 buf md4
 301   end
 302     (*
 303       : sig
 304         type t
 305           val parse : int -> string  -> t
 306           val print : t -> unit
 307           val write : Buffer.t -> t  -> unit
 308           val t :t
 309           end
 310       )
 311 *)
 312
 313 (* In Emule, this message contains much more information, and will probably
 314 remove the need for QueryChunks. *)
 315
 316 let get_bitmap s pos =
 317   let nchunks = get_int16 s pos in
 318   let chunks, pos =
 319     if nchunks = 0 then (Bitv.create 0 false), pos+2 else
 320     let pos = pos + 2 in
 321     let chunks = (Bitv.create nchunks false) in
 322     for i = 0 to (nchunks-1) / 8 do
 323       let m = get_uint8 s (pos + i) in
 324       for j = 0 to 7 do
 325         let n = i * 8 + j in
 326         if n < nchunks then
 327           Bitv.set chunks n ((m land (1 lsl j)) <> 0);
 328       done;
 329     done;
 330     let pos = pos + (nchunks-1)/8 + 1 in
 331     chunks, pos
 332   in
 333   chunks, pos
 334
 335 let print_bitmap chunks =
 336   lprintf "\n%s\n" (Bitv.to_string chunks)
 337
 338 let write_bitmap buf chunks =
 339   let nchunks = Bitv.length chunks in
 340   buf_int16 buf nchunks;
 341   if nchunks > 0 then
 342   for i = 0 to (nchunks-1) / 8 do
 343     let m = ref 0 in
 344     for j = 0 to 7 do
 345       let n = i * 8 + j in
 346       if n < nchunks then
 347         if (Bitv.get chunks n) then
 348           m :=  !m lor (1 lsl j);
 349     done;
 350     buf_int8 buf !m
 351   done
 352
 353 module QueryFile  = struct
 354     type t = {
 355         md4 : Md4.t;
 356         emule_extension : (Bitv.t * int) option;
 357       }
 358
 359     let parse emule len s =
 360 (*      lprintf "Query File: emule version %d len %d"
 361       (extendedrequest emule) len;
 362       print_newline (); *)
 363       let md4 = get_md4 s 1 in
 364       let emule_extension =
 365         try
 366           if len < 18 || extendedrequest emule = 0 then None else
 367           let chunks, pos = get_bitmap s 17 in
 368           let ncompletesources =
 369             if extendedrequest emule > 1 && len > pos+1 then get_int16 s pos
 370             else -1 in
 371           Some (chunks, ncompletesources)
 372         with _ -> None
 373       in
 374       { md4 = md4;
 375         emule_extension = emule_extension }
 376
 377     let print t =
 378       lprintf_nl "QUERY FILE OF %s" (Md4.to_string t.md4);
 379       match t.emule_extension with
 380         None -> ()
 381       | Some (bitmap, ncompletesources) ->
 382           print_bitmap bitmap;
 383           lprint_newline ();
 384           if ncompletesources >= 0 then
 385             lprintf_nl "Complete sources: %d" ncompletesources
 386
 387     let write emule buf t =
 388       buf_md4 buf t.md4;
 389       match t.emule_extension with
 390         None -> ()
 391       | Some (chunks, ncompletesources) ->
 392           if extendedrequest emule > 0 then begin
 393               write_bitmap buf chunks;
 394               if extendedrequest emule > 1 && ncompletesources >= 0 then
 395                 buf_int16 buf ncompletesources
 396             end
 397   end
 398
 399 module QueryChunks  = OneMd4(struct let m = "QUERY CHUNKS" end)
 400   (* Request 79 *)
 401
 402 module QueryChunkMd4  = OneMd4(struct let m = "QUERY CHUNKS MD4" end)
 403 module EndOfDownload  = OneMd4(struct let m = "END OF DOWNLOAD MD4" end)
 404 module NoSuchFile  = OneMd4(struct let m = "NO SUCH FILE" end)
 405
 406 module QueryChunksReply = struct (* Request 80 *)
 407
 408     type t = {
 409         md4 : Md4.t;
 410         chunks: Bitv.t;
 411       }
 412
 413     let parse len s =
 414       let md4 = get_md4 s 1 in
 415       let chunks, pos = get_bitmap s 17 in
 416       {
 417         md4 = md4;
 418         chunks = chunks;
 419       }
 420
 421     let print t =
 422       lprintf_nl "CHUNKS for %s" (Md4.to_string t.md4);
 423       lprintf_nl "%s\n" (Bitv.to_string t.chunks)
 424
 425     let write buf t =
 426       buf_md4 buf t.md4;
 427       write_bitmap buf t.chunks;
 428       if Bitv.length t.chunks = 0 then buf_int8 buf 0
 429   end
 430 (*
 431 dec: [(96)(215)(1)(0)(0)(0)(0)(0)(0)(0)(0)(0)(0)]
 432
 433 OP_QUEUERANKING: int16
 434 *)
 435
 436 module QueryChunkMd4Reply = struct (* Request 80 *)
 437
 438     type t = {
 439         md4 : Md4.t;
 440         chunks: Md4.t array;
 441       }
 442
 443     let parse len s =
 444       let md4 = get_md4 s 1 in
 445       let nchunks = get_int16 s 17 in
 446 (*      lprintf "nchunks : %d" nchunks; lprint_newline (); *)
 447       let chunks = Array.make nchunks md4  in
 448       for i = 0 to nchunks - 1 do
 449         chunks.(i) <- get_md4 s (19 + i * 16)
 450       done;
 451       {
 452         md4 = md4;
 453         chunks = chunks;
 454       }
 455
 456     let print t =
 457       lprintf_nl "CHUNKSMd4 for %s" (Md4.to_string t.md4);
 458       lprint_string "   ";
 459       Array.iter (fun b ->
 460           lprintf "  %s" (Md4.to_string b))
 461       t.chunks;
 462       lprint_newline ()
 463
 464     let write buf t =
 465       buf_md4 buf t.md4;
 466       let nchunks = Array.length t.chunks in
 467       buf_int16 buf nchunks;
 468       for i = 0 to nchunks - 1 do
 469         buf_md4 buf t.chunks.(i)
 470       done
 471   end
 472
 473 module QueryFileReply  = struct
 474     type t = {
 475         md4 : Md4.t;
 476         name : string;
 477       }
 478
 479     let parse len s =
 480       let name, _ = get_string s 17 in
 481       { md4 = get_md4 s 1;
 482         name =  name;
 483       }
 484
 485     let print t =
 486       lprintf_nl "QUERY FILE REPLY OF %s : \"%s\"" (Md4.to_string t.md4) t.name
 487
 488     let write buf t =
 489       buf_md4 buf t.md4;
 490       buf_string buf t.name
 491   end
 492
 493 module Bloc  = struct
 494     type t = {
 495         md4 : Md4.t;
 496         usesixtyfour : bool;
 497         start_pos : int64;
 498         end_pos: int64;
 499         bloc_str: string;
 500         bloc_begin : int;
 501         bloc_len : int;
 502       }
 503
 504     let parse usesixtyfour len s =
 505       {
 506         md4 = get_md4 s 1;
 507         usesixtyfour = usesixtyfour;
 508         start_pos = if usesixtyfour then get_int64 s 17 else get_uint64_32 s 17;
 509         end_pos   = if usesixtyfour then get_int64 s 25 else get_uint64_32 s 21;
 510         bloc_str = s;
 511         bloc_begin = if usesixtyfour then 33 else 25;
 512         bloc_len = if usesixtyfour then len - 33 else len - 25;
 513       }
 514
 515     let print t =
 516       lprintf_nl "BLOC OF %s len %Ld [%Ld - %Ld] " (Md4.to_string t.md4)
 517       (t.end_pos -- t.start_pos)
 518       t.start_pos
 519         t.end_pos
 520
 521     let write buf t =
 522       buf_md4 buf t.md4;
 523       if t.usesixtyfour then buf_int64 buf t.start_pos else buf_int64_32 buf t.start_pos;
 524       if t.usesixtyfour then buf_int64 buf t.end_pos else buf_int64_32 buf t.end_pos;
 525       Buffer.add_substring buf t.bloc_str t.bloc_begin t.bloc_len
 526   end
 527
 528 module QueryBloc  = struct
 529     type t = {
 530         md4 : Md4.t;
 531         usesixtyfour : bool;
 532         start_pos1 : int64; (* 180 ko *)
 533         end_pos1: int64;
 534         start_pos2 : int64;
 535         end_pos2: int64;
 536         start_pos3 : int64;
 537         end_pos3: int64;
 538       }
 539
 540     let parse usesixtyfour len s =
 541       {
 542         md4 = get_md4 s 1;
 543         usesixtyfour = usesixtyfour;
 544         start_pos1 = if usesixtyfour then get_int64 s 17 else get_uint64_32 s 17;
 545         end_pos1   = if usesixtyfour then get_int64 s 41 else get_uint64_32 s 29;
 546         start_pos2 = if usesixtyfour then get_int64 s 25 else get_uint64_32 s 21;
 547         end_pos2   = if usesixtyfour then get_int64 s 49 else get_uint64_32 s 33;
 548         start_pos3 = if usesixtyfour then get_int64 s 33 else get_uint64_32 s 25;
 549         end_pos3   = if usesixtyfour then get_int64 s 57 else get_uint64_32 s 37;
 550       }
 551
 552     let print t =
 553       lprintf_nl "QUERY BLOCS OF %s [%s - %s] [%s - %s] [%s - %s]"
 554       (Md4.to_string t.md4)
 555       (Int64.to_string t.start_pos1) (Int64.to_string t.end_pos1)
 556       (Int64.to_string t.start_pos2) (Int64.to_string t.end_pos2)
 557       (Int64.to_string t.start_pos3) (Int64.to_string t.end_pos3)
 558
 559     let write buf t =
 560       buf_md4 buf t.md4;
 561       if t.usesixtyfour then buf_int64 buf t.start_pos1 else buf_int64_32 buf t.start_pos1;
 562       if t.usesixtyfour then buf_int64 buf t.start_pos2 else buf_int64_32 buf t.start_pos2;
 563       if t.usesixtyfour then buf_int64 buf t.start_pos3 else buf_int64_32 buf t.start_pos3;
 564       if t.usesixtyfour then buf_int64 buf t.end_pos1 else buf_int64_32 buf t.end_pos1;
 565       if t.usesixtyfour then buf_int64 buf t.end_pos2 else buf_int64_32 buf t.end_pos2;
 566       if t.usesixtyfour then buf_int64 buf t.end_pos3 else buf_int64_32 buf t.end_pos3
 567   end
 568
 569 let unit = ()
 570 module NoArg = functor(M: sig val m : string end) -> (struct
 571         type t = unit
 572
 573         let parse len s = ()
 574
 575         let print t =
 576           lprintf_nl "%s:" M.m
 577
 578         let write (buf: Buffer.t) (t: t) = unit
 579
 580         let t = (() : t)
 581       end : sig
 582         type t
 583           val parse : int -> string  -> t
 584           val print : t -> unit
 585           val write : Buffer.t -> t  -> unit
 586           val t :t
 587           end
 588       )
 589
 590 module AvailableSlot = NoArg(struct let m = "AvailableSlot" end)
 591 module ReleaseSlot = NoArg(struct let m = "ReleaseSlot" end)
 592 module OutOfParts = NoArg(struct let m = "OutOfParts" end)
 593 module ViewFiles = NoArg(struct let m = "VIEW FILES" end)
 594 module ViewDirs = NoArg(struct let m = "VIEW DIRS" end)
 595
 596 module ViewFilesReply = struct
 597
 598     type file = {
 599         md4: Md4.t;
 600         ip: Ip.t;
 601         port: int;
 602         tags:  tag list;
 603       }
 604
 605     type t = tagged_file list
 606
 607     let names_of_tag = file_common_tags
 608
 609     let rec get_files  s pos n =
 610       if n = 0 then [], pos else
 611       let md4 = get_md4 s pos in
 612       let ip = get_ip s (pos + 16) in
 613       let port = get_port s (pos + 20) in
 614       let tags, pos = get_tags s (pos+22) names_of_tag in
 615       let file = {
 616           f_md4 = md4;
 617           f_ip = ip;
 618           f_port = port;
 619           f_tags = tags;
 620         } in
 621       let files, pos =  get_files s pos (n-1) in
 622       file :: files, pos
 623
 624     let parse len s =
 625       let n = get_int s 1 in
 626       let files, pos = get_files s 5 n in
 627       files
 628
 629     let print t =
 630       lprintf_nl "VIEW FILES REPLY:";
 631       List.iter (fun t ->
 632           lprintf_nl "FILE:";
 633           lprintf_nl "  MD4: %s" (Md4.to_string t.f_md4);
 634           lprintf_nl "  ip: %s" (Ip.to_string t.f_ip);
 635           lprintf_nl "  port: %d" t.f_port;
 636           lprintf "  tags: ";
 637           print_tags t.f_tags;
 638           lprint_newline ();) t
 639
 640     let rec write_files buf files =
 641       match files with
 642         [] -> ()
 643       | file :: files ->
 644           buf_md4 buf file.f_md4;
 645           buf_ip buf file.f_ip;
 646           buf_port buf file.f_port;
 647           buf_tags buf file.f_tags names_of_tag;
 648           write_files buf files
 649
 650     let write buf t =
 651       buf_int buf (List.length t);
 652       write_files buf t
 653
 654     let rec write_files_max buf files nfiles max_len =
 655       let prev_len = Buffer.length buf in
 656       match files with
 657         [] -> nfiles, prev_len
 658       | file :: files ->
 659           buf_md4 buf file.f_md4;
 660           buf_ip buf file.f_ip;
 661           buf_port buf file.f_port;
 662           buf_tags buf file.f_tags names_of_tag;
 663           if Buffer.length buf < max_len then
 664             write_files_max buf files (nfiles+1) max_len
 665           else
 666             nfiles, prev_len
 667   end
 668
 669 module ViewDirsReply = struct
 670
 671     type t = string list
 672
 673     let rec get_dirs s pos n =
 674       if n = 0 then [], pos else
 675       let dir, pos = get_string16 s pos in
 676       let dirs, pos = get_dirs s pos (n-1) in
 677       dir :: dirs, pos
 678
 679     let parse len s =
 680       let dirs, pos = get_dirs s 2 (get_int16 s 0) in
 681       dirs
 682
 683     let print t =
 684       lprintf_nl "VIEW DIRS REPLY:";
 685       List.iter (fun dir ->
 686           lprintf_nl "DIR: %s" dir;) t
 687
 688     let write buf t =
 689       buf_int buf (List.length t);
 690       List.iter (fun dir ->
 691         buf_string buf dir;) t
 692
 693   end
 694
 695 module ViewFilesDir = struct
 696
 697     type t = string
 698
 699     let print t =
 700       lprintf_nl "VIEW FILES DIR: %s" t
 701
 702     let parse len s =
 703       let dir, pos = get_string s 1 in
 704       dir
 705
 706     let write buf t =
 707       buf_string buf t
 708
 709   end
 710
 711 module ViewFilesDirReply = struct
 712
 713     type t = string * tagged_file list
 714
 715     let names_of_tag = file_common_tags
 716
 717     let parse len s =
 718       let dir, pos = get_string s 1 in
 719       let n = get_int s (pos+1) in
 720       let files, pos = ViewFilesReply.get_files s (pos+5) n in
 721       dir, files
 722
 723     let print t =
 724       lprintf_nl "VIEW FILES DIR REPLY:";
 725       let dir, files = t in begin
 726         lprintf_nl "DIR: %s" dir;
 727         List.iter (fun file ->
 728             lprintf_nl "FILE:";
 729             lprintf_nl "  MD4: %s" (Md4.to_string file.f_md4);
 730             lprintf_nl "  ip: %s" (Ip.to_string file.f_ip);
 731             lprintf_nl "  port: %d" file.f_port;
 732             lprintf "  tags: ";
 733             print_tags file.f_tags;
 734             lprint_newline ();) files
 735       end
 736
 737     let write buf t =
 738       let dir, files = t in begin
 739         buf_string buf dir;
 740         buf_int buf (List.length files);
 741         ViewFilesReply.write_files buf files
 742       end
 743
 744   end
 745
 746 module OtherLocations = struct
 747
 748     type t = Ip.t list
 749
 750     let parse len s =
 751       let list = ref [] in
 752       for i = 0 to len / 4 - 1 do
 753         list := (get_ip s (i*4+1)) :: !list;
 754       done;
 755       !list
 756
 757     let print t =
 758       lprintf_nl "OTHER LOCATIONS:\n";
 759       List.iter (fun ip ->
 760           lprintf_nl "  ip: %s" (Ip.to_string ip);) t
 761
 762     let write buf t =
 763       List.iter (buf_ip buf) t
 764   end
 765
 766 module NewUserID = struct
 767
 768     type t = Ip.t * Ip.t
 769
 770     let parse len s =
 771       get_ip s 1, get_ip s 5
 772
 773     let print (ip1,ip2) =
 774       lprintf_nl "NEW USER ID: %s -> %s" (Ip.to_string ip1)
 775       (Ip.to_string ip2)
 776
 777     let write buf (ip1,ip2) =
 778       buf_ip buf ip1;
 779       buf_ip buf ip2
 780   end
 781
 782
 783 module Sources = struct
 784
 785     type t = {
 786         md4: Md4.t;
 787         sources : (Ip.t * int * Ip.t) list;
 788       }
 789
 790     let parse len s =
 791       let len = get_int16 s 1 in
 792       let md4 = get_md4 s 3 in
 793       let list = ref [] in
 794 (*      let pos = 19 in *)
 795       for i = 0 to len - 1 do
 796         list := (get_ip s (19 + 10 * i), get_port s (23 + 10 * i),
 797           get_ip  s (25 + 10 * i)) :: !list;
 798       done;
 799       { md4 = md4;
 800         sources = !list;
 801       }
 802
 803     let print t =
 804       lprintf_nl "SOURCES for %s:" (Md4.to_string t.md4);
 805       List.iter (fun (ip1, port, ip2) ->
 806           lprintf_nl "  %s:%d:%s" (Ip.to_string ip1) port(Ip.to_string ip2)) t.sources
 807
 808     let write buf t =
 809       buf_int16 buf (List.length t.sources);
 810       buf_md4 buf t.md4;
 811       List.iter (fun (ip1, port, ip2) ->
 812           buf_ip buf ip1;
 813           buf_port buf port;
 814           buf_ip buf ip2) t.sources
 815   end
 816
 817 module EmuleClientInfo = struct
 818
 819     type t = {
 820         version : int; (* CURRENT_VERSION_SHORT = !!emule_protocol_version *)
 821         protversion : int; (* EMULE_PROTOCOL_VERSION = 0x1 *)
 822         mutable tags : tag list;
 823       }
 824
 825     let names_of_tag = client_common_tags
 826
 827     let names_of_tag =
 828       List.map (fun (v, name) -> (v, Field_KNOWN name)) names_of_tag
 829
 830     let parse len s =
 831       let version = get_uint8 s 1 in
 832       let protversion = get_uint8 s 2 in
 833       let tags,_ = get_tags s 3 names_of_tag in
 834       {
 835         version = version;
 836         protversion = protversion;
 837         tags = tags;
 838       }
 839
 840     let print m t =
 841       let b1 = Buffer.create 50 in
 842       lbprint_tags b1 t.tags;
 843       lprintf_nl "%s: [version: %d] [protversion: %d] [tags:%s]" m t.version t.protversion (Buffer.contents b1)
 844
 845     let write buf t =
 846       buf_int8 buf t.version;
 847       buf_int8 buf t.protversion;
 848       buf_tags buf t.tags names_of_tag;
 849
 850   end
 851
 852 module EmuleQueueRanking = struct
 853
 854     type t = int
 855
 856     let parse len s = get_int16 s 1
 857     let print t =
 858       lprintf_nl "EmuleQueueRanking: %d" t
 859
 860     let string_null10 = String.make 10 (char_of_int 0)
 861
 862     let write buf t =
 863       buf_int16 buf t;
 864       Buffer.add_string buf string_null10
 865
 866   end
 867
 868 module QueueRank = struct
 869
 870     type t = int
 871
 872     let parse len s = get_int s 1
 873     let print t =
 874       lprintf_nl "QueueRank: %d" t
 875
 876     let write buf t =
 877       buf_int buf t
 878
 879   end
 880
 881 module EmuleRequestSources = struct
 882
 883     type t =  Md4.t
 884
 885     let parse len s =
 886       get_md4 s 1
 887
 888     let print t =
 889       lprintf_nl "EmuleRequestSources: %s" (Md4.to_string t)
 890
 891     let write buf t =
 892       buf_md4 buf t
 893
 894   end
 895
 896
 897 let buf_estring buf s =
 898   let len = String.length s in
 899   buf_int8 buf len;
 900   Buffer.add_string buf s
 901
 902 module EmuleSignatureReq = struct
 903
 904     type t = {
 905         signature : string;
 906         ip_type : int;
 907       }
 908
 909     let print t =
 910       lprintf_nl "EmuleSignatureReq [type %d] [sig(%d): %s]" t.ip_type (String.length t.signature) (String.escaped t.signature)
 911
 912     let parse len s =
 913       let mlen = get_uint8 s 1 in
 914       let slen = String.length s in
 915       let signature = String.sub s 2 mlen in
 916       let ip_type = if mlen = (slen-2) then 0 else get_uint8 s (2 + mlen) in
 917       {
 918         signature = signature;
 919         ip_type = ip_type;
 920       }
 921
 922     let write buf t =
 923       buf_estring buf t.signature;
 924       if (t.ip_type <> 0) then
 925            buf_int8 buf t.ip_type;
 926
 927   end
 928
 929
 930 module EmulePublicKeyReq = struct
 931
 932     type t = string
 933
 934     let print t =
 935       lprintf_nl "EmulePublicKeyReq [key(%d): %s]" (String.length t) (String.escaped t)
 936
 937     let parse len s =
 938       let len = get_uint8 s 1 in
 939       String.sub s 2 len
 940
 941     let write buf t =
 942       buf_estring buf t
 943
 944   end
 945
 946
 947 module EmuleCaptchaReq = struct
 948
 949     type t = string
 950
 951     let print t =
 952       lprintf_nl "EmuleCaptchaReq [CAPTCHA BMP length=%d bytedata=%s]" (String.length t) (String.escaped t)
 953
 954     let parse len s =
 955       String.sub s 2 (len - 2)
 956
 957     let write buf t =
 958       buf_estring buf t
 959
 960   end
 961
 962
 963 module EmuleCaptchaRes = struct
 964
 965     type t = int
 966
 967     let print t =
 968       lprintf_nl "EmuleCaptchaRes RESPONSE=%d" t
 969
 970     let parse s =
 971       get_uint8 s 1
 972
 973     let write buf t =
 974       buf_int8 buf t
 975
 976   end
 977
 978
 979 module EmuleSecIdentStateReq = struct
 980
 981     type t = {
 982         state : int;
 983         challenge : int64;
 984       }
 985
 986     let print t =
 987       lprintf_nl "EmuleSecIdentStateReq [state: %d] [challenge: %Ld]" t.state t.challenge
 988
 989     let parse len s =
 990       let state = get_uint8 s 1 in
 991       let challenge = get_uint64_32 s 2 in
 992       {
 993         state = state;
 994         challenge = challenge;
 995       }
 996
 997     let write buf t =
 998       buf_int8 buf t.state;
 999       buf_int64_32 buf t.challenge
1000
1001   end
1002
1003 module EmuleRequestSourcesReply = struct
1004
1005     type source = {
1006         src_ip : Ip.t;
1007         src_port : int;
1008         mutable src_server_ip : Ip.t;
1009         mutable src_server_port : int;
1010         mutable src_md4 : Md4.t;
1011         mutable src_cc : int option;
1012       }
1013
1014     type t = {
1015         md4 : Md4.t;
1016         sources : source array;
1017       }
1018
1019     let dummy_source = {
1020         src_ip = Ip.null;
1021         src_port = 0;
1022         src_server_ip = Ip.null;
1023         src_server_port = 0;
1024         src_md4 = Md4.null;
1025         src_cc = None;
1026       }
1027
1028     let parse e len s =
1029       let md4 = get_md4 s 1 in
1030       let ncount = get_int16 s 17 in
1031
1032       let sources =
1033         if ncount = 0 then [||] else
1034         let slen = (len - 19) / ncount in
1035 (*        lprintf "PER SOURCES LEN: %d\n" slen; *)
1036         let sources = Array.make ncount dummy_source in
1037         let rec iter pos i =
1038           if i < ncount then
1039             let ss =
1040               let ip = get_ip s pos in
1041               {
1042                 dummy_source with
1043                 src_ip = ip;
1044                 src_port = get_int16 s (pos+4);
1045                 src_cc = Geoip.get_country_code_option ip
1046               } in
1047             let pos =
1048               if slen > 6 then begin
1049                   ss.src_server_ip <- get_ip s (pos+6);
1050                   ss.src_server_port <- get_int16 s (pos+10);
1051                   if slen > 12 && (sourceexchange e > 1) then begin
1052                       ss.src_md4 <- get_md4 s (pos+12);
1053                       pos + 28
1054                     end else
1055                     pos + 12
1056                 end
1057               else pos + 6
1058             in
1059             sources.(i) <- ss;
1060             iter pos (i+1)
1061         in
1062         iter 19 0;
1063         sources
1064       in
1065       {
1066         md4 = md4;
1067         sources = sources;
1068       }
1069
1070     let print t =
1071       let ncount = Array.length t.sources in
1072       lprintf_nl "EMULE SOURCES REPLY: %d sources for %s"
1073         ncount (Md4.to_string t.md4);
1074        for i = 0 to ncount - 1 do
1075         let s = t.sources.(i) in
1076           lprintf_nl "%s %s"
1077           (if Ip.valid s.src_ip then
1078               Printf.sprintf "%s:%d" (Ip.to_string s.src_ip) s.src_port
1079           else
1080               Printf.sprintf  "%s:%d (Indirect)" (Ip.to_string s.src_server_ip) s.src_server_port)
1081           (if s.src_md4 != Md4.null then
1082               Printf.sprintf "MD4: %s" (Md4.to_string s.src_md4)
1083           else "")
1084       done
1085
1086     let write e buf t =
1087       buf_md4 buf t.md4;
1088       let ncount = Array.length t.sources in
1089       buf_int16 buf ncount;
1090
1091       for i = 0 to ncount - 1 do
1092         let s = t.sources.(i) in
1093           buf_ip buf s.src_ip;
1094           buf_port buf s.src_port;
1095           if sourceexchange e > 0 then begin
1096               buf_ip buf s.src_server_ip;
1097               buf_port buf s.src_server_port;
1098               if sourceexchange e > 1 then
1099                 buf_md4 buf s.src_md4
1100             end
1101       done
1102
1103   end
1104 module EmuleFileDesc = struct
1105
1106     type t = {
1107         rating : int;
1108         comment : string;
1109       }
1110
1111     let parse len s =
1112       let rating = get_uint8 s 1 in
1113       let (comment, _) = get_string32 s 2 in
1114       {
1115         rating = rating;
1116         comment = comment;
1117       }
1118
1119     let print t =
1120       lprintf_nl "EmuleFileDesc [%d][%s]" t.rating t.comment
1121
1122     let write buf t =
1123       buf_int8 buf t.rating;
1124       buf_string buf t.comment
1125   end
1126
1127 module EmuleCompressedPart = struct
1128
1129     type t = {
1130         md4 : Md4.t;
1131         usesixtyfour : bool;
1132         statpos : int64;
1133         newsize : int64;
1134         bloc : string;
1135       }
1136
1137     let parse usesixtyfour len s =
1138       {
1139         md4 = get_md4 s 1;
1140         usesixtyfour = usesixtyfour;
1141         statpos = if usesixtyfour then get_int64 s 17 else get_uint64_32 s 17;
1142         newsize = if usesixtyfour then get_uint64_32 s 25 else get_uint64_32 s 21;
1143         bloc = if usesixtyfour then String.sub s 29 (len-29) else String.sub s 25 (len-25)
1144       }
1145
1146     let print t =
1147       lprintf_nl "EmuleCompressedPart for %s %Ld %Ld len %d"
1148         (Md4.to_string t.md4) t.statpos t.newsize (String.length t.bloc)
1149
1150     let write buf t =
1151       buf_md4 buf t.md4;
1152       if t.usesixtyfour then buf_int64 buf t.statpos else buf_int64_32 buf t.statpos;
1153       buf_int64_32 buf t.newsize;
1154       Buffer.add_string buf t.bloc
1155   end
1156
1157 module EmulePortTestReq = struct
1158
1159     type t = string
1160
1161     let print s =
1162       lprintf_nl "Emule porttest request %s" (String.escaped s)
1163
1164     let parse s = s
1165
1166     let write buf =
1167       buf_int8 buf 0x12
1168
1169   end
1170
1171 type t =
1172 | ConnectReq of Connect.t
1173 | ConnectReplyReq of Connect.t
1174 | QueryFileReq of QueryFile.t
1175 | QueryFileReplyReq of QueryFileReply.t
1176 | BlocReq of Bloc.t
1177 | QueryBlocReq of QueryBloc.t
1178 | JoinQueueReq of JoinQueue.t (* sent before queryBloc *)
1179 | AvailableSlotReq of AvailableSlot.t
1180 | ReleaseSlotReq of ReleaseSlot.t
1181 | OutOfPartsReq of OutOfParts.t
1182 | QueryChunksReq of QueryChunks.t
1183 | QueryChunksReplyReq of QueryChunksReply.t
1184 | QueryChunkMd4Req of QueryChunkMd4.t
1185 | QueryChunkMd4ReplyReq of QueryChunkMd4Reply.t
1186 | ViewFilesReq of ViewFiles.t
1187 | ViewFilesReplyReq of ViewFilesReply.t
1188 | ViewDirsReq of ViewDirs.t
1189 | ViewDirsReplyReq of ViewDirsReply.t
1190 | ViewFilesDirReq of ViewFilesDir.t
1191 | ViewFilesDirReplyReq of ViewFilesDirReply.t
1192 | QueueReq of OtherLocations.t
1193 | UnknownReq of int * string
1194 | OtherLocationsReq of OtherLocations.t
1195 | SayReq of Say.t
1196 | SourcesReq of Sources.t
1197 | EndOfDownloadReq of EndOfDownload.t
1198 | NewUserIDReq of NewUserID.t
1199 | NoSuchFileReq of NoSuchFile.t
1200 | QueueRankReq of QueueRank.t
1201
1202 | EmuleClientInfoReq of EmuleClientInfo.t
1203 | EmuleClientInfoReplyReq of EmuleClientInfo.t
1204 | EmuleQueueRankingReq of EmuleQueueRanking.t
1205 | EmuleRequestSourcesReq of EmuleRequestSources.t
1206 | EmuleRequestSourcesReplyReq of EmuleRequestSourcesReply.t
1207 | EmuleFileDescReq of EmuleFileDesc.t
1208 | EmulePublicKeyReq of EmulePublicKeyReq.t
1209 | EmuleSignatureReq of EmuleSignatureReq.t
1210 | EmuleSecIdentStateReq  of EmuleSecIdentStateReq.t
1211 | EmuleMultiPacketReq of Md4.t * t list
1212 | EmuleMultiPacketAnswerReq of Md4.t * t list
1213 | EmuleCompressedPart of EmuleCompressedPart.t
1214 | EmulePortTestReq of EmulePortTestReq.t
1215 | EmuleCaptchaReq of EmuleCaptchaReq.t
1216 | EmuleCaptchaRes of EmuleCaptchaRes.t
1217
1218 let rec print t =
1219   begin
1220     match t with
1221     | ConnectReq t -> Connect.print t
1222     | ConnectReplyReq t -> Connect.print t
1223     | QueryFileReq t -> QueryFile.print t
1224     | QueryFileReplyReq t -> QueryFileReply.print t
1225     | BlocReq t -> Bloc.print t
1226     | QueryBlocReq t -> QueryBloc.print t
1227     | JoinQueueReq t -> JoinQueue.print t
1228     | AvailableSlotReq t -> AvailableSlot.print t
1229     | ReleaseSlotReq t -> ReleaseSlot.print t
1230     | OutOfPartsReq t -> OutOfParts.print t
1231     | QueryChunksReq t -> QueryChunks.print t
1232     | QueryChunksReplyReq t -> QueryChunksReply.print t
1233     | QueryChunkMd4Req t -> QueryChunkMd4.print t
1234     | QueryChunkMd4ReplyReq t -> QueryChunkMd4Reply.print t
1235     | ViewFilesReplyReq t -> ViewFilesReply.print t
1236     | ViewFilesReq t -> ViewFiles.print t
1237     | ViewDirsReq t -> ViewDirs.print t
1238     | ViewDirsReplyReq t -> ViewDirsReply.print t
1239     | ViewFilesDirReq t -> ViewFilesDir.print t
1240     | ViewFilesDirReplyReq t -> ViewFilesDirReply.print t
1241     | QueueReq t -> OtherLocations.print t
1242     | OtherLocationsReq t  -> OtherLocations.print t
1243     | SayReq t -> Say.print t
1244     | SourcesReq t -> Sources.print t
1245     | EndOfDownloadReq t -> EndOfDownload.print t
1246     | NewUserIDReq t -> NewUserID.print t
1247     | NoSuchFileReq t -> NoSuchFile.print t
1248     | QueueRankReq t ->
1249         QueueRank.print t
1250
1251     | EmuleClientInfoReq t ->
1252         EmuleClientInfo.print "EmuleClientInfo"  t
1253     | EmuleClientInfoReplyReq t ->
1254         EmuleClientInfo.print "EmuleClientInfoReply" t
1255     | EmuleQueueRankingReq t ->
1256         EmuleQueueRanking.print t
1257     | EmuleRequestSourcesReq t ->
1258         EmuleRequestSources.print  t
1259     | EmuleRequestSourcesReplyReq t ->
1260         EmuleRequestSourcesReply.print t
1261
1262     | EmuleFileDescReq t ->
1263         EmuleFileDesc.print t
1264
1265     | EmuleMultiPacketReq (md4, list) ->
1266         lprintf_nl "EmuleMultiPacket for %s:" (Md4.to_string md4);
1267         List.iter (fun t ->
1268             lprintf "  ";
1269             print t
1270         ) list
1271
1272     | EmuleMultiPacketAnswerReq (md4, list) ->
1273         lprintf_nl "EmuleMultiPacketAnswer for %s:" (Md4.to_string md4);
1274         List.iter (fun t ->
1275             lprintf "  ";
1276             print t
1277         ) list
1278     | EmuleSecIdentStateReq t ->
1279         EmuleSecIdentStateReq.print t
1280     | EmuleSignatureReq t ->
1281         EmuleSignatureReq.print t
1282     | EmulePublicKeyReq t ->
1283         EmulePublicKeyReq.print t
1284     | EmuleCompressedPart t ->
1285         EmuleCompressedPart.print t
1286     | EmulePortTestReq t ->
1287         EmulePortTestReq.print t
1288     | EmuleCaptchaReq t ->
1289         EmuleCaptchaReq.print t
1290     | EmuleCaptchaRes t ->
1291         EmuleCaptchaRes.print t
1292     | UnknownReq (opcode, s) ->
1293         let len = String.length s in
1294         lprintf_nl "UnknownReq: magic (%d), opcode (%d) len (%d)" opcode
1295         (int_of_char s.[0])
1296         (String.length s);
1297         lprintf "ascii: [";
1298         for i = 0 to len - 1 do
1299           let c = s.[i] in
1300           let n = int_of_char c in
1301           if n > 31 && n < 127 then
1302             lprintf " %c" c
1303           else
1304             lprintf "(%d)" n
1305         done;
1306         lprintf "]\n";
1307         lprintf "dec: [";
1308         for i = 0 to len - 1 do
1309           let c = s.[i] in
1310           let n = int_of_char c in
1311           lprintf "(%d)" n
1312         done;
1313         lprintf "]\n"
1314   end
1315
1316 let rec parse_emule_packet emule opcode len s =
1317 (*
1318   lprintf "Emule magic: %d opcode %d:" magic opcode; lprint_newline ();
1319           dump s; lprint_newline ();
1320   *)
1321   let t = match opcode with
1322     | 1 -> EmuleClientInfoReq (EmuleClientInfo.parse len s)
1323     | 2 -> EmuleClientInfoReplyReq (EmuleClientInfo.parse len s)
1324
1325     | 0x60 (* 96 *) -> EmuleQueueRankingReq (EmuleQueueRanking.parse len s)
1326
1327     | 0x61 (* 97 *) -> EmuleFileDescReq (EmuleFileDesc.parse len s)
1328
1329     | 0x81 (* 129 *) -> EmuleRequestSourcesReq (EmuleRequestSources.parse len s)
1330     | 0x82 (* 130 *) ->
1331         EmuleRequestSourcesReplyReq (
1332           EmuleRequestSourcesReply.parse emule len s)
1333
1334     | 0x40 (* 64 *) ->
1335 (* OP_COMPRESSEDPART *)
1336         EmuleCompressedPart (EmuleCompressedPart.parse false len s)
1337
1338     | 0x85 (* 133 *) ->
1339         EmulePublicKeyReq(EmulePublicKeyReq.parse len s)
1340
1341     | 0x86 (* 134 *) ->
1342         EmuleSignatureReq(EmuleSignatureReq.parse len s)
1343
1344     | 0x87 (* 135 *) ->
1345         EmuleSecIdentStateReq (EmuleSecIdentStateReq.parse len s)
1346
1347 (*     | 0x90 (* 144 *) -> RequestPreview *)
1348 (*    | 0x91 (* 145 *) -> PreviewAnswer *)
1349     | 0x92 (* 146 *) ->
1350         let md4 = get_md4 s 1 in
1351
1352 (*        lprintf "MULTI EMULE VERSION %d"
1353           (extendedrequest emule); print_newline (); *)
1354 (*        let pos = 17 in *)
1355         let rec iter pos =
1356           if pos < len then
1357             let opcode = get_uint8 s pos in
1358             match opcode with
1359               0x58 (* 88 *) ->
1360                 let bitmap, pos = get_bitmap s (pos+1) in
1361                 let ncompletesources, pos =
1362                   if extendedrequest emule > 1 then
1363                     get_int16 s pos, pos+2
1364                   else -1, pos
1365                 in
1366                 (QueryFileReq {
1367                     QueryFile.md4 = md4;
1368                     QueryFile.emule_extension = Some (bitmap, ncompletesources);
1369                   }) :: (iter pos)
1370             | 0x4F (* 79 *) ->
1371                 (QueryChunksReq md4) :: iter (pos+1)
1372             | 0x81 (* 129 *) ->
1373                 (EmuleRequestSourcesReq md4) :: iter (pos+1)
1374             | _ ->
1375                 lprintf_nl "Unknown short emule packet %d" opcode;
1376                 raise Not_found
1377           else
1378             []
1379         in
1380         EmuleMultiPacketReq (md4, iter 17)
1381
1382     | 0x93 (* 147 *) ->
1383         if String.length s < 16 then begin
1384           if !verbose_unknown_messages then lprintf_nl "EmuleMultiPacketAnswer: incomplete request";
1385           raise Not_found
1386         end;
1387         let md4 = get_md4 s 1 in
1388
1389 (*        lprintf "MULTI EMULE VERSION %d"
1390           (extendedrequest emule); print_newline (); *)
1391         let rec iter s pos len =
1392           if pos < len then
1393             let opcode = get_uint8 s pos in
1394             match opcode with
1395             | 89 ->
1396                 let module Q = QueryFileReply in
1397                 let name, pos = get_string s (pos+1) in
1398                 let q = {
1399                     Q.md4 = md4;
1400                     Q.name =  name;
1401                   } in
1402                 (QueryFileReplyReq q) :: (iter s pos len)
1403             | 80 ->
1404                 let module Q = QueryChunksReply in
1405                 let chunks, pos = get_bitmap s (pos+1) in
1406                 let q = {
1407                     Q.md4 = md4;
1408                     Q.chunks = chunks;
1409                   } in
1410                 (QueryChunksReplyReq q) :: (iter s pos len)
1411             | _ ->
1412                 lprintf_nl "Unknown packet in emule multipacket 0x93: %d" opcode;
1413                 raise Not_found
1414           else
1415             []
1416         in
1417         EmuleMultiPacketAnswerReq (md4, iter s 17 len)
1418
1419     | 0xa1 (* 161 *) -> (* OP_COMPRESSEDPART_I64 *)
1420         EmuleCompressedPart (EmuleCompressedPart.parse true len s)
1421     | 0xa2 -> BlocReq (Bloc.parse true len s) (* OP_SENDINGPART_I64 *)
1422     | 0xa3 -> QueryBlocReq (QueryBloc.parse true len s) (*OP_REQUESTPARTS_I64 *)
1423     | 0xa5 (* 165 *) -> EmuleCaptchaReq (EmuleCaptchaReq.parse len s) (* OP_CHATCAPTCHAREQ *)
1424     | 0xa6 (* 166 *) -> EmuleCaptchaRes (EmuleCaptchaRes.parse s) (* OP_CHATCAPTCHARES *)
1425     | 0xfe (* 254 *) -> EmulePortTestReq s
1426
1427     | code ->
1428         if !CommonOptions.verbose_unknown_messages then
1429           lprintf_nl "EDK: unknown eMule message %d" code;
1430         raise Not_found
1431   in
1432 (*
1433           lprintf "EMULE MESSAGE: "; lprint_newline ();
1434           print t;
1435           lprint_newline (); *)
1436   t
1437
1438 and parse emule_version magic s =
1439   try
1440     let len = String.length s in
1441     if len = 0 then raise Not_found;
1442     let opcode = int_of_char (s.[0]) in
1443 (*lprintf "opcode: %d" opcode; lprint_newline (); *)
1444     match magic with
1445       227 ->
1446         begin
1447           match opcode with
1448           | 1 -> ConnectReq (Connect.parse false len s)
1449           | 70 -> BlocReq (Bloc.parse false len s)
1450           | 71 -> QueryBlocReq (QueryBloc.parse false len s)
1451           | 72 -> NoSuchFileReq (NoSuchFile.parse len s)
1452           | 73 -> EndOfDownloadReq (EndOfDownload.parse len s)
1453           | 74 -> ViewFilesReq (ViewFiles.parse len s)
1454           | 75 -> ViewFilesReplyReq (ViewFilesReply.parse len s)
1455           | 76 -> ConnectReplyReq (Connect.parse true len s)
1456           | 77 -> NewUserIDReq (NewUserID.parse len s)
1457           | 78 -> SayReq (Say.parse len s)
1458           | 79 -> QueryChunksReq (QueryChunks.parse len s)
1459           | 80 -> QueryChunksReplyReq (QueryChunksReply.parse len s)
1460           | 81 -> QueryChunkMd4Req (QueryChunkMd4.parse len s)
1461           | 82 -> QueryChunkMd4ReplyReq (QueryChunkMd4Reply.parse len s)
1462 (* JoinQueue: the sender wants to join the upload queue *)
1463           | 84 -> JoinQueueReq (JoinQueue.parse len s)
1464 (* AvailableSlot: there is an available slot in upload queue *)
1465           | 85 -> AvailableSlotReq (AvailableSlot.parse len s)
1466 (* ReleaseSlot: the upload is finished *)
1467           | 86 -> ReleaseSlotReq (ReleaseSlot.parse len s)
1468 (* OutOfParts: the upload slot is not available *)
1469           | 87 -> OutOfPartsReq (OutOfParts.parse len s)
1470           | 88 -> QueryFileReq (QueryFile.parse emule_version len s)
1471           | 89 -> QueryFileReplyReq (QueryFileReply.parse len s)
1472           | 92 -> QueueRankReq (QueueRank.parse len s)
1473           | 93 -> ViewDirsReq (ViewDirs.parse len s)
1474           | 94 -> ViewFilesDirReq (ViewFilesDir.parse len s)
1475           (*
1476           | 95 -> ViewDirsReplyReq (ViewDirsReply.parse len s)
1477           | 96 -> ViewFilesDirReplyReq (ViewFilesDirReply.parse len s)
1478           *)
1479           | 250 -> SourcesReq (Sources.parse len s)
1480
1481           | _ -> raise Not_found
1482         end
1483
1484     | 0xc5  -> (* 197: emule extended protocol *)
1485         parse_emule_packet emule_version opcode len s
1486
1487 (* Compressed packet, probably sent by cDonkey ? *)
1488
1489     | 0xD4 -> (* 212 *)
1490
1491           let s = Zlib2.uncompress_string2 (String.sub s 1 (len-1)) in
1492           let s = Printf.sprintf "%c%s" (char_of_int opcode) s in
1493     begin try
1494             parse_emule_packet emule_version opcode (String.length s) s
1495           with
1496           | e ->
1497               if !CommonOptions.verbose_unknown_messages then begin
1498                   lprintf_nl "Unknown message From client: %s (magic %d)"
1499                     (Printexc2.to_string e) magic;
1500                   let tmp_file = Filename2.temp_file "comp" "pak" in
1501                   File.from_string tmp_file s;
1502                   lprintf_nl "Saved unknown packet %s" tmp_file;
1503                   dump s;
1504                   lprint_newline ();
1505                 end;
1506               UnknownReq (magic,s)
1507     end
1508
1509     | _ ->
1510         if !CommonOptions.verbose_unknown_messages then
1511             lprintf_nl "Strange magic: %d" magic;
1512         raise Not_found
1513   with
1514   | e ->
1515       if !CommonOptions.verbose_unknown_messages then begin
1516           lprintf_nl "Unknown message From client: %s (magic %d)"
1517               (Printexc2.to_string e) magic;
1518                let tmp_file = Filename2.temp_file "comp" "pak" in
1519        File.from_string tmp_file s;
1520        lprintf_nl "Saved unknown packet %s" tmp_file;
1521
1522           dump s;
1523           lprint_newline ();
1524         end;
1525       UnknownReq (magic,s)
1526
1527 let write emule buf t =
1528   let magic = match t with
1529       EmuleMultiPacketAnswerReq _
1530     | EmuleMultiPacketReq _
1531     | EmuleSecIdentStateReq _
1532     | EmuleSignatureReq _
1533     | EmulePublicKeyReq _
1534     | EmuleRequestSourcesReplyReq _
1535     | EmuleRequestSourcesReq _
1536     | EmuleClientInfoReplyReq _
1537     | EmuleClientInfoReq _
1538     | EmuleFileDescReq _
1539     | EmuleQueueRankingReq _
1540     | EmuleCaptchaReq _
1541     | EmuleCaptchaRes _
1542     | EmuleCompressedPart _
1543       -> 0xC5
1544     | QueryBlocReq t when t.QueryBloc.usesixtyfour -> 0xC5
1545     | BlocReq t when t.Bloc.usesixtyfour -> 0xC5
1546     | _
1547       ->  227
1548   in
1549   begin
1550     match t with
1551     | ConnectReq t ->
1552         buf_int8 buf 1;
1553         Connect.write false buf t
1554     | ConnectReplyReq t ->
1555         buf_int8 buf 76;
1556         Connect.write true buf t
1557     | QueryFileReq t ->
1558         buf_int8 buf 88;
1559         QueryFile.write emule buf t
1560     | QueryFileReplyReq t ->
1561         buf_int8 buf 89;
1562         QueryFileReply.write buf t
1563     | QueueReq t ->
1564         buf_int8 buf 77;
1565         OtherLocations.write buf t
1566     | QueryBlocReq t ->
1567         buf_int8 buf (if t.QueryBloc.usesixtyfour then 0xa3 else 71);
1568         QueryBloc.write buf t
1569     | BlocReq t ->
1570         buf_int8 buf (if t.Bloc.usesixtyfour then 0xa2 else 70);
1571         Bloc.write buf t
1572     | JoinQueueReq t ->
1573         buf_int8 buf 84;
1574         JoinQueue.write emule buf t
1575     | QueryChunksReq t ->
1576         buf_int8 buf 79;
1577         QueryChunks.write buf t
1578     | QueryChunksReplyReq t ->
1579         buf_int8 buf 80;
1580         QueryChunksReply.write buf t
1581     | QueryChunkMd4Req t ->
1582         buf_int8 buf 81;
1583         QueryChunkMd4.write buf t
1584     | QueryChunkMd4ReplyReq t ->
1585         buf_int8 buf 82;
1586         QueryChunkMd4Reply.write buf t
1587     | AvailableSlotReq t ->
1588         buf_int8 buf 85;
1589         AvailableSlot.write buf t
1590     | ReleaseSlotReq t ->
1591         buf_int8 buf 86;
1592         ReleaseSlot.write buf t
1593     | OutOfPartsReq t ->
1594         buf_int8 buf 87;
1595         OutOfParts.write buf t
1596     | ViewFilesReq t ->
1597         buf_int8 buf 74;
1598         ViewFiles.write buf t
1599     | ViewFilesReplyReq t ->
1600         buf_int8 buf 75;
1601         ViewFilesReply.write buf t
1602     | ViewDirsReq t ->
1603         buf_int8 buf 93;
1604         ViewDirs.write buf t
1605     | ViewDirsReplyReq t ->
1606         buf_int8 buf 95;
1607         ViewDirsReply.write buf t
1608     | ViewFilesDirReq t ->
1609         buf_int8 buf 94;
1610         ViewFilesDir.write buf t
1611     | ViewFilesDirReplyReq t ->
1612         buf_int8 buf 96;
1613         ViewFilesDirReply.write buf t
1614     | OtherLocationsReq t ->
1615         buf_int8 buf 72;
1616         OtherLocations.write buf t
1617     | SayReq t ->
1618         buf_int8 buf 78;
1619         Say.write buf t
1620     | SourcesReq t ->
1621         buf_int8 buf 250;
1622         Sources.write buf t
1623     | NewUserIDReq t ->
1624         buf_int8 buf 77;
1625         NewUserID.write buf t
1626     | EndOfDownloadReq t ->
1627         buf_int8 buf 73;
1628         EndOfDownload.write buf t
1629     | NoSuchFileReq t ->
1630         buf_int8 buf 72;
1631         NoSuchFile.write buf t
1632     | QueueRankReq t ->
1633         buf_int8 buf 92;
1634         QueueRank.write buf t
1635
1636     | EmuleClientInfoReq t ->
1637         buf_int8 buf 1;
1638         EmuleClientInfo.write buf t
1639     | EmuleClientInfoReplyReq t ->
1640         buf_int8 buf 2;
1641         EmuleClientInfo.write buf t
1642     | EmuleQueueRankingReq t ->
1643         buf_int8 buf 0x60;
1644         EmuleQueueRanking.write buf t
1645     | EmuleRequestSourcesReq t ->
1646         buf_int8 buf 0x81;
1647         EmuleRequestSources.write buf t
1648     | EmuleRequestSourcesReplyReq t ->
1649         buf_int8 buf 0x82;
1650         EmuleRequestSourcesReply.write emule buf t
1651     | EmuleFileDescReq t ->
1652         buf_int8 buf 0x61;
1653         EmuleFileDesc.write buf t
1654     | EmuleCompressedPart t ->
1655         buf_int8 buf (if t.EmuleCompressedPart.usesixtyfour then 0xa1 else 0x40);
1656         EmuleCompressedPart.write buf t
1657     | EmuleMultiPacketReq (md4, list) ->
1658         buf_int8 buf 0x92;
1659         buf_md4 buf md4;
1660         List.iter (fun t ->
1661             match t with
1662               QueryFileReq t ->
1663                 buf_int8 buf 0x58;
1664                 (match t.QueryFile.emule_extension with
1665                     None -> ()
1666                   | Some (bitmap, ncompletesources) ->
1667                       write_bitmap buf bitmap;
1668                       if ncompletesources >= 0 && extendedrequest emule > 1 then
1669                         buf_int16 buf ncompletesources)
1670             | QueryChunksReq _ ->
1671                 buf_int8 buf 0x4F
1672             | EmuleRequestSourcesReq _ ->
1673                 buf_int8 buf 0x81
1674             | _ ->
1675                 lprintf_nl "WARNING: Don't know how to write short packet:";
1676                 print t;
1677                 print_newline ();
1678         ) list
1679
1680     | EmuleMultiPacketAnswerReq (md4, list) ->
1681         buf_int8 buf 0x93;
1682         buf_md4 buf md4;
1683         List.iter (fun t ->
1684             match t with
1685               QueryFileReplyReq t ->
1686                 buf_int8 buf 89;
1687                 buf_string buf t.QueryFileReply.name
1688             | QueryChunksReplyReq t ->
1689                 buf_int8 buf 80;
1690                 write_bitmap buf t.QueryChunksReply.chunks
1691             | _ ->
1692                 lprintf_nl "WARNING: Don't know how to write short packet:";
1693                 print t;
1694                 print_newline ();
1695         ) list
1696
1697     | EmuleSecIdentStateReq t ->
1698         buf_int8 buf 0x87;
1699         EmuleSecIdentStateReq.write buf t
1700
1701     | EmuleSignatureReq t ->
1702         buf_int8 buf 0x86;
1703         EmuleSignatureReq.write buf t
1704
1705     | EmulePublicKeyReq t ->
1706         buf_int8 buf 0x85;
1707         EmulePublicKeyReq.write buf t
1708
1709     | EmulePortTestReq t ->
1710         buf_int8 buf 0xfe;
1711         EmulePortTestReq.write buf
1712
1713     | EmuleCaptchaReq t ->
1714         buf_int8 buf 0xa5;
1715         EmuleCaptchaReq.write buf t
1716
1717     | EmuleCaptchaRes t ->
1718         buf_int8 buf 0xa6;
1719         EmuleCaptchaRes.write buf t
1720
1721     | UnknownReq (opcode, s) ->
1722         Buffer.add_string buf s
1723
1724   end;
1725   magic
1726
1727 (*
1728 ------------------------------------------------------
1729 1044008574.297 192.168.0.3:37522 -> 80.26.114.12:13842 of len 6
1730 ? Become Friend ? ping ?
1731
1732 (227)(1)(0)(0)(0)
1733 (98)
1734
1735 ------------------------------------------------------
1736 1044008576.274 80.26.114.12:13842 -> 192.168.0.3:37522 of len 6
1737 ? OK ? pong ?
1738
1739 (227)(1)(0)(0)(0)(99)]
1740
1741 ------------------------------------------------------
1742 1044008687.977 192.168.0.3:37522 -> 80.26.114.12:13842 of len 6
1743 Browse Main Dir
1744
1745 (227)(1)(0)(0)(0)
1746 (93)
1747
1748 ------------------------------------------------------
1749 1044008690.832 80.26.114.12:13842 -> 192.168.0.3:37522 of len 43
1750 Browse Main Dir Reply
1751 (227)(38)(0)(0)(0)
1752 (95)
1753 (2)(0)(0)(0) --------> 2 directories:
1754 (12)(0) C : \ D o w n l o a d s
1755 (17)(0) ! I n c o m p l e t e   F i l e s
1756
1757
1758 ------------------------------------------------------
1759 1044008766.137 192.168.0.3:37522 -> 80.26.114.12:13842 of len 20
1760 Browse directory
1761
1762 (227)(15)(0)(0)(0)
1763 (94)
1764 (12)(0) C : \ D o w n l o a d s
1765
1766 ------------------------------------------------------
1767 1044008769.045 80.26.114.12:13842 -> 192.168.0.3:37522 of len 300
1768 (227) p(8)(0)(0) `(12)(0) C : \ D o w n l o a d s(21)(0)(0)(0)(152) 2(229)(158)(218)(141)(217)(138) n(181) 6 ( ) h V(179)(0)(0)(0)(0)(0)(0)(3)(0)(0)(0)(2)(1)(0)(1)(11)(0) d e s k t o p . i n i(3)(1)(0)(2)(180)(0)(0)(0)(3)(1)(0)(19)(0)(0)(0)(0) y(16)(15) 9 O Z(219) i e(200)(10) |(29)(27) F(128)(0)(0)(0)(0)(0)(0)(5)(0)(0)(0)(2)(1)(0)(1)(15)(0) u t b o n u s p a c k . z i p(3)(1)(0)(2) J(16)(221)(0)(2)(1)(0)(3)(3)(0) P r o(2)(1)(0)(4)(3)(0) z i p(3)(1)(0)(19)(0)(0)(0)(0)(178)(145)(161)(146) P(199)(228)(249) K a :(9)(237)(246)(233) v(0)(0)(0)(0)(0)(0)(5)(0)(0)(0)(2)(1)(0)(1)(11)(0) c t f m a p s . z i p(3)(1)(0)(2)(236)(239)(23)(0)(2)(1)(0)(3)(3)(0) P r o(2)(1)(0)(4)(3)(0) z i p(3)(1)(0)(19)(0)(0)(0)(0) a n(251)(225) ^ g(205)(133)(25)(12) # ' J A(221) `(0)(0)(0)(0)(0)(0)(5)(0)(0)(0)(2)(1)(0)(1)(23)(0) u t i n o x x p a c k - n o - u m o d . z i p(3)(1)(0)(2)]
1769 (227)(112)(8)(0)(0)
1770
1771 (96)
1772 (12)(0) C : \ D o w n l o a d s
1773 (21)(0)(0)(0) 21 files
1774
1775 (152)(50)(229)(158)(218)(141)(217)(138)(110)(181)(54)(40)(41)(104)(86)(179)
1776 (0)(0)(0)(0)
1777 (0)(0)
1778 (3)(0)(0)(0)
1779 (2)
1780 (1)(0)(1)
1781 (11)(0)  d e s k t o p . i n i
1782 (3)
1783 (1)(0)(2)
1784 (180)(0)(0)(0)
1785 (3)
1786 (1)(0)(19)
1787 (0)(0)(0)(0)
1788
1789 (121)(16)(15)(57)(79)(90)(219)(105)(101)(200)(10)(124)(29)(27)(70)(128)
1790 (0)(0)(0)(0)
1791 (0)(0)
1792 (5)(0)(0)(0)
1793 (2)
1794 (1)(0)(1)
1795 (15)(0) u t b o n u s p a c k . z i p
1796 (3)
1797 (1)(0)(2)
1798 (74)(16)(221)(0)
1799 (2)
1800 (1)(0)(3)
1801 (3)(0) Pro
1802 (2)
1803 (1)(0)(4)
1804 (3)(0) zip
1805 (3)
1806 (1)(0)(19)
1807 (0)(0)(0)(0)
1808 ....
1809
1810 *)
1811
1812 (* 92: Queue Rank *)