src/daemon/common/commonComplexOptions.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 Int64ops
  21 open Options
  22 open Printf2
  23 open BasicSocket
  24
  25 open CommonGlobals
  26 open CommonClient
  27 open CommonServer
  28 open CommonNetwork
  29 open CommonOptions
  30 open CommonUserDb
  31 open CommonTypes
  32 open CommonFile
  33 open Gettext
  34
  35 let _s x = _s "CommonComplexOptions" x
  36 let _b x = _b "CommonComplexOptions" x
  37
  38 let log_prefix = "[cCO]"
  39
  40 let lprintf_nl fmt =
  41   lprintf_nl2 log_prefix fmt
  42
  43 let lprintf_n fmt =
  44   lprintf2 log_prefix fmt
  45
  46 (*************************************************************************)
  47 (*                                                                       *)
  48 (*                         FILES                                         *)
  49 (*                                                                       *)
  50 (*************************************************************************)
  51
  52 module FileOption = struct
  53
  54     let value_to_state v =
  55       match v with
  56       | StringValue "Paused" -> FilePaused
  57       | StringValue "Downloading" -> FileDownloading
  58       | StringValue "Downloaded" -> FileDownloaded
  59       | _ -> raise Not_found
  60
  61     let state_to_value s =
  62       match s with
  63       | FilePaused | FileAborted _ -> StringValue "Paused"
  64       | FileDownloaded -> StringValue "Downloaded"
  65       | _ -> StringValue "Downloading"
  66
  67
  68     let value_to_file is_done v =
  69       match v with
  70         Options.Module assocs ->
  71           let get_value name conv = conv (List.assoc name assocs) in
  72           let get_value_nil name conv =
  73             try conv (List.assoc name assocs) with Not_found -> [] in
  74           let filename = get_value "file_filename" value_to_string in
  75           let network = try get_value "file_network" value_to_string
  76             with _ -> "Donkey" in
  77           let network =
  78             try network_find_by_name network with e ->
  79                 lprintf_nl
  80                   "Error %s for network %s while parsing file %s"
  81                     (Printexc2.to_string e) network filename;
  82                 lprintf_nl "This core is lacking support for network %s, exiting" network;
  83                 exit_properly 70
  84           in
  85           let file_state =
  86             try
  87               get_value "file_state" value_to_state
  88             with _ -> FileDownloading
  89           in
  90           let file_size = try
  91               value_to_int64 (List.assoc "file_size" assocs)
  92             with _ -> Int64.zero
  93           in
  94
  95           let file_user =
  96             try
  97               let u = get_value "file_owner" value_to_string in
  98                 begin
  99                   try
 100                     user2_user_find u
 101                   with Not_found ->
 102                     lprintf_nl "file_owner %s of %s does not exist, changing to %s"
 103                       u filename (admin_user ()).user_name;
 104                     admin_user ()
 105                 end
 106             with Not_found ->
 107                 lprintf_nl "file_owner of %s is empty, changing to %s"
 108                   filename (admin_user ()).user_name;
 109                 admin_user ()
 110           in
 111
 112           let file_group =
 113             let dgroup = user2_print_user_default_group file_user in
 114             try
 115               match (get_value "file_group" value_to_stringoption) with
 116                 None -> None
 117               | Some g ->
 118                   begin
 119                     try
 120                       let g = user2_group_find g in
 121                       if List.mem g file_user.user_groups then
 122                         Some g
 123                       else
 124                         begin
 125                           lprintf_nl "file_owner %s is not member of file_group %s, changing file_group of %s to user_default_group %s"
 126                             file_user.user_name g.group_name filename dgroup;
 127                           file_user.user_default_group
 128                         end
 129                     with Not_found ->
 130                       lprintf_nl "file_group %s of %s not found, changing to user_default_group %s of user %s"
 131                         g filename dgroup file_user.user_name;
 132                       file_user.user_default_group
 133                   end
 134             with Not_found ->
 135                 lprintf_nl "file_group of %s is empty, changing to user_default_group %s of user %s"
 136                   filename dgroup file_user.user_name;
 137                 file_user.user_default_group
 138           in
 139
 140           let file = network_file_of_option network file_size
 141               file_state file_user file_group assocs in
 142
 143           let impl = as_file_impl file in
 144           (try
 145               impl.impl_file_age <-
 146                 normalize_time (get_value "file_age" value_to_int)
 147             with _ -> ());
 148
 149           (try
 150               impl.impl_file_release <-
 151                 get_value "file_release" value_to_bool
 152             with _ -> ());
 153
 154           set_file_state file file_state;
 155
 156           (try
 157               set_file_best_name file filename "" 0
 158             with _ -> ());
 159
 160           (try
 161             List.iter (fun s -> add_file_filenames file s)
 162               (get_value_nil "file_filenames" (value_to_list value_to_string))
 163             with _ -> ());
 164
 165           let priority = try get_value "file_priority" value_to_int
 166             with _ -> 0 in
 167           set_file_priority file priority;
 168
 169           if !verbose && !CommonGlobals.is_startup_phase then
 170             lprintf_nl "Started download of %s, user:group %s:%s"
 171               (file_best_name file)
 172               file_user.user_name
 173               (user2_print_group file_group);
 174
 175           file
 176       | _ -> assert false
 177
 178     let file_to_value file =
 179         let netname = string_to_value (file_network file).network_name in
 180       let impl = as_file_impl file in
 181       Options.Module (
 182         ("file_network", netname) ::
 183         ("file_size", int64_to_value (file_size file)) ::
 184         ("file_priority", int_to_value (file_priority file)) ::
 185         ("file_state", state_to_value (file_state file)) ::
 186         ("file_filename", string_to_value (file_best_name file)) ::
 187         ("file_filenames", List
 188         (List.map string_to_value impl.impl_file_filenames)) ::
 189         ("file_age", IntValue (Int64.of_int impl.impl_file_age)) ::
 190         ("file_release", bool_to_value impl.impl_file_release) ::
 191         ("file_owner", string_to_value (file_owner file).user_name) ::
 192         ("file_group", stringoption_to_value (match file_group file with Some g -> Some g.group_name | None -> None)) ::
 193           (file_to_option file)
 194         )
 195
 196     let t is_done =
 197       define_option_class "File" (value_to_file is_done) file_to_value
 198     ;;
 199   end
 200
 201
 202 let swarmers_section = file_section files_ini [] ""
 203 let files_section = file_section files_ini [] ""
 204
 205 let done_files =
 206   define_option files_section ["done_files"]
 207     "The files whose download is finished" (
 208     listiter_option (FileOption.t true)) []
 209
 210 let files =
 211   define_option files_section ["files"]
 212     "The files currently being downloaded, primary downloads must come first" (
 213     listiter_option (FileOption.t false)) []
 214
 215 (*************************************************************************)
 216 (*                                                                       *)
 217 (*                         RESULTS                                       *)
 218 (*                                                                       *)
 219 (*************************************************************************)
 220
 221 let value_to_tag =
 222   value_to_tuple2 (fun (v1,v2) ->
 223       let name = value_to_string v1 in
 224       let value = match v2 with
 225           IntValue i -> Uint64 i
 226         | _ -> String (value_to_string v2)
 227       in
 228       { tag_name = field_of_string name; tag_value = value })
 229
 230 let tag_to_value =
 231   tuple2_to_value (fun tag ->
 232       string_to_value (string_of_field tag.tag_name),
 233       match tag.tag_value with
 234         Uint64 i -> int64_to_value i
 235       | String s -> string_to_value s
 236       | Addr _ -> assert false
 237       | Fint64 i -> int64_to_value i
 238       | Uint16 n | Uint8 n -> int_to_value n
 239       | Pair (n1,n2) -> assert false
 240   )
 241
 242 module ResultOption = struct
 243
 244     let value_to_result v =
 245       match v with
 246         Options.Module assocs ->
 247           let get_value name conv = conv (List.assoc name assocs) in
 248
 249           let uids = get_value "uids" (fun uids ->
 250                 let uids = value_to_list value_to_string uids in
 251                 List.map Uid.of_string uids) in
 252           let names = get_value "names" (value_to_list value_to_string) in
 253           let size = get_value "size" value_to_int64 in
 254           let time = get_value "time" value_to_int in
 255           let format = try get_value "format" value_to_string with _ -> "" in
 256           let file_type = try get_value "type" value_to_string with _ -> "" in
 257           let tags = try get_value "tags" (value_to_list value_to_tag)
 258               with _ -> [] in
 259           let r = {
 260               CommonResult.dummy_result with
 261               result_uids = uids;
 262               result_names = names;
 263               result_size = size;
 264               result_time = time;
 265               result_format = format;
 266               result_type = file_type;
 267               result_tags = tags;
 268             }
 269           in
 270           let rs = CommonResult.update_result_num r in
 271           rs
 272       | _ -> assert false
 273
 274     let result_to_value rs =
 275       let r = CommonResult.IndexedResults.get_result rs in
 276
 277       let tags = ref [] in
 278       List.iter (fun tag ->
 279           match tag.tag_name with
 280             Field_Availability | Field_Completesources -> ()
 281           | _ -> tags := tag :: !tags;
 282       ) r.result_tags;
 283
 284       let list = [] in
 285       let list =  if !tags = [] then list else
 286           ("tags", list_to_value tag_to_value !tags) :: list
 287       in
 288       let list = if r.result_format = "" then list else
 289           ("format", string_to_value r.result_format) :: list
 290       in
 291       let list = if r.result_type = "" then list else
 292           ("type", string_to_value r.result_type) :: list
 293       in
 294       let list =
 295         ("uids", SmallList
 296             (List.map (fun uid ->
 297                 string_to_value (Uid.to_string uid)) r.result_uids)) ::
 298         ("names", SmallList
 299             (List.map string_to_value r.result_names)) ::
 300         ("size", int64_to_value r.result_size) ::
 301         ("time", int_to_value r.result_time) ::
 302         list
 303       in
 304       Options.Module list
 305
 306     let t =
 307       define_option_class "Result" value_to_result result_to_value
 308     end
 309
 310 let results_section = file_section results_ini [] ""
 311 let results = define_option results_section ["results"] ""
 312     (list_option ResultOption.t) []
 313 let known_uids = define_option results_section ["known_uids"] ""
 314     (list_option (tuple2_option (Uid.option, int_option))) []
 315
 316 (*************************************************************************)
 317 (*                                                                       *)
 318 (*                         SERVERS                                       *)
 319 (*                                                                       *)
 320 (*************************************************************************)
 321
 322
 323 module ServerOption = struct
 324
 325     let value_to_server v =
 326       match v with
 327         Options.Module assocs ->
 328           let get_value name conv = conv (List.assoc name assocs) in
 329           let network = try
 330               get_value "server_network" value_to_string
 331             with _ -> "Donkey"
 332           in
 333           let network =
 334             try network_find_by_name network with e ->
 335                 lprintf_nl "Loading servers, network %s not supported, deleting server" network;
 336                 raise e
 337               in
 338           let server = network_server_of_option network assocs in
 339           server
 340       | _ -> assert false
 341
 342     let server_to_value server =
 343       Options.Module (
 344         ("server_network",
 345           string_to_value (server_network server).network_name)
 346         ::
 347         (server_to_option server)
 348       )
 349
 350     let t =
 351       define_option_class "Server" value_to_server server_to_value
 352   end
 353
 354
 355 let servers = define_option servers_section
 356     ["known_servers"] "List of known servers"
 357     (intmap_option (fun s -> server_num s) ServerOption.t) Intmap.empty
 358
 359
 360 (*************************************************************************)
 361 (*                                                                       *)
 362 (*                         QUERIES                                       *)
 363 (*                                                                       *)
 364 (*************************************************************************)
 365
 366 let rec string_of_option v =
 367   match v with
 368     Module m -> "{ MODULE }"
 369   | StringValue s -> Printf.sprintf "STRING [%s]" s
 370   | IntValue i -> Printf.sprintf "INT [%Ld]" i
 371   | FloatValue f -> Printf.sprintf "FLOAT [%f]" f
 372   | OnceValue v -> string_of_option v
 373   | List l | SmallList l ->
 374       (List.fold_left (fun s v ->
 375             s ^ (string_of_option v) ^ ";"
 376         ) "LIST [" l) ^ "]"
 377   | DelayedValue _ -> assert false
 378
 379
 380 module QueryOption = struct
 381     let rec query_to_value q =
 382       match q with
 383       | Q_AND list ->
 384           List ((StringValue "AND") :: (List.map query_to_value list))
 385       | Q_OR list ->
 386           List ((StringValue "OR"):: (List.map query_to_value list))
 387       | Q_HIDDEN list ->
 388           List ((StringValue "HIDDEN"):: (List.map query_to_value list))
 389       | Q_ANDNOT (q1, q2) ->
 390           SmallList [StringValue "ANDNOT"; query_to_value q1; query_to_value q2 ]
 391       | Q_MODULE (s, q) ->
 392           SmallList [StringValue "MODULE"; StringValue s;  query_to_value q]
 393
 394
 395         | Q_KEYWORDS (label, s) ->
 396             SmallList [StringValue "KEYWORDS"; StringValue label; StringValue s]
 397         | Q_MINSIZE (label, s) ->
 398             SmallList [StringValue "MINSIZE"; StringValue label; StringValue s]
 399         | Q_MAXSIZE (label, s) ->
 400             SmallList [StringValue "MAXSIZE"; StringValue label; StringValue s]
 401         | Q_FORMAT (label, s) ->
 402             SmallList [StringValue "FORMAT"; StringValue label; StringValue s]
 403         | Q_MEDIA (label, s) ->
 404             SmallList [StringValue "MEDIA"; StringValue label; StringValue s]
 405
 406         | Q_MP3_ARTIST (label, s) ->
 407             SmallList [StringValue "MP3_ARTIST"; StringValue label; StringValue s]
 408         | Q_MP3_TITLE (label, s) ->
 409             SmallList [StringValue "MP3_TITLE"; StringValue label; StringValue s]
 410         | Q_MP3_ALBUM (label, s) ->
 411             SmallList [StringValue "MP3_ALBUM"; StringValue label; StringValue s]
 412         | Q_MP3_BITRATE (label, s) ->
 413             SmallList [StringValue "MP3_BITRATE"; StringValue label; StringValue s]
 414
 415       | Q_COMBO _ -> assert false
 416
 417     let rec value_to_query v =
 418       match v with
 419       | SmallList ((StringValue "AND") :: list)
 420       | List ((StringValue "AND") :: list) ->
 421           Q_AND (List.map value_to_query list)
 422
 423       | SmallList ((StringValue "OR") :: list)
 424       | List ((StringValue "OR") :: list) ->
 425           Q_OR (List.map value_to_query list)
 426
 427       | SmallList ((StringValue "HIDDEN") :: list)
 428       | List ((StringValue "HIDDEN") :: list) ->
 429           Q_HIDDEN (List.map value_to_query list)
 430
 431       | SmallList [StringValue "ANDNOT"; v1; v2 ]
 432       | List [StringValue "ANDNOT"; v1; v2 ] ->
 433           Q_ANDNOT (value_to_query v1, value_to_query v2)
 434
 435       | SmallList [StringValue "MODULE"; StringValue label; v2 ]
 436       | List [StringValue "MODULE"; StringValue label; v2 ] ->
 437           Q_MODULE (label, value_to_query v2)
 438
 439
 440
 441       | SmallList [StringValue "KEYWORDS"; StringValue label; StringValue s]
 442       | List [StringValue "KEYWORDS"; StringValue label; StringValue s] ->
 443           Q_KEYWORDS (label, s)
 444
 445       | SmallList [StringValue "MINSIZE"; StringValue label; StringValue s]
 446       | List [StringValue "MINSIZE"; StringValue label; StringValue s] ->
 447           Q_MINSIZE (label, s)
 448
 449       | SmallList [StringValue "MAXSIZE"; StringValue label; StringValue s]
 450       | List [StringValue "MAXSIZE"; StringValue label; StringValue s] ->
 451           Q_MAXSIZE (label, s)
 452
 453       | SmallList [StringValue "MINSIZE"; StringValue label; IntValue s]
 454       | List [StringValue "MINSIZE"; StringValue label; IntValue s] ->
 455           Q_MINSIZE (label, Int64.to_string s)
 456
 457       | SmallList [StringValue "MAXSIZE"; StringValue label; IntValue s]
 458       | List [StringValue "MAXSIZE"; StringValue label; IntValue s] ->
 459           Q_MAXSIZE (label, Int64.to_string s)
 460
 461       | SmallList [StringValue "FORMAT"; StringValue label; StringValue s]
 462       | List [StringValue "FORMAT"; StringValue label; StringValue s] ->
 463           Q_FORMAT (label, s)
 464
 465       | SmallList [StringValue "MEDIA"; StringValue label; StringValue s]
 466       | List [StringValue "MEDIA"; StringValue label; StringValue s] ->
 467           Q_MEDIA (label, s)
 468
 469       | SmallList [StringValue "MP3_ARTIST"; StringValue label; StringValue s]
 470       | List [StringValue "MP3_ARTIST"; StringValue label; StringValue s] ->
 471           Q_MP3_ARTIST (label, s)
 472
 473       | SmallList [StringValue "MP3_TITLE"; StringValue label; StringValue s]
 474       | List [StringValue "MP3_TITLE"; StringValue label; StringValue s] ->
 475           Q_MP3_TITLE (label, s)
 476
 477       | SmallList [StringValue "MP3_ALBUM"; StringValue label; StringValue s]
 478       | List [StringValue "MP3_ALBUM"; StringValue label; StringValue s] ->
 479           Q_MP3_ALBUM (label, s)
 480
 481       | SmallList [StringValue "MP3_BITRATE"; StringValue label; StringValue s]
 482       | List [StringValue "MP3_BITRATE"; StringValue label; StringValue s] ->
 483           Q_MP3_BITRATE (label, s)
 484
 485       | SmallList [StringValue "MP3_BITRATE"; StringValue label; IntValue s]
 486       | List [StringValue "MP3_BITRATE"; StringValue label; IntValue s] ->
 487           Q_MP3_BITRATE (label, Int64.to_string s)
 488
 489       | _ -> failwith (Printf.sprintf "Query option: error while parsing %s"
 490               (string_of_option  v)
 491           )
 492
 493     let t = define_option_class "Query" value_to_query query_to_value
 494   end
 495
 496 let searches_section = file_section searches_ini [] ""
 497
 498 let max_saved_searches = define_option searches_section
 499     ["max_saved_searches"] "Maximal number of saved searches"
 500     int_option 10
 501
 502 let customized_queries = define_option searches_section
 503   ["customized_queries"] ""
 504     (list_option (tuple2_option (string_option, QueryOption.t)))
 505   [
 506     "Complex Search",
 507     Q_AND [
 508       Q_KEYWORDS ("keywords", "");
 509       Q_MODULE ("Simple Options",
 510         Q_AND [
 511           Q_MINSIZE ("Min Size", "");
 512           Q_MAXSIZE ("Max Size", "");
 513           Q_MEDIA ("Media", "");
 514           Q_FORMAT ("Format", "");
 515         ];
 516       );
 517       Q_MODULE ("Mp3 Options",
 518         Q_AND [
 519           Q_MP3_ARTIST ("Artist", "");
 520           Q_MP3_ALBUM ("Album", "");
 521           Q_MP3_TITLE ("Title", "");
 522           Q_MP3_BITRATE ("Min Bitrate", "");
 523         ]
 524       );
 525     ];
 526     "MP3 Search",
 527     Q_AND [
 528       Q_KEYWORDS ("keywords", "");
 529       Q_MP3_ARTIST ("Artist", "");
 530       Q_MP3_ALBUM ("Album", "");
 531       Q_MP3_TITLE ("Title", "");
 532       Q_MP3_BITRATE ("Min Bitrate", "");
 533       Q_HIDDEN [
 534         Q_MEDIA ("Media", "Audio");
 535         Q_FORMAT ("Format", "mp3");
 536       ]
 537     ];
 538     "Movie Search",
 539     Q_AND [
 540       Q_KEYWORDS ("keywords", "");
 541       Q_HIDDEN [
 542         Q_MINSIZE ("Min Size", "500000000");
 543         Q_MEDIA ("Media", "Video");
 544         Q_FORMAT ("Format", "avi");
 545       ]
 546     ];
 547     "Album Search",
 548     Q_AND [
 549       Q_KEYWORDS ("Keywords", "album");
 550       Q_HIDDEN [
 551         Q_ANDNOT (
 552           Q_MINSIZE ("Min Size", "30000000"),
 553           Q_FORMAT ("Format", "mp3")
 554         );
 555       ]
 556     ];
 557   ]
 558
 559 let special_queries = define_option searches_section
 560     ["special_queries"] "Shortcuts for special specialized searches"
 561     (list_option (tuple2_option (string_option, string_option)))
 562   [
 563     "-1cd", "-maxsize 735000000";
 564     "-movies", "avi -minsize 650000000 -1cd";
 565     "-mp3s", "mp3 -minsize 3000000 -maxsize 10000000";
 566     "-albums", "album -minsize 30000000 -maxsize 150000000";
 567     "-nosex", "-not xxx";
 568   ]
 569
 570 let customized_queries =
 571   let custom = ref None in
 572   fun () ->
 573     match !custom with
 574       Some cq -> cq
 575     | None ->
 576
 577         let rec intern q =
 578           match q with
 579           | Q_AND list -> Q_AND (List.map intern list)
 580           | Q_OR list -> Q_OR (List.map intern list)
 581           | Q_HIDDEN list -> Q_HIDDEN (List.map intern list)
 582           | Q_ANDNOT (q1,q2) -> Q_ANDNOT (intern q1, intern q2)
 583
 584           | Q_MP3_BITRATE (s, v) -> Q_MP3_BITRATE (_s s, v)
 585           | Q_MP3_ALBUM (s, v) -> Q_MP3_ALBUM (_s s, v)
 586           | Q_MP3_TITLE (s, v) -> Q_MP3_TITLE (_s s, v)
 587           | Q_MP3_ARTIST (s, v) -> Q_MP3_ARTIST (_s s, v)
 588
 589           | Q_COMBO (s, v, l) -> Q_COMBO (_s s, v, l)
 590
 591           | Q_MEDIA (s, v) -> Q_MEDIA (_s s, v)
 592           | Q_KEYWORDS (s, v) -> Q_KEYWORDS (_s s, v)
 593           | Q_MINSIZE (s, v) -> Q_MINSIZE (_s s, v)
 594           | Q_MAXSIZE (s, v) -> Q_MAXSIZE (_s s, v)
 595           | Q_FORMAT (s, v) -> Q_FORMAT (_s s, v)
 596
 597           | Q_MODULE (s,q) -> Q_MODULE (_s s, intern q)
 598         in
 599         let qs =
 600           (List.map (fun (s,v) ->
 601                 _s s, intern v) !!customized_queries)
 602         in
 603         custom := Some qs;
 604         qs
 605
 606
 607 (*************************************************************************)
 608 (*                                                                       *)
 609 (*                         CLIENTS                                       *)
 610 (*                                                                       *)
 611 (*************************************************************************)
 612
 613
 614 module ClientOption = struct
 615
 616     let value_to_client is_friend v =
 617       match v with
 618         Options.Module assocs ->
 619           let get_value name conv = conv (List.assoc name assocs) in
 620           let network = try
 621               get_value "client_network" value_to_string
 622             with _ -> "Donkey"
 623           in
 624           let network = network_find_by_name network in
 625           let c = network_client_of_option network is_friend assocs in
 626           c
 627       | _ -> assert false
 628
 629     let client_to_value client =
 630       Options.Module (
 631         ("client_network", string_to_value (client_network client).network_name)
 632         ::
 633         (client_to_option client)
 634       )
 635
 636     let t is_friend =
 637       define_option_class "Client" (value_to_client is_friend)
 638       client_to_value
 639     ;;
 640   end
 641
 642 let friends_section = file_section friends_ini [] ""
 643 let friends =
 644   define_option friends_section ["friends"]
 645     "The list of known friends" (listiter_option (ClientOption.t true)) []
 646
 647
 648 let contacts = ref []
 649
 650
 651 (*************************************************************************)
 652 (*                                                                       *)
 653 (*                         SHARING                                       *)
 654 (*                                                                       *)
 655 (*************************************************************************)
 656
 657 module SharingOption = struct
 658
 659     let value_to_sharing v =
 660       match v with
 661       | Module assocs -> begin
 662             let get_value name conv default =
 663               try conv (List.assoc name assocs)
 664               with _ -> default
 665             in
 666             let get_bool_value name =  get_value name value_to_bool false in
 667             let sharing_recursive = get_bool_value "recursive" in
 668             let sharing_minsize = get_value "minsize" value_to_int64 zero
 669             in
 670             let sharing_maxsize = get_value "maxsize" value_to_int64
 671               Int64.max_int
 672             in
 673             let sharing_extensions = get_value "extensions"
 674                 (value_to_list value_to_string) []
 675             in
 676             let sharing_directories = get_bool_value "directories" in
 677             let sharing_incoming = get_bool_value "incoming" in
 678             {
 679               sharing_directories = sharing_directories;
 680               sharing_incoming = sharing_incoming;
 681               sharing_recursive = sharing_recursive;
 682               sharing_minsize = sharing_minsize;
 683               sharing_maxsize = sharing_maxsize;
 684               sharing_extensions = sharing_extensions;
 685             }
 686           end
 687       | _ -> assert false
 688
 689     let sharing_to_value s =
 690       let assocs = [
 691           "extensions",
 692           list_to_value string_to_value s.sharing_extensions;
 693           "minsize", int64_to_value s.sharing_minsize;
 694           "maxsize", int64_to_value s.sharing_maxsize;
 695         ]
 696       in
 697       let add_bool_value name v assocs =
 698         if v then
 699           (name , bool_to_value v) :: assocs
 700         else assocs
 701       in
 702       let assocs = add_bool_value "directories" s.sharing_directories assocs in
 703       let assocs = add_bool_value "incoming" s.sharing_incoming assocs in
 704       let assocs = add_bool_value "recursive" s.sharing_recursive assocs in
 705
 706       Options.Module assocs
 707
 708     let t =
 709       define_option_class "Sharing" value_to_sharing
 710         sharing_to_value
 711
 712   end
 713
 714 let sharing_only_directory = {
 715     sharing_incoming = false;
 716     sharing_directories = false;
 717     sharing_extensions = [];
 718     sharing_recursive = false;
 719     sharing_minsize = zero;
 720     sharing_maxsize = Int64.max_int;
 721   }
 722
 723 let sharing_incoming_directories = {
 724     sharing_incoming = true;
 725     sharing_directories = true;
 726     sharing_extensions = [];
 727     sharing_recursive = false;
 728     sharing_minsize = zero;
 729     sharing_maxsize = Int64.max_int;
 730   }
 731
 732 let sharing_incoming_files = {
 733     sharing_incoming = true;
 734     sharing_directories = false;
 735     sharing_extensions = [];
 736     sharing_recursive = true;
 737     sharing_minsize = zero;
 738     sharing_maxsize = Int64.max_int;
 739   }
 740
 741 let sharing_directories = {
 742       sharing_incoming = false;
 743       sharing_directories = true;
 744       sharing_extensions = [];
 745       sharing_recursive = false;
 746       sharing_minsize = zero;
 747       sharing_maxsize = Int64.max_int;
 748     }
 749
 750 let sharing_strategies = define_option searches_section
 751     ["customized_sharing"] ""
 752     (list_option (tuple2_option (string_option, SharingOption.t)))
 753   [
 754
 755 (* For mp3 sharers: recursively share all .mp3 files < 10 MB *)
 756     "mp3s", {
 757       sharing_incoming = false;
 758       sharing_directories = false;
 759
 760       sharing_extensions = [".mp3"];
 761       sharing_recursive = true;
 762       sharing_minsize = zero;
 763       sharing_maxsize = megabytes 10;
 764     };
 765
 766 (* For video sharers: recursively share all .avi files > 500 MB *)
 767     "avis", {
 768       sharing_incoming = false;
 769       sharing_directories = false;
 770       sharing_extensions = [".avi"];
 771       sharing_recursive = true;
 772       sharing_minsize = megabytes 500;
 773       sharing_maxsize = Int64.max_int;
 774     };
 775
 776     "all_files", {
 777       sharing_incoming = false;
 778       sharing_directories = false;
 779       sharing_extensions = [];
 780       sharing_recursive = true;
 781       sharing_minsize = zero;
 782       sharing_maxsize = Int64.max_int;
 783     };
 784
 785     "incoming_files",  sharing_incoming_files;
 786
 787     "incoming_directories", sharing_incoming_directories;
 788
 789 (* For incoming directory, share all files in the directory (not recursive) *)
 790     "only_directory", sharing_only_directory;
 791
 792     "directories", sharing_directories;
 793   ]
 794
 795 let _ =
 796   option_hook sharing_strategies (fun _ ->
 797
 798       if not (List.exists
 799             (fun (_,s) -> s.sharing_incoming && s.sharing_directories)
 800           !!sharing_strategies) then
 801         sharing_strategies =:=
 802           ("incoming_directories", sharing_incoming_directories) ::
 803         !!sharing_strategies;
 804
 805       if not (List.exists
 806             (fun (_,s) -> s.sharing_incoming && not s.sharing_directories)
 807           !!sharing_strategies) then
 808         sharing_strategies =:=
 809           ("incoming_files", sharing_incoming_files) :: !!sharing_strategies;
 810
 811   )
 812
 813 let sharing_strategy name =
 814   match name with
 815   | "incoming_files" -> sharing_incoming_files
 816   | "incoming_directories" -> sharing_incoming_directories
 817   | "only_directory" -> sharing_only_directory
 818   | "directories" -> sharing_directories
 819   | _ ->
 820       try
 821         List.assoc name !!sharing_strategies
 822       with _ -> sharing_only_directory
 823
 824 (*************************************************************************)
 825 (*                                                                       *)
 826 (*                         SHARED                                        *)
 827 (*                                                                       *)
 828 (*************************************************************************)
 829
 830 module SharedDirectoryOption = struct
 831
 832     let value_to_shared_directory v =
 833       match v with
 834       | Module assocs -> begin
 835             let get_value name conv =  conv (List.assoc name assocs)
 836             in
 837             let get_value_safe name conv default =
 838               try conv (List.assoc name assocs)
 839               with _ -> default
 840             in
 841             let shdir_dirname = get_value "dirname" value_to_filename
 842             in
 843             let shdir_priority = get_value_safe "priority" value_to_int 0
 844             in
 845 (*
 846             let shdir_networks = get_value_safe "networks"
 847                 (value_to_list value_to_string) []
 848             in
 849 *)
 850             let shdir_strategy = get_value_safe "strategy"
 851                 value_to_string "only_directory"
 852             in
 853             {
 854               shdir_dirname = shdir_dirname;
 855               shdir_strategy = shdir_strategy;
 856               shdir_networks = []; (* shdir_networks; *)
 857               shdir_priority = shdir_priority;
 858             }
 859           end
 860
 861       | SmallList [dir; prio]
 862       | List [dir; prio] ->
 863           {
 864             shdir_dirname = value_to_filename dir;
 865             shdir_strategy = "only_directory";
 866             shdir_networks = [];
 867             shdir_priority = value_to_int prio;
 868           }
 869       | v ->
 870           let dir = value_to_string v in
 871           let prio = 0 in
 872           {
 873             shdir_dirname = dir;
 874             shdir_strategy = "only_directory";
 875             shdir_networks = [];
 876             shdir_priority = prio;
 877           }
 878
 879     let shared_directory_to_value s =
 880       let list = [
 881           "dirname", filename_to_value s.shdir_dirname;
 882 (*
 883           "networks",
 884           list_to_value string_to_value s.shdir_networks;
 885 *)
 886           "strategy",
 887           string_to_value  s.shdir_strategy;
 888           "priority", int_to_value s.shdir_priority;
 889         ]
 890       in
 891       Options.Module list
 892
 893     let t =
 894       define_option_class "Shared Directory" value_to_shared_directory
 895         shared_directory_to_value
 896
 897   end
 898
 899 let default_incoming_files = {
 900   shdir_dirname = Filename.concat "incoming" "files";
 901   shdir_priority = 0;
 902   shdir_networks = [];
 903   shdir_strategy = "incoming_files";
 904   }
 905
 906 let default_incoming_directories = {
 907   shdir_dirname = Filename.concat "incoming" "directories";
 908   shdir_priority = 0;
 909   shdir_networks = [];
 910   shdir_strategy = "incoming_directories";
 911   }
 912
 913 let shared_directories =
 914   define_option CommonOptions.path_section ["shared_directories" ]
 915   "                Incoming and shared directories.
 916    At least two entries have to be present here, one with strategy
 917    incoming_files and one with strategy incoming_directories.
 918    Both entries can point to the same directory.
 919    If one of the two strategies is missing, MLDonkey will create a default
 920    directory with its entry here.
 921    Finished BT multifile downloads are committed to the first directory
 922    with strategy incoming_directories. Other downloads are committed
 923    to the first directory with the strategy incoming_files.
 924    MLdonkey searches all shared_directories with incoming_* strategies
 925    on commit and uses the first one with enough free diskspace.
 926    Other strategies can be found in searches.ini, section customized_sharing."
 927     (list_option SharedDirectoryOption.t)
 928   [
 929     {
 930       shdir_dirname = "shared";
 931       shdir_priority = 0;
 932       shdir_networks = [];
 933       shdir_strategy = "all_files";
 934     };
 935     default_incoming_files;
 936     default_incoming_directories;
 937   ]
 938
 939
 940 let search_incoming_files () =
 941   let list =
 942     List.filter (fun s -> s.shdir_strategy = "incoming_files") !!shared_directories
 943   in
 944   match list with
 945   | [] -> shared_directories =:= default_incoming_files :: !!shared_directories;
 946         [default_incoming_files]
 947   | l -> l
 948
 949 let search_incoming_directories () =
 950   let list =
 951     List.filter (fun s -> s.shdir_strategy = "incoming_directories") !!shared_directories
 952   in
 953   match list with
 954   | [] -> shared_directories =:= default_incoming_directories :: !!shared_directories;
 955         [default_incoming_directories]
 956   | l -> l
 957
 958 let shared_directories_including_user_commit () =
 959 (* This function is to be used in bTInteractive.try_share_file which is not recursive.
 960    Its a replacement for !!shared_directories and provides the same list, but with
 961    sub-directories added based on user_commit_dir.
 962    This function works without disc access to avoid overhead. *)
 963   let list = ref [] in
 964   List.iter (fun s ->
 965     let user_commit_dir_list = ref [] in
 966     if (sharing_strategy s.shdir_strategy).sharing_incoming then
 967       begin
 968         user2_users_iter (fun u ->
 969           if u.user_commit_dir <> "" then
 970             user_commit_dir_list := !user_commit_dir_list @
 971               [{
 972                 shdir_dirname = Filename.concat s.shdir_dirname u.user_commit_dir;
 973                 shdir_priority = s.shdir_priority;
 974                 shdir_networks = s.shdir_networks;
 975                 shdir_strategy = s.shdir_strategy;
 976               }]
 977         )
 978       end;
 979     list := !list @ [s] @ !user_commit_dir_list
 980   ) !!shared_directories;
 981   !list
 982
 983 let incoming_dir usedir ?user ?needed_space ?network () =
 984
 985   let directories =
 986     if usedir then
 987       search_incoming_directories ()
 988     else
 989       search_incoming_files ()
 990   in
 991
 992   let dirname_user =
 993     match user with
 994     | None -> ""
 995     | Some user -> user.user_commit_dir
 996   in
 997
 998 (*
 999   let dirname_network =
1000     match network with
1001     | None -> ""
1002     | Some network -> network
1003   in
1004 *)
1005 (* todo: make the dir naming order user configurable *)
1006   let compute_dir_name dir =
1007     let dirname = Filename2.normalize (Filename.concat dir dirname_user) in
1008 (*    let dirname = Filename.concat dirname dirname_network in *)
1009     dirname
1010   in
1011
1012   let checkdir =
1013     let module U = Unix.LargeFile in
1014     try
1015       List.find (fun d ->
1016         let dirname = compute_dir_name d.shdir_dirname in
1017 (* check if temp_directory and incoming are on different partitions *)
1018         try
1019           if (U.stat dirname).U.st_dev <> (U.stat !!temp_directory).U.st_dev then
1020             begin
1021               match needed_space with
1022               | None -> true
1023               | Some needed_space ->
1024                   match Unix32.diskfree dirname with
1025                     Some v -> v >= needed_space
1026                   | _ -> true
1027             end
1028           else true
1029         with _ -> true
1030         ) directories
1031     with Not_found -> raise Incoming_full;
1032   in
1033
1034   let newdir = {
1035       shdir_dirname = (compute_dir_name checkdir.shdir_dirname);
1036       shdir_priority = checkdir.shdir_priority;
1037       shdir_networks = checkdir.shdir_networks;
1038       shdir_strategy = checkdir.shdir_strategy;
1039     }
1040   in
1041   Unix2.safe_mkdir newdir.shdir_dirname;
1042   Unix2.can_write_to_directory newdir.shdir_dirname;
1043   newdir
1044
1045
1046 let _ =
1047 (* Check the definition of the incoming_files and incoming_directories in
1048 shared_directories *)
1049   let verification = ref false in
1050   option_hook shared_directories (fun _ ->
1051       if not !verification then begin
1052           verification := true;
1053           ignore (incoming_dir false ());
1054           ignore (incoming_dir true ());
1055           verification := false
1056         end
1057   )
1058
1059
1060 (*************************************************************************)
1061 (*                                                                       *)
1062 (*                         Functions                                     *)
1063 (*                                                                       *)
1064 (*************************************************************************)
1065
1066 let load () =
1067   Options.load files_ini;
1068   shorten_all_file_filenames !!max_filenames;
1069   Options.load servers_ini;
1070   Options.load searches_ini;
1071   Options.load results_ini;
1072   results =:= [];
1073   List.iter (fun (uid, time) ->
1074       Hashtbl.add CommonResult.known_uids (Uid.to_uid uid) time;
1075   ) !!known_uids;
1076   known_uids =:= [];
1077   Options.load friends_ini
1078
1079 let allow_saving_ini_files = ref true
1080
1081 let save () =
1082   if !allow_saving_ini_files then begin
1083   networks_iter (fun n -> network_save_complex_options n);
1084
1085   Options.save_with_help files_ini;
1086   Options.save_with_help searches_ini;
1087   Options.save_with_help friends_ini;
1088   Options.save_with_help servers_ini;
1089   begin
1090     match !!save_results with
1091     | 0 -> ()
1092     | 1 ->
1093         Hashtbl.iter (fun uid time ->
1094             let uid = Uid.create uid in
1095             known_uids =:= (uid, time) :: !!known_uids;
1096         ) CommonResult.known_uids;
1097         Options.save_with_help results_ini;
1098         known_uids =:= [];
1099     | _ ->
1100         CommonResult.results_iter (fun _ rs -> results =:= rs :: !!results);
1101         Options.save_with_help results_ini;
1102         results =:= [];
1103     end;
1104   lprintf_nl (_b "Options correctly saved")
1105   end
1106
1107 let save_sources () =
1108   if !allow_saving_ini_files then begin
1109   networks_iter (fun n -> network_save_sources n);
1110   lprintf_nl (_b "Sources correctly saved")
1111   end
1112
1113 open Zip
1114
1115 let backup_zip archive files =
1116   try
1117     Unix2.tryopen_umask 0o066 (fun _old_umask ->
1118       Unix2.tryopen_write_zip archive (fun oc ->
1119         List.iter (fun file -> try
1120           let module U = Unix.LargeFile in
1121           let s = U.stat file in
1122           Zip.copy_file_to_entry file oc ~level:9 ~mtime:s.U.st_mtime file
1123         with e ->
1124           failwith (Printf.sprintf "Zip: error %s in %s" (Printexc2.to_string e) file)
1125       ) files))
1126   with e ->
1127     failwith (Printf.sprintf "Zip: error %s in %s" (Printexc2.to_string e) archive)
1128
1129 open Tar
1130
1131 let backup_tar archive files =
1132   let failed_files = ref [] in
1133   Unix2.tryopen_umask 0o066 (fun _old_umask ->
1134     Unix2.tryopen_write_tar ~compress:`Gzip archive (fun otar ->
1135       List.iter (fun arg -> try
1136         let header, s =
1137           Unix2.tryopen_read_bin arg (fun ic ->
1138             let stat = Unix.stat arg in
1139             let size = stat.Unix.st_size in
1140             if size > Sys.max_string_length then
1141               failwith (Printf.sprintf
1142                   "Tar: file %s too big, system limit %d byte, use .zip to avoid this limit"
1143                     arg Sys.max_string_length);
1144             let header =
1145               { Tar.t_name = arg;
1146               t_mode = stat.Unix.st_perm;
1147               t_uid = stat.Unix.st_uid;
1148               t_gid = stat.Unix.st_gid;
1149               t_size = stat.Unix.st_size;
1150               t_mtime = Int32.of_float stat.Unix.st_mtime;
1151               t_chksum = 0;
1152               t_typeflag = REGULAR;
1153               t_linkname = "";
1154               t_format = POSIX_FORMAT;
1155               t_uname = "";
1156               t_gname = "";
1157               t_devmajor = 0;
1158               t_devminor = 0;
1159               t_prefix = "";
1160               t_gnu = None;} in
1161             let s = String.create size in
1162             Pervasives.really_input ic s 0 size;
1163             header, s) in
1164         Tar.output otar header s
1165       with
1166       | e ->
1167           failed_files := arg :: !failed_files;
1168           lprintf_nl "Tar: skipping %s, error %s" arg (Printexc2.to_string e)
1169       ) files
1170     )
1171   );
1172   if !failed_files <> [] then
1173     failwith (Printf.sprintf "Tar: skipped %s due to backup errors"
1174       (String.concat " " (List.rev !failed_files)))
1175
1176 let backup_options () =
1177   let counter = ref 1 in
1178   let backup_prefix = "backup-" in
1179   let old_backups = List.rev (List.sort (fun o -> compare o)
1180     (List.filter (fun o -> (
1181         String.lowercase (Filename2.extension o) = ".tar.gz"
1182         || String.lowercase (Filename2.extension o) = ".zip")
1183           && String.sub o 0 (String.length backup_prefix) = backup_prefix)
1184     (Unix2.list_directory "old_config")))
1185   in
1186   List.iter (fun s ->
1187     incr counter;
1188     if !counter > !!backup_options_generations then
1189         Sys.remove (Filename.concat "old_config" s)
1190     ) old_backups;
1191   let format =
1192     begin
1193       match !!backup_options_format with
1194         "zip" -> ".zip"
1195       | _ -> ".tar.gz"
1196     end
1197   in
1198   begin
1199     try
1200       let archive =
1201         Filename.concat "old_config" (backup_prefix ^ Date.reverse (Unix.time ()) ^ format)
1202       in
1203       let files =
1204         List.sort (fun o -> compare o) (List.filter (fun o ->
1205           String.lowercase (Filename2.last_extension o) = ".ini"
1206           && o <> "file_sources.ini")
1207             (Unix2.list_directory file_basedir))
1208       in
1209       begin
1210         match (Filename2.last_extension archive) with
1211           ".zip" -> backup_zip archive files
1212         | _ -> backup_tar archive files
1213       end
1214     with e -> lprintf_nl "Exception %s while options backup" (Printexc2.to_string e)
1215   end;
1216   lprintf_nl (_b "Options backup as %s correctly saved") format
1217
1218 let _ =
1219   CommonBlocking.add_update_hook CommonServer.check_blocked_servers;
1220   CommonBlocking.add_update_hook CommonServer.server_must_update_all;
1221   option_hook ip_blocking (fun _ ->
1222     try
1223       CommonBlocking.set_ip_blocking_list !!ip_blocking
1224     with _ -> ()
1225   );
1226   option_hook ip_blocking_countries (fun _ ->
1227     CommonBlocking.set_ip_blocking_countries !!ip_blocking_countries
1228   );
1229   option_hook ip_blocking_countries_block (fun _ ->
1230     CommonBlocking.set_ip_blocking_countries_block !!ip_blocking_countries_block;
1231     CommonBlocking.set_ip_blocking_countries !!ip_blocking_countries
1232   );
1233   option_hook geoip_dat (fun _ ->
1234     try
1235       CommonBlocking.set_geoip_dat !!geoip_dat
1236     with _ -> ()
1237   );
1238   option_hook max_filenames (fun _ ->
1239     shorten_all_file_filenames !!max_filenames
1240   );
1241
1242   option_hook max_upload_slots (fun _ ->
1243       if !!max_upload_slots < 3 then
1244         max_upload_slots =:= 3;
1245       networks_iter (fun n -> network_check_upload_slots n)
1246     );
1247
1248   let max_opened_connections_pass = ref 0 in
1249   option_hook max_opened_connections (fun _ ->
1250
1251   incr max_opened_connections_pass;
1252
1253 (* let users see if the option is called again *)
1254   let lprintf_nl s = lprintf_nl2
1255       (Printf.sprintf "%s pass %d:" log_prefix !max_opened_connections_pass) s in
1256
1257   if !verbose then lprintf_nl
1258     "checking max_opened_connections = %d for validity" !!max_opened_connections;
1259
1260 (* maximum value of open sockets/files allowed *)
1261   let max_all_fds = Unix2.c_getdtablesize () in
1262
1263 (* ini files, dynamic libs, etc. *)
1264   let reserved_fds = max CommonOptions.min_reserved_fds (max_all_fds / 50) in
1265
1266 (* minimum number of max_opened_connections, p2p needs some sockets *)
1267   let min_conns = CommonOptions.min_connections in
1268 (* max_conns *should* be greater than min_conns at that point, because of
1269    the sanity check at start time in CommonOptions;
1270    taking the max is just a safety belt from a paranoid :) *)
1271   let max_conns = max min_conns
1272     (max_all_fds - reserved_fds - Unix32.max_cache_size_default) in
1273
1274   let print_stats verbose =
1275     if verbose then begin
1276       lprintf_nl "file descriptors status: total allowed (ulimit -n) %d" max_all_fds;
1277       lprintf_nl "- max_opened_connections %d (%d%% indirect)"
1278         !!max_opened_connections !!max_indirect_connections;
1279       lprintf_nl "- file cache size %d" (Unix32.get_max_cache_size ());
1280       lprintf_nl "- reserved %d" reserved_fds;
1281       let s,v =
1282         let v1 =
1283           max_all_fds - !!max_opened_connections - (Unix32.get_max_cache_size ()) - reserved_fds
1284         in
1285         if v1 >= 0 then "left", v1 else "missing", (abs v1)
1286       in
1287       lprintf_nl "= %d descriptors %s" v s
1288     end
1289   in
1290
1291   if !!max_opened_connections < min_conns then begin
1292     lprintf_nl "max_opened_connections is set too low (%d), raising to %d"
1293       !!max_opened_connections min_conns;
1294     print_stats true;
1295     max_opened_connections =:= min_conns
1296   end
1297   else if !!max_opened_connections > max_conns then begin
1298     lprintf_nl "max_opened_connections is set too high (%d), lowering to %d"
1299       !!max_opened_connections max_conns;
1300     print_stats true;
1301     max_opened_connections =:= max_conns
1302   end
1303   else begin
1304     TcpBufferedSocket.set_max_opened_connections (fun _ -> !!max_opened_connections);
1305
1306     let unused_fds = max_conns - !!max_opened_connections in
1307
1308     Unix32.set_max_cache_size
1309       (Unix32.max_cache_size_default + unused_fds * 75 / 100);
1310
1311     calc_real_max_indirect_connections ();
1312
1313     print_stats !verbose
1314   end;
1315
1316   if !verbose then lprintf_nl "checking max_opened_connections finished";
1317   decr max_opened_connections_pass
1318 )
1319
1320 let _ =
1321   Heap.add_memstat "CommonComplexOptions" (fun level buf ->
1322       Printf.bprintf buf "  friends: %d\n" (List.length !!friends);
1323       Printf.bprintf buf "  contacts: %d\n" (List.length !contacts);
1324   )