[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Mldonkey-commits] mldonkey distrib/ChangeLog src/networks/direct_...
|
From: |
mldonkey-commits |
|
Subject: |
[Mldonkey-commits] mldonkey distrib/ChangeLog src/networks/direct_... |
|
Date: |
Wed, 08 Sep 2010 16:31:51 +0000 |
CVSROOT: /sources/mldonkey
Module name: mldonkey
Changes by: spiralvoice <spiralvoice> 10/09/08 16:31:51
Modified files:
distrib : ChangeLog
src/networks/direct_connect: dcClients.ml dcInteractive.ml
dcProtocol.ml dcShared.ml
dcTypes.ml
Log message:
patch #7308
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/mldonkey/distrib/ChangeLog?cvsroot=mldonkey&r1=1.1473&r2=1.1474
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcClients.ml?cvsroot=mldonkey&r1=1.18&r2=1.19
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcInteractive.ml?cvsroot=mldonkey&r1=1.39&r2=1.40
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcProtocol.ml?cvsroot=mldonkey&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcShared.ml?cvsroot=mldonkey&r1=1.6&r2=1.7
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcTypes.ml?cvsroot=mldonkey&r1=1.8&r2=1.9
Patches:
Index: distrib/ChangeLog
===================================================================
RCS file: /sources/mldonkey/mldonkey/distrib/ChangeLog,v
retrieving revision 1.1473
retrieving revision 1.1474
diff -u -b -r1.1473 -r1.1474
--- distrib/ChangeLog 8 Sep 2010 16:29:23 -0000 1.1473
+++ distrib/ChangeLog 8 Sep 2010 16:31:50 -0000 1.1474
@@ -15,6 +15,7 @@
=========
2010/09/08
+7308: DC: handle ADCGET list (ygrek)
7307: New make target "tests" for unit tests (ygrek)
7306: DC: show client brand, session transfer and duration (ygrek)
Index: src/networks/direct_connect/dcClients.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcClients.ml,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -b -r1.18 -r1.19
--- src/networks/direct_connect/dcClients.ml 8 Sep 2010 16:26:04 -0000
1.18
+++ src/networks/direct_connect/dcClients.ml 8 Sep 2010 16:31:50 -0000
1.19
@@ -582,7 +582,8 @@
let read_first_message t sock =
(match t with
| MyNickReq n -> (* if very first client to client
message is $MyNick, then continue... *)
- if !verbose_msg_clients then lprintf_nl "Received FIRST MyNick with name
(%s)" n;
+ let ip,port as peer_addr = TcpBufferedSocket.peer_addr sock in
+ if !verbose_msg_clients then lprintf_nl "Received FIRST MyNick with name
%S from %s:%u" n (Ip.to_string ip) port;
(try
let u = search_user_by_name n in (* check if user with this name
exists *)
let c =
@@ -624,7 +625,7 @@
lprintf_nl "Should not happen: In FIRST MyNick user (%s)" n;
raise Not_found ) );
u.user_state <- UserIdle; (* initialize user_state for later
correct usage *)
- c.client_addr <- Some (TcpBufferedSocket.peer_addr sock);
+ c.client_addr <- Some peer_addr;
init_connection c sock;
Some c (* return client *)
with _ ->
@@ -651,12 +652,11 @@
(* Send download commands to client *)
let dc_send_download_command c sock =
let xmlbzlist, adc, tthf = get_client_supports c in
- let fname, from_pos , tth =
- (match c.client_state with
+ let name, from_pos =
+ match c.client_state with
| DcDownload file ->
let separator = String2.of_char '/' in
let fname = file.file_directory ^ separator ^ file.file_name in
- let fname = if adc then separator ^ fname else fname in (* adc needs
trailing '/' *)
let preload_bytes = (* calculate
preread bytes position *)
let from_pos = file_downloaded file in
if from_pos < int64_kbyte then begin (* if read
under 1k bytes from client, start over *)
@@ -668,40 +668,44 @@
end
in
c.client_preread_bytes_left <- preload_bytes;
- fname, c.client_pos -- (Int64.of_int preload_bytes),
file.file_unchecked_tiger_root
+ `Normal (fname, file.file_unchecked_tiger_root), c.client_pos --
(Int64.of_int preload_bytes)
| _ ->
c.client_pos <- Int64.zero;
- if xmlbzlist then
- mylistxmlbz2, c.client_pos, empty_string
- else
- mylist, c.client_pos , empty_string )
+ `List (if xmlbzlist then mylistxmlbz2 else mylist), c.client_pos
in
if !verbose_msg_clients || !verbose_download then
+ begin
+ let (fname,tth) = match name with `Normal (name,tth) -> name,tth | `List
name -> name,"" in
lprintf_nl "Sending $Get/$ADCGET: (%s)(%s)(%s)(%Ld)" (clients_username c)
fname tth from_pos;
- if adc then begin (* if client
supports adc ...*)
- let fname = if (tth <> "") && tthf (* if client
supports tthf ... *)
- then empty_string (* only tth or
filename is sent valid *)
- else fname
- in
- dc_send_msg sock ( AdcGetReq {
- AdcGet.adctype = AdcFile;
- AdcGet.fname = fname;
- AdcGet.tth = tth;
- AdcGet.start_pos = from_pos;
- AdcGet.bytes = Int64.minus_one; (* TODO load file
from from_pos to anywhere *)
- AdcGet.zl = false;
- } )
- end else if xmlbzlist then begin (* if client
supports ugetblock ...*)
- dc_send_msg sock ( UGetBlockReq {
- UGetBlock.ufilename = fname;
+ end;
+ let msg = match adc, tthf, name with
+ | true, true, `Normal (_,tth) when tth <> "" ->
+ AdcGetReq {
+ AdcGet.adctype = AdcFile (NameTTH tth);
+ start_pos = from_pos;
+ bytes = Int64.minus_one; (* TODO load file from
from_pos to anywhere *)
+ zl = false;
+ }
+ | true, _, `List name ->
+ AdcGetReq {
+ AdcGet.adctype = AdcFile (NameSpecial name); (* FIXME AdcList *)
+ start_pos = from_pos;
+ bytes = Int64.minus_one;
+ zl = false;
+ }
+ | _, _, (`Normal (name,_) | `List name) ->
+ if xmlbzlist then (* if client supports ugetblock ...*)
+ UGetBlockReq {
+ UGetBlock.ufilename = name;
UGetBlock.ubytes = Int64.minus_one;
UGetBlock.upos = from_pos;
- } )
- end else begin (* else send
normal GET *)
- dc_send_msg sock ( GetReq {
- Get.filename = fname;
- Get.pos = Int64.succ from_pos } )
- end
+ }
+ else (* else send normal GET *)
+ GetReq {
+ Get.filename = name;
+ Get.pos = Int64.succ from_pos }
+ in
+ dc_send_msg sock msg
(* clients messages normal reader *)
let rec client_reader c t sock =
@@ -870,19 +874,7 @@
| AdcGetReq _
| GetReq _
| UGetBlockReq _ -> (* TODO downloading a section of file *) (* TODO state
checking ? *)
- let fname, tth, start_pos, bytes, zl =
- (match t with
- | AdcGetReq t ->
- (*lprintf_nl "Received $AdcGet (%s) (%s) %Ld %Ld" t.AdcGet.fname
t.AdcGet.tth t.AdcGet.start_pos t.AdcGet.bytes;*)
- t.AdcGet.fname, t.AdcGet.tth, t.AdcGet.start_pos, t.AdcGet.bytes,
t.AdcGet.zl
- | GetReq t ->
- (*lprintf_nl "Received $Get %s %Ld" t.Get.filename t.Get.pos;*)
- t.Get.filename, empty_string, (Int64.pred t.Get.pos),
Int64.minus_one, false
- | UGetBlockReq t ->
- (*lprintf_nl "Received $UGetBlock %Ld %Ld %s" t.UGetBlock.upos
t.UGetBlock.ubytes t.UGetBlock.ufilename;*)
- t.UGetBlock.ufilename, empty_string, t.UGetBlock.upos,
t.UGetBlock.ubytes, false
- | _ -> raise Not_found )
- in
+
if (c.client_state = DcUploadDoneWaitingForMore) then begin (* if this
is a continual loading *)
if !verbose_upload || !verbose_msg_clients then lprintf_nl "
Continuing upload/slot";
TcpBufferedSocket.set_lifetime sock infinite_timeout; (* restore
connection lifetime *)
@@ -895,94 +887,134 @@
| _ -> false );
in
- if (fname = mylist) || (fname = mylistxmlbz2) then begin (* client
wants our filelist *)
- let mylist_filename =
- if (fname = mylist) then (Filename.concat directconnect_directory
mylist)
- else if (fname = mylistxmlbz2) then (Filename.concat
directconnect_directory mylistxmlbz2)
- else begin
- if !verbose_upload && !verbose_unexpected_messages then lprintf_nl
"Invalid mylistname";
- raise Not_found
- end
+ begin try
+
+ let req =
+ match t with
+ | AdcGetReq { AdcGet.zl = true } ->
+ failwith "ZLib not yet supported"
+
+ | AdcGetReq { AdcGet.adctype = AdcList (dir,re1) } -> `PartialList
(dir,re1)
+
+ | AdcGetReq { AdcGet.adctype = AdcFile (NameSpecial name) }
+ | GetReq { Get.filename = name }
+ | UGetBlockReq { UGetBlock.ufilename = name }
+ when name = mylist || name = mylistxmlbz2 -> `FullList name
+
+ | AdcGetReq { AdcGet.adctype = AdcFile (NameSpecial name) } ->
+ failwith ("ADCGET special name not supported : " ^ name)
+
+ | AdcGetReq { AdcGet.adctype = AdcFile (NameTTH tth); start_pos=start;
bytes=bytes } ->
+ `File (`TTH tth, start, bytes)
+
+ | GetReq t ->
+ let name = String2.replace t.Get.filename char92 "/" in
+ `File (`Name name, Int64.pred t.Get.pos, Int64.minus_one)
+
+ | UGetBlockReq t ->
+ let name = String2.replace t.UGetBlock.ufilename char92 "/" in
+ `File (`Name name, t.UGetBlock.upos, t.UGetBlock.ubytes)
+
+ | _ -> failwith "Unexpected request"
in
+ match req with
+ | `FullList name ->
+ lprintf_nl "Client %S requested FullList %s" (clients_username c) name;
+
+ let mylist_filename = Filename.concat directconnect_directory name in
c.client_state <- DcUploadListStarting mylist_filename;
c.client_pos <- Int64.zero;
let size = Unix32.getsize mylist_filename in
- (match t with
- | AdcGetReq _ ->
- if zl then begin
- if !verbose_upload && !verbose_unexpected_messages then
lprintf_nl "Zlib not yet supported";
- raise Not_found
- end;
+ begin match t with
+ | AdcGetReq t ->
dc_send_msg sock (AdcSndReq {
- AdcSnd.adctype = AdcFile;
- AdcSnd.fname = fname;
- AdcSnd.tth = tth;
- AdcSnd.start_pos = start_pos;
+ AdcSnd.adctype = t.AdcGet.adctype;
+ AdcSnd.start_pos = 0L;
AdcSnd.bytes = size;
AdcSnd.zl = false; (* CHECK *)
});
client_reader c SendReq sock (* call ourselves
again with send starting *)
| _ -> (* GetReq _ |
UGetBlockReq _ *)
- dc_send_msg sock (FileLengthReq size) );
+ dc_send_msg sock (FileLengthReq size)
+ end
- end else begin (* client wants
normal file *)
- let fname = String2.replace fname char92 "/" in
- (try
- (*lprintf_nl "Client (%s) wants to download %s (%s) %Ld bytes from
pos: %Ld" (clients_username c)
- fname tth bytes start_pos;*)
- let dcsh =
- if tth <> "" then begin
+ | `PartialList (dir,_re) ->
+ lprintf_nl "Client %s requested PartialList %s" (clients_username c)
dir;
+
+ let mylist = try DcShared.make_xml_mylist (DcShared.find_dir_exn
dir)
+ with exn -> failwith (Printf.sprintf "PartialList %s : %s" dir
(Printexc2.to_string exn))
+ in
+ let filename = Filename.concat directconnect_directory
+ (DcGlobals.safe_filename (Printf.sprintf "mylist.%s.partial.xml"
(clients_username c)))
+ in
+ DcShared.buffer_to_bz2_to_file mylist filename;
+ c.client_state <- DcUploadListStarting filename;
+ c.client_pos <- Int64.zero;
+ let size = Int64.of_int (Buffer.length mylist) in
+ begin match t with
+ | AdcGetReq t ->
+ dc_send_msg sock (AdcSndReq {
+ AdcSnd.adctype = t.AdcGet.adctype;
+ AdcSnd.start_pos = 0L;
+ AdcSnd.bytes = size;
+ AdcSnd.zl = false; (* CHECK *)
+ });
+ client_reader c SendReq sock (* call ourselves
again with send starting *)
+ | _ -> (* GetReq _ |
UGetBlockReq _ *)
+ assert false
+ end
+
+ | `File (name, start_pos, bytes) -> (* client wants normal file *)
+ let dcsh = match name with
+ | `TTH tth ->
(try (* lets find file by
tth *)
- Hashtbl.find dc_shared_files_by_hash tth (* if found, return
files name *)
+ Hashtbl.find dc_shared_files_by_hash tth
with _ ->
- if !verbose_upload then lprintf_nl "Shared file not found by
tth (%s) in Get/Adcget" tth;
- raise Not_found )
- end else begin
+ failwith (Printf.sprintf "Shared file not found by tth %S"
tth))
+ | `Name fname ->
(try (* so lets find
filename then *)
Hashtbl.find dc_shared_files_by_codedname fname
with _ ->
- if !verbose_upload then lprintf_nl "Shared file not found by
codedname (%s) in Get/AdcGet" fname ;
- raise Not_found )
- end
+ failwith (Printf.sprintf "Shared file not found by codedname
%S" fname))
in
+ lprintf_nl "Client %S wants to download %S (%s) %Ld bytes from pos:
%Ld" (clients_username c)
+ dcsh.dc_shared_fullname dcsh.dc_shared_tiger_root bytes
start_pos;
(* check if upload still exists *)
c.client_pos <- start_pos;
let rem = dcsh.dc_shared_size -- c.client_pos in
- if dc_can_upload () || (counts_as_minislot dcsh.dc_shared_size) then
begin (* if free slots or file size *)
+ if dc_can_upload () || (counts_as_minislot dcsh.dc_shared_size) then
+ begin (* if free slots or file size *)
if not (counts_as_minislot dcsh.dc_shared_size) then
dc_insert_uploader ();(* increase uploaders *)
c.client_state <- DcUploadStarting (dcsh,start_pos,bytes);
(match t with
- | AdcGetReq _ ->
- if zl then begin
- if !verbose_upload && !verbose_unexpected_messages then
lprintf_nl "Zlib not yet supported";
- raise Not_found
- end;
+ | AdcGetReq t ->
dc_send_msg sock (AdcSndReq {
- AdcSnd.adctype = AdcFile;
- AdcSnd.fname = fname;
- AdcSnd.tth = tth;
- AdcSnd.start_pos = start_pos;
- AdcSnd.bytes = bytes;
- AdcSnd.zl = false; (* CHECK *)
+ AdcSnd.adctype = t.AdcGet.adctype;
+ start_pos = start_pos;
+ bytes = bytes;
+ zl = false; (* CHECK *)
} );
client_reader c SendReq sock (* call ourselves
again with send starting *)
| _ -> (* GetReq _ |
UGetBlockReq _ *)
- dc_send_msg sock (FileLengthReq rem) );
+ dc_send_msg sock (FileLengthReq rem) )
end else begin
(*lprintf_nl "Sending MaxedOut to (%s)" (clients_username c);*)
dc_send_msg sock MaxedOutReq;
close sock (Closed_for_error ("By us: Maxedout"))
end
- with _ ->
+ with exn ->
+ if !verbose_upload then
+ lprintf_nl "Error answering GET/ADCGET: %s" (Printexc2.to_string
exn);
let errortxt = "File Not Available" in
- (match t with
+ begin match t with
| AdcGetReq _
| GetReq _ ->
dc_send_msg sock (ErrorReq errortxt)
| _ -> (* UGetBlockReq _ *)
- dc_send_msg sock (FailedReq errortxt) );
- close sock (Closed_for_error ("By us:" ^ errortxt)) )
+ dc_send_msg sock (FailedReq errortxt)
+ end;
+ close sock (Closed_for_error ("By us:" ^ errortxt))
end;
if direction_change then begin (* now the users
clients states wont interfere this check *)
(match c.client_user with (* we can check if we
can start new download immediately *)
Index: src/networks/direct_connect/dcInteractive.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/direct_connect/dcInteractive.ml,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -b -r1.39 -r1.40
--- src/networks/direct_connect/dcInteractive.ml 18 Jul 2010 10:59:20
-0000 1.39
+++ src/networks/direct_connect/dcInteractive.ml 8 Sep 2010 16:31:50
-0000 1.40
@@ -290,7 +290,7 @@
num
(td_command
(if s.server_autoconnect then "UnSet" else "Set")
- "Set this server/hub autoconnection state"
+ "Set this hub autoconnection state"
["dcautoconnect"; (if s.server_autoconnect then "false" else "true");
sip] )
sname sip sport sstate
(td_command (string_of_int susers) "Show users for this hub only"
["dcusers";sip] )
@@ -1336,13 +1336,14 @@
), "<name> : Show filelist for user";
"dcautoconnect", Arg_two (fun arg1 arg2 o ->
- (try
+ show_dc_buttons o;
+ try
let s = Hashtbl.find servers_by_ip arg2 in
let auto = bool_of_string arg1 in
s.server_autoconnect <- auto;
- server_must_update s
- with _ -> () );
+ server_must_update s;
"ok"
+ with exn -> Printf.sprintf "Failed : %s" (Printexc2.to_string exn)
), "<true/false> <ip> : Set/unset the server autoconnection state";
] (* end of let commands = *)
Index: src/networks/direct_connect/dcProtocol.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcProtocol.ml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- src/networks/direct_connect/dcProtocol.ml 15 Aug 2010 15:01:53 -0000
1.13
+++ src/networks/direct_connect/dcProtocol.ml 8 Sep 2010 16:31:50 -0000
1.14
@@ -103,6 +103,22 @@
with
_ -> Charset.Locale.to_utf8 s
+let make_name s =
+ match String2.split s '/' with
+ | ["TTH";tth] ->
+ if is_valid_tiger_hash tth then NameTTH tth else failwith "Invalid TTH"
+(*
+ | ""::path ->
+ if List.exists (function "." | ".." -> true | _ -> false) path then
failwith "Invalid path" else NameShared path
+*)
+ | [file] -> NameSpecial file
+ | _ -> failwith ("Invalid name : " ^ s)
+
+let show_name = function
+(* | NameShared l -> "/" ^ String.concat "/" l *)
+ | NameSpecial s -> s
+ | NameTTH tth -> "TTH/" ^ tth
+
module SimpleCmd(M: sig val msg : string end) = struct
type t = string
let parse nick = dc_to_utf nick
@@ -170,92 +186,47 @@
well be sent in one go. Identifier must be a directory in the unnamed root,
ending (and beginning) with â/â. *)
type t = {
- mutable adctype : adc_type;
- mutable fname : string;
- mutable tth : string;
- mutable start_pos : int64;
- mutable bytes : int64;
- mutable zl : bool;
+ adctype : adc_type;
+ start_pos : int64;
+ bytes : int64;
+ zl : bool;
}
- let s_tth = ref "TTH/"
- let s_tthl = ref "tthl"
- let s_file = ref "file"
-
let parse s =
- (try
- let m = {
- adctype = AdcFile;
- fname = "";
- tth = "";
- start_pos = Int64.zero;
- bytes = Int64.zero;
- zl = false;
- } in
- let strip_right str =
- let pos = String.rindex str ' ' in
- String2.before str pos, String2.after str (pos+1)
- in
- (match String2.splitn s ' ' 1 with
- | [adc_type ; msg] ->
- let msg = (* strip possible ZL1 *)
- (match String2.split msg ' ' with
- | msg :: "ZL1" :: [] -> m.zl <- true; msg
- | _ -> msg )
- in
- m.adctype <- (* define adc-type *)
- (match adc_type with
- | "file" -> AdcFile
- | "tthl" -> AdcTthl
- | _ -> raise Not_found );
-
- let msg, bytes = strip_right msg in (* strip bytes and start
from msg right side *)
- m.bytes <- Int64.of_string bytes;
- let msg, start = strip_right msg in
- m.start_pos <- Int64.of_string start;
-
- if (String2.before msg 4) = !s_tth then (* identifier is TTH *)
- m.tth <- String2.after msg 4
- else begin (* identifier is file *)
- let msg = (* strip first / that DC++ seems to add at least
downloads from filelists *)
- if (String2.before msg 1 = "/") then (String2.after msg 1)
- else msg in
- let s = dc_replace_str_to_str msg "\\ " " " in (* replace escaped
"\ " from filename with " " space *)
- m.fname <- s
+ try
+ match String2.split s ' ' with
+ | adc_type :: ident :: start_pos :: bytes :: flags ->
+ {
+ adctype = begin match adc_type with
+ | "file" -> AdcFile (make_name ident)
+(* | "tthl" -> AdcTthl (match name with NameTTH tth -> tth
| _ -> failwith "tthl") *)
+ | "list" -> AdcList (ident, List.mem "RE1" flags)
+(* ((match name with NameShared dir -> dir | _ -> failwith
"list"), *)
+ | _ -> failwith "Unknown ADC GET type"
end;
+ start_pos = Int64.of_string start_pos;
+ bytes = Int64.of_string bytes;
+ zl = List.mem "ZL1" flags;
+ }
+ | _ -> failwith "Invalid ADC GET format"
+ with exn ->
+ if !verbose_msg_clients || !verbose_upload then
+ lprintf_nl "Error in AdcGet parsing : %s" (Printexc2.to_string exn);
+ raise Not_found
- (* sanity checks... *)
- if (m.adctype = AdcTthl) && (m.fname = "") then raise Not_found;
- m (* return m as result *)
- | _ -> raise Not_found )
- with _ ->
- if !verbose_msg_clients || !verbose_upload then lprintf_nl "Error in
AdcGet parsing";
- raise Not_found )
-
- let print t =
- let adc_type,fname_or_tth =
- (match t.adctype with
- | AdcTthl -> !s_tthl, !s_tth ^ t.tth
- | AdcFile -> !s_file, (if t.tth <> "" then !s_tth ^ t.tth else t.fname )
)
- in
- lprintf_nl "%s %s %s %Ld %Ld%s" A.command
- adc_type fname_or_tth t.start_pos t.bytes (if t.zl then " ZL1" else "")
+ let to_string t =
+ let adc_type,ident,flags =
+ match t.adctype with
+(* | AdcTthl tth -> "tthl", show_name (NameTTH tth), [] *)
+ | AdcFile name -> "file", show_name name, ""
+ | AdcList (path,re) -> "list", path, " RE1"
+ in
+ let flags = if t.zl then flags ^ " ZL1" else flags in
+ Printf.sprintf "$%s %s %s %Ld %Ld%s" A.command
+ adc_type ident t.start_pos t.bytes flags
- let write buf t =
- let adc_type,fname_or_tth =
- (match t.adctype with
- | AdcTthl -> !s_tthl, !s_tth ^ t.tth
- | AdcFile -> !s_file,
- (if t.tth <> "" then !s_tth ^ t.tth else begin
- let s = ref "" in
- s := dc_replace_str_to_str t.fname " " "\\ "; (* escape all spaces
*)
- !s
- end )
- )
- in
- Printf.bprintf buf "$%s %s %s %Ld %Ld%s" A.command
- adc_type fname_or_tth t.start_pos t.bytes (if t.zl then " ZL1" else "")
- (*if !verbose_msg_clients || !verbose_download then lprintf_nl "Sending:
(%s)" (Buffer.contents buf);*)
+ let print t = lprintf_nl "%s" (to_string t)
+ let write buf t = Buffer.add_string buf (to_string t)
end
Index: src/networks/direct_connect/dcShared.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcShared.ml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -b -r1.6 -r1.7
--- src/networks/direct_connect/dcShared.ml 7 Sep 2010 18:25:50 -0000
1.6
+++ src/networks/direct_connect/dcShared.ml 8 Sep 2010 16:31:50 -0000
1.7
@@ -76,7 +76,7 @@
Buffer.contents buf
(* Create mylist of shared files in xml-format *)
-let make_xml_mylist () =
+let make_xml_mylist root =
let buf = Buffer.create 1000 in
Printf.bprintf buf "<?xml version=\"1.0\" encoding=\"utf-8\"
standalone=\"yes\"?>\r\n";
Printf.bprintf buf "<FileListing Version=\"1\" CID=\"1,0,2,3,4,5,6\"
Base=\"/\" Generator=\"MLDC-%s\">\r\n" (Xml.escape Autoconf.current_version);
@@ -102,7 +102,7 @@
Printf.bprintf buf "</Directory>\r\n"
) node.shared_dirs
in
- iter 0 dc_shared_tree;
+ iter 0 root;
Printf.bprintf buf "</FileListing>";
buf
@@ -212,12 +212,21 @@
(* Create xml and mylist filelist *)
let create_filelist () =
- buffer_to_bz2_to_file (make_xml_mylist () ) (Filename.concat
directconnect_directory mylistxmlbz2);
+ buffer_to_bz2_to_file (make_xml_mylist dc_shared_tree) (Filename.concat
directconnect_directory mylistxmlbz2);
if !verbose_upload then lprintf_nl "Created mylist.xml file";
string_to_che3_to_file (make_mylist () ) (Filename.concat
directconnect_directory mylist);
if !verbose_upload then lprintf_nl "Created mylist file";
()
+let find_dir_exn name =
+ let path = String2.split_simplify name '/' in
+ let rec follow path node =
+ match path with
+ | [] -> node
+ | x::xs -> follow xs (List.assoc x node.shared_dirs)
+ in
+ follow path dc_shared_tree
+
(*let dc_share_file dcsh = ()*)
(* let magic =
match Magic.M.magic_fileinfo dcsh.dc_shared_fullname false with
Index: src/networks/direct_connect/dcTypes.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcTypes.ml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -b -r1.8 -r1.9
--- src/networks/direct_connect/dcTypes.ml 8 Sep 2010 16:26:05 -0000
1.8
+++ src/networks/direct_connect/dcTypes.ml 8 Sep 2010 16:31:50 -0000
1.9
@@ -375,7 +375,15 @@
| MylistDirectory of (string * dc_mylistnode list ref)
| MylistFile of (string * string) (* filename * size *)
-and adc_type = AdcTthl | AdcFile
+and adc_name =
+(* | NameShared of string list (* shared filename - path from root *) *)
+ | NameSpecial of string (* rootless filename - filelists, future extensions
*)
+ | NameTTH of string (* TTH/ *)
+
+and adc_type =
+ | AdcFile of adc_name
+(* | AdcTthl of string (* tth *) *)
+ | AdcList of string * bool (* path * recursive *)
and dc_shared_tree =
{