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