src/networks/bittorrent/kademlia.ml

   1 (** Generic implementation of Kademlia *)
   2
   3 let bucket_nodes = 8
   4
   5 module H = Md4.Sha1
   6
   7 let pr fmt = Printf.ksprintf print_endline fmt
   8
   9 let () =
  10   let hash = H.random () in
  11   pr "len: %d up: %x %x %x" H.length (H.up hash) (H.up2 hash) (H.up3 hash);
  12   pr "string: %s" (H.to_string hash);
  13   pr "direct: %S" (H.direct_to_string hash);
  14   pr "hexa: %s" (H.to_hexa hash);
  15   pr "bits: %s" (H.to_bits hash);
  16   pr "base32: %s" (H.to_base32 hash);
  17
  18 (** node ID type *)
  19 type id = H.t
  20 let show_id = H.to_hexa
  21 type addr = Ip.t * int
  22
  23 type time = float
  24 type status = | Good | Bad | Unknown | Pinged
  25 type node = { id : id; addr : addr; mutable last : time; mutable status : status; }
  26 type bucket = { lo : id; hi : id; mutable last_change : time; nodes : node array; }
  27 (* FIXME better *)
  28 type tree = L of bucket | N of tree * tree
  29 type table = { mutable root : tree; self : id; }
  30
  31 let show_addr (ip,port) = Printf.sprintf "%s:%u" (Ip.to_string ip) port
  32
  33 let show_status = function
  34   | Good -> "good"
  35   | Bad -> "bad"
  36   | Unknown -> "unk"
  37   | Pinged -> "ping"
  38
  39 let show_node n =
  40   pr " id : %s inet %s last : %f status : %s"
  41     (H.to_hexa n.id) (show_addr n.addr) n.last (show_status n.status)
  42
  43 let show_bucket b =
  44   pr "lo : %s hi : %s changed : %f" (H.to_hexa b.lo) (H.to_hexa b.hi) b.last_change;
  45   Array.iter show_node b.nodes
  46
  47 let rec show_table = function
  48   | N (l,r) -> show_table l; show_table r
  49   | L b -> show_bucket b
  50
  51 let h2s h =
  52   let s = H.direct_to_string h in
  53   assert (String.length s = H.length);
  54   s
  55
  56 type cmp = LT | EQ | GT
  57
  58 let cmp id1 id2 =
  59   match String.compare (h2s id1) (h2s id2) with
  60   | -1 -> LT
  61   | 0 -> EQ
  62   | 1 -> GT
  63   | _ -> assert false
  64
  65 (* boundaries inclusive *)
  66 let inside x node = not (cmp x node.lo = LT || cmp x node.hi = GT)
  67
  68 let bracket res destroy k =
  69   let x = try k res with exn -> destroy res; raise exn in
  70   destroy res;
  71   x
  72
  73 let with_open_in_bin file = bracket (open_in_bin file) close_in_noerr
  74 let with_open_out_bin file = bracket (open_out_bin file) close_out_noerr
  75
  76 let load file : table = with_open_in_bin file Marshal.from_channel
  77 let store file (t:table) = with_open_out_bin file (fun ch -> Marshal.to_channel ch t [])
  78
  79 let middle =
  80   let s = String.make 20 (Char.chr 0xFF) in
  81   s.[0] <- Char.chr 0x7F;
  82   H.direct_of_string s
  83
  84 let middle' =
  85   let s = String.make 20 (Char.chr 0x00) in
  86   s.[0] <- Char.chr 0x80;
  87   H.direct_of_string s
  88
  89 let last =
  90   H.direct_of_string (String.make 20 (Char.chr 0xFF))
  91
  92 open Big_int
  93
  94 let big_int_of_hash h =
  95   let s = h2s h in
  96   let n = ref zero_big_int in
  97   for i = 0 to String.length s - 1 do
  98     n := add_int_big_int (Char.code s.[i]) (mult_int_big_int 256 !n)
  99   done;
 100   !n
 101
 102 let hash_of_big_int n =
 103   let s = String.create H.length in
 104   let n = ref n in
 105   let div = big_int_of_int 256 in
 106   for i = String.length s - 1 downto 0 do
 107     let (d,m) = quomod_big_int !n div in
 108     s.[i] <- Char.chr (int_of_big_int m);
 109     n := d
 110   done;
 111   assert (eq_big_int zero_big_int !n);
 112   H.direct_of_string s
 113
 114 (* hash <-> number *)
 115 let h2n = big_int_of_hash
 116 let n2h = hash_of_big_int
 117
 118 let split lo hi =
 119   assert (cmp lo hi = LT);
 120   let mid = div_big_int (add_big_int (h2n lo) (h2n hi)) (big_int_of_int 2) in
 121   n2h mid
 122
 123 let distance h1 h2 =
 124   let s1 = h2s h1 and s2 = h2s h2 in
 125   let d = ref zero_big_int in
 126   for i = 0 to H.length - 1 do
 127     let x = Char.code s1.[i] lxor Char.code s2.[i] in
 128     d := add_int_big_int x (mult_int_big_int 256 !d)
 129   done;
 130   !d
 131
 132 let () =
 133   print_endline (show_id H.null);
 134   print_endline (show_id middle);
 135   print_endline (show_id middle');
 136   print_endline (show_id last);
 137   assert (LT = cmp H.null middle);
 138   assert (LT = cmp H.null middle');
 139   assert (LT = cmp H.null last);
 140   assert (GT = cmp middle' middle);
 141   assert (GT = cmp last middle');
 142   assert (GT = cmp last middle);
 143   assert (EQ = cmp H.null H.null);
 144   assert (EQ = cmp middle middle);
 145   assert (EQ = cmp last last);
 146   assert (n2h (h2n middle) = middle);
 147   assert (n2h (h2n middle') = middle');
 148   assert (n2h (h2n last) = last);
 149   assert (n2h (h2n H.null) = H.null);
 150   assert (compare_big_int (h2n H.null) zero_big_int = 0);
 151   assert (cmp (split H.null last) middle = EQ);
 152   assert (eq_big_int (distance H.null last) (pred_big_int (power_int_positive_int 2 160)));
 153   assert (eq_big_int (distance middle' middle) (pred_big_int (power_int_positive_int 2 160)));
 154   ()
 155
 156 exception Nothing
 157
 158 let insert table node =
 159   let rec loop = function
 160   | N (l,r) -> if cmp node.id r.lo = LT then N (loop l, r) else N (l, loop r)
 161   | L b ->
 162     if Array.find (fun n -> n.id = node.id)
 163   Array.length b.nodes <> bucket_nodes -> b.nodes <- Array.of_list (node::Array.to_list b.nodes); raise Nothing
 164   | L b when inside table.self b ->
 165   | L _ -> raise Nothing (* throw away *)
 166   in
 167   try table.root <- loop table.root
 168   with Nothing -> ()
 169
 170 let now = Unix.gettimeofday
 171
 172 let empty () = L { lo = H.null; hi = last; last_change = now (); nodes = [||]; }
 173
 174 let table = { root = empty (); self = H.random (); }
 175
 176 let () =
 177   show_table !table
 178