(**************************************************************************)
(*  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 Printf
open Ben
open Core
module M = Package.Map
module S = Package.Set

let use_projectb = ref false
let run_debcheck = ref false

open Modules
module Marshal = Marshal.Make (Marshallable)
open Marshallable

type origin = {
  get_binaries :
    Package.binary Package.t PAMap.t ->
    string ->
    Package.binary Package.t PAMap.t;
  get_sources :
    (Package.source, Package.source Package.t) M.t ->
    (Package.source, Package.source Package.t) M.t;
}

let default_relevant_binary_keys =
  StringSet.from_list
    [
      "package";
      "source";
      "version";
      "maintainer";
      "architecture";
      "provides";
      "depends";
      "pre-depends";
      "replaces";
      "multi-arch";
      "conflicts";
      "breaks";
      "suggests";
      "recommends";
      "enhances";
    ]

let default_relevant_source_keys =
  StringSet.from_list
    [
      "package";
      "source";
      "version";
      "maintainer";
      "architecture";
      "directory";
      "binary";
      "build-depends";
      "build-depends-indep";
      "build-depends-arch";
    ]

let relevant_binary_keys = ref default_relevant_binary_keys
let relevant_source_keys = ref default_relevant_source_keys
let ( // ) = Filename.concat
let ( !! ) = Lazy.force
let ( !!! ) = Package.Name.to_string

let file_origin =
  let get_binaries accu arch =
    Utils.parse_control_file Binary
      (!Clflags.cache_dir // ("Packages_" ^ arch))
      (fun x -> StringSet.mem x !relevant_binary_keys)
      (fun name pkg accu ->
        try
          let old_pkg = PAMap.find (name, arch) accu in
          let old_ver = Package.get "version" old_pkg in
          let ver = Package.get "version" pkg in
          if Debian_version.compare old_ver ver < 0 then
            PAMap.add (name, arch) pkg accu
          else accu
        with _ -> PAMap.add (name, arch) pkg accu)
      accu
  in
  let get_sources accu =
    Utils.parse_control_file Source
      (!Clflags.cache_dir // "Sources")
      (fun x -> StringSet.mem x !relevant_source_keys)
      (fun name pkg accu ->
        try
          let old_pkg = M.find name accu in
          let old_ver = Package.get "version" old_pkg in
          let ver = Package.get "version" pkg in
          if Debian_version.compare old_ver ver < 0 then M.add name pkg accu
          else accu
        with _ -> M.add name pkg accu)
      accu
  in
  { get_binaries; get_sources }

module Projectb = struct
  let mk_origin () =
    (* psql service=projectb must work, e.g. on
       mirror.ftp-master.debian.org. To make it work elsewhere, copy
       mirror.ftp-master.debian.org:/etc/postgresql-common/pg_service.conf
       to your ~/.pg_service.conf and set up tunnels accordingly. *)
    let projectb = new Postgresql.connection ~conninfo:"service=projectb" in
    let mk_wrapper_maps transform sql =
      let r = (projectb ())#exec sql in
      assert (r#status = Postgresql.Tuples_ok);
      Array.fold_left
        (fun (a, b) row ->
          match row with
          | [| key_id; key |] ->
              let key = transform key and key_id = int_of_string key_id in
              (IntMap.add key_id key a, StringMap.add key key_id b)
          | _ -> assert false)
        (IntMap.empty, StringMap.empty)
        r#get_all
    in
    let string_identity x = x in
    let mk_wrappers name (key_of_id_map, id_of_key_map) =
      ( (fun x ->
          try IntMap.find x key_of_id_map
          with Not_found -> ksprintf invalid_arg "%s_of_id(%d)" name x),
        fun x ->
          try StringMap.find x id_of_key_map
          with Not_found -> ksprintf invalid_arg "id_of_%s(%s)" name x )
    in
    let key_of_id, id_of_key =
      mk_wrappers "key"
        (mk_wrapper_maps String.lowercase_ascii
           "select key_id, key from metadata_keys")
    in
    let _, id_of_suite =
      mk_wrappers "suite"
        (mk_wrapper_maps string_identity "select id, suite_name from suite")
    in
    let _, id_of_arch =
      mk_wrappers "arch"
        (mk_wrapper_maps string_identity
           "select id, arch_string from architecture")
    in
    let relevant_binary_key_ids =
      List.map id_of_key (StringSet.elements !relevant_binary_keys)
    in
    let get_binaries accu arch =
      Clflags.progress "Querying projectb for %s binaries in unstable...\n" arch;
      let sql =
        sprintf
          "select b.bin_id, b.key_id, b.value from bin_associations as a join \
           (select * from binaries_metadata where key_id in (%s)) as b on \
           b.bin_id = a.bin join (select * from binaries) as c on c.id = a.bin \
           where a.suite = %d and c.architecture in (%d,%d)"
          (String.concat "," (List.map string_of_int relevant_binary_key_ids))
          (id_of_suite "unstable") (id_of_arch "all") (id_of_arch arch)
      in
      let r = (projectb ())#exec sql in
      assert (r#status = Postgresql.Tuples_ok);
      let id_indexed_map =
        Array.fold_left
          (fun a row ->
            match row with
            | [| src_id; key_id; value |] ->
                let src_id = int_of_string src_id
                and key_id = int_of_string key_id in
                let old =
                  try IntMap.find src_id a with Not_found -> Stanza.empty
                in
                let old = Stanza.add (key_of_id key_id) value old in
                IntMap.add src_id old a
            | _ -> assert false)
          IntMap.empty r#get_all
      in
      let result =
        IntMap.fold
          (fun _ assoc accu ->
            let pkg = Package.of_stanza Binary assoc in
            let name = Package.Name.of_string (Package.get "package" pkg) in
            let ver = Package.get "version" pkg in
            try
              let old_pkg = PAMap.find (name, arch) accu in
              let old_ver = Package.get "version" old_pkg in
              if Debian_version.compare old_ver ver < 0 then
                PAMap.add (name, arch) pkg accu
              else accu
            with Not_found -> PAMap.add (name, arch) pkg accu)
          id_indexed_map accu
      in
      result
    in
    let sources_in_testing =
      Clflags.progress "Querying projectb for sources in testing...\n";
      let sql =
        sprintf
          "select (select value from source_metadata as b where key_id = %d \
           and b.src_id = a.source) from src_associations as a where a.suite = \
           %d"
          (id_of_key "source") (id_of_suite "testing")
      in
      let r = (projectb ())#exec sql in
      assert (r#status = Postgresql.Tuples_ok);
      let result =
        Array.fold_left
          (fun a row ->
            match row with
            | [| source |] -> StringSet.add source a
            | _ -> assert false)
          StringSet.empty r#get_all
      in
      result
    in
    let relevant_source_key_ids =
      (* beware! key "directory" does not exist in projectb and is
         handled specifically below *)
      List.map id_of_key
        (List.filter
           (fun x -> x <> "directory")
           (StringSet.elements !relevant_source_keys))
    in
    let get_sources accu =
      Clflags.progress "Querying projectb for sources in unstable...\n";
      (* get general metadata *)
      let sql =
        sprintf
          "select b.src_id, b.key_id, b.value from src_associations as a join \
           (select * from source_metadata where key_id in (%s)) as b on \
           b.src_id = a.source where a.suite = %d"
          (String.concat "," (List.map string_of_int relevant_source_key_ids))
          (id_of_suite "unstable")
      in
      let r = (projectb ())#exec sql in
      assert (r#status = Postgresql.Tuples_ok);
      let id_indexed_map =
        Array.fold_left
          (fun a row ->
            match row with
            | [| src_id; key_id; value |] ->
                let src_id = int_of_string src_id
                and key_id = int_of_string key_id in
                let old =
                  try IntMap.find src_id a with Not_found -> Stanza.empty
                in
                let key = key_of_id key_id in
                (* translate "source" to "package" for consistency with
                   Sources files *)
                let key = if key = "source" then "package" else key in
                let old = Stanza.add (String.capitalize_ascii key) value old in
                IntMap.add src_id old a
            | _ -> assert false)
          IntMap.empty r#get_all
      in
      (* get .dsc paths to compute directories *)
      let sql =
        sprintf
          "select a.source, c.filename from src_associations as a join (select \
           * from dsc_files) as b on b.source = a.source, files as c where \
           a.suite = %d and b.file = c.id and c.filename like '%%dsc'"
          (id_of_suite "unstable")
      in
      let r = (projectb ())#exec sql in
      assert (r#status = Postgresql.Tuples_ok);
      let id_indexed_dscs =
        Array.fold_left
          (fun a row ->
            match row with
            | [| src_id; filename |] ->
                let src_id = int_of_string src_id in
                IntMap.add src_id filename a
            | _ -> assert false)
          IntMap.empty r#get_all
      in
      (* fake directory entry by merging id_indexed_{map,dscs} *)
      let id_indexed_map =
        IntMap.mapi
          (fun src_id pkg ->
            let directory =
              Filename.concat "pool"
                (Filename.dirname (IntMap.find src_id id_indexed_dscs))
            in
            Stanza.add "Directory" directory pkg)
          id_indexed_map
      in
      let result =
        IntMap.fold
          (fun _ assoc accu ->
            let pkg = Package.of_stanza Source assoc in
            let sname = Package.get "package" pkg in
            let is_in_testing =
              if StringSet.mem sname sources_in_testing then "yes" else "no"
            in
            let pkg = Package.add "is-in-testing" is_in_testing pkg in
            let name = Package.Name.of_string sname in
            let ver = Package.get "version" pkg in
            try
              let old_pkg = M.find name accu in
              let old_ver = Package.get "version" old_pkg in
              if Debian_version.compare old_ver ver < 0 then M.add name pkg accu
              else accu
            with Not_found -> M.add name pkg accu)
          id_indexed_map accu
      in
      result
    in
    { get_binaries; get_sources }
end

let filter_affected { src_map = srcs; bin_map = bins } is_affected config =
  let src_map =
    M.fold
      (fun name src accu ->
        if Query.eval_source src !!(is_affected config) then M.add name src accu
        else accu)
      srcs M.empty
  in
  let src_map, bin_map =
    PAMap.fold
      (fun (name, arch) pkg (saccu, baccu) ->
        let src_name = Package.get "source" pkg in
        let src_name = Package.Name.of_string src_name in
        try
          let src = M.find src_name srcs in
          if
            Query.eval_binary pkg !!(is_affected config)
            || Query.eval_source src !!(is_affected config)
          then (M.add src_name src saccu, PAMap.add (name, arch) pkg baccu)
          else (saccu, baccu)
        with Not_found -> (saccu, baccu))
      bins (src_map, PAMap.empty)
  in
  let bin_map =
    PAMap.fold
      (fun (name, arch) pkg accu ->
        let src_name = Package.get "source" pkg in
        let src_name = Package.Name.of_string src_name in
        if M.mem src_name src_map then PAMap.add (name, arch) pkg accu else accu)
      bins bin_map
  in
  { src_map; bin_map }

let read_debcheck =
  let rex = Re.Pcre.regexp "^  package: (.*)$" in
  let ignore = Re.Pcre.regexp "^ +(architecture|status|source): " in
  fun ic ->
    let check_empty accu =
      if Package.Map.is_empty accu then
        Printf.eprintf "W: no uninstallable packages!\n%!";
      accu
    in
    let reason buf =
      let r = ExtString.String.strip (Buffer.contents buf) in
      let () = Buffer.reset buf in
      r
    in
    let get_package_name p =
      let p = Re.Pcre.get_substring p 1 in
      try snd (ExtString.String.split p ":") with _ -> p
    in
    let rec read_pkg accu =
      match try Some (input_line ic) with End_of_file -> None with
      | None -> check_empty accu
      | Some line -> (
          try
            let r = Re.Pcre.exec ~rex line in
            let package = get_package_name r in
            let buf = Buffer.create 1024 in
            let () = Buffer.add_string buf line in
            let () = Buffer.add_char buf '\n' in
            read_reason (Package.Name.of_string package) accu buf
          with Not_found -> read_pkg accu)
    and read_reason pkg accu buf =
      match try Some (input_line ic) with End_of_file -> None with
      | None ->
          let accu = Package.Map.add pkg (reason buf) accu in
          read_pkg accu
      | Some line ->
          if line = " -" then
            let accu = Package.Map.add pkg (reason buf) accu in
            read_pkg accu
          else if Re.Pcre.pmatch ~rex:ignore line then read_reason pkg accu buf
          else
            let () = Buffer.add_string buf line in
            let () = Buffer.add_char buf '\n' in
            read_reason pkg accu buf
    in
    read_pkg Package.Map.empty

let inject_debcheck_data (bins : Package.binary Package.t PAMap.t) architectures
    =
  let a, b = if !Clflags.quiet then ("\n", "") else ("", "\n") in
  let all_uninstallable_packages =
    Parallel.fold
      (fun map arch_ref ->
        Clflags.progress "Running dose-debcheck on %s...\n" arch_ref;
        let dose_debcheck_cmd =
          Printf.sprintf
            "dose-debcheck --deb-native-arch=%s --explain --quiet --failures"
            arch_ref
        in
        let ((ic, oc) as p) = Unix.open_process dose_debcheck_cmd in
        let fmt = Format.formatter_of_out_channel oc in
        (* inefficiency: for each architecture, we iterate on all binary
           packages, not only on binary packages of said architectures *)
        PAMap.iter
          (fun (_, arch) pkg -> if arch = arch_ref then Package.print fmt pkg)
          bins;
        Format.pp_print_flush fmt ();
        close_out oc;
        let result = read_debcheck ic in
        (match Unix.close_process p with
        | Unix.WEXITED (0 | 1) -> ()
        | Unix.WEXITED i ->
            Printf.eprintf
              "%sW: subprocess dose-debcheck exited with code %d%s%!" a i b
        | Unix.WSIGNALED i ->
            Printf.eprintf
              "%sW: subprocess dose-debcheck died with signal %d%s%!" a i b
        | Unix.WSTOPPED i ->
            Printf.eprintf
              "%sW: subprocess dose-debcheck stopped with signal %d%s%!" a i b);
        StringMap.add arch_ref result map)
      StringMap.empty architectures StringMap.fusion
  in
  PAMap.mapi
    (fun (name, arch) pkg ->
      try
        let uninstallable_packages =
          StringMap.find arch all_uninstallable_packages
        in
        let reason = Package.Map.find name uninstallable_packages in
        let pkg = Package.add "uninstallable" "yes" pkg in
        Package.add "debcheck-reason" reason pkg
      with Not_found -> pkg)
    bins

module SAIndex = struct
  type t = Package.source Package.Name.t * string

  let compare = Stdlib.compare
end

module SAMap = Map.Make (SAIndex)

let inject_build_status architectures src_map bin_map =
  let ( ++ ) current is_all =
    match (current, is_all) with
    | None, b -> `Up_to_date b
    | Some `Out_of_date, _ -> `Out_of_date
    | Some (`Up_to_date a), b -> `Up_to_date (a && b)
  in
  let status =
    PAMap.fold
      (fun (_, arch) pkg accu ->
        let source = Package.(get "source" pkg |> Name.of_string) in
        match Package.Map.find_opt source src_map with
        | None -> accu
        | Some source_package ->
            let source_version = Package.get "source-version" pkg in
            let latest_version = Package.get "version" source_package in
            if Debian_version.compare source_version latest_version < 0 then
              SAMap.add (source, arch) `Out_of_date accu
            else
              let current = SAMap.find_opt (source, arch) accu in
              let binary_arch = Package.get "architecture" pkg in
              SAMap.add (source, arch) (current ++ (binary_arch = "all")) accu)
      bin_map SAMap.empty
  in
  let has_arch_any =
    Package.Map.mapi
      (fun source _ ->
        List.exists
          (fun arch ->
            match SAMap.find_opt (source, arch) status with
            | Some (`Up_to_date false) -> true
            | _ -> false)
          architectures)
      src_map
  in
  PAMap.mapi
    (fun (_, arch) pkg ->
      let source = Package.(get "source" pkg |> Name.of_string) in
      let status = SAMap.find_opt (source, arch) status in
      let status =
        match status with
        | None -> "uncompiled"
        | Some `Out_of_date -> "out-of-date"
        | Some (`Up_to_date false) -> "up-to-date"
        | Some (`Up_to_date true) -> (
            (* seen only arch-all packages on this architecture, check
               if there are arch-any packages elsewhere *)
            match Package.Map.find_opt source has_arch_any with
            | Some true -> "uncompiled"
            | _ -> "up-to-date")
      in
      pkg
      |> Package.add "build-architecture" arch
      |> Package.add "build-status" status)
    bin_map

let generate_cache file architectures =
  let origin = if !use_projectb then Projectb.mk_origin () else file_origin in
  let src_map = origin.get_sources M.empty in
  let bin_map =
    Parallel.fold origin.get_binaries PAMap.empty architectures PAMap.fusion
  in
  let bin_map =
    if !run_debcheck then inject_debcheck_data bin_map architectures
    else bin_map
  in
  let bin_map = inject_build_status architectures src_map bin_map in
  let data = { src_map; bin_map } in
  Marshal.dump file data;
  data

let load_cache architectures =
  let file = Clflags.get_cache_file () in
  if !Clflags.use_cache && Sys.file_exists file then Marshal.load file
  else (
    if !Clflags.verbose then
      Clflags.progress "Cache file (%s) is missing. Recreating it.\n%!" file;
    generate_cache file architectures)