(*---------------------------------------------------------------------------
   Copyright (c) 2016 Daniel C. Bünzli. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open Bos_setup

(* Misc *)

let path_set_of_strings ps =
  try
    let add_excl acc p = match Fpath.of_string p with
    | Error (`Msg msg) -> failwith msg
    | Ok p -> Fpath.Set.add p acc
    in
    Ok (List.fold_left add_excl Fpath.Set.empty ps)
  with
  Failure msg -> R.error_msg msg

let rec path_list_of_strings ps =
  let rec loop acc = function
  | [] -> Ok (List.rev acc)
  | p :: ps ->
      match Fpath.of_string p with
      | Error _ as e -> e
      | Ok p -> loop (p :: acc) ps
  in
  loop [] ps

let uri_sld uri = match Topkg_care_text.split_uri uri with
| None -> None
| Some (_, host, _) ->
    match List.rev (String.cuts ~sep:"." host) with
    | fst :: snd :: _ -> Some snd
    | _ -> None

let uri_append u s = match String.head ~rev:true u with
| None -> s
| Some '/' -> strf "%s%s" u s
| Some _ -> strf "%s/%s" u s

let chop_ext u = match String.cut ~rev:true ~sep:"." u with
| None -> u
| Some (u, _) -> u

let chop_git_prefix u = match String.cut ~sep:"git+" u with
| Some ("", uri) -> uri
| _ -> u

(* Package *)

type t =
  { name : string option;
    version : string option;
    delegate : Cmd.t option;
    build_dir : Fpath.t option;
    opam : Fpath.t option;
    opam_descr : Fpath.t option;
    opam_fields : (string list String.map, R.msg) result Lazy.t;
    readmes : Fpath.t list option;
    change_logs : Fpath.t list option;
    licenses : Fpath.t list option;
    distrib_uri : string option;
    distrib_file : Fpath.t option;
    publish_msg : string option;
    publish_artefacts : [ `Distrib | `Doc | `Alt of string ] list option;
    pkg_file : Fpath.t;
    pkg : (Topkg.Private.Pkg.t, R.msg) result Lazy.t; }

let empty p = { p with pkg = lazy (Ok (Topkg.Private.Pkg.empty)) }
let pkg p = Lazy.force p.pkg

let opam_fields p = Lazy.force p.opam_fields
let opam_field p f = opam_fields p >>| fun fields -> String.Map.find f fields
let opam_field_hd p f = opam_field p f >>| function
| None | Some [] -> None
| Some (v :: _) -> Some v

let opam_homepage_sld p = opam_field_hd p "homepage" >>| function
| None -> None
| Some uri -> match uri_sld uri with None -> None | Some sld -> Some (uri, sld)

let pkg_file p = p.pkg_file

let name p = match p.name with
| Some n -> Ok n
| None -> pkg p >>| Topkg.Private.Pkg.name

let version p = match p.version with
| Some v -> Ok v
| None -> Topkg.Vcs.get () >>= fun r -> Topkg.Vcs.describe ~dirty:false r

let delegate p =
  let not_found () =
    R.error_msg "No package delegate found. \
                 Try `topkg help delegate` for more information."
  in
  match p.delegate with
  | Some cmd -> Ok cmd
  | None ->
      pkg p >>| Topkg.Private.Pkg.delegate >>= function
      | Some cmd -> Ok (Cmd.of_list @@ Topkg.Cmd.to_list cmd)
      | None ->
          match OS.Env.(value "TOPKG_DELEGATE" (some cmd) ~absent:None) with
          | Some cmd -> Ok cmd
          | None ->
              opam_homepage_sld p >>= function
              | None -> not_found ()
              | Some (_, sld) ->
                  let exec = strf "%s-topkg-delegate" sld in
                  let cmd = Cmd.v exec in
                  OS.Cmd.exists cmd >>= function
                  | true -> Ok cmd
                  | false ->
                      if exec <> "github-topkg-delegate"
                      then not_found ()
                      else Ok (Cmd.v "toy-github-topkg-delegate")

let build_dir p = match p.build_dir with
| Some b -> Ok b
| None -> pkg p >>| Topkg.Private.Pkg.build_dir >>= Fpath.of_string

let readmes p = match p.readmes with
| Some f -> Ok f
| None -> pkg p >>| Topkg.Private.Pkg.readmes >>= path_list_of_strings

let readme p = readmes p >>= function
| [] -> R.error_msgf "No readme file specified in the package description"
| r :: _ -> Ok r

let opam p = match p.opam with
| Some f -> Ok f
| None ->
    name p
    >>= fun name -> pkg p
    >>| Topkg.Private.Pkg.opam ~name >>= Fpath.of_string

let opam_field_descr p =
  opam_field p "synopsis" >>= function
  | None -> Ok None
  | Some syn ->
      opam_field p "description" >>= function
      | None -> Ok None
      | Some descr -> Ok (Some (List.hd syn, List.hd descr))

let opam_descr p =
  let descr_file_for_opam opam =
    if Fpath.has_ext ".opam" opam then Fpath.(rem_ext opam + ".descr") else
    Fpath.(parent opam / "descr")
  in
  let read f =
    OS.File.read f
    >>= fun c -> Topkg_care_opam.Descr.of_string c
    >>| fun d -> d, false
  in
  match p.opam_descr with
  | Some f -> read f
  | None ->
      opam_field_descr p >>= function
      | Some descr -> Ok (descr, true)
      | None ->
          opam p
          >>= fun opam -> Ok (descr_file_for_opam opam)
          >>= fun descr_file -> OS.File.exists descr_file
          >>= function
          | true ->
              Logs.info (fun m -> m "Found opam descr file %a"
                            Fpath.pp descr_file);
              read descr_file
          | false ->
              readme p
              >>= fun readme ->
              Logs.info
                (fun m -> m "Extracting opam descr from %a" Fpath.pp readme);
              Topkg_care_opam.Descr.of_readme_file readme
              >>| fun d -> d, false

let change_logs p = match p.change_logs with
| Some f -> Ok f
| None -> pkg p >>| Topkg.Private.Pkg.change_logs >>= path_list_of_strings

let change_log p = change_logs p >>= function
| [] -> R.error_msgf "No change log specified in the package description."
| l :: _ -> Ok l

let licenses p = match p.licenses with
| Some f -> Ok f
| None -> pkg p >>| Topkg.Private.Pkg.licenses >>= path_list_of_strings

let distrib_uri ?(raw = false) p =
  let subst_uri p uri =
    uri
    >>= fun uri -> name p
    >>= fun name -> version p
    >>= fun version -> Ok (Topkg.String.drop_initial_v version)
    >>= fun version_num ->
    let defs = String.Map.(empty
                          |> add "NAME" name |> add "VERSION" version
                          |> add "VERSION_NUM" version_num)
    in
    Pat.of_string uri >>| fun pat -> Pat.format defs pat
  in
  let not_found () =
    R.error_msg "no distribution URI found, see topkg's API documentation."
  in
  let uri = match p.distrib_uri with
  | Some u -> Ok u
  | None ->
      pkg p
      >>= fun pkg -> match Topkg.Private.Pkg.distrib_uri pkg with
      | Some u -> Ok u
      | None ->
          opam_homepage_sld p >>= function
          | None -> not_found ()
          | Some (uri, sld) ->
              if sld <> "github"
              then (Ok (uri_append uri "releases/$(NAME)-$(VERSION_NUM).tbz"))
              else
              opam_field_hd p "dev-repo">>= function
              | None -> not_found ()
              | Some dev_repo ->
                  Ok (uri_append (chop_git_prefix (chop_ext dev_repo))
                      "releases/download/$(VERSION)/$(NAME)-$(VERSION_NUM).tbz")
  in
  if raw then uri else subst_uri p uri

let distrib_filename ?(opam = false) p =
  let sep = if opam then '.' else '-' in
  name p
  >>= fun name -> version p
  >>= fun version -> Ok (Topkg.String.drop_initial_v version)
  >>= fun version_num -> Fpath.of_string (strf "%s%c%s" name sep version_num)

let distrib_archive_path p =
  build_dir p
  >>= fun build_dir -> distrib_filename ~opam:false p
  >>| fun b -> Fpath.(build_dir // b + ".tbz")

let distrib_file p = match p.distrib_file with
| Some f -> Ok f
| None ->
    (distrib_archive_path p
     >>= fun f -> OS.File.must_exist f)
    |> R.reword_error_msg
      (fun _ -> R.msgf "Did you forget to call 'topkg distrib' ?")

let publish_msg p = match p.publish_msg with
| Some msg -> Ok msg
| None ->
    change_log p
    >>= fun change_log -> Topkg_care_text.change_log_file_last_entry change_log
    >>= fun (_, (h, txt)) -> Ok (strf "%s\n%s" h txt)

let publish_artefacts p = match p.publish_artefacts with
| Some arts -> Ok arts
| None -> pkg p >>| Topkg.Private.Pkg.publish_artefacts

let v
    ?name ?version ?delegate ?build_dir ?opam:opam_file ?opam_descr
    ?readme ?change_log ?license ?distrib_uri ?distrib_file ?publish_msg
    ?publish_artefacts
    pkg_file
  =
  let readmes = match readme with Some r -> Some [r] | None -> None in
  let change_logs = match change_log with Some c -> Some [c] | None -> None in
  let licenses = match license with Some l -> Some [l] | None -> None in
  let pkg = lazy (Topkg_care_ipc.ask ~pkg_file (Topkg.Private.Ipc.pkg ())) in
  let rec opam_fields = lazy (opam p >>= fun o -> Topkg_care_opam.File.fields o)
  and p =
    { name; version; delegate; build_dir; opam = opam_file; opam_descr;
      opam_fields; readmes; change_logs; licenses; distrib_uri; distrib_file;
      publish_msg; publish_artefacts; pkg_file; pkg }
  in
  p

(* Distrib *)

let distrib_prepare_ipc p ~dist_build_dir ~name ~version ~opam ~opam_adds =
  let dist_build_dir = Fpath.to_string dist_build_dir in
  let opam = Fpath.to_string opam in
  R.join @@ Topkg_care_ipc.ask ~pkg_file:p.pkg_file
    (Topkg.Private.Ipc.distrib_prepare ~dist_build_dir ~name ~version ~opam
       ~opam_adds)

let distrib_archive p ~keep_dir =
  Topkg_care_archive.ensure_bzip2 ()
  >>= fun () -> name p
  >>= fun name -> build_dir p
  >>= fun build_dir -> version p
  >>= fun version -> opam p
  >>= fun opam -> distrib_filename p
  >>= fun root -> Ok Fpath.(build_dir // root + ".build")
  >>= fun dist_build_dir -> OS.Dir.delete ~recurse:true dist_build_dir
  >>= fun () -> Topkg_vcs.get ()
  >>= fun repo -> Topkg_vcs.commit_id repo ~dirty:false
  >>= fun head -> Topkg_vcs.commit_ptime_s repo ~commit_ish:head
  >>= fun mtime -> Topkg_vcs.clone repo ~dir:(Fpath.to_string dist_build_dir)
  >>= fun () -> Topkg_vcs.get ~dir:(Fpath.to_string dist_build_dir) ()
  >>= fun clone -> Ok (Topkg_string.strf "topkg-dist-%s" head)
  >>= fun branch -> Topkg_vcs.checkout clone ~branch ~commit_ish:head
  >>= fun () -> opam_descr p
  >>= fun (descr, from_opam) ->
  let opam_adds =
    if from_opam then "" else
    (Topkg_care_opam.Descr.to_opam_fields descr ^ "\n")
  in
  distrib_prepare_ipc p ~dist_build_dir ~name ~version ~opam ~opam_adds
  >>= fun exclude_paths -> path_set_of_strings exclude_paths
  >>= fun exclude_paths ->
  Topkg_care_archive.tar dist_build_dir ~exclude_paths ~root ~mtime
  >>= fun tar -> distrib_archive_path p
  >>= fun archive -> Topkg_care_archive.bzip2 tar ~dst:archive
  >>= fun () ->
  (if keep_dir then Ok () else OS.Dir.delete ~recurse:true dist_build_dir)
  >>= fun () -> Ok archive

(* Test & build *)

let run p ~dir cmd ~args ~out =
  let pkg_file = p.pkg_file in
  let cmd = Cmd.(v "ocaml" % p pkg_file % cmd %% args) in
  let run () = OS.Cmd.run_out cmd |> out in
  R.join @@ OS.Dir.with_current dir run ()

let test p ~dir ~args ~out = run p ~dir "test" ~args ~out
let build p ~dir ~args ~out = run p ~dir "build" ~args ~out
let clean p ~dir ~args ~out = run p ~dir "clean" ~args ~out

(* Lint *)

let pp_path = Topkg_care_text.Pp.path
let pp_status = Topkg_care_text.Pp.status

let lint_log msg = Logs.info (fun m -> m ~header:"LINT" "%a" Fmt.text msg); 0
let lint_disabled test =
  Logs.info (fun m -> m ~header:"LINT" "Package@ disabled@ %a." Fmt.text test);
  0

let lint_custom p =
  let report errs res =
    let status, msg, errs = match res with
    | Ok (`Msg msg) -> `Ok, msg, errs
    | Error (`Msg msg) -> `Fail, msg, errs + 1
    in
    Logs.app (fun m -> m "%a @[%a@]" pp_status status Fmt.text msg);
    errs
  in
  begin
    let pkg_file = p.pkg_file in
    pkg p >>= fun p -> match Topkg.Private.Pkg.lint_custom p with
    | None -> Ok (lint_disabled "custom linting")
    | _ ->
        Topkg_care_ipc.ask ~pkg_file (Topkg.Private.Ipc.lint_custom ())
        >>= function
        | None -> assert false
        | Some results -> Ok (List.fold_left report 0 results)
  end
  |> Logs.on_error_msg ~use:(fun () -> 1)

let lint_std_files p =
  let lint_exists file errs =
    let report exists =
      let status, errs = if exists then `Ok, errs else `Fail, errs + 1 in
      Logs.app (fun m ->
           m "%a @[File %a@ is@ present.@]" pp_status status pp_path file);
      errs
    in
    (OS.File.exists file >>= fun exists -> Ok (report exists))
    |> Logs.on_error_msg ~use:(fun () -> errs + 1)
  in
  begin
    pkg p >>= fun p -> match Topkg.Private.Pkg.lint_files p with
    | None -> Ok (lint_disabled "standard files linting")
    | Some files ->
        path_set_of_strings files
        >>= fun files -> Ok (Fpath.Set.fold lint_exists files 0)
  end
  |> Logs.on_error_msg ~use:(fun () -> 1)

let lint_file_with_cmd file_kind ~cmd file errs handle_exit =
  let run_linter cmd file ~exists =
    if not exists then Ok (`Fail (strf "%a: No such file" Fpath.pp file)) else
    OS.Cmd.(run_out ~err:err_run_out Cmd.(cmd % p file) |> out_string)
    >>| fun (out, status) -> handle_exit (snd status) out
  in
  begin
    OS.File.exists file
    >>= fun exists -> run_linter cmd file ~exists
    >>| function
    | `Ok ->
        Logs.app
          (fun m -> m "%a @[lint@ %s %a.@]"
              pp_status `Ok file_kind pp_path file);
        errs
    | `Fail msgs ->
        Logs.app
          (fun m -> m "%a @[<v>@[lint@ %s %a:@]@,@[%a messages:@]@,%a@]"
              pp_status `Fail file_kind pp_path file Cmd.pp cmd Fmt.lines msgs);
        errs + 1
  end
  |> Logs.on_error_msg ~use:(fun () -> errs + 1)

let lint_metas p =
  begin
    pkg p
    >>= fun p -> match Topkg.Private.Pkg.lint_metas p with
    | [] -> Ok (lint_log "No ocamlfind META file to lint")
    | metas ->
      let cmd = Cmd.(Topkg_care_ocamlfind.cmd % "lint") in
      let handle_exit status out = match status with
      | `Exited 0 -> `Ok
      | _ -> `Fail out
      in
      let lint errs (f, lint) =
        begin
          Fpath.of_string f >>| fun f ->
          if not lint
          then lint_log (strf "ocamlfind META lint disabled for %a" Fpath.pp f)
          else lint_file_with_cmd "META file" ~cmd f errs handle_exit
        end
        |> Logs.on_error_msg ~use:(fun () -> errs + 1)
      in
      Ok (List.fold_left lint 0 metas)
  end
  |> Logs.on_error_msg ~use:(fun () -> 1)

let lint_opams p =
  begin
    pkg p >>= fun p -> match Topkg.Private.Pkg.lint_opams p with
    | [] -> Ok (lint_log "No opam file to lint")
    | opams ->
        (* We first run opam lint with -s and if there's something beyond
           5 we rerun it without it for the error messages. It's ugly
           since 5 will still but opam lint's cli is broken. *)
        let cmd = Cmd.(Topkg_care_opam.cmd % "lint") in
        let handle_exit file status out = match status, out with
        | `Exited 0,
          ("" | "5" (* dirname version vs opam file version *)) -> `Ok
        | _ ->
            let err = OS.Cmd.err_run_out in
            match OS.Cmd.(run_out ~err Cmd.(cmd % p file) |> out_string) with
            | Ok (out, _) -> `Fail out
            | Error (`Msg out) -> `Fail out
        in
        let cmd = Cmd.(cmd % "-s") in
        let lint errs (f, lint, _) =
          begin
            Fpath.of_string f >>| fun f ->
            if not lint
            then lint_log (strf "opam file lint disabled for %a" Fpath.pp f)
            else lint_file_with_cmd "opam file" ~cmd f errs (handle_exit f)
          end
          |> Logs.on_error_msg ~use:(fun () -> errs + 1)
        in
        Ok (List.fold_left lint 0 opams)
  end
  |> Logs.on_error_msg ~use:(fun () -> 1)

let lint_deps_default_excludes =
  let exclude = ["ocamlfind"; "ocamlbuild"; "topkg"; "ocaml"] in
  Topkg_care_ocamlfind.base_packages
  |> String.Set.union Topkg_care_opam.ocaml_base_packages
  |> String.Set.union (String.Set.of_list exclude)

let lint_opam_deps errs (opam, _, exclude) =
  let pp_deps_mismatches ppf (opam_only, tags_only) =
    let pp_miss present absent ppf id =
      Fmt.pf ppf "@[%a: %a present but %a absent@]"
        Fmt.(styled `Underline string) id
        Fmt.(styled `Green string) present
        Fmt.(styled `Red string) absent
    in
    let sep =
      if String.Set.(is_empty opam_only || is_empty tags_only)
      then Fmt.nop else Fmt.cut
    in
    Fmt.pf ppf "@[<v>%a%a%a@]"
      (String.Set.pp (pp_miss "opam" "_tags")) opam_only sep ()
      (String.Set.pp (pp_miss "_tags" "opam")) tags_only
  in
  let lint_deps ~exclude ~opam ~tags =
    begin
      Topkg_care_ocamlbuild.package_tags ~roots:true tags
      >>= fun tags -> Topkg_care_opam.File.fields opam
      >>| fun fields ->
      let exclude = String.Set.union exclude lint_deps_default_excludes in
      let keep id =
        not (String.Set.mem id exclude) &&
        not (String.is_prefix ~affix:"conf-" id)
      in
      let opam_deps = Topkg_care_opam.File.deps ~opts:true fields in
      let opam = String.Set.filter keep opam_deps in
      let tags = String.Set.filter keep tags in
      let opam_only = String.Set.diff opam tags in
      let tags_only = String.Set.diff tags opam in
      if String.Set.is_empty opam_only && String.Set.is_empty tags_only
      then None
      else Some (opam_only, tags_only)
    end
    |> R.reword_error_msg ~replace:true
      (fun msg -> R.msgf "could not lint dependencies: %s" msg)
  in
  begin
    Fpath.of_string opam
    >>= fun opam -> match exclude with
    | None ->
        Ok (lint_disabled @@
            Fmt.(str_like
                   stdout "opam dependency linting for %a" pp_path opam))
    | Some exclude ->
        let tags = Fpath.v "_tags" in
        let exclude = String.Set.of_list exclude in
        lint_deps ~exclude ~opam ~tags
        >>| function
        | None ->
            Logs.app (fun m -> m "%a @[opam file %a@ and %a dependency check."
                         pp_status `Ok pp_path opam pp_path tags);
            errs
        | Some miss ->
            Logs.app
              (fun m -> m "%a @[<v>@[File %a and %a dependency check:@]@,%a@]"
                  pp_status `Fail pp_path opam pp_path tags
                  pp_deps_mismatches miss);
            errs + 1
  end
  |> Logs.on_error_msg ~use:(fun () -> errs + 1)

let lint_deps p =
  begin
    pkg p >>= fun p -> match Topkg.Private.Pkg.lint_opams p with
    | [] -> Ok (lint_log "No opam file to dependency lint")
    | opams -> Ok (List.fold_left lint_opam_deps 0 opams)
  end
  |> Logs.on_error_msg ~use:(fun () -> 1)

type lint = [ `Custom | `Std_files | `Meta | `Opam | `Deps ]

let lints =
  [`Custom, lint_custom;
   `Std_files, lint_std_files;
   `Meta, lint_metas;
   `Opam, lint_opams;
   `Deps, lint_deps ]

let lint_all = List.map fst lints

let lint ?(ignore_pkg = false) p ~dir todo =
  let lint pkg =
    let do_lint acc (l, f) = acc + if List.mem l todo then f pkg else 0 in
    match List.fold_left do_lint 0 lints with
    | 0 ->
        Logs.app (fun m -> m "%a lint@ %a %a"
                     pp_status `Ok pp_path dir
                     Fmt.(styled `Green (any "success")) ()); 0
    | n ->
        Logs.app (fun m -> m "%a lint@ %a@ %a:@ %d@ errors."
                     pp_status `Fail pp_path dir
                     Fmt.(styled `Red (any "failure")) () n); 1
  in
  let p =
    if ignore_pkg then Ok (empty p) else
    pkg p >>| fun _ -> p (* verify the pkg_file exists *)
  in
  p >>= fun p -> OS.Dir.with_current dir lint p
