1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
3 This file is part of mldonkey.
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.
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.
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
25 open TcpBufferedSocket
29 let log_prefix = "[dcPro]"
32 lprintf_nl2
log_prefix fmt
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
44 index := String2.search_from s 0 find_str
46 | Not_found -> index := -1 );
47 if (!index = -1) then begin
50 str := !str ^ String2.before s !index ^ to_str;
51 rest := String2.after s (!index+flen);
55 if not ok then replace !rest
60 (* Decode chat messages *)
61 (* You can now use $ and | in the chat. *)
62 (* DC++ uses the HTML standard $ and | to replace them *)
63 let dc_decode_chat s
= (* convert html characters $ to '|' and | and & from text *)
64 let s = dc_replace_str_to_str s "|" "|" in
65 let s = dc_replace_str_to_str s "$" "$" in
66 let s = dc_replace_str_to_str s "&" "&" in
69 (* Encode chat messages *)
70 let dc_encode_chat s = (* convert '|'and '$' to html characters $ and | *)
71 let s = String2.replace s '$'
"$" in
72 let s = String2.replace s '
|'
"|" in
73 let s = String2.replace s '
&'
"&" in
76 (* Reuseable modules for simple commands *)
77 module Empty
= functor(M
: sig val msg
: string end) -> struct
79 let print t
= lprintf_nl "%s" M.msg
83 module Empty2
= functor(M
: sig val msg
: string end) -> struct
85 let print t
= lprintf_nl "%s" M.msg
86 let write buf t
= Printf.bprintf buf
"$%s" M.msg
89 (* DC uses 1-byte encodings *)
90 (* Probably better convert to/from utf at transport layer!? *)
93 (* FIXME need hub-specific encodings *)
94 (* Charset.convert Charset.UTF_8 Charset.CP1252 s *)
96 Charset.convert
Charset.UTF_8
(Charset.charset_from_string
!!DcOptions.default_encoding
) s
98 _
-> Charset.Locale.to_locale
s
102 Charset.convert
(Charset.charset_from_string
!!DcOptions.default_encoding
) Charset.UTF_8
s
104 _
-> Charset.Locale.to_utf8
s
107 match String2.split
s '
/'
with
109 if is_valid_tiger_hash tth
then NameTTH tth
else failwith
"Invalid TTH"
112 if List.exists (function "." | ".." -> true | _ -> false) path then failwith "Invalid path" else NameShared path
114 | [file
] -> NameSpecial file
115 | _
-> failwith
("Invalid name : " ^
s)
117 let show_name = function
118 (* | NameShared l -> "/" ^ String.concat "/" l *)
120 | NameTTH tth
-> "TTH/" ^ tth
122 module SimpleCmd
(M
: sig val msg
: string end) = struct
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
)
129 (*module NickAndAddr (M: sig val msg : string end) = struct
136 let (nick, rem) = String2.cut_at s ' ' in
137 let (ip, port) = String2.cut_at rem ':' in {
139 ip = Ip.of_string ip;
140 port = int_of_string port;
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;
146 module SimpleNickList
= functor (M
: sig val cmd
: string end) -> struct
149 let list = String2.split_simplify t '$'
in
150 let list = List.rev_map
(fun nick
-> dc_to_utf nick
) list in
153 lprintf
"%s list ( " M.cmd
;
154 List.iter
(fun s -> lprintf
"%s " s) t
;
157 Buffer.add_char buf ' '
;
158 List.iter
(fun nick
-> Printf.bprintf buf
"%s %s$$" M.cmd
(utf_to_dc nick
)) t
161 (* Command modules *)
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
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
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 ‘/’. *)
197 match String2.split
s ' '
with
198 | adc_type
:: ident
:: start_pos
:: bytes
:: flags
->
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"
207 start_pos
= Int64.of_string start_pos
;
208 bytes
= Int64.of_string bytes
;
209 zl
= List.mem
"ZL1" flags
;
211 | _
-> failwith
"Invalid ADC GET format"
213 if !verbose_msg_clients
|| !verbose_upload
then
214 lprintf_nl "Error in AdcGet parsing : %s" (Printexc2.to_string exn
);
218 let adc_type,ident
,flags
=
220 (* | AdcTthl tth -> "tthl", show_name (NameTTH tth), [] *)
221 | AdcFile name
-> "file", show_name name
, ""
222 | AdcList
(path
,re
) -> "list", path
, " RE1"
224 let flags = if t
.zl
then flags ^
" ZL1" else flags in
225 Printf.sprintf
"$%s %s %s %Ld %Ld%s" A.command
226 adc_type ident t
.start_pos t
.bytes
flags
228 let print t
= lprintf_nl "%s" (to_string t
)
229 let write buf t
= Buffer.add_string buf
(to_string t
)
233 module AdcGet
= Adc
(struct let command = "ADCGET" end)
235 module AdcSnd
= Adc
(struct let command = "ADCSND" end)
237 module Canceled
= Empty2
(struct let msg = "Canceled" end)
239 module ConnectToMe
= struct
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
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
;
258 let print t
= lprintf_nl "$ConnectToMe %s %s:%d" t
.nick
(Ip.to_string t
.ip
) t
.port
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
);
265 module Direction
= struct
267 direction
: dc_direction
;
270 let txt_upload = "Upload"
271 let txt_download = "Download"
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
283 let print t
= lprintf_nl "Direction %s %d" (
284 match t
.direction
with
285 | Download _
-> txt_download
286 | Upload _
-> txt_upload) t
.level
289 Printf.bprintf buf
"$Direction %s %d"
290 (match t
.direction
with
291 | Download _
-> txt_download
292 | Upload _
-> txt_upload)
296 module FileLength
= struct
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
303 module ForceMove
= SimpleCmd
(struct let msg = "ForceMove" end)
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));
316 let print t
= lprintf_nl "Get [%s] %Ld" t
.filename t
.pos
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
)
322 module GetListLen
= Empty2
(struct let msg = "GetListLen" end)
324 module Hello
= SimpleCmd
(struct let msg = "Hello" end)
325 module HubName
= SimpleCmd
(struct let msg = "HubName" end)
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
340 extended_protocol
: bool;
342 let ext_txt = "EXTENDEDPROTOCOL"
344 match String2.splitn
s ' '
1 with
346 extended_protocol
= (String2.string_ncmp key
ext_txt (String.length
ext_txt)); (* if s has ext_txt at start, return true *)
349 | _
-> raise Not_found
350 let print t
= lprintf_nl "$Lock %s%s Pk=%s" ext_txt t
.key
Autoconf.current_version
352 Printf.bprintf buf
" %s%s Pk=%s" ext_txt t
.key
Autoconf.current_version
355 module Message
= struct
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;
366 if (m
.[0] = '
<'
) then begin
367 (match String2.splitn m ' '
1 with
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
)
375 let m = dc_decode_chat m in
376 { from = "-"; message
= dc_to_utf m }
379 let print t
= lprintf_nl "<Message> (%s) (%s)" t
.from t
.message
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
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 *)
399 open_upload_slot
= 0;
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$
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 *)
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
)
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
)
433 if tagline
= "" then return_no_tags dest nick tagline email
size
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
)
440 (match String2.splitn
tagline ' '
1 with (* split desc with one ' ' *)
442 let version = ref "" in
443 let mode = ref 'A'
in
444 let hubs = ref (0 , 0 , 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
452 | 'v'
(* GreylinkDC++ *)
453 | 'V'
-> (try version := String2.after
str 2 with _
-> () )
454 | 'M'
-> if (str.[2] = 'P'
) then mode := 'P'
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 ) )
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 _
-> () )
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.. *)
472 description
= tagline;
473 client_brand
= client
;
479 open_upload_slot
= !upload;
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
490 return_no_tags dest nick
tagline email
size)
492 | _
-> raise Not_found
) (* MyInfo basic structure was wrong *)
494 lprintf_nl "Error in MyInfo parsing";
497 let print t
= lprintf_nl "$MyINFO %s %s %s %s %Ld" t
.dest t
.nick t
.description t
.conn_speed t
.sharesize
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
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)
509 module RevConnectToMe
= struct
515 let (orig
, dest) = String2.cut_at
s ' '
in {
516 dest = dc_to_utf dest;
517 orig
= dc_to_utf orig
;
519 let print t
= lprintf_nl "$RevConnectToMe %s %s" t
.orig t
.dest
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
)
525 module Search
= struct
531 sizelimit
: sizelimit
;
533 words_or_tth
: string;
536 (* Active user: $Search <ip>:<port> <searchstring>
537 Passive user: $Search Hub:<requestornick> <searchstring>
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.
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")
559 <searchpattern> = used by other users to determine if any files match. Non-alphanumeric characters
560 (including spaces and periods) are replaced by '$'.
562 64.78.55.32:412 T?T?500000?1?Gentoo$2005
563 Hub:SomeNick T?T?500000?1?Gentoo$2005
570 (match String2.split_simplify
s ' '
with
571 | [orig ; search
] -> orig , search
572 | _
-> raise Not_found
)
574 let passive , nick
, ip
, port
=
575 (match String2.splitn
orig '
:'
1 with
577 true, dc_to_utf nick
, empty_string
, empty_string
579 false, empty_string
, ip
, port
580 | _
-> raise Not_found
)
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 '$' ' '
;
594 let words = dc_to_utf words in
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))
607 words_or_tth
= words;
609 | _
-> raise Not_found
)
611 if !verbose_msg_clients
then lprintf_nl "Search parsing error: (%s)" s;
614 let print t
= lprintf_nl "$Search %s %s %d %s" t
.nick t
.ip t
.filetype t
.words_or_tth
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
622 (match t
.sizelimit
with
623 | AtMost n
-> Int64.to_string n
624 | AtLeast n
-> Int64.to_string n
628 if t
.filetype = 9 then s_tth ^ t
.words_or_tth
(* if TTH search is wanted, send root hash *)
630 let s = ref (String.copy t
.words_or_tth
) in (* otherwise send search words *)
631 String2.replace_char
!s char32 '$'
;
636 (*if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)*)
639 module Send
= Empty2
(struct let msg = "Send" end)
649 server_name
: string;
652 server_port
: string;
653 to_nick
: string option;
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
)
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 *)
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
)
682 (match String2.splitn
size_and_slots ' '
1 with (*...<0x05>437 3/4<0x05>... *)
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
)
692 let server_name, tth
, ip
, port
=
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
698 (match String2.split
server_addr '
:'
with
699 | [ip ; port
] -> ip, port
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, "", "" )
712 owner
= dc_to_utf owner
;
713 directory = directory;
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;
724 | _
-> raise Not_found
)
725 | _
-> raise Not_found
)
726 | _
-> raise Not_found
)
728 if !verbose_msg_clients
then lprintf_nl "Error in SR parsing (%s)" s;
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| */ *)
735 Printf.bprintf buf
" %s %s\\%s%c%s %d/%d%cTTH:%s (%s:%s)"
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
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)*)
746 module Supports
= struct (* Extended DC++ *)
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"
756 let x_hubtopic = "HubTopic"
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"
766 let x_clientid = "ClientID"
767 let x_chunk = "CHUNK"
768 let x_gettestzblock = "GetTestZBlock"
769 let x_getcid = "GetCID"
771 let create_supports_string 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 );
800 let support_exists lst x
=
801 let result = ref false in
803 if !result = false then
807 if hd
= x
then result := true
815 let l = String2.split
m ' '
in
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);
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);
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
)
854 if ((String.length
s) > 75000) then begin
855 lprintf_nl "Overlength $To: (%s)" (shorten_string
s 50);
858 (match String2.splitn
s ' '
4 with
859 | [dest ; "From:" ; from ; _
; message
] ->
861 let m = dc_decode_chat message
in
864 dest = dc_to_utf dest;
865 from = dc_to_utf from;
866 message
= dc_to_utf m;
868 | _
-> raise Not_found
)
870 let print t
= lprintf_nl "$To (%s) (%s) (%s)" t
.dest t
.from t
.message
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
879 module UGetBlock
= struct
886 (match String2.splitn
s ' '
2 with
887 | [pos; bytes
; filename
] ->
888 let filename = dc_to_utf filename in
890 ufilename
= filename;
891 ubytes
= Int64.of_string bytes
;
892 upos
= Int64.of_string
pos;
894 | _
-> raise Not_found
)
895 let print t
= lprintf_nl "Get %Ld %Ld %s" t
.upos t
.ubytes t
.ufilename
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
)
901 module UserIP
= struct
904 let parse s = String2.split_simplify
s '$'
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
)
913 lprintf
"UserIP list (";
914 List.iter
(fun s -> lprintf
"%s " (dc_to_utf s)) st
;
918 Printf.bprintf buf
"$UserIP %s" (String.concat
"$$" (List.map
utf_to_dc st
))
921 (* Message type definitions and basic parsing *)
923 | AdcGetReq
of AdcGet.t
924 | AdcSndReq
of AdcSnd.t
927 | ConnectToMeReq
of ConnectToMe.t
928 | DirectionReq
of Direction.t
930 | FailedReq
of string
931 | FileLengthReq
of FileLength.t
932 | ForceMoveReq
of ForceMove.t
937 | HelloReq
of Hello.t
939 | HubNameReq
of HubName.t
940 | HubTopicReq
of string
943 | LogedInReq
of string
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
954 | RevConnectToMeReq
of RevConnectToMe.t
955 | SearchReq
of Search.t
958 | SupportsReq
of DcTypes.dc_supports
960 | UGetBlockReq
of UGetBlock.t
961 | UnknownReq
of string
963 | UserIPReq
of UserIP.t
964 | ValidateDenideReq
of string
965 | ValidateNickReq
of string
966 | VersionReq
of string
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
971 source: true = server, false = client *)
972 let dc_parse source
s =
974 let ws = String2.splitn
s ' '
1 in
976 | [] -> UnknownReq
"" (* ignore empty messages *)
977 | [cmd ; args
] -> (* two part message - cmd and args *)
978 if (cmd.[0] = '$'
) then (* Commands 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
1019 | "$BadPass" -> BadPassReq
1020 | "$Canceled" -> CanceledReq
1021 | "$GetListLen" -> GetListLenReq
1022 | "$GetPass" -> GetPassReq
1023 | "$HubIsFull" -> HubIsFullReq
1024 | "$MaxedOut" -> MaxedOutReq
1025 | "$Send" -> SendReq
1026 | _
-> UnknownReq
s )
1028 MessageReq
(Message.parse s)
1029 | _
-> UnknownReq
s )
1033 let dc_write buf
m =
1035 | AdcGetReq t
-> AdcGet.write buf t
1036 | AdcSndReq t
-> AdcSnd.write buf t
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"
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 )
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 )
1127 (* server incoming messages handler *) (* |7467673|738838383| *)
1128 let dc_handler_server f sock nread
=
1129 let b = TcpBufferedSocket.buf sock
in
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
1139 try f
(dc_parse true s) sock
1140 with exn
-> lprintf_nl "server handler %S : %s" s (Printexc2.to_string exn
)
1147 with Not_found
-> () )
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
1155 let rec iter nread
=
1156 if nread
> 0 then begin
1158 | Some
c when c.client_receiving
<> Int64.zero
-> (* if we are downloading from client ...*)
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
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
)
1179 (*lprintf_nl "Message from client cut: (%s)" (String.sub b.buf b.pos b.len);*)
1182 let buf = Buffer.create
100
1184 (* To servers and to clients outgoing messages *)
1185 let dc_send_msg sock
m =
1188 Buffer.add_char
buf '
|'
;
1189 let s = Buffer.contents
buf in