(**************************************************************************)
(*  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 Benl_modules
module Marshal = Benl_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 = [`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 ->
     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 accu
  | 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%!";
  )

let print_verdicts verdicts hints =
  let verdicts =
    HintSet.fold (fun hint accu ->
        match SMap.find_opt (item_of_hint hint) verdicts with
        | Some verdict -> hintset_map_add 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_verdicts file =
  if Sys.file_exists file then (
    eprintf "Loading %s...\n%!" file;
    let ic = open_in file in
    let rec loop accu =
      match input_line ic with
      | exception End_of_file -> accu
      | line ->
         match String.split_on_char ' ' line with
         | [item; verdict] -> loop (SMap.add item verdict accu)
         | _ -> ksprintf failwith "could not parse verdict line %S" line
    in
    loop SMap.empty
  ) else SMap.empty

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 verdicts = load_verdicts "verdicts.txt" in
     print_testing queries;
     let testing_bin, hints =
       QuerySet.fold (process_binaries unstable) queries
         (testing.bin_map, HintSet.empty)
     in
     print_verdicts verdicts 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
       Package.Map.iter (fun _ p -> Package.print oc p) pkgs;
       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 Benl_frontend in
  { name = "migrate"; main; anon_fun; help }
