(**************************************************************************)
(*  Copyright © 2019 Stéphane Glondu <steph@glondu.net>                   *)
(*                                                                        *)
(*  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 Modules
module Marshal = Marshal.Make (Marshallable)
open Marshallable

let args = ref []
let anon_fun name = args := name :: !args

let usage () =
  fprintf stderr
    "Usage: ben migrate <testing.cache> <unstable.cache> [ [_]srcpkg ... ]\n";
  exit 1

let help = []

let startswith prefix str =
  let n = String.length prefix and m = String.length str in
  m >= n && String.sub str 0 n = prefix

module SMap = Map.Make (String)
module SSet = Set.Make (String)

type srcpkg = Package.source Package.Name.t
type version = string
type query_type = QRemove | QUpdate | QBinNMU
type query = query_type * srcpkg * version

type hint =
  | Remove of srcpkg * version
  | Update of srcpkg * version
  | BinNMU of srcpkg * string * version

module QuerySet = Set.Make (struct
  type t = query

  let compare = compare
end)

module HintSet = Set.Make (struct
  type t = hint

  let compare = compare
end)

let hintset_map_add key value map =
  let old =
    match SMap.find_opt key map with None -> HintSet.empty | Some x -> x
  in
  SMap.add key (HintSet.add value old) map

let parse_query testing unstable str =
  if startswith "_" str then
    let str = String.sub str 1 (String.length str - 1) in
    let pkg = Package.Name.of_string str in
    let version =
      match Package.Map.find_opt pkg testing.src_map with
      | None -> ksprintf failwith "%s not in testing" str
      | Some p -> Package.get "version" p
    in
    (QRemove, pkg, version)
  else
    let pkg = Package.Name.of_string str in
    let version_in_unstable =
      match Package.Map.find_opt pkg unstable.src_map with
      | None -> ksprintf failwith "%s not in unstable" str
      | Some p -> Package.get "version" p
    in
    match Package.Map.find_opt pkg testing.src_map with
    | None -> (QUpdate, pkg, version_in_unstable)
    | Some p ->
        let version_in_testing = Package.get "version" p in
        if version_in_testing = version_in_unstable then
          (QBinNMU, pkg, version_in_unstable)
        else (QUpdate, pkg, version_in_unstable)

let string_of_hint = function
  | Remove (pkg, _) -> sprintf "-%s" (Package.Name.to_string pkg)
  | Update (pkg, version) ->
      sprintf "%s/%s" (Package.Name.to_string pkg) version
  | BinNMU (pkg, arch, version) ->
      sprintf "%s/%s/%s" (Package.Name.to_string pkg) arch version

let item_of_hint = function
  | Remove (pkg, _) -> sprintf "-%s" (Package.Name.to_string pkg)
  | Update (pkg, _) -> Package.Name.to_string pkg
  | BinNMU (pkg, arch, _) -> sprintf "%s/%s" (Package.Name.to_string pkg) arch

let process_binaries unstable (q, pkg, version) ((testing_bin, hints) as accu) =
  match q with
  | QUpdate ->
      let testing_bin =
        (* we first remove all binaries of pkg from testing *)
        PAMap.filter
          (fun _ p ->
            let src = Package.Name.of_string (Package.get "source" p) in
            not (src = pkg))
          testing_bin
      in
      PAMap.fold
        (fun x p ((testing_bin, hints) as accu) ->
          let src = Package.Name.of_string (Package.get "source" p) in
          let ver = Package.get "source-version" p in
          if src = pkg && ver = version then
            ( PAMap.add x p testing_bin,
              HintSet.add (Update (pkg, version)) hints )
          else accu)
        unstable.bin_map (testing_bin, hints)
  | QBinNMU ->
      PAMap.fold
        (fun ((_, arch) as x) p ((testing_bin, hints) as accu) ->
          let src = Package.Name.of_string (Package.get "source" p) in
          let source_version = Package.get "source-version" p in
          let binary_version = Package.get "version" p in
          if src = pkg && source_version = version then
            match PAMap.find_opt x testing_bin with
            | Some p when binary_version = Package.get "version" p -> accu
            | _ ->
                ( PAMap.add x p testing_bin,
                  HintSet.add (BinNMU (pkg, arch, version)) hints )
          else accu)
        unstable.bin_map accu
  | QRemove ->
      ( PAMap.filter
          (fun _ p ->
            let src = Package.Name.of_string (Package.get "source" p) in
            let ver = Package.get "source-version" p in
            not (src = pkg && ver = version))
          testing_bin,
        HintSet.add (Remove (pkg, version)) hints )

let process_source unstable (q, pkg, version) testing_src =
  match q with
  | QRemove -> Package.Map.remove pkg testing_src
  | QBinNMU -> testing_src
  | QUpdate -> (
      match Package.Map.find_opt pkg unstable.src_map with
      | Some p when Package.get "version" p = version ->
          Package.Map.add pkg p testing_src
      | _ ->
          ksprintf failwith "could not update %s/%s"
            (Package.Name.to_string pkg)
            version)

let print_testing queries =
  let in_testing, not_in_testing =
    QuerySet.fold
      (fun q ((a, b) as accu) ->
        match q with
        | QUpdate, pkg, version -> (a, (pkg, version) :: b)
        | QBinNMU, pkg, version -> ((pkg, version) :: a, b)
        | _ -> accu)
      queries ([], [])
  in
  if in_testing <> [] then (
    printf "Packages already in testing:";
    List.iter
      (fun (pkg, version) ->
        printf " %s/%s" (Package.Name.to_string pkg) version)
      (List.rev in_testing);
    printf "\n%!");
  if not_in_testing <> [] then (
    printf "Packages not in testing:";
    List.iter
      (fun (pkg, version) ->
        printf " %s/%s" (Package.Name.to_string pkg) version)
      (List.rev not_in_testing);
    printf "\n%!")

open Ppx_yojson_conv_lib.Yojson_conv.Primitives

type item = { verdict : string; excuses : string list } [@@deriving yojson]

let print_verdicts excuses hints =
  let verdicts =
    HintSet.fold
      (fun hint accu ->
        match SMap.find_opt (item_of_hint hint) excuses with
        | Some x -> hintset_map_add x.verdict hint accu
        | None -> hintset_map_add "NO_VERDICT" hint accu)
      hints SMap.empty
  in
  SMap.iter
    (fun verdict hints ->
      printf "%s:" verdict;
      HintSet.iter (fun hint -> printf " %s" (string_of_hint hint)) hints;
      printf "\n%!")
    verdicts

let load_excuses file =
  if Sys.file_exists file then (
    eprintf "Loading %s...\n%!" file;
    match Yojson.Safe.from_file file with
    | `Assoc o ->
        List.fold_left
          (fun accu (item, o) -> SMap.add item (item_of_yojson o) accu)
          SMap.empty o
    | _ | (exception _) -> ksprintf failwith "error in %s!" file)
  else ksprintf failwith "%s does not exist!" file

let main () =
  match List.rev !args with
  | testing :: unstable :: queries ->
      let testing = Marshal.load testing in
      let unstable = Marshal.load unstable in
      let queries =
        List.fold_left
          (fun accu x ->
            let q = parse_query testing unstable x in
            QuerySet.add q accu)
          QuerySet.empty queries
      in
      let excuses = load_excuses "excuses.json" in
      print_testing queries;
      let testing_bin, hints =
        QuerySet.fold
          (process_binaries unstable)
          queries
          (testing.bin_map, HintSet.empty)
      in
      print_verdicts excuses hints;
      let testing_src =
        QuerySet.fold (process_source unstable) queries testing.src_map
      in
      let per_arch_mapping =
        PAMap.fold
          (fun (pkg, arch) p accu ->
            let current =
              match SMap.find_opt arch accu with
              | None -> Package.Map.empty
              | Some x -> x
            in
            SMap.add arch (Package.Map.add pkg p current) accu)
          testing_bin SMap.empty
      in
      let write fn pkgs =
        eprintf "Writing %s...\n%!" fn;
        let oc = open_out fn in
        let fmt = Format.formatter_of_out_channel oc in
        Package.Map.iter (fun _ p -> Package.print fmt p) pkgs;
        Format.pp_print_flush fmt ();
        close_out oc
      in
      write "Sources" testing_src;
      SMap.iter
        (fun arch pkgs -> write ("Packages_" ^ arch) pkgs)
        per_arch_mapping;
      if not (HintSet.is_empty hints) then (
        printf "Easy hint:";
        HintSet.iter (fun x -> printf " %s" (string_of_hint x)) hints;
        printf "\n%!");
      let minimized_query =
        HintSet.fold
          (fun hint accu ->
            let pkg =
              match hint with
              | BinNMU (pkg, _, _) | Update (pkg, _) ->
                  Package.Name.to_string pkg
              | Remove (pkg, _) -> sprintf "_%s" (Package.Name.to_string pkg)
            in
            SSet.add pkg accu)
          hints SSet.empty
      in
      if not (SSet.is_empty minimized_query) then (
        printf "Minimized query:";
        SSet.iter (printf " %s") minimized_query;
        printf "\n%!")
  | _ -> usage ()

let frontend =
  let open Frontend in
  { name = "migrate"; main; anon_fun; help }