Source file BuildTaskForm.ml

(** Make a UserFormKind task from an AST. *)

open BuildCore

let really_trace = ref false
let equal_slot a b = MlFront_Thunk.ThunkCommand.compare_object_slot a b = 0

(** Maddeningly file_exists is [true] for directories. Rename it for clarity. *)
let path_exists = Sys.file_exists

let range_into_problem_location ~(source : BuildCore.Io.file_object) range :
    MlFront_Thunk.BuildWriters.Standard.problem_location list
    BuildCore.Alacarte_6_4_test.CSuspending.t =
  let open BuildInstance.Syntax in
  let* read_result = lift_promise @@ 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 mkdir ~values_file ~what assetrange 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 ->
      let* error_locations =
        range_into_problem_location ~source:values_file assetrange
      in
      fail ~error_code:"8d3e888a"
        ~cant_do:(Printf.sprintf "create %s" what)
        ~because:e ~error_locations ()
  | `Created -> return ()

let rmdir ~values_file ~what assetrange fp =
  let open BuildInstance.Syntax in
  let fp_dir = BuildCore.Io.disk_dir fp in
  let* deletedir_result =
    lift_promise @@ BuildCore.Io.delete_directory fp_dir
  in
  match deletedir_result with
  | `Error e ->
      let* error_locations =
        range_into_problem_location ~source:values_file assetrange
      in
      fail ~error_code:"91703ff8"
        ~cant_do:(Printf.sprintf "delete %s" what)
        ~because:e ~error_locations ()
  | `Deleted -> return ()

let rmfile ~values_file ~what assetrange fp =
  let open BuildInstance.Syntax in
  let fp_file = BuildCore.Io.disk_file fp in
  let* deletefile_result = lift_promise @@ BuildCore.Io.delete_file fp_file in
  match deletefile_result with
  | `Error e ->
      let* error_locations =
        range_into_problem_location ~source:values_file assetrange
      in
      fail ~error_code:"6b6fadf5"
        ~cant_do:(Printf.sprintf "delete %s" what)
        ~because:e ~error_locations ()
  | `Deleted -> return ()

let aux_verify_path_exists ~source ~range ~k_user_form ~error_code ~because
    ~recommendations path f : _ Alacarte_6_4_test.CSuspending.t =
  let open Alacarte_3_2_apparatus in
  let open Alacarte_6_4_test in
  let open MlFront_Thunk.BuildConstraints.MonadLetSyntax (CSuspending) in
  let open BuildInstance.Syntax in
  let path_s = MlFront_Core.FilePath.to_string path in
  if path_exists path_s then f true
  else
    (* Error. The file or directory does not exist. *)
    let* error_locations = range_into_problem_location ~source range in
    let* () =
      fail ~error_code
        ~cant_do:(Format.asprintf "build `%a`" K.pp k_user_form)
        ~because ~error_locations ~recommendations ()
    in
    f false

let verify_slot_used ~general_recommendations ~source ~range ~k_user_form slot
    path : bool Alacarte_6_4_test.CSuspending.t =
  let because =
    Format.asprintf
      "it did not create an output zip or output directory at ${SLOT.%a}"
      MlFront_Thunk.ThunkCommand.pp_object_slot slot
  in
  aux_verify_path_exists ~source ~range ~k_user_form ~error_code:"e3dd11f5"
    ~because ~recommendations:general_recommendations path (fun (b : bool) ->
      Alacarte_6_4_test.CSuspending.pure b)

let fail_if_output_path_does_not_exists ~config ~general_recommendations ~source
    ~range ~k_user_form ~full_path slot path :
    unit Alacarte_6_4_test.CSuspending.t =
  aux_verify_path_exists ~source ~range ~k_user_form ~error_code:"27d1a9c1"
    ~because:
      (Format.asprintf "it did not create the path `%s` in ${SLOT.%a}" path
         MlFront_Thunk.ThunkCommand.pp_object_slot slot)
    full_path
    (fun (_ : bool) -> Alacarte_6_4_test.CSuspending.pure ())
    ~recommendations:
      ([
         (* In CI we can't display the PIDs, but if user requests intermediate we can. *)
         (if BuildConfig.intermediate config then
            let open MlFront_Core.FilePath in
            Format.asprintf
              "Since you used `-d intermediate`, inspect the slot intermediate \
               files created by the form. The output file `%s` was expected in \
               `%s`."
              (basename full_path)
              (show (parent full_path))
          else "Run with `-d intermediate` to keep the intermediate slot files.");
       ]
      @ general_recommendations)

let is_slot_member_of_slots slot =
  List.exists (fun (_range, slot') -> equal_slot slot' slot)

let paths_for_slot slot form =
  match (form : MlFront_Thunk.ThunkAst.form) with
  | { outputs = { files = _range, first_file, rest_files }; _ } ->
      List.fold_left
        (fun acc
             ({ slots = first_slot, rest_slots; paths = first_path, rest_paths } :
               MlFront_Thunk.ThunkAst.output) ->
          if is_slot_member_of_slots slot (first_slot :: rest_slots) then
            first_path :: rest_paths
          else acc)
        [] (first_file :: rest_files)

module FilePathMap = Map.Make (MlFront_Core.FilePath)

let populate_file_path_map paths_for_slot =
  List.fold_left
    (fun acc (range, path) ->
      FilePathMap.add
        MlFront_Core.FilePath.(of_string_exn path |> normalize)
        range acc)
    FilePathMap.empty paths_for_slot

let check_ast_output_exists_then_zipdir ~config ~general_recommendations
    ~destzip ~srcslotdir ~user_slot ~source ~k_user_form ast :
    unit Alacarte_6_4_test.CSuspending.t =
  let open Alacarte_3_2_apparatus in
  let open Alacarte_3_7_test_last in
  let open Alacarte_6_4_test in
  let open MlFront_Thunk.BuildConstraints.MonadLetSyntax (CSuspending) in
  let module I = ThunkTrackingInterpreter in
  let open Traces (I) in
  (* Get list of files we expect to see in the [srcslotdir] directory *)
  let paths_for_slot = paths_for_slot user_slot ast in
  let pathset = ref (populate_file_path_map paths_for_slot) in
  let* () =
    List.fold_left
      (fun c ((range, path) : MlFront_Thunk.ThunkAst.ranged_path) ->
        let* () = c in

        (* The output path matched the task's user slot.
           But does it exist? *)
        (* IMPLEMENTATIONS: This is the place you want to apply
            extra care. On a Unix machine, if [path = /etc/passwd]
            then the password file will be available as an output.
            That would be perfectly fine if the intent is to package
            up a reproducible Docker-like system image, but
            it could be malicious.

            You may consider disallowing absolute paths especially
            if your system only supports builds not installations.
            Otherwise prompt the user that non-project files
            are being read. *)
        let path_fp = MlFront_Core.FilePath.of_string_exn path in
        if MlFront_Core.FilePath.is_absolute path_fp then
          Printf.eprintf
            "[security]: The output path `%s` for form %s is absolute. The \
             build system will read that path and place it in the object \
             store. Do not distribute the build artifacts or the value store \
             if you did not intend to read files outside of your project.\n\
             %!"
            (MlFront_Core.FilePath.show path_fp)
            (K.show k_user_form);
        let full_path = MlFront_Core.FilePath.append_exn path srcslotdir in
        fail_if_output_path_does_not_exists ~config ~general_recommendations
          ~source ~range ~k_user_form ~full_path user_slot path)
      (CSuspending.pure ()) paths_for_slot
  in
  (* Remove the object path if it exists, so we can replace zip not
     add to it. *)
  let* () =
    rmfile ~values_file:source ~what:"output zipfile"
      (MlFront_Thunk.ThunkAst.form_output_files_range ast)
      destzip
  in
  let* () =
    mkdir ~values_file:source ~what:"directory of output zipfile"
      (MlFront_Thunk.ThunkAst.form_output_files_range ast)
      (MlFront_Core.FilePath.parent destzip)
  in
  (* Make the zipfile, while verifying that all desired paths are placed in it. *)
  let extraneous_paths = ref [] in
  MlFront_ZipFile.ZipFile.zip_exn ~deterministic:()
    ~filter:(fun path ->
      let fp = MlFront_Core.FilePath.(of_string_exn path |> normalize) in
      if FilePathMap.mem fp !pathset then begin
        pathset := FilePathMap.remove fp !pathset;
        true
      end
      else begin
        extraneous_paths := fp :: !extraneous_paths;
        false
      end)
    ~destzip:(MlFront_Core.FilePath.to_string destzip)
    ~srcdir:(MlFront_Core.FilePath.to_string srcslotdir)
    ();
  (* Verification *)
  let cant_do = Format.asprintf "verify `%a`" K.pp k_user_form in
  let recommendation1 =
    (* In CI we can't display the PIDs, but if user requests intermediate we can. *)
    if BuildConfig.intermediate config then
      Format.asprintf
        "Since you used `-d intermediate`, inspect the files the form placed \
         in the slot directory `%a`."
        MlFront_Core.FilePath.pp srcslotdir
    else "Run with `-d intermediate` to keep the intermediate slot files."
  in
  let pp_fp_list ppf (files : MlFront_Core.FilePath.t list) =
    (* Use JSON encoding so can be copy-pasted into values.json *)
    let size = ref 0 in
    let json : MlFront_Thunk.YojsonI.Safe.t =
      `List
        (List.map
           (fun fp ->
             let f = MlFront_Core.FilePath.show fp in
             size := !size + String.length f;
             `String f)
           files)
    in
    let encode =
      (* Pretty print unless too big *)
      if !size > 1024 then
        MlFront_Thunk.YojsonI.Safe.to_string ?buf:None ~len:(!size * 2) ~suf:""
          ~std:true
      else MlFront_Thunk.YojsonI.Safe.pretty_to_string ~std:true
    in
    Format.pp_print_string ppf (encode json)
  in
  let* () =
    if not (FilePathMap.is_empty !pathset) then
      let* error_locations =
        range_into_problem_location ~source
          (MlFront_Thunk.ThunkAst.form_output_files_range ast)
      in
      fail ~error_code:"4be0529f" ~cant_do
        ~because:
          (Format.asprintf
             "the ${SLOT.%a} directory is missing files declared in `files`: \
              `%a`"
             MlFront_Thunk.ThunkCommand.pp_object_slot user_slot pp_fp_list
             (FilePathMap.bindings !pathset |> List.map fst))
        ~error_locations
        ~recommendations:
          [
            recommendation1;
            "Double-check that you are declaring files rather than directories.";
          ]
        ()
    else CSuspending.pure ()
  in
  let* () =
    if [] <> !extraneous_paths then
      let* error_locations =
        range_into_problem_location ~source
          (MlFront_Thunk.ThunkAst.form_output_files_range ast)
      in
      fail ~error_code:"4be0529f" ~cant_do
        ~because:
          (Format.asprintf
             "the ${SLOT.%a} directory has extra files not declared in \
              `files`: `%a`"
             MlFront_Thunk.ThunkCommand.pp_object_slot user_slot pp_fp_list
             !extraneous_paths)
        ~error_locations ~recommendations:[ recommendation1 ] ()
    else CSuspending.pure ()
  in
  CSuspending.pure ()

let rec check_ast_output_in_zip_then_copyzipfile ~config
    ~general_recommendations ~srczip ~destzip ~k_user_form ~user_slot ~source
    ast : unit Alacarte_6_4_test.CSuspending.t =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  let recommendations =
    (* In CI we can't display the PIDs, but if user requests intermediate we can. *)
    if BuildConfig.intermediate config then
      Format.asprintf
        "Since you used `-d intermediate`, inspect the slot zip file `%a`."
        MlFront_Core.FilePath.pp srczip
      :: general_recommendations
    else
      "Run with `-d intermediate` to keep the intermediate slot files."
      :: general_recommendations
  in
  (* Get list of files we expect to see in the zipfile *)
  let paths_for_slot = paths_for_slot user_slot ast in
  let pathset = ref (populate_file_path_map paths_for_slot) in
  (* Verify they all exist in the zipfile *)
  let cant_do = Format.asprintf "verify `%a`" K.pp k_user_form in
  let* () =
    MlFront_ZipFile.ZipFile.zip_fold_entries
      ~srczip:(MlFront_Core.FilePath.to_string srczip)
      (fun c path _is_dir _size ->
        let* () = c in
        let fp = MlFront_Core.FilePath.(of_string_exn path |> normalize) in
        if FilePathMap.mem fp !pathset then begin
          pathset := FilePathMap.remove fp !pathset;
          c
        end
        else
          let* error_locations =
            range_into_problem_location ~source
              (MlFront_Thunk.ThunkAst.form_output_files_range ast)
          in
          fail ~error_code:"cd113edb" ~cant_do
            ~because:
              (Format.asprintf
                 "the ${SLOT.%a} zip file has a member that was not declared \
                  in `files`: `%s`"
                 MlFront_Thunk.ThunkCommand.pp_object_slot user_slot path)
            ~error_locations ~recommendations ())
      (return ())
  in
  (* If any paths are left, then they were not found in the zipfile. *)
  let remaining_paths =
    FilePathMap.fold (fun path range acc -> (path, range) :: acc) !pathset []
  in
  match remaining_paths with
  | [] ->
      (* Copy the zip file *)
      let* () =
        mkdir ~values_file:source ~what:"directory of output zipfile"
          (MlFront_Thunk.ThunkAst.form_output_files_range ast)
          (MlFront_Core.FilePath.parent destzip)
      in
      let* () =
        copy_file_or_fail ~general_recommendations:recommendations ~src:srczip
          ~dest:destzip ~source
          ~cant_do:(Format.asprintf "copy `%a`" K.pp k_user_form)
          (MlFront_Thunk.ThunkAst.form_output_files_range ast)
      in
      return ()
  | (_first_path, first_range) :: _ ->
      (* We'll report the error with the first range. *)
      let* error_locations = range_into_problem_location ~source first_range in
      let* () =
        fail ~error_code:"b8845e39" ~cant_do
          ~because:
            (Format.asprintf "the ${SLOT.%a} zip file is missing the members %a"
               MlFront_Thunk.ThunkCommand.pp_object_slot user_slot
               Format.(
                 pp_print_list
                   ~pp_sep:(fun ppf () -> fprintf ppf ", ")
                   (fun ppf fp ->
                     fprintf ppf "`%a`" MlFront_Core.FilePath.pp fp))
               (List.map fst remaining_paths))
          ~error_locations ~recommendations ()
      in
      return ()

and copy_file_or_fail ~general_recommendations ~src ~dest ~source ~cant_do range
    =
  let open BuildInstance.Syntax in
  BuildCore.Io.copy_or_fail
    ~src:(BuildCore.Io.disk_file src)
    ~dest:(BuildCore.Io.disk_file dest)
    ~on_error:(fun because ->
      let* error_locations = range_into_problem_location ~source range in
      fail ~error_code:"6088c54b" ~cant_do ~because ~error_locations
        ~recommendations:general_recommendations ())
    (return ())

let qw = MlFront_Thunk.ThunkCommand.InternalUse.posix_quote_word

let qslot slot =
  qw (Format.asprintf "%a" MlFront_Thunk.ThunkCommand.pp_object_slot slot)

let qid ({ id; version } : MlFront_Thunk.ThunkCommand.module_version) =
  qw
    (Printf.sprintf "%s@%s"
       (MlFront_Core.StandardModuleId.show_dot id)
       (MlFront_Thunk.ThunkSemver64.to_string version))

let qm = function
  | None -> ""
  | Some archive_member -> Printf.sprintf " -m %s" (qw archive_member)

let fail_shell_object ~source range =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"f450ca0f" ~cant_do:"run enter-object precommand"
    ~because:"shells are only available from the command line" ~error_locations
    ()

let output_slot_of_eval_item ~request_slot item =
  match (item : MlFront_Thunk.ThunkCommand.evalable_item) with
  | SlotVariable (output_slot, _range) -> Some output_slot
  | SlotRequest _range -> Some request_slot
  | SlotNameRequest _ | Literal _
  | PipeVariable (_, _)
  | MoreIncludesDir | MoreCommandsFile | DirectorySeperator | ExecutableSuffix
  | HomeDir | CacheDir | DataDir | ConfigDir | StateDir | RuntimeDir ->
      None

(** If a command uses output slots, but none of those match the requested slot,
    we can optimize the command out per the SPECIFICATION. *)
let can_optimize_out_eval_term ~user_slot
    (term : MlFront_Thunk.ThunkCommand.evalable_term) : bool =
  let all_slots =
    List.filter_map (output_slot_of_eval_item ~request_slot:user_slot) term
  in
  match all_slots with
  | [] ->
      (* No output slots for the command. So don't optimize away. *)
      false
  | _ ->
      (* If any output slot matches the user slot, then we cannot
         optimize the command out. But if none of them match,
         we can optimize the command out. *)
      not @@ List.exists (equal_slot user_slot) all_slots

let can_optimize_out_shell_output ~user_slot
    (shell_output : MlFront_Thunk.ThunkCommand.shell_output) : bool =
  match shell_output with
  | OutputDir { dir; strip = _ } -> can_optimize_out_eval_term ~user_slot dir
  | OutputFile file -> can_optimize_out_eval_term ~user_slot file

let can_optimize_out_precommand ~user_slot
    ({ precommand_canonical_id = _; precommand = _range, command } :
      MlFront_Thunk.ThunkAst.precommand_instance) : bool =
  match command with
  | MlFront_Thunk.ThunkCommand.GetObject
      { slot = _; id = _; command_output; archive_member = _ } ->
      can_optimize_out_shell_output ~user_slot (snd command_output)
  | MlFront_Thunk.ThunkCommand.InstallObject
      { slot = _; id = _; command_output; archive_member = _ } ->
      can_optimize_out_shell_output ~user_slot (snd command_output)
  | MlFront_Thunk.ThunkCommand.PipeObject
      { slot = _; id = _; pipe = _; archive_member = _ } ->
      false
  | MlFront_Thunk.ThunkCommand.EnterObject { slot = _; id = _ } -> false
  | MlFront_Thunk.ThunkCommand.GetAsset
      { id = _; filepath = _; command_output; archive_member = _ } ->
      can_optimize_out_shell_output ~user_slot (snd command_output)
  | MlFront_Thunk.ThunkCommand.GetBundle { id = _; command_output } ->
      can_optimize_out_shell_output ~user_slot (snd command_output)

let fork_precommand_objects_and_assets ~config ~source ~source_sha256
    (precommands : MlFront_Thunk.ThunkAst.precommand_instance list) fetch :
    (Alacarte_3_2_apparatus.K.t * Alacarte_3_2_apparatus.V.t) list
    Alacarte_6_4_test.CSuspending.t =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  (* Build the object or bundle for each precommand. Print if --verbose. *)
  let job
      ({ precommand_canonical_id = _; precommand = range, command } :
        MlFront_Thunk.ThunkAst.precommand_instance) =
    let* apply_aliases = BuildTraceStore.get_apply_aliases ~config in
    let apply_aliases = Some apply_aliases in
    (* Create a reference for the key we'll be creating *)
    let mk_ref range' : K.reference option =
      Some
        {
          reference_range = range';
          reference_file_sha256 = source_sha256;
          reference_transient = Some { reference_file = source };
        }
    in
    (* Do the monadic sequence *)
    match command with
    | EnterObject _ ->
        let* () = fail_shell_object ~source range in
        return (K.reserved_fail_key, V.Failure_is_pending)
    | GetObject
        {
          slot;
          id = range, { id = module_id; version = module_semver };
          command_output = _;
          archive_member = _;
        } ->
        let k =
          K.create_for_form ~apply_aliases ~debug_reference:(mk_ref range)
            ~module_id ~module_semver ~slot ()
        in
        let* v = fetch O.not_relevant k in
        return (k, v)
    | InstallObject
        {
          slot;
          id = range, { id = module_id; version = module_semver };
          command_output = _;
          archive_member = _;
        } ->
        let k =
          K.create_for_form ~apply_aliases ~debug_reference:(mk_ref range)
            ~module_id ~module_semver ~slot ()
        in
        let* v = fetch O.not_relevant k in
        return (k, v)
    | PipeObject
        {
          slot;
          id = range, { id = module_id; version = module_semver };
          pipe = _;
          archive_member = _;
        } ->
        let k =
          K.create_for_form ~apply_aliases ~debug_reference:(mk_ref range)
            ~module_id ~module_semver ~slot ()
        in
        let* v = fetch O.not_relevant k in
        return (k, v)
    | GetBundle
        {
          id = range, { id = module_id; version = module_semver };
          command_output = _;
        } ->
        let k =
          K.create_for_bundle ~apply_aliases ~debug_reference:(mk_ref range)
            ~module_id ~module_semver ()
        in
        let* v = fetch O.not_relevant k in
        return (k, v)
    | GetAsset
        {
          id = range, { id = module_id; version = module_semver };
          filepath = asset_path;
          command_output = _;
          archive_member = _;
        } ->
        let k =
          K.create_for_asset ~apply_aliases ~debug_reference:(mk_ref range)
            ~module_id ~module_semver ~asset_path ()
        in
        let* v = fetch O.not_relevant k in
        return (k, v)
  in
  parallel (List.map job precommands)

let join_precommand_outputs ~config ~cid_ast ~source ~basedir
    (precommands_with_keyvalues :
      (MlFront_Thunk.ThunkAst.precommand_instance
      * (Alacarte_3_2_apparatus.K.t * Alacarte_3_2_apparatus.V.t))
      list) =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  (* Collect the output from each precommand. Print if --verbose *)
  List.fold_left
    (fun c
         (( ({ precommand = range, command; precommand_canonical_id = _ } as
             precommand_instance),
            (k, v) ) :
           MlFront_Thunk.ThunkAst.precommand_instance * (K.t * V.t)) ->
      (* We switch to the form initiator for all the precommands.
         That is, the staging directories and all directories be fully isolated
         to the precommand. *)
      let cid =
        MlFront_Thunk.ThunkAst.canonical_id_precommand precommand_instance
      in
      let initiator =
        BuildTask.CommandInitiated
          {
            cid_thunk_for_output = cid_ast;
            cid_command = cid;
            basedir = Some basedir;
            request_slot = MlFront_Thunk.ThunkCommand.object_slot command;
          }
      in

      (* Common functions *)
      let exception Failed of string in
      let qco : MlFront_Thunk.ThunkCommand.shell_output -> string = function
        | MlFront_Thunk.ThunkCommand.OutputDir { dir; strip } -> begin
            match BuildTask.eval_term_as_filepath ~config ~initiator dir with
            | Error e -> raise (Failed e)
            | Ok fp ->
                Printf.sprintf " -d %s%s"
                  (qw (MlFront_Core.FilePath.to_string fp))
                  (if strip <= 0 then "" else Printf.sprintf " -n %d" strip)
          end
        | MlFront_Thunk.ThunkCommand.OutputFile f -> begin
            match BuildTask.eval_term_as_filepath ~config ~initiator f with
            | Error e -> raise (Failed e)
            | Ok fp ->
                Printf.sprintf " -f %s"
                  (qw (MlFront_Core.FilePath.to_string fp))
          end
      in
      let on_found ~cant_do v f =
        match v with
        | V.Input_not_found k ->
            let* error_locations =
              match k.debug_reference with
              | None -> return []
              | Some reference ->
              match reference.reference_transient with
              | None -> return []
              | Some transient ->
                  range_into_problem_location ~source:transient.reference_file
                    reference.reference_range
            in
            fail ~error_code:"917b6e5f" ~cant_do ~because:"it does not exist"
              ~error_locations ()
        | _ -> f ()
      in

      (* Do the monadic sequence *)
      let* () = c in
      let* () =
        let do_trace = !really_trace && BuildConfig.verbose config in
        match command with
        | EnterObject _ -> fail_shell_object ~source range
        | GetObject { slot; id = _range, id; command_output; archive_member } ->
            if do_trace then
              Printf.eprintf "[finish] get-object %s -s %s%s%s\n" (qid id)
                (qslot slot) (qm archive_member)
                (qco (snd command_output));
            on_found ~cant_do:"get object" v (fun () ->
                XCommon.output_get_object ~config ~initiator ~command_output
                  ~source ~archive_member k v)
        | InstallObject
            { slot; id = _range, id; command_output; archive_member } ->
            if do_trace then
              Printf.eprintf "[finish] install-object %s -s %s%s%s\n" (qid id)
                (qslot slot) (qm archive_member)
                (qco (snd command_output));
            on_found ~cant_do:"install object" v (fun () ->
                XCommon.output_install_object ~config ~initiator ~command_output
                  ~source ~archive_member k v)
        | PipeObject { slot; id = _range, id; pipe; archive_member } ->
            if do_trace then
              Printf.eprintf "[finish] pipe-object %s -s %s -x %s%s\n" (qid id)
                (qslot slot)
                (qw (snd pipe))
                (qm archive_member);
            on_found ~cant_do:"pipe object" v (fun () ->
                XCommon.output_pipe_object ~config ~initiator ~source ~pipe
                  ~archive_member k v)
        | GetBundle { id = _range, id; command_output } ->
            if do_trace then
              Printf.eprintf "[finish] get-bundle %s%s\n" (qid id)
                (qco (snd command_output));
            on_found ~cant_do:"get bundle" v (fun () ->
                XCommon.output_get_asset ~config ~initiator ~command_output
                  ~source ~archive_member:None k v)
        | GetAsset
            {
              id = _range, id;
              filepath = asset_path;
              command_output;
              archive_member;
            } ->
            if do_trace then
              Printf.eprintf "[finish] get-asset %s -p %s%s%s\n" (qid id)
                (qw asset_path) (qm archive_member)
                (qco (snd command_output));
            on_found ~cant_do:"get asset" v (fun () ->
                XCommon.output_get_asset_file ~config ~initiator ~command_output
                  ~source ~archive_member k v)
        | exception Failed because ->
            let* error_locations = range_into_problem_location ~source range in
            let* () =
              fail ~error_code:"9b31c4a2" ~cant_do:"evaluate precommand"
                ~because ~error_locations ()
            in
            return ()
      in
      return ())
    (return ()) precommands_with_keyvalues

let ast_to_envmods ~config ~initiator ast =
  let aux ~initiator
      (lst : (Fmlib_parse.Position.range * MlFront_Thunk.ThunkAst.envmod) list)
      : (MlFront_Core.EnvMods.t, Fmlib_parse.Position.range * string) result =
    let eval = BuildTask.eval_term_as_string ~config ~initiator in
    List.fold_right
      (fun (envmodrange, envmod) envmods ->
        let ( let* ) = Result.bind in
        let* envmods = envmods in
        match (envmod : MlFront_Thunk.ThunkAst.envmod) with
        | AddEnv { envname; envvalue } -> begin
            match eval envvalue with
            | Error e -> Error (envmodrange, e)
            | Ok envvalue ->
                Ok (MlFront_Core.EnvMods.add envname envvalue envmods)
          end
        | RemoveEnv name ->
            Ok (MlFront_Core.EnvMods.remove_names [ name ] envmods)
        | PrependPathEnv { pathenvname; pathenvvalue } -> begin
            match eval pathenvvalue with
            | Error e -> Error (envmodrange, e)
            | Ok pathenvvalue ->
                Ok
                  (MlFront_Core.EnvMods.prepend_path pathenvname pathenvvalue
                     envmods)
          end)
      lst (Ok MlFront_Core.EnvMods.empty)
  in
  match (ast : MlFront_Thunk.ThunkAst.form) with
  | { function_ = None; _ } -> Ok MlFront_Core.EnvMods.empty
  | { function_ = Some (_function_range, { args = _; envmods }); _ } ->
      (* [relative_to] is None since we cwd to [function_path]. *)
      aux ~initiator envmods

let handle_process_result ~source ~function_range ~recommendations
    (process_result :
      [ `Error of string | `Exited of int | `Signaled of int | `Stopped of int ])
    : unit Alacarte_6_4_test.CSuspending.t =
  let open BuildInstance.Syntax in
  let cant_do = "run function successfully" in
  let* error_locations = range_into_problem_location ~source function_range in
  match process_result with
  | `Exited 0 -> return ()
  | `Exited n ->
      fail ~error_code:"63937ccd" ~cant_do
        ~because:(Printf.sprintf "the function exited with code %d" n)
        ~error_locations ~exitcode_posix:n ~exitcode_windows:n ~recommendations
        ()
  | `Signaled n ->
      fail ~error_code:"d65c6d3b" ~cant_do
        ~because:(Printf.sprintf "the function was killed by signal %d" n)
        ~error_locations ~recommendations ()
  | `Stopped n ->
      fail ~error_code:"db556aab" ~cant_do
        ~because:(Printf.sprintf "the function was stopped by signal %d" n)
        ~error_locations ~recommendations ()
  | `Error because ->
      fail ~error_code:"3fd725f2" ~cant_do
        ~because:
          (Printf.sprintf "there was an error in the function: >> %s <<" because)
        ~error_locations ~recommendations ()

let make_userformkind_task ~config ~k_user_form ~values_file_sha256 :
    ((Alacarte_3_2_apparatus.O.t ->
     Alacarte_3_2_apparatus.K.t ->
     Alacarte_3_2_apparatus.V.t Alacarte_6_4_test.CSuspending.t) ->
    Alacarte_3_2_apparatus.V.t Alacarte_6_4_test.CSuspending.t)
    Alacarte_6_4_test.CSuspending.t =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  let user_slot = K.slot_exn k_user_form in
  let form_id = K.module_version_exn k_user_form in
  let build = MlFront_Thunk.ThunkSemver64.build form_id.version in

  (* Provide the task definition *)
  let task
      (fetch :
        Alacarte_3_2_apparatus.O.t ->
        Alacarte_3_2_apparatus.K.t ->
        Alacarte_3_2_apparatus.V.t Alacarte_6_4_test.CSuspending.t) =
    (* Add dependency to distribution *)
    let* dist_result =
      BuildTask.depend_on_distribution ~config ~fetch ~error_locations:[]
        ~module_version:form_id
    in
    match dist_result with
    | `Failure_is_pending -> return V.Failure_is_pending
    | `Ok -> (
        (* Add dependency to parsed values, and extract the form from its index *)
        let* form_result =
          BuildTask.depend_on_values_ast ~fetch ~error_locations:[]
            ~values_file_sha256 (fun ast ->
              match MlFront_Thunk.ThunkAst.find_form ast form_id with
              | None ->
                  Error
                    (Printf.sprintf "AST did not contain the form `%s` "
                       (MlFront_Thunk.ThunkCommand.show_module_version form_id))
              | Some form -> Ok form)
        in
        match form_result with
        | `Failure_is_pending -> return V.Failure_is_pending
        | `FoundInValues
            {
              answer = form, _form_range;
              answer_values_file = values_file;
              answer_values_file_sha256 = values_file_sha256;
              answer_values_canonical_id = _values_canonical_id;
            } ->
            (* Extract from [form_result] *)
            let commands =
              match form with
              | { precommands = { private_; public_ }; _ } -> private_ @ public_
            in
            let cid = MlFront_Thunk.ThunkAst.canonical_id_form form in
            let function_path =
              BuildTask.resolve_task_function_path ~config ~cid user_slot
            in
            let output_path =
              BuildTask.resolve_task_output_path ~config ~cid user_slot
            in
            let form_output_files_range =
              MlFront_Thunk.ThunkAst.form_output_files_range form
            in
            let* error_locations_for_output =
              range_into_problem_location ~source:values_file
                form_output_files_range
            in

            (* Clean function directory if function exists, so function has
           pristine environment. *)
            let* function_or_output_range =
              match form with
              | { function_ = None; _ } -> return form_output_files_range
              | { function_ = Some (function_range, _function_); _ } ->
                  (* Clean function directory *)
                  let* () =
                    rmdir ~values_file ~what:"function directory" function_range
                      function_path
                  in
                  return function_range
            in
            (* Yet even if function does not exist we must at least create the
           function directory because a precommand with a relative file/dir
           output must go into function directory. *)
            let* () =
              mkdir ~values_file ~what:"function directory"
                function_or_output_range function_path
            in

            (* Clean task output directory *)
            let* () =
              rmdir ~values_file ~what:"form output directory"
                form_output_files_range output_path
            in
            let* () =
              (* Since we don't know if the precommands and function will make a
             directory or a file, just make parent directory. *)
              mkdir ~values_file ~what:"parent directory of form output"
                form_output_files_range
                (MlFront_Core.FilePath.parent output_path)
            in

            (* We can optimize out precommands that use at least one output slot
           yet none of those output slots are what is requested in [user_slot].
           See SPECIFICATION and allowed optimizations for precommands. *)
            let relevant_commands =
              List.filter
                (Fun.negate (can_optimize_out_precommand ~user_slot))
                commands
            in

            (* Run precommands.
           Their output and temporary files go to their own unique precommand
           directories, but the relative path outputs go to the function
           directory. *)
            let* precommand_keyvalues =
              fork_precommand_objects_and_assets ~config ~source:values_file
                ~source_sha256:values_file_sha256 relevant_commands fetch
            in
            let* () =
              (* The precommand `-f ${SLOT.name}/blah` outputs go to this
             parent task (the AST task), but relative paths
             `-d m/n/o` go to the function directory of this parent task. *)
              join_precommand_outputs ~config ~cid_ast:cid ~source:values_file
                ~basedir:function_path
                (List.combine relevant_commands precommand_keyvalues)
            in

            (* Hook: Check if we'll enter shell before running function *)
            let des =
              BuildConfig.does_enter_shell_before_function config k_user_form
            in
            let func_exec_initiator =
              BuildTask.FunctionInitiated
                { cid_thunk = cid; request_slot = Some user_slot }
            in
            let func_exec_envmods () =
              ast_to_envmods ~config ~initiator:func_exec_initiator form
            in
            let func_exec_cwd = BuildCore.Io.disk_dir function_path in
            let* () =
              if des then
                let promptname = K.show k_user_form in
                match func_exec_envmods () with
                | Error (erange, e) ->
                    let* error_locations =
                      range_into_problem_location ~source:values_file erange
                    in
                    let* () =
                      fail ~error_code:"473cd47a"
                        ~cant_do:"evaluate environment mods" ~because:e
                        ~error_locations ()
                    in
                    return ()
                | Ok envmods ->
                    (* Add SHELL_SLOTS and SHELL_SLOT for convenience if not already present *)
                    let envmods_if_not_exist =
                      let to_os =
                        if Sys.win32 then MlFront_Core.FilePath.to_windows
                        else MlFront_Core.FilePath.to_unix
                      in
                      let abs_output_path =
                        MlFront_Core.FilePath.concat
                          (MlFront_Core.FilePath.of_string_exn (Sys.getcwd ()))
                          output_path
                      in
                      let em =
                        MlFront_Core.EnvMods.add "SHELL_SLOTS"
                          MlFront_Core.FilePath.(
                            parent abs_output_path |> to_os |> to_string)
                          envmods
                      in
                      MlFront_Core.EnvMods.add "SHELL_SLOT"
                        MlFront_Core.FilePath.(
                          to_os abs_output_path |> to_string)
                        em
                    in
                    let envmods =
                      MlFront_Core.EnvMods.union envmods_if_not_exist envmods
                    in
                    (* Run the interactive shell *)
                    let* process_result =
                      lift_promise
                      @@ BuildCore.Io.interactive_shell_in_directory ~promptname
                           ~envmods ~cwd:func_exec_cwd ()
                    in
                    handle_process_result ~source:values_file
                      ~function_range:function_or_output_range
                      ~recommendations:[] process_result
              else return ()
            in

            (* Run function if exists. Print if --verbose *)
            let* general_recommendations =
              match form with
              | { function_ = None; _ } -> return []
              | {
               function_ =
                 Some
                   (function_range, { args = first_arg, rest_args; envmods = _ });
               _;
              } ->
              match func_exec_envmods () with
              | Error (erange, e) ->
                  let* error_locations =
                    range_into_problem_location ~source:values_file erange
                  in
                  let* () =
                    fail ~error_code:"a0eb3bd3"
                      ~cant_do:"evaluate environment mods" ~because:e
                      ~error_locations ()
                  in
                  return []
              | Ok envmods -> (
                  let eval f = f ~config ~initiator:func_exec_initiator in
                  let command_result =
                    (* No [basedir] since [command] is relative to the [cwd] we'll
                   spawn in. *)
                    eval
                      (BuildTask.eval_term_as_filepath ?platform:None)
                      first_arg
                  in
                  match command_result with
                  | Error e ->
                      let* error_locations =
                        range_into_problem_location ~source:values_file
                          function_range
                      in
                      let* () =
                        fail ~error_code:"9044ed69"
                          ~cant_do:"evaluate function command" ~because:e
                          ~error_locations ()
                      in
                      return []
                  | Ok command -> (
                      let args_result platform =
                        List.fold_right
                          (fun v acc ->
                            let ( let* ) = Result.bind in
                            let* acc = acc in
                            match
                              eval (BuildTask.eval_term_as_string ?platform) v
                            with
                            | Error e -> Error e
                            | Ok v -> Ok (v :: acc))
                          rest_args (Ok [])
                      in
                      match
                        ( args_result None,
                          args_result (Some `Windows),
                          args_result (Some `Unix) )
                      with
                      | Error e, _, _ | _, Error e, _ | _, _, Error e ->
                          let* error_locations =
                            range_into_problem_location ~source:values_file
                              function_range
                          in
                          let* () =
                            fail ~error_code:"044e336b"
                              ~cant_do:"evaluate function arguments" ~because:e
                              ~error_locations ()
                          in
                          return []
                      | Ok args, Ok args_win32, Ok args_unix -> (
                          if BuildConfig.verbose config then
                            Printf.eprintf "spawn: %s %s\n%!"
                              (qw (MlFront_Core.FilePath.to_string command))
                              (String.concat " " (List.map qw args));

                          (* create output directory *)
                          let log_path =
                            BuildTask.resolve_task_output_path ~config ~cid
                              user_slot
                          in
                          let* () =
                            mkdir ~values_file ~what:"form output directory"
                              function_range log_path
                          in

                          (* create log directory *)
                          let log_path =
                            BuildTask.resolve_task_log_path ~config ~cid
                              user_slot
                          in
                          let* () =
                            mkdir ~values_file ~what:"form log directory"
                              function_range log_path
                          in

                          (* create stdout/stderr *)
                          let stdout =
                            BuildCore.Io.disk_file
                              (MlFront_Core.FilePath.append_exn "stdout.log"
                                 log_path)
                          in
                          let stderr =
                            BuildCore.Io.disk_file
                              (MlFront_Core.FilePath.append_exn "stderr.log"
                                 log_path)
                          in
                          let cmdlog =
                            BuildCore.Io.disk_file
                              (MlFront_Core.FilePath.append_exn "command.txt"
                                 log_path)
                          in

                          (* create executed command log *)
                          let* cmdlog_result =
                            let text_cd f =
                              Printf.sprintf "cd %s"
                                (MlFront_Core.FilePath.to_string
                                   (f function_path))
                            in
                            let unix_command =
                              List.map
                                MlFront_Thunk.ThunkCommand.InternalUse
                                .posix_quote_word
                                (MlFront_Core.FilePath.to_string
                                   (MlFront_Core.FilePath.to_unix command)
                                :: args_unix)
                              |> String.concat " "
                            in
                            let windowsbatch_command =
                              List.map
                                MlFront_Thunk.ThunkCommand.InternalUse
                                .windowsbatch_quote_word
                                (MlFront_Core.FilePath.to_string
                                   (MlFront_Core.FilePath.to_windows command)
                                :: args_win32)
                              |> String.concat " "
                            in
                            let text_all =
                              Printf.sprintf
                                "# unix\n%s\n%s\n\nREM windows\n%s\n%s\n"
                                (text_cd MlFront_Core.FilePath.to_unix)
                                unix_command
                                (text_cd MlFront_Core.FilePath.to_windows)
                                windowsbatch_command
                            in
                            lift_promise
                            @@ BuildCore.Io.replace_all_string cmdlog text_all 0
                                 (String.length text_all)
                          in
                          let* error_locations =
                            range_into_problem_location ~source:values_file
                              function_range
                          in
                          match cmdlog_result with
                          | `Error e ->
                              let* () =
                                fail ~error_code:"f6aeab02"
                                  ~cant_do:"create command log" ~because:e
                                  ~error_locations ()
                              in
                              return []
                          | `IsDirectory dir ->
                              let* () =
                                fail ~error_code:"f6aeab02"
                                  ~cant_do:"create command log"
                                  ~because:
                                    (Printf.sprintf
                                       "the command log location `%s` is a \
                                        directory rather than a file"
                                       (Io.directory_origin dir))
                                  ~error_locations ()
                              in
                              return []
                          | `WroteBytes ->
                              (* all other directories are responsibility of the form *)
                              let* process_result =
                                lift_promise
                                @@ BuildCore.Io.spawn_in_directory ~command
                                     ~args ~cwd:func_exec_cwd ~envmods ~stdout
                                     ~stderr ()
                              in
                              let general_recommendations =
                                [
                                  Printf.sprintf
                                    "Check the logs `%s`, `%s` and `%s`."
                                    (BuildCore.Io.file_origin stdout)
                                    (BuildCore.Io.file_origin stderr)
                                    (BuildCore.Io.file_origin cmdlog);
                                ]
                              in
                              let* () =
                                handle_process_result ~source:values_file
                                  ~function_range
                                  ~recommendations:general_recommendations
                                  process_result
                              in
                              return general_recommendations)))
            in

            (* The task runs for _one_ object slot.
           That sounds duplicative and expensive when we have one ABI per object slot!
           The same form precommands and the same function get executed over and
           over again.

           However, any precommands that output to a different object slot are skipped.

           Combine that also with `dk` or a similar tool that can generate cross-platform
           executables, and you now have an efficient function that can be reused
           with different ABI object slots. *)
            let value_id =
              BuildTask.value_id_form_object ~cid ~build user_slot
            in
            let* staging_object_path =
              lift_promise
              @@ BuildInstance.ValueStore.prepare_value_for_upload
                   ~valuestore:(BuildConfig.valuestore config)
                   ~value_id ()
            in
            (* C1. Check if each output path exists. *)
            let output_path_s = MlFront_Core.FilePath.to_string output_path in
            let* exists =
              verify_slot_used ~general_recommendations ~source:values_file
                ~range:form_output_files_range ~k_user_form user_slot
                output_path
            in
            if exists then begin
              let* () =
                if Sys.is_directory output_path_s then
                  (* C2. If it is a directory, then we zip it and store the zip file in the
                 value store. *)
                  check_ast_output_exists_then_zipdir ~config
                    ~general_recommendations ~destzip:staging_object_path
                    ~srcslotdir:output_path ~user_slot ~source:values_file
                    ~k_user_form form
                else begin
                  (* C3. If it is a file, then we store the file path in the object
                 store. But if it is a zip we check its contents. *)
                  if MlFront_ZipFile.ZipFile.is_file_zip output_path_s then
                    (* Check zip contents, then copy. *)
                    check_ast_output_in_zip_then_copyzipfile ~config
                      ~general_recommendations ~srczip:output_path
                      ~destzip:staging_object_path ~k_user_form ~user_slot
                      ~source:values_file form
                  else begin
                    (* Check that only the single file was expected, then
                   copy the file to the value store. *)
                    let* () =
                      let cant_do =
                        Format.asprintf
                          "store output for `${SLOT.%a}` in value store"
                          MlFront_Thunk.ThunkCommand.pp_object_slot user_slot
                      in
                      match paths_for_slot user_slot form with
                      | [ (_single_range, _) ] -> return ()
                      | [] ->
                          fail ~error_code:"195e59a9" ~cant_do
                            ~because:
                              (Format.asprintf
                                 "the `${SLOT.%a}` slot was not declared in \
                                  `files`"
                                 MlFront_Thunk.ThunkCommand.pp_object_slot
                                 user_slot)
                            ~error_locations:error_locations_for_output
                            ~recommendations:general_recommendations ()
                      | _first :: _rest ->
                          fail ~error_code:"92be533a" ~cant_do
                            ~because:
                              "an output file that is not a zip file must be \
                               declared only with one (1) entry `\"path\": \
                               \"...\"` in `files`"
                            ~error_locations:error_locations_for_output
                            ~recommendations:
                              ([
                                 "Use a zip file output if you want to output \
                                  multiple files.";
                                 "Remove all but one of the `\"path\": \
                                  \"...\"` entries in `files`.";
                               ]
                              @ general_recommendations)
                            ()
                    in
                    let* () =
                      copy_file_or_fail ~src:output_path
                        ~dest:staging_object_path ~source:values_file
                        ~cant_do:
                          (Format.asprintf "store output file for `${SLOT.%a}`"
                             MlFront_Thunk.ThunkCommand.pp_object_slot user_slot)
                        ~general_recommendations form_output_files_range
                    in
                    return ()
                  end
                end
              in
              let* sha256_result =
                lift_promise
                @@ BuildCore.Io.checksum_file ~algo:`Sha256
                     (BuildCore.Io.disk_file staging_object_path)
              in
              match sha256_result with
              | `Checksum (value_sha256, _value_size) ->
                  let* () =
                    lift_promise
                    @@ BuildInstance.ValueStore.upload_value
                         ~valuestore:(BuildConfig.valuestore config)
                         ~value_id ~value_sha256 staging_object_path
                  in
                  return
                    (V.Object
                       {
                         value_id;
                         value_sha256;
                         value =
                           Some
                             {
                               object_id = form.form_id;
                               object_range = form_output_files_range;
                               object_origin = None;
                             };
                       })
              | `Error e ->
                  let* () =
                    fail ~error_code:"3070225b"
                      ~cant_do:
                        (Format.asprintf
                           "compute sha256 of output for `${SLOT.%a}`"
                           MlFront_Thunk.ThunkCommand.pp_object_slot user_slot)
                      ~because:e ~error_locations:error_locations_for_output
                      ~recommendations:general_recommendations ()
                  in
                  return V.Failure_is_pending
            end
            else
              (* [verify_path_exists] already did a [fail] for us. It is pending ... *)
              return V.Failure_is_pending)
  in
  return task