From 6564cec6b5b5d4e24dea6c73d97e623fd60c8f96 Mon Sep 17 00:00:00 2001 From: ygrek Date: Sun, 5 Sep 2010 16:37:23 +0300 Subject: [PATCH] answer ADCGET list --- src/networks/direct_connect/dcClients.ml | 41 +++++++++++++++++++++++----- src/networks/direct_connect/dcInteractive.ml | 15 +++++----- src/networks/direct_connect/dcProtocol.ml | 10 +++---- src/networks/direct_connect/dcShared.ml | 15 ++++++++-- 4 files changed, 59 insertions(+), 22 deletions(-) diff --git a/src/networks/direct_connect/dcClients.ml b/src/networks/direct_connect/dcClients.ml index bab4fae6..7798f5ac 100644 --- a/src/networks/direct_connect/dcClients.ml +++ b/src/networks/direct_connect/dcClients.ml @@ -582,7 +582,8 @@ let client_handler sock event = 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 @@ let read_first_message t sock = 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 _ -> @@ -647,7 +648,7 @@ let get_client_supports c = (* return ( xmlbzlist , adc ,tthf ) xmlbzlist means | None -> false,false,false ) in xmlbzlist , adc, tthf - + (* Send download commands to client *) let dc_send_download_command c sock = let xmlbzlist, adc, tthf = get_client_supports c in @@ -918,6 +919,8 @@ let rec client_reader c t sock = 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; @@ -935,11 +938,33 @@ let rec client_reader c t sock = dc_send_msg sock (FileLengthReq size) end - | `PartialList _ -> failwith "Partial lists not yet supported" + | `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 *) - (*lprintf_nl "Client (%s) wants to download %s (%s) %Ld bytes from pos: %Ld" (clients_username c) - fname tth bytes start_pos;*) let dcsh = match name with | `TTH tth -> (try (* lets find file by tth *) @@ -952,6 +977,8 @@ let rec client_reader c t sock = with _ -> 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 @@ -964,7 +991,7 @@ let rec client_reader c t sock = dc_send_msg sock (AdcSndReq { AdcSnd.adctype = t.AdcGet.adctype; start_pos = start_pos; - bytes = rem; + bytes = bytes; zl = false; (* CHECK *) } ); client_reader c SendReq sock (* call ourselves again with send starting *) diff --git a/src/networks/direct_connect/dcInteractive.ml b/src/networks/direct_connect/dcInteractive.ml index dce721bd..c9c92ec3 100644 --- a/src/networks/direct_connect/dcInteractive.ml +++ b/src/networks/direct_connect/dcInteractive.ml @@ -116,7 +116,7 @@ let td_command text title ?(blink=false) ?(target=`Output) cmd = onMouseOut=\\\"mOut(this);\\\" title=\\\"%s\\\" onClick=\\\"parent.%s.location.href='submit?q=%s'\\\"\\>%s\\" (if blink then "style=\\\"text-decoration:blink\\\" " else "") - title (match target with `Output -> "output" | `Status -> "fstatus") + title (match target with `Output -> "output" | `Status -> "fstatus") (String.concat "+" cmd) (* Url.encode ? *) text @@ -288,9 +288,9 @@ let hub_print s num o = %s\\\n" (html_mods_cntr ()) num - (td_command + (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 @@ msgWindow.location.reload(); ), " : 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 _ -> () ); - "ok" + server_must_update s; + "ok" + with exn -> Printf.sprintf "Failed : %s" (Printexc2.to_string exn) ), " : Set/unset the server autoconnection state"; ] (* end of let commands = *) diff --git a/src/networks/direct_connect/dcProtocol.ml b/src/networks/direct_connect/dcProtocol.ml index b671d2c3..2907a0dc 100644 --- a/src/networks/direct_connect/dcProtocol.ml +++ b/src/networks/direct_connect/dcProtocol.ml @@ -218,12 +218,12 @@ well be sent in one go. Identifier must be a directory in the unnamed root, endi 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, if re then ["RE1"] else [] + | AdcFile name -> "file", show_name name, "" + | AdcList (path,re) -> "list", path, " RE1" in - let flags = if t.zl then "ZL1"::flags else flags in - Printf.sprintf "$%s %s %s %Ld %Ld %s" A.command - adc_type ident t.start_pos t.bytes (String.concat " " flags) + 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 print t = lprintf_nl "%s" (to_string t) let write buf t = Buffer.add_string buf (to_string t) diff --git a/src/networks/direct_connect/dcShared.ml b/src/networks/direct_connect/dcShared.ml index 0bcb5a72..91ab54f9 100644 --- a/src/networks/direct_connect/dcShared.ml +++ b/src/networks/direct_connect/dcShared.ml @@ -76,7 +76,7 @@ let make_mylist () = 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 "\r\n"; Printf.bprintf buf "\r\n" (Xml.escape Autoconf.current_version); @@ -102,7 +102,7 @@ let make_xml_mylist () = Printf.bprintf buf "\r\n" ) node.shared_dirs in - iter 0 dc_shared_tree; + iter 0 root; Printf.bprintf buf ""; buf @@ -212,12 +212,21 @@ let buffer_to_bz2_to_file buf filename = (* 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 -- 2.11.4.GIT