(**************************************************************************)
(*  Copyright © 2011 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 Tyxml.Html
open Ben
open Core
open Clflags
open Utils
open Error

let ( $ ) f x = f x
let base = ref "."
let config_dir = ref "config"
let lock = ref "ben.lock"
let clean = ref true
let tconfig = ref None
let output_formats = ref [ Ben_monitor.Xhtml ]

open Types
open Modules
open Frontend

let eval x =
  Query.eval_source (Package.of_stanza Source Stanza.empty) (Query.of_expr x)

let read_global_config file =
  if Sys.file_exists file then
    let config = Utils.parse_config_file file in
    StringMap.iter
      (fun key value ->
        match (key, value) with
        | "architectures", archs ->
            Clflags.debian_architectures :=
              to_string_l_auto "architectures" archs
        | "ignored", archs ->
            Clflags.ignored_architectures := to_string_l "ignored" archs
        | "suite", EString suite -> Clflags.suite := suite
        | ("areas" | "components"), components ->
            Clflags.components := to_string_l_auto "components" components
        | "base", EString path -> base := path
        | "config-dir", EString path -> config_dir := path
        | "cache-dir", EString dir -> Clflags.cache_dir := dir
        | "mirror-binaries", EString mirror -> Clflags.mirror_binaries := mirror
        | "mirror-sources", EString mirror -> Clflags.mirror_sources := mirror
        | "mirror", EString mirror ->
            Clflags.mirror_sources := mirror;
            Clflags.mirror_binaries := mirror
        | "use-cache", expr -> Clflags.use_cache := eval expr
        | "run-debcheck", expr -> Data.run_debcheck := eval expr
        | "use-projectb", expr -> Data.use_projectb := eval expr
        | "base-url", EString url -> Ben_monitor.baseurl := url
        | "template", EString template -> Templates.load_template template
        | "output-formats", formats ->
            output_formats :=
              to_string_l "output-formats" formats
              |> List.map Ben_monitor.format_of_string
        | item, _ -> warn (Unknown_configuration_item item))
      config

let lockf () = FilePath.concat !cache_dir !lock

let spec =
  Arg.align
    [
      ( "--config-dir",
        Arg.Set_string config_dir,
        " Specify tracker's global configuration directory" );
      ("-cd", Arg.Set_string config_dir, " ");
      ( "--global-conf",
        Arg.String read_global_config,
        " Specify tracker's global configuration file" );
      ("-g", Arg.String read_global_config, " ");
      ( "--transition",
        Arg.String (fun t -> tconfig := Some t),
        " Specify selected transition" );
      ("-t", Arg.String (fun t -> tconfig := Some t), " ");
      ("--update", Arg.Set Clflags.update, " Do update the cache file");
      ("-u", Arg.Set Clflags.update, " ");
      ("--base", Arg.Set_string base, " Specify tracker's base directory");
      ("-b", Arg.Set_string base, " ");
      ( "--run-debcheck",
        Arg.Set Data.run_debcheck,
        " Run debcheck to register installability information" );
      ( "--use-projectb",
        Arg.Set Data.use_projectb,
        " Use Projectb to fetch information about distributions" );
      ( "--template",
        Arg.String (fun t -> Templates.load_template t),
        " Specify template to use" );
      ( "--no-clean",
        Arg.Clear clean,
        " Do not clean HTML directory before exiting" );
    ]

type profile = Planned | Ongoing | Permanent | Finished | Old | Unknown

let string_of_profile = function
  | Planned -> "planned"
  | Ongoing -> "ongoing"
  | Permanent -> "permanent"
  | Finished -> "finished"
  | Old -> "old"
  | Unknown -> "unknown"

let profile_of_string = function
  | "planned" -> Planned
  | "ongoing" -> Ongoing
  | "permanent" -> Permanent
  | "finished" -> Finished
  | "old" -> Old
  | _ -> Unknown

let profiles_desc =
  [
    (Planned, ("Some planned transitions", false));
    (Ongoing, ("Ongoing transitions", true));
    (Permanent, ("Permanent trackers", false));
    (Finished, ("(almost) Finished transitions", true));
    (Old, ("Old trackers", false));
    (Unknown, ("Miscellaneous transitions", false));
  ]

open FileUtil

let p = Clflags.progress

let is_packages_file name =
  try
    let name = String.sub (Filename.basename name) 0 9 in
    name = "Packages_"
  with _ -> false

let clear_cache () =
  let cached = !cache_dir in
  let cachef = !cache_file in
  let test_cond = Or (Basename_is cachef, Custom is_packages_file) in
  let pkgs = find test_cond cached (fun x y -> y :: x) [] in
  rm ~force:Force pkgs

let update_test () =
  let cachef = Clflags.get_cache_file () in
  !Clflags.update || (!Clflags.use_cache && test (Not Exists) cachef)

let read_cache architectures =
  if update_test () then (
    if not !Data.use_projectb then (
      clear_cache ();
      Ben_download.download_all architectures);
    Data.generate_cache (Clflags.get_cache_file ()) architectures)
  else Data.load_cache architectures

let profile_of_file file =
  try profile_of_string $ Filename.basename (Filename.dirname file)
  with _ -> Unknown

let read_transition_config file =
  let ( !! ) = Filename.basename in
  let transition = FilePath.chop_extension !!file in
  (* Read a .ben file *)
  (transition, Frontend.read_ben_file file)

let get_export config =
  try Clflags.get_config config "export" = Types.Etrue with _ -> true

let get_transition_data data name config =
  try
    let transition_data = Ben_monitor.compute_transition_data data config in
    Some transition_data
  with e ->
    Error.warn_exn ("Failed to process transition " ^ name) e;
    None

module SMap = Map.Make (String)

let sadd mp p t =
  let ts = try SMap.find p mp with _ -> [] in
  SMap.add p (t :: ts) mp

let smerge _ v1 v2 =
  match (v1, v2) with
  | Some v1, Some v2 -> Some (v1 @ v2)
  | Some v1, None -> Some v1
  | None, Some v2 -> Some v2
  | _ -> None

let format_path_t format name =
  Filename.concat format (Printf.sprintf "%s.%s" name format)

let print_html_collisions (hits : (SMap.key * SMap.key list) list) =
  let hits =
    List.fold_left
      (fun map (pkg, transitions) ->
        List.fold_left (fun map t -> sadd map t pkg) map transitions)
      SMap.empty hits
  in
  div
    ~a:[ a_id "collisions" ]
    [
      b [ txt "Collisions:" ];
      (let hits =
         SMap.fold
           (fun transition packages list ->
             let elt =
               li
                 [
                   Ben_monitor.a_link (transition ^ ".html") transition;
                   txt " through ";
                   txt (String.concat ", " packages);
                 ]
             in
             elt :: list)
           hits []
       in
       match List.rev hits with [] -> txt "(none)" | h :: l -> ul (h :: l));
    ]

let print_html_monitor fmt template file transition_data collisions =
  let ( !! ) = Filename.basename in
  let collisions_div =
    try
      let hits = SMap.find !!file collisions in
      Some (print_html_collisions hits)
    with Not_found -> None
  in
  let output =
    Ben_monitor.print_html_monitor template transition_data collisions_div
  in
  Format.fprintf fmt "%a\n%!" (Tyxml.Html.pp ()) output

let print_monitor_inner fmt format template file transition_data collisions =
  match format with
  | Ben_monitor.Xhtml ->
      print_html_monitor fmt template file transition_data collisions
  | _ -> Ben_monitor.print_monitor format fmt transition_data

let print_monitor format template file transition_data collisions =
  let ( $ ) = Filename.concat in
  let ( !! ) = Filename.basename in
  let format_name = Ben_monitor.string_of_format format in
  let htmlp = format_path_t format_name !!file in
  let html = !base $ htmlp in
  p "Generating %s\n" htmlp;
  try
    let oc = open_out html in
    try
      let fmt = Format.formatter_of_out_channel oc in
      print_monitor_inner fmt format template file transition_data collisions;
      close_out oc
    with e ->
      close_out oc;
      Stdlib.raise e
  with e -> Error.warn_exn ("Failed to generate " ^ html) e

let compute_collisions results =
  let data_map =
    List.fold_left
      (fun data_map (transition, _, transition_data) ->
        let pkgs = transition_data.Ben_monitor.packages in
        let new_data =
          Data.S.fold
            (fun package data ->
              SMap.add (Package.Name.to_string package) [ transition ] data)
            pkgs SMap.empty
        in
        SMap.merge smerge data_map new_data)
      SMap.empty results
  in
  let collision_map =
    SMap.fold
      (fun pkg transitions map ->
        List.fold_left
          (fun map t ->
            let ts_left = List.filter (fun r -> t <> r) transitions in
            sadd map t (pkg, ts_left))
          map transitions)
      data_map SMap.empty
  in
  collision_map

let generate_stats results =
  List.fold_left
    (fun (packages, profiles) (t, p, transition_data) ->
      let Ben_monitor.{ config; all; bad; _ } = transition_data in
      let export = get_export config in
      let pkgs = transition_data.Ben_monitor.packages in
      let htmlp = format_path_t "html" t in
      let profiles = sadd profiles (string_of_profile p) (htmlp, t, all, bad) in
      let packages =
        Data.S.fold
          (fun package packages ->
            if export then
              sadd packages (Package.Name.to_string package) (t, p, export)
            else packages)
          pkgs packages
      in
      (packages, profiles))
    (SMap.empty, SMap.empty) results

let dump_yaml smap file =
  let transition (name, profile, _) =
    sprintf "[ '%s' , '%s' ]" name (string_of_profile profile)
  in
  let file = Filename.concat !base (Filename.concat "export" file) in
  p "Generating %s\n" file;
  let string =
    SMap.fold
      (fun key list string ->
        let list = List.filter (fun (_, _, export) -> export) list in
        sprintf "%s- {'name': '%s',\n   'list': [%s]\n  }\n" string key
          (String.concat ", " (List.map transition list)))
      smap ""
  in
  try
    mkdir ~parent:true (Filename.dirname file);
    let newfile = FilePath.add_extension file "new" in
    dump_to_file newfile string;
    mv newfile file
  with exn -> Error.error_exn ("Failed to generate " ^ file) exn

let clean_up smap =
  if !clean then (
    p "Cleaning up...\n";
    let ( $ ) = Filename.concat in
    let html_dir = !base $ "html" in
    let known_transitions =
      SMap.fold
        (fun _ tlist accu ->
          let tlist =
            List.map (fun (name, _, _, _) -> Filename.basename name) tlist
          in
          let tset = StringSet.from_list tlist in
          StringSet.union tset accu)
        smap StringSet.empty
    in
    try
      let dir_content = Sys.readdir html_dir in
      Array.iter
        (fun file ->
          if
            Filename.check_suffix file ".html"
            && not (StringSet.mem file known_transitions)
          then (
            let file = html_dir $ file in
            p "Removing %s\n" file;
            Sys.remove file))
        dir_content
    with _ -> ())

let tracker template profiles =
  let page_title = "Transition tracker" in
  let footer = [ small (Ben_monitor.generated_on_text ()) ] in
  let tget show_score (path, name, all, bad) =
    li
      (Ben_monitor.a_link path name
      ::
      (if show_score then
         let score = if all = 0 then 0 else 100 * (all - bad) / all in
         [ txt (sprintf " (%d%%)" score) ]
       else []))
  in
  let contents =
    SMap.fold
      (fun profile tlist acc ->
        let title, show_score =
          try
            let profile = profile_of_string profile in
            List.assoc profile profiles_desc
          with _ -> List.assoc Unknown profiles_desc
        in
        let tlist = List.sort Stdlib.compare tlist in
        let tlist = List.map (tget show_score) tlist in
        match tlist with
        | [] -> acc
        | _ :: _ ->
            let tdiv =
              div ~a:[ a_class [ "transitions" ] ] [ b [ txt title ]; ul tlist ]
            in
            tdiv :: acc)
      profiles []
  in
  let contents = template.Template.intro @ contents in
  let index = Filename.concat !base "index.html" in
  let subtitle = [ txt "Transition tracker" ] in
  let output =
    template.Template.page ~title:page_title ~subtitle ~headers:[]
      ~body:contents ~footer
  in
  try
    p "Generating index...\n";
    dump_xhtml_to_file index output
  with exn -> Error.error_exn "Failed to generate index.html" exn

let main () =
  let lockf = lockf () in
  if test Exists lockf then eprintf "Please wait until %s is removed!\n" lockf
  else
    let () = at_exit (fun () -> try rm [ lockf ] with _ -> ()) in
    try
      let lockf_b = Filename.dirname lockf in
      let () =
        if test Exists lockf_b then touch lockf
        else
          eprintf "%s doesn't exist. Skipping creation of lock file.\n" lockf_b
      in
      let () =
        List.iter
          (fun format ->
            let dir =
              Filename.concat !base (Ben_monitor.string_of_format format)
            in
            if test (Not Exists) dir then mkdir ~parent:true dir)
          !output_formats
      in
      Ben_monitor.check_media_dir !base;
      let confd = !config_dir in
      let test_cond =
        And
          (Size_not_null, And (Has_extension "ben", And (Is_file, Is_readable)))
      in
      let template = Templates.get_registered_template () in
      (* Computing list of transitions *)
      let transition_files =
        match !tconfig with
        | Some transition -> [ (transition, profile_of_file transition) ]
        | None ->
            find test_cond confd
              (fun results transition ->
                match profile_of_file transition with
                | Old -> results
                | profile -> (transition, profile) :: results)
              []
      in
      (* Read found .ben files *)
      let transitions =
        Parallel.map
          (fun (transition, profile) ->
            try
              let name, config = read_transition_config transition in
              Some (name, (config, transition, profile))
            with
            | Error.Error e ->
                (* Ben file has errors *)
                warn e;
                None
            | e ->
                Error.warn_exn ("Failed to read " ^ transition) e;
                None)
          transition_files
      in
      let transitions =
        List.fold_left
          (fun transitions -> function
            | Some t -> t :: transitions | None -> transitions)
          [] transitions
      in
      (* Read ben.cache *)
      let cache = read_cache (Ben_download.archs_list ()) in
      (* Emit warnings for missing source packages *)
      let () =
        if !Clflags.verbose || not !Clflags.quiet then
          let { Marshallable.src_map = srcs; Marshallable.bin_map = bins } =
            cache
          in
          let missing = Hashtbl.create 43 in
          PAMap.iter
            (fun (_, arch) pkg ->
              let src_name = Package.get "source" pkg in
              let src = Package.Name.of_string src_name in
              if
                not (Package.Map.mem src srcs || Hashtbl.mem missing (src, arch))
              then
                let () = Hashtbl.add missing (src, arch) () in
                eprintf "warning: Source package %s is missing on %s!\n%!"
                  src_name arch)
            bins
      in
      (* Compute data for each transition *)
      let results =
        Parallel.map
          (fun (name, (config, _, profile)) ->
            let () =
              p "Computing data for (%s) %s\n" (string_of_profile profile) name
            in
            (name, profile, get_transition_data cache name config))
          transitions
      in
      let results =
        List.fold_left
          (fun results -> function
            | n, p, Some d -> (n, p, d) :: results | _ -> results)
          [] results
      in
      (* Compute collisions *)
      let collisions = compute_collisions results in
      (* Generate an HTML page for each transition *)
      let () =
        Parallel.iter
          (fun (transition, _, transition_data) ->
            List.iter
              (fun format ->
                print_monitor format template transition transition_data
                  collisions)
              !output_formats)
          results
      in
      (* Generate the packages.yaml file *)
      let packages, profiles = generate_stats results in
      let () = dump_yaml packages "packages.yaml" in
      (* Clean up the HTML directory from old files *)
      let () = clean_up profiles in
      (* Generate the index page *)
      match !tconfig with
      | None -> tracker template profiles
      | Some _ -> ()
    with exn ->
      Error.error_exn "General error" exn;
      exit 42

let frontend =
  {
    Frontend.name = "tracker";
    Frontend.main;
    Frontend.anon_fun = (fun _ -> ());
    Frontend.help = spec;
  }