src/networks/bittorrent/bTComplexOptions.ml

   1 (* Copyright 2001, 2002 b52_simon :), b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Int64ops
  21 open Printf2
  22 open BasicSocket
  23 open Md4
  24 open Options
  25
  26 open CommonGlobals
  27 open CommonDownloads
  28 open CommonTypes
  29 open CommonFile
  30
  31 open BTTypes
  32 open BTOptions
  33 open BTGlobals
  34
  35 let bt_dht_ini = create_options_file "bt_dht.ini"
  36 let bt_dht_section = file_section bt_dht_ini [] ""
  37
  38 let dht_routing_table = define_option bt_dht_section ["dht_routing_table"] ""
  39     Kademlia.RoutingTableOption.t (Kademlia.create ())
  40
  41 let bt_stats_ini = create_options_file "stats_bt.ini"
  42 let bt_stats_section = file_section bt_stats_ini [] ""
  43
  44 module StatsOption = struct
  45
  46     let value_to_stat v =
  47       match v with
  48         Options.Module assocs ->
  49           {
  50             brand_seen = value_to_int (List.assoc "seen" assocs);
  51             brand_banned = value_to_int (List.assoc "banned" assocs);
  52             brand_filerequest = value_to_int (List.assoc "filereqs" assocs);
  53             brand_download = value_to_int64 (List.assoc "download" assocs);
  54             brand_upload = value_to_int64 (List.assoc "upload" assocs);
  55           }
  56
  57       | _ -> failwith "Options: not a stat option"
  58
  59     let stat_to_value b =
  60       Options.Module [
  61         "seen", int_to_value b.brand_seen;
  62         "banned", int_to_value b.brand_banned;
  63         "filereqs", int_to_value b.brand_filerequest;
  64         "download", int64_to_value b.brand_download;
  65         "upload", int64_to_value b.brand_upload;
  66       ]
  67
  68
  69     let t = define_option_class "Stat" value_to_stat stat_to_value
  70   end
  71
  72 module ClientOption = struct
  73
  74     let value_to_client file v =
  75       match v with
  76       | Module assocs ->
  77
  78           let get_value name conv = conv (List.assoc name assocs) in
  79           let client_ip = get_value "client_ip" (from_value Ip.option)
  80           in
  81           let client_port = get_value "client_port" value_to_int in
  82           let client_uid = get_value "client_uid" (from_value Sha1.option) in
  83           let c = new_client file client_uid (client_ip, client_port) None in
  84
  85           c
  86       | _ -> failwith "Options: Not a client"
  87
  88
  89     let client_to_value c =
  90       let (ip,port) = c.client_host in
  91           Options.Module [
  92             "client_uid", to_value Sha1.option c.client_uid;
  93             "client_ip", to_value Ip.option ip;
  94             "client_port", int_to_value port;
  95           ]
  96
  97     let to_value = client_to_value
  98     let of_value = value_to_client
  99
 100   end
 101
 102 let value_to_file file_size file_state user group assocs =
 103   let get_value name conv = conv (List.assoc name assocs) in
 104   let file_trackers =
 105     try
 106       get_value "file_trackers" (value_to_list value_to_string)
 107     with _ ->
 108         try
 109           [get_value "file_tracker"  value_to_string]
 110         with _ -> failwith "Bad file_tracker"
 111   in
 112
 113   let file_id, torrent, torrent_diskname =
 114     try
 115       let torrent_diskname = get_value "file_torrent_name" value_to_string in
 116       let s = File.to_string torrent_diskname in
 117       let file_id, torrent = BTTorrent.decode_torrent s in
 118       file_id, torrent, torrent_diskname
 119     with _ ->
 120
 121         let file_name = get_value "file_name" value_to_string in
 122         let file_comment = try get_value "file_comment" value_to_string with Not_found -> "" in
 123         let file_id =
 124           try
 125             Sha1.of_string (get_value "file_id" value_to_string)
 126           with _ -> failwith "Bad file_id"
 127         in
 128         let file_piece_size = try
 129             value_to_int64 (List.assoc "file_piece_size" assocs)
 130           with _ -> failwith "Bad file size"
 131         in
 132         let file_chunks =
 133           get_value "file_hashes" (value_to_array
 134               (from_value Sha1.option))
 135         in
 136         let file_size = get_value "file_size" value_to_int64 in
 137         let file_created_by = try get_value "file_created_by" value_to_string with Not_found -> "" in
 138         let file_creation_date = try get_value "file_creation_date" value_to_int64 with Not_found -> Int64.zero in
 139         let file_modified_by = try get_value "file_modified_by" value_to_string with Not_found -> "" in
 140         let file_encoding = try get_value "file_encoding" value_to_string with Not_found -> "" in
 141         let file_is_private =
 142           try get_value "file_is_private" value_to_bool with
 143           | Not_found -> false
 144           | _ -> try get_value "file_is_private" value_to_int64 <> 0L with _ -> false
 145         in
 146         let file_files =
 147           try
 148             let file_files = (get_value "file_files"
 149                   (value_to_list (fun v ->
 150                       match v with
 151                         SmallList [name; p1]
 152                       | List [name; p1] ->
 153                           value_to_string name, value_to_int64 p1
 154                       | _ -> assert false
 155                   ))) in
 156             file_files
 157           with _ -> []
 158         in
 159         let torrent = {
 160             torrent_name = file_name;
 161             torrent_filename = "";
 162             torrent_name_utf8 = file_name;
 163             torrent_comment = file_comment;
 164             torrent_pieces = file_chunks;
 165             torrent_piece_size = file_piece_size;
 166             torrent_files = file_files;
 167             torrent_length = file_size;
 168             torrent_created_by = file_created_by;
 169             torrent_creation_date = file_creation_date;
 170             torrent_modified_by = file_modified_by;
 171             torrent_encoding = file_encoding;
 172             torrent_private = file_is_private;
 173 (*
 174             torrent_nodes = file_nodes;
 175 *)
 176             torrent_announce =
 177             (match file_trackers with
 178               | h::q -> h
 179               | [] -> "");
 180             torrent_announce_list = file_trackers;
 181           } in
 182         let torrent_diskname = Filename.concat downloads_directory
 183             (file_name ^ ".torrent") in
 184         file_id, torrent, torrent_diskname
 185
 186   in
 187   let file_temp = try
 188       get_value "file_temp" value_to_string
 189     with Not_found ->
 190         let file_temp = Filename.concat !!DO.temp_directory
 191             (Printf.sprintf "BT-%s" (Sha1.to_string file_id)) in
 192         file_temp
 193   in
 194   let file = new_file file_id torrent torrent_diskname
 195                file_temp file_state user group in
 196
 197   let file_uploaded = try
 198       value_to_int64 (List.assoc "file_uploaded" assocs)
 199     with _ -> zero
 200   in
 201   file.file_uploaded <- file_uploaded;
 202
 203   (match file.file_swarmer with
 204       None -> ()
 205     | Some swarmer ->
 206         CommonSwarming.value_to_frontend swarmer assocs;
 207   );
 208
 209 (*
 210   (try
 211       ignore
 212         (get_value  "file_sources" (
 213           value_to_list (ClientOption.of_value file)))
 214     with e ->
 215         lprintf_nl "Exception %s while loading sources"
 216           (Printexc2.to_string e);
 217   );
 218 *)
 219   as_file file
 220
 221 let file_to_value file =
 222   try
 223     let assocs =
 224       [
 225         "file_temp", string_to_value (Unix32.filename (file_fd file));
 226         "file_piece_size", int64_to_value (file.file_piece_size);
 227         "file_name", string_to_value file.file_name;
 228         "file_uploaded", int64_to_value  (file.file_uploaded);
 229         "file_id", string_to_value (Sha1.to_string file.file_id);
 230         "file_trackers", (list_to_value string_to_value)
 231         (List.map (fun t -> show_tracker_url t.tracker_url) file.file_trackers);
 232 (* OK, but I still don't like the idea of forgetting all the clients.
 233 We should have a better strategy, ie rating the clients and connecting
 234 to them depending on the results of our last connections. And then,
 235 if we could not download enough in the last interval, ask the tracker to
 236 send us more clients.
 237
 238     "file_sources",
 239     list_to_value "BT Sources" (fun c ->
 240         ClientOption.to_value c) sources
 241 ;
 242   *)
 243       ]
 244     in
 245     let assocs =
 246       ("file_torrent_name", string_to_value file.file_torrent_diskname) ::
 247       ("file_hashes", array_to_value
 248           (to_value Sha1.option) file.file_chunks) ::
 249       ("file_files", list_to_value
 250           (fun (name, p1, _) ->
 251             SmallList [string_to_value name; int64_to_value p1])
 252         file.file_files) ::
 253       assocs
 254     in
 255     match file.file_swarmer with
 256       None -> assocs
 257     | Some swarmer ->
 258         CommonSwarming.frontend_to_value swarmer assocs
 259   with
 260     e ->
 261       lprintf_file_nl (as_file file) "exception %s in file_to_value"
 262         (Printexc2.to_string e); raise e
 263
 264
 265 let save_config () =
 266   Options.save_with_help bittorrent_ini
 267
 268
 269 let config_files_loaded = ref false
 270
 271 let load _ =
 272   begin try Options.load bt_stats_ini with Sys_error _ -> () end;
 273   begin try Options.load bt_dht_ini with Sys_error _ -> () end;
 274   check_client_uid ();
 275   config_files_loaded := true
 276
 277 let guptime = define_option bt_stats_section ["guptime"] "" int_option 0
 278
 279 let new_stats_array () =
 280   Array.init brand_count (fun _ ->
 281       { dummy_stats with brand_seen = 0 }
 282   )
 283
 284
 285 let gstats_array = define_option bt_stats_section ["stats"] ""
 286     (array_option StatsOption.t) (new_stats_array ())
 287
 288
 289 let _ =
 290   option_hook gstats_array (fun _ ->
 291       let old_stats = !!gstats_array in
 292       let old_len = Array.length old_stats in
 293       if old_len <> brand_count then
 294         let t = new_stats_array () in
 295         for i = 0 to old_len - 1 do
 296           t.(i) <- old_stats.(i)
 297         done;
 298         gstats_array =:= t
 299   )
 300
 301 let diff_time = ref 0
 302
 303 let sources_loaded = ref false  (* added 2.5.24 *)
 304
 305 let save _ =
 306   if !config_files_loaded then begin
 307 (*  lprintf "SAVING SHARED FILES AND SOURCES\n"; *)
 308       guptime =:= !!guptime + (last_time () - start_time) - !diff_time;
 309       diff_time := (last_time () - start_time);
 310       Options.save_with_help bt_stats_ini;
 311       Options.save_with_help bt_dht_ini;
 312     end
 313 (*  lprintf "SAVED\n";  *)
 314
 315 let guptime () = !!guptime - !diff_time
 316
 317 let _ =
 318   network.op_network_file_of_option <- value_to_file;
 319   file_ops.op_file_to_option <- file_to_value;
 320
 321   (* Shut up message "Network.save/load_complex_options not implemented by BitTorrent" *)
 322   network.op_network_load_complex_options <- load;
 323   network.op_network_save_complex_options <- save;
 324   network.op_network_update_options <- (fun _ -> ());
 325   network.op_network_save_sources <- (fun _ -> ())