src/networks/direct_connect/dcProtocol.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 CommonOptions
  22 open CommonGlobals
  23 open DcTypes
  24 open DcGlobals
  25 open TcpBufferedSocket
  26 open Options
  27 (*open AnyEndian*)
  28
  29 let log_prefix = "[dcPro]"
  30
  31 let lprintf_nl fmt =
  32   lprintf_nl2 log_prefix fmt
  33
  34 (* Replace one string to another string from string *)
  35 (*let dc_replace_str_to_str s find_str to_str =
  36   if find_str = to_str then failwith "dc_replace_str_to_str find_str = to_str";
  37   let flen = String.length find_str in
  38   let str = ref "" in
  39   let rest = ref "" in
  40   let index = ref 0 in
  41   let rec replace s =
  42     let ok =
  43       (try
  44         index := String2.search_from s 0 find_str
  45       with
  46       | Not_found -> index := -1 );
  47       if (!index = -1) then begin
  48         str := !str ^ s; true
  49       end else begin
  50         str := !str ^ String2.before s !index ^ to_str;
  51         rest := String2.after s (!index+flen);
  52         false
  53       end
  54     in
  55     if not ok then replace !rest
  56     else !str
  57   in
  58   replace s *)
  59
  60 (* Decode chat messages *)
  61 (* You can now use $ and | in the chat. *)
  62 (* DC++ uses the HTML standard &#36; and &#124; to replace them *)
  63 let dc_decode_chat s =  (* convert html characters &#36; to '|' and &#124; and &amp; from text *)
  64   let s = dc_replace_str_to_str s "&#124;" "|" in
  65   let s = dc_replace_str_to_str s "&#36;" "$" in
  66   let s = dc_replace_str_to_str s "&amp;" "&" in
  67   s
  68
  69 (* Encode chat messages *)
  70 let dc_encode_chat s = (* convert '|'and '$' to html characters &#36; and &#124; *)
  71   let s = String2.replace s '$' "&#36;" in
  72   let s = String2.replace s '|' "&#124;" in
  73   let s = String2.replace s '&' "&amp;" in
  74   s
  75
  76 (* Reuseable modules for simple commands *)
  77 module Empty = functor(M: sig val msg : string end) ->  struct
  78   let parse s = ()
  79   let print t = lprintf_nl "%s" M.msg
  80       let write buf t = ()
  81     end
  82
  83 module Empty2 = functor(M: sig val msg : string end) ->  struct
  84       let parse s = ()
  85   let print t = lprintf_nl "%s" M.msg
  86       let write buf t = Printf.bprintf buf "$%s" M.msg
  87     end
  88
  89 (* DC uses 1-byte encodings *)
  90 (* Probably better convert to/from utf at transport layer!? *)
  91
  92 let utf_to_dc s =
  93   (* FIXME need hub-specific encodings *)
  94 (*   Charset.convert Charset.UTF_8 Charset.CP1252 s *)
  95   try
  96     Charset.convert Charset.UTF_8 (Charset.charset_from_string !!DcOptions.default_encoding) s
  97   with
  98     _ -> Charset.Locale.to_locale s
  99
 100 let dc_to_utf s =
 101   try
 102     Charset.convert (Charset.charset_from_string !!DcOptions.default_encoding) Charset.UTF_8 s
 103   with
 104     _ -> Charset.Locale.to_utf8 s
 105
 106 let make_name s =
 107   match String2.split s '/' with
 108   | ["TTH";tth] ->
 109       if is_valid_tiger_hash tth then NameTTH tth else failwith "Invalid TTH"
 110 (*
 111   | ""::path ->
 112       if List.exists (function "." | ".." -> true | _ -> false) path then failwith "Invalid path" else NameShared path
 113 *)
 114   | [file] -> NameSpecial file
 115   | _ -> failwith ("Invalid name : " ^ s)
 116
 117 let show_name = function
 118 (*   | NameShared l -> "/" ^ String.concat "/" l *)
 119   | NameSpecial s -> s
 120   | NameTTH tth -> "TTH/" ^ tth
 121
 122 module SimpleCmd(M: sig val msg : string end) = struct
 123   type t = string
 124   let parse nick = dc_to_utf nick
 125   let print t = lprintf_nl "%s (%s)" M.msg t
 126   let write buf t = Printf.bprintf buf "$%s %s" M.msg (utf_to_dc t)
 127 end
 128
 129 (*module NickAndAddr (M: sig val msg : string end) = struct
 130   type t = {
 131     nick : string;
 132     ip : Ip.t;
 133     port : int;
 134   }
 135   let parse s =
 136     let (nick, rem) = String2.cut_at s ' ' in
 137     let (ip, port) = String2.cut_at rem ':' in {
 138       nick = nick;
 139       ip = Ip.of_string ip;
 140       port = int_of_string port;
 141     }
 142   let print t = lprintf_nl "%s %s %s:%d" M.msg t.nick (Ip.to_string t.ip) t.port
 143   let write buf t = Printf.bprintf  buf "$%s %s %s:%d" M.msg t.nick (Ip.to_string t.ip) t.port;
 144 end *)
 145
 146 module SimpleNickList = functor (M: sig val cmd : string end) -> struct
 147   type t = string list
 148   let parse t =
 149     let list = String2.split_simplify t '$' in
 150     let list = List.rev_map (fun nick -> dc_to_utf nick) list in
 151     list
 152   let print t =
 153     lprintf "%s list ( " M.cmd;
 154     List.iter (fun s -> lprintf "%s " s) t;
 155     lprintf_nl " )"
 156   let write buf t =
 157     Buffer.add_char buf ' ';
 158     List.iter (fun nick -> Printf.bprintf buf "%s %s$$" M.cmd (utf_to_dc nick)) t
 159   end
 160
 161 (* Command modules *)
 162
 163 module Adc = functor (A: sig val command : string end) -> struct
 164 (* ADCSEARCH ?? -- DC++ ShareManager.cpp -> ShareManager::AdcSearch::AdcSearch *)
 165 (* ADC Protocol Draft 0.12
 166 GET type identifier start_pos bytes
 167
 168 Requests that a certain file or binary data be transmitted. <start_pos> counts 0 as the first byte. <bytes> may be
 169 set to -1 to indicate that the sending client should fill it in with the number of bytes needed to complete the
 170 file from <start_pos>. <type> is a [a-zA-Z0-9]+ string that specifies the namespace for identifier and BASE requires
 171 that clients recognize the types 'file', 'tthl' and 'list'. Extensions may add to the identifier names as well as
 172  add new types.
 173 'file' transfers transfer the file data in binary, starting at <start_pos> and sending <bytes> bytes.
 174 Identifier must be a TTH root value from the 'TTH/' root.
 175 'tthl' transfers send the largest set of leaves available) as a binary stream of leaf data, right-to-left, with no
 176 spacing in between them. <start_pos> must be set to 0 and <bytes> to -1 when requesting the data. <bytes> must
 177 contain the total binary size of the leaf stream in SND, and by dividing this length by the individual hash length,
 178 the number of leaves, and thus the leaf level can be deducted. The received leaves can then be used to reconstruct
 179 the entire tree, and the resulting root must match the root of the file (this verifies the integrity of the tree
 180 itself). Identifier must be a TTH root value from the 'TTH/' root.
 181 'list' transfers are used for partial file lists and have a directory as identifier. <start_pos> is always 0 and
 182 <bytes> contains the uncompressed length of the generated XML text in the corresponding SND. An optional flag 'RE1'
 183 means that the client is requesting a recursive list and that the sending client should send the directory itself
 184 and all subdirectories as well. If this is too much, the sending client may choose to send only parts. The flag
 185 should be taken as a hint that the requesting client will be getting the subdirectories as well, so they might as
 186 well be sent in one go. Identifier must be a directory in the unnamed root, ending (and beginning) with ‘/’. *)
 187
 188   type t = {
 189     adctype : adc_type;
 190     start_pos : int64;
 191     bytes : int64;
 192     zl : bool;
 193   }
 194
 195   let parse s =
 196     try
 197       match String2.split s ' ' with
 198       | adc_type :: ident :: start_pos :: bytes :: flags ->
 199         {
 200           adctype = begin match adc_type with
 201                     | "file" -> AdcFile (make_name ident)
 202 (*                     | "tthl" -> AdcTthl (match name with NameTTH tth -> tth | _ -> failwith "tthl") *)
 203                     | "list" -> AdcList (ident, List.mem "RE1" flags)
 204 (*                     ((match name with NameShared dir -> dir | _ -> failwith "list"),  *)
 205                     | _ -> failwith "Unknown ADC GET type"
 206           end;
 207           start_pos = Int64.of_string start_pos;
 208           bytes = Int64.of_string bytes;
 209           zl = List.mem "ZL1" flags;
 210         }
 211       | _ -> failwith "Invalid ADC GET format"
 212     with exn ->
 213       if !verbose_msg_clients || !verbose_upload then
 214         lprintf_nl "Error in AdcGet parsing : %s" (Printexc2.to_string exn);
 215       raise Not_found
 216
 217   let to_string t =
 218     let adc_type,ident,flags =
 219       match t.adctype with
 220 (*       | AdcTthl tth -> "tthl", show_name (NameTTH tth), [] *)
 221       | AdcFile name -> "file", show_name name, []
 222       | AdcList (path,re) -> "list", path, if re then ["RE1"] else []
 223     in
 224     let flags = if t.zl then "ZL1"::flags else flags in
 225     Printf.sprintf "$%s %s %s %Ld %Ld %s" A.command
 226       adc_type ident t.start_pos t.bytes (String.concat " " flags)
 227
 228   let print t = lprintf_nl "%s" (to_string t)
 229   let write buf t = Buffer.add_string buf (to_string t)
 230
 231   end
 232
 233 module AdcGet = Adc (struct let command = "ADCGET" end)
 234
 235 module AdcSnd = Adc (struct let command = "ADCSND" end)
 236
 237 module Canceled = Empty2(struct let msg = "Canceled" end)
 238
 239 module ConnectToMe = struct
 240     type t = {
 241     nick : string;
 242     ip : Ip.t;
 243     port : int;
 244       }
 245
 246     let parse s =
 247     let snick, rnick, senderip =
 248       match String2.split s ' ' with
 249       | [ snick ; rnick ; senderip ] -> snick, rnick, senderip (* NMDC compatible clients: *)
 250       | [ rnick ; senderip ] -> create_temp_nick (), rnick, senderip   (* DC++, NMDC v2.205 and DC:PRO v0.2.3.97A: *)
 251       | _ -> raise Not_found
 252     in
 253     let (ip,port) = String2.cut_at senderip ':' in {
 254       nick = dc_to_utf snick;
 255       ip = Ip.of_string ip;
 256       port = int_of_string port;
 257     }
 258   let print t = lprintf_nl "$ConnectToMe %s %s:%d" t.nick (Ip.to_string t.ip) t.port
 259     let write buf t =
 260      Printf.bprintf buf " %s %s:%d" (utf_to_dc t.nick) (Ip.to_string t.ip) t.port;
 261      if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf);
 262   end
 263
 264
 265 module Direction = struct
 266     type t = {
 267     direction : dc_direction;
 268         level : int;
 269       }
 270   let txt_upload = "Upload"
 271   let txt_download = "Download"
 272
 273     let parse s =
 274       match String2.split s ' ' with
 275       | ["Download"; level] -> {
 276       direction = Download (int_of_string level);
 277             level = int_of_string level }
 278       | ["Upload"; level] -> {
 279       direction = Upload (int_of_string level);
 280             level = int_of_string level }
 281     | _ -> raise Not_found
 282
 283   let print t = lprintf_nl "Direction %s %d" (
 284         match t.direction with
 285       | Download _ -> txt_download
 286       | Upload _ -> txt_upload) t.level
 287
 288     let write buf t =
 289       Printf.bprintf buf "$Direction %s %d"
 290         (match t.direction with
 291          | Download _ -> txt_download
 292          | Upload _ -> txt_upload)
 293         t.level
 294 end
 295
 296 module FileLength = struct
 297   type t = int64
 298   let parse s = Int64.of_string s
 299   let print t = lprintf_nl "FileLength %Ld" t
 300   let write buf t = Printf.bprintf buf "$FileLength %Ld" t
 301   end
 302
 303 module ForceMove = SimpleCmd(struct let msg = "ForceMove" end)
 304
 305 module Get = struct
 306   type t = {
 307     filename : string;
 308     pos : int64;
 309     }
 310   let parse s =
 311     let len = String.length s in
 312     let pos = String.rindex s '$' in {
 313       filename = dc_to_utf (String.sub s 0 pos);
 314       pos = Int64.of_string (String.sub s (pos+1) (len-pos-1));
 315     }
 316   let print t = lprintf_nl "Get [%s] %Ld" t.filename t.pos
 317   let write buf t =
 318     Printf.bprintf buf "$Get %s$%Ld" (utf_to_dc t.filename) t.pos;
 319     if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)
 320   end
 321
 322 module GetListLen = Empty2(struct let msg = "GetListLen" end)
 323
 324 module Hello = SimpleCmd(struct let msg = "Hello" end)
 325 module HubName = SimpleCmd(struct let msg = "HubName" end)
 326
 327 module Key = struct
 328     type t = {
 329         key : string;
 330       }
 331     let parse key = { key = key }
 332   let print t = lprintf_nl "$Key (%s)" t.key
 333   let write buf t = Printf.bprintf buf " %s" t.key
 334 end
 335
 336 module Lock = struct
 337   type t = {
 338     key : string;
 339     info : string;
 340     extended_protocol: bool;
 341   }
 342   let ext_txt = "EXTENDEDPROTOCOL"
 343   let parse s =
 344     match String2.splitn s ' ' 1 with
 345     | [key; info] -> {
 346         extended_protocol = (String2.string_ncmp key ext_txt (String.length ext_txt)); (* if s has ext_txt at start, return true *)
 347         key = key;
 348         info = info }
 349     | _ -> raise Not_found
 350   let print t = lprintf_nl "$Lock %s%s Pk=%s" ext_txt t.key Autoconf.current_version
 351     let write buf t =
 352     Printf.bprintf buf " %s%s Pk=%s" ext_txt t.key Autoconf.current_version
 353   end
 354
 355 module Message = struct
 356     type t = {
 357     from : string;
 358         message : string;
 359       }
 360   let parse m =
 361     let l = String.length m in
 362     if l > 75000 then begin
 363       lprintf_nl "Overlength <Message>: (%s...%d chars)" (shorten_string m 100) l;
 364       raise Not_found
 365     end else begin
 366       if (m.[0] = '<') then begin
 367         (match String2.splitn m ' ' 1 with
 368         | [from; m] ->
 369             let from = String2.replace from char60 empty_string in
 370             let from = String2.replace from char62 empty_string in
 371             let m = dc_decode_chat m in
 372             { from = dc_to_utf from; message = dc_to_utf m }
 373         | _ -> raise Not_found )
 374       end else begin
 375         let m = dc_decode_chat m in
 376         { from = "-"; message = dc_to_utf m }
 377       end
 378     end
 379   let print t = lprintf_nl "<Message> (%s) (%s)" t.from t.message
 380   let write buf t =
 381     let m = utf_to_dc t.message in
 382     let m = dc_encode_chat m in
 383     Printf.bprintf buf "<%s> %s" (utf_to_dc t.from) m
 384 end
 385
 386 module MyINFO = struct
 387   let return_no_tags dest nick tag email share =
 388     { (* basic info record to return as result... *)
 389       (* Some hubs (Y-hub) send MyInfo without any info, so eg. we don't know users states *)
 390       dest = dest;
 391       nick = nick;
 392       description = tag;
 393       client_brand = "";
 394       version = "";
 395       mode = 'P';
 396       hubs = (0 , 0 , 0);
 397       slots = 0;
 398       conn_speed = "";
 399       open_upload_slot = 0;
 400       flag = 1;
 401       sharesize = share;
 402       email = email;
 403       bwlimit = 0;
 404     }
 405   (* ALL OpChat Operator chat - only for OPs$ $$$0$ *)
 406   (* ALL nick <description>$ $<connection><flag>$<e-mail>$<sharesize>$ *)
 407   (* ALL nick <McDC 0.38><++ V:0.691,M:P,H:0/0/10,S:1> *)
 408   (* ALL nick $ $  $$245524999567$|  Hub can send this also *)
 409   (* ALL nick <StrgDC++ V:1.00 RC9,M:P,H:9/0/0,S:3>$ $DSL^A$$957396830$
 410   *)
 411     let parse s =
 412     (try
 413       (match String2.split s '$' with               (* divide string to list by delimiter '$' *)
 414       | [] -> raise Not_found                       (* MyInfo basic structure was wrong *)
 415       | _ :: nickdesc :: _ :: connf :: email :: share :: _ ->
 416           let l = String.length connf in
 417           let speed = if (l > 1) then String.sub connf 0 (l-1) else "" in    (* if no conn. type, set to "" *)
 418           let flag = if (l > 0) then int_of_char connf.[l-1] else 1 in       (* if no flag, set to 1 (normal) *)
 419           let size = (try Int64.of_string share with _ -> Int64.of_int 0) in (* if no share, set to 0 *)
 420
 421           let dest_nick,tagline =
 422             (match String2.split nickdesc '<' with  (* continue dividing nick and description field with '<' ... *)
 423             | [ dest_nick ; tagline ] -> dest_nick , tagline
 424             | [ dest_nick ; _ ; tagline] -> dest_nick , tagline
 425             | [ dest_nick ] -> dest_nick , ""
 426             | _ -> if !verbose_msg_clients then lprintf_nl "No. of '<':s is wrong in nickdesk"; raise Not_found )
 427           in
 428           let dest,nick =
 429             (match String2.splitn dest_nick ' ' 2 with
 430             | [ dest ; nick ; _ ] -> dest, dc_to_utf nick
 431             | _ -> if !verbose_msg_clients then lprintf_nl "No. of ' ':s is wrong in dest_nick"; raise Not_found )
 432           in
 433           if tagline = "" then return_no_tags dest nick tagline email size
 434           else begin
 435             let tagline =
 436               (match String2.split tagline '>' with      (* split desc with '>' *)
 437               | [tagline ; _ ] -> tagline
 438               | _ -> if !verbose_msg_clients then lprintf_nl "No. of '>':s is wrong in nickdesk"; raise Not_found )
 439             in
 440             (match String2.splitn tagline ' ' 1 with        (* split desc with one ' ' *)
 441             | [client ; tags] ->
 442                 let version = ref "" in
 443                 let mode = ref 'A' in
 444                 let hubs = ref (0 , 0 , 0) in
 445                 let slots = ref 0 in
 446                 let upload = ref 0 in
 447                 let bwlimit = ref 0 in
 448                 List.iter (fun str ->                 (* split tags with ',' for this iteration *)
 449                   let l = String.length str in
 450                   if (l > 2) then
 451                     (match str.[0] with
 452                     | 'v' (* GreylinkDC++ *)
 453                     | 'V' -> (try version := String2.after str 2 with _ -> () )
 454                     | 'M' -> if (str.[2] = 'P') then mode := 'P'
 455                     | 'H' ->
 456                         (match String2.split str '/' with
 457                         | a :: b :: c :: _ -> hubs :=
 458                             ( (try int_of_string (String2.after a 2) with _ -> 0 ),
 459                             (try int_of_string b with _ -> 0 ),
 460                             (try int_of_string c with _ -> 0 ) )
 461                         | _ -> () )
 462                     | 'S' -> (try slots := int_of_string (String2.after str 2) with _ -> () )
 463                     | 'O' -> (try upload := int_of_string (String2.after str 2) with _ ->  () )
 464                     | 'L' | 'B' -> (try bwlimit := int_of_string (String2.after str 2) with _ ->  () )
 465                     | _ ->
 466                         if !verbose_unknown_messages then
 467                           lprintf_nl "MyINFO: Unknown tag (%c) in (%s) (%s). Implement or fake line ?" str.[0] tagline nick )
 468                 ) (String2.split tags ',');
 469                 {                                   (* pass this info record as result.. *)
 470                   dest = dest;
 471                   nick = nick;
 472                   description = tagline;
 473                   client_brand = client;
 474                   version = !version;
 475                   mode = !mode;
 476                   hubs = !hubs;
 477                   slots = !slots;
 478                   conn_speed = speed;
 479                   open_upload_slot = !upload;
 480                   flag = flag;
 481                   sharesize = size;
 482                   email = email;
 483                   bwlimit = !bwlimit;
 484                 }
 485             | _ ->       (* description has no ' ' separator for client and tags *)
 486                 if !verbose_msg_clients || !verbose_unexpected_messages then begin
 487                   lprintf_nl "MyINFO: No correct ' ' separator in tagline (%s)" tagline;
 488                   lprintf_nl "MyINFO: Whole line is: (%s)" s
 489                 end;
 490                 return_no_tags dest nick tagline email size)
 491         end
 492       | _ -> raise Not_found ) (* MyInfo basic structure was wrong *)
 493     with _ ->
 494       lprintf_nl "Error in MyInfo parsing";
 495       raise Not_found )
 496
 497   let print t = lprintf_nl "$MyINFO %s %s %s %s %Ld" t.dest t.nick t.description t.conn_speed t.sharesize
 498     let write buf t =
 499     Printf.bprintf buf " %s %s %s$ $%s%c$%s$%Ld$"
 500       t.dest (utf_to_dc t.nick) t.description t.conn_speed
 501       (char_of_int t.flag) t.email t.sharesize
 502 end
 503
 504 module MyNick = SimpleCmd(struct let msg = "MyNick" end)
 505 module Quit = SimpleCmd(struct let msg = "Quit" end)
 506 module NickList = SimpleNickList(struct let cmd = "NickList" end)
 507 module OpList = SimpleNickList(struct let cmd = "OpList" end)
 508
 509 module RevConnectToMe = struct
 510   type t = {
 511     dest : string;
 512     orig : string;
 513   }
 514   let parse s =
 515     let (orig , dest) = String2.cut_at s ' ' in {
 516       dest = dc_to_utf dest;
 517       orig = dc_to_utf orig;
 518     }
 519   let print t = lprintf_nl "$RevConnectToMe %s %s" t.orig t.dest
 520   let write buf t =
 521     Printf.bprintf buf "$RevConnectToMe %s %s" (utf_to_dc t.orig) (utf_to_dc t.dest);
 522     if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)
 523   end
 524
 525 module Search = struct
 526     type t = {
 527     passive : bool;
 528     ip : string;
 529     port : string;
 530     nick : string;
 531         sizelimit : sizelimit;
 532         filetype : int;
 533     words_or_tth : string;
 534       }
 535
 536   (*  Active user:       $Search <ip>:<port> <searchstring>
 537       Passive user:      $Search Hub:<requestornick> <searchstring>
 538
 539       <ip>             = client IP address
 540       <port>           = UDP port on which the client is listening for responses.
 541       <requestornick>  = Nick of the Passive User doing the Search.
 542
 543       <searchstring>   = <sizerestricted>?<isminimumsize>?<size>?<datatype>?<searchpattern>
 544       <sizerestricted> = 'T' if the search should be restricted to files of a minimum or maximum size, otherwise 'F'.
 545       <isminimumsize>  = 'F' if <sizerestricted> is 'F' or if the size restriction places an upper limit
 546                          on file size, otherwise 'T'.
 547       <size>           = minimum or maximum size of the file to report (according to <isminimumsize>)
 548                          if <sizerestricted> is 'T', otherwise 0.
 549       <datatype>       = restricts the search to files of a particular type. It is an integer selected from:
 550                          * 1 for any file type
 551                          * 2 for audio files ("mp3", "mp2", "wav", "au", "rm", "mid", "sm")
 552                          * 3 for compressed files ("zip", "arj", "rar", "lzh", "gz", "z", "arc", "pak")
 553                          * 4 for documents ("doc", "txt", "wri", "pdf", "ps", "tex")
 554                          * 5 for executables ("pm", "exe", "bat", "com")
 555                          * 6 for pictures ("gif", "jpg", "jpeg", "bmp", "pcx", "png", "wmf", "psd")
 556                          * 7 for video ("mpg", "mpeg", "avi", "asf", "mov")
 557                          * 8 for folders
 558                          * 9 for TTH
 559       <searchpattern>  = used by other users to determine if any files match. Non-alphanumeric characters
 560                          (including spaces and periods) are replaced by '$'.
 561       Examples:
 562         64.78.55.32:412 T?T?500000?1?Gentoo$2005
 563         Hub:SomeNick T?T?500000?1?Gentoo$2005
 564   *)
 565   let s_tth = "TTH:"
 566
 567     let parse s =
 568     (try
 569       let orig , search =
 570         (match String2.split_simplify s ' ' with
 571         | [orig ; search ] -> orig , search
 572         | _ -> raise Not_found )
 573       in
 574       let passive , nick , ip , port =
 575         (match String2.splitn orig ':' 1 with
 576         | ["Hub" ; nick] ->
 577             true, dc_to_utf nick, empty_string, empty_string
 578         | [ip ; port] ->
 579             false, empty_string, ip, port
 580         | _ -> raise Not_found )
 581       in
 582       (match String2.splitn search '?' 4 with
 583       | [has_size; size_kind; size; filetype; words] ->
 584           let filetype = int_of_string filetype in
 585           let words =                                        (* strip TTH: from TTH-search or return search words *)
 586             if filetype = 9 then                             (* TTH *)
 587               dc_replace_str_to_str words s_tth empty_string (* Strip TTH: *)
 588             else begin                                       (* normal search words *)
 589               let s = ref (String.copy words) in
 590               String2.replace_char !s '$' ' ';
 591               String.lowercase !s
 592             end
 593           in
 594           let words = dc_to_utf words in
 595           let size =
 596             (match has_size, size_kind with
 597             | "T", "T" -> AtMost (Int64.of_float (float_of_string size))
 598               |  "T", "F" -> AtLeast (Int64.of_float (float_of_string size))
 599             | _ -> NoLimit )
 600           in {
 601             passive = passive;
 602             nick = nick;
 603             ip = ip;
 604             port = port;
 605             sizelimit = size;
 606             filetype = filetype;
 607             words_or_tth = words;
 608             }
 609       | _ -> raise Not_found )
 610     with _ ->
 611       if !verbose_msg_clients then lprintf_nl "Search parsing error: (%s)" s;
 612       raise Not_found )
 613
 614   let print t = lprintf_nl "$Search %s %s %d %s" t.nick t.ip t.filetype t.words_or_tth
 615   let write buf t =
 616       Printf.bprintf buf " %s %c?%c?%s?%d?%s"
 617       (if t.passive then "Hub:" ^ (utf_to_dc t.nick) else t.ip ^ ":" ^ t.port )
 618       (if t.sizelimit = NoLimit then 'F' else 'T')
 619       (match t.sizelimit with
 620        | AtMost _ -> 'T'
 621        | _ -> 'F' )
 622       (match t.sizelimit with
 623        | AtMost n -> Int64.to_string n
 624         | AtLeast n -> Int64.to_string n
 625         | _  -> "0")
 626       t.filetype
 627       (let words =
 628          if t.filetype = 9 then s_tth ^ t.words_or_tth    (* if TTH search is wanted, send root hash *)
 629          else begin
 630            let s = ref (String.copy t.words_or_tth) in    (* otherwise send search words *)
 631            String2.replace_char !s char32 '$';
 632            !s
 633          end
 634        in
 635        utf_to_dc words);
 636     (*if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)*)
 637   end
 638
 639 module Send = Empty2 (struct let msg = "Send" end)
 640
 641 module SR = struct
 642     type t = {
 643         owner : string;
 644     directory : string;
 645         filename : string;
 646         filesize : int64;
 647         open_slots : int;
 648         all_slots : int;
 649         server_name : string;
 650     tth : string;
 651     server_ip : string;
 652     server_port : string;
 653         to_nick : string option;
 654       }
 655     let parse s =
 656     (try
 657       let is_dir, owner_and_filename , size_and_slots, server_info =
 658         (match String2.split s char5 with
 659         | [owner_and_filename; size_and_slots; server_info] -> (* result is a file *)
 660             false, owner_and_filename, size_and_slots, server_info
 661         | [owner_and_filename; server_info] ->                 (* result is a directory, currently not supported *)
 662             let pos = String.rindex owner_and_filename ' ' in
 663             let len = String.length owner_and_filename in
 664             let size_and_slots = Printf.sprintf "0 %s"
 665               (String.sub owner_and_filename (pos+1) (len - pos - 1)) in
 666             let owner_and_filename = String.sub owner_and_filename 0 pos in
 667             true , owner_and_filename, size_and_slots, server_info
 668         | _ -> raise Not_found )
 669       in
 670       (match String2.splitn owner_and_filename ' ' 1 with
 671       | [owner; filename_with_dir] ->            (* $SR User1 mypathmotd.txt<0x05>437 3/4<0x05>Testhub (10.10.10... *)
 672           let directory , filename =
 673             if is_dir then filename_with_dir, "" (* if it was directory, null the filename *)
 674             else begin
 675               (try
 676                 let pos = String.rindex filename_with_dir char92 in
 677                 dc_to_utf (String.sub filename_with_dir 0 pos) ,
 678                 dc_to_utf (String2.after filename_with_dir (pos+1))
 679                with _ -> "" , filename_with_dir )
 680             end
 681           in
 682           (match String2.splitn size_and_slots ' ' 1 with   (*...<0x05>437 3/4<0x05>...  *)
 683           | [size; slots] ->
 684               (match String2.splitn slots '/' 1 with
 685               | [open_slots; all_slots] ->
 686                   let get_server_and_tth str =           (* function for separation of TTH and servername     *)
 687                     (match String2.splitn str ':' 1 with (* the <server_name> is replaced with TTH:<tth_hash> *)
 688                     | ["TTH" ; tiger_root] -> tiger_root, ""
 689                     | [server_name] -> "", (dc_to_utf server_name)
 690                     | _ -> "","" )
 691                   in
 692                   let server_name, tth, ip, port =
 693                     (try
 694                       let pos = String.rindex server_info '(' in
 695                       let server_or_tth = String.sub server_info 0 (pos-1) in
 696                       let server_addr = String.sub server_info (pos+1) (String.length server_info - (pos+2)) in
 697                       let ip,port =
 698                         (match String2.split server_addr ':' with
 699                         | [ip ; port] -> ip, port
 700                         | [ip] -> ip,""
 701                         | _ -> "","" )
 702                       in
 703                       let tth,server_name = get_server_and_tth server_or_tth in
 704                       server_name,tth,ip,port
 705                     with _ ->                      (* if error above, try to find only TTH hash from start *)
 706                       let pos = String.index server_info '(' in
 707                       let server_or_tth = String.sub server_info 0 (pos-1) in
 708                       let tth, server_name = get_server_and_tth server_or_tth in
 709                       server_name, tth, "", "" )
 710       in
 711                               {
 712                     owner = dc_to_utf owner;
 713                     directory = directory;
 714                                 filename = filename;
 715                     filesize = ( try Int64.of_string size with _ -> Int64.of_int 0 );
 716                     open_slots = ( try int_of_string open_slots with _ -> 0 );
 717                     all_slots = ( try int_of_string all_slots with _ -> 0 );
 718                     to_nick = None; (* hubs should not send this at all *)
 719                                 server_name = server_name;
 720                     tth = tth;
 721                     server_ip = ip;
 722                     server_port = port;
 723                               }
 724               | _ -> raise Not_found )
 725           | _ -> raise Not_found )
 726       | _ -> raise Not_found )
 727     with e ->
 728       if !verbose_msg_clients then lprintf_nl "Error in SR parsing (%s)" s;
 729       raise Not_found )
 730
 731   let print t = lprintf_nl "$SR %s (%d/%d): %s %s %Ld (%s)"
 732       t.owner t.open_slots t.all_slots t.directory t.filename t.filesize t.tth
 733       (* opendchub-0.6.7/src/commands.c: * $SR fromnick filename\5filesize openslots/totalslots\5hubname (hubip:hubport)\5tonick| */ *)
 734     let write buf t =
 735     Printf.bprintf buf " %s %s\\%s%c%s %d/%d%cTTH:%s (%s:%s)"
 736       (utf_to_dc t.owner)
 737       (utf_to_dc t.directory)
 738       (utf_to_dc t.filename) char5 (Int64.to_string t.filesize)
 739       t.open_slots t.all_slots char5 t.tth t.server_ip t.server_port;
 740     (match t.to_nick with
 741     | None -> ()
 742     | Some nick -> Printf.bprintf buf "%c%s" char5 (utf_to_dc nick) );
 743     (*if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)*)
 744 end
 745
 746 module Supports = struct (* Extended DC++ *)
 747
 748   let x_nogetinfo = "NoGetINFO"
 749   let x_nohello = "NoHello"
 750   let x_userip2 = "UserIP2"
 751   let x_usercommand = "UserCommand"
 752   let x_tthsearch = "TTHSearch"
 753   let x_opplus = "OpPlus"
 754   let x_feed = "Feed"
 755   let x_mcto = "MCTo"
 756   let x_hubtopic = "HubTopic"
 757
 758   let x_bzlist = "BZList"
 759   let x_minislots = "MiniSlots"
 760   let x_getzblock = "GetZBlock"
 761   let x_xmlbzlist = "XmlBZList"
 762   let x_adcget = "ADCGet"
 763   let x_tthl = "TTHL"
 764   let x_tthf = "TTHF"
 765   let x_zlig = "ZLIG"
 766   let x_clientid = "ClientID"
 767   let x_chunk = "CHUNK"
 768   let x_gettestzblock = "GetTestZBlock"
 769   let x_getcid = "GetCID"
 770
 771   let create_supports_string t =
 772     let c = ref " " in
 773     let s = ref "" in
 774     (match t with
 775     | HubSupports t ->
 776         if t.nogetinfo = true then s := !s ^ !c ^ x_nogetinfo;
 777         if t.nohello = true then s := !s ^ !c ^ x_nohello;
 778         if t.userip2 = true then s := !s ^ !c ^ x_userip2;
 779         if t.usercommand = true then s := !s ^ !c ^ x_usercommand;
 780         if t.tthsearch = true then s := !s ^ !c ^ x_tthsearch;
 781         if t.opplus = true then s := !s ^ !c ^ x_opplus;
 782         if t.feed = true then s := !s ^ !c ^ x_feed;
 783         if t.mcto = true then s := !s ^ !c ^ x_mcto;
 784         if t.hubtopic = true then s := !s ^ !c ^ x_hubtopic;
 785     | ClientSupports t ->
 786         if t.bzlist = true then s := !s ^ !c ^ x_bzlist;
 787         if t.minislots = true then s := !s ^ !c ^ x_minislots;
 788         if t.getzblock = true then s := !s ^ !c ^ x_getzblock;
 789         if t.xmlbzlist = true then s := !s ^ !c ^ x_xmlbzlist;
 790         if t.adcget = true then s := !s ^ !c ^ x_adcget;
 791         if t.tthl = true then s := !s ^ !c ^ x_tthl;
 792         if t.tthf = true then s := !s ^ !c ^ x_tthf;
 793         if t.zlig = true then s := !s ^ !c ^ x_zlig;
 794         if t.clientid = true then s := !s ^ !c ^ x_clientid;
 795         if t.chunk = true then s := !s ^ !c ^ x_chunk;
 796         if t.gettestzblock = true then s := !s ^ !c ^ x_gettestzblock;
 797         if t.getcid = true then s := !s ^ !c ^ x_getcid );
 798     !s
 799
 800   let support_exists lst x =
 801     let result = ref false in
 802     let rec loop i =
 803       if !result = false then
 804         match i with
 805         | [] -> ()
 806         | hd :: tl -> (
 807             if hd = x then result := true
 808             else loop tl
 809           )
 810     in
 811     loop lst;
 812     !result
 813
 814   let parse source m =
 815     let l = String2.split m ' ' in
 816     (match source with
 817     | true -> HubSupports {  (* message is from server *)
 818         nogetinfo = (support_exists l x_nogetinfo);
 819         nohello = (support_exists l x_nohello);
 820         userip2 = (support_exists l x_userip2);
 821         usercommand = (support_exists l x_usercommand);
 822         tthsearch = (support_exists l x_tthsearch);
 823         opplus = (support_exists l x_opplus);
 824         feed = (support_exists l x_feed);
 825         mcto = (support_exists l x_mcto);
 826         hubtopic = (support_exists l x_hubtopic);
 827       }
 828     | false -> ClientSupports { (* message is from client *)
 829         bzlist = (support_exists l x_bzlist);
 830         minislots = (support_exists l x_minislots);
 831         getzblock = (support_exists l x_getzblock);
 832         xmlbzlist = (support_exists l x_xmlbzlist);
 833         adcget = (support_exists l x_adcget);
 834         tthl = (support_exists l x_tthl);
 835         tthf = (support_exists l x_tthf);
 836         zlig = (support_exists l x_zlig);
 837         clientid = (support_exists l x_clientid);
 838         chunk = (support_exists l x_chunk);
 839         gettestzblock = (support_exists l x_gettestzblock);
 840         getcid = (support_exists l x_getcid);
 841       } )
 842
 843   let print t = lprintf_nl "$Supports%s" (create_supports_string t)
 844   let write buf t = Printf.bprintf buf "$Supports%s" (create_supports_string t)
 845   end
 846
 847 module To = struct
 848     type t = {
 849     dest : string;
 850     from : string;
 851     message : string;
 852       }
 853     let parse s =
 854     if ((String.length s) > 75000) then begin
 855       lprintf_nl "Overlength $To: (%s)" (shorten_string s 50);
 856           raise Not_found
 857     end else begin
 858       (match String2.splitn s ' ' 4 with
 859       | [dest ; "From:" ; from ; _ ; message] ->
 860           let m =
 861             let m = dc_decode_chat message in
 862             m
 863           in {
 864             dest = dc_to_utf dest;
 865             from = dc_to_utf from;
 866             message = dc_to_utf m;
 867                     }
 868       | _ -> raise Not_found )
 869               end
 870   let print t = lprintf_nl "$To (%s) (%s) (%s)" t.dest t.from t.message
 871     let write buf t =
 872     let m = dc_encode_chat t.message in
 873     let from = utf_to_dc t.from in
 874     Printf.bprintf buf " %s From: %s $<%s> %s"
 875       (utf_to_dc t.dest) from from
 876       (utf_to_dc m)
 877   end
 878
 879 module UGetBlock = struct
 880     type t = {
 881     ufilename : string;
 882     ubytes : int64;
 883     upos : int64;
 884       }
 885     let parse s =
 886     (match String2.splitn s ' ' 2 with
 887     | [pos; bytes; filename ] ->
 888         let filename = dc_to_utf filename in
 889       {
 890           ufilename = filename;
 891           ubytes = Int64.of_string bytes;
 892           upos = Int64.of_string pos;
 893       }
 894     | _ -> raise Not_found )
 895   let print t = lprintf_nl "Get %Ld %Ld %s" t.upos t.ubytes t.ufilename
 896     let write buf t =
 897     Printf.bprintf buf "$Get %Ld$ %Ld %s" t.upos t.ubytes t.ufilename; (*UTF8*)
 898     if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)
 899   end
 900
 901 module UserIP = struct
 902   type t = string list
 903
 904   let parse s = String2.split_simplify s '$'
 905
 906   let parse_nameip =
 907     List2.filter_map (fun s ->
 908       match String2.split s ' ' with
 909       | [name;addr] -> Some (dc_to_utf name, Ip.addr_of_string addr)
 910       | _ -> None)
 911
 912   let print st =
 913     lprintf "UserIP list (";
 914     List.iter (fun s -> lprintf "%s " (dc_to_utf s)) st;
 915     lprintf_nl ")"
 916
 917   let write buf st =
 918     Printf.bprintf buf "$UserIP %s" (String.concat "$$" (List.map utf_to_dc st))
 919   end
 920
 921 (* Message type definitions and basic parsing *)
 922 type t =
 923   | AdcGetReq of AdcGet.t
 924   | AdcSndReq of AdcSnd.t
 925   | BadPassReq
 926   | CanceledReq
 927   | ConnectToMeReq of ConnectToMe.t
 928   | DirectionReq of Direction.t
 929   | ErrorReq of string
 930   | FailedReq of string
 931   | FileLengthReq of FileLength.t
 932   | ForceMoveReq of ForceMove.t
 933   | GetListLenReq
 934   | GetNickListReq
 935   | GetPassReq
 936   | GetReq of Get.t
 937   | HelloReq of Hello.t
 938   | HubIsFullReq
 939   | HubNameReq of HubName.t
 940   | HubTopicReq of string
 941   | KeyReq of Key.t
 942   | LockReq of Lock.t
 943   | LogedInReq of string
 944   | MaxedOutReq
 945   | MessageReq of Message.t
 946   (*| MultiConnectToMeReq of MultiConnectToMe.t*)
 947   (*| MultiSearchReq of Search.t*)
 948   | MyInfoReq of DcTypes.dc_myinfo
 949   | MyNickReq of MyNick.t
 950   | MyPassReq of string
 951   | NickListReq of NickList.t
 952   | OpListReq of OpList.t
 953   | QuitReq of Quit.t
 954   | RevConnectToMeReq of RevConnectToMe.t
 955   | SearchReq of Search.t
 956   | SendReq
 957   | SRReq of SR.t
 958   | SupportsReq of DcTypes.dc_supports
 959   | ToReq of To.t
 960   | UGetBlockReq of UGetBlock.t
 961   | UnknownReq of string
 962   | UserCommandReq
 963   | UserIPReq of UserIP.t
 964   | ValidateDenideReq of string
 965   | ValidateNickReq of string
 966   | VersionReq of string
 967
 968 (* Parse messages from a string s that "dc_handler" has sent and already separated
 969    from sock.buffer with '|'. From now on, parse the actual commands that start
 970    with '$' or '<'
 971    source: true = server, false = client *)
 972 let dc_parse source s =
 973   (try
 974     let ws = String2.splitn s ' ' 1 in
 975     (match ws with
 976     | [] -> UnknownReq ""       (* ignore empty messages *)
 977     | [cmd ; args] ->           (* two part message - cmd and args *)
 978         if (cmd.[0] = '$') then (* Commands with '$' ...*)
 979           (match cmd with
 980           | "$ADCGET" -> AdcGetReq (AdcGet.parse args)
 981           | "$ADCSND" -> AdcSndReq (AdcSnd.parse args)
 982           | "$ConnectToMe" -> ConnectToMeReq (ConnectToMe.parse args)
 983           | "$Direction" -> DirectionReq (Direction.parse args)
 984           | "$Error" -> ErrorReq s
 985           | "$Failed" -> FailedReq s
 986           | "$FileLength" -> FileLengthReq (FileLength.parse args)
 987           | "$ForceMove" -> ForceMoveReq (ForceMove.parse args)
 988           | "$Get" -> GetReq (Get.parse args)
 989           | "$GetNickList" -> GetNickListReq
 990           | "$Hello" -> HelloReq (Hello.parse args)
 991           | "$HubName" -> HubNameReq (HubName.parse args)
 992           | "$HubTopic" -> HubTopicReq (dc_to_utf args)
 993           | "$Key" -> KeyReq (Key.parse args)
 994           | "$Lock" -> LockReq (Lock.parse args)
 995           | "$LogedIn" -> LogedInReq args
 996           (*| "$MultiConnectToMe" -> MultiConnectToMeReq (MultiConnectToMe.parse args)*)
 997           (*| "$MultiSearch" -> MultiSearchReq (Search.parse args)*)
 998           | "$MyINFO" -> MyInfoReq (MyINFO.parse args)
 999           | "$MyNick" -> MyNickReq (MyNick.parse args)
1000           | "$NickList" -> NickListReq (NickList.parse args)
1001           | "$OpList" -> OpListReq (OpList.parse args)
1002           | "$Quit" -> QuitReq (Quit.parse args)
1003           | "$RevConnectToMe" -> RevConnectToMeReq (RevConnectToMe.parse args)
1004           | "$Search" -> SearchReq (Search.parse args)
1005           | "$SR" -> SRReq (SR.parse args)
1006           | "$Supports" -> SupportsReq (Supports.parse source args) (* here we need the info about source type*)
1007           | "$To:" -> ToReq (To.parse args)
1008           | "$UGetBlock" -> UGetBlockReq (UGetBlock.parse args)
1009           | "$UserCommand" -> UserCommandReq
1010           | "$UserIP" -> UserIPReq (UserIP.parse args)
1011           | "$ValidateDenide" -> ValidateDenideReq args
1012           | "$Version" -> VersionReq args (* VersionReq (Version.parse args) *)
1013           | _ -> UnknownReq s )
1014         else              (* all other two part messages, that don't start with '$' get type MessageReq *)
1015           MessageReq (Message.parse s)
1016     | [ cmd ] ->            (* Messages with only one part *)
1017         if (cmd.[0] = '$') then
1018           (match cmd with
1019           | "$BadPass" -> BadPassReq
1020           | "$Canceled" -> CanceledReq
1021           | "$GetListLen" -> GetListLenReq
1022           | "$GetPass" -> GetPassReq
1023           | "$HubIsFull" -> HubIsFullReq
1024           | "$MaxedOut" -> MaxedOutReq
1025           | "$Send" -> SendReq
1026           | _ -> UnknownReq s )
1027         else
1028           MessageReq (Message.parse s)
1029     | _ -> UnknownReq s )
1030   with _ ->
1031     UnknownReq s )
1032
1033 let dc_write buf m =
1034   (match m with
1035   | AdcGetReq t -> AdcGet.write buf t
1036   | AdcSndReq t -> AdcSnd.write buf t
1037   | BadPassReq -> ()
1038   | CanceledReq -> Canceled.write buf ()
1039   | ConnectToMeReq t -> Buffer.add_string buf "$ConnectToMe"; ConnectToMe.write buf t
1040   | DirectionReq t -> Direction.write buf t
1041   | ErrorReq s -> Printf.bprintf buf "$Error <%s>" (utf_to_dc s)
1042   | FailedReq s -> Printf.bprintf buf "$Failed <%s>" s (*UTF8*)
1043   | FileLengthReq t -> FileLength.write buf t
1044   | ForceMoveReq t -> ForceMove.write buf t
1045   | GetListLenReq -> GetListLen.write buf ()
1046   | GetNickListReq -> Buffer.add_string buf "$GetNickList"
1047   | GetPassReq -> ()
1048   | GetReq t -> Get.write buf t
1049   | HelloReq t -> Hello.write buf t
1050   | HubIsFullReq -> ()
1051   | HubNameReq t -> HubName.write buf t
1052   | HubTopicReq s -> ()
1053   | LockReq t -> Buffer.add_string buf "$Lock"; Lock.write buf t
1054   | LogedInReq s -> ()
1055   | KeyReq t -> Buffer.add_string buf "$Key"; Key.write buf t
1056   | MaxedOutReq -> Buffer.add_string buf "$MaxedOut"
1057   | MessageReq t -> Message.write buf t
1058   (*| MultiConnectToMeReq t -> MultiConnectToMe.write buf t*)
1059   (*| MultiSearchReq t -> Buffer.add_string buf "$MultiSearch"; Search.write buf t*)
1060   | MyInfoReq t -> Buffer.add_string buf "$MyINFO"; MyINFO.write buf t
1061   | MyNickReq t -> MyNick.write buf t
1062   | MyPassReq s -> Printf.bprintf buf "$MyPass %s" s
1063   | NickListReq t -> NickList.write buf t
1064   | OpListReq t -> OpList.write buf t
1065   | QuitReq t -> Quit.write buf t
1066   | RevConnectToMeReq t -> RevConnectToMe.write buf t
1067   | SearchReq t -> Buffer.add_string buf "$Search"; Search.write buf t
1068   | SendReq -> Send.write buf ()
1069   | SRReq t -> Buffer.add_string buf "$SR"; SR.write buf t
1070   | SupportsReq t -> Supports.write buf t
1071   | ToReq t -> Buffer.add_string buf "$To:"; To.write buf t
1072   | UnknownReq t -> Buffer.add_string buf t
1073   | UGetBlockReq t -> UGetBlock.write buf t
1074   | UserCommandReq -> ()
1075   | UserIPReq t -> UserIP.write buf t
1076   | ValidateNickReq s -> Printf.bprintf buf "$ValidateNick %s" s
1077   | ValidateDenideReq s -> Buffer.add_string buf s
1078   | VersionReq s -> Printf.bprintf buf "$Version %s" s )
1079
1080 let dc_print m =
1081   (match m with
1082   | AdcGetReq t -> AdcGet.print t
1083   | AdcSndReq t -> AdcSnd.print t
1084   | BadPassReq -> lprintf_nl "$BadPass"
1085   | CanceledReq -> Canceled.print ()
1086   | ConnectToMeReq t -> ConnectToMe.print t
1087   | DirectionReq t -> Direction.print t
1088   | ErrorReq t -> lprintf_nl "$Error"
1089   | FailedReq t -> lprintf_nl "$Failed"
1090   | FileLengthReq t -> FileLength.print t
1091   | ForceMoveReq t -> ForceMove.print t
1092   | GetListLenReq -> GetListLen.print ()
1093   | GetNickListReq -> lprintf_nl "$GetNickList"
1094   | GetPassReq -> lprintf_nl "$GetPass"
1095   | GetReq t -> Get.print t
1096   | HelloReq t -> Hello.print t
1097   | HubIsFullReq -> lprintf_nl "$HubIsFull"
1098   | HubNameReq t -> HubName.print t
1099   | HubTopicReq _ -> lprintf_nl "$HubTopic"
1100   | LockReq t -> Lock.print t
1101   | LogedInReq _ -> lprintf_nl "$LogedIn"
1102   | KeyReq t -> Key.print t
1103   | MaxedOutReq -> lprintf_nl "$MaxedOut"
1104   | MessageReq t -> Message.print t
1105   (*| MultiConnectToMeReq t -> MultiConnectToMe.print t*)
1106   (*| MultiSearchReq t -> lprintf "MULTI "; Search.print t*)
1107   | MyPassReq s -> lprintf_nl "$MyPass %s" s
1108   | MyInfoReq t -> MyINFO.print t
1109   | MyNickReq t -> MyNick.print t
1110   | NickListReq t -> NickList.print t
1111   | OpListReq t -> OpList.print t
1112   | QuitReq t -> Quit.print t
1113   | RevConnectToMeReq t -> RevConnectToMe.print t
1114   | SearchReq t -> Search.print t
1115   | SendReq -> Send.print ()
1116   | SRReq t -> SR.print t
1117   | SupportsReq t -> Supports.print t
1118   | ToReq t -> To.print t
1119   | UGetBlockReq t -> UGetBlock.print t
1120   | UnknownReq s -> lprintf_nl "UnknownReq: (%s)..." s
1121   | UserCommandReq -> lprintf_nl "UserCommand"
1122   | UserIPReq st -> UserIP.print st
1123   | ValidateNickReq s -> lprintf_nl "$ValidateNick %s" s
1124   | ValidateDenideReq s -> lprintf_nl "$ValidateDenide %s" s
1125   | VersionReq s -> lprintf_nl "$Version %s" s )
1126
1127 (* server incoming messages handler *) (* |7467673|738838383| *)
1128 let dc_handler_server f sock nread =
1129   let b = TcpBufferedSocket.buf sock in
1130   (try
1131     let rec iter nread =
1132       if nread > 0 then begin
1133         let pos = String.index_from b.buf b.pos '|' in
1134         if pos < (b.pos + b.len) then begin
1135           let len = pos - b.pos in
1136           let s = String.sub b.buf b.pos len in
1137           buf_used b (len+1);
1138           begin
1139             try f (dc_parse true s) sock
1140             with exn -> lprintf_nl "server handler %S : %s" s (Printexc2.to_string exn)
1141           end;
1142           iter b.len
1143         end
1144       end
1145     in
1146     iter nread
1147   with Not_found -> () )
1148
1149 (* client incoming messages handler *)
1150 let dc_handler_client c fm nm dm sock nread = (* fm = (read_first_message false) t sock *)
1151                                               (* nm = DcClients.client_reader c t sock *)
1152                                               (* dm = DcClients.client_downloaded c sock nread  *)
1153   let b = TcpBufferedSocket.buf sock in
1154   (try
1155     let rec iter nread =
1156       if nread > 0 then begin
1157         (match !c with
1158         | Some c when c.client_receiving <> Int64.zero -> (* if we are downloading from client ...*)
1159             dm c sock nread
1160         | _ ->                                            (* or message is a new connection ... *)
1161             let pos = String.index_from b.buf b.pos '|' in
1162             if pos < (b.pos + b.len) then begin
1163               let len = pos - b.pos in
1164               let s = String.sub b.buf b.pos len in
1165               let msg = dc_parse false s in
1166               buf_used b (len+1);
1167               begin try
1168                 (match !c with
1169                 | None -> c := fm msg sock (* do this only once per new non-existing client eg. we are in ACTIVE mode *)
1170                 | Some c -> nm c msg sock); (* after initial connection is established *)
1171               with exn -> lprintf_nl "client handler %S : %s" s (Printexc2.to_string exn)
1172               end;
1173               iter b.len
1174             end )
1175       end
1176     in
1177     iter nread
1178   with Not_found ->
1179     (*lprintf_nl "Message from client cut: (%s)" (String.sub b.buf b.pos b.len);*)
1180     () )
1181
1182 let buf = Buffer.create 100
1183
1184 (* To servers and to clients outgoing messages *)
1185 let dc_send_msg sock m =
1186   Buffer.reset buf;
1187   dc_write buf m;
1188   Buffer.add_char buf '|';
1189   let s = Buffer.contents buf in
1190   write_string sock s
1191