(**************************************************************************)
(*  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 Benl_core
open Benl_base
open Tyxml.Html
open Benl_compat.Html

let use_colors = ref false
let output_file = ref None
let input_source = ref Benl_types.NoSource
let baseurl = ref "https://people.canonical.com/~ubuntu-archive/transitions/"

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 = Benl_frontend.get_selected_frontend () in
  if fr.Benl_frontend.name = "monitor" then
    Benl_parallel.map ~level:(Benl_parallel.get_level ()) f l
  else
    List.map f l

let get_config config key =
  try StringMap.find key config
  with Not_found -> Benl_error.raise (Benl_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 Benl_modules
open Marshallable
open Benl_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://ben.debian.net"

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 Benl_data.run_debcheck, " Run debcheck to register installability information";
  "--use-projectb", Arg.Set Benl_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 := Benl_types.Stdin
  )
                                                  , " Use stdin to read the input file";
  "--template"    , Arg.String (fun template ->
    Benl_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 !Benl_clflags.media_dir mediad
  else
    match (Unix.stat mediad).Unix.st_kind with
    | Unix.S_LNK ->
        let target = Unix.readlink mediad in
        if target != !Benl_clflags.media_dir then begin
          Unix.unlink mediad;
          Unix.symlink !Benl_clflags.media_dir mediad
        end
    | _ -> ()

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
    | Benl_types.EList l -> l
    | _ -> assert false
  in
  let release_archs_list = expr_l (Benl_clflags.get_config config "architectures") in
  let ignored_archs_list =
    try
      expr_l (Benl_clflags.get_config config "ignored")
    with _ -> []
  in
  let archs_list = Benl_core.uniq (release_archs_list @ ignored_archs_list) in
  List.sort Benl_compat.compare archs_list

let compute_monitor_data config sources binaries rounds =
  map_fun begin fun xs ->
    let packages = List.sort (fun x y -> compare !!!x !!!y) xs in
    map_fun begin fun sname ->
      let src = M.find sname sources in
      let src_name = Package.get "package" src in
      let states =
        List.map begin function
        | Benl_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
        end (archs_list config)
      in src, states
    end packages
  end rounds

type transition_data = {
    config : Benl_types.expr Benl_core.StringMap.t;
    monitor_data :
      ([ `source ] Package.t *
         (string * (string * Benl_base.status)) list)
        list list;
    sources : ([ `source ], [ `source ] Package.t) Package.Map.t;
    binaries : [ `binary ] Package.t Benl_modules.PAMap.t;
    rounds : [ `source ] Package.Name.t list list;
    dep_graph : ([ `source ], [ `source ] Package.Set.t) Package.Map.t;
    all : int;
    bad : int;
    packages : [ `source ] Benl_data.S.t;
  }

let print_text_monitor fmt {config; monitor_data; sources; rounds; _} =
  let nmax = M.fold begin fun src _ accu ->
    let n = String.length !!!src in
    if n > accu then n else accu
  end sources 0 in
  let architectures =
    List.map (Benl_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 begin fun i xs ->
    Format.fprintf fmt header_fmt i;
    List.iter begin 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 begin fun (arch, (_, state)) ->
        Format.fprintf fmt " %s" (format_arch state arch)
      end states;
      Format.fprintf fmt "\n";
    end xs;
    Format.fprintf fmt "\n"
  end monitor_data

let print_json_monitor fmt {monitor_data; _} =
  let levels = List.mapi begin fun i xs ->
    let srcs = List.map begin 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 begin fun (arch, (_, state)) ->
        Printf.sprintf "      \"%s\":\"%s\"" arch (class_of_status state)
      end states in
      Printf.sprintf "    \"%s\" : {\n%s\n    }" sname (String.concat ",\n" archs)
    end xs in
    Printf.sprintf "  \"%d\" : {\n%s\n  }" i (String.concat ",\n" srcs)
  end 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)] [pcdata text]

let escape = Netencoding.Url.encode

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 () =
  [ pcdata "Page generated by ";
    a_link ben_webpage "Ben ";
    pcdata Benl_version.version;
    pcdata (Printf.sprintf " on %s" (Benl_core.get_rfc2822_date ()));
    pcdata "; bzr branch ";
    a_link "https://code.launchpad.net/+branch/ubuntu-transition-tracker" "lp:ubuntu-transition-tracker"
  ]

let overrall_state l =
  let _ (* ignored_archs *), release_archs =
    List.partition
      (fun (arch,_) -> List.mem arch !Benl_base.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 !Benl_data.use_projectb || is_in_testing) ->
              return (all+1) (bad+1)
          | Partial when (not !Benl_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 -> pcdata 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 *) pcdata ""
      )
      t

let compute_graph data config =
  let {src_map = sources; bin_map = binaries} = filter_affected data is_affected config in
  let src_of_bin : ([`binary], [`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")]
      (pcdata "");

    script
      ~a:[a_src (uri_of_string ("media/script.js"))]
      (pcdata "");
  ] in
  let hbody table = [
    b [ pcdata "Parameters:" ];
    ul~a:[ a_class ["parameters"] ]
      [li [ small [ b [ pcdata "Affected: " ]; pcdata is_affected ] ];
       li [ small [ b [ pcdata "Good: " ]; pcdata is_good ] ];
       li [ small [ b [ pcdata "Bad: " ]; pcdata is_bad ] ];
      ];
    if String.length notes = 0 then
      div [ ]
    else
      div ~a:[ a_class ["parameters"] ]
        [ small [ b [ pcdata "Notes: " ] ];
          pre ( beautify_text template notes ) ]
    ;
    div
      [
        pcdata "Filter by status: ";
        input ~a:[a_input_type `Checkbox; a_id "good"] ();
        pcdata "good ";
        input ~a:[a_input_type `Checkbox; a_checked (); a_id "partial"] ();
        pcdata "partial ";
        input ~a:[a_input_type `Checkbox; a_checked (); a_id "bad"] ();
        pcdata "bad ";
        input ~a:[a_input_type `Checkbox; a_checked (); a_id "unknown"] (); pcdata "unknown";
        span ~a:[a_id "count"] [];
      ];
    div (if has_testing_data
      then [
        input ~a:[a_input_type `Checkbox; a_id "notintesting"] ();
        pcdata "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 begin function
    | Benl_types.EString arch when (List.mem arch !Benl_base.ignored_architectures) ->
      th [ small [ i [ pcdata (abrege arch) ] ] ]
    | Benl_types.EString arch ->
      th [ small [ pcdata (abrege arch) ] ]
    | _ -> assert false
  end (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 begin fun (rows, i) xs ->
      let names, rows =
      (List.fold_left begin 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 (Benl_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 [
            pcdata " [";
            small [pcdata additional_text];
            pcdata "]";
          ] 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 [pcdata " (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"] ]
                   ([ pcdata "[";
                     buildd template (escape src) version;
                     pcdata "] (";
                     changelog template (sprintf "%s" version) directory (escape src);
                     pcdata ")" ] @ additional_text_html)
              ]
              @
                (List.map begin fun (_, (reasons, state)) ->
                                (td ~a:[ a_class [ Benl_base.class_of_status state ]; a_title reasons ]
                                    [ small [ pcdata (Benl_base.string_of_status state) ] ])
                          end states)
             )
             :: acc
        in
        sources, acc
      end ([], 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
        [
          pcdata " (";
          buildd_link; pcdata " "; rc_bugs_link;
          pcdata ")"
        ]
        with Exit -> []
      in
      let title = pcdata (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)
    end ([], (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";
     pcdata (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 begin 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 begin fun src ->
      let deps = M.find src dep_graph in
      print_dep_line fmt src deps
    end packages
  end 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 = Benl_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
    | Benl_types.NoSource -> Benl_error.raise Benl_error.Missing_configuration_file
    | _ as source -> Benl_frontend.read_config ~multi:true source
  in
  let archs_list = Benl_frontend.to_string_l
    "architectures"
    (Benl_clflags.get_config config "architectures")
  in
  let data = Benl_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 Benl_core.ends_with file ".ben" then
    input_source := Benl_types.File file

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