(**************************************************************************************)
(*  Copyright (C) 2009 Pietro Abate <pietro.abate@pps.jussieu.fr>                     *)
(*  Copyright (C) 2009 Mancoosi Project                                               *)
(*                                                                                    *)
(*  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.                               *)
(**************************************************************************************)

(** Representation of a parsed source description item. all fields are string *)

open ExtLib
open Common

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

type source = {
  name : Packages_types.name;
  version : Packages_types.version;
  architecture : Packages_types.architecture list;
  binaries : string list ;
  build_depends : Packages_types.builddepsformula;
  build_depends_indep : Packages_types.builddepsformula;
  build_depends_arch : Packages_types.builddepsformula;
  build_conflicts : Packages_types.builddepslist;
  build_conflicts_indep : Packages_types.builddepslist;
  build_conflicts_arch : Packages_types.builddepslist;
}

let default_source = {
  name = "";
  version = "";
  architecture = [];
  binaries = [];
  build_depends = [];
  build_depends_indep = [];
  build_depends_arch = [];
  build_conflicts = [];
  build_conflicts_indep = [];
  build_conflicts_arch = [];
}

let parse_s = Packages.parse_s
let parse_name = Packages.parse_name
let parse_version = Packages.parse_version
let parse_builddepslist = Packages.lexbuf_wrapper Packages_parser.builddepslist_top
let parse_builddepsformula = Packages.lexbuf_wrapper Packages_parser.builddepsformula_top

let parse_architectures buildarchlist (_loc,s) =
  let matchsource sourcearchlist buildarchlist = 
    List.exists (fun arch ->
      List.exists(fun source ->
        Architecture.src_matches_arch source arch
      ) sourcearchlist
    ) buildarchlist
  in
  let sourcearchlist = Packages.lexbuf_wrapper Packages_parser.archlist_top (_loc,s) in
  if buildarchlist = [] then sourcearchlist
  else if matchsource sourcearchlist buildarchlist then sourcearchlist
  else raise (Packages.IgnorePackage "")
;;

(* Relationships between source and binary packages
 * http://www.debian.org/doc/debian-policy/ch-relationships.html
 * Build-Depends, Build-Depends-Indep, Build-Conflicts, Build-Conflicts-Indep
*)
let parse_package_stanza filter archs par =
  let parse_archs = parse_architectures archs in
  let parse_arch = Packages.lexbuf_wrapper Packages_parser.archlist_top in
  let p () = {
    name = parse_s ~err:"(MISSING NAME)" parse_name "Package" par;
    version = parse_s ~err:"(MISSING VERSION)" parse_version "Version" par;
    architecture = parse_s ~err:"(MISSING ARCH)" parse_archs "Architecture" par;
    binaries = [];
    build_depends = 
      parse_s ~opt:[] ~multi:true parse_builddepsformula "Build-Depends" par; 
    build_depends_indep =
      parse_s ~opt:[] ~multi:true parse_builddepsformula "Build-Depends-Indep" par;
    build_depends_arch =
      parse_s ~opt:[] ~multi:true parse_builddepsformula "Build-Depends-Arch" par;
    build_conflicts = 
      parse_s ~opt:[] ~multi:true parse_builddepslist "Build-Conflicts" par;
    build_conflicts_indep = 
      parse_s ~opt:[] ~multi:true parse_builddepslist "Build-Conflicts-Indep" par;
    build_conflicts_arch =
      parse_s ~opt:[] ~multi:true parse_builddepslist "Build-Conflicts-Arch" par
    }
  in
  try
    if Option.is_none filter then Some (p ())
    else if (Option.get filter) par then Some(p ()) 
    else None
  with Packages.IgnorePackage s -> begin
    let n = parse_s ~opt:"?" parse_name "Package" par in
    let v = parse_s ~opt:"?" parse_version "Version" par in
    let al = parse_s ~opt:[] parse_arch "Architecture" par in
    debug "Ignoring Source Package (%s,%s,%s) : %s" n v (String.concat "," al) s;
    None
  end
;;

(** parse a debian Sources file from channel *)
let parse_sources_in ?filter ?(archs=[]) fname ic =
  info "Parsing Sources file %s..." fname;
  let stanza_parser = parse_package_stanza filter archs in
  Format822.parse_from_ch (Packages.packages_parser fname stanza_parser []) ic
;;

(** parse a debian Sources file. 
 [~archs] determines which which architectures should be considered while
 parsing the Souces file. if ~arch is [] then all archs are cosidered *)
let input_raw ?filter ?(archs=[]) =
  let module Set = Set.Make(struct type t = source let compare = compare end) in
  let module M = Format822.RawInput(Set) in
  M.input_raw (parse_sources_in ?filter ~archs)
;;

let sep = ":" ;;

(* as per policy, if the first arch restriction contains a !
 * then we assume that all archs on the lists are bang-ed.
 * cf: http://www.debian.org/doc/debian-policy/ch-relationships.html 7.1 *)
let matcharch hostarch = function
  | [] -> true
  | ((true,_)::_) as al ->
    List.exists (fun (_,a) -> Architecture.src_matches_arch a hostarch) al
  | ((false,_)::_) as al ->
    List.for_all (fun (_,a) -> not(Architecture.src_matches_arch a hostarch)) al
;;

(* the nested build profiles formula is given in disjunctive normal form *)
let matchprofile profiles = function
  | [] -> true
  | ll -> List.exists (List.for_all (fun (c,p) -> c = (List.mem p profiles))) ll
;;

(* given archs, profile and a dependency with an architecture and profile list,
 * decide whether to select or drop that dependency *)
let select hostarch profiles (v,al,pl) =
  if matcharch hostarch al && matchprofile profiles pl then Some v else None
;;

(* the package name is encodes as src:<package-name> *)
let src2pkg ?(dropalternatives=false) ?(profiles=[]) ?(noindep=false) ?(src="src") buildarch hostarch srcpkg =
  let conflicts l = List.filter_map (select hostarch profiles) l in
  (* imitate sbuild behaviour and drop all alternatives except those that have
   * the same name as the first. Search for RESOLVE_ALTERNATIVES in
   * lib/Sbuild/ResolverBase.pm in the sbuild sources *)
  let dropalt l = match l with
    | [] -> []
    | [p] -> [p]
    | hd::tl -> List.filter (fun p -> fst p = fst hd) l
  in
  let depends ll =
    List.filter_map (fun l ->
        match List.filter_map (select hostarch profiles) l with
        |[] -> None
        |l -> Some (if dropalternatives then dropalt l else l)
      ) ll
  in
  let extras_profiles  = match profiles with [] -> [] | _ -> [("profiles", String.join " " profiles)] in
  let depends_indep   = if noindep then [] else srcpkg.build_depends_indep in
  let conflicts_indep = if noindep then [] else srcpkg.build_conflicts_indep in
  (* when crossbuilding (host != build), implicitly depend on build-essential
   * and crossbuild-essential-$hostarch. When compiling natively, implicitly
   * depend on build-essential *)
  let build_essential = if buildarch<>hostarch then
      [[(("build-essential", Some buildarch), None)];[(("crossbuild-essential-"^hostarch, Some buildarch), None)]]
    else
      [[(("build-essential", Some buildarch), None)]]
  in
  { Packages.default_package with
    Packages.name = src ^ sep ^ srcpkg.name ;
    source = (srcpkg.name, Some srcpkg.version);
    version = srcpkg.version;
    depends = build_essential @ (depends (depends_indep @ srcpkg.build_depends @ srcpkg.build_depends_arch));
    conflicts = conflicts (conflicts_indep @ srcpkg.build_conflicts @ srcpkg.build_conflicts_arch);
    architecture = String.concat "," srcpkg.architecture;
    extras = extras_profiles @ [("Type",src)]
  }
;;

(* given archs, profile and a dependency with an architecture and profile list,
 * decide whether to select or drop that dependency *)
(** transform a list of sources packages into dummy binary packages.
  * This function preserve the order *)
let sources2packages ?(dropalternatives=false) ?(profiles=[]) ?(noindep=false) ?(src="src") buildarch hostarch =
  List.map (src2pkg ~dropalternatives ~profiles ~noindep ~src buildarch hostarch)
;;


(** Check if a package is of "Type" source as encoded by the function sources2packages *)
let is_source ?(src="src") pkg = List.mem ("Type", src) pkg.Packages.extras;;

exception MismatchSrc of Cudf.package list
exception NotfoundSrc

(**
 [get_src_package universe binpkg] returns the source package associate
 with the given binary package.
 
 precondition : the package has "type" bin and the universe contains
 packages of "type" src encoded with sources2packages.
 
 Raise MismatchSrc if there exists a source package with the same name
 but with a different version . Raise NotfoundSrc if the univese does not
 contain either a source package associated with the binary package or
 a source package with the same name but different version.
*)
let get_src_package universe binpkg =
  let sn = CudfAdd.encode ("src:"^(CudfAdd.get_property "source" binpkg)) in
  let sv = int_of_string (CudfAdd.get_property "sourceversion" binpkg) in
  try Cudf.lookup_package universe (sn,sv)
  with Not_found -> begin
    let name = CudfAdd.decode sn in
    let number = CudfAdd.get_property "sourcenumber" binpkg in
    match Cudf.lookup_packages universe sn with
    |[] -> begin
        debug "Cannot find source package %s %s associated to the binary package %s"
        name number (CudfAdd.string_of_package binpkg);
        raise NotfoundSrc
    end
    |othersl -> begin
      let othersrcnumbers = 
        List.map (fun othersrc ->
          CudfAdd.get_property "number" othersrc
        ) othersl
      in
      debug "Cannot find source package %s %s associated to the binary package %s"
      name number (CudfAdd.string_of_package binpkg);
      debug "There exist other versions (%s) of the source package %s in the repository"
      (String.concat " , " othersrcnumbers) name;
      raise (MismatchSrc othersl)
    end
  end
;;

(** Returns an hash table that associates source packages (encoded by the
    function sources2packages) to binary packages in the universe. It is
    possible that a source package is not associated with any binary
    packages.
*)
let srcbin_table 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 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
      |NotfoundSrc -> () (* this binary is not associated to any src *)
      |MismatchSrc sl ->
          (* we add the src to the table, but we do not associate to any
             binary *)
        List.iter (fun srcpkg -> 
          if not(CudfAdd.Cudf_hashtbl.mem h srcpkg) then
            CudfAdd.Cudf_hashtbl.add h srcpkg (ref [])
        ) sl
    end
  in
  Cudf.iter_packages aux universe ;
  h
;;

(** Returns the list of binary packages associated to a package of "Type" source
    encoded by the function sources2packages. The table h associated each source
    with a list of binaries *)
let get_bin_packages h srcpkg =
  try !(CudfAdd.Cudf_hashtbl.find h srcpkg)
  with Not_found -> begin
    let sn = CudfAdd.decode srcpkg.Cudf.package in
    let sv = CudfAdd.get_property "number" srcpkg in
    debug "Source package %s %s not associated with any binary package" sn sv;
    raise Not_found
  end
;;

(** Returns the set of binary packages generated by the packages in srclist.
    The function get_bin_packages gets a source package and returns the set
    of packages associated to it. If the source package is not known, then
    it is ignored. *)
let binset get_bin_packages srclist =
  List.fold_left (fun acc srcpkg ->
    try CudfAdd.Cudf_set.union acc (CudfAdd.to_set (get_bin_packages srcpkg))
    with Not_found -> acc
  ) CudfAdd.Cudf_set.empty srclist
;;
