Source file tool.ml

(*
 * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
 * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
 * Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Action.Syntax
open DSL

let src = Logs.Src.create "functoria.tool" ~doc:"functoria library"

module Log = (val Logs.src_log src : Logs.LOG)

module type S = sig
  val name : string
  val version : string
  val packages : package list
  val create : job impl list -> job impl
end

let check_version ~name ~version data =
  let ( let* ) = Result.bind in
  let extract_version v =
    try Ok (Scanf.sscanf v "%u.%u.%u" (fun ma mi pa -> (ma, mi, pa))) with
    | Scanf.Scan_failure _ | End_of_file -> (
        try Ok (Scanf.sscanf v "%u.%u" (fun ma mi -> (ma, mi, 0))) with
        | Scanf.Scan_failure _ | End_of_file -> (
            try Ok (Scanf.sscanf v "%u" (fun ma -> (ma, 0, 0)))
            with Scanf.Scan_failure _ | Failure _ | End_of_file ->
              Error ("couldn't extract version (%u) from " ^ v))
        | Failure f ->
            Error ("couldn't extract version (%u.%u) from " ^ v ^ ": " ^ f))
    | Failure f ->
        Error ("couldn't extract version (%u.%u.%u) from " ^ v ^ ": " ^ f)
  in
  if String.equal version ("%%" ^ "VERSION%%") then (
    Log.info (fun m ->
        m "Skipping version check, since our_version is not watermarked");
    Ok ())
  else
    let* version' = extract_version version in
    let first_str = "(* " ^ name ^ " " in
    let fl = String.length first_str in
    if fl < String.length data && String.equal (String.sub data 0 fl) first_str
    then
      let* lower_version, upper_version =
        let vs =
          String.split_on_char ' '
            (String.sub data fl (String.length data - fl))
        in
        let rec go lower upper = function
          | "&" :: tl -> go lower upper tl
          | ">=" :: v :: tl ->
              if lower = None then go (Some v) upper tl
              else Error "Bad comment, multiple >= constraints"
          | "<" :: v :: tl ->
              if upper = None then go lower (Some v) tl
              else Error "Bad comment, multiple < constraints"
          | "*)" :: _ -> Ok (lower, upper)
          | "" :: tl -> go lower upper tl
          | _ ->
              Error
                (Fmt.str
                   "Unknown first line, must be (* %s [>= a.b.c] [&] [< d.e.f] \
                    *)"
                   name)
        in
        go None None vs
      in
      let cmp ~eq (ma, mi, pa) (ma', mi', pa') =
        ma > ma'
        || (ma = ma' && mi > mi')
        || (ma = ma' && mi = mi' && pa > pa')
        || (ma = ma' && mi = mi' && pa = pa' && eq)
      in
      let* () =
        match lower_version with
        | None -> Ok ()
        | Some v ->
            let* v' = extract_version v in
            if cmp ~eq:true version' v' then Ok ()
            else
              Error
                (Fmt.str
                   "Version mismatch: required is %s >= %s, but %s is \
                    installed. Please upgrade your installation (opam update; \
                    opam install '%s>=%s')"
                   name v version name v)
      in
      match upper_version with
      | None -> Ok ()
      | Some v ->
          let* v' = extract_version v in
          if cmp ~eq:false v' version' then Ok ()
          else
            Error
              (Fmt.str
                 "Version mismatch: required is %s < %s, but %s is installed. \
                  Please downgrade your installation (opam update; opam \
                  install '%s<%s')"
                 name v version name v)
    else Ok ()

module Make (P : S) = struct
  module Filegen = Filegen.Make (P)

  let build_dir t = Fpath.parent t.Cli.config_file
  let context_file t = Context_cache.file ~name:P.name t

  let add_context_file t argv =
    match t.Cli.context_file with
    | Some _ -> Action.ok argv
    | None ->
        let file = context_file t in
        let+ is_file = Action.is_file file in
        if is_file then
          Array.append argv [| "--context"; Fpath.to_string file |]
        else (* should only happen when doing configure --help *) argv

  let run_cmd ?ppf ?err_ppf command =
    let err = match err_ppf with None -> None | Some f -> Some (`Fmt f) in
    let out = match ppf with None -> None | Some f -> Some (`Fmt f) in
    Action.run_cmd ?err ?out command

  let re_exec_cli t argv =
    let* argv = add_context_file t argv in
    let args = Bos.Cmd.of_list (List.tl (Array.to_list argv)) in
    let config_exe =
      Fpath.(v "_build" / "default" // build_dir t / "config.exe")
    in
    let command = Bos.Cmd.(v (p config_exe) %% args) in
    Action.run_cmd_cli command

  (* Generate the base dune and dune-project files *)
  let generate_base_dune t =
    let dune_config_path = Fpath.(build_dir t / "dune.config") in
    Log.info (fun m -> m "Generating: %a (base)" Fpath.pp dune_config_path);
    let dune_config =
      Dune.base ~config_ml_file:t.Cli.config_file ~packages:P.packages
    in
    let dune_config = Fmt.str "%a\n%!" Dune.pp dune_config in
    let* () = Filegen.write dune_config_path dune_config in
    let dune_path = Fpath.(build_dir t / "dune") in
    let dune = Fmt.str "(include dune.config)" in
    Filegen.write dune_path dune

  let dune_workspace_path t =
    Fpath.(build_dir t / P.name / "dune-workspace.config")

  let generate_base_dune_workspace t =
    let dune_workspace_path = dune_workspace_path t in
    Log.info (fun m -> m "Generating: %a (base)" Fpath.pp dune_workspace_path);
    let dune = Dune.base_workspace in
    let dune = Fmt.str "%a\n%!" Dune.pp dune in
    Filegen.write dune_workspace_path dune

  let generate_base_dune_project () =
    let dune_project_path = Fpath.(v "dune-project") in
    Log.info (fun m -> m "Generating: %a (base)" Fpath.pp dune_project_path);
    let dune = Dune.v Dune.base_project in
    let dune = Fmt.str "%a\n%!" Dune.pp dune in
    Filegen.write dune_project_path dune

  let build_config_exe t ?ppf ?err_ppf () =
    let dune_workspace_path = dune_workspace_path t in
    let command =
      Bos.Cmd.(
        v "dune"
        % "build"
        % p Fpath.(build_dir t / "config.exe")
        % "--root"
        % "."
        % "--workspace"
        % p dune_workspace_path)
    in
    run_cmd ?ppf ?err_ppf command

  let write_context t argv = Context_cache.write (context_file t) argv
  let remove_context t = Action.rm (context_file t)

  (* Generated a project skeleton and try to compile config.exe. *)
  let generate_project_skeleton ~save_args t ?ppf ?err_ppf argv =
    let* _ = Action.mkdir Fpath.(build_dir t / P.name) in
    let* () = generate_base_dune_workspace t in
    let* () = generate_base_dune_project () in
    let* () = generate_base_dune t in
    let* () = if save_args then write_context t argv else Action.ok () in
    (* try to compile config.exe to detect early compilation errors. *)
    build_config_exe t ?ppf ?err_ppf ()

  let exit_err t = function
    | Ok v -> v
    | Error (`Msg m) ->
        flush_all ();
        if m <> "" then Fmt.epr "%a\n%!" Fmt.(styled (`Fg `Red) string) m;
        if not t.Cli.dry_run then exit 1 else Fmt.epr "(exit 1)\n%!"

  let handle_parse_args_no_config ?help_ppf ?err_ppf (`Msg error) argv =
    let context =
      (* Extract all the keys directly. Useful to pre-resolve the keys
         provided by the specialized DSL. *)
      let base_keys = Engine.keys @@ Impl.abstract @@ P.create [] in
      Cmdliner.Term.(const (fun _ -> Action.ok ()) $ Key.context base_keys)
    in
    let result =
      Cli.eval ?help_ppf ?err_ppf ~name:P.name ~version:P.version
        ~configure:context ~query:context ~describe:context ~clean:context
        ~help:context ~mname:P.name argv
    in
    let ok = Action.ok () in
    let error = Action.error error in
    match result with `Version | `Help | `Ok (Cli.Help _) -> ok | _ -> error

  let with_project_skeleton ~save_args t ?ppf ?err_ppf argv f =
    let file = t.Cli.config_file in
    let* is_file = Action.is_file file in
    if not is_file then
      let msg = Fmt.str "configuration file %a missing" Fpath.pp file in
      handle_parse_args_no_config ?help_ppf:ppf ?err_ppf (`Msg msg) argv
    else
      let* () = generate_project_skeleton ~save_args t ?ppf ?err_ppf argv in
      f ()

  let action_run t a =
    if not t.Cli.dry_run then Action.run a
    else
      let env = Action.env ~files:(`Passtrough (Fpath.v ".")) () in
      let dom = Action.dry_run ~env a in
      List.iter
        (fun line ->
          Fmt.epr "%a %s\n%!" Fmt.(styled (`Fg `Cyan) string) "*" line)
        dom.logs;
      dom.result

  let clean_files ?ppf ?err_ppf args =
    let dune_clean () =
      let* var = Action.get_var "INSIDE_FUNCTORIA_TESTS" in
      match var with
      | Some "1" | Some "" -> Action.rm Fpath.(build_dir args / ".merlin")
      | _ -> run_cmd ?ppf ?err_ppf Bos.Cmd.(v "dune" % "clean")
    in
    let rm_gen_files () =
      let* files = Action.ls (Fpath.v ".") (fun _ -> true) in
      let files = List.sort Fpath.compare files in
      let files =
        List.filter_map
          (fun file ->
            if Fpath.parent file <> Fpath.v "./" then None
            else
              let base, ext = Fpath.split_ext file in
              let base = Fpath.basename base in
              match (base, ext) with
              | ("Makefile" | "dune-project" | "dune-workspace"), "" ->
                  Some file
              | _ ->
                  Log.info (fun f -> f "Skipped %a" Fpath.pp file);
                  None)
          files
      in
      let* () = Action.List.iter ~f:Filegen.rm files in
      let* () = remove_context args in
      let* () = Filegen.rm Fpath.(build_dir args / "dune") in
      let* () = Filegen.rm Fpath.(build_dir args / "dune.build") in
      Filegen.rm Fpath.(build_dir args / "dune.config")
    in
    let* () = dune_clean () in
    rm_gen_files ()

  (* App builder configuration *)
  let configure ({ args; _ } : _ Cli.configure_args) ?ppf ?err_ppf argv =
    let file = args.Cli.config_file in
    let* () =
      let* is_file = Action.is_file file in
      if not is_file then
        Action.errorf "configuration file %a missing" Fpath.pp file
      else Action.ok ()
    in
    let* () =
      let* data =
        let cmd = Bos.Cmd.(v "head" % "-1" % p file) in
        Action.run_cmd_out ~err:`Null cmd
      in
      let version =
        let v = P.version in
        if String.length v > 0 && String.get v 0 = 'v' then
          String.sub v 1 (String.length v - 1)
        else v
      in
      Result.fold
        ~ok:(fun () -> Action.ok ())
        ~error:(fun msg -> Action.error msg)
        (check_version ~name:P.name ~version data)
    in
    (* Files to build config.ml *)
    with_project_skeleton ~save_args:true args ?ppf ?err_ppf argv @@ fun () ->
    Log.info (fun f -> f "Set-up config skeleton.");
    (* Launch config.exe: additional generated files for the application. *)
    re_exec_cli args argv

  let try_to_re_exec args ?ppf ?err_ppf argv =
    with_project_skeleton ~save_args:false args ?ppf ?err_ppf argv @@ fun () ->
    re_exec_cli args argv

  let error t = try_to_re_exec t
  let query (t : 'a Cli.query_args) = try_to_re_exec t.args
  let describe (t : 'a Cli.describe_args) = try_to_re_exec t.args
  let help (t : 'a Cli.help_args) = try_to_re_exec t

  let clean args ?ppf ?err_ppf argv =
    let config = args.Cli.config_file in
    let* () =
      let* is_file = Action.is_file config in
      if is_file then try_to_re_exec args ?ppf ?err_ppf argv else Action.ok ()
    in
    clean_files args

  let run args action = action |> action_run args |> exit_err args
  let pp_unit _ _ = ()

  let run_with_argv ?help_ppf ?err_ppf argv =
    let t = Cli.peek ~with_setup:true ~mname:P.name argv in
    match t with
    | `Version ->
        Log.info (fun l -> l "version");
        Fmt.pr "%s\n%!" P.version
    | `Error (Some t, _) ->
        Log.info (fun l -> l "error: %a" (Cli.pp_args pp_unit) t);
        run t @@ error t ?ppf:help_ppf ?err_ppf argv
    | `Error (None, _) ->
        let action =
          handle_parse_args_no_config ?help_ppf ?err_ppf (`Msg "") argv
        in
        let args = Cli.default_args in
        action_run args action |> exit_err args
    | `Ok t -> (
        Log.info (fun l -> l "run: %a" (Cli.pp_action pp_unit) t);
        let run = run (Cli.args t) in
        let ppf = help_ppf in
        match t with
        | Configure t -> run @@ configure t ?ppf ?err_ppf argv
        | Clean t -> run @@ clean t ?ppf ?err_ppf argv
        | Query t -> run @@ query t ?ppf ?err_ppf argv
        | Describe t -> run @@ describe t ?ppf ?err_ppf argv
        | Help t -> run @@ help t ?ppf ?err_ppf argv)

  let run () = run_with_argv Sys.argv
end