(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2012 Johannes 'josch' Schauer <j.schauer@email.de>      *)
(*  Copyright (C) 2012 Pietro Abate <pietro.abate@pps.jussieu.fr>         *)
(*                                                                        *)
(*  This library is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version.  A special linking    *)
(*  exception to the GNU Lesser General Public License applies to this    *)
(*  library, see the COPYING file for more information.                   *)
(**************************************************************************)

open ExtLib
open Common
open Debian
open Algo

include Util.Logging(struct let label = __FILE__ end) ;;

module CudfSet = CudfAdd.Cudf_set

module Int = struct type t = int let compare = Pervasives.compare end
module IntSet = Set.Make(Int)
module StringSet = Set.Make(String)

module type Ot = sig
  val options :
    ?version:string ->
    ?suppress_usage:bool ->
    ?suppress_help:bool ->
    ?prog:string ->
    ?formatter:OptParse.Formatter.t -> unit -> OptParse.OptParser.t
end

module MakeOptions(O : Ot) = struct
  open OptParse ;;

  let verbose = StdOpt.incr_option ()
  let quiet = StdOpt.store_true ()
  let options = O.options ~version:"unreleased" () ;;

  open OptParser ;;

  add options ~short_name:'v' ~long_name:"verbose" ~help:"print additional information" verbose;
  add options ~long_name:"quiet" ~help:"do no print any messages" quiet;
end

(* get the name of a package *)
let string_of_package pkg = CudfAdd.decode pkg.Cudf.package;;

let string_of_list string_of_item sep l =
  let buf = Buffer.create 1023 in
  let rec aux = function
    | [] -> assert false
    | [last] -> (* last item, no trailing sep *)
        Buffer.add_string buf (string_of_item last)
    | item :: tl -> (* at least one item in tl *)
        Buffer.add_string buf (string_of_item item);
        Buffer.add_string buf sep;
        aux tl in
  let _ =
    match l with
      | [] -> ()
      | [sole] -> Buffer.add_string buf (string_of_item sole)
      | _ -> aux l in
  Buffer.contents buf
;;

let string_of_pkglist = string_of_list string_of_package ", ";;

(* check if a package is member of a package list *)
let pkg_list_mem l pkg =
  List.exists (fun p -> (CudfAdd.compare p pkg)=0) l
;;

let pkg_is_arch_all pkg =
  try (Cudf.lookup_package_property pkg "architecture") = "all"
  with Not_found -> false
;;

let pkg_is_not_arch_all pkg = not(pkg_is_arch_all pkg);;

let pkg_compare a b =
  let name_a = begin
    let decoded = CudfAdd.decode a.Cudf.package in
    try match String.split decoded ":" with
      |_,n -> n
    with ExtString.Invalid_string ->
      decoded
  end in
  let name_b = begin
    let decoded = CudfAdd.decode b.Cudf.package in
    try match String.split decoded ":" with
      |_,n -> n
    with ExtString.Invalid_string ->
      decoded
  end in
  let name_cmp = Pervasives.compare name_a name_b in
  if name_cmp <> 0 then
    name_cmp
  else begin
    let ver_cmp = Pervasives.compare a.Cudf.version b.Cudf.version in
    if ver_cmp <> 0 then
      ver_cmp
    else begin
      let arch_a = try
          Cudf.lookup_package_property a "architecture"
        with Not_found -> ""
      in
      let arch_b = try
          Cudf.lookup_package_property b "architecture"
        with Not_found -> ""
      in
      Pervasives.compare arch_a arch_b
    end
  end

(* sort a package list by their name/version/architecture *)
let pkg_sort pkgs = List.sort ~cmp:pkg_compare pkgs;;

(*
 * return each line of a textfile in a list
 * allow comments, empty lines and spaces in the textfile
 * *)
let read_linebased_file filename =
  let ic = open_in filename in
  (* remove everything after the # and strip whitespaces *)
  let process_line line = String.strip (
    try String.sub line 0 (String.index line '#')
    with Not_found -> line)
  in
  (* process each line and only keep the non-empty ones *)
  let result = List.filter
    (fun line -> String.length line > 0)
    (List.map process_line (Std.input_list ic))
  in
  close_in ic;
  result
;;

(* given one or more package lists, returns the unique union of them *)
let unique ll =
  CudfSet.elements (List.fold_left (fun acc l ->
    CudfSet.union acc (CudfAdd.to_set l)
  ) CudfSet.empty ll)
;;

let optimal_subset ?(global_constraints=true) ?(available=(fun _ -> true)) pkg univ closure =
  let globalid = Cudf.universe_size univ in
  (* if global constraints are to be enforced, then all essential packages are
   * added to the installation request *)
  let essential =
    if global_constraints then
      List.map
        (fun pkg -> (pkg.Cudf.package, Some (`Eq, pkg.Cudf.version)))
        (CudfAdd.latest (Cudf.get_packages
           ?filter:(Some (fun pkg -> pkg.keep = `Keep_package ))
           univ))
    else
      []
  in
  (* removes the globalid from the closure (if any) and adds the property
   * "notavailable" to all binary packages that satisfy the predicate function
   * "available" *)
  let cudf_closure = List.filter_map (fun i ->
      if i = globalid then
        None
      else begin
        let pkg = CudfAdd.inttovar univ i in
        if List.mem ("type", `String "src") pkg.Cudf.pkg_extra then
          Some pkg
        else begin
          let notavail = if available pkg then `Int 0 else `Int 1 in
          Some { pkg with Cudf.pkg_extra = ("notavailable", notavail) :: pkg.Cudf.pkg_extra }
        end
      end
    ) closure
  in
  (* create a cudf request with
   *  - all packages in the universe
   *  - the notavailable property in the preamble
   *  - the request to install the current package
   *  - to optimize first by minimum number of not-available packages in the
   *    solution and then by solution size *)
  let newuniverse = Cudf.load_universe cudf_closure in
  let preamble = Debcudf.preamble in
  let preamble = CudfAdd.add_properties preamble [("notavailable",(`Int (Some 0)))] in
  let request_pkgname = pkg.Cudf.package in
  let request = { Cudf.default_request
                  with Cudf.request_id = "";
                       Cudf.install = (request_pkgname, Some (`Eq, pkg.Cudf.version)) :: essential }
  in
  let criteria = "-sum(solution,notavailable),-count(solution)" in
  let cmd = "aspcud $in $out $pref" in
  try
    Depsolver.check_request ~cmd ~criteria (preamble,newuniverse,request)
  with e ->
    warning "exception when handling %s" pkg.Cudf.package;
    raise e
;;

(* split the installation set in a list of list of packages.
 * Each list is associated to a dependendency of the give package.
 * *)
(*
 * in case more than one package in a disjunction is part of the installation
 * set, it is sufficient to just pick any one package in the disjunction
 * because in the end it is not important that the union of all those choices
 * makes the original installation set but that the union of all these choices
 * creates any valid installation set. This is fulfilled by picking a valid
 * installation set for any single package in a disjunction.
 *
 *
 *)
let partition_deps ?(partition_optimizer=(fun p s -> s)) pool univ iss pkg =
  let to_set l = List.fold_right IntSet.add l IntSet.empty in
  let globalid = Cudf.universe_size univ in
  let l = List.map (fun vpkglist ->
    let l = CudfAdd.resolve_vpkgs_int univ vpkglist in
    let s = to_set l in
    let intrs = IntSet.inter iss s in
    if IntSet.cardinal intrs > 1 then
      debug "More then one package in the intersection";
    if not(IntSet.is_empty intrs) then begin
      let pid = IntSet.choose intrs in
      let dc = Depsolver_int.dependency_closure_cache pool [pid; globalid] in
      let dcs = to_set dc in
      (* calculate the intersection between the chosen installation set and the
       * dependency closure of pid *)
      let dcs = IntSet.inter iss dcs in
      (* pass the installation set to the optimizer *)
      let dcs = partition_optimizer pid dcs in
      (pid,dcs)
    end else
      fatal "the intersection between a dependency disjunction and the installation set must not be empty";
  ) pkg.Cudf.depends in
  l
;;

let compute_dependency_sets_opt ?(global_constraints=true) ?(partition=true) ?(available=(fun _ -> true)) opt_partition_cache pool univ srcpkg =
        (*info "%s" srcpkg.Cudf.package;*)
  let id = CudfAdd.vartoint univ srcpkg in
  let globalid = Cudf.universe_size univ in
  let closure = Depsolver_int.dependency_closure_cache pool [id; globalid] in
  (* given a package and an installation set, passes that set to a solver to
   * find a smaller set
   *
   * results are cached and retrieved from the cache if it has them
   * caching is useful because only a about a third of all installation sets is
   * unique. Thus, caching reduces runtime by about a factor of about three *)
  let partition_optimizer pid dcs =
    let cache_key = (pid, (IntSet.elements dcs)) in
    match Hashtbl.find_option opt_partition_cache cache_key with
    | Some is -> is
    | None -> begin
        let r = optimal_subset ~available (CudfAdd.inttovar univ pid) univ (IntSet.elements dcs) in
        let is = match r with
          |Algo.Depsolver.Error s -> fatal "%s" s;
          |Algo.Depsolver.Unsat _ -> fatal "this must not happen";
          |Algo.Depsolver.Sat (_,soluniv) ->
            Cudf.fold_packages (fun acc pkg ->
                IntSet.add (CudfAdd.vartoint univ pkg) acc
              ) IntSet.empty soluniv
        in
        Hashtbl.add opt_partition_cache cache_key is;
        is
      end
  in
  (* compute an optimal installation set for the given source package
   *
   * since there are no duplicate source packages, the results of this do not
   * have to be cached *)
  let r = optimal_subset ~global_constraints ~available srcpkg univ closure in
  begin match r with
    |Algo.Depsolver.Error s -> fatal "%s" s;
    |Algo.Depsolver.Unsat diagnosis -> begin
        if Util.Debug.is_enabled "BootstrapCommon" then begin match diagnosis with
          | None -> ()
          | Some diagnosis -> Diagnostic.fprintf ~explain:true ~failure:true Format.err_formatter diagnosis
        end;
        warning "source package %s cannot be compiled" (CudfAdd.string_of_package srcpkg);
        IntSet.empty, []
      end
    |Algo.Depsolver.Sat (_,soluniv) -> begin
        (* remove source package from installation set *)
        let iss = Cudf.fold_packages (fun acc pkg ->
            IntSet.add (CudfAdd.vartoint univ pkg) acc
          ) IntSet.empty soluniv
        in
        if partition then
          iss, (partition_deps ~partition_optimizer pool univ iss srcpkg)
        else
          iss, []
      end
  end
;;

(* compute_dependency_sets using low level integer interface *)
let compute_dependency_sets ?(global_constraints=true) ?(partition=true) custom_is_ht pool univ srcpkg =
  let id = CudfAdd.vartoint univ srcpkg in
  (* globalid is a fake package indentifier used to encode global
   * constraints in the universe *)
  let globalid = Cudf.universe_size univ in
  let closure = Depsolver_int.dependency_closure_cache pool [id; globalid] in
  let solver = Depsolver_int.init_solver_closure pool closure in
  let req =
    if global_constraints then
      Diagnostic_int.Sng (Some globalid,id)
    else
      Diagnostic_int.Sng (None,id)
  in
  let excludeset = Hashtbl.find_option custom_is_ht srcpkg.Cudf.package in
  let d = match excludeset with
    | Some es -> begin
        (* generate an installation set without one or more packages *)
        (* get ids to not include *)
        let excludelits = List.filter_map (fun pid ->
          if pid = id || pid = globalid then None
          else begin
            let pkg = CudfAdd.inttovar univ pid in
            if StringSet.mem pkg.Cudf.package es then
              Some (Depsolver_int.S.lit_of_var (solver.Depsolver_int.map#vartoint pid) false)
            else None
          end
        ) closure in
        match excludelits with
          | [] -> begin (* empty list. Solve normally *)
              warning "list of packages to exclude from the IS of %s is empty" (srcpkg.Cudf.package);
              Depsolver_int.solve solver req
            end
          | _ -> begin
              let solver = Depsolver_int.copy_solver solver in
              Depsolver_int.S.add_rule solver.Depsolver_int.constraints (Array.of_list excludelits) [];
              Depsolver_int.solve solver req
            end
      end
    | None -> (* generate an installation set normally *)
        Depsolver_int.solve solver req
  in
  match d with
  |Diagnostic_int.Success f_int -> begin
    (* remove source package and globalid from installation set *)
    let iss = List.fold_left (fun s i ->
      if i = globalid || i = id then s else IntSet.add i s
    ) IntSet.empty (f_int ()) in
    if partition then
      iss, (partition_deps pool univ iss srcpkg)
    else
      iss, []
  end
  | _ -> begin
      if Util.Debug.is_enabled "BootstrapCommon" then begin
        (*let result = Depsolver.diagnosis solver.Depsolver_int.map univ d req in*)
        Diagnostic.fprintf ~explain:true ~failure:true Format.err_formatter { Diagnostic.result = Depsolver.result solver.Depsolver_int.map univ d; request = Depsolver.request univ req }
      end;
      (* source package could not be compiled. If the installation set was chosen
       * manually, fail. Otherwise just throw a warning. *)
      match excludeset with
        | Some es -> failwith (Printf.sprintf "source package %s is not compilable after excluding %s" (srcpkg.Cudf.package) (String.concat "," (StringSet.elements es)))
        | None -> warning "source package %s cannot be compiled" (CudfAdd.string_of_package srcpkg);
    IntSet.empty, []
  end
;;

let get_custom_is_ht arch custom_is_files =
  let lines = List.fold_left (fun l f ->
    List.rev_append (read_linebased_file f) l
  ) [] custom_is_files in
  let custom_is_ht = Hashtbl.create (List.length lines) in
  List.iter (fun line ->
    match String.nsplit line " " with
      | hd::tl ->
          let bins = List.fold_left (fun acc d ->
            StringSet.add (CudfAdd.encode (arch^":"^d)) acc
          ) StringSet.empty tl in
          let oldbins = Hashtbl.find_default custom_is_ht (CudfAdd.encode hd) StringSet.empty in
          Hashtbl.replace custom_is_ht (CudfAdd.encode hd) (StringSet.union bins oldbins)
      | _ -> ();
  ) lines;
  custom_is_ht
;;

let get_reduced_deps_ht ?(weak_file="./droppable/weak-build-dependencies.list") remove_weak archs srcpkglist reduced_deps_files =
  let lines = List.fold_left (fun l f ->
    List.rev_append (read_linebased_file f) l
  ) [] reduced_deps_files in
  let reduced_deps_ht = Hashtbl.create (List.length lines) in
  List.iter (fun line ->
    match String.nsplit line " " with
      | hd::tl ->
          let deps = List.fold_left (fun acc d ->
            List.fold_left (fun a arch ->
              StringSet.add (CudfAdd.encode (arch^":"^d)) a
            ) acc archs
          ) StringSet.empty tl in
          let olddeps = Hashtbl.find_default reduced_deps_ht (CudfAdd.encode hd) StringSet.empty in
          Hashtbl.replace reduced_deps_ht (CudfAdd.encode hd) (StringSet.union deps olddeps)
      | _ -> ();
  ) lines;
  (* get the set of weak dependencies *)
  let weak_deps_set = if weak_file <> "" then begin
    List.fold_left (fun acc line ->
      List.fold_left (fun a arch ->
        StringSet.add (CudfAdd.encode (arch^":"^line)) a
      ) acc archs
    ) StringSet.empty (read_linebased_file weak_file)
  end else StringSet.empty in
  (* make the weak build dependencies a build profile of all source packages in
   * the graph *)
  if not (StringSet.is_empty weak_deps_set) && remove_weak then begin
    List.iter (fun pkg ->
      let value = Hashtbl.find_default reduced_deps_ht (pkg.Cudf.package) StringSet.empty in
      Hashtbl.replace reduced_deps_ht (pkg.Cudf.package) (StringSet.union value weak_deps_set)
    ) srcpkglist;
  end;
  reduced_deps_ht, weak_deps_set
;;

(* the >% operator was only introduced in libcudf >= 0.6.3 *)
let (>%) pkg1 pkg2 = Pervasives.compare (pkg2.Cudf.package, pkg2.Cudf.version) (pkg1.Cudf.package, pkg1.Cudf.version)

let get_src_package ?(allowmismatch=false) universe binpkg =
  try Sources.get_src_package universe binpkg
  with Sources.MismatchSrc sl -> begin (* names matches but version doesnt *)
    if allowmismatch then begin
      warning "binary package %s does not have an associated source package - falling back to highest version" (CudfAdd.string_of_package binpkg);
      List.hd (List.sort ~cmp:(>%) sl)
    end else
      raise Sources.NotfoundSrc
  end
;;

(* given a universe, return a hashtable mapping source packages to a list of
 * binary packages *)
let srcbin_table ?(available=CudfAdd.Cudf_set.empty) ?(allowmismatch=false) ?(ignoresrclessbin=false) universe =
  let h = CudfAdd.Cudf_hashtbl.create (Cudf.universe_size universe) in
  let aux binpkg =
    if CudfAdd.get_property "type" binpkg = "bin" then begin
      try
        let srcpkg = get_src_package ~allowmismatch universe binpkg in
        try let l = CudfAdd.Cudf_hashtbl.find h srcpkg in l := binpkg::!l
        with Not_found -> CudfAdd.Cudf_hashtbl.add h srcpkg (ref [binpkg])
      with Sources.NotfoundSrc ->
        (* No source was found for this binary. That's okay if this binary is
         * member of the available set *)
        if CudfAdd.Cudf_set.mem binpkg available then
          ()
        else
          (* it's also okay if the user requested to ignore source-less binaries *)
          if ignoresrclessbin then begin
            warning "binary package %s does not have an associated source package - ignoring" (CudfAdd.string_of_package binpkg);
            ()
          end else failwith (Printf.sprintf "can't find source package for binary package %s" (CudfAdd.string_of_package binpkg))
    end
  in
  Cudf.iter_packages aux universe ;
  h
;;

let get_bin_packages h srcpkg =
  try !(CudfAdd.Cudf_hashtbl.find h srcpkg)
  with Not_found ->
    warning "Source package %s is not associated to any binary package" (CudfAdd.string_of_package srcpkg);
    []
;;

let parse_packages ?(noindep=true) parse_cmdline build host foreign = function
  |[] | [_] -> fatal
    "You must provide a list of Debian Packages files and \
     a Debian Sources file"
  |l ->
      begin match List.rev l with
      |h::t ->
          let (fg,bg) = parse_cmdline (`Deb,false) [h] in
          let fgl = Sources.input_raw ~archs:[build] fg in
          let bgl = Sources.input_raw ~archs:[build] bg in
          let fgsrcl = Sources.sources2packages ~noindep build host fgl in
          let bgsrcl = Sources.sources2packages ~noindep build host bgl in
          let pkgl = Packages.input_raw ~archs:(build::host::foreign) t in
          (pkgl, (fgsrcl,bgsrcl), fgl)
      |_ -> assert false
      end
;;

let read_package_file ?(archs=[]) tocudf f =
  let l = Packages.input_raw ~archs [f] in
  List.fold_left (fun acc pkg ->
    let cudfpkg =
      try tocudf pkg
      with Not_found ->
        failwith (Printf.sprintf "cannot find cudf version for %s - do \
                  your foreground packages contain it?" (pkg.Packages.name));
    in
    CudfAdd.Cudf_set.add cudfpkg acc
  ) CudfAdd.Cudf_set.empty l
;;

let more_problems_callback printer universe results summary d =
  if summary then Diagnostic.collect results d ;
  match d with
  |{Diagnostic.result = Diagnostic.Failure (f) ; request = Diagnostic.Package r } -> begin
      let new_reasons = f () in
      List.iter (fun reason ->
          match reason with
          |Diagnostic.Conflict (i,j,vpkg) -> begin
              info "handling conflict between %s and %s because of %s"
                (CudfAdd.string_of_package i) (CudfAdd.string_of_package j)
                (Cudf_types_pp.string_of_vpkg vpkg);
              let filter k l = List.filter (fun (p,c) ->
                  let other = p=k.Cudf.package && Cudf.version_matches k.Cudf.version c in
                  let provides = List.exists (function
                      | n,None -> p=n
                      | n,Some (`Eq, version) ->
                        p=n && Cudf.version_matches version c
                    ) k.Cudf.provides
                  in
                  not other && not provides
                ) l.Cudf.conflicts in
              let new_i = { i with Cudf.conflicts = filter j i } in
              let new_j = { j with Cudf.conflicts = filter i j } in
              (* modify i to no longer contain the conflict vpkg *)
              let pkglist = Cudf.fold_packages (fun acc pkg ->
                  if Cudf.(=%) pkg i then      new_i::acc
                  else if Cudf.(=%) pkg j then new_j::acc
                  else pkg::acc
                ) [] !universe in
              universe := Cudf.load_universe pkglist;
            end
          |Diagnostic.Missing (i,vpkgs) -> begin
              info "handling missing dependency of %s on %s"
                (CudfAdd.string_of_package i)
                (Cudf_types_pp.string_of_vpkglist vpkgs);
              let new_i = {
                i with
                Cudf.depends = List.filter ((<>) vpkgs) i.Cudf.depends
              } in
              (* modify i to no longer contain the conflict vpkg *)
              let pkglist = Cudf.fold_packages (fun acc pkg ->
                  if Cudf.(=%) pkg i then new_i::acc
                  else pkg::acc
                ) [] !universe in
              universe := Cudf.load_universe pkglist;
            end
          |Diagnostic.Dependency _ -> () (* we ignore dependency paths *)
        ) new_reasons;
      printer d
    end
  |{Diagnostic.result = Diagnostic.Success _; request = Diagnostic.Package _} -> ()
  |{Diagnostic.request = Diagnostic.PackageList _} -> failwith "impossible #3"; (* we should only get single packages *)
;;
