src/networks/bittorrent/bTUdpTracker.mlp

   1 (** UDP trackers
   2   http://www.bittorrent.org/beps/bep_0015.html *)
   3
   4 open Bitstring
   5
   6 let of_bits = string_of_bitstring
   7 let bits = bitstring_of_string
   8
   9 exception Error of string
  10
  11 let fail fmt = Printf.ksprintf (fun s -> raise (Error s)) fmt
  12
  13 let bitmatch error_response = { 3l : 32 ; txn : 32 ; msg : -1 : string }
  14
  15 (** connect - obtain connection_id *)
  16 let connect_request txn =
  17   of_bits ( BITSTRING { 0x41727101980L : 64 ; 0l : 32 ; txn : 32 } )
  18
  19 (** connect response with connection_id for future use *)
  20 let connect_response s exp_txn =
  21   bitmatch bits s with
  22   | { 0l : 32 ; txn : 32 ; conn_id : 64 } ->
  23     if txn = exp_txn then conn_id else fail "error connect_response txn %ld expected %ld" txn exp_txn
  24   | { :error_response } -> fail "error connect_response txn %ld : %s" txn msg
  25   | { }  -> fail "error connect_response"
  26
  27 (** announce *)
  28 let announce_request conn txn ~info_hash ~peer_id (downloaded,left,uploaded) event ?(ip=0l) ?(key=0l) ~numwant port =
  29   of_bits (BITSTRING {
  30     conn : 64 ;
  31     1l : 32 ;
  32     txn : 32 ;
  33     info_hash : 20 * 8 : string;
  34     peer_id : 20 * 8 : string;
  35     downloaded : 64 ;
  36     left : 64 ;
  37     uploaded : 64 ;
  38     event : 32 ;
  39     0l : 32 ; (* ip *)
  40     key : 32 ; (* key *)
  41     numwant : 32 ; (* numwant *)
  42     port : 16 })
  43
  44 (** announce response *)
  45 let announce_response s exp_txn =
  46   let rec clients rest l =
  47     bitmatch rest with
  48     | { ip : 32 ; port : 16 ; rest : -1 : bitstring } -> clients rest ((ip,port)::l)
  49     | { } -> l
  50   in
  51   bitmatch bits s with
  52   | { 1l : 32 ; txn : 32 ; interval : 32 ; leechers : 32 ; seeders : 32 ;
  53       rest : -1 : bitstring } ->
  54         if txn = exp_txn then
  55           (interval,clients rest [])
  56         else
  57           fail "error announce_response txn %ld expected %ld" txn exp_txn
  58   | { :error_response } -> fail "error announce_response txn %ld : %s" txn msg
  59   | { } -> fail "error announce_response"
  60