From 3af878c634503c7694de214be526d7b351c78b27 Mon Sep 17 00:00:00 2001 From: ygrek Date: Sun, 9 May 2010 16:56:00 +0300 Subject: [PATCH] parse ADCGET list, prepare to answer --- src/networks/direct_connect/dcClients.ml | 211 +++++++++++++++--------------- src/networks/direct_connect/dcProtocol.ml | 139 ++++++++------------ src/networks/direct_connect/dcTypes.ml | 10 +- 3 files changed, 172 insertions(+), 188 deletions(-) diff --git a/src/networks/direct_connect/dcClients.ml b/src/networks/direct_connect/dcClients.ml index c20e4d44..bab4fae6 100644 --- a/src/networks/direct_connect/dcClients.ml +++ b/src/networks/direct_connect/dcClients.ml @@ -651,12 +651,11 @@ let get_client_supports c = (* return ( xmlbzlist , adc ,tthf ) xmlbzlist means (* 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 +667,44 @@ let dc_send_download_command c sock = 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 + 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 = @@ -866,123 +869,125 @@ let rec client_reader c t sock = if !verbose_unexpected_messages then lprintf_nl "Exception (%s) FileLength/AdcSnd:" (Printexc2.to_string e); close sock (Closed_for_error (Printexc2.to_string e)) ) - + | 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 *) - end; - + end; + let direction_change = (* memorize possible direction change *) (match c.client_state with | DcConnectionStyle MeActive Download 65535 | DcConnectionStyle ClientActive Download 65535 -> true (* these mean direction change and we have lost *) | _ -> 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 - in + + 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 -> + 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 + | `PartialList _ -> failwith "Partial lists not yet supported" + + | `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 = - if tth <> "" then begin + 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 (* 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 = rem; + zl = false; (* CHECK *) } ); client_reader c SendReq sock (* call ourselves again with send starting *) | _ -> (* GetReq _ | UGetBlockReq _ *) - dc_send_msg sock (FileLengthReq rem) ); - - end else begin + 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 _ -> + | 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 *) @@ -991,9 +996,9 @@ let rec client_reader c t sock = ignore (ask_user_for_download user) | _ -> () ); end - + | GetListLenReq -> () - + | KeyReq _ -> (*lprintf_nl "Received $Key ... dumping it";*) (*lprintf_nl "Client state: %s" (client_state_to_string c);*) diff --git a/src/networks/direct_connect/dcProtocol.ml b/src/networks/direct_connect/dcProtocol.ml index ea6d16f4..b671d2c3 100644 --- a/src/networks/direct_connect/dcProtocol.ml +++ b/src/networks/direct_connect/dcProtocol.ml @@ -30,7 +30,7 @@ let log_prefix = "[dcPro]" let lprintf_nl fmt = lprintf_nl2 log_prefix fmt - + (* Replace one string to another string from string *) (*let dc_replace_str_to_str s find_str to_str = if find_str = to_str then failwith "dc_replace_str_to_str find_str = to_str"; @@ -56,7 +56,7 @@ let lprintf_nl fmt = else !str in replace s *) - + (* Decode chat messages *) (* You can now use $ and | in the chat. *) (* DC++ uses the HTML standard $ and | to replace them *) @@ -72,7 +72,7 @@ let dc_encode_chat s = (* convert '|'and '$' to html characters $ and | let s = String2.replace s '|' "|" in let s = String2.replace s '&' "&" in s - + (* Reuseable modules for simple commands *) module Empty = functor(M: sig val msg : string end) -> struct let parse s = () @@ -103,6 +103,22 @@ let dc_to_utf s = 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,93 +186,48 @@ should be taken as a hint that the requesting client will be getting the subdire 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 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 ) - ) + 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, if re then ["RE1"] else [] 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 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 print t = lprintf_nl "%s" (to_string t) + let write buf t = Buffer.add_string buf (to_string t) + end module AdcGet = Adc (struct let command = "ADCGET" end) diff --git a/src/networks/direct_connect/dcTypes.ml b/src/networks/direct_connect/dcTypes.ml index 855ba2ba..d53ca302 100644 --- a/src/networks/direct_connect/dcTypes.ml +++ b/src/networks/direct_connect/dcTypes.ml @@ -375,7 +375,15 @@ and dc_mylistnode = (* type for mylist parsing *) | 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 = { -- 2.11.4.GIT