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
654 let fname, from_pos
, tth
=
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 fname = if adc
then separator ^
fname else fname in (* adc needs trailing '/' *)
660 let preload_bytes = (* calculate preread bytes position *)
661 let from_pos = file_downloaded file
in
662 if from_pos < int64_kbyte
then begin (* if read under 1k bytes from client, start over *)
663 c.client_pos
<- Int64.zero
;
666 c.client_pos
<- from_pos;
670 c.client_preread_bytes_left
<- preload_bytes;
671 fname, c.client_pos
-- (Int64.of_int
preload_bytes), file
.file_unchecked_tiger_root
673 c.client_pos
<- Int64.zero
;
675 mylistxmlbz2
, c.client_pos
, empty_string
677 mylist
, c.client_pos
, empty_string
)
679 if !verbose_msg_clients
|| !verbose_download
then
680 lprintf_nl "Sending $Get/$ADCGET: (%s)(%s)(%s)(%Ld)" (clients_username
c) fname tth
from_pos;
681 if adc
then begin (* if client supports adc ...*)
682 let fname = if (tth
<> "") && tthf
(* if client supports tthf ... *)
683 then empty_string
(* only tth or filename is sent valid *)
686 dc_send_msg sock
( AdcGetReq
{
687 AdcGet.adctype
= AdcFile
;
688 AdcGet.fname = fname;
690 AdcGet.start_pos
= from_pos;
691 AdcGet.bytes
= Int64.minus_one
; (* TODO load file from from_pos to anywhere *)
694 end else if xmlbzlist then begin (* if client supports ugetblock ...*)
695 dc_send_msg sock
( UGetBlockReq
{
696 UGetBlock.ufilename
= fname;
697 UGetBlock.ubytes
= Int64.minus_one
;
698 UGetBlock.upos
= from_pos;
700 end else begin (* else send normal GET *)
701 dc_send_msg sock
( GetReq
{
702 Get.filename
= fname;
703 Get.pos
= Int64.succ
from_pos } )
706 (* clients messages normal reader *)
707 let rec client_reader c t sock
=
712 (*if !verbose_msg_clients then lprintf_nl "Received $Direction (%s)" (clients_username c);*)
713 (match c.client_state
with
714 | DcDownloadListConnecting
(our_level
,_
,_
) (* We are downloading filelist *)
715 | DcConnectionStyle
(ClientActive
(Upload our_level
)) (* We are in passive mode *)
716 | DcConnectionStyle
(MeActive
(Upload our_level
)) -> (* We are in active mode, client needs to upload) *)
717 (match t
.Direction.direction
with
719 if !verbose_msg_clients
then
720 lprintf_nl "We have a conflict with (%s), both want to download..." (clients_username
c);
721 if (t
.Direction.level
> our_level
) then begin (* client gets to start download first *)
722 if !verbose_msg_clients
then lprintf_nl " Client won the election...";
723 (match c.client_state
with (* memorize list loading if that is the case *)
724 | DcConnectionStyle _
-> (* if file was tried to download ... *)
725 let nc = new_copy_client
c in
726 nc.client_sock
<- NoConnection
;
727 nc.client_addr
<- None
;
728 (match c.client_file
with
730 add_client_to_file
nc file
;
731 (match c.client_user
with
733 add_client_to_user
nc user;
735 nc.client_state
<- DcDownloadWaiting file
737 remove_client_from_clients_file
c
738 | _
-> (* DcDownloadListConnecting *) (* if filelist was tried to download *)
739 let nc = new_copy_client
c in
740 nc.client_sock
<- NoConnection
;
741 nc.client_addr
<- None
;
742 (match c.client_user
with
743 | Some
user -> add_client_to_user
nc user
745 nc.client_state
<- DcDownloadListWaiting
);
746 (* we change our direction *)
747 (match c.client_state
with (* check which one is the case *)
748 | DcConnectionStyle
(ClientActive
(Upload _
)) -> (* if client was initiating *)
749 c.client_state
<- DcConnectionStyle
(ClientActive
(Download
65535)) (* 65535 means to KeyReq that *)
750 | DcConnectionStyle
(MeActive
(Upload _
)) (* direction is changed *)
751 | DcDownloadListConnecting _
-> (* if we were initiating *)
752 c.client_state
<- DcConnectionStyle
(MeActive
(Download
65535))
754 (* we check in GetReq if we can start a new download immediately *)
756 end else if (t
.Direction.level
< our_level
) then begin (* we win and start downloading *)
757 if !verbose_msg_clients
then lprintf_nl " We won the election..."
758 end else (* otherwise close connection *)
759 if !verbose_msg_clients
then
760 lprintf_nl " Stalemate (levels are equal), closing";
761 close sock
(Closed_for_error
"Negotiation download: Stalemate" )
762 | _
-> () ) (* Upload *)
763 | DcConnectionStyle
(MeActive
(Download our_level
))
764 | DcConnectionStyle
(ClientActive
(Download our_level
)) -> (* connection is ready for uploading *)
765 (match t
.Direction.direction
with
766 | Upload level
-> (* Active mode and client wants to upload too ?? *)
767 if !verbose_msg_clients
then lprintf_nl "We have a conflict, both want to upload...";
768 (match c.client_state
with
769 | DcConnectionStyle MeActive _
->
770 if !verbose_msg_clients
then
771 lprintf_nl " and client (%s) is in passive mode" (clients_username
c)
773 if !verbose_msg_clients
then
774 lprintf_nl " and client (%s) is in active mode" (clients_username
c) );
775 close sock
(Closed_for_error
"Negotiation upload: conflict" );
776 | _
-> () ) (* Download *)
778 if !verbose_msg_clients
|| !verbose_unexpected_messages
then
779 lprintf_nl "In Direction: client state invalid";
780 close sock
(Closed_for_error
"Negotiation: client state invalid" ) )
783 | FailedReq errortxt
->
784 if !verbose_msg_clients
then begin
786 | ErrorReq _
-> lprintf_nl "Received (%s) from (%s)" errortxt
(clients_username
c)
787 | _
-> lprintf_nl "Received (%s) from (%s)" errortxt
(clients_username
c))
789 (match String2.split_simplify errortxt ' '
with
790 | [ _
; "File" ; txt1
; txt2
] ->
791 (* $Error File Not Available
792 $Error File not available *)
793 if (String.length txt1
= 3) && (txt2
.[1] = 'v'
) then new_client_error c FileNotAvailable
794 | _
-> lprintf_nl "New errortext: (%s) - make handling ??" errortxt
);
795 close sock
(Closed_for_error
(Printf.sprintf
"From client (%s): (%s)" (clients_username
c) errortxt
) )
800 if !verbose_msg_clients
then begin
802 | FileLengthReq _
-> lprintf_nl "Received $FileLength from (%s)" (clients_username
c)
803 | _
-> lprintf_nl "Received $AdcSnd from (%s)" (clients_username
c) ) (* AdcSnd *)
805 TcpBufferedSocket.set_rtimeout sock
(float !!client_read_timeout
);
806 (match c.client_state
with
810 | FileLengthReq t
-> t
811 | AdcSndReq t
-> (* check file current position with to be sended data position *)
812 let size = file_downloaded file
in
813 if !verbose_download
then
814 lprintf_nl "AdcSnd: file_downloaded=(%Ld) preread=(%d) start_pos=(%Ld)"
815 size c.client_preread_bytes_left t
.AdcSnd.start_pos
;
816 if size -- (Int64.of_int
c.client_preread_bytes_left
) = t
.AdcSnd.start_pos
then begin
817 if t
.AdcSnd.bytes = Int64.minus_one
then file_size file
else t
.AdcSnd.bytes
819 if !verbose_unexpected_messages
|| !verbose_download
then
820 lprintf_nl "AdcSnd: Current file=(%s) size=(%Ld) don't match start_pos=(%Ld) for user=(%s)"
821 file
.file_name
size t
.AdcSnd.start_pos
(clients_username
c);
824 | _
-> raise Not_found
)
826 c.client_receiving
<- bytes;
827 c.client_error
<- NoError
;
828 file_add file
.file_file FileDownloading
;
831 dc_send_msg sock SendReq
832 | _
-> () ) (* AdcSnd *)
834 | DcDownloadListConnecting _
->
835 let filelist_name = Filename.concat filelist_directory
(
836 (match c.client_user
with
838 (match c.client_supports
with
840 if c_supports
.xmlbzlist then u.user_nick ^ mylistxmlbz2_ext
841 else u.user_nick ^ mylist_ext
842 | None
-> u.user_nick ^ mylist_ext
)
843 | None
-> failwith
"No User" )
845 if !verbose_msg_clients
|| !verbose_download
then
846 lprintf_nl "Creating filelist with name: (%s)" filelist_name;
847 let filelist_fd = Unix32.create_rw
filelist_name in
850 | FileLengthReq t
-> t
851 | AdcSndReq t
-> (* check that adc client send the size of file in here *)
852 if t
.AdcSnd.bytes > Int64.zero
then t
.AdcSnd.bytes
853 else failwith
"Wrong bytes in AdcSnd"
854 | _
-> raise Not_found
)
856 c.client_state
<- DcDownloadList
filelist_fd;
857 c.client_receiving
<- bytes;
858 c.client_error
<- NoError
;
861 dc_send_msg sock SendReq
862 | _
-> () ) (* AdcSnd *)
864 failwith
"Nothing to download" )
866 if !verbose_unexpected_messages
then
867 lprintf_nl "Exception (%s) FileLength/AdcSnd:" (Printexc2.to_string e
);
868 close sock
(Closed_for_error
(Printexc2.to_string e
)) )
872 | UGetBlockReq _
-> (* TODO downloading a section of file *) (* TODO state checking ? *)
873 let fname, tth
, start_pos
, bytes, zl
=
876 (*lprintf_nl "Received $AdcGet (%s) (%s) %Ld %Ld" t.AdcGet.fname t.AdcGet.tth t.AdcGet.start_pos t.AdcGet.bytes;*)
877 t
.AdcGet.fname, t
.AdcGet.tth
, t
.AdcGet.start_pos
, t
.AdcGet.bytes, t
.AdcGet.zl
879 (*lprintf_nl "Received $Get %s %Ld" t.Get.filename t.Get.pos;*)
880 t
.Get.filename
, empty_string
, (Int64.pred t
.Get.pos
), Int64.minus_one
, false
882 (*lprintf_nl "Received $UGetBlock %Ld %Ld %s" t.UGetBlock.upos t.UGetBlock.ubytes t.UGetBlock.ufilename;*)
883 t
.UGetBlock.ufilename
, empty_string
, t
.UGetBlock.upos
, t
.UGetBlock.ubytes
, false
884 | _
-> raise Not_found
)
886 if (c.client_state
= DcUploadDoneWaitingForMore
) then begin (* if this is a continual loading *)
887 if !verbose_upload
|| !verbose_msg_clients
then lprintf_nl " Continuing upload/slot";
888 TcpBufferedSocket.set_lifetime sock infinite_timeout
; (* restore connection lifetime *)
891 let direction_change = (* memorize possible direction change *)
892 (match c.client_state
with
893 | DcConnectionStyle MeActive Download
65535
894 | DcConnectionStyle ClientActive Download
65535 -> true (* these mean direction change and we have lost *)
898 if (fname = mylist
) || (fname = mylistxmlbz2
) then begin (* client wants our filelist *)
899 let mylist_filename =
900 if (fname = mylist
) then (Filename.concat directconnect_directory mylist
)
901 else if (fname = mylistxmlbz2
) then (Filename.concat directconnect_directory mylistxmlbz2
)
903 if !verbose_upload
&& !verbose_unexpected_messages
then lprintf_nl "Invalid mylistname";
907 c.client_state
<- DcUploadListStarting
mylist_filename;
908 c.client_pos
<- Int64.zero
;
909 let size = Unix32.getsize
mylist_filename in
913 if !verbose_upload
&& !verbose_unexpected_messages
then lprintf_nl "Zlib not yet supported";
916 dc_send_msg sock
(AdcSndReq
{
917 AdcSnd.adctype
= AdcFile
;
918 AdcSnd.fname = fname;
920 AdcSnd.start_pos
= start_pos
;
922 AdcSnd.zl
= false; (* CHECK *)
924 client_reader c SendReq sock
(* call ourselves again with send starting *)
925 | _
-> (* GetReq _ | UGetBlockReq _ *)
926 dc_send_msg sock
(FileLengthReq
size) );
928 end else begin (* client wants normal file *)
929 let fname = String2.replace
fname char92
"/" in
931 (*lprintf_nl "Client (%s) wants to download %s (%s) %Ld bytes from pos: %Ld" (clients_username c)
932 fname tth bytes start_pos;*)
934 if tth
<> "" then begin
935 (try (* lets find file by tth *)
936 Hashtbl.find dc_shared_files_by_hash tth
(* if found, return files name *)
938 if !verbose_upload
then lprintf_nl "Shared file not found by tth (%s) in Get/Adcget" tth
;
941 (try (* so lets find filename then *)
942 Hashtbl.find dc_shared_files_by_codedname
fname
944 if !verbose_upload
then lprintf_nl "Shared file not found by codedname (%s) in Get/AdcGet" fname ;
948 (* check if upload still exists *)
949 c.client_pos
<- start_pos
;
950 let rem = dcsh.dc_shared_size
-- c.client_pos
in
951 if dc_can_upload
() || (counts_as_minislot
dcsh.dc_shared_size
) then begin (* if free slots or file size *)
952 if not
(counts_as_minislot
dcsh.dc_shared_size
) then dc_insert_uploader
();(* increase uploaders *)
953 c.client_state
<- DcUploadStarting
(dcsh,start_pos
,bytes);
957 if !verbose_upload
&& !verbose_unexpected_messages
then lprintf_nl "Zlib not yet supported";
960 dc_send_msg sock
(AdcSndReq
{
961 AdcSnd.adctype
= AdcFile
;
962 AdcSnd.fname = fname;
964 AdcSnd.start_pos
= start_pos
;
965 AdcSnd.bytes = bytes;
966 AdcSnd.zl
= false; (* CHECK *)
968 client_reader c SendReq sock
(* call ourselves again with send starting *)
969 | _
-> (* GetReq _ | UGetBlockReq _ *)
970 dc_send_msg sock
(FileLengthReq
rem) );
973 (*lprintf_nl "Sending MaxedOut to (%s)" (clients_username c);*)
974 dc_send_msg sock MaxedOutReq
;
975 close sock
(Closed_for_error
("By us: Maxedout"))
978 let errortxt = "File Not Available" in
982 dc_send_msg sock
(ErrorReq
errortxt)
983 | _
-> (* UGetBlockReq _ *)
984 dc_send_msg sock
(FailedReq
errortxt) );
985 close sock
(Closed_for_error
("By us:" ^
errortxt)) )
987 if direction_change then begin (* now the users clients states wont interfere this check *)
988 (match c.client_user
with (* we can check if we can start new download immediately *)
990 lprintf_nl "Because we lost conflict we now try to start new download from %s" user.user_nick
;
991 ignore
(ask_user_for_download user)
995 | GetListLenReq
-> ()
998 (*lprintf_nl "Received $Key ... dumping it";*)
999 (*lprintf_nl "Client state: %s" (client_state_to_string c);*)
1000 let level = Random.int 32767 in
1001 let send_downloading_command dir
c = (* inside Key function ... *)
1002 (match dir
with (* Send first $Get if necessary *)
1003 | Upload _
-> (* sent we want to download and client needs to be uploading part *)
1004 (match c.client_file
with (* here we set the downloading file back again to client state *)
1006 close sock
(Closed_for_error
"Nothing to download")
1008 c.client_state
<- DcDownload file
;
1009 dc_send_download_command c sock
)
1010 | _
-> () ) (* we are uploading and wait for $Get now *)
1012 (match c.client_state
with
1013 | DcDownloadListConnecting
(_
,passive
,time
) ->
1014 (match passive
with (* if we were/are in passive mode *)
1016 (*lprintf_nl "Connection state is: DcDownloadListConnecting )"; *)
1017 (match c.client_supports
with (* send $Supports if necessary *)
1019 | Some dc_client_supports
->
1020 dc_send_msg sock
( SupportsReq
(ClientSupports mldonkey_dc_client_supports
) ) );
1021 c.client_state
<- DcDownloadListConnecting
(level,true,time
); (* memorise $Direction level *)
1022 dc_send_msg sock
( DirectionReq
{
1023 Direction.direction
= Download
level; Direction.level = level } );
1024 dc_send_msg sock
( KeyReq
{ Key.key
= DcKey.calculate_key
c.client_lock
})
1026 dc_send_download_command c sock
;
1028 | DcConnectionStyle
( ClientActive dir
) ->
1029 (match dir
with (* check that direction was not changed on election *)
1030 | Download
65535 -> () (* if was, do nothing and wait the Get from client *)
1032 (match c.client_supports
with (* send $Supports if necessary *)
1034 | Some dc_client_supports
-> (* if EXTENDEDPROTOCOL supported by client, send own $Supports *)
1035 dc_send_msg sock
( SupportsReq
(ClientSupports mldonkey_dc_client_supports
) ) );
1037 (match dir
with (* send $Direction *)
1038 | Upload _
-> (* client seems to be uploading so ... *)
1039 c.client_state
<- DcConnectionStyle
(ClientActive
(Upload
level)); (* set level *)
1040 dc_send_msg sock
( DirectionReq
{ (* we thank and send Download *)
1041 Direction.direction
= Download
level; Direction.level = level } )
1042 | Download _
-> (* clients want to download from us ... *)
1043 (* we send possible no slot later *)
1044 c.client_state
<- DcConnectionStyle
(ClientActive
(Download
level));
1045 dc_send_msg sock
( DirectionReq
{ (* we prepare for uploading file *)
1046 Direction.direction
= Upload
level; Direction.level = level } ) );
1049 KeyReq
{ Key.key
= DcKey.calculate_key
c.client_lock
});
1051 send_downloading_command dir
c )
1053 | DcConnectionStyle
(MeActive dir
) ->
1054 (match dir
with (* check that direction was not changed on election *)
1055 | Download
65535 -> () (* if was, do nothing and wait the Get from client *)
1056 | _
-> send_downloading_command dir
c )
1061 (*lprintf_nl "Received $Lock";*)
1062 (*lprintf_nl "Client state: %s" (client_state_to_string c);*)
1063 c.client_lock
<- lock
.Lock.key
; (* save the clients lock for later use *)
1065 (match c.client_state
with
1066 | DcDownloadListConnecting _
1067 | DcConnectionStyle
( MeActive _
) -> (* we are answering to a connection initialized by passive client *)
1068 let dir = (* lets set dir to DcDownloadListConnecting also ... *)
1069 (match c.client_state
with
1070 | DcDownloadListConnecting
(level,_
,_
) -> Upload
level
1071 | DcConnectionStyle
( MeActive
dir ) -> dir
1075 (match c.client_user
with
1077 (match user.user_servers
with
1078 | [] -> local_login
()
1079 | s
:: _
-> s
.server_last_nick
) (* pick first servers nick that is known to both... *)
1080 | _
-> local_login
() )
1082 dc_send_msg sock
(MyNickReq
my_nick); (* send nick and lock requests to client *)
1083 dc_send_msg sock
(LockReq
{
1084 Lock.info
= empty_string
;
1085 Lock.key
= DcKey.create_key
;
1086 Lock.extended_protocol
= true
1088 dc_send_msg sock
( SupportsReq
(ClientSupports mldonkey_dc_client_supports
) );
1089 let level = Random.int 32767 in
1092 (match c.client_state
with
1093 | DcConnectionStyle _
-> c.client_state
<- DcConnectionStyle
( MeActive
(Upload
level))
1094 | _
-> () (* DcDownloadListConnecting *) );
1095 dc_send_msg sock
( DirectionReq
{
1096 Direction.direction
= Download
level; (* we are downloading *)
1097 Direction.level = level } )
1098 | Download _
-> (* we set level to 0 so that we lose possible conflict all the time purposely *)
1099 (match c.client_state
with
1100 | DcConnectionStyle _
-> c.client_state
<- DcConnectionStyle
( MeActive
(Download
0))
1101 | _
-> () (* DcDownloadListConnecting *) );
1102 dc_send_msg sock
( DirectionReq
{
1103 Direction.direction
= Upload
0; (* we are uploading *)
1104 Direction.level = level } ) );
1105 dc_send_msg sock
(KeyReq
{ Key.key
= DcKey.calculate_key
c.client_lock
} );
1106 if !verbose_msg_clients
then
1107 lprintf_nl "Sent answer to (%s) (MyNick,Lock,Supports,Direction,Key)" (clients_username
c)
1111 (*lprintf_nl "Received MaxedOut";*)
1112 new_client_error c NoFreeSlots
;
1113 close sock
(Closed_for_error
"MaxedOut from client")
1116 if !verbose_msg_clients
then
1117 lprintf_nl "Received Normal $MyNick with nick (%s)" n
;
1118 (*lprintf_nl "Client state: %s" (client_state_to_string c);*)
1119 connection_ok
c.client_connection_control
;
1121 let u = search_user_by_name n
in (* connect first correct user and client together *)
1122 (match u.user_state
with
1123 | UserActiveUserInitiating
-> (* RevConnect sent, another client present already *)
1124 (* Now we have to swap clients info *)
1126 List.iter
(fun fc
->
1127 (match c.client_state
with
1128 | DcConnectionStyle ClientActive Upload
0 -> raise
(Found_client fc
)
1131 failwith
"Not found client with correct state"
1133 | Found_client fc
->
1134 (match fc
.client_file
with
1135 | Some file
-> add_client_to_file
c file
;
1137 remove_client_from_clients_file fc
;
1140 | UserPassiveUserInitiating _
(* ConnectToMe sent as answer to RevConnect, should not hapen here *)
1141 | UserActiveMeInitiating
(* ConnectToMe sent, another client already present, should not happen in here *)
1143 failwith
"User state is wrong" );
1145 add_client_to_user
c u;
1146 c.client_name
<- Some
u.user_nick
;
1147 set_client_state
c (Connected
0);
1149 (match c.client_state
with (* now decide correct state *)
1150 | DcDownloadListConnecting _
-> () (* if client state is filelist downloading... *)
1152 (match u.user_state
with
1153 | UserActiveUserInitiating
-> (* we sent RevConnect ... *)
1154 c.client_state
<- DcConnectionStyle
(ClientActive
(Upload
0)); (* level assigned later *)
1155 | UserIdle
-> (* totally new connection initialized by client *)
1156 c.client_state
<- DcConnectionStyle
(ClientActive
(Download
0))
1158 failwith
"Invalid user state" )
1160 u.user_state
<- UserIdle
; (* not needed anymore *)
1162 if !verbose_unexpected_messages
|| !verbose_msg_clients
then
1163 lprintf_nl "In normal MyNick: (%s) when received nick=(%s)" (Printexc2.to_string e
) n
;
1164 close sock
(Closed_for_error
"Error in $MyNick") )
1167 (*lprintf_nl "Received or commanded $Send";*)
1169 (match c.client_state
with
1170 | DcUploadListStarting
fname ->
1171 let file_fd = Unix32.create_ro
fname in
1172 c.client_state
<- DcUploadList
file_fd;
1173 c.client_endpos
<- Unix32.getsize64
file_fd;
1174 let file = new_upfile None
file_fd in
1175 c.client_file
<- Some
file;
1176 set_clients_upload
c (as_file
file.file_file
);
1177 | DcUploadStarting
(dcsh,start_pos
,bytes) ->
1179 if bytes = Int64.minus_one
then dcsh.dc_shared_size
1181 let client_wants = start_pos
++ bytes in (* if client requests too much data *)
1182 if client_wants > dcsh.dc_shared_size
then failwith
"Start_pos + bytes > dcsh.dc_shared_size"
1186 let file_fd = Unix32.create_ro
dcsh.dc_shared_fullname
in
1187 c.client_state
<- DcUpload
(dcsh,file_fd,start_pos
,bytes);
1188 c.client_endpos
<- endpos;
1189 let file = new_upfile
(Some
dcsh) file_fd in
1190 c.client_file
<- Some
file;
1191 set_clients_upload
c (as_file
file.file_file
);
1192 | _
-> failwith
"Wrong client state in Send" );
1194 set_client_has_a_slot
(as_client
c.client_client
) NormalSlot
;
1195 (*client_enter_upload_queue (as_client c.client_client);*)
1196 TcpBufferedSocket.set_wtimeout sock
(float !!client_write_timeout
)
1199 lprintf_nl "Exception %s in upload creation" (Printexc2.to_string e
);
1200 close sock
(Closed_for_error
"Error in upload creation");
1201 failwith
"Error in upload creation" )
1203 | SupportsReq t
-> (* After EXTENDEDPROTOCOL support list from client ... *)
1204 (*lprintf_nl "Received $Supports";*)
1206 | ClientSupports t
-> c.client_supports
<- Some t
(* Save supports into clientdata *)
1211 if !verbose_unexpected_messages
|| !verbose_msg_clients
then begin
1212 let l = String.length s
in
1213 let txt = Printf.sprintf
"Unknown client message: (%s)" (clients_username
c) in
1214 if l > 50 then lprintf_nl "%s (%s...%d chars)" txt (shorten_string s
50) l
1215 else lprintf_nl "%s (%s)" txt s
1219 lprintf_nl "--> Unhandled client message. Implement ?:";
1220 DcProtocol.dc_print t
)
1222 (* Find next download from this user/client *)
1223 let find_next_client c =
1224 (match c.client_user
with
1227 if !verbose_download
then lprintf_nl "Trying to find next download to user (%s)" u.user_nick
;
1229 List.iter
(fun cl
-> (* check first if filelist is waiting ... *)
1230 (match cl
.client_state
with
1231 | DcDownloadListWaiting
-> raise
(Found_client cl
)
1233 ) u.user_clients
; (* then normal downloads ... *)
1234 List.iter
(fun cl
->
1235 (match cl
.client_state
with
1236 | DcDownloadWaiting _
-> raise
(Found_client cl
)
1239 None
(* return false to calling function that closes the socket *)
1241 | Found_client cl
-> (Some cl
) (* we have a next file with existing client to download *)
1245 (* Start next download from user and if change, current client <-> pending client *)
1246 (* Remove other client if not change *)
1247 let next_download change
c sock cl
= (* c is current connection, cl is the pending download *)
1248 (match cl
.client_state
with
1249 | DcDownloadWaiting
file ->
1250 if change
then begin (* we need to change current download with pending one *)
1251 (match c.client_state
with
1252 | DcDownload
f -> (* here we exchange pending client to existing client socket *)
1253 c.client_state
<- DcDownload
file;
1254 cl
.client_state
<- DcDownloadWaiting
f;
1255 remove_client_from_clients_file
c;
1256 remove_client_from_clients_file cl
;
1257 add_client_to_file
c file;
1258 add_client_to_file cl
f;
1261 remove_client_from_clients_file
c; (* because file commit removes the file <-> client connection also, *)
1262 (* this has to be done before assigning new file to this reused client, *)
1263 (* so that file remove don't erase this clients file *)
1264 add_client_to_file
c file; (* no change needed *)
1265 remove_client cl
; (* remove not needed client *)
1266 c.client_state
<- DcDownload
file;
1267 dc_send_download_command c sock
1269 | DcDownloadListWaiting
->
1270 if not change
then begin (* filelists changing not currently possible *)
1272 c.client_state
<- DcDownloadListConnecting
(0,!!firewalled
,nan
);
1273 dc_send_download_command c sock
1277 (* File is finished downloading, so remove file from clients list and client from files list *)
1278 let file_complete file =
1279 if !verbose_download
then lprintf_nl "File %s downloaded" file.file_name
;
1280 file_completed
(as_file
file.file_file
); (* update_file_state impl FileDownloaded; *)
1281 List.iter
(fun c -> (* remove this files clients except current connection *)
1282 (match c.client_state
with (* because we use this connection possibly for next download *)
1283 | DcDownload
f -> () (* only one client should be in this state *)
1288 let closing_text = "All files downloaded"
1289 (* Continue downloading from client that we have initialized *)
1290 let client_downloaded c sock nread
= (* TODO check tth while loading, abort if error *)
1291 if nread
> 0 then begin
1292 (match c.client_state
with
1293 | DcDownload
file ->
1294 let b = TcpBufferedSocket.buf sock
in
1296 if c.client_preread_bytes_left
> 0 then begin (* if precheck not yet done *)
1297 let check_bytes = min nread
c.client_preread_bytes_left
in (* which is smaller... *)
1298 let check_buffer = String.create
check_bytes in
1299 Unix32.read
(file_fd file) (c.client_pos
-- (Int64.of_int
c.client_preread_bytes_left
))
1300 check_buffer 0 check_bytes;
1301 let str2 = String.sub
b.buf
b.pos
check_bytes in
1302 if (String.compare
check_buffer str2) = 0 then begin (* if downloaded is ok *)
1303 c.client_preread_bytes_left
<- c.client_preread_bytes_left
- check_bytes;
1304 if c.client_preread_bytes_left
= 0 then begin (* if checked all preread bytes *)
1305 let downloaded = b.len
- check_bytes in
1306 if downloaded > 0 then begin (* check if buffer has bytes to write to file *)
1307 Unix32.write
(file_fd file) c.client_pos
b.buf
(b.pos
+check_bytes) downloaded
1309 Int64.of_int
downloaded
1311 end else begin (* if file check failed *)
1312 if !verbose_download
then
1313 lprintf_nl "Corrupted file (%s) download from (%s)" file.file_name
(clients_username
c);
1314 c.client_state
<- DcIdle
; (* now closing sock removes the client also *)
1315 close sock
(Closed_for_error
"Corrupted file");
1318 end else begin (* precheck done, normal flow *)
1319 Unix32.write
(file_fd file) c.client_pos
b.buf
b.pos
b.len
;
1323 c.client_pos
<- c.client_pos
++ downloaded;
1324 (match c.client_user
with
1325 | Some
u -> u.user_downloaded
<- u.user_downloaded
++ downloaded
1327 c.client_downloaded <- c.client_downloaded ++ downloaded;
1329 if c.client_pos
> (file_downloaded
file) then (* update downloading state *) (* TODO check tth while loading *)
1330 add_file_downloaded
(as_file
file.file_file
) (c.client_pos
-- (file_downloaded
file));
1331 if (file_downloaded
file) = (file_size
file) then begin
1333 c.client_receiving
<- Int64.zero
; (* this marks client as receiving normal commands again *)
1334 c.client_pos
<- Int64.zero
;
1335 TcpBufferedSocket.set_rtimeout sock infinite_timeout
; (* back to normal *)
1336 (* update myinfo ? *)
1337 (match (find_next_client c) with (* try to continue slot *)
1338 | Some cl
-> next_download false c sock cl
(* connected client , sock , client download_waiting *)
1340 c.client_state
<- DcIdle
; (* now closing sock removes the client also *)
1341 close sock
(Closed_for_error
closing_text) )
1344 | DcDownloadList
filelist_fd -> (* downloading file list *)
1345 let b = TcpBufferedSocket.buf sock
in
1346 let len = Int64.of_int
b.len in
1347 Unix32.write
filelist_fd c.client_pos
b.buf
b.pos
b.len;
1348 c.client_pos
<- c.client_pos
++ len;
1349 (match c.client_user
with
1350 | Some
u -> u.user_downloaded
<- u.user_downloaded
++ len
1352 c.client_downloaded <- c.client_downloaded ++ len;
1353 c.client_receiving
<- c.client_receiving
-- len;
1355 if c.client_receiving
= Int64.zero
then begin
1356 Unix32.close
filelist_fd;
1357 if !verbose_download
then lprintf_nl "Received filelist from (%s)" (clients_username
c);
1358 c.client_receiving
<- Int64.zero
; (* this marks client as receiving commands again *)
1359 c.client_pos
<- Int64.zero
;
1360 TcpBufferedSocket.set_rtimeout sock infinite_timeout
;
1361 (match (find_next_client c) with
1363 next_download false c sock cl
(* connected client , sock , client download_waiting *)
1365 c.client_state
<- DcIdle
;
1366 close sock
(Closed_for_error
closing_text) )
1368 | _
-> raise Not_found
)
1371 (* initialize a new connection when nothing is known from client *)
1372 let init_anon_client sock
=
1373 TcpBufferedSocket.set_read_controler sock download_control
;
1374 TcpBufferedSocket.set_write_controler sock upload_control
;
1375 TcpBufferedSocket.set_rtimeout sock infinite_timeout
; (* client timeouts *)
1376 TcpBufferedSocket.set_wtimeout sock infinite_timeout
;
1377 TcpBufferedSocket.set_reader sock
(dc_handler_client
(ref (None
))
1378 read_first_message client_reader client_downloaded)
1380 (* create listening socket for incoming connection, return socket or None *)
1381 let create_tcp_socket () =
1383 let sock = TcpServerSocket.create
"DC client listening" (Ip.to_inet_addr
!!client_bind_addr
) !!dc_port
1386 | TcpServerSocket.CONNECTION
(s
, Unix.ADDR_INET
(from_ip
, from_port
)) ->
1387 (*lprintf_nl "Listen: connection received from %s:%d"
1388 (Ip.to_string (Ip.of_inet_addr from_ip)) from_port; *)
1390 (* CHECK Allow this connection or not ? *)
1391 let token = create_token connection_manager
in
1392 let sock = TcpBufferedSocket.create
token
1393 "DC client connection" s
client_handler(*(fun _ _ -> ())*) in
1394 init_anon_client sock
1397 (*lprintf_nl "Created listening socket..." ;*)
1398 dc_tcp_listen_sock
:= Some
sock;
1399 (match (Unix.getsockname
(BasicSocket.fd
(TcpServerSocket.sock sock))) with
1400 | Unix.ADDR_INET
(addr
,port
) -> Some
sock
1402 with e
-> lprintf_nl "Exception %s while initializing DC listen socket" (Printexc2.to_string e
);
1407 (* Parse udp messages *)
1408 let udp_parse buf
sock =
1409 if !verbose_udp
then lprintf_nl "UDP Receive: (%s)" buf
;
1410 let str = String2.splitn buf ' '
1 in
1413 let module S
= SR
in
1414 let msg = S.parse
(String2.replace args '
|' empty_string
) in (* strip following '|' from message *)
1415 if msg.S.filename
= empty_string
then ()
1416 (*lprintf_nl "This result seems to be directory result, we don't support it atm."*)
1419 let s = Hashtbl.find servers_by_ip
msg.S.server_ip
in
1420 received_new_search_result s msg;
1421 with _
-> if !verbose_udp
then
1422 lprintf_nl "UDP: Not valid ip-address (%s) in $SR" msg.S.server_ip
)
1424 | [cmd
] -> if !verbose_udp
then lprintf_nl "UDP: Unknown command %s" cmd
1425 | _
-> if !verbose_udp
then lprintf_nl "UDP: Unknown message %s" (String.escaped buf
) )
1428 let udp_send ip port m
=
1432 Buffer.add_char buf '
|'
;
1433 let s = Buffer.contents buf
in
1434 (match !dc_udp_sock
with
1436 (*if !verbose_udp || !verbose_msg_clients then lprintf_nl "UDP Send: (%s)" s;*)
1437 UdpSocket.write
sock false s ip port
1438 | None
-> failwith
"No UDP socket" );
1440 if !verbose_udp
|| !verbose_msg_clients
then
1441 lprintf_nl "Exception (%s) in UDP send" (Printexc2.to_string e
) )
1443 (* Udp event handling *)
1444 let udp_handler sock event
=
1446 | UdpSocket.READ_DONE
->
1447 UdpSocket.read_packets
sock (fun p
->
1449 let pbuf = p
.UdpSocket.udp_content
in
1450 let len = String.length
pbuf in
1457 (* create listening udp port *)
1458 let create_udp_socket () =
1460 let sock = UdpSocket.create
(Ip.to_inet_addr
!!client_bind_addr
) !!dc_port
1461 (fun sock event
-> udp_handler sock event
)
1463 dc_udp_sock
:= Some
sock;
1464 UdpSocket.set_write_controler
sock udp_write_controler
;
1467 lprintf_nl "Exception %s while binding UDP socket" (Printexc2.to_string e
);
1470 (* Start a connection to client *)
1471 let connect_client c =
1473 add_pending_connection connection_manager
(fun token ->
1475 match c.client_addr
with
1478 connection_try
c.client_connection_control
;
1479 let sock = TcpBufferedSocket.connect
token "client connection" (Ip.to_inet_addr ip
) port
1480 client_handler (*(fun _ _ -> ())*)
1482 TcpBufferedSocket.set_read_controler
sock download_control
; (* CommonGlobals.download_control *)
1483 TcpBufferedSocket.set_write_controler
sock upload_control
;
1484 TcpBufferedSocket.set_rtimeout
sock infinite_timeout
; (* client timeouts *)
1485 TcpBufferedSocket.set_wtimeout
sock infinite_timeout
;
1486 TcpBufferedSocket.set_closer
sock (fun _ reason
-> client_disconnected sock reason
c);
1487 TcpBufferedSocket.set_reader
sock (dc_handler_client
(ref (Some
c)) read_first_message
1488 client_reader client_downloaded);
1489 init_connection c sock; (* Send first answer messages to client *)
1491 lprintf_nl "Exception: %s, while connecting to client" (Printexc2.to_string e
);
1493 c.client_sock
<- ConnectionWaiting
token
1495 (* Upload to client *)
1496 let dc_upload c bytes =
1497 (match c.client_sock
with
1498 | Connection
sock ->
1500 if (bytes > 0) && can_write_len
sock bytes then begin
1501 (* update upload rate from len bytes *)
1502 (*Rate.update c.client_upload_rate (float_of_int len);*)
1505 count_filerequest c; *)
1507 (match c.client_state
with
1508 | DcUpload
(_
,fd
,_
,_
) -> fd
1509 | DcUploadList fd
-> fd
1510 | _
-> failwith
"No fd in upload" )
1513 let rem = Int64.to_int
(c.client_endpos
-- c.client_pos
) in
1514 if rem > bytes then bytes else rem
1516 CommonUploads.consume_bandwidth
rlen;
1517 let upload_buffer = String.create
rlen in
1518 Unix32.read
file_fd c.client_pos
upload_buffer 0 rlen;
1519 TcpBufferedSocket.write
sock upload_buffer 0 rlen;
1520 (*lprintf_nl " Wrote (%d) bytes" rlen;*)
1521 let uploaded = Int64.of_int
rlen in
1522 c.client_pos
<- c.client_pos
++ uploaded;
1523 dc_total_uploaded
:= !dc_total_uploaded
++ uploaded;
1524 (match c.client_user
with
1525 | Some
u -> u.user_uploaded
<- u.user_uploaded
++ uploaded
1527 c.client_uploaded
<- c.client_uploaded
++ uploaded;
1528 (match c.client_state
with
1529 | DcUpload
(dcsh,_
,_
,_
) ->
1531 let sh = CommonUploads.find_by_name
dcsh.dc_shared_codedname
in
1532 sh.shared_impl
.impl_shared_uploaded
<- c.client_pos
;
1533 shared_must_update
(as_shared
sh.shared_impl
)
1536 if c.client_pos
= c.client_endpos
then begin
1537 if !verbose_upload
then lprintf_nl "Finished uploading to (%s)" (clients_username
c);
1538 Unix32.close
file_fd;
1539 set_refill
sock (fun _
-> () );
1540 (match c.client_state
with
1541 | DcUpload
(dcsh,_
,_
,_
) ->
1542 if not
(counts_as_minislot
dcsh.dc_shared_size
) then dc_remove_uploader
() (* slots *)
1544 c.client_state
<- DcUploadDoneWaitingForMore
;
1545 set_client_has_a_slot
(as_client
c.client_client
) NoSlot
; (* inform GUI *)
1546 TcpBufferedSocket.set_lifetime
sock (float !!wait_for_next_upload
);
1548 ready_for_upload
(as_client
c.client_client
);
1550 end else begin (* HMMM Is it ok to bang this line over and over again ? *)
1551 ready_for_upload
(as_client
c.client_client
)
1554 if !verbose_upload
then lprintf_nl "Exception (%s) in upload" (Printexc2.to_string e
);
1555 new_client_error c UploadError
)
1557 if !verbose_upload
then
1558 lprintf_nl "Socket not connected in uploading to (%s)" (clients_username
c);
1559 c.client_state
<- DcIdle
;
1560 set_client_has_a_slot
(as_client
c.client_client
) NoSlot
;
1561 dc_disconnect_client c (Closed_for_error
"No socket in upload") )
1565 (* register client operations *)
1567 client_ops
.op_client_info
<- (fun c ->
1568 let name = clients_username
c in
1569 let kind,total_downloaded
,total_uploaded
=
1571 (match c.client_addr
with
1572 | Some
(ip,port
) -> ip,port
1573 | None
-> Ip.null
,0 )
1575 (match c.client_user
with
1578 if (user_active
user) then Known_location
(ip,port
)
1579 else Indirect_location
(empty_string
,Md4.null
,ip,port
)
1581 kind,user.user_downloaded
,user.user_uploaded
1583 let kind = Indirect_location
(empty_string
,Md4.null
,ip,port
) in
1584 kind,Int64.zero
,Int64.zero
)
1586 let software, version
=
1587 match c.client_user
with
1588 | Some
u -> u.user_myinfo
.client_brand
, u.user_myinfo
.version
1589 | None
-> empty_string
, empty_string
1592 (match c.client_file
with
1593 | Some
file -> file.file_name
1596 { (impl_client_info
c.client_client
) with
1597 P.client_network
= network
.network_num
;
1598 P.client_kind
= kind;
1599 P.client_state
= client_state
(as_client
c.client_client
);
1600 P.client_type
= client_type
c;
1601 P.client_name
= name;
1602 P.client_num
= (client_num
(as_client
c.client_client
));
1603 P.client_connect_time
= c.client_connect_time
;
1604 P.client_software
= software;
1605 P.client_release
= version
;
1606 P.client_emulemod
= empty_string
;
1607 P.client_session_downloaded
= c.client_downloaded;
1608 P.client_session_uploaded
= c.client_uploaded
;
1609 P.client_total_downloaded
= total_downloaded
;
1610 P.client_total_uploaded
= total_uploaded
;
1611 P.client_upload
= Some
filename;
1612 P.client_sui_verified
= None
; (* new 2.6.5 *)
1613 (* P.client_sock_addr = ""; *)
1616 client_ops
.op_client_browse
<- (fun _ _ -> lprintf_nl "Received (op_client_browse)" );
1617 client_ops
.op_client_can_upload
<- (fun c bytes -> dc_upload c bytes );
1618 client_ops
.op_client_enter_upload_queue
<- (fun c ->
1619 if !verbose_msg_clients
|| !verbose_upload
then
1620 lprintf_nl "Client (%s) started to upload" (clients_username
c);
1621 ready_for_upload
(as_client
c.client_client
)
1625 mutable op_client_network : CommonTypes.network;
1626 mutable op_client_connect : 'a -> unit;
1627 mutable op_client_disconnect : 'a -> unit;
1628 mutable op_client_say : 'a -> string -> unit;
1629 mutable op_client_files : 'a -> (string * CommonTypes.result) list;
1630 mutable op_client_clear_files : 'a -> unit;
1631 mutable op_client_bprint : 'a -> Buffer.t -> unit;
1632 mutable op_client_dprint :
1633 'a -> CommonTypes.ui_conn -> CommonTypes.file -> unit;
1634 mutable op_client_dprint_html :
1635 'a -> CommonTypes.ui_conn -> CommonTypes.file -> string -> bool;
1636 mutable op_client_debug : 'a -> bool -> unit;