Source file BuildValidation.ml

type render_summary = {
  diag_file : string option;
  diag_error_code : string option;
  diag_hints : string list;
  diag_line : int option;
  diag_col : int option;
}

let range_into_problem_location ~(source : BuildCore.Io.file_object) range :
    MlFront_Thunk.BuildWriters.Standard.problem_location list
    BuildCore.Alacarte_xpromise_apparatus.Promise.t =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let* read_result = BuildCore.Io.read_all source in
  match read_result with
  | `Error _ | `ExceededSizeLimit _ -> return []
  | `Content source_code ->
      return
        [
          MlFront_Thunk.BuildWriters.Standard.
            {
              origin = Some (BuildCore.Io.file_origin source);
              source = source_code;
              range;
            };
        ]

let find_first_duplicate compare projection consider =
  let sorted =
    List.sort
      (fun (p_c1, _c1) (p_c2, _c2) -> compare p_c1 p_c2)
      (List.map (fun c -> (projection c, c)) consider)
  in
  (* Go through all the values in "consider", and if any subsequent value is
     equivalent to the prior value, then that is a duplicate. *)
  let rec aux = function
    | [] -> None
    | [ _single ] -> None
    | (p_x, x) :: ((p_y, y) :: _ as rest) ->
        if compare p_x p_y = 0 then Some (x, y) else aux rest
  in
  aux sorted

let verify_nonoverlapping_subpaths_for_getobject ~config ~fail ~initiator
    ~source (commands : MlFront_Thunk.ThunkAst.precommand_instance list) =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let rec aux acc (cmds : MlFront_Thunk.ThunkAst.precommand_instance list) =
    match cmds with
    | [] -> acc
    | {
        precommand = _range, GetObject { command_output; _ };
        precommand_canonical_id = _;
      }
      :: rest -> begin
        match command_output with
        | range, OutputDir { dir; strip = _ } -> aux ((range, dir) :: acc) rest
        | range, OutputFile file -> aux ((range, file) :: acc) rest
      end
    | _other_command :: rest -> aux acc rest
  in
  let getobject_destination_terms :
      (Fmlib_parse.Position.range * MlFront_Thunk.ThunkCommand.evalable_term)
      list =
    aux [] commands
  in
  let getobject_destinations :
      ( (Fmlib_parse.Position.range * MlFront_Core.FilePath.t) list,
        Fmlib_parse.Position.range
        * string
        * MlFront_Thunk.ThunkCommand.evalable_term )
      result =
    let ( let* ) = Result.bind in
    List.fold_right
      (fun (range, term) acc ->
        let* acc = acc in
        match BuildTask.eval_term_as_filepath ~config ~initiator term with
        | Error e -> Error (range, e, term)
        | Ok fp -> Ok ((range, fp) :: acc))
      getobject_destination_terms (Ok [])
  in
  match getobject_destinations with
  | Error (range, msg, term) ->
      let* err = range_into_problem_location ~source range in
      fail ~error_code:"6e3d1e38"
        ~cant_do:
          (Printf.sprintf "evaluate the expression `%s`"
             (MlFront_Thunk.ThunkCommand.evalable_term_to_shell term))
        ~because:msg ~error_locations:err ~recommendations:[] ()
  | Ok getobject_destinations ->
  (* Do a strict subpath check. We can recommend `install-object` for these. *)
  match
    MlFront_Core.FilePath.find_first_subpath_opt ~strict:() snd
      getobject_destinations
  with
  | None -> return (Ok ())
  | Some ((parentrange, parent), (childrange, child)) ->
      let* error_locations1 = range_into_problem_location ~source parentrange in
      let* error_locations2 = range_into_problem_location ~source childrange in
      fail ~error_code:"6e3d1e38"
        ~cant_do:
          (Format.asprintf "get the object `%a`" MlFront_Core.FilePath.pp child)
        ~because:
          (Format.asprintf "the output overlaps with another output `%a`"
             MlFront_Core.FilePath.pp parent)
        ~error_locations:(error_locations1 @ error_locations2)
        ~recommendations:
          [
            "Use the `install-object` command instead of `get-object` if you \
             truly mean to squish multiple outputs into the same directory \
             trees.";
          ]
        ()

let verify_unique_paths_for_objectcommands ~config ~fail ~initiator ~source
    (commands : MlFront_Thunk.ThunkAst.precommand_instance list) =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let rec aux acc (cmds : MlFront_Thunk.ThunkAst.precommand_instance list) =
    match cmds with
    | [] -> acc
    | {
        precommand = _range, GetObject { command_output; _ };
        precommand_canonical_id = _;
      }
      :: rest -> begin
        match command_output with
        | range, OutputDir { dir; strip = _ } ->
            aux ((range, `Get, dir) :: acc) rest
        | range, OutputFile file -> aux ((range, `Get, file) :: acc) rest
      end
    | {
        precommand = _range, InstallObject { command_output; _ };
        precommand_canonical_id = _;
      }
      :: rest -> begin
        match command_output with
        | range, OutputDir { dir; strip = _ } ->
            aux ((range, `Install, dir) :: acc) rest
        | range, OutputFile file -> aux ((range, `Install, file) :: acc) rest
      end
    | {
        precommand = _range, GetBundle { command_output; _ };
        precommand_canonical_id = _;
      }
      :: rest -> begin
        match command_output with
        | range, OutputDir { dir; strip = _ } ->
            aux ((range, `GetBundle, dir) :: acc) rest
        | range, OutputFile file -> aux ((range, `GetBundle, file) :: acc) rest
      end
    | {
        precommand = _range, GetAsset { command_output; _ };
        precommand_canonical_id = _;
      }
      :: rest -> begin
        match command_output with
        | range, OutputDir { dir; strip = _ } ->
            aux ((range, `GetAsset, dir) :: acc) rest
        | range, OutputFile file -> aux ((range, `GetAsset, file) :: acc) rest
      end
    | {
        precommand = _range, (PipeObject _ | EnterObject _);
        precommand_canonical_id = _;
      }
      :: rest ->
        (* No command output. Continue with rest. *)
        aux acc rest
  in
  let object_destination_terms :
      (Fmlib_parse.Position.range
      * _
      * MlFront_Thunk.ThunkCommand.evalable_term)
      list =
    aux [] commands
  in
  (* [install-object] are allowed to have duplicates. So remove the
     duplicates. But can't use [get-object -d DIR1] and
     [install-object -d DIR1] simultaneously, so keep [install-object]
     in the comparisons. *)
  let object_destination_terms =
    List.sort_uniq
      (fun (i1, (_range1, typ1, _term1)) (i2, (_range2, typ2, _term2)) ->
        match (typ1, typ2) with
        | `Install, `Install -> 0
        | _ ->
            (* don't deduplicate if non-Install *)
            i2 - i1)
      (List.mapi (fun i v -> (i, v)) object_destination_terms)
    |> List.map snd
  in
  (* *)
  let object_destinations :
      ( (Fmlib_parse.Position.range * _ * MlFront_Core.FilePath.t) list,
        Fmlib_parse.Position.range
        * string
        * MlFront_Thunk.ThunkCommand.evalable_term )
      result =
    let ( let* ) = Result.bind in
    List.fold_right
      (fun (range, typ, term) acc ->
        let* acc = acc in
        match BuildTask.eval_term_as_filepath ~config ~initiator term with
        | Error e -> Error (range, e, term)
        | Ok fp -> Ok ((range, typ, fp) :: acc))
      object_destination_terms (Ok [])
  in
  match object_destinations with
  | Error (range, msg, term) ->
      let* err = range_into_problem_location ~source range in
      fail ~error_code:"ed248cd8"
        ~cant_do:
          (Printf.sprintf "evaluate the expression `%s`"
             (MlFront_Thunk.ThunkCommand.evalable_term_to_shell term))
        ~because:msg ~error_locations:err ~recommendations:[] ()
  | Ok object_destinations ->
  (* Do an equality check *)
  match
    find_first_duplicate MlFront_Core.FilePath.compare
      (fun (_, _, fp) -> fp)
      object_destinations
  with
  | None -> return (Ok ())
  | Some ((onerange, onetyp, _one), (anotherrange, _anothertyp, another)) ->
      let* error_locations1 = range_into_problem_location ~source onerange in
      let* error_locations2 =
        range_into_problem_location ~source anotherrange
      in
      fail ~error_code:"e0067628"
        ~cant_do:
          (match onetyp with
          | `Get -> "get object"
          | `Install -> "install object"
          | `GetAsset -> "get asset"
          | `GetBundle -> "get bundle"
          | `Resume -> "resume object")
        ~because:
          (Format.asprintf "two commands share the same output path `%a`"
             MlFront_Core.FilePath.pp another)
        ~error_locations:(error_locations1 @ error_locations2)
        ~recommendations:[] ()

let verify_unique_pipes_for_objectcommands ~fail ~source
    (commands : MlFront_Thunk.ThunkAst.precommand_instance list) =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let rec aux acc (cmds : MlFront_Thunk.ThunkAst.precommand_instance list) =
    match cmds with
    | [] -> acc
    | {
        precommand_canonical_id = _;
        precommand = _range, PipeObject { pipe = range, pipename; _ };
      }
      :: rest ->
        aux ((range, `Pipe, pipename) :: acc) rest
    | {
        precommand_canonical_id = _;
        precommand =
          ( _range,
            ( GetObject _ | InstallObject _ | EnterObject _ | GetBundle _
            | GetAsset _ ) );
      }
      :: rest ->
        (* No command output. Continue with rest. *)
        aux acc rest
  in
  let pipe_terms : (Fmlib_parse.Position.range * _ * string) list =
    aux [] commands
  in
  (* Do an equality check *)
  match
    find_first_duplicate String.compare
      (fun (_, _typ, pipeline) -> pipeline)
      pipe_terms
  with
  | None -> return (Ok ())
  | Some ((onerange, onetyp, _one), (anotherrange, _anothertyp, another)) ->
      let* error_locations1 = range_into_problem_location ~source onerange in
      let* error_locations2 =
        range_into_problem_location ~source anotherrange
      in
      fail ~error_code:"cc40063b"
        ~cant_do:(match onetyp with `Pipe -> "pipe object")
        ~because:
          (Format.asprintf "two commands share the same pipe `%s`" another)
        ~error_locations:(error_locations1 @ error_locations2)
        ~recommendations:[] ()

let render_trace ?downgrade_errors_into_warnings ~cant_do
    ~(observer_result :
       (module MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)) ~source_file
    trace =
  let module ResultObserver = (val observer_result) in
  (* Identify root cause (the deepest item in the backtrace) *)
  let rootcause_origin, rootcause_ranges, rootcause_source, rootcause_code =
    let ranges0 = Fmlib_parse.Position.[ (start, start) ] in
    let ( let* ) = BuildCore.Alacarte_xpromise_apparatus.Promise.bind in
    let rec aux ((origin, ranges, (source : string option), _item) as acc) =
      function
      | [] -> BuildCore.Alacarte_xpromise_apparatus.Promise.return acc
      | first_item :: rest_items ->
          let open MlFront_Thunk.BuildWriters.Standard in
          let origin', range', source' =
            match problem_location_backtrace_item first_item with
            | [] -> (origin, ranges, source)
            | { origin; range; source } :: rest
              when List.for_all
                     (fun problem ->
                       String.equal (problem_source problem) source)
                     rest ->
                (origin, range :: List.map problem_range rest, Some source)
            | { origin; range; source } :: _rest ->
                (* Since we have dissimilar sources, we display the first one *)
                (origin, [ range ], Some source)
          in
          aux
            (origin', range', source', Some (code_backtrace_item first_item))
            rest_items
    in
    let promise =
      let* source0_result = BuildCore.Io.read_all source_file in
      let source0 =
        match source0_result with
        | `Error _ | `ExceededSizeLimit _ -> None
        | `Content source_code -> Some source_code
      in
      aux (None, ranges0, source0, None) trace
    in
    BuildInstance.Launcher.run_isolated_promise promise
  in
  let marker_message =
    let errors =
      List.filter_map
        (fun item ->
          match item with
          | MlFront_Thunk.BuildWriters.Standard.InfoBacktraceItem' _ -> None
          | MlFront_Thunk.BuildWriters.Standard.ErrorBacktraceItem'
              {
                error_code = _;
                cant_do;
                because;
                error_locations = _;
                recommendations = _;
              } ->
              Some
                (Printf.sprintf "Could not %s%s." cant_do
                   (if because = "" then "" else " because " ^ because)))
        trace
    in
    match errors with
    | [] -> "Could not recover the error."
    | _ -> String.concat "\n" errors
  in
  let summary =
    let maybe_first_range =
      match rootcause_ranges with
      | [] -> None
      | first_range :: _rest -> Some first_range
    in
    let rootcause_line, rootcause_col =
      match maybe_first_range with
      | None -> (None, None)
      | Some (start, _end_) ->
          (* Fmlib is zero-based *)
          ( Some (1 + Fmlib_parse.Position.line start),
            Some (1 + Fmlib_parse.Position.column start) )
    in
    {
      diag_file = rootcause_origin;
      diag_error_code = rootcause_code;
      diag_hints = [];
      diag_line = rootcause_line;
      diag_col = rootcause_col;
    }
  in
  let r =
    ResultObserver.(
      create_report ?code:rootcause_code
        ~is_error:(downgrade_errors_into_warnings = None)
        ()
      |> with_message (Printf.sprintf "Could not %s." cant_do))
  in
  let r =
    List.fold_left
      (fun r range ->
        ResultObserver.add_marker ~marker_message ~origin:rootcause_origin
          ~range r)
      r rootcause_ranges
  in

  (* Add info as notes and recommendations as hints. *)
  let r, summary =
    List.fold_left
      (fun (acc_r, acc_summary) item ->
        match item with
        | MlFront_Thunk.BuildWriters.Standard.InfoBacktraceItem'
            { info_code = _; message; info_locations = _ } ->
            ( ResultObserver.add_hint message acc_r,
              {
                acc_summary with
                diag_hints = message :: acc_summary.diag_hints;
              } )
        | MlFront_Thunk.BuildWriters.Standard.ErrorBacktraceItem'
            {
              error_code = _;
              cant_do = _;
              because = _;
              error_locations = _;
              recommendations;
            } ->
            List.fold_left
              (fun (acc2_r, acc2_summary) recommendation ->
                ( ResultObserver.add_hint recommendation acc2_r,
                  {
                    acc2_summary with
                    diag_hints = recommendation :: acc2_summary.diag_hints;
                  } ))
              (acc_r, acc_summary) recommendations)
      (r, summary) trace
  in

  let rendered =
    ResultObserver.render ~origin:rootcause_origin
      ~source:
        (Option.value ~default:"<source code is too big>" rootcause_source)
      r
  in
  (rendered, summary)

let validate_precommands ?downgrade_errors_into_warnings ~config ~source
    (commands : MlFront_Thunk.ThunkAst.precommand_instance list) =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let fail ~error_code ~cant_do ~because ~error_locations ~recommendations () =
    let observer_result = BuildConfig.observer_result config in
    let traceitem : MlFront_Thunk.BuildWriters.Standard.backtrace_item =
      MlFront_Thunk.BuildWriters.Standard.ErrorBacktraceItem'
        { error_code; cant_do; because; error_locations; recommendations }
    in
    let rendered, _summary =
      render_trace ?downgrade_errors_into_warnings ~cant_do ~observer_result
        ~source_file:source [ traceitem ]
    in
    return (Error rendered)
  in
  (* Validate the AST. This is "late" validation because we need to evaluate
     any terms inside the precommands, and this is where we have the placeholders
     to expand those terms. *)

  (* We don't need a real initiator when checking correctness.
     We can use mock paths that are easy to read when there are problems.. *)
  let mock_initiator =
    BuildTask.CommandInitiated
      {
        cid_command = "01";
        cid_thunk_for_output = "02";
        basedir = None;
        request_slot = None;
      }
  in
  let* verify_result =
    verify_nonoverlapping_subpaths_for_getobject ~config ~fail
      ~initiator:mock_initiator ~source commands
  in
  match verify_result with
  | Error _ as e -> return e
  | Ok () -> (
      let* verify_result =
        verify_unique_paths_for_objectcommands ~config ~fail
          ~initiator:mock_initiator ~source commands
      in
      match verify_result with
      | Error _ as e -> return e
      | Ok () -> verify_unique_pipes_for_objectcommands ~fail ~source commands)