Commits

Roma Sokolov committed 07a23f8

update to latest found version

Comments (0)

Files changed (20)

+(* Inspired by MLDonkey bigEndian module, but more cool and cute ^_^ *) 
+
+ open KUtil
+
+module BigEndian = struct 
+  
+  let flsr a b = a lsr b
+  let flsl a b = a lsl b
+  
+  let int_one i =
+    i land 0xff >> char_of_int >> String.make 1
+
+                                     
+  let int64_one i =
+    Int64.logand i 0xffL >> Int64.to_int >> char_of_int >> String.make 1 
+  
+
+  let gen_four shiftf onef num =  
+    let buf = Buffer.create 32 in
+    let ints = range ~start:(-24) ~stop:8 ~step:(-8) () in
+      List.iter (fun i-> shiftf num i >> onef >> Buffer.add_string buf) ints;
+    Buffer.contents buf                                
+  
+  
+  let int_four = gen_four flsr int_one                                          
+  let int64_four = gen_four Int64.shift_right_logical int64_one
+     
+                       
+  let get_int_one chr = 
+    int_of_char chr
+ 
+ 
+  let get_int64_one chr =
+    Char.code chr >> Int64.of_int     
+                      
+                       
+  let gen_get_four shiftf onef add init cl = 
+    let ints = range ~start:(-24) ~stop:8 ~step:(-8) () in
+      List.map2 (fun a-> fun b-> shiftf (onef a) b) cl ints >> List.fold_left (add) init
+       
+                                      
+  let get_int_four = gen_get_four flsl get_int_one (+) 0
+  let get_int64_four = gen_get_four Int64.shift_left get_int64_one Int64.add 0L
+
+ end;;
+
+ open KUtil
+
+ module KFile = struct 
+   
+   type file = {file:Unix.file_descr;
+                buffer:string Weak.t;
+                fmutex:Mutex.t;
+                piece_length:int64;
+                pieces_count:int}
+
+   let create flnm plength pcount = 
+     let flags = [Unix.O_RDWR; Unix.O_NONBLOCK; Unix.O_CREAT] in 
+     {file=Unix.openfile flnm flags 0o666;
+      buffer=Weak.create pcount;
+      fmutex=Mutex.create ();
+      piece_length=plength;
+      pieces_count=pcount}
+   
+   
+   let close bfile = 
+     Mutex.lock bfile.fmutex;
+     Unix.close bfile.file;
+     Mutex.unlock bfile.fmutex
+
+     
+   let direct_write file piece_length pindex part_offset data = 
+     let dlength = String.length data in      
+     let foffset = Int64.of_int pindex >> Int64.mul piece_length >> Int64.add part_offset in
+     let (_:int64) = Unix.LargeFile.lseek file foffset Unix.SEEK_SET in 
+     let (_:int) = ThreadUnix.write file data 0 dlength in
+       ()
+  
+   let write bfile pindex part_offset data  = 
+     let int_part_offset = Int64.to_int part_offset in (* Hope this not exceed integer range *)
+     let int_piece_length = Int64.to_int bfile.piece_length in (* see above ^ *)
+     let () = Mutex.lock bfile.fmutex in
+     let fulld = match Weak.get bfile.buffer pindex with 
+                   None -> let s = String.make int_piece_length '\000' in
+                           Weak.set bfile.buffer pindex (Some s); s
+                 | Some s -> s
+                 in
+     String.blit data 0 fulld int_part_offset (String.length data);
+     direct_write bfile.file bfile.piece_length pindex part_offset data;
+     Mutex.unlock bfile.fmutex
+
+    
+   let direct_read file piece_length part_length pindex part_offset = 
+     let int_part_length = Int64.to_int part_length in (* why ocaml String module not supported int64 for indexes? *)
+     let foffset = Int64.of_int pindex >> Int64.mul piece_length >> Int64.add part_offset in
+       let (_:int64) = Unix.LargeFile.lseek file foffset Unix.SEEK_SET in
+       let res = String.make int_part_length '\000' in
+       let (_:int) = ThreadUnix.read file res 0 int_part_length in
+       res
+       
+   
+   let read bfile part_length pindex part_offset = 
+     match Weak.get bfile.buffer pindex with
+        None -> let () = Mutex.lock bfile.fmutex in
+                let r = direct_read bfile.file bfile.piece_length part_length pindex part_offset in
+                  Mutex.unlock bfile.fmutex; r
+      | Some data -> data
+   
+ 
+ end;;
+
+open KNet
+
+module KHttp = struct 
+
+   (* convert string `service://hostname:port/page` (host, port, page) : (string, string, string) *)
+   (* keep params in url as is *)
+   let parse_url ?(default_port="80") url = 
+     let without_service = List.tl & Str.split (Str.regexp "://") url
+     in 
+       match without_service with 
+           [serv_page] -> begin match Str.split (Str.regexp "/") serv_page with 
+                                    [serv; page] -> begin match Str.split (Str.regexp ":") serv with
+                                                              [host; port] -> (host, port, page)
+                                                            | [host] -> (host, default_port, page)
+                                                            | _ -> failwith "Invalid url!"
+                                                    end
+                                  | _-> failwith "Invalid url!"
+                          end
+         | _ -> failwith "Invalid url!"  
+ 
+  
+   (* request to server must be urlencoded *)                      
+   let urlencode str =
+     let buf = Buffer.create 20
+     in
+     let rec enc st = match (safe_next st) with
+         Some chr -> conv chr; enc st
+       | None -> Buffer.contents buf
+     and safe_next st =
+       try Some (Stream.next st)
+       with Stream.Failure -> None
+     and conv chr = match chr with
+         '0'..'9' | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' | '-' | '~' -> Buffer.add_char buf chr
+         | '\000' .. '\015' -> Printf.bprintf buf "%%0%X" (Char.code chr)
+         | _ -> Printf.bprintf buf "%%%X" (Char.code chr)
+     in enc (Stream.of_string str)                          
+ 
+   (* convert [(string, string);...] to urlencoded key=value&key=value...*)                    
+   let format_query dct = 
+     let process (key, value) = Printf.sprintf "%s=%s" (urlencode key) (urlencode value) in
+       String.concat "&" (List.map process dct)
+
+   (* parse tracker's response and return its content *)
+   let response_content resp =
+     if contain resp "200 OK" then
+       try
+         List.hd & List.filter (min_len 2) & List.rev & Str.split (Str.regexp "\r\n") resp
+       with Failure s -> failwith ("Server return bad response!\n" ^ resp ^ s)
+     else failwith ("Server return bad response!\n" ^ resp)
+ 
+  let page_delim page = 
+    if String.contains page '?' then 
+      if (String.get page & String.length page - 1) = '&' then page
+      else page ^ "&"
+    else page ^ "?"
+
+
+   (* perform request to given hostname with given params *)
+   let request announce_addr params = 
+     let (host, port, page) = parse_url announce_addr in
+     let page = page_delim page in 
+     let req = Printf.sprintf "GET /%s%s HTTP/1.1\r\nHost: %s\r\nUser-Agent: KamloTor0.1\r\nAccept-Encoding: gzip\r\n\r\n"
+                 page (format_query params) host in   
+         let sock = connect_to (host, port) in
+         let (_:int) = send_all sock req in
+         let resp = recv_all sock in
+           Unix.close sock; response_content resp
+                                                     
+ end;;
+
+ open KUtil
+ open Katorrent 
+
+ (* TODO:
+    1) oeo?oeou acaeiiaaenoaea ia?ao iiaoeyie, aiaaaeou neaiaoo?u, 
+       aaa iaiaoiaeii -- aaanoe ooieoi?u (io aano?aeoiuo oeiia ecaaaeouny, aaau)
+    2) eniieuciaaou oaioiiiua oeiu aey oaeeia e nieaoia, auou ii?ao. ioaaeuiue iiaoeu 
+       aey yoiai ( niio?aou ia a?aeino?eo eyieoae e y?iia ieinee, iie e?ooua)
+    3) naaeaou iiaoeu aey iiiaa, e nicaaou i?oaenio? iiiaao -- au?eneaiey a iae aaoiiaoe?anee
+       caueua?ony i?oaenii.
+    4) ?acia?aouny n iauei oaaeiiii ie?ia, eoneia e oaeea -- nouiinou + i?oaen. ioieo o?e aie?ai iiii?u
+    5) Lwt, cothread. eee ia?aaanoe ia jocaml
+    6) iiniio?aou ia ieaieiao, eae ii?ao iiii?u, eee naiiio i?ee?ooeou select, poll, epoll. 
+       o.e. iia aaiao oi?a iaai, ii?ao auou -- eeaaaaio
+    7) ?anoe?aiey i?ioieiea: DHT, etc.
+ *)  
+   
+ let main ?(path="") () = (* path arg only for debug process *)
+   
+ let filename = if path="" then Sys.argv.(1) else path in
+ let peer_id = gen_peer_id () in
+ let servport = 12345 in (* hardcode this *)
+ let peer_tbl = {tbl=Hashtbl.create 20; pemutex=Mutex.create ()} in 
+ let metainfo = Bencode.decode_file filename in
+ let (info_hash,
+      announce_addr,
+      piece_length,
+      piece_ar,
+      pieces_count,
+      filename,
+      file_length) = get_torrent_info metainfo in
+ let () =  print_info filename file_length in
+ let pieces = {arr=piece_ar; pimutex=Mutex.create ()} in 
+ let bfile = KFile.create filename piece_length pieces_count in
+ let servthread = Thread.create KNet.make_serversocket
+                    (servport, KPeer.handle_incoming, (info_hash, peer_id, 
+                                                       peer_tbl, bfile, pieces)) in 
+ 
+ let f_info = KTracker.calculate_file_info pieces.arr piece_length file_length in 
+ let r_query = KTracker.make_init_query info_hash peer_id servport f_info in
+ let rec process finfo query threadacc = 
+   if all_done pieces.arr then
+     let () = Thread.kill servthread in 
+     List.iter Thread.kill threadacc;
+     KFile.close bfile
+   else 
+     let rcontent = KHttp.request announce_addr query in
+     let (t_info, peer_list) = KTracker.parse_tracker_response rcontent in
+     let not_exist_peers = List.filter (fun it -> not & Hashtbl.mem peer_tbl.tbl it) peer_list in 
+     let thrds = List.map (fun peer -> Thread.create KPeer.handle_outcoming
+                                         (peer, info_hash, peer_id,
+                                          peer_tbl, bfile, pieces)
+                          ) not_exist_peers in
+     let () = register_peers peer_tbl not_exist_peers pieces_count in 
+     let () = KTracker.print_stat t_info finfo (Hashtbl.length peer_tbl.tbl) in 
+     let () = Thread.delay t_info.KTracker.interval in 
+     let f_info = KTracker.calculate_file_info pieces.arr piece_length file_length in 
+     let r_query = KTracker.make_time_query t_info.KTracker.tracker_id info_hash peer_id servport f_info in
+       process f_info r_query (thrds @ threadacc)
+ in process f_info r_query []
+ 
Empty file added.
+
+ open KUtil
+
+ module KMsg = struct
+ 
+    type peer_msg = 
+     | KeepAlive
+     | Choke
+     | Unchoke
+     | Interested
+     | NotInterested
+     | Have of int
+     | BitField of string
+     | Request of int * int64 * int64
+     | Piece of int * int64 * string
+     | Cancel of int * int64 * int64
+                                
+   let format_msg msg = 
+       let buf = Buffer.create 100 in
+       let buf_add = Buffer.add_string buf 
+       in begin
+         match msg with
+           | KeepAlive -> ()
+           | Choke -> buf_add (BigEndian.int_one 0)
+           | Unchoke -> buf_add (BigEndian.int_one 1)
+           | Interested -> buf_add (BigEndian.int_one 2)
+           | NotInterested -> buf_add (BigEndian.int_one 3)
+           | Have piece_index -> buf_add (BigEndian.int_one 4);
+                                 buf_add (BigEndian.int_four piece_index)
+           | BitField bitfield -> buf_add (BigEndian.int_one 5);
+                                  buf_add bitfield 
+           | Request (piece_index, offset, length) -> buf_add (BigEndian.int_one 6);
+                                                      buf_add (BigEndian.int_four piece_index);
+                                                      buf_add (BigEndian.int64_four offset);
+                                                      buf_add (BigEndian.int64_four length);
+           | Piece (piece_index, offset, block) -> buf_add (BigEndian.int_one 7);
+                                                   buf_add (BigEndian.int_four piece_index);
+                                                   buf_add (BigEndian.int64_four offset); 
+                                                   buf_add block;
+           | Cancel (piece_index, offset, length) -> buf_add (BigEndian.int_one 8);
+                                                     buf_add (BigEndian.int_four piece_index);
+                                                     buf_add (BigEndian.int64_four offset);
+                                                     buf_add (BigEndian.int64_four length);
+       end;
+       let length = Buffer.length buf
+       and content = Buffer.contents buf 
+       in  (BigEndian.int_four length) ^ content
+ 
+   let parse_with_opcode strm opcode length = 
+     let len = length - 1 in (* without opcode *)
+       match opcode with 
+         | 0 -> Choke
+         | 1 -> Unchoke
+         | 2 -> Interested 
+         | 3 -> NotInterested 
+         | 4 -> Have (stream_nextn len strm >> BigEndian.get_int_four)
+         | 5 -> BitField (stream_nextn len strm >> make_string)
+         | 6 -> let piece_index = stream_nextn 4 strm >> BigEndian.get_int_four in
+                let offset = stream_nextn 4 strm >> BigEndian.get_int64_four in 
+                let length = stream_nextn 4 strm >> BigEndian.get_int64_four in
+                  Request (piece_index, offset, length)
+         | 7 -> let piece_index = stream_nextn 4 strm >> BigEndian.get_int_four in
+                let offset = stream_nextn 4 strm >> BigEndian.get_int64_four in
+                let block = stream_nextn (len - 8) strm >> make_string in
+                  Piece (piece_index, offset,block)
+         | 8 -> let piece_index = stream_nextn 4 strm >> BigEndian.get_int_four in
+                let offset = stream_nextn 4 strm >> BigEndian.get_int64_four in 
+                let length = stream_nextn 4 strm >> BigEndian.get_int64_four in
+                  Cancel (piece_index, offset, length)
+         | _ -> failwith "invalid opcode!"
+                                          
+                                      
+   let parse_msg strmsg = 
+     if String.length strmsg = 0 then KeepAlive
+     else
+       let strm = Stream.of_string strmsg in 
+       let length = stream_nextn 4 strm >> BigEndian.get_int_four in
+         if length = 0 then KeepAlive
+         else
+           let opcode = Stream.next strm >> Char.code in 
+             parse_with_opcode strm opcode length
+            
+                                      
+ end;;
+ 
+open KUtil
+
+module KNet = struct
+                       
+   (* convert packed ip (4byte) and port (2byte) into (host, port) : (string, int) *)
+   let inet_ntoa str = let st = Stream.of_string str in
+     let rec parse acc = parser
+       | [< 'ip1; 'ip2; 'ip3; 'ip4; 'p1; 'p2; rst>] -> 
+          let host = String.concat "." & List.map (string_of_int $ Char.code) [ip1; ip2; ip3; ip4]
+          and port = string_of_int & (Char.code p1) * 128 + (Char.code p2)
+          in parse ((host, port)::acc) rst
+       | [< >] -> acc 
+     in parse [] st
+
+   
+   (* get Unix.ai_addr for given (host, port) pair *)
+   let get_addr (host, port) =
+     let addrinfos = Unix.getaddrinfo host port [] 
+     in let ainfo = List.hd addrinfos 
+     in ainfo.Unix.ai_addr
+
+          
+  let get_hostport sock_addr = match sock_addr with 
+      Unix.ADDR_INET (inetaddr, port)-> (Unix.string_of_inet_addr inetaddr, string_of_int port)
+    | Unix.ADDR_UNIX _ -> failwith "invalid argument -- unix socket addr"
+          
+                            
+   let connect_to (host, port) = 
+     let s = ThreadUnix.socket Unix.PF_INET Unix.SOCK_STREAM 0
+     and addr = get_addr (host, port) in
+       ThreadUnix.connect s addr; s
+     
+          
+   (* send whole message *)       
+   let send_all sock msg = 
+     let lngth = String.length msg
+     in ThreadUnix.send sock msg 0 lngth []
+
+
+   (* recieve all data from socket *)
+   let recv_all ?(thunk=1024) sock = 
+     let buffer = String.create thunk in 
+     let rec recvR acc = 
+       let count = ThreadUnix.recv sock buffer 0 thunk [] in
+         if count < thunk then (String.sub buffer 0 count)::acc
+         else recvR ((String.sub buffer 0 count)::acc)
+     in
+       String.concat "" (List.rev & recvR [])
+
+
+   (* make server socket and bind it on local addres with given port
+      client connections handles with given handler func*)
+   let make_serversocket (port, handler_func, args) = 
+     let port = string_of_int port in 
+     let servsocket = ThreadUnix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+     let addr_info = List.hd & Unix.getaddrinfo "" port [Unix.AI_PASSIVE] in 
+     let sock_addr = addr_info.Unix.ai_addr
+     in 
+       Unix.setsockopt servsocket Unix.SO_REUSEADDR true;
+       Unix.setsockopt servsocket Unix.TCP_NODELAY true;
+       Unix.bind servsocket sock_addr;
+       Unix.listen servsocket 5;
+       while true do
+         let (clientsock, clientaddr) = ThreadUnix.accept servsocket in
+         ignore & Thread.create handler_func ((clientsock, clientaddr), args)
+       done;
+       servsocket
+
+ end;;
+
+ open KUtil
+ open Katorrent
+ open KMsg
+   
+ module KPeer = struct
+   
+   type current_piece = {mutable cindex:int;
+                         mutable coffset:int64;
+                         mutable is_new: bool}
+ 
+
+   let send_msg peer kmsg = 
+     send_all peer & format_msg kmsg
+
+   let recv_msg peer = 
+     parse_msg & recv_all peer
+   
+   (* generate string to handshake with remote peer *)
+   let handshake info_hash peer_id = 
+     let reserved = String.make 8 '\000' in
+     Printf.sprintf "\019BitTorrent protocol%s%s%s" reserved info_hash peer_id
+
+       
+   let parse_handshake msg info_hash = 
+     let reserved = String.make 8 '\000' in
+     let () = String.blit reserved 0 msg 20 8 in
+     if (String.length msg) = 68
+     then
+       if (String.sub msg 0 48) = (Printf.sprintf "\019BitTorrent protocol%s%s" reserved info_hash)
+       then
+         true
+       else
+         false
+     else
+       false
+
+         
+   let get_interesting_piece peer_tbl host_port pieces =
+     let peer_piecehave = fst & Hashtbl.find peer_tbl.tbl host_port in 
+     let piece_array = pieces.arr in 
+     let length = Array.length peer_piecehave in 
+     let rec pred ind = 
+       if ind = length
+       then None
+       else 
+         let peer_piece = Array.get peer_piecehave ind in
+         let my_piece = (Array.get piece_array ind).have in
+           if peer_piece && not my_piece
+           then (Some ind)
+           else pred (ind + 1)
+     in pred 0         
+
+
+   let set_peer_status peer_tbl host_port field value = 
+     let peer_status = snd & Hashtbl.find peer_tbl.tbl host_port in 
+     Mutex.lock peer_tbl.pemutex;
+     match field with 
+         Am_choking -> peer_status.am_choking <- value
+       | Am_interested -> peer_status.am_interested <- value
+       | Peer_choking -> peer_status.peer_choking <- value
+       | Peer_interested -> peer_status.peer_interested <- value
+                                                             ;
+     Mutex.unlock peer_tbl.pemutex
+       
+       
+   let get_peer_status peer_tbl host_port field = 
+     let peer_status = snd & Hashtbl.find peer_tbl.tbl host_port in
+       match field with 
+         Am_choking -> peer_status.am_choking 
+       | Am_interested -> peer_status.am_interested 
+       | Peer_choking -> peer_status.peer_choking 
+       | Peer_interested -> peer_status.peer_interested    
+
+                              
+   let update_peer_status peer peer_tbl host_port pieces = 
+     match get_interesting_piece peer_tbl host_port pieces with
+         Some _ -> let (_:int) = send_msg peer Interested in 
+                   let (_:int) = send_msg peer Unchoke in
+                   set_peer_status peer_tbl host_port Am_choking false;
+                   set_peer_status peer_tbl host_port Am_interested true
+       | None -> let (_:int) = send_msg peer NotInterested in 
+                 let (_:int) = send_msg peer Choke in 
+                 set_peer_status peer_tbl host_port Am_choking true;
+                 set_peer_status peer_tbl host_port Am_interested false
+                              
+    
+   let register_peer_piece peer_tbl host_port piece_index =
+     let (oldhave, pstat) = Hashtbl.find peer_tbl.tbl host_port in
+       Mutex.lock peer_tbl.pemutex;
+       Array.set oldhave piece_index true;
+       Mutex.unlock peer_tbl.pemutex
+         
+         
+   let register_peer_bitfield peer_tbl host_port bitfield = 
+     let piece_have = get_piecehave bitfield in 
+     let (oldhave, peer_stat) = Hashtbl.find peer_tbl.tbl host_port in
+       Mutex.lock peer_tbl.pemutex;
+       Hashtbl.replace peer_tbl.tbl host_port (piece_have, peer_stat);
+       Mutex.unlock peer_tbl.pemutex
+
+         
+   let process_peer peer host_port info_hash peer_id peers bfile pieces =
+     let work curpiece = 
+       let peer_choking = get_peer_status peers host_port Peer_choking in 
+       let am_interesting = get_peer_status peers host_port Am_interested in 
+         if not peer_choking && am_interesting
+         then 
+           if curpiece.is_new 
+           then match get_interesting_piece peers host_port pieces with
+               Some ind -> curpiece.is_new <- false;
+                           curpiece.cindex <- ind;
+                           curpiece.coffset <- 0L;
+                           ignore & send_msg peer & Request(curpiece.cindex,
+                                                                 curpiece.coffset,
+                                                                 32768L)
+             | None -> update_peer_status peer peers host_port pieces
+  
+           else ignore & send_msg peer & Request(curpiece.cindex,
+                                                    curpiece.coffset,
+                                                    32768L)
+        else () 
+     in
+     
+     let hsmsg = handshake info_hash peer_id in 
+     let (_:int) = send_all peer hsmsg in 
+     let anshs = recv_all peer in 
+       if parse_handshake anshs info_hash
+       then
+         let curpiece = {cindex=0; coffset=0L; is_new=true} in 
+         let bf_msg = BitField (get_bitfield pieces.arr) in 
+         let (_:int) = send_msg peer (if (empty_array pieces.arr) then KeepAlive else bf_msg) in 
+         let counter = ref 0 in 
+           while true do
+             if !counter = 12 then
+               let (_:int) =  send_msg peer KeepAlive in 
+                 counter := 0
+             else 
+               let () = work curpiece in 
+                 counter := !counter + 1;
+              begin match recv_msg peer with
+                 KeepAlive -> work curpiece 
+                | Choke -> set_peer_status peers host_port Peer_choking true
+                | Unchoke -> set_peer_status peers host_port Peer_choking false
+                | Interested -> set_peer_status peers host_port Peer_interested true
+                | NotInterested -> set_peer_status peers host_port Peer_interested false
+                | Have pindex -> register_peer_piece peers host_port pindex;
+                                 update_peer_status peer peers host_port pieces
+                | BitField bitfield -> register_peer_bitfield peers host_port bitfield;
+                                       update_peer_status peer peers host_port pieces
+                | Request (pindex, poffset, length) -> let is_choked = get_peer_status peers host_port Am_choking in
+                                                       if not is_choked && (Array.get pieces.arr pindex).have 
+                                                       then 
+                                                         let part_piece = KFile.read bfile length pindex poffset in
+                                                         let (_:int) = send_msg peer & Piece(pindex, poffset, part_piece)
+                                                         in ()
+                                                       else ()
+                | Piece (pindex, poffset, block) -> KFile.write bfile pindex poffset block;
+                                                    let h_piece = KFile.read bfile bfile.KFile.piece_length pindex 0L in
+                                                    let h_piece_hash = sha1sum h_piece in 
+                                                      if (Array.get pieces.arr pindex).piece_hash = h_piece_hash
+                                                      then 
+                                                        begin register_piece pieces pindex;
+                                                           curpiece.is_new <- true;
+                                                           curpiece.coffset <- 0L;
+                                                           curpiece.cindex <- 0 
+                                                        end
+                                                      else let lblock = Int64.of_int & String.length block in
+                                                           curpiece.coffset <- (Int64.add poffset lblock);
+                                                           curpiece.is_new <- false
+                | Cancel (pindex, offset, length) -> () (* end-game algorithm -- not supported, just ingore msg *)
+           end;
+           Thread.delay 10.0;
+           print_string "cycle passed \r\n"; flush stdout;
+           done
+       else
+         Unix.close peer     
+
+         
+   let handle_incoming ((clsock, claddr), (info_hash, peer_id, peers, bfile, pieces)) =
+     let host_port = get_hostport claddr in
+       regiser_peer peers host_port bfile.KFile.pieces_count;
+       process_peer clsock host_port info_hash peer_id peers bfile pieces
+
+
+   let handle_outcoming (host_port, info_hash, peer_id, peers, bfile, pieces) =
+     let clsock = connect_to host_port in  
+       process_peer clsock host_port info_hash peer_id peers bfile pieces
+
+ 
+ end;;
+
+ open KUtil
+ open Katorrent
+ open Bencode  
+   
+ module KTracker = struct
+ 
+   type tracker_info = {interval:float; tracker_id:string; complete:int; incomplete:int}
+   
+   type event = Started | Stopped | Completed
+   let strevent ev = match ev with
+       Started -> "started"
+     | Stopped -> "stopped"
+     | Completed -> "completed"   
+   
+   type file_info = {uploaded:int64; downloaded:int64; left:int64}
+ 
+   (* simple calculate file_info based on piece_array, may differ from real numbers 
+      with cheats ^_^ *)
+   let calculate_file_info piece_array plength flength = 
+     let count = Array.fold_left (fun a {have=have;} -> a + if have then 1 else 0) 0 piece_array in
+     let dnld = Int64.mul plength (Int64.of_int count) in
+     let upld = Int64.mul dnld 2L in
+     let lft = Int64.sub flength dnld in
+       {uploaded=upld;downloaded=dnld;left=lft}
+     
+   let print_stat tinfo finfo peers_count = 
+       Printf.printf "seeders: %d\n" tinfo.complete;
+       Printf.printf "leechers: %d\n" tinfo.incomplete;
+       Printf.printf "peers: %d\n" peers_count;       
+       Printf.printf "I'm downloaded: %Ld bytes\n" finfo.downloaded;
+       flush stdout
+
+         
+   let make_query addps info_hash peer_id serverport finfo = 
+     [("info_hash", info_hash );
+      ("peer_id", peer_id);
+      ("port", string_of_int serverport);
+      ("uploaded", string_of_int64 finfo.uploaded);
+      ("downloaded", string_of_int64 finfo.downloaded);
+      ("left", string_of_int64 finfo.left);
+      ("numwant", "10");(* hardocoded this. in later version, maybe load from config *)
+      ("compact", "1")] @ addps
+
+                            
+   let make_init_query = make_query [("event", strevent Started)]
+   
+   let make_time_query tracker_id = make_query [("tracker_id", tracker_id)]
+
+   let make_completed_query = make_query [("event", strevent Completed)]
+
+  (* get peer list from parsed tracker response content *)
+   let peer_list peers = match peers with
+       BList lst -> List.map (fun dct -> (get_str & bassoc "ip" dct, get_str & bassoc "port" dct)) lst
+     | BString str -> inet_ntoa str
+     | _ -> failwith "`peers` value in tracker response not a supported Bencoded Type!" 
+
+              
+   let parse_tracker_response resp = 
+     let bresp = decode_string resp in
+     let gfi k = get_int & bassoc k bresp in
+     let gfs k = get_str & bassoc k bresp in
+     if mem_bassoc "failure reason" bresp 
+     then
+       let err = gfs "failure reason" in 
+         failwith & "Tracker answer error response:\n" ^ err
+     else
+     let tracker_id = try gfs "tracker_id" with Not_found -> "" in
+     let complete = try gfi "complete" with Not_found -> 0 in
+     let incomplete = try gfi "incomplete" with Not_found -> 0 in
+     let interval = float_of_int & gfi "interval" in
+       ({interval = interval;
+         tracker_id = tracker_id;
+         complete = complete;
+         incomplete = incomplete
+        },
+        peer_list & bassoc "peers" bresp
+       )
+ 
+ end;;
 (* different utility functions *)
 
  module KUtil = struct
-   let (>>) x f = f x
-   let ( & ) f x = f x         
+   
+   let ( >> ) x f = f x
+   let ( & ) f x = f x   
+   let ( $ ) f g x = f (g x)   
+   
+   let odd num = num mod 2 = 1
+   let even num = num mod 2 <> 1  
+ 
+   let min_len l = fun s -> (String.length s) > l
    
    (* bicycle!  use String.concat instead*)
    let join delim lst_of_string = 
            [] -> acc
          | h :: [] -> acc ^ h
          | h :: t -> joinR t (acc ^ h ^ delim)
-     in joinR lst_of_string "";; 
- 
-   
-   let urlencode str =
-     let buf = Buffer.create 20
-     in
-     let rec enc st = match (safe_next st) with
-         Some chr -> conv chr; enc st
-       | None -> Buffer.contents buf
-     
-     and safe_next st = try Some (Stream.next st)
-                        with Stream.Failure -> None
-     and conv chr = match chr with
-      '0'..'9' | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' | '-' | '~' -> Buffer.add_char buf chr
-      | _ -> Printf.bprintf buf "%%%x" (Char.code chr)
-  in enc (Stream.of_string str)
-
-
- let sha1sum s = Sha1.to_hex (Sha1.string s)
-
-                                              
- let gen20byte () = sha1sum & Printf.sprintf "%.0f"  & Unix.time ();;   
- 
- 
- let get_addr hostname port =
-   let addrinfos = Unix.getaddrinfo hostname port [] 
-   in let ainfo = List.hd addrinfos 
-   in ainfo.Unix.ai_addr
-        
- (* send whole message *)       
- let send_all sock msg = 
-   let lngth = String.length msg
-   in Unix.send sock msg 0 lngth []
-
- (* recieve all data from socket *)
- let recv_all ?(thunk=1024) sock = 
-   let buffer = String.create thunk in 
-   let rec recvR acc = 
-     let count = Unix.recv sock 0 thunk [] in
-       if count = 0 then acc
-       else recvR ((String.sub buffer 0 count)::acc)
-   in
-     String.concat "" (List.rev recvR [])
+     in joinR lst_of_string "" 
 
    
+   let range ?(start=0) ~stop ?(step=1) () =
+     let len = abs & if even start
+                     then (stop - start + 1)/step
+                     else (stop - start)/step
+     in 
+     Array.to_list & Array.init len (fun i -> i*step + (abs start))
    
+
+   let make_string char_list = 
+     let buf = Buffer.create (List.length char_list) in
+       List.iter (fun c -> Buffer.add_char buf c) char_list;
+       Buffer.contents buf
+   
+         
+   let contain str sub =
+     try
+      let (_:int) = Str.search_forward (Str.regexp sub) str 0 in
+        true
+     with Not_found -> false 
+         
+         
+   let hexn = List.map (fun num -> (Printf.sprintf "%x" num, num)) (range 15 ())
+          
+   let sha1sum s = 
+     let sha = Sha1.to_hex (Sha1.string s) in
+     let ssha = Stream.of_string sha in
+       let rec unhex acc = parser 
+         | [< 'fst; 'snd; rst >] -> 
+            let f = List.assoc (String.make 1 fst) hexn
+            and s = List.assoc (String.make 1 snd) hexn
+            in unhex ((Char.chr & f*16 + s)::acc) rst
+         | [< >] -> make_string & List.rev acc
+       in unhex [] ssha
+              
+   
+   let string_of_int64 n = Printf.sprintf "%Ld" n
+
+   (* read all data from file *)
+   let input_all chn = 
+     let rec inputln acc = 
+       try
+         inputln ((input_line chn)::acc)
+       with End_of_file -> List.rev acc
+     in 
+       String.concat "" (inputln [])
+
+   (* same as Stream.npeek, but remove elements from stream *)
+   let stream_nextn n strm =
+     let rec collect i acc =
+       if i = 0 then List.rev acc
+       else
+         try
+           collect (i-1) ((Stream.next strm)::acc)
+         with
+           Stream.Failure -> List.rev acc
+     in collect n []
+
  end;;
Empty file added.
+HTTP/1.0 200 OK
+Content-Type: text/plain
+Content-Length: 431
+
+d8:completei54e10:downloadedi5e10:incompletei2e8:intervali1942e12:min intervali971e5:peers336:YдK�>ˆ"qc_ں
         BString of string
       | BInt of int64
       | BList of value list
-      | BDict of (string * value) list    
+      | BDict of (string * value) list                      
+                   
     let char_to_int64 c = Int64.of_string (String.make 1 c)
 
-
     let decode_stream stream = 
       let ten = Int64.of_int 10 in 
       let rec parse_value = parser 
        | [< >] -> List.rev acc
       in
         let show () = 
-        (* show function is whole copy from ygrek's source. can't explain it yet ^_^ *)
           let tail = Stream.npeek 10 stream >> List.map (String.make 1) >> String.concat ""
           in Printf.sprintf "Position %u : %s" (Stream.count stream) tail 
         in
     let decode_file flnm = 
       let fl = open_in_bin flnm in 
       let stream = Stream.of_channel fl in
-      decode_stream stream
+      let res = decode_stream stream in 
+        close_in fl; res
 
         
     (* for short-writing *)

fromtorrentru.txt

+'GET /announce?info_hash=%e6%25%c0U%a7%09%9a%97%5b%d6%87L%a8P%c7b%28%e2A%04&peer_id=M6-1-2--n4%40B%3a%cc%c3%17%5d%b7%ff3&port=50238&uploaded=0&downloaded=0&left=2702848&corrupt=0&key=0E6A0E15&event=started&numwant=200&compact=1&no_peer_id=1&ipv6=fe80%3a%3a2441%3aa338%3abd06%3a1497 HTTP/1.1\r\nHost: 192.168.6.131:12313\r\nUser-Agent: BitTorrent/6120\r\nAccept-Encoding: gzip\r\n\r\n'
+
+
+  "GET /announce.php?uk=6qYih4A9Kv&?info_hash=%e6%25%c0U%a7%9%9a%97%5b%d6%87L%a8
+P%c7b%28%e2A%4&peer_id=-KA0001-%21L%81%e1%e5%d2%3b%17%c7%c3%7v5%85&port=12345&up
+loaded=0&downloaded=0&left=2702848&event=started&numwant=10&compact=1 HTTP/1.1\r
+\nHost: bt3.torrents.ru\r\nUser-Agent: KamloTor0.1\r\nAccept-Encoding: gzip\r\n\
+r\n"

fsharp.torrent

Binary file added.
- open KUtil
+ open KNet
+ open KHttp
+ open Bencode
+   
+ module Katorrent = struct   
+   
+   
+   type piece_array = {arr:piece_info array; pimutex:Mutex.t}
+   and piece_info = {piece_hash:string;mutable have:bool}
 
- let get_bdictkey key bdict = match bdict with
-     Bencode.BDict lst -> List.assoc key lst
-   | _ -> failwith "Invalid argument!"
- 
- let info = get_bdictkey "info"
- let announce_addr = get_bdictkey "announce"
- let gen_peer_id () = urlencode & gen20byte ()
+
+   type peer_table = {tbl:(string * string, bool array * peer_status) Hashtbl.t;
+                      pemutex:Mutex.t} 
+   and peer_status = {mutable am_choking:bool;
+                       mutable am_interested:bool;
+                       mutable peer_choking:bool;
+                       mutable peer_interested:bool
+                      }
+   type peer_field = Am_choking |  Am_interested |  Peer_choking | Peer_interested
+   let init_status () = {am_choking = true; am_interested = false;
+                         peer_choking = true; peer_interested = false}
+
+
+
+   let gen_peer_id () = 
+     let rnd = sha1sum & Printf.sprintf "%.0f"  & Unix.time () in
+     let prt = String.sub rnd 0 12 in
+     "-KA0001-" ^ prt
+   
+   (* return value from bdict associated with key *)
+   let bassoc key bdict = match bdict with
+       BDict lst -> List.assoc key lst
+     | _ -> failwith "Invalid argument -- not a bencoded dictionary"  
+              
+              
+   let mem_bassoc key bdict = match bdict with
+       BDict lst -> List.mem_assoc key lst
+     | _ -> failwith "Invalid argument -- not a bencoded dictionary"               
+    
+              
+   let get_str bval = match bval with
+       BString st -> st
+     | _ -> failwith "value not a string!"
+
+   let get_int bval = match bval with
+       BInt i64 -> Int64.to_int i64
+     | _ -> failwith "value not an integer!"                         
+   
+   let get_int64 bval = match bval with
+       BInt i64 -> i64
+     | _ -> failwith "value not an integer!" 
+              
+   (* generate piece_info array from `piece` string from info_dict
+      piece status initialy -- not have  *)
+   let piece_array ?(plen=20) hashstr = 
+     let slen = String.length hashstr in 
+       Array.init (slen / 20) (fun i -> let s = String.sub hashstr (i*plen) plen
+                                 in {piece_hash=s;have=false})
+   
+   let get_bitfield piece_array = 
+     let count = (Array.length piece_array) / 8 in
+     let buf = Buffer.create count in 
+     let byte piece_infos = 
+       let dec init {have=have;} = 2*init + if have then 1 else 0 in
+         Char.chr & Array.fold_left dec 0 piece_infos
+     in for i=0 to count-1 do
+       Buffer.add_char buf & byte & Array.sub piece_array (i*8) 8
+     done;
+     Buffer.contents buf
+                 
+   let init_piecehave piece_count = Array.create piece_count false       
+   
+   (* generate piecehave array from bitifield *)
+   let get_piecehave bitfield = 
+     let bin chr = 
+       let rec binR num acc = 
+         if num = 0
+            then
+              let answ = Array.of_list acc in
+              let alen = Array.length answ in
+                if alen = 8
+                   then answ
+                   else Array.append (Array.make (8-alen) false) answ 
+           else binR (num / 2) ((num mod 2 = 1)::acc)
+       in 
+         binR (Char.code chr) [] 
+     in
+     let len = String.length bitfield in
+       Array.concat & List.map bin & Stream.npeek len & Stream.of_string bitfield
+   
+                                                          
+   let all_done parray = 
+     Array.fold_left (fun init {have=h} -> init && h) true parray                                                         
+           
+
+   let empty_array parray = 
+     Array.fold_left (fun init {have=h} -> true && (not h)) true parray
+
+       
+   let register_piece pieces piece_index = 
+     Mutex.lock pieces.pimutex;
+     pieces.arr.(piece_index).have <- true;
+     Mutex.unlock pieces.pimutex
+
+
+   
+   let get_torrent_info metainfo =
+     try
+       let tracker_addr = get_str & bassoc "announce" metainfo in  
+       let infod = bassoc "info" metainfo in 
+       let info_hash = sha1sum & encode infod in 
+       let piece_length = get_int64 & bassoc "piece length" infod in
+       let pieces = piece_array & get_str & bassoc "pieces" infod in
+       let pieces_count = Array.length pieces in  
+       let filename = get_str & bassoc "name" infod in
+       let filelength = get_int64 & bassoc "length" infod in
+        (info_hash, tracker_addr, piece_length, pieces, pieces_count, filename, filelength)
+     with Not_found -> failwith "Multifile torrent not implemented yet"
+
+           
+   let print_info flnm flng = 
+     Printf.printf "\n %s -- %s Byte \n" flnm (Int64.to_string flng)
+   
+                                                   
+   let register_peers peer_tbl peer_list piece_count = 
+     Mutex.lock peer_tbl.pemutex;
+     List.iter (fun host_port -> 
+                  Hashtbl.add peer_tbl.tbl host_port (init_piecehave piece_count,
+                                                      init_status ())
+               ) peer_list;
+     Mutex.unlock peer_tbl.pemutex
+       
+       
+   let regiser_peer peer_tbl peer piece_count = 
+     Mutex.lock peer_tbl.pemutex;
+     Hashtbl.add peer_tbl.tbl peer (init_piecehave piece_count, init_status ());
+     Mutex.unlock peer_tbl.pemutex
+      
+               
+ end;;
+     
+#directory "sha1";;
+#directory "C:\\Ocaml\\lib\\threads";;
+#load "dynlink.cma";;
+#load "camlp4o.cma";;
+#load "sha1.cma";;
+#load "Unix.cma";;
+#load "Str.cma";;
+#load "Threads.cma";;
+
+#use "KUtil.ml";;
+#use "Bencode.ml";;
+#use "KNet.ml";;
+#use "BigEndian.ml";;
+#use "KMsg.ml";;
+#use "KHttp.ml";;
+#use "katorrent.ml";;
+#use "KTracker.ml";;
+#use "KFile.ml";;
+#use "KPeer.ml";;
+#use "KMain.ml";;
+
+#trace KNet.get_hostport;;
+#trace KPeer.process_peer;;
+#trace KPeer.handle_outcoming;;
+#trace KPeer.handle_incoming;;
+#trace List.filter;;
+#trace Katorrent.get_torrent_info;;
+#trace KNet.inet_ntoa;;
+#trace KNet.recv_all;;
+#trace KPeer.parse_handshake;;
+#trace KMsg.parse_msg;;
+#trace KMsg.format_msg;;
+(* main ~path:"mod.torrent" ();; *)
+d8:announce50:http://bt3.torrents.ru/announce.php?uk=uWraGiplqu&13:announce-listll50:http://bt3.torrents.ru/announce.php?uk=uWraGiplqu&el31:http://retracker.local/announceee7:comment48:http://torrents.ru/forum/viewtopic.php?t=236423210:created by13:uTorrent/184013:creation datei1256892494e8:encoding5:UTF-84:infod6:lengthi60351e4:name21:СУПЕР МОД.rar12:piece lengthi65536e6:pieces20:W!Z�H���

ocaml.torrent

Binary file added.
+GET /announce?info_hash=W%8b%1a1V%1c%a3X%b0%f7f%e2%0b%5b%2b%af%b6%126%a6&peer_id=M6-1-2--n4%5eeB~%02%b2%a7v%d5%ca&port=50238&uploaded=0&downloaded=0&left=11170400&corrupt=0&key=CB451D6A&event=started&numwant=200&compact=1&no_peer_id=1&ipv6=2001%3a0%3ad5c7%3aa2d6%3a285e%3a8cf%3aa62f%3a4bb4 HTTP/1.1\r\nHost: localhost:8080\r\nUser-Agent: BitTorrent/6120\r\nAccept-Encoding: gzip\r\n\r\n
+
+
+answ
+
+HTTP/1.0 200 OK
+Content-Type: text/plain
+Content-Length: 431
+
+d8:completei54e10:downloadedi5e10:incompletei2e8:intervali1942e12:min intervali971e5:peers336:YдK�>ˆ"qc_ں
+
+
+
+===========================
+
+