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
20 open CommonInteractive
25 open CommonInteractive
30 open TcpBufferedSocket
47 let log_prefix = "[dcCli]"
50 lprintf_nl2
log_prefix fmt
52 (* Check current client state and setup for future proceeding with client *)
53 let set_client_state_on_disconnect c
=
54 (match c
.client_state
with
55 | DcDownloadWaiting file
(* if client is downloading a file ...*)
57 | DcDownloadConnecting
(file
,_
) ->
58 (*if !verbose_download then
59 lprintf_nl "Client (%s) state is (DcDownload/-Waiting/-Connecting file) on closing socket" (clients_username c);*)
60 c
.client_state
<- DcDownloadWaiting file
; (* continue downloading later *)
61 set_client_state c NewHost
62 | DcUploadList file_fd
(* if client was handling file lists... *)
63 | DcDownloadList file_fd
->
64 (*if !verbose_upload || !verbose_download then
65 lprintf_nl "Client (%s) state is (DcUploadList/DcDownloadList) on closing socket" (clients_username c); *)
66 c
.client_state
<- DcIdle
;
67 Unix32.close file_fd
; (* close file descriptor and remove client *)
69 | DcUploadStarting
(dcsh
,_
,_
)
70 | DcUpload
(dcsh
,_
,_
,_
) -> (* if client was uploading file ... *)
71 (*if !verbose_upload then
72 lprintf_nl "Client (%s) state is (DcUpload/UploadStarting) on closing socket" (clients_username c);*)
73 if not
(counts_as_minislot dcsh
.dc_shared_size
) then dc_remove_uploader
(); (* check if we have to free a slot *)
74 set_client_has_a_slot
(as_client c
.client_client
) NoSlot
; (* inform GUI *)
75 (match c
.client_state
with
76 | DcUpload
(_
,file_fd
,_
,_
) -> Unix32.close file_fd
78 c
.client_state
<- DcIdle
;
80 | DcDownloadListWaiting
(* filelist downloading *)
81 | DcDownloadListConnecting _
->
82 (*if !verbose_download then
83 lprintf_nl "Client (%s) state is (DcDownloadListWaiting/-Connecting) on closing socket" (clients_username c);*)
84 c
.client_state
<- DcDownloadListWaiting
;
85 set_client_state c NewHost
;
86 | DcConnectionStyle _
->
87 (*if !verbose_upload || !verbose_download then
88 lprintf_nl "Client (%s) state is (DcConnectionStyle) on closing socket" (clients_username c);*)
89 c
.client_state
<- DcIdle
;
91 | DcUploadListStarting _
92 | DcUploadDoneWaitingForMore
94 (*if !verbose_upload then
95 lprintf_nl "Client (%s) state is (DcUploadListStarting/DoneWaitingForMore) on closing socket" (clients_username c);*)
96 c
.client_state
<- DcIdle
;
100 (* check that file can be started and no other client is downloading it *)
101 let can_file_start_downloading f
=
103 (match (file_state f
) with (* check file state *)
104 | FileDownloaded
| FileShared
| FileCancelled
| FileAborted _
| FilePaused
-> raise BreakIter
106 List.iter
(fun c
-> (* check files all other clients that they are not already possibly loading *)
107 if is_client_blocking_downloading c
then raise BreakIter
112 (* Try to find alternative client to file *)
113 let find_downloadable_client_for_file file
= (* CHECK possible user state also... *)
115 List.iter
(fun c
-> (* chech all files sources *)
116 (match c
.client_user
with
118 if (can_user_start_downloading u
) then begin
119 if is_client_waiting c
then begin
120 (match c
.client_error
with
121 | NoError
| NoFreeSlots
| UploadError
-> raise
(Found_client c
)
122 | FileNotAvailable
| UserNotReachable
| ClosedOnInit
| ConnectionResetByPeer
123 | UserDontReplyOnTime
-> () )
130 | Found_client c
-> Some c
)
132 (* Disconnect client with proper even if no socket yet handling *)
133 let dc_disconnect_client c reason
=
134 (match c
.client_sock
with
136 connection_failed c
.client_connection_control
;
137 dc_set_client_disconnected c reason
;
138 TcpBufferedSocket.close sock reason
;
139 c
.client_sock
<- NoConnection
;
140 | ConnectionWaiting token
->
142 c
.client_sock
<- NoConnection
;
144 set_client_state_on_disconnect c
;
145 (match c
.client_user
with
147 user
.user_state
<- UserIdle
; (* initialize also possible user *)
150 (* Move file to last in global filelist *)
151 let move_file_to_last_in_files f
=
152 if List.length
!current_files
> 1 then begin
153 let list = List2.removeq_first f
!current_files
in
154 current_files
:= list @ [f
];
157 (* Move client to first in files clientlist *)
158 let move_client_to_first_in_fileslist c
=
159 (match c
.client_file
with
161 if List.length f
.file_clients
> 1 then begin
162 let list = List2.removeq_first c f
.file_clients
in
163 f
.file_clients
<- c
:: list; (* lets put this client on top of files clients *)
167 (* Move client to first in users clientlist *)
168 let move_client_to_first_in_userslist c
=
169 (match c
.client_user
with
171 if List.length u
.user_clients
> 1 then begin
172 let list = List2.removeq_first c u
.user_clients
in
173 u
.user_clients
<- c
:: list; (* lets put this client on top of users clients *)
177 (* Move client to last in users clientlist *)
178 let move_client_to_last_in_userslist c
=
179 (match c
.client_user
with
181 if List.length u
.user_clients
> 1 then begin
182 let list = List2.removeq_first c u
.user_clients
in (* lets move this client to last in users list *)
183 u
.user_clients
<- list @ [c
];
187 (* Move client to last in users clientlist *)
188 let move_client_to_last_in_fileslist c
=
189 (match c
.client_file
with
191 if List.length f
.file_clients
> 1 then begin
192 let list = List2.removeq_first c f
.file_clients
in (* lets move this client to last in files list *)
193 f
.file_clients
<- list @ [c
];
197 (* Try to find next available source to this file and make it next in line, return true if found *)
198 let find_existing_source c
=
199 (match c
.client_file
with
201 let alternative = find_downloadable_client_for_file f
in
202 (match alternative with
203 | Some ac
-> (* we have a client that we can try to download *)
204 move_client_to_first_in_fileslist ac
; (* lets top this client to be next in line to be tried *)
205 move_client_to_first_in_userslist ac
;
210 (* Send search request to server *)
211 let server_send_search s search filetype sname
=
212 if !verbose_msg_clients
&& (List.length
!connected_servers
) > 0 then
213 lprintf_nl "Sending: $Search (%s) (%s)" (shorten_string s
.server_name
20) sname
;
214 do_if_connected s
.server_sock
(fun sock
->
215 let module S
= DcProtocol.Search
in
216 let msg = DcProtocol.SearchReq
{
217 S.passive
= !!firewalled
;
218 S.nick
= if !!firewalled
then s
.server_last_nick
else empty_string
;
219 S.ip
= if !!firewalled
then empty_string
else Ip.to_string
(CommonOptions.client_ip
(Some sock
));
220 S.port
= if !!firewalled
then empty_string
else (string_of_int
!!dc_port
);
221 S.sizelimit
= NoLimit
;
222 S.filetype
= filetype
;
223 S.words_or_tth
= sname
;
225 dc_send_msg sock
msg;
226 s
.server_search
<- Some search
;
227 s
.server_search_timeout
<- last_time
() + !!search_timeout
;
230 (* Received SR from servers or by udp *)
231 let received_new_search_result s
msg =
232 if s
.server_search_timeout
< last_time
() then s
.server_search
<- None
;
233 (match s
.server_search
with
237 let user = new_user
(Some s
) msg.S.owner
in (* create possibly new user *)
238 let result = new_result
user msg.S.tth
msg.S.directory
msg.S.filename
msg.S.filesize
in (* new or retrieve existing *)
239 (* result dir,filename,size *)
240 ignore
(add_info_to_result
result user msg.S.tth
msg.S.directory
); (* add info to dc-fields *)
241 CommonInteractive.search_add_result
false q
result;
242 if !!autosearch_by_tth
&& (msg.S.tth
<> empty_string
) then begin
244 let f = Hashtbl.find dc_files_by_unchecked_hash
msg.S.tth
in (* if this hash is in downloads *)
245 if (List.length
f.file_clients
< !!max_sources_file
) then begin
247 List.iter
(fun c
-> (* check if some of users client is already on this files list *)
248 if (List.mem c
f.file_clients
) then raise BreakIter
250 let c = new_client_to_user_with_file
user f in
251 c.client_state
<- DcDownloadWaiting
f;
252 if !verbose_msg_clients
then lprintf_nl "New client (%s) created by tth search to file (%s)"
253 (clients_username
c) f.file_name
254 with _
-> () ) (* user has already client with this file *)
256 with _
-> () ) (* this file is in active downloads *)
259 (* Create new search automatically if possible *)
260 let create_new_search f =
261 let query = QAnd
(QHasField
(Field_Type
, "TTH") , (QHasWord
f.file_unchecked_tiger_root
)) in
262 let search = CommonSearch.new_search
(CommonUserDb.find_ui_user
CommonUserDb.admin_user_name
)
263 (let module G
= GuiTypes
in
265 G.search_query
= query;
266 G.search_max_hits
= 1000;
267 G.search_type
= RemoteSearch
;
268 G.search_network
= network
.network_num
;
271 dc_with_connected_servers
(fun s
-> (* iter all servers *)
272 server_send_search s
search 9 f.file_unchecked_tiger_root
274 (match !dc_last_autosearch
with
275 | Some s
-> CommonSearch.search_forget
(CommonUserDb.find_ui_user
CommonUserDb.admin_user_name
) s
277 dc_last_autosearch
:= Some
search;
278 dc_last_autosearch_time
:= current_time
();
279 f.file_autosearch_count
<- succ
f.file_autosearch_count
281 let create_autosearch () =
282 let s_time_out = float !!search_timeout
in
283 let c_time = current_time
() in
284 if (!dc_last_autosearch_time
+. s_time_out) < c_time &&
285 (!dc_last_manual_search
+. s_time_out) < c_time && (List.length
!connected_servers
) > 0 then begin
286 (*lprintf_nl "Created autosearch";*)
290 List.iter
(fun c -> (* lets check that file is not already being downloaded *)
291 if is_client_blocking_downloading
c then raise BreakIter
293 if (List.length
f.file_clients
< !!max_sources_file
) &&
294 (is_valid_tiger_hash
f.file_unchecked_tiger_root
) then begin
296 raise
(Found_file
f);
301 (*lprintf_nl "Autosearch end not found"; *)
303 move_file_to_last_in_files f ) (* lets give next search to different file *)
304 (*lprintf_nl "Autosearch end file found" )*)
307 (* Memorize and take action on different client error situations *)
308 let new_client_error c error
=
309 let same_as_before = (error
= c.client_error
) in
310 if not
same_as_before then c.client_error_count
<- 1
311 else c.client_error_count
<- succ
c.client_error_count
;
313 | NoFreeSlots
-> (* MaxedOut *)
314 move_client_to_last_in_userslist c;
315 move_client_to_last_in_fileslist c;
316 c.client_error
<- NoFreeSlots
;
317 | FileNotAvailable
->
318 c.client_error
<- FileNotAvailable
;
319 (match c.client_state
with
320 | DcDownloadList _
-> (* on rare condition... eg. DC++ 0.401 *)(* TODO Try to load MyList.DcLst *)
323 move_client_to_last_in_userslist c;
324 move_client_to_last_in_fileslist c;
326 | UserNotReachable
->
327 c.client_error
<- UserNotReachable
;
329 if same_as_before then begin
330 (* what to do if connection closes on init phase without clear reason *)
331 if (is_even_to_tenths
c.client_error_count
) then begin
332 if not
(find_existing_source c) then begin (* if not available source *)
333 if !verbose_msg_clients
then
334 lprintf_nl "ClosedOnInit: (%s)" (clients_username
c);
338 c.client_error
<- ClosedOnInit
340 | ConnectionResetByPeer
->
341 if same_as_before then begin
342 (* what to do if client resets connection without error messages and without reason *)
343 if (c.client_error_count
> 10) then begin
344 if not
(find_existing_source c) then begin (* if not available source *)
345 if !verbose_msg_clients
then
346 lprintf_nl "ConnectionResetByPeer: (%s)" (clients_username
c);
350 c.client_error
<- ConnectionResetByPeer
353 c.client_error
<- UploadError
;
354 if !verbose_msg_clients
|| !verbose_upload
then
355 lprintf_nl "UploadError: (%s)" (clients_username
c);
356 (*ready_for_upload (as_client c.client_client);*) (* still try to continue upload, or what ? *)
357 | UserDontReplyOnTime
->
358 (* what to do if we have sent Rev/ConnectToMe to user but got no MyNick on time *)
359 if same_as_before then begin
360 if (is_even_to_twos
c.client_error_count
) then begin
361 if not
(find_existing_source c) then begin (* if not available source *)
362 if !verbose_msg_clients
then
363 lprintf_nl "UserDontReplyOnTime: (%s)" (clients_username
c);
365 dc_disconnect_client c (Closed_for_error
"User waiting timeout") (* disconnect connection anyway *)
368 c.client_error
<- UserDontReplyOnTime
373 (* Client connection closing handler *)
374 let client_disconnected sock reason
c =
375 (match c.client_sock
with
376 | Connection csock
->
377 if not
(sock
== csock
) then
378 if !verbose_msg_clients
|| !verbose_unexpected_messages
then
379 lprintf_nl " On (client_disconnected sock reason c) sock <> c.client_sock ?!?"
381 dc_disconnect_client c reason
383 (* Try to send connection messages to client, return true if sent *)
384 let try_connect_client c =
385 (* if connection_can_try c.client_connection_control then begin *)
386 (match c.client_user
with
389 List.iter
(fun s
-> (* find first server we are connected to iter users servers *)
390 (match s
.server_sock
with (* send to only one server *)
391 | Connection sock
-> (* if we are connected to this server already *)
392 if user.user_state
= TryingToSendFirstContact
then begin
393 if !!firewalled
then begin (* if we are in passive mode *)
394 user.user_state
<- UserActiveUserInitiating
; (* mark user to be connecting to/for us *)
396 let module C
= RevConnectToMe
in
398 C.orig
= s
.server_last_nick
;
399 C.dest
= user.user_nick
;
402 end else begin (* if we are in active mode *)
403 user.user_state
<- UserActiveMeInitiating
; (* mark user to be connecting us directly *)
405 let module C
= ConnectToMe
in
407 C.nick
= user.user_nick
;
408 C.ip
= CommonOptions.client_ip
(Some sock
);
415 | _
-> () ) (* do nothing if we are not already connected to this server *)
419 if user.user_state
= TryingToSendFirstContact
then begin (* if no connection try was sent at all *)
420 (match c.client_state
with
421 | DcDownloadConnecting
(f,_
) -> c.client_state
<- DcDownloadWaiting
f
422 | DcDownloadListConnecting _
-> c.client_state
<- DcDownloadListWaiting
423 | _
-> lprintf_nl "Wrong client state on trying to connect" );
424 new_client_error c UserNotReachable
;
425 user.user_state
<- UserIdle
; (* go back to waiting *)
428 | _
-> lprintf_nl "no user for client"; false )
430 lprintf_nl "c.client_connection_control denies connection to %s" c.client_name
433 (* Ask all files sources for download activation *)
434 let ask_file_sources_for_download f =
437 (match c.client_user
with
439 if (can_user_start_downloading u
) then begin (* check if download can be started *)
440 (match c.client_file
with
442 if (can_file_start_downloading f) then begin
443 c.client_state
<- DcDownloadConnecting
(f,current_time
());
444 u
.user_state
<- TryingToSendFirstContact
;
445 if try_connect_client c then raise
(Found_client
c)
448 end else begin (* otherwise do clients timeout checkings here *)
449 (match c.client_state
with
450 | DcDownloadListConnecting
(_
,_
,time
)
451 | DcDownloadConnecting
(_
,time
) ->
452 if (current_time
() -. time
) > float_of_int
!!client_timeout
then begin (* if waiting timeout is reached *)
453 new_client_error c UserDontReplyOnTime
;
461 | Found_client
c -> Some
c
462 | Not_found
-> None
)
464 (* Check a user pending downloads if they can be started, return client *)
465 let ask_user_for_download u
=
467 if (can_user_start_downloading u
) then begin (* check if download can be started *)
468 List.iter
(fun c -> (* that have clients ... *)
469 if (is_client_waiting
c) then begin
470 (match c.client_file
with
472 c.client_state
<- DcDownloadConnecting
(f,current_time
());
473 u
.user_state
<- TryingToSendFirstContact
;
474 if try_connect_client c then raise
(Found_client
c)
477 end else begin (* otherwise check possible clients timeout *)
478 (match c.client_state
with
479 | DcDownloadListConnecting
(_
,_
,time
)
480 | DcDownloadConnecting
(_
,time
) ->
481 if (current_time
() -. time
) > float_of_int
!!client_timeout
then begin (* if waiting timeout is reached *)
482 new_client_error c UserDontReplyOnTime
;
487 end else begin (* Check users, that have sent RevConnectToMe and we have sent ConnectToMe and we are waiting *)
492 | Found_client
c -> Some
c
493 | Not_found
-> None
)
495 (* Check all users pending downloads if they can be started *)
496 let ask_all_users_for_files () =
497 Hashtbl.iter
(fun _ u
-> (* with all users .. *)
498 ignore
(ask_user_for_download u
);
502 (* Try to resume all files *)
503 let try_to_resume_files () =
504 List.iter
(fun f -> (* with all files *)
506 ignore
(ask_file_sources_for_download f)
509 (* Get clients server and send contact messages to client *)
510 let init_connection c sock
=
511 c.client_receiving
<- Int64.zero
;
512 c.client_sock
<- Connection sock
;
513 connection_ok
c.client_connection_control
;
514 (match c.client_state
with
515 | DcConnectionStyle
(ClientActive _
) ->
516 (* we are sending to unknown client and have to decide correct state later *)
518 (match c.client_user
with
520 (match user.user_servers
with
521 | [] -> local_login
()
522 | s
:: _
-> s
.server_last_nick
) (* pick first servers nick that is known to both... *)
523 | _
-> local_login
() )
525 dc_send_msg sock
(MyNickReq
my_nick); (* send nick and lock requests to client *)
526 dc_send_msg sock
(LockReq
{
527 Lock.info
= empty_string
;
528 Lock.key
= DcKey.create_key
;
529 Lock.extended_protocol
= true
531 | DcDownloadListConnecting _
532 | DcConnectionStyle
(MeActive _
) -> ()
534 if !verbose_unexpected_messages
then lprintf_nl "In (init_connection) c.client_state was invalid";
537 let print_client_error sock txt
=
538 ignore
(Printf.sprintf
" %s (%s)" txt
539 (match find_sockets_client sock
with
540 | Some
c -> (clients_username
c)
541 | _
-> "(Client not found)" )
544 (* Client handler for if proper connection yet not exist *)
545 let client_handler sock event
=
547 | BASIC_EVENT LTIMEOUT
->
548 if !verbose_msg_clients
then
549 print_client_error sock
"BASIC_EVENT LTIMEOUT";
550 close sock Closed_for_timeout
551 | BASIC_EVENT RTIMEOUT
->
552 if !verbose_msg_clients
then
553 print_client_error sock
"BASIC_EVENT RTIMEOUT";
554 close sock Closed_for_timeout
555 (*| WRITE_DONE -> lprintf_nl " Event: WRITE_DONE";
556 | CAN_REFILL -> lprintf_nl " Event: CAN_REFILL";
557 | CONNECTED -> lprintf_nl " Event: CONNECTED";*)
559 if !verbose_msg_clients
then
560 print_client_error sock
"Event: BUFFER_OVERFLOW";
561 close sock Closed_for_overflow
562 (*| READ_DONE _ -> lprintf_nl " Event: READ_DONE";*)
563 | BASIC_EVENT
(CLOSED reason
) ->
564 (match find_sockets_client sock
with
566 if !verbose_msg_clients
then
567 lprintf_nl "BASIC_EVENT CLOSED: (%s) (%s)" (closing_reason_to_text reason
) (clients_username
c);
568 new_client_error c ClosedOnInit
;
569 dc_disconnect_client c reason
;
571 if !verbose_msg_clients
then
572 lprintf_nl "BASIC_EVENT CLOSED: No client exists for socket on CLOSE" )
573 | BASIC_EVENT WTIMEOUT
->
574 if !verbose_msg_clients
then
575 print_client_error sock
"BASIC_EVENT WTIMEOUT";
576 close sock Closed_for_timeout
577 (* | BASIC_EVENT CAN_READ -> lprintf_nl " Event: Other BASIC_EVENT CAN_READ"*)
578 (* | BASIC_EVENT CAN_WRITE -> lprintf_nl " Event: Other BASIC_EVENT CAN_WRITE"*)
581 (* Get first message from totally new client, return new client *)
582 let read_first_message t sock
=
584 | MyNickReq n
-> (* if very first client to client message is $MyNick, then continue... *)
585 if !verbose_msg_clients
then lprintf_nl "Received FIRST MyNick with name (%s)" n
;
587 let u = search_user_by_name n
in (* check if user with this name exists *)
589 (match u.user_state
with
590 | UserActiveMeInitiating
-> (* client already present, find the right one *)
593 (match fc
.client_state
with
594 | DcDownloadListConnecting _
| DcDownloadConnecting _
-> raise
(Found_client fc
)
597 if !verbose_msg_clients
|| !verbose_unexpected_messages
then
598 lprintf_nl "In FIRST MyNick users client (%s) state not correct" u.user_nick
;
601 | Found_client fc
-> fc
)
602 | UserPassiveUserInitiating _
-> (* create new client *)
603 let c = new_client
() in
604 c.client_name
<- Some n
;
605 add_client_to_user
c u;
608 if !verbose_msg_clients
|| !verbose_unexpected_messages
then
609 lprintf_nl "In FIRST MyNick user (%s) state not correct" n
;
612 set_client_state
c (Connected
0);
613 TcpBufferedSocket.set_closer sock
(fun _ reason
-> client_disconnected sock reason
c);
614 (match c.client_state
with
615 | DcDownloadListConnecting _
-> ()
617 (match u.user_state
with
618 | UserPassiveUserInitiating _
->
619 c.client_state
<- DcConnectionStyle
(MeActive
(Download
0)) (* level is set after $Directions *)
620 | UserActiveMeInitiating
->
621 c.client_state
<- DcConnectionStyle
(MeActive
(Upload
0))
623 if !verbose_msg_clients
|| !verbose_unexpected_messages
then
624 lprintf_nl "Should not happen: In FIRST MyNick user (%s)" n
;
626 u.user_state
<- UserIdle
; (* initialize user_state for later correct usage *)
627 c.client_addr
<- Some
(TcpBufferedSocket.peer_addr sock
);
628 init_connection c sock
;
629 Some
c (* return client *)
631 close sock
(Closed_for_error
"Closed in FIRST MyNick");
632 None
) (* return no client *)
633 | _
-> (* all other first messages are ignored and connection is closed *)
634 if !verbose_msg_clients
then
635 lprintf_nl "In FIRST message from client: not MyNick";
636 close sock
(Closed_for_error
"First message not MyNick");
637 None
) (* return no client *)
639 (* Get combination on own and client supports *)
640 let get_client_supports c = (* return ( xmlbzlist , adc ,tthf ) xmlbzlist means also ugetblock *)
641 let xmlbzlist , adc
, tthf
=
642 (match c.client_supports
with
644 (mldonkey_dc_client_supports
.xmlbzlist && c_supports
.xmlbzlist), (* own support && clients support *)
645 (mldonkey_dc_client_supports
.adcget
&& c_supports
.adcget
),
646 (mldonkey_dc_client_supports
.tthf
&& c_supports
.tthf
)
647 | None
-> false,false,false )
649 xmlbzlist , adc
, tthf
651 (* Send download commands to client *)
652 let dc_send_download_command c sock
=
653 let xmlbzlist, adc
, tthf
= get_client_supports c in
655 match c.client_state
with
657 let separator = String2.of_char '
/'
in
658 let fname = file
.file_directory ^
separator ^ file
.file_name
in
659 let preload_bytes = (* calculate preread bytes position *)
660 let from_pos = file_downloaded file
in
661 if from_pos < int64_kbyte
then begin (* if read under 1k bytes from client, start over *)
662 c.client_pos
<- Int64.zero
;
665 c.client_pos
<- from_pos;
669 c.client_preread_bytes_left
<- preload_bytes;
670 `Normal
(fname, file
.file_unchecked_tiger_root
), c.client_pos
-- (Int64.of_int
preload_bytes)
672 c.client_pos
<- Int64.zero
;
673 `List
(if xmlbzlist then mylistxmlbz2
else mylist
), c.client_pos
675 if !verbose_msg_clients
|| !verbose_download
then
677 let (fname,tth
) = match name with `Normal
(name,tth
) -> name,tth
| `List
name -> name,"" in
678 lprintf_nl "Sending $Get/$ADCGET: (%s)(%s)(%s)(%Ld)" (clients_username
c) fname tth
from_pos;
680 let msg = match adc
, tthf
, name with
681 | true, true, `Normal
(_
,tth
) when tth
<> "" ->
683 AdcGet.adctype
= AdcFile
(NameTTH tth
);
684 start_pos
= from_pos;
685 bytes
= Int64.minus_one
; (* TODO load file from from_pos to anywhere *)
688 | true, _
, `List
name ->
690 AdcGet.adctype
= AdcFile
(NameSpecial
name); (* FIXME AdcList *)
691 start_pos
= from_pos;
692 bytes
= Int64.minus_one
;
695 | _
, _
, (`Normal
(name,_
) | `List
name) ->
696 if xmlbzlist then (* if client supports ugetblock ...*)
698 UGetBlock.ufilename
= name;
699 UGetBlock.ubytes
= Int64.minus_one
;
700 UGetBlock.upos
= from_pos;
702 else (* else send normal GET *)
705 Get.pos
= Int64.succ
from_pos }
709 (* clients messages normal reader *)
710 let rec client_reader c t sock
=
715 (*if !verbose_msg_clients then lprintf_nl "Received $Direction (%s)" (clients_username c);*)
716 (match c.client_state
with
717 | DcDownloadListConnecting
(our_level
,_
,_
) (* We are downloading filelist *)
718 | DcConnectionStyle
(ClientActive
(Upload our_level
)) (* We are in passive mode *)
719 | DcConnectionStyle
(MeActive
(Upload our_level
)) -> (* We are in active mode, client needs to upload) *)
720 (match t
.Direction.direction
with
722 if !verbose_msg_clients
then
723 lprintf_nl "We have a conflict with (%s), both want to download..." (clients_username
c);
724 if (t
.Direction.level
> our_level
) then begin (* client gets to start download first *)
725 if !verbose_msg_clients
then lprintf_nl " Client won the election...";
726 (match c.client_state
with (* memorize list loading if that is the case *)
727 | DcConnectionStyle _
-> (* if file was tried to download ... *)
728 let nc = new_copy_client
c in
729 nc.client_sock
<- NoConnection
;
730 nc.client_addr
<- None
;
731 (match c.client_file
with
733 add_client_to_file
nc file
;
734 (match c.client_user
with
736 add_client_to_user
nc user;
738 nc.client_state
<- DcDownloadWaiting file
740 remove_client_from_clients_file
c
741 | _
-> (* DcDownloadListConnecting *) (* if filelist was tried to download *)
742 let nc = new_copy_client
c in
743 nc.client_sock
<- NoConnection
;
744 nc.client_addr
<- None
;
745 (match c.client_user
with
746 | Some
user -> add_client_to_user
nc user
748 nc.client_state
<- DcDownloadListWaiting
);
749 (* we change our direction *)
750 (match c.client_state
with (* check which one is the case *)
751 | DcConnectionStyle
(ClientActive
(Upload _
)) -> (* if client was initiating *)
752 c.client_state
<- DcConnectionStyle
(ClientActive
(Download
65535)) (* 65535 means to KeyReq that *)
753 | DcConnectionStyle
(MeActive
(Upload _
)) (* direction is changed *)
754 | DcDownloadListConnecting _
-> (* if we were initiating *)
755 c.client_state
<- DcConnectionStyle
(MeActive
(Download
65535))
757 (* we check in GetReq if we can start a new download immediately *)
759 end else if (t
.Direction.level
< our_level
) then begin (* we win and start downloading *)
760 if !verbose_msg_clients
then lprintf_nl " We won the election..."
761 end else (* otherwise close connection *)
762 if !verbose_msg_clients
then
763 lprintf_nl " Stalemate (levels are equal), closing";
764 close sock
(Closed_for_error
"Negotiation download: Stalemate" )
765 | _
-> () ) (* Upload *)
766 | DcConnectionStyle
(MeActive
(Download our_level
))
767 | DcConnectionStyle
(ClientActive
(Download our_level
)) -> (* connection is ready for uploading *)
768 (match t
.Direction.direction
with
769 | Upload level
-> (* Active mode and client wants to upload too ?? *)
770 if !verbose_msg_clients
then lprintf_nl "We have a conflict, both want to upload...";
771 (match c.client_state
with
772 | DcConnectionStyle MeActive _
->
773 if !verbose_msg_clients
then
774 lprintf_nl " and client (%s) is in passive mode" (clients_username
c)
776 if !verbose_msg_clients
then
777 lprintf_nl " and client (%s) is in active mode" (clients_username
c) );
778 close sock
(Closed_for_error
"Negotiation upload: conflict" );
779 | _
-> () ) (* Download *)
781 if !verbose_msg_clients
|| !verbose_unexpected_messages
then
782 lprintf_nl "In Direction: client state invalid";
783 close sock
(Closed_for_error
"Negotiation: client state invalid" ) )
786 | FailedReq errortxt
->
787 if !verbose_msg_clients
then begin
789 | ErrorReq _
-> lprintf_nl "Received (%s) from (%s)" errortxt
(clients_username
c)
790 | _
-> lprintf_nl "Received (%s) from (%s)" errortxt
(clients_username
c))
792 (match String2.split_simplify errortxt ' '
with
793 | [ _
; "File" ; txt1
; txt2
] ->
794 (* $Error File Not Available
795 $Error File not available *)
796 if (String.length txt1
= 3) && (txt2
.[1] = 'v'
) then new_client_error c FileNotAvailable
797 | _
-> lprintf_nl "New errortext: (%s) - make handling ??" errortxt
);
798 close sock
(Closed_for_error
(Printf.sprintf
"From client (%s): (%s)" (clients_username
c) errortxt
) )
803 if !verbose_msg_clients
then begin
805 | FileLengthReq _
-> lprintf_nl "Received $FileLength from (%s)" (clients_username
c)
806 | _
-> lprintf_nl "Received $AdcSnd from (%s)" (clients_username
c) ) (* AdcSnd *)
808 TcpBufferedSocket.set_rtimeout sock
(float !!client_read_timeout
);
809 (match c.client_state
with
813 | FileLengthReq t
-> t
814 | AdcSndReq t
-> (* check file current position with to be sended data position *)
815 let size = file_downloaded file
in
816 if !verbose_download
then
817 lprintf_nl "AdcSnd: file_downloaded=(%Ld) preread=(%d) start_pos=(%Ld)"
818 size c.client_preread_bytes_left t
.AdcSnd.start_pos
;
819 if size -- (Int64.of_int
c.client_preread_bytes_left
) = t
.AdcSnd.start_pos
then begin
820 if t
.AdcSnd.bytes = Int64.minus_one
then file_size file
else t
.AdcSnd.bytes
822 if !verbose_unexpected_messages
|| !verbose_download
then
823 lprintf_nl "AdcSnd: Current file=(%s) size=(%Ld) don't match start_pos=(%Ld) for user=(%s)"
824 file
.file_name
size t
.AdcSnd.start_pos
(clients_username
c);
827 | _
-> raise Not_found
)
829 c.client_receiving
<- bytes;
830 c.client_error
<- NoError
;
831 file_add file
.file_file FileDownloading
;
834 dc_send_msg sock SendReq
835 | _
-> () ) (* AdcSnd *)
837 | DcDownloadListConnecting _
->
838 let filelist_name = Filename.concat filelist_directory
(
839 (match c.client_user
with
841 (match c.client_supports
with
843 if c_supports
.xmlbzlist then u.user_nick ^ mylistxmlbz2_ext
844 else u.user_nick ^ mylist_ext
845 | None
-> u.user_nick ^ mylist_ext
)
846 | None
-> failwith
"No User" )
848 if !verbose_msg_clients
|| !verbose_download
then
849 lprintf_nl "Creating filelist with name: (%s)" filelist_name;
850 let filelist_fd = Unix32.create_rw
filelist_name in
853 | FileLengthReq t
-> t
854 | AdcSndReq t
-> (* check that adc client send the size of file in here *)
855 if t
.AdcSnd.bytes > Int64.zero
then t
.AdcSnd.bytes
856 else failwith
"Wrong bytes in AdcSnd"
857 | _
-> raise Not_found
)
859 c.client_state
<- DcDownloadList
filelist_fd;
860 c.client_receiving
<- bytes;
861 c.client_error
<- NoError
;
864 dc_send_msg sock SendReq
865 | _
-> () ) (* AdcSnd *)
867 failwith
"Nothing to download" )
869 if !verbose_unexpected_messages
then
870 lprintf_nl "Exception (%s) FileLength/AdcSnd:" (Printexc2.to_string e
);
871 close sock
(Closed_for_error
(Printexc2.to_string e
)) )
875 | UGetBlockReq _
-> (* TODO downloading a section of file *) (* TODO state checking ? *)
877 if (c.client_state
= DcUploadDoneWaitingForMore
) then begin (* if this is a continual loading *)
878 if !verbose_upload
|| !verbose_msg_clients
then lprintf_nl " Continuing upload/slot";
879 TcpBufferedSocket.set_lifetime sock infinite_timeout
; (* restore connection lifetime *)
882 let direction_change = (* memorize possible direction change *)
883 (match c.client_state
with
884 | DcConnectionStyle MeActive Download
65535
885 | DcConnectionStyle ClientActive Download
65535 -> true (* these mean direction change and we have lost *)
893 | AdcGetReq
{ AdcGet.zl
= true } ->
894 failwith
"ZLib not yet supported"
896 | AdcGetReq
{ AdcGet.adctype
= AdcList
(dir
,re1
) } -> `PartialList
(dir
,re1
)
898 | AdcGetReq
{ AdcGet.adctype
= AdcFile
(NameSpecial
name) }
899 | GetReq
{ Get.filename
= name }
900 | UGetBlockReq
{ UGetBlock.ufilename
= name }
901 when name = mylist
|| name = mylistxmlbz2
-> `FullList
name
903 | AdcGetReq
{ AdcGet.adctype
= AdcFile
(NameSpecial
name) } ->
904 failwith
("ADCGET special name not supported : " ^
name)
906 | AdcGetReq
{ AdcGet.adctype
= AdcFile
(NameTTH tth
); start_pos
=start
; bytes=bytes } ->
907 `File
(`TTH tth
, start
, bytes)
910 let name = String2.replace t
.Get.filename char92
"/" in
911 `File
(`Name
name, Int64.pred t
.Get.pos
, Int64.minus_one
)
914 let name = String2.replace t
.UGetBlock.ufilename char92
"/" in
915 `File
(`Name
name, t
.UGetBlock.upos
, t
.UGetBlock.ubytes
)
917 | _
-> failwith
"Unexpected request"
921 let mylist_filename = Filename.concat directconnect_directory
name in
922 c.client_state
<- DcUploadListStarting
mylist_filename;
923 c.client_pos
<- Int64.zero
;
924 let size = Unix32.getsize
mylist_filename in
927 dc_send_msg sock
(AdcSndReq
{
928 AdcSnd.adctype
= t
.AdcGet.adctype
;
929 AdcSnd.start_pos
= 0L;
931 AdcSnd.zl
= false; (* CHECK *)
933 client_reader c SendReq sock
(* call ourselves again with send starting *)
934 | _
-> (* GetReq _ | UGetBlockReq _ *)
935 dc_send_msg sock
(FileLengthReq
size)
938 | `PartialList _
-> failwith
"Partial lists not yet supported"
940 | `File
(name, start_pos
, bytes) -> (* client wants normal file *)
941 (*lprintf_nl "Client (%s) wants to download %s (%s) %Ld bytes from pos: %Ld" (clients_username c)
942 fname tth bytes start_pos;*)
943 let dcsh = match name with
945 (try (* lets find file by tth *)
946 Hashtbl.find dc_shared_files_by_hash tth
948 failwith
(Printf.sprintf
"Shared file not found by tth %S" tth
))
950 (try (* so lets find filename then *)
951 Hashtbl.find dc_shared_files_by_codedname
fname
953 failwith
(Printf.sprintf
"Shared file not found by codedname %S" fname))
955 (* check if upload still exists *)
956 c.client_pos
<- start_pos
;
957 let rem = dcsh.dc_shared_size
-- c.client_pos
in
958 if dc_can_upload
() || (counts_as_minislot
dcsh.dc_shared_size
) then
959 begin (* if free slots or file size *)
960 if not
(counts_as_minislot
dcsh.dc_shared_size
) then dc_insert_uploader
();(* increase uploaders *)
961 c.client_state
<- DcUploadStarting
(dcsh,start_pos
,bytes);
964 dc_send_msg sock
(AdcSndReq
{
965 AdcSnd.adctype
= t
.AdcGet.adctype
;
966 start_pos
= start_pos
;
968 zl
= false; (* CHECK *)
970 client_reader c SendReq sock
(* call ourselves again with send starting *)
971 | _
-> (* GetReq _ | UGetBlockReq _ *)
972 dc_send_msg sock
(FileLengthReq
rem) )
975 (*lprintf_nl "Sending MaxedOut to (%s)" (clients_username c);*)
976 dc_send_msg sock MaxedOutReq
;
977 close sock
(Closed_for_error
("By us: Maxedout"))
980 if !verbose_upload
then
981 lprintf_nl "Error answering GET/ADCGET: %s" (Printexc2.to_string exn
);
982 let errortxt = "File Not Available" in
986 dc_send_msg sock
(ErrorReq
errortxt)
987 | _
-> (* UGetBlockReq _ *)
988 dc_send_msg sock
(FailedReq
errortxt)
990 close sock
(Closed_for_error
("By us:" ^
errortxt))
992 if direction_change then begin (* now the users clients states wont interfere this check *)
993 (match c.client_user
with (* we can check if we can start new download immediately *)
995 lprintf_nl "Because we lost conflict we now try to start new download from %s" user.user_nick
;
996 ignore
(ask_user_for_download user)
1000 | GetListLenReq
-> ()
1003 (*lprintf_nl "Received $Key ... dumping it";*)
1004 (*lprintf_nl "Client state: %s" (client_state_to_string c);*)
1005 let level = Random.int 32767 in
1006 let send_downloading_command dir
c = (* inside Key function ... *)
1007 (match dir
with (* Send first $Get if necessary *)
1008 | Upload _
-> (* sent we want to download and client needs to be uploading part *)
1009 (match c.client_file
with (* here we set the downloading file back again to client state *)
1011 close sock
(Closed_for_error
"Nothing to download")
1013 c.client_state
<- DcDownload file
;
1014 dc_send_download_command c sock
)
1015 | _
-> () ) (* we are uploading and wait for $Get now *)
1017 (match c.client_state
with
1018 | DcDownloadListConnecting
(_
,passive
,time
) ->
1019 (match passive
with (* if we were/are in passive mode *)
1021 (*lprintf_nl "Connection state is: DcDownloadListConnecting )"; *)
1022 (match c.client_supports
with (* send $Supports if necessary *)
1024 | Some dc_client_supports
->
1025 dc_send_msg sock
( SupportsReq
(ClientSupports mldonkey_dc_client_supports
) ) );
1026 c.client_state
<- DcDownloadListConnecting
(level,true,time
); (* memorise $Direction level *)
1027 dc_send_msg sock
( DirectionReq
{
1028 Direction.direction
= Download
level; Direction.level = level } );
1029 dc_send_msg sock
( KeyReq
{ Key.key
= DcKey.calculate_key
c.client_lock
})
1031 dc_send_download_command c sock
;
1033 | DcConnectionStyle
( ClientActive dir
) ->
1034 (match dir
with (* check that direction was not changed on election *)
1035 | Download
65535 -> () (* if was, do nothing and wait the Get from client *)
1037 (match c.client_supports
with (* send $Supports if necessary *)
1039 | Some dc_client_supports
-> (* if EXTENDEDPROTOCOL supported by client, send own $Supports *)
1040 dc_send_msg sock
( SupportsReq
(ClientSupports mldonkey_dc_client_supports
) ) );
1042 (match dir
with (* send $Direction *)
1043 | Upload _
-> (* client seems to be uploading so ... *)
1044 c.client_state
<- DcConnectionStyle
(ClientActive
(Upload
level)); (* set level *)
1045 dc_send_msg sock
( DirectionReq
{ (* we thank and send Download *)
1046 Direction.direction
= Download
level; Direction.level = level } )
1047 | Download _
-> (* clients want to download from us ... *)
1048 (* we send possible no slot later *)
1049 c.client_state
<- DcConnectionStyle
(ClientActive
(Download
level));
1050 dc_send_msg sock
( DirectionReq
{ (* we prepare for uploading file *)
1051 Direction.direction
= Upload
level; Direction.level = level } ) );
1054 KeyReq
{ Key.key
= DcKey.calculate_key
c.client_lock
});
1056 send_downloading_command dir
c )
1058 | DcConnectionStyle
(MeActive dir
) ->
1059 (match dir
with (* check that direction was not changed on election *)
1060 | Download
65535 -> () (* if was, do nothing and wait the Get from client *)
1061 | _
-> send_downloading_command dir
c )
1066 (*lprintf_nl "Received $Lock";*)
1067 (*lprintf_nl "Client state: %s" (client_state_to_string c);*)
1068 c.client_lock
<- lock
.Lock.key
; (* save the clients lock for later use *)
1070 (match c.client_state
with
1071 | DcDownloadListConnecting _
1072 | DcConnectionStyle
( MeActive _
) -> (* we are answering to a connection initialized by passive client *)
1073 let dir = (* lets set dir to DcDownloadListConnecting also ... *)
1074 (match c.client_state
with
1075 | DcDownloadListConnecting
(level,_
,_
) -> Upload
level
1076 | DcConnectionStyle
( MeActive
dir ) -> dir
1080 (match c.client_user
with
1082 (match user.user_servers
with
1083 | [] -> local_login
()
1084 | s
:: _
-> s
.server_last_nick
) (* pick first servers nick that is known to both... *)
1085 | _
-> local_login
() )
1087 dc_send_msg sock
(MyNickReq
my_nick); (* send nick and lock requests to client *)
1088 dc_send_msg sock
(LockReq
{
1089 Lock.info
= empty_string
;
1090 Lock.key
= DcKey.create_key
;
1091 Lock.extended_protocol
= true
1093 dc_send_msg sock
( SupportsReq
(ClientSupports mldonkey_dc_client_supports
) );
1094 let level = Random.int 32767 in
1097 (match c.client_state
with
1098 | DcConnectionStyle _
-> c.client_state
<- DcConnectionStyle
( MeActive
(Upload
level))
1099 | _
-> () (* DcDownloadListConnecting *) );
1100 dc_send_msg sock
( DirectionReq
{
1101 Direction.direction
= Download
level; (* we are downloading *)
1102 Direction.level = level } )
1103 | Download _
-> (* we set level to 0 so that we lose possible conflict all the time purposely *)
1104 (match c.client_state
with
1105 | DcConnectionStyle _
-> c.client_state
<- DcConnectionStyle
( MeActive
(Download
0))
1106 | _
-> () (* DcDownloadListConnecting *) );
1107 dc_send_msg sock
( DirectionReq
{
1108 Direction.direction
= Upload
0; (* we are uploading *)
1109 Direction.level = level } ) );
1110 dc_send_msg sock
(KeyReq
{ Key.key
= DcKey.calculate_key
c.client_lock
} );
1111 if !verbose_msg_clients
then
1112 lprintf_nl "Sent answer to (%s) (MyNick,Lock,Supports,Direction,Key)" (clients_username
c)
1116 (*lprintf_nl "Received MaxedOut";*)
1117 new_client_error c NoFreeSlots
;
1118 close sock
(Closed_for_error
"MaxedOut from client")
1121 if !verbose_msg_clients
then
1122 lprintf_nl "Received Normal $MyNick with nick (%s)" n
;
1123 (*lprintf_nl "Client state: %s" (client_state_to_string c);*)
1124 connection_ok
c.client_connection_control
;
1126 let u = search_user_by_name n
in (* connect first correct user and client together *)
1127 (match u.user_state
with
1128 | UserActiveUserInitiating
-> (* RevConnect sent, another client present already *)
1129 (* Now we have to swap clients info *)
1131 List.iter
(fun fc
->
1132 (match c.client_state
with
1133 | DcConnectionStyle ClientActive Upload
0 -> raise
(Found_client fc
)
1136 failwith
"Not found client with correct state"
1138 | Found_client fc
->
1139 (match fc
.client_file
with
1140 | Some file
-> add_client_to_file
c file
;
1142 remove_client_from_clients_file fc
;
1145 | UserPassiveUserInitiating _
(* ConnectToMe sent as answer to RevConnect, should not hapen here *)
1146 | UserActiveMeInitiating
(* ConnectToMe sent, another client already present, should not happen in here *)
1148 failwith
"User state is wrong" );
1150 add_client_to_user
c u;
1151 c.client_name
<- Some
u.user_nick
;
1152 set_client_state
c (Connected
0);
1154 (match c.client_state
with (* now decide correct state *)
1155 | DcDownloadListConnecting _
-> () (* if client state is filelist downloading... *)
1157 (match u.user_state
with
1158 | UserActiveUserInitiating
-> (* we sent RevConnect ... *)
1159 c.client_state
<- DcConnectionStyle
(ClientActive
(Upload
0)); (* level assigned later *)
1160 | UserIdle
-> (* totally new connection initialized by client *)
1161 c.client_state
<- DcConnectionStyle
(ClientActive
(Download
0))
1163 failwith
"Invalid user state" )
1165 u.user_state
<- UserIdle
; (* not needed anymore *)
1167 if !verbose_unexpected_messages
|| !verbose_msg_clients
then
1168 lprintf_nl "In normal MyNick: (%s) when received nick=(%s)" (Printexc2.to_string e
) n
;
1169 close sock
(Closed_for_error
"Error in $MyNick") )
1172 (*lprintf_nl "Received or commanded $Send";*)
1174 (match c.client_state
with
1175 | DcUploadListStarting
fname ->
1176 let file_fd = Unix32.create_ro
fname in
1177 c.client_state
<- DcUploadList
file_fd;
1178 c.client_endpos
<- Unix32.getsize64
file_fd;
1179 let file = new_upfile None
file_fd in
1180 c.client_file
<- Some
file;
1181 set_clients_upload
c (as_file
file.file_file
);
1182 | DcUploadStarting
(dcsh,start_pos
,bytes) ->
1184 if bytes = Int64.minus_one
then dcsh.dc_shared_size
1186 let client_wants = start_pos
++ bytes in (* if client requests too much data *)
1187 if client_wants > dcsh.dc_shared_size
then failwith
"Start_pos + bytes > dcsh.dc_shared_size"
1191 let file_fd = Unix32.create_ro
dcsh.dc_shared_fullname
in
1192 c.client_state
<- DcUpload
(dcsh,file_fd,start_pos
,bytes);
1193 c.client_endpos
<- endpos;
1194 let file = new_upfile
(Some
dcsh) file_fd in
1195 c.client_file
<- Some
file;
1196 set_clients_upload
c (as_file
file.file_file
);
1197 | _
-> failwith
"Wrong client state in Send" );
1199 set_client_has_a_slot
(as_client
c.client_client
) NormalSlot
;
1200 (*client_enter_upload_queue (as_client c.client_client);*)
1201 TcpBufferedSocket.set_wtimeout sock
(float !!client_write_timeout
)
1204 lprintf_nl "Exception %s in upload creation" (Printexc2.to_string e
);
1205 close sock
(Closed_for_error
"Error in upload creation");
1206 failwith
"Error in upload creation" )
1208 | SupportsReq t
-> (* After EXTENDEDPROTOCOL support list from client ... *)
1209 (*lprintf_nl "Received $Supports";*)
1211 | ClientSupports t
-> c.client_supports
<- Some t
(* Save supports into clientdata *)
1216 if !verbose_unexpected_messages
|| !verbose_msg_clients
then begin
1217 let l = String.length s
in
1218 let txt = Printf.sprintf
"Unknown client message: (%s)" (clients_username
c) in
1219 if l > 50 then lprintf_nl "%s (%s...%d chars)" txt (shorten_string s
50) l
1220 else lprintf_nl "%s (%s)" txt s
1224 lprintf_nl "--> Unhandled client message. Implement ?:";
1225 DcProtocol.dc_print t
)
1227 (* Find next download from this user/client *)
1228 let find_next_client c =
1229 (match c.client_user
with
1232 if !verbose_download
then lprintf_nl "Trying to find next download to user (%s)" u.user_nick
;
1234 List.iter
(fun cl
-> (* check first if filelist is waiting ... *)
1235 (match cl
.client_state
with
1236 | DcDownloadListWaiting
-> raise
(Found_client cl
)
1238 ) u.user_clients
; (* then normal downloads ... *)
1239 List.iter
(fun cl
->
1240 (match cl
.client_state
with
1241 | DcDownloadWaiting _
-> raise
(Found_client cl
)
1244 None
(* return false to calling function that closes the socket *)
1246 | Found_client cl
-> (Some cl
) (* we have a next file with existing client to download *)
1250 (* Start next download from user and if change, current client <-> pending client *)
1251 (* Remove other client if not change *)
1252 let next_download change
c sock cl
= (* c is current connection, cl is the pending download *)
1253 (match cl
.client_state
with
1254 | DcDownloadWaiting
file ->
1255 if change
then begin (* we need to change current download with pending one *)
1256 (match c.client_state
with
1257 | DcDownload
f -> (* here we exchange pending client to existing client socket *)
1258 c.client_state
<- DcDownload
file;
1259 cl
.client_state
<- DcDownloadWaiting
f;
1260 remove_client_from_clients_file
c;
1261 remove_client_from_clients_file cl
;
1262 add_client_to_file
c file;
1263 add_client_to_file cl
f;
1266 remove_client_from_clients_file
c; (* because file commit removes the file <-> client connection also, *)
1267 (* this has to be done before assigning new file to this reused client, *)
1268 (* so that file remove don't erase this clients file *)
1269 add_client_to_file
c file; (* no change needed *)
1270 remove_client cl
; (* remove not needed client *)
1271 c.client_state
<- DcDownload
file;
1272 dc_send_download_command c sock
1274 | DcDownloadListWaiting
->
1275 if not change
then begin (* filelists changing not currently possible *)
1277 c.client_state
<- DcDownloadListConnecting
(0,!!firewalled
,nan
);
1278 dc_send_download_command c sock
1282 (* File is finished downloading, so remove file from clients list and client from files list *)
1283 let file_complete file =
1284 if !verbose_download
then lprintf_nl "File %s downloaded" file.file_name
;
1285 file_completed
(as_file
file.file_file
); (* update_file_state impl FileDownloaded; *)
1286 List.iter
(fun c -> (* remove this files clients except current connection *)
1287 (match c.client_state
with (* because we use this connection possibly for next download *)
1288 | DcDownload
f -> () (* only one client should be in this state *)
1293 let closing_text = "All files downloaded"
1294 (* Continue downloading from client that we have initialized *)
1295 let client_downloaded c sock nread
= (* TODO check tth while loading, abort if error *)
1296 if nread
> 0 then begin
1297 (match c.client_state
with
1298 | DcDownload
file ->
1299 let b = TcpBufferedSocket.buf sock
in
1301 if c.client_preread_bytes_left
> 0 then begin (* if precheck not yet done *)
1302 let check_bytes = min nread
c.client_preread_bytes_left
in (* which is smaller... *)
1303 let check_buffer = String.create
check_bytes in
1304 Unix32.read
(file_fd file) (c.client_pos
-- (Int64.of_int
c.client_preread_bytes_left
))
1305 check_buffer 0 check_bytes;
1306 let str2 = String.sub
b.buf
b.pos
check_bytes in
1307 if (String.compare
check_buffer str2) = 0 then begin (* if downloaded is ok *)
1308 c.client_preread_bytes_left
<- c.client_preread_bytes_left
- check_bytes;
1309 if c.client_preread_bytes_left
= 0 then begin (* if checked all preread bytes *)
1310 let downloaded = b.len
- check_bytes in
1311 if downloaded > 0 then begin (* check if buffer has bytes to write to file *)
1312 Unix32.write
(file_fd file) c.client_pos
b.buf
(b.pos
+check_bytes) downloaded
1314 Int64.of_int
downloaded
1316 end else begin (* if file check failed *)
1317 if !verbose_download
then
1318 lprintf_nl "Corrupted file (%s) download from (%s)" file.file_name
(clients_username
c);
1319 c.client_state
<- DcIdle
; (* now closing sock removes the client also *)
1320 close sock
(Closed_for_error
"Corrupted file");
1323 end else begin (* precheck done, normal flow *)
1324 Unix32.write
(file_fd file) c.client_pos
b.buf
b.pos
b.len
;
1328 c.client_pos
<- c.client_pos
++ downloaded;
1329 (match c.client_user
with
1330 | Some
u -> u.user_downloaded
<- u.user_downloaded
++ downloaded
1332 c.client_downloaded <- c.client_downloaded ++ downloaded;
1334 if c.client_pos
> (file_downloaded
file) then (* update downloading state *) (* TODO check tth while loading *)
1335 add_file_downloaded
(as_file
file.file_file
) (c.client_pos
-- (file_downloaded
file));
1336 if (file_downloaded
file) = (file_size
file) then begin
1338 c.client_receiving
<- Int64.zero
; (* this marks client as receiving normal commands again *)
1339 c.client_pos
<- Int64.zero
;
1340 TcpBufferedSocket.set_rtimeout sock infinite_timeout
; (* back to normal *)
1341 (* update myinfo ? *)
1342 (match (find_next_client c) with (* try to continue slot *)
1343 | Some cl
-> next_download false c sock cl
(* connected client , sock , client download_waiting *)
1345 c.client_state
<- DcIdle
; (* now closing sock removes the client also *)
1346 close sock
(Closed_for_error
closing_text) )
1349 | DcDownloadList
filelist_fd -> (* downloading file list *)
1350 let b = TcpBufferedSocket.buf sock
in
1351 let len = Int64.of_int
b.len in
1352 Unix32.write
filelist_fd c.client_pos
b.buf
b.pos
b.len;
1353 c.client_pos
<- c.client_pos
++ len;
1354 (match c.client_user
with
1355 | Some
u -> u.user_downloaded
<- u.user_downloaded
++ len
1357 c.client_downloaded <- c.client_downloaded ++ len;
1358 c.client_receiving
<- c.client_receiving
-- len;
1360 if c.client_receiving
= Int64.zero
then begin
1361 Unix32.close
filelist_fd;
1362 if !verbose_download
then lprintf_nl "Received filelist from (%s)" (clients_username
c);
1363 c.client_receiving
<- Int64.zero
; (* this marks client as receiving commands again *)
1364 c.client_pos
<- Int64.zero
;
1365 TcpBufferedSocket.set_rtimeout sock infinite_timeout
;
1366 (match (find_next_client c) with
1368 next_download false c sock cl
(* connected client , sock , client download_waiting *)
1370 c.client_state
<- DcIdle
;
1371 close sock
(Closed_for_error
closing_text) )
1373 | _
-> raise Not_found
)
1376 (* initialize a new connection when nothing is known from client *)
1377 let init_anon_client sock
=
1378 TcpBufferedSocket.set_read_controler sock download_control
;
1379 TcpBufferedSocket.set_write_controler sock upload_control
;
1380 TcpBufferedSocket.set_rtimeout sock infinite_timeout
; (* client timeouts *)
1381 TcpBufferedSocket.set_wtimeout sock infinite_timeout
;
1382 TcpBufferedSocket.set_reader sock
(dc_handler_client
(ref (None
))
1383 read_first_message client_reader client_downloaded)
1385 (* create listening socket for incoming connection, return socket or None *)
1386 let create_tcp_socket () =
1388 let sock = TcpServerSocket.create
"DC client listening" (Ip.to_inet_addr
!!client_bind_addr
) !!dc_port
1391 | TcpServerSocket.CONNECTION
(s
, Unix.ADDR_INET
(from_ip
, from_port
)) ->
1392 (*lprintf_nl "Listen: connection received from %s:%d"
1393 (Ip.to_string (Ip.of_inet_addr from_ip)) from_port; *)
1395 (* CHECK Allow this connection or not ? *)
1396 let token = create_token connection_manager
in
1397 let sock = TcpBufferedSocket.create
token
1398 "DC client connection" s
client_handler(*(fun _ _ -> ())*) in
1399 init_anon_client sock
1402 (*lprintf_nl "Created listening socket..." ;*)
1403 dc_tcp_listen_sock
:= Some
sock;
1404 (match (Unix.getsockname
(BasicSocket.fd
(TcpServerSocket.sock sock))) with
1405 | Unix.ADDR_INET
(addr
,port
) -> Some
sock
1407 with e
-> lprintf_nl "Exception %s while initializing DC listen socket" (Printexc2.to_string e
);
1412 (* Parse udp messages *)
1413 let udp_parse buf
sock =
1414 if !verbose_udp
then lprintf_nl "UDP Receive: (%s)" buf
;
1415 let str = String2.splitn buf ' '
1 in
1418 let module S
= SR
in
1419 let msg = S.parse
(String2.replace args '
|' empty_string
) in (* strip following '|' from message *)
1420 if msg.S.filename
= empty_string
then ()
1421 (*lprintf_nl "This result seems to be directory result, we don't support it atm."*)
1424 let s = Hashtbl.find servers_by_ip
msg.S.server_ip
in
1425 received_new_search_result s msg;
1426 with _
-> if !verbose_udp
then
1427 lprintf_nl "UDP: Not valid ip-address (%s) in $SR" msg.S.server_ip
)
1429 | [cmd
] -> if !verbose_udp
then lprintf_nl "UDP: Unknown command %s" cmd
1430 | _
-> if !verbose_udp
then lprintf_nl "UDP: Unknown message %s" (String.escaped buf
) )
1433 let udp_send ip port m
=
1437 Buffer.add_char buf '
|'
;
1438 let s = Buffer.contents buf
in
1439 (match !dc_udp_sock
with
1441 (*if !verbose_udp || !verbose_msg_clients then lprintf_nl "UDP Send: (%s)" s;*)
1442 UdpSocket.write
sock false s ip port
1443 | None
-> failwith
"No UDP socket" );
1445 if !verbose_udp
|| !verbose_msg_clients
then
1446 lprintf_nl "Exception (%s) in UDP send" (Printexc2.to_string e
) )
1448 (* Udp event handling *)
1449 let udp_handler sock event
=
1451 | UdpSocket.READ_DONE
->
1452 UdpSocket.read_packets
sock (fun p
->
1454 let pbuf = p
.UdpSocket.udp_content
in
1455 let len = String.length
pbuf in
1462 (* create listening udp port *)
1463 let create_udp_socket () =
1465 let sock = UdpSocket.create
(Ip.to_inet_addr
!!client_bind_addr
) !!dc_port
1466 (fun sock event
-> udp_handler sock event
)
1468 dc_udp_sock
:= Some
sock;
1469 UdpSocket.set_write_controler
sock udp_write_controler
;
1472 lprintf_nl "Exception %s while binding UDP socket" (Printexc2.to_string e
);
1475 (* Start a connection to client *)
1476 let connect_client c =
1478 add_pending_connection connection_manager
(fun token ->
1480 match c.client_addr
with
1483 connection_try
c.client_connection_control
;
1484 let sock = TcpBufferedSocket.connect
token "client connection" (Ip.to_inet_addr ip
) port
1485 client_handler (*(fun _ _ -> ())*)
1487 TcpBufferedSocket.set_read_controler
sock download_control
; (* CommonGlobals.download_control *)
1488 TcpBufferedSocket.set_write_controler
sock upload_control
;
1489 TcpBufferedSocket.set_rtimeout
sock infinite_timeout
; (* client timeouts *)
1490 TcpBufferedSocket.set_wtimeout
sock infinite_timeout
;
1491 TcpBufferedSocket.set_closer
sock (fun _ reason
-> client_disconnected sock reason
c);
1492 TcpBufferedSocket.set_reader
sock (dc_handler_client
(ref (Some
c)) read_first_message
1493 client_reader client_downloaded);
1494 init_connection c sock; (* Send first answer messages to client *)
1496 lprintf_nl "Exception: %s, while connecting to client" (Printexc2.to_string e
);
1498 c.client_sock
<- ConnectionWaiting
token
1500 (* Upload to client *)
1501 let dc_upload c bytes =
1502 (match c.client_sock
with
1503 | Connection
sock ->
1505 if (bytes > 0) && can_write_len
sock bytes then begin
1506 (* update upload rate from len bytes *)
1507 (*Rate.update c.client_upload_rate (float_of_int len);*)
1510 count_filerequest c; *)
1512 (match c.client_state
with
1513 | DcUpload
(_
,fd
,_
,_
) -> fd
1514 | DcUploadList fd
-> fd
1515 | _
-> failwith
"No fd in upload" )
1518 let rem = Int64.to_int
(c.client_endpos
-- c.client_pos
) in
1519 if rem > bytes then bytes else rem
1521 CommonUploads.consume_bandwidth
rlen;
1522 let upload_buffer = String.create
rlen in
1523 Unix32.read
file_fd c.client_pos
upload_buffer 0 rlen;
1524 TcpBufferedSocket.write
sock upload_buffer 0 rlen;
1525 (*lprintf_nl " Wrote (%d) bytes" rlen;*)
1526 let uploaded = Int64.of_int
rlen in
1527 c.client_pos
<- c.client_pos
++ uploaded;
1528 dc_total_uploaded
:= !dc_total_uploaded
++ uploaded;
1529 (match c.client_user
with
1530 | Some
u -> u.user_uploaded
<- u.user_uploaded
++ uploaded
1532 c.client_uploaded
<- c.client_uploaded
++ uploaded;
1533 (match c.client_state
with
1534 | DcUpload
(dcsh,_
,_
,_
) ->
1536 let sh = CommonUploads.find_by_name
dcsh.dc_shared_codedname
in
1537 sh.shared_impl
.impl_shared_uploaded
<- c.client_pos
;
1538 shared_must_update
(as_shared
sh.shared_impl
)
1541 if c.client_pos
= c.client_endpos
then begin
1542 if !verbose_upload
then lprintf_nl "Finished uploading to (%s)" (clients_username
c);
1543 Unix32.close
file_fd;
1544 set_refill
sock (fun _
-> () );
1545 (match c.client_state
with
1546 | DcUpload
(dcsh,_
,_
,_
) ->
1547 if not
(counts_as_minislot
dcsh.dc_shared_size
) then dc_remove_uploader
() (* slots *)
1549 c.client_state
<- DcUploadDoneWaitingForMore
;
1550 set_client_has_a_slot
(as_client
c.client_client
) NoSlot
; (* inform GUI *)
1551 TcpBufferedSocket.set_lifetime
sock (float !!wait_for_next_upload
);
1553 ready_for_upload
(as_client
c.client_client
);
1555 end else begin (* HMMM Is it ok to bang this line over and over again ? *)
1556 ready_for_upload
(as_client
c.client_client
)
1559 if !verbose_upload
then lprintf_nl "Exception (%s) in upload" (Printexc2.to_string e
);
1560 new_client_error c UploadError
)
1562 if !verbose_upload
then
1563 lprintf_nl "Socket not connected in uploading to (%s)" (clients_username
c);
1564 c.client_state
<- DcIdle
;
1565 set_client_has_a_slot
(as_client
c.client_client
) NoSlot
;
1566 dc_disconnect_client c (Closed_for_error
"No socket in upload") )
1570 (* register client operations *)
1572 client_ops
.op_client_info
<- (fun c ->
1573 let name = clients_username
c in
1574 let kind,total_downloaded
,total_uploaded
=
1576 (match c.client_addr
with
1577 | Some
(ip,port
) -> ip,port
1578 | None
-> Ip.null
,0 )
1580 (match c.client_user
with
1583 if (user_active
user) then Known_location
(ip,port
)
1584 else Indirect_location
(empty_string
,Md4.null
,ip,port
)
1586 kind,user.user_downloaded
,user.user_uploaded
1588 let kind = Indirect_location
(empty_string
,Md4.null
,ip,port
) in
1589 kind,Int64.zero
,Int64.zero
)
1591 let software, version
=
1592 match c.client_user
with
1593 | Some
u -> u.user_myinfo
.client_brand
, u.user_myinfo
.version
1594 | None
-> empty_string
, empty_string
1597 (match c.client_file
with
1598 | Some
file -> file.file_name
1601 { (impl_client_info
c.client_client
) with
1602 P.client_network
= network
.network_num
;
1603 P.client_kind
= kind;
1604 P.client_state
= client_state
(as_client
c.client_client
);
1605 P.client_type
= client_type
c;
1606 P.client_name
= name;
1607 P.client_num
= (client_num
(as_client
c.client_client
));
1608 P.client_connect_time
= c.client_connect_time
;
1609 P.client_software
= software;
1610 P.client_release
= version
;
1611 P.client_emulemod
= empty_string
;
1612 P.client_session_downloaded
= c.client_downloaded;
1613 P.client_session_uploaded
= c.client_uploaded
;
1614 P.client_total_downloaded
= total_downloaded
;
1615 P.client_total_uploaded
= total_uploaded
;
1616 P.client_upload
= Some
filename;
1617 P.client_sui_verified
= None
; (* new 2.6.5 *)
1618 (* P.client_sock_addr = ""; *)
1621 client_ops
.op_client_browse
<- (fun _ _ -> lprintf_nl "Received (op_client_browse)" );
1622 client_ops
.op_client_can_upload
<- (fun c bytes -> dc_upload c bytes );
1623 client_ops
.op_client_enter_upload_queue
<- (fun c ->
1624 if !verbose_msg_clients
|| !verbose_upload
then
1625 lprintf_nl "Client (%s) started to upload" (clients_username
c);
1626 ready_for_upload
(as_client
c.client_client
)
1630 mutable op_client_network : CommonTypes.network;
1631 mutable op_client_connect : 'a -> unit;
1632 mutable op_client_disconnect : 'a -> unit;
1633 mutable op_client_say : 'a -> string -> unit;
1634 mutable op_client_files : 'a -> (string * CommonTypes.result) list;
1635 mutable op_client_clear_files : 'a -> unit;
1636 mutable op_client_bprint : 'a -> Buffer.t -> unit;
1637 mutable op_client_dprint :
1638 'a -> CommonTypes.ui_conn -> CommonTypes.file -> unit;
1639 mutable op_client_dprint_html :
1640 'a -> CommonTypes.ui_conn -> CommonTypes.file -> string -> bool;
1641 mutable op_client_debug : 'a -> bool -> unit;