src/networks/fileTP/fileTPComplexOptions.ml

   1 (* Copyright 2001, 2002 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 Queues
  21 open Printf2
  22 open Md4
  23 open Options
  24 open BasicSocket
  25
  26 open CommonDownloads
  27 open CommonTypes
  28 open CommonFile
  29
  30 open FileTPTypes
  31 open FileTPOptions
  32 open FileTPGlobals
  33
  34 module ClientOption = struct
  35
  36     let value_to_client v =
  37       match v with
  38       | Module assocs ->
  39
  40           let get_value name conv = conv (List.assoc name assocs) in
  41           let client_hostname = get_value "client_hostname" value_to_string in
  42           let client_port = get_value "client_port" value_to_int in
  43           let client_referer = try
  44               get_value "client_referer" value_to_string with _ -> "" in
  45           let client_proto = try
  46               get_value "client_proto" value_to_string with _ -> "http" in
  47           let proto = find_proto client_proto in
  48           let c = new_client proto client_hostname client_port client_referer in
  49           c
  50       | _ -> failwith "Options: Not a client"
  51
  52     let client_to_value c =
  53       Options.Module [
  54         "client_hostname", string_to_value c.client_hostname;
  55         "client_port", int_to_value c.client_port;
  56         "client_proto", string_to_value c.client_proto.proto_string;
  57         "client_referer", string_to_value c.client_referer;
  58       ]
  59
  60     let t =
  61       define_option_class "Client" value_to_client client_to_value
  62
  63   end
  64
  65 let value_to_int32pair v =
  66   match v with
  67     List [v1;v2] | SmallList [v1;v2] ->
  68       (value_to_int64 v1, value_to_int64 v2)
  69   | _ ->
  70       failwith "Options: Not an int32 pair"
  71
  72 let value_to_file file_size file_state user group assocs =
  73   let get_value name conv = conv (List.assoc name assocs) in
  74
  75   let file_name = get_value "file_filename" value_to_string in
  76   let file_id =
  77     try
  78       Md4.of_string (get_value "file_id" value_to_string)
  79     with _ -> failwith "Bad file_id"
  80   in
  81   let file = new_file file_id file_name file_size user group in
  82
  83   (match file.file_swarmer with
  84       None -> ()
  85     | Some swarmer ->
  86         CommonSwarming.value_to_frontend swarmer assocs;
  87   );
  88
  89   (try
  90       ignore (get_value "file_sources" (value_to_list (fun v ->
  91               match v with
  92               | SmallList [c; index] | List [c; index] ->
  93                   let s = ClientOption.value_to_client c in
  94                   add_download file s (Url.of_string (value_to_string index))
  95               | _ -> failwith "Bad source"
  96           )))
  97     with e ->
  98         lprintf "Exception %s while loading source\n"
  99           (Printexc2.to_string e);
 100   );
 101   as_file file
 102
 103 let file_to_value file =
 104   let assocs =
 105     [
 106       "file_id", string_to_value (Md4.to_string file.file_id);
 107       "file_sources",
 108       list_to_value (fun c ->
 109           let n = (find_download file c.client_downloads).download_url in
 110           SmallList [ClientOption.client_to_value c;
 111             string_to_value (Url.to_string n)]
 112       ) file.file_clients;
 113     ]
 114   in
 115   match file.file_swarmer with
 116     None -> assocs
 117   | Some swarmer ->
 118       CommonSwarming.frontend_to_value swarmer assocs
 119
 120 let old_files =
 121   define_option fileTP_section ["old_urls"]
 122     "" (list_option Url.option) []
 123
 124 let save_config () =
 125
 126   let files = !!old_files in
 127   old_files =:= [];
 128   List.iter (fun file ->
 129       if not (List.mem file !!old_files) then
 130         old_files =:= file :: !!old_files
 131   ) files;
 132   ()
 133
 134 let _ =
 135   network.op_network_file_of_option <- value_to_file;
 136   file_ops.op_file_to_option <- file_to_value;
 137   file_ops.op_file_recover <- (fun _ -> ());
 138   network.op_network_load_complex_options <- (fun _ -> ());
 139   network.op_network_save_complex_options <- (fun _ -> ());
 140   network.op_network_update_options <- (fun _ -> ());
 141   network.op_network_save_sources <- (fun _ -> ())