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