(**************************************************************************)
(*  Copyright © 2009 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 Tyxml.Html
open Ben
open Types
open Core
open Common

let use_colors = ref false
let output_file = ref None
let input_source = ref Ben.Types.NoSource
let baseurl = ref "file:///.."

type output_format = Text | Xhtml | Levels | Json

let output_format = ref Levels

let output_format_from_string = function
  | "text" -> Text
  | "xhtml" | "html" -> Xhtml
  | "json" -> Json
  | "color" ->
      use_colors := true;
      Text
  | _ -> Levels

let format_of_string = function
  | "html" -> Xhtml
  | "json" -> Json
  | "txt" -> Text
  | "levels" -> Levels
  | s -> Printf.ksprintf invalid_arg "invalid format: %s" s

let string_of_format = function
  | Text -> "txt"
  | Json -> "json"
  | Xhtml -> "html"
  | Levels -> "levels"

let map_fun f l =
  let fr = Frontend.get_selected_frontend () in
  if fr.Frontend.name = "monitor" then
    Parallel.map ~level:(Parallel.get_level ()) f l
  else List.map f l

let get_config config key =
  try StringMap.find key config
  with Not_found -> Error.raise (Error.Missing_configuration_item key)

let is_affected config = lazy (Query.of_expr (get_config config "is_affected"))
let is_good config = lazy (Query.of_expr (get_config config "is_good"))
let is_bad config = lazy (Query.of_expr (get_config config "is_bad"))

open Modules
open Marshallable
open Data

let format_arch x =
  let f =
    match x with
    | Unknown -> fun x -> "." ^ x ^ "."
    | Up_to_date -> fun x -> "(" ^ x ^ ")"
    | Outdated -> fun x -> "[" ^ x ^ "]"
    | Partial -> fun x -> "¿" ^ x ^ "?"
  in
  let f =
    if !use_colors then
      match x with
      | Unknown -> f
      | Up_to_date -> fun x -> "\027[32m" ^ f x ^ "\027[0m"
      | Outdated -> fun x -> "\027[1m\027[31m" ^ f x ^ "\027[0m"
      | Partial -> fun x -> "\027[33m" ^ f x ^ "\027[0m"
    else f
  in
  f

let ben_webpage = "https://debian.pages.debian.net/ben/"

let print_dep_line fmt src deps =
  Format.fprintf fmt "%s:" !!!src;
  S.iter (fun dep -> Format.fprintf fmt " %s" !!!dep) deps;
  Format.fprintf fmt "\n%!"

let spec =
  Arg.align
    [
      ( "--run-debcheck",
        Arg.Set Data.run_debcheck,
        " Run debcheck to register installability information" );
      ( "--use-projectb",
        Arg.Set Data.use_projectb,
        " Get package lists from Projectb database" );
      ( "--output",
        Arg.String (fun filename -> output_file := Some filename),
        " Path to output file" );
      ( "-o",
        Arg.String (fun filename -> output_file := Some filename),
        " Path to output file" );
      ( "--output-format",
        Arg.String
          (fun format -> output_format := output_format_from_string format),
        " Format of output" );
      ( "-f",
        Arg.String
          (fun format -> output_format := output_format_from_string format),
        " Format of output" );
      ( "-stdin",
        Arg.Unit (fun () -> input_source := Types.Stdin),
        " Use stdin to read the input file" );
      ( "--template",
        Arg.String (fun template -> Templates.load_template template),
        " Select an HTML template" );
    ]

let check_media_dir base =
  let mediad = base // "media" in
  if not (Sys.file_exists mediad) then Unix.symlink !Clflags.media_dir mediad
  else
    match (Unix.stat mediad).Unix.st_kind with
    | Unix.S_LNK ->
        let target = Unix.readlink mediad in
        if target != !Clflags.media_dir then (
          Unix.unlink mediad;
          Unix.symlink !Clflags.media_dir mediad)
    | _ -> ()

let compute_state config pkg =
  if Query.eval_binary pkg !!(is_bad config) then
    if Query.eval_binary pkg !!(is_good config) then Partial else Outdated
  else if Query.eval_binary pkg !!(is_good config) then Up_to_date
  else Unknown

let combine_states state1 state2 =
  match (state1, state2) with
  | Partial, _ | _, Partial -> Partial
  | Outdated, Up_to_date | Up_to_date, Outdated -> Partial
  | Outdated, _ | _, Outdated -> Outdated
  | Up_to_date, _ | _, Up_to_date -> Up_to_date
  | Unknown, Unknown -> state2

let archs_list config =
  let expr_l = function Types.EList l -> l | _ -> assert false in
  let release_archs_list = expr_l (Clflags.get_config config "architectures") in
  let ignored_archs_list =
    try expr_l (Clflags.get_config config "ignored") with _ -> []
  in
  let archs_list = Core.uniq (release_archs_list @ ignored_archs_list) in
  List.sort Stdlib.compare archs_list

let compute_monitor_data config sources binaries rounds =
  map_fun
    (fun xs ->
      let packages = List.sort (fun x y -> compare !!!x !!!y) xs in
      map_fun
        (fun sname ->
          let src = M.find sname sources in
          let src_name = Package.get "package" src in
          let states =
            List.map
              (function
                | Types.EString arch ->
                    (* FIXME: indexing by name+arch is not a good idea after all *)
                    ( arch,
                      PAMap.fold
                        (fun (_, arch') pkg (reasons, accu) ->
                          if arch' = arch && Package.get "source" pkg = src_name
                          then
                            let reason =
                              try
                                Printf.sprintf "  %s\n"
                                  (Package.get "debcheck-reason" pkg)
                              with _ -> ""
                            in
                            let reasons =
                              Printf.sprintf "%s%s" reasons reason
                            in
                            let state = compute_state config pkg in
                            (reasons, combine_states accu state)
                          else (reasons, accu))
                        binaries ("", Unknown) )
                | _ -> assert false)
              (archs_list config)
          in
          (src, states))
        packages)
    rounds

type transition_data = {
  config : Types.expr Core.StringMap.t;
  monitor_data :
    (Package.source Package.t * (string * (string * status)) list) list list;
  sources : (Package.source, Package.source Package.t) Package.Map.t;
  binaries : Package.binary Package.t Modules.PAMap.t;
  rounds : Package.source Package.Name.t list list;
  dep_graph : (Package.source, Package.source Package.Set.t) Package.Map.t;
  all : int;
  bad : int;
  packages : Package.source Data.S.t;
}

let print_text_monitor fmt { config; monitor_data; sources; rounds; _ } =
  let nmax =
    M.fold
      (fun src _ accu ->
        let n = String.length !!!src in
        if n > accu then n else accu)
      sources 0
  in
  let architectures =
    List.map (Frontend.to_string "architectures") (archs_list config)
  in
  let width = String.length (String.concat "   " architectures) + 6 + nmax in
  let nrounds = String.length (string_of_int (List.length rounds)) in
  let hwidth = String.length "> Dependency level  <" + nrounds in
  let header_fmt =
    let width = width - hwidth + 2 in
    let left = width / 2 in
    let right = width - left in
    let buf = Buffer.create 64 in
    for _ = 1 to left do
      Buffer.add_char buf '='
    done;
    bprintf buf "> Dependency level %%%dd <" nrounds;
    for _ = 1 to right do
      Buffer.add_char buf '='
    done;
    Buffer.add_char buf '\n';
    Scanf.format_from_string (Buffer.contents buf) "%d"
  in
  List.iteri
    (fun i xs ->
      Format.fprintf fmt header_fmt i;
      List.iter
        (fun (src, states) ->
          let in_testing =
            try not (Package.get "is-in-testing" src = "no")
            with Not_found -> true
          in
          let sname = Package.get "package" src in
          let sname = if in_testing then sname else "_" ^ sname in
          Format.fprintf fmt "%*s:" (nmax + 3) sname;
          List.iter
            (fun (arch, (_, state)) ->
              Format.fprintf fmt " %s" (format_arch state arch))
            states;
          Format.fprintf fmt "\n")
        xs;
      Format.fprintf fmt "\n")
    monitor_data

let print_json_monitor fmt { monitor_data; _ } =
  let levels =
    List.mapi
      (fun i xs ->
        let srcs =
          List.map
            (fun (src, states) ->
              let in_testing =
                try not (Package.get "is-in-testing" src = "no")
                with Not_found -> true
              in
              let sname = Package.get "package" src in
              let sname = if in_testing then sname else "_" ^ sname in
              let archs =
                List.map
                  (fun (arch, (_, state)) ->
                    Printf.sprintf "      \"%s\":\"%s\"" arch
                      (class_of_status state))
                  states
              in
              Printf.sprintf "    \"%s\" : {\n%s\n    }" sname
                (String.concat ",\n" archs))
            xs
        in
        Printf.sprintf "  \"%d\" : {\n%s\n  }" i (String.concat ",\n" srcs))
      monitor_data
  in
  Format.fprintf fmt "{\n%s\n}" (String.concat ",\n" levels)

let a_link url text = a ~a:[ a_href (uri_of_string url) ] [ txt text ]
let escape x = Uri.pct_encode ~component:`Fragment x
let pts t src = a_link (t.Template.pts ~src:(escape src)) src
let buildd t src ver = a_link (t.Template.buildd ~src ~ver) "build logs"

let buildds t srcs =
  match t.Template.buildds ~srcs with
  | None -> raise Exit
  | Some s -> a_link s "build logs"

let rc_bugs t src =
  match t.Template.critical_bugs ~srcs:src with
  | None -> raise Exit
  | Some s -> a_link s "RC bugs"

let changelog t ver dir src =
  small [ a_link (t.Template.changelog ~letter:dir ~src ~ver) ver ]

let generated_on_text () =
  [
    txt "Page generated by ";
    a_link ben_webpage "Ben";
    txt " ";
    txt Version.version;
    txt (Printf.sprintf " on %s" (Core.get_rfc2822_date ()));
  ]

let overrall_state l =
  let _ (* ignored_archs *), release_archs =
    List.partition
      (fun (arch, _) -> List.mem arch !Clflags.ignored_architectures)
      l
  in
  if List.for_all (fun (_, (_, status)) -> status = Unknown) release_archs then
    Unknown
  else if
    List.for_all (fun (_, (_, status)) -> status <> Outdated) release_archs
  then
    if List.for_all (fun (_, (_, status)) -> status <> Partial) release_archs
    then Up_to_date
    else Partial
  else Outdated

let generate_stats monitor_data =
  List.fold_left
    (fun (all, bad, packages) level ->
      List.fold_left
        (fun (all, bad, packages) (package, statuses) ->
          let is_in_testing =
            try Package.get "is-in-testing" package = "yes" with _ -> false
          in
          let package =
            Package.Name.of_string (Package.get "package" package)
          in
          let overrall_state = overrall_state statuses in
          let packages = S.add package packages in
          let return all bad = (all, bad, packages) in
          match overrall_state with
          | Outdated when (not !Data.use_projectb) || is_in_testing ->
              return (all + 1) (bad + 1)
          | Partial when (not !Data.use_projectb) || is_in_testing ->
              return (all + 1) (bad + 1)
          | Up_to_date -> return (all + 1) bad
          | _ -> return all bad)
        (all, bad, packages) level)
    (0, 0, S.empty) monitor_data

let starts_with text head =
  let s = try String.sub text 0 (String.length head) with _ -> text in
  s = head

let cut_head text head =
  try
    let len = String.length head in
    String.sub text len (String.length text - len)
  with _ -> text

let beautify_text =
  let r_link =
    Re.Pcre.regexp
      "#[0-9]{4,}|[a-z]{3,}://[^\\s><]+|<[^\\s><]+@[^\\s><]+>|[Pp][Tt][Ss]:[a-z0-9+\\-\\.]+|[Bb][Uu][Ii][Ll][Dd][Dd]:[a-z0-9+\\-\\.]+"
  in
  fun tpl text ->
    let t = Re.Pcre.full_split ~rex:r_link text in
    List.map
      (function
        | Re.Pcre.Text s -> txt s
        | Re.Pcre.Delim s ->
            let l = String.lowercase_ascii s in
            if s.[0] = '#' then
              let ss = String.sub s 1 (String.length s - 1) in
              let link = tpl.Template.bugs ~src:ss in
              a_link link s
            else if s.[0] = '<' then
              let ss = String.sub s 1 (String.length s - 2) in
              let link = tpl.Template.msg_id ~mid:ss in
              a_link link s
            else if starts_with l "pts" then
              let text = cut_head s "pts:" in
              let link = tpl.Template.pts ~src:text in
              a_link link s
            else if starts_with l "buildd" then
              let text = cut_head s "buildd:" in
              let link = tpl.Template.buildd ~src:text ~ver:"" in
              a_link link s
            else a_link s s
        | Re.Pcre.Group _ | Re.Pcre.NoGroup -> (* Ignore this case *) txt "")
      t

let compute_graph data config =
  let { src_map = sources; bin_map = binaries } =
    filter_affected data is_affected config
  in
  let src_of_bin : (Package.binary, Package.source Package.Name.t) M.t =
    PAMap.fold
      (fun (name, _) pkg accu ->
        let source = Package.get "source" pkg in
        M.add name (Package.Name.of_string source) accu)
      binaries M.empty
  in
  let dep_graph = Dependencies.get_dep_graph sources src_of_bin in
  let rounds = Dependencies.topo_split dep_graph in
  (rounds, sources, binaries, dep_graph)

let compute_transition_data data config =
  let rounds, sources, binaries, dep_graph = compute_graph data config in
  let monitor_data = compute_monitor_data config sources binaries rounds in
  let all, bad, packages = generate_stats monitor_data in
  {
    config;
    monitor_data;
    sources;
    binaries;
    rounds;
    dep_graph;
    all;
    bad;
    packages;
  }

let has_testing_data monitor_data =
  match monitor_data with
  | ((src, _) :: _) :: _ -> (
      (* if is-in-testing has been injected, it has been injected into
         all packages, so just pick any *)
      try
        let _ = Package.get "is-in-testing" src in
        true
      with Not_found -> false)
  | _ -> false

let print_html_monitor template
    { config; monitor_data; binaries; dep_graph; packages; _ } extra =
  let has_testing_data = has_testing_data monitor_data in
  let affected = packages in
  let mytitle =
    try
      Query.to_string ~escape:false (Query.of_expr (get_config config "title"))
    with _ -> "(no title)"
  in
  let notes =
    try
      Query.to_string ~escape:false (Query.of_expr (get_config config "notes"))
    with _ -> ""
  in
  let is_affected = Query.to_string (Lazy.force (is_affected config)) in
  let is_good = Query.to_string (Lazy.force (is_good config)) in
  let is_bad = Query.to_string (Lazy.force (is_bad config)) in
  let archs_count = List.length (archs_list config) in
  let page_title = sprintf "Transition: %s" mytitle in
  let extra_headers =
    [
      script
        (cdata_script
           (sprintf "var nb_columns = %d; var nb_rounds = %d;" (2 + archs_count)
              (List.length monitor_data)));
      script ~a:[ a_src (uri_of_string "media/jquery.min.js") ] (txt "");
      script ~a:[ a_src (uri_of_string "media/script.js") ] (txt "");
    ]
  in
  let hbody table =
    [
      b [ txt "Parameters:" ];
      ul
        ~a:[ a_class [ "parameters" ] ]
        [
          li [ small [ b [ txt "Affected: " ]; txt is_affected ] ];
          li [ small [ b [ txt "Good: " ]; txt is_good ] ];
          li [ small [ b [ txt "Bad: " ]; txt is_bad ] ];
        ];
      (if String.length notes = 0 then div []
       else
         div
           ~a:[ a_class [ "parameters" ] ]
           [ small [ b [ txt "Notes: " ] ]; pre (beautify_text template notes) ]);
      div
        [
          txt "Filter by status: ";
          input ~a:[ a_input_type `Checkbox; a_id "good" ] ();
          label ~a:[ a_label_for "good" ] [ txt "good" ];
          txt " ";
          input ~a:[ a_input_type `Checkbox; a_checked (); a_id "partial" ] ();
          label ~a:[ a_label_for "partial" ] [ txt "partial" ];
          txt " ";
          input ~a:[ a_input_type `Checkbox; a_checked (); a_id "bad" ] ();
          label ~a:[ a_label_for "bad" ] [ txt "bad" ];
          txt " ";
          input ~a:[ a_input_type `Checkbox; a_checked (); a_id "unknown" ] ();
          label ~a:[ a_label_for "unknown" ] [ txt "unknown" ];
          txt " ";
          span ~a:[ a_id "count" ] [];
        ];
      div
        (if has_testing_data then
           [
             input ~a:[ a_input_type `Checkbox; a_id "notintesting" ] ();
             label
               ~a:[ a_label_for "notintesting" ]
               [ txt "ignore packages that are not in testing" ];
           ]
         else []);
      table;
    ]
  in
  let footer = [ small (generated_on_text ()) ] in
  let abrege = function
    | "hurd-i386" -> "hurd"
    | "kfreebsd-amd64" -> "kbsd64"
    | "kfreebsd-i386" -> "kbsd32"
    | "powerpc" -> "ppc"
    | x -> x
  in
  let archs_columns =
    List.map
      (function
        | Types.EString arch when List.mem arch !Clflags.ignored_architectures
          ->
            th [ small [ i [ txt (abrege arch) ] ] ]
        | Types.EString arch -> th [ small [ txt (abrege arch) ] ]
        | _ -> assert false)
      (archs_list config)
  in
  let archs_columns round header =
    tr ~a:[ a_id (sprintf "header%d" round) ] (header :: archs_columns)
  in
  let rows, _ =
    List.fold_left
      (fun (rows, i) xs ->
        let names, rows =
          List.fold_left
            (fun (sources, acc) (source, states) ->
              let src = Package.get "package" source in
              let is_arch_all = Package.get "architecture" source = "all" in
              let has_ma_same =
                List.exists
                  (fun bin ->
                    List.exists
                      (fun arch ->
                        try
                          let pkg = PAMap.find (bin, arch) binaries in
                          Package.get "multi-arch" pkg = "same"
                        with Not_found -> false)
                      (List.map
                         (Frontend.to_string "architectures")
                         (archs_list config)))
                  (Package.binaries source)
              in
              let has_additional_text, additional_texts =
                List.fold_left
                  (fun (has, acc) (property, text) ->
                    if property then (property || has, text :: acc)
                    else (has, acc))
                  (false, [])
                  [ (is_arch_all, "arch:all"); (has_ma_same, "ma:same") ]
              in
              let additional_text = String.concat ", " additional_texts in
              let additional_text_html =
                if has_additional_text then
                  [ txt " ["; small [ txt additional_text ]; txt "]" ]
                else []
              in
              let in_testing =
                try not (Package.get "is-in-testing" source = "no")
                with Not_found -> true
              in
              let classes =
                [ "src"; sprintf "round%d" i ]
                @ if in_testing then [] else [ "notintesting" ]
              in
              let deps = M.find (Package.Name.of_string src) dep_graph in
              let deps = S.filter (fun p -> S.mem p affected) deps in
              let deps =
                if S.is_empty deps then ""
                else
                  let names = List.map ( !!! ) (S.elements deps) in
                  "Dependencies: " ^ String.concat ", " names
              in
              let version = Package.get "version" source in
              let directory = Package.get "directory" source in
              let sources = src :: sources in
              let overrall_state =
                [ class_of_status (overrall_state states) ]
              in
              let src_text =
                pts template src
                :: (if in_testing then [] else [ txt " (sid only)" ])
              in
              let acc =
                tr
                  ([
                     td
                       ~a:
                         [
                           a_class ("srcname" :: (overrall_state @ classes));
                           a_id src;
                           a_title deps;
                         ]
                       src_text;
                     td
                       ~a:[ a_class [ "src" ] ]
                       ([
                          txt "[";
                          buildd template (escape src) version;
                          txt "] (";
                          changelog template (sprintf "%s" version) directory
                            (escape src);
                          txt ")";
                        ]
                       @ additional_text_html);
                   ]
                  @ List.map
                      (fun (_, (reasons, state)) ->
                        td
                          ~a:
                            [
                              a_class [ class_of_status state ]; a_title reasons;
                            ]
                          [ small [ txt (string_of_status state) ] ])
                      states)
                :: acc
              in
              (sources, acc))
            ([], rows) (List.rev xs)
        in
        let escaped_names = List.map (fun x -> escape x) names in
        let column_arg =
          try
            let buildd_link = buildds template escaped_names in
            let rc_bugs_link = rc_bugs template escaped_names in
            [ txt " ("; buildd_link; txt " "; rc_bugs_link; txt ")" ]
          with Exit -> []
        in
        let title = txt (sprintf "Dependency level %d" (i + 1)) in
        let tr_cols =
          archs_columns i
            (th ~a:[ a_colspan 2; a_class [ "level" ] ] (title :: column_arg))
        in
        let rows = tr_cols :: rows in
        (rows, i - 1))
      ([], List.length monitor_data - 1)
      (List.rev monitor_data)
  in
  let table = table rows in
  let content =
    match extra with
    | None -> table
    | Some extra -> div ~a:[ a_class [ "content" ] ] [ table; extra ]
  in
  let subtitle =
    [
      a_link (Filename.concat !baseurl "index.html") "Transitions";
      txt (Printf.sprintf " → %s" mytitle);
    ]
  in
  let html =
    template.Template.page ~title:page_title ~subtitle ~headers:extra_headers
      ~body:(hbody content) ~footer
  in
  html

let print_dependency_levels fmt { dep_graph; rounds; _ } =
  List.iteri
    (fun i xs ->
      Format.fprintf fmt "===[ Dependency level %d ]=====\n" i;
      let packages = List.sort (fun x y -> compare !!!x !!!y) xs in
      List.iter
        (fun src ->
          let deps = M.find src dep_graph in
          print_dep_line fmt src deps)
        packages)
    rounds

let print_monitor format fmt transition_data =
  match format with
  | Levels -> print_dependency_levels fmt transition_data
  | Text -> print_text_monitor fmt transition_data
  | Json -> print_json_monitor fmt transition_data
  | Xhtml ->
      let template = Templates.get_registered_template () in
      let output = print_html_monitor template transition_data None in
      Format.fprintf fmt "%a\n%!" (Tyxml.Html.pp ()) output

let main _ =
  let config =
    match !input_source with
    | Types.NoSource -> Error.raise Error.Missing_configuration_file
    | _ as source -> Frontend.read_config ~multi:true source
  in
  let archs_list =
    Frontend.to_string_l "architectures"
      (Clflags.get_config config "architectures")
  in
  let data = Data.load_cache archs_list in
  let transition_data = compute_transition_data data config in
  let fmt, close =
    match !output_file with
    | None -> (Format.std_formatter, fun () -> ())
    | Some file ->
        let oc = open_out file in
        (Format.formatter_of_out_channel oc, fun () -> close_out oc)
  in
  let () =
    match (!output_format, !output_file) with
    | Xhtml, Some file -> check_media_dir (Filename.basename file)
    | _, _ -> ()
  in
  print_monitor !output_format fmt transition_data;
  close ()

let anon_fun file =
  if String.ends_with file ~suffix:".ben" then input_source := Types.File file

let frontend =
  {
    Frontend.name = "monitor";
    Frontend.main;
    Frontend.anon_fun;
    Frontend.help = spec;
  }