(**************************************************************************)
(*  Copyright © 2009-2013 Stéphane Glondu <steph@glondu.net>              *)
(*            © 2010-2013 Mehdi Dogguy <mehdi@dogguy.org>                 *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

open Ben
open Error
open Core
open Types

type frontend = {
  name : string;
  main : unit -> unit;
  anon_fun : string -> unit;
  help : (Arg.key * Arg.spec * Arg.doc) list;
}

let frontends = ref []
let current_frontend = ref None
let register_frontend sc = frontends := (sc.name, sc) :: !frontends

let get_frontend x =
  try List.assoc x !frontends with Not_found -> raise (Unknown_command x)

let get_selected_frontend () =
  match !current_frontend with
  | None -> Stdlib.raise (Arg.Help "No frontend selected!")
  | Some frontend -> frontend

let set_selected_frontend x = current_frontend := Some x
let available_frontends () = List.map fst !frontends

let fail fmt =
  Printf.ksprintf (fun x -> raise (Error_in_configuration_file x)) fmt

let to_string what = function
  | EString s -> s
  | _ -> fail "%s must be a string" what

let to_string_l what = function
  | EList ys ->
      List.map
        (function
          | EString s -> s | _ -> fail "%s must be a list of strings" what)
        ys
  | _ -> fail "%s must be a list of strings" what

let to_expr_l l =
  let of_string s = Types.EString s in
  Types.EList (List.map of_string l)

let read_config ?(multi = false) source =
  let config =
    match source with
    | File filename -> Utils.parse_config_file filename
    | Stdin -> Utils.parse_config_from_in_channel stdin
    | NoSource -> assert false
  in
  StringMap.fold
    (fun key value accu ->
      match (key, value) with
      | "mirror", x ->
          Clflags.mirror_binaries := to_string "mirror" x;
          Clflags.mirror_sources := to_string "mirror" x;
          StringMap.add key value accu
      | "mirror-binaries", x ->
          Clflags.mirror_binaries := to_string "mirror-binaries" x;
          StringMap.add key value accu
      | "mirror-sources", x ->
          Clflags.mirror_sources := to_string "mirror-sources" x;
          StringMap.add key value accu
      | "areas", x ->
          if multi then StringMap.add key value accu
          else
            let () = Clflags.areas := to_string_l key x in
            accu
      | "architectures", x ->
          if multi then StringMap.add key value accu
          else
            let () = Clflags.debian_architectures := to_string_l key x in
            accu
      | "suite", x ->
          if multi then StringMap.add key value accu
          else
            let () = Clflags.suite := to_string key x in
            accu
      | "cache-dir", x ->
          Clflags.cache_dir := to_string "cache-dir" x;
          StringMap.add key value accu
      | "cache-file", x ->
          let name = to_string "cache-file" x in
          Clflags.set_cache_file name;
          accu
      | "use-cache", Etrue ->
          Clflags.use_cache := true;
          StringMap.add key value accu
      | "more-binary-keys", x ->
          let new_keys =
            List.map String.lowercase_ascii (to_string_l "more-binary-keys" x)
          in
          Data.relevant_binary_keys :=
            StringSet.union
              (StringSet.from_list new_keys)
              !Data.relevant_binary_keys;
          accu
      | "more-source-keys", x ->
          let new_keys =
            List.map String.lowercase_ascii (to_string_l "more-source-keys" x)
          in
          Data.relevant_source_keys :=
            StringSet.union
              (StringSet.from_list new_keys)
              !Data.relevant_source_keys;
          accu
      | "preferred-compression-format", x ->
          let format = to_string "preferred-compression-format" x in
          if Compression.is_known format then
            Clflags.preferred_compression_format := Compression.of_string format
          else warn (Unknown_input_format format);
          StringMap.add key value accu
      | _ -> StringMap.add key value accu)
    config StringMap.empty

let read_ben_file filename =
  let config = read_config ~multi:true (File filename) in
  let default_values =
    [
      ("architectures", to_expr_l !Clflags.debian_architectures);
      ("ignored", to_expr_l !Clflags.ignored_architectures);
      ("areas", to_expr_l !Clflags.areas);
      ("suite", Types.EString !Clflags.suite);
    ]
  in
  List.fold_left
    (fun config (key, value) ->
      if not (StringMap.mem key config) then StringMap.add key value config
      else config)
    config default_values

let spec =
  ref
    (Arg.align
       [
         ( "--no-benrc",
           Arg.Clear Clflags.use_benrc,
           " Do not read .benrc file at startup" );
         ("--dry-run", Arg.Set Clflags.dry_run, " Dry run");
         ("-n", Arg.Set Clflags.dry_run, " Dry run");
         ("--parallel", Arg.Int Parallel.set_level, " Set parallelism level");
         ("-P", Arg.Int Parallel.set_level, " Set parallelism level");
         ("--quiet", Arg.Set Clflags.quiet, " Quiet mode");
         ("-q", Arg.Set Clflags.quiet, " Quiet mode");
         ("--verbose", Arg.Set Clflags.verbose, " Verbose mode");
         ("-v", Arg.Set Clflags.verbose, " Verbose mode");
         ( "--mirror",
           Arg.String
             (fun m ->
               Clflags.mirror_binaries := m;
               Clflags.mirror_sources := m),
           " Mirror to use" );
         ( "--mirror-binaries",
           Arg.String (fun m -> Clflags.mirror_binaries := m),
           " Mirror to use for binaries" );
         ( "--mirror-sources",
           Arg.String (fun m -> Clflags.mirror_sources := m),
           " Mirror to use for sources" );
         ( "--areas",
           Arg.String (fun a -> Clflags.areas := Core.simple_split ',' a),
           " Areas to consider" );
         ( "--archs",
           Arg.String
             (fun a -> Clflags.debian_architectures := Core.simple_split ',' a),
           " Architectures to consider" );
         ("--suite", Arg.Set_string Clflags.suite, " Suite");
         ( "--cache-dir",
           Arg.Set_string Clflags.cache_dir,
           " Path to cache directory" );
         ( "--config",
           Arg.String (fun c -> ignore (read_config (File c))),
           " Path to configuration file" );
         ( "-c",
           Arg.String (fun c -> ignore (read_config (File c))),
           " Path to configuration file" );
         ("--cache", Arg.String Clflags.set_cache_file, " Path to cache file");
         ("-C", Arg.String Clflags.set_cache_file, " Path to cache file");
         ( "--use-cache",
           Arg.Set Clflags.use_cache,
           " Enable use of cache file, if available" );
         ( "--more-binary-keys",
           Arg.String
             (fun x ->
               let new_keys =
                 List.map String.lowercase_ascii (Core.simple_split ',' x)
               in
               Data.relevant_binary_keys :=
                 StringSet.union
                   (StringSet.from_list new_keys)
                   !Data.relevant_binary_keys),
           " Further relevant binary keys" );
         ( "--more-source-keys",
           Arg.String
             (fun x ->
               let new_keys =
                 List.map String.lowercase_ascii (Core.simple_split ',' x)
               in
               Data.relevant_source_keys :=
                 StringSet.union
                   (StringSet.from_list new_keys)
                   !Data.relevant_source_keys),
           " Further relevant source keys" );
         ( "--preferred-compression-format",
           Arg.String
             (fun x ->
               if Compression.is_known x then
                 Clflags.preferred_compression_format := Compression.of_string x
               else warn (Unknown_input_format x)),
           " Preferred compression format" );
         ( "-z",
           Arg.String
             (fun x ->
               if Compression.is_known x then
                 Clflags.preferred_compression_format := Compression.of_string x
               else warn (Unknown_input_format x)),
           " Preferred compression format" );
         ( "-h",
           Arg.Unit
             (fun () -> Stdlib.raise (Arg.Help "Use -help or --help instead\n")),
           " Display this list of options" );
         ( "-V",
           Arg.Unit (fun () -> Clflags.show_version := true),
           " Display version number (and build date) and exists." );
         ( "--version",
           Arg.Set Clflags.show_version,
           " Display version number (and build date) and exists." );
       ])
