Source file ShellVSL.ml

let file_checksum_location :
    MlFront_Thunk.ThunkAst.asset_checksum -> Fmlib_parse.Position.range =
  function
  | `Sha1 (range, _) | `Sha256 (range, _) -> range

(** check if the directory or its parent or its grandparent contains either the
    file [.tracestore] or [.valuestore]. *)
let dir_or_ancestor_has_dot_tracestore_or_valuestore dir =
  let file_exists fp =
    try Sys.file_exists (MlFront_Core.FilePath.to_string fp)
    with Sys_error _ -> false
  in
  let open MlFront_Core.FilePath in
  let rec aux n dir =
    if n <= 0 then false
    else begin
      let dot_tracestore = append_exn ".tracestore" dir in
      let dot_valuestore = append_exn ".valuestore" dir in
      if file_exists dot_tracestore || file_exists dot_valuestore then true
      else aux (n - 1) (parent dir)
    end
  in
  aux 2 dir

let mkdir ~on_fail fp =
  let open BuildInstance.Syntax in
  let fp_dir = BuildCore.Io.disk_dir fp in
  let* createdir_result =
    lift_promise @@ BuildCore.Io.create_directory fp_dir
  in
  match createdir_result with
  | `Error e ->
      on_fail ~error_code:"8d3e888a"
        ~because:
          (Printf.sprintf "while making `%s` got the error `%s`"
             (BuildCore.Io.directory_origin fp_dir)
             e)
        ~recommendations:[] ()
  | `Created -> return ()

let rmfile ~on_fail fp =
  let open BuildInstance.Syntax in
  let fp_file = BuildCore.Io.disk_file fp in
  let* rmdir_result = lift_promise @@ BuildCore.Io.delete_file fp_file in
  match rmdir_result with
  | `Error e ->
      on_fail ~error_code:"3782d9b2"
        ~because:
          (Printf.sprintf "while removing `%s` got the error `%s`"
             (BuildCore.Io.file_origin fp_file)
             e)
        ~recommendations:[] ()
  | `Deleted -> return ()

let verify_download_checksum ~on_fail ~mirror ~unverified_file ~actual_checksum
    ~file_checksum ~file_sz () =
  let open BuildInstance.Syntax in
  let algo, name, (cksum_range, expected_cksum), to_known =
    match (file_checksum : MlFront_Thunk.ThunkAst.asset_checksum) with
    | `Sha1 cksum -> (`Sha1, "SHA1", cksum, fun v sz -> `KnownSha1 (v, sz))
    | `Sha256 cksum ->
        (`Sha256, "SHA256", cksum, fun v sz -> `KnownSha256 (v, sz))
  in
  let* checksum_result =
    match actual_checksum with
    | `KnownSha256 actual when algo = `Sha256 -> return (`Checksum actual)
    | `KnownSha1 actual when algo = `Sha1 -> return (`Checksum actual)
    | _ ->
        lift_promise
        @@ BuildCore.Io.checksum_file ~algo
             (BuildCore.Io.disk_file unverified_file)
  in
  match checksum_result with
  | `Error e ->
      return
      @@ ShellCore.FailedRetryableAttempt
           {
             error_code = ExecErrorCodes.ChecksumErrors.uncalculable_checksum;
             because =
               Printf.sprintf
                 "the %s checksum could not be calculated due to error `%s`"
                 name e;
             recommendations = [];
             location_if_checksum_error = Some cksum_range;
           }
  | `Checksum (actual_checksum, actual_sz) -> begin
      match (actual_checksum, expected_cksum, actual_sz, file_sz) with
      | actual, expected, _, _ when not (String.equal actual expected) -> begin
          let* () = rmfile ~on_fail unverified_file in
          return
          @@ ShellCore.FailedRetryableAttempt
               {
                 error_code = ExecErrorCodes.ChecksumErrors.mismatched_checksum;
                 because =
                   Printf.sprintf "the computed %s checksum `%s` was unexpected"
                     name actual;
                 recommendations =
                   [
                     Printf.sprintf
                       "This may have been a corrupted download, or an attempt \
                        to compromise security. Check the source `%s`. If \
                        unsure how to proceed, contact your system or security \
                        administrator."
                       mirror;
                     Autofix.create ~problematic_text:expected
                       ~replace_with:actual
                       ~condition:
                         "only if the checksum is valid; use `--autofix` to \
                          automatically correct it"
                       ()
                     |> Autofix.hint;
                   ];
                 location_if_checksum_error = Some cksum_range;
               }
        end
      | _, _, actual, Some (size_range, expected)
        when not (Int64.equal actual expected) -> begin
          let* () = rmfile ~on_fail unverified_file in
          return
          @@ ShellCore.FailedRetryableAttempt
               {
                 error_code = ExecErrorCodes.ChecksumErrors.mismatched_checksum;
                 because =
                   Printf.sprintf "the real file size `%Ld` was unexpected"
                     actual;
                 recommendations =
                   [
                     Printf.sprintf
                       "This may have been a corrupted download, or an attempt \
                        to compromise security. Check the source `%s`. If \
                        unsure how to proceed, contact your system or security \
                        administrator."
                       mirror;
                     Autofix.create ~problematic_text:(Int64.to_string expected)
                       ~replace_with:(Int64.to_string actual)
                       ~condition:
                         "only if the size is valid; use `--autofix` to \
                          automatically correct it"
                       ()
                     |> Autofix.hint;
                   ];
                 location_if_checksum_error = Some size_range;
               }
        end
      | _ ->
          return
            (ShellCore.Downloaded
               {
                 origin = MlFront_Core.FilePath.to_string unverified_file;
                 downloaded_checksum = to_known actual_checksum actual_sz;
               })
    end

let copy_local ?intermediate ~staging_dir ~localbasepath ~file_path
    destination_file =
  let localbasepath = MlFront_Core.FilePath.of_string_exn localbasepath in
  let open BuildInstance.Syntax in
  let local_file = MlFront_Core.FilePath.append_exn file_path localbasepath in
  BuildCore.Io.copy_file_or_dir_to_file_and_sha256_or_fail ?intermediate
    ~src:(BuildCore.Io.disk_file local_file)
    ~dest:(BuildCore.Io.disk_file destination_file)
    ~staging_dir:(BuildCore.Io.disk_dir staging_dir)
    ~on_error:(fun because ->
      return
        (ShellCore.FailedRetryableAttempt
           {
             error_code = "956bc988";
             because;
             recommendations = [];
             location_if_checksum_error = None;
           }))
    (fun sha256 sz ->
      return
        (ShellCore.Downloaded
           {
             origin = MlFront_Core.FilePath.to_string local_file;
             downloaded_checksum = `KnownSha256 (sha256, sz);
           }))

let download ?verbose ?debug_connection ?intermediate ?assettrace ~staging_dir
    ~autofix
    ~(on_fail :
       location_if_checksum_error:Fmlib_parse.Position.range option ->
       error_code:string ->
       because:string ->
       recommendations:string list ->
       unit ->
       unit BuildInstance.Syntax.cont) ~file_path ~file_checksum ~file_sz
    ~origin_mirrors:(first_mirror, rest_mirrors) destination_file =
  let open BuildInstance.Syntax in
  let* () =
    mkdir
      ~on_fail:(on_fail ~location_if_checksum_error:None)
      (MlFront_Core.FilePath.parent destination_file)
  in
  let* status =
    List.fold_left
      (fun c (mirror : string) ->
        let* status = c in
        match status with
        | ShellCore.Downloaded _ | Failed _ -> c
        | FailedRetryableAttempt _ ->
            (* We do not yet have a successful download. Try the mirror. *)
            let* real_status =
              if
                String.starts_with ~prefix:"https://" mirror
                || String.starts_with ~prefix:"http://" mirror
              then
                ShellCore.download_remote ?verbose ?debug_connection ~autofix
                  ~on_fail:(fun ~error_code ~because ~recommendations () ->
                    let* () =
                      on_fail ~location_if_checksum_error:None ~error_code
                        ~because ~recommendations ()
                    in
                    return (ShellCore.Failed ()))
                  ~return ~mirror ~file_path ~file_sz destination_file
              else
                copy_local ?intermediate ~staging_dir ~localbasepath:mirror
                  ~file_path destination_file
            in
            (* Just because it is downloaded does not mean it is valid.
               Check for checksum! *)
            let* effective_status =
              match real_status with
              | Failed _ | FailedRetryableAttempt _ -> return real_status
              | Downloaded { origin; downloaded_checksum } ->
                  let* final_status =
                    verify_download_checksum
                      ~on_fail:(on_fail ~location_if_checksum_error:None)
                      ~mirror ~actual_checksum:downloaded_checksum
                      ~unverified_file:destination_file ~file_checksum ~file_sz
                      ()
                  in
                  (match (assettrace, final_status) with
                  | Some (), Downloaded _ ->
                      Printf.eprintf "[asset] %s to %s\n" origin
                        (MlFront_Core.FilePath.to_string destination_file)
                  | _ -> ());
                  return final_status
            in
            return effective_status)
      (return
         (ShellCore.FailedRetryableAttempt
            {
              error_code = "b7c0c55c";
              because = "there were no mirrors";
              recommendations = [];
              location_if_checksum_error = None;
            }))
      (first_mirror :: rest_mirrors)
  in
  match status with
  | Downloaded { origin = _; downloaded_checksum = `KnownSha256 sha256 } ->
      return (`Downloaded (`Sha256 sha256))
  | Downloaded _ -> begin
      let checksum_result =
        MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file ~algo:`Sha256
          ~return:Fun.id
          (MlFront_Core.FilePath.to_string destination_file)
      in
      match checksum_result with
      | `Error e ->
          let* () =
            on_fail
              ~error_code:ExecErrorCodes.ChecksumErrors.uncalculable_checksum
              ~because:
                (Printf.sprintf
                   "the SHA256 checksum could not be calculated due to error \
                    `%s`"
                   e)
              ~recommendations:[]
              ~location_if_checksum_error:
                (Some (file_checksum_location file_checksum))
              ()
          in
          return `Failed
      | `Checksum sha256 -> return (`Downloaded (`Sha256 sha256))
    end
  | Failed _ -> return `Failed
  | FailedRetryableAttempt
      { error_code; because; recommendations; location_if_checksum_error } ->
      let* () =
        on_fail ~error_code ~because ~recommendations
          ~location_if_checksum_error ()
      in
      return `Failed

type parsed_command = {
  module_id :
    Fmlib_parse.Position.range * MlFront_Thunk.ThunkCommand.module_version;
  request_slot : MlFront_Thunk.ThunkCommand.object_slot option;
  runner :
    context:XCommon.IdWithContext.t ->
    tasks:BuildEngine.tasks ->
    (module MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT) ->
    BuildEngine.key BuildInstance.Syntax.cont;
}

let parse_command command : parsed_command =
  let request_slot = MlFront_Thunk.ThunkCommand.object_slot command in
  match command with
  | GetObject { slot; id; command_output; archive_member } ->
      {
        module_id = id;
        request_slot;
        runner = XGetObject.run ~slot ~command_output ~archive_member;
      }
  | InstallObject { slot; id; command_output; archive_member } ->
      {
        module_id = id;
        request_slot;
        runner = XInstallObject.run ~slot ~command_output ~archive_member;
      }
  | PipeObject { slot; id; pipe = _; archive_member = _ } ->
      { module_id = id; request_slot; runner = XPipeObject.run ~slot }
  | EnterObject { slot; id } ->
      { module_id = id; request_slot; runner = XEnterObject.run ~slot }
  | GetBundle { id; command_output } ->
      { module_id = id; request_slot; runner = XGetBundle.run ~command_output }
  | GetAsset { id; filepath; command_output; archive_member } ->
      {
        module_id = id;
        request_slot;
        runner = XGetAsset.run ~filepath ~command_output ~archive_member;
      }

let run_command ~config ~initiator ~vsl_source ~vsl_source_sha256 ~tasks
    parsed_command : BuildEngine.key BuildCore.Alacarte_6_4_test.CSuspending.t =
  let { module_id; runner; request_slot = _ } : parsed_command =
    parsed_command
  in
  let context =
    XCommon.IdWithContext.create ~id:module_id ~source:vsl_source
      ~source_sha256:vsl_source_sha256 ~config ~initiator
  in
  let observer_result = BuildConfig.observer_result config in
  runner ~context ~tasks observer_result

let parse_argv module_or command_line =
  match
    MlFront_Thunk.ThunkCommand.parse_argv module_or ~origin:"<mlfront-shell>"
      (Array.of_list command_line)
  with
  | Error { error_range = _; error_message; is_rendered = _ } ->
      ShellCore.quick_error error_message
  | Ok (GetObject _ as v) -> (v, "get object")
  | Ok (InstallObject _ as v) -> (v, "install object")
  | Ok (PipeObject _ as v) -> (v, "pipe object")
  | Ok (EnterObject _ as v) -> (v, "enter object")
  | Ok (GetBundle _ as v) -> (v, "get bundle")
  | Ok (GetAsset _ as v) -> (v, "get asset")

let start_phase1 ~data_dir ~cache_dir ~valuestore ~tracestore ~random_seed
    ~integrity ~install ~keys_env ~keys_dir debugmodes : ShellCore.phase1 =
  let buildlogtrace = if List.mem `BuildLog debugmodes then Some () else None in
  let parsetrace = if List.mem `ParseTrace debugmodes then Some () else None in
  let debug_task = if List.mem `Task debugmodes then Some () else None in
  let preconfig =
    BuildConfig.preconfigure ?data_dir ?cache_dir ?valuestore ?tracestore
      ?buildlogtrace ?parsetrace ?debug_task ~install ~keys_env ~keys_dir
      ~random_seed ~integrity ()
  in
  (* Create trace store directory *)
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(BuildConfig.fatal_return ~error_code:"d41d8cd9")
    (BuildConfig.preconfig_tracestore preconfig);
  (* Create [.tracestore] so autofix can avoid this directory *)
  let dot_tracestore =
    MlFront_Core.FilePath.append_exn ".tracestore"
      (BuildConfig.preconfig_tracestore preconfig)
  in
  Out_channel.with_open_bin (MlFront_Core.FilePath.to_string dot_tracestore)
    (fun _oc -> ());
  ({ preconfig } : ShellCore.phase1)

let create_tracefd ~wait_trace_store preconfig =
  let tracestore = BuildConfig.preconfig_tracestore preconfig in
  let tracefile = BuildConfig.preconfig_tracefile preconfig in
  let trace_store_s =
    MlFront_Core.FilePath.(to_string (append_exn tracefile tracestore))
  in
  try
    let tracefd =
      Unix.openfile trace_store_s [ Unix.O_RDWR; Unix.O_CREAT ] 0o640
    in
    Unix.lockf tracefd
      (if wait_trace_store then Unix.F_LOCK else Unix.F_TLOCK)
      0;
    tracefd
  with Unix.Unix_error (Unix.EACCES, _, _) ->
    raise
      (BuildExceptions.EngineShutdown
         {
           trace =
             [
               ErrorBacktraceItem'
                 {
                   error_code = "72d075f8";
                   cant_do =
                     Printf.sprintf "lock the trace store %s" trace_store_s;
                   because = "another build is running in the same directory";
                   recommendations =
                     [
                       "Use the `--wait-trace-store` option if you can wait an \
                        indefinite amount of time.";
                     ];
                   error_locations = [];
                 };
             ];
           exitcode_posix = 4;
           exitcode_windows = 4;
         })

(** Starts phase 2 and returns a build configuration. *)
let start_phase2 ~preconfig ~autofix ~verbose ~nobuiltininc ~nosysinc
    ~sysincludedirs ~includedirs ~local_packages ~build_number
    ~inferred_package_id_or_reason_whynone debugmodes observer_result :
    BuildConfig.t =
  let explain = if List.mem `Explain debugmodes then Some () else None in
  let assettrace = if List.mem `AssetTrace debugmodes then Some () else None in
  let debug_connection =
    if List.mem `Connection debugmodes then Some () else None
  in
  let intermediate =
    if List.mem `Intermediate debugmodes then Some () else None
  in
  let importtrace = if List.mem `Import debugmodes then Some () else None in
  let importtrace2 = if List.mem `Import2 debugmodes then Some () else None in
  let verbose = if verbose then Some () else None in
  let nobuiltininc = if nobuiltininc then Some () else None in
  let nosysinc = if nosysinc then Some () else None in
  (* Temporary space for the running process. We allow multiple simultaneous runs
     by using the PID of the running process, and try to be a somewhat nice citizen
     of the users' disk space by re-using space. A non-reference implementation
     should use LRU caching, garbage collection or something similar. *)
  let threaddir =
    let pid = Unix.getpid () in
    let d =
      MlFront_Core.FilePath.(
        of_string_exn "target/pid" |> append_exn (string_of_int pid))
    in
    MlFront_Thunk_IoDisk.ThunkIoDisk.remove_directory_recursively
      ~return:(BuildConfig.fatal_return ~error_code:"0c12f056")
      d;
    d
  in
  (* Initialize configuration *)
  let config =
    let download =
      let staging_dir = MlFront_Core.FilePath.append_exn "dls" threaddir in
      download ?verbose ?debug_connection ?intermediate ?assettrace ~staging_dir
        ~autofix
    in
    BuildConfig.create ?verbose ?explain ?intermediate ?importtrace
      ?importtrace2 ?nobuiltininc ?nosysinc ~preconfig ~sysincludedirs
      ~includedirs ~local_packages ~build_number
      ~inferred_package_id_or_reason_whynone ~threaddir ~download
      ~observer_result ()
  in
  (* Create value store directory *)
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(BuildConfig.fatal_return ~error_code:"bcd6b2d4")
    (BuildConfig.valuestore config);
  (* Create [.valuestore] so autofix can avoid this directory *)
  let dot_valuestore =
    MlFront_Core.FilePath.append_exn ".valuestore"
      (BuildConfig.valuestore config)
  in
  Out_channel.with_open_bin (MlFront_Core.FilePath.to_string dot_valuestore)
    (fun _oc -> ());
  config

let start_phase3 ~config ~traces module_or parsed_command : ShellCore.phase3 =
  (* Initialize BuildEngine *)
  let initiator =
    BuildTask.(
      UserInitiated
        {
          agent = "mlfront-shell command";
          request_slot = parsed_command.request_slot;
        })
  in
  let state, tasks, system_keys =
    BuildEngine.load_state_and_tasks ~config ~traces module_or
  in
  { config; initiator; state; tasks; system_keys }

let start_phase4 ~(shell : ShellCore.phase3) ~preconfig module_or :
    BuildEngine.state =
  (* Post-load integrity checks *)
  let state1 =
    BuildEngine.remove_invalid_values ~config:shell.config shell.state
  in

  (* Make tasks from values files *)
  let state2 =
    let system_kont =
      BuildEngine.make_tasks_from_values_files ~config:shell.config
        ~tasks:shell.tasks ~initiator:shell.initiator module_or
        shell.system_keys
    in
    BuildEngine.run_unit_continuation system_kont state1
  in
  if BuildConfig.preconfig_debug_task preconfig then
    Printf.eprintf "[task] %d values task%s complete\n"
      (List.length shell.system_keys)
      (if List.length shell.system_keys = 1 then "" else "s");
  state2

let finish_phase1 ~config state_after_run tracefd =
  (* Save traces. *)
  let all_traces =
    BuildCore.Alacarte_6_4_test.StateSuspending.get_all_traces state_after_run
  in
  BuildTraceStore.save ~config all_traces tracefd

let do_autofix ~file ~code ~first_hint ~rest_hints ~line ~col () =
  let exception Skip in
  let exception SkipWithReason of string in
  try
    (* only mismatched checksum supported for now. *)
    if String.equal ExecErrorCodes.ChecksumErrors.mismatched_checksum code then
      ()
    else raise Skip;

    (* and there must be a hint with an autofix *)
    let autofix =
      List.find_map
        (fun h ->
          match Autofix.parse_string h with
          | Ok v -> Some v
          | Error _msg ->
              (* prerr_endline msg; *)
              None)
        (first_hint :: rest_hints)
    in
    let autofix =
      match autofix with
      | None -> raise (SkipWithReason "no autofix available")
      | Some v -> v
    in

    (* safety checks. must be relative path under pwd and not be in value/tracestore. *)
    let fp = MlFront_Core.FilePath.(of_string_exn file |> normalize) in
    if MlFront_Core.FilePath.is_absolute fp then raise Skip;
    (match MlFront_Core.FilePath.rootless_segments fp with
    | [] | ".." :: _ ->
        raise
          (SkipWithReason
             "file to be fixed is not in or under the current directory")
    | _ -> ());
    if
      dir_or_ancestor_has_dot_tracestore_or_valuestore
        (MlFront_Core.FilePath.parent fp)
    then raise (SkipWithReason "file to be fixed is in trace or value store");

    (* edit the file *)
    match Autofix.edit_file ~file_path:file ~line ~col autofix with
    | Ok () -> Printf.eprintf "autofix applied to `%s`\n%!" file
    | Error m -> Printf.eprintf "autofix failed on `%s`: %s\n%!" file m
  with
  | Skip -> ()
  | SkipWithReason reason -> Printf.eprintf "autofix ignored: %s\n%!" reason

let rec process_value_shell_command ~valuestore ~tracestore ~data_dir ~cache_dir
    ~autofix ~verbose ~install ~keys_env ~keys_dir ~random_seed
    ~wait_trace_store ~nobuiltininc ~nosysinc ~sysincludedirs ~includedirs
    ~local_packages ~build_number ~integrity
    ~inferred_package_id_or_reason_whynone ~transform_values
    ~dump_ancestors_graph ~dump_dependency_graph debugmodes module_or
    vsl_command_line =
  (* source *)
  let vsl_source, (vsl_source_sha256, _vsl_source_sz) =
    let contents =
      List.map MlFront_Thunk.ThunkCommand.InternalUse.posix_quote_word
        vsl_command_line
      |> String.concat " "
    in
    let file =
      BuildCore.Io.inmemory_file
        ~origin:(MlFront_Core.FilePath.of_string_exn "/dev/argv")
        contents
    in
    match
      BuildInstance.Launcher.run_isolated_promise
        (BuildCore.Io.checksum_file ~algo:`Sha256 file)
    with
    | `Error msg -> ShellCore.quick_error msg
    | `Checksum sha256 -> (file, sha256)
  in

  let latest_cant_do = ref "run mlfront-shell" in
  try
    (* Start phase 1 *)
    let { preconfig } : ShellCore.phase1 =
      start_phase1 ~valuestore ~tracestore ~data_dir ~cache_dir ~install
        ~keys_env ~keys_dir ~random_seed ~integrity debugmodes
    in

    (* Lock the trace file exclusively to this process since Marshal
       files can't be merged or updated.
       Other implementations can use a MVCC keystore (etc.). *)
    let tracefd = create_tracefd ~wait_trace_store preconfig in

    (* Load traces. *)
    let traces =
      BuildTraceStore.read_traces_gracefully ~preconfig ~transform_values
        tracefd
    in

    (* Start phase 2 *)
    let config =
      start_phase2 ~preconfig ~autofix ~verbose ~nobuiltininc ~nosysinc
        ~sysincludedirs ~includedirs ~local_packages ~build_number
        ~inferred_package_id_or_reason_whynone debugmodes module_or
    in

    (* Parse the command. We need the request slot. *)
    let command, cant_do = parse_argv module_or vsl_command_line in
    latest_cant_do := cant_do;
    let parsed_command = parse_command command in

    (* Start phase 3 *)
    let shell = start_phase3 ~config ~traces module_or parsed_command in

    (* Start phase 4 *)
    let shell =
      let state2 = start_phase4 ~shell ~preconfig module_or in
      { shell with state = state2 }
    in

    (* Run user task *)
    let target_key, state_after_run =
      let user_kont =
        run_command ~config:shell.config ~initiator:shell.initiator ~vsl_source
          ~vsl_source_sha256 ~tasks:shell.tasks parsed_command
      in
      BuildEngine.run_continuation user_kont shell.state
    in
    let target_key = BuildEngine.uncloak_key target_key in
    let state_after_run = BuildEngine.uncloak_state state_after_run in

    (* Dump graphs if requested *)
    (match dump_ancestors_graph with
    | None -> ()
    | Some where ->
        ShellCore.with_ppf
          (fun ppf ->
            BuildCore.Alacarte_6_4_test.StateSuspending.pp_graph_of_key
              `Ancestors ppf state_after_run target_key)
          where);
    (match dump_dependency_graph with
    | None -> ()
    | Some where ->
        ShellCore.with_ppf
          (fun ppf ->
            BuildCore.Alacarte_6_4_test.StateSuspending.pp_graph_of_key
              `Dependencies ppf state_after_run target_key)
          where);

    (* Finish phase 1 *)
    finish_phase1 ~config:shell.config state_after_run tracefd
  with
  | BuildExceptions.EngineShutdown { trace; exitcode_posix; exitcode_windows }
  ->
    process_exception ~trace ~exitcode_posix ~exitcode_windows
      ~cant_do:!latest_cant_do ~source_file:vsl_source ~autofix module_or

and process_exception ~trace ~exitcode_posix ~exitcode_windows ~cant_do
    ~source_file ~autofix module_or =
  let rendered, summary =
    BuildValidation.render_trace ~observer_result:module_or ~cant_do
      ~source_file trace
  in
  prerr_endline rendered;
  (if autofix then
     match
       ( summary.diag_file,
         summary.diag_error_code,
         summary.diag_hints,
         summary.diag_line,
         summary.diag_col )
     with
     | Some file, Some code, first_hint :: rest_hints, Some line, Some col ->
         do_autofix ~file ~code ~first_hint ~rest_hints ~line ~col ()
     | _ -> ());
  exit (if Sys.win32 then exitcode_windows else exitcode_posix)