Source file XCommon.ml

(** Common code for [XGetObject], [XGetBundle], and all the other [X*] modules.
*)

(** An identifier within the source of a build file and the context for running
    a shell command. *)
module IdWithContext = struct
  type t = {
    id : MlFront_Thunk.ThunkCommand.module_version;
    id_range : Fmlib_parse.Position.range;
    source : BuildCore.Io.file_object;
    source_sha256 : string;
    config : BuildConfig.t;
    initiator : BuildTask.initiator;
  }

  let create ~id ~source ~source_sha256 ~config ~initiator =
    { id = snd id; id_range = fst id; source; source_sha256; config; initiator }

  let debug_reference
      { source; source_sha256; id = _; id_range; config = _; initiator = _ } :
      BuildCore.Alacarte_3_2_apparatus.K.reference option =
    Some
      {
        reference_range = id_range;
        reference_file_sha256 = source_sha256;
        reference_transient = Some { reference_file = source };
      }

  let module_id { id; _ } = id.id
  let module_semver { id; _ } = id.version
  let config { config; _ } = config
  let initiator { initiator; _ } = initiator
  let source { source; _ } = source
end

let rec unzip_and_cache_value ~config ~source range value :
    MlFront_Core.FilePath.t option BuildInstance.Syntax.cont =
  let open BuildInstance.Syntax in
  let g ~value_id ~category () =
    let* object_archive_opt =
      read_value_or_fail ~config ~value_id ~source range ()
    in
    let metadb = BuildConfig.metadb config in
    match object_archive_opt with
    | None -> return None
    | Some object_archive -> (
        let srczip = MlFront_Core.FilePath.to_string object_archive in
        let dbresult :
            ((Fpath.t, [ `ErrorCaptured ]) result, [ `ErrorCaptured ]) result =
          MlFront_Cache.MetaDb.with_ ~supercategory:"val" metadb
            (fun
              ~data_ops:(module DataOps : MlFront_Cache.MetaOps.S)
              ~cache_ops:(module CacheOps : MlFront_Cache.MetaOps.S)
            ->
              CacheOps.cache_dir ~category ~key:value_id
                ~cache_hit:(fun ~dir_for_upsert:_ _cdir -> Ok `Keep)
                ~cache_miss:(fun ~dir_for_upsert ->
                  try
                    MlFront_ZipFile.ZipFile.unzip_exn ~srczip
                      ~destdir:(Fpath.to_string dir_for_upsert)
                      ();
                    Ok `Upsert
                  with MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) ->
                    MlFront_Errors.Errors.Details.add_error (fun ppf () ->
                        Format.fprintf ppf
                          "Unsuccessful unzip of `%s` into `%a`: %s"
                          (MlFront_Core.FilePath.show object_archive)
                          Fpath.pp dir_for_upsert msg);
                    Error `ErrorCaptured)
                ())
        in
        match dbresult with
        | Ok (Ok dir) ->
            return
              (Some (MlFront_Core.FilePath.of_string_exn (Fpath.to_string dir)))
        | Ok (Error `ErrorCaptured) | Error `ErrorCaptured ->
            let* () =
              let msg =
                Format.asprintf "%a" MlFront_Errors.Errors.Details.pp ()
              in
              fail_cant_unzip ~source ~msg ~srczip range
            in
            return None)
  in
  match (value : BuildCore.Alacarte_3_2_apparatus.V.t) with
  | Object { value_id; value_sha256 = _; value = Some _ } ->
      g ~value_id ~category:"object" ()
  | Bundle { value_id; value_sha256 = _; value = Some _ } ->
      g ~value_id ~category:"bundle" ()
  | Asset { value_id; value_sha256 = _; value = Some _ } ->
      g ~value_id ~category:"asset" ()
  | Distribution _ | Object _ | Constant _ | ValuesFile _ | Values _ | Form _
  | Bundle _ | Asset _ | Input_not_found _ | Failure_is_pending ->
      (* Should never happen. *)
      let* () =
        fail ~error_code:"c04e9687" ~cant_do:"get value"
          ~because:
            (Format.asprintf "the value is not fully specified: %a"
               BuildCore.Alacarte_3_2_apparatus.V.pp value)
          ~recommendations:[ "This is a bug. Please file an issue." ]
          ()
      in
      return None

(** [output_value].

    [cid] is the canonical id of the _parent_ AST which contains the precommand
    that is running. It is needed so we can copy the precommand up-to-date value
    to the destination _parent_ SLOT (or whatever directory it is going). In
    other words, the precommand output goes into the parent AST directories. *)
and output_value ~config ~initiator ~source ~command_output ~archive_member key
    value : unit BuildCore.Alacarte_6_4_test.CSuspending.t =
  let open BuildInstance.Syntax in
  let g ~value_id ~typ () =
    let* fp_opt =
      read_value_or_fail ~config ~value_id ~source (fst command_output) ()
    in
    match fp_opt with
    | None -> return ()
    | Some fp ->
        output_object ~config ~initiator ~source ~command_output
          ~cant_do:(Printf.sprintf "use value store %s `%s`" typ value_id)
          ~archive_member fp
  in
  match (value : BuildCore.Alacarte_3_2_apparatus.V.t) with
  | Object { value_id; value_sha256 = _; value = Some _ } ->
      g ~value_id ~typ:"object" ()
  | Bundle { value_id; value_sha256 = _; value = Some _ } ->
      g ~value_id ~typ:"bundle" ()
  | Asset { value_id; value_sha256 = _; value = Some _ } ->
      g ~value_id ~typ:"asset" ()
  | Constant
      {
        value_id;
        value_sha256 = _;
        value = Some { constant_transient = Some { constant_value } };
      } ->
      output_constant ~key ~config ~initiator ~source ~command_output
        ~archive_member ~constantid:value_id constant_value
  | Distribution _ | Object _ | Constant _ | ValuesFile _ | Values _ | Form _
  | Bundle _ | Asset _ | Input_not_found _ | Failure_is_pending ->
      (* Should never happen. *)
      fail ~error_code:"6d73e0d1" ~cant_do:"output value"
        ~because:
          (Format.asprintf "the value is not fully specified: %a"
             BuildCore.Alacarte_3_2_apparatus.V.pp value)
        ~recommendations:[ "This is a bug. Please file an issue." ]
        ()

and mkdir ~source ~what range 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 range in
      fail ~error_code:"14019995"
        ~cant_do:(Printf.sprintf "create %s" what)
        ~because:e ~error_locations ()
  | `Created -> return ()

(** Use a value that has just been placed in the value store. The sha256 of that
    value is computed on the fly, and depending on the integrity configuration
    the value may be validated on the flay. *)
and read_value_or_fail ~config ~value_id ~source range () =
  let open BuildInstance.Syntax in
  let* fp_opt =
    lift_promise
    @@ BuildInstance.ValueStore.get_value_file
         ~valuestore:(BuildConfig.valuestore config)
         ~value_id ()
  in
  begin
    let* error_locations = range_into_problem_location ~source range in
    match fp_opt with
    | None ->
        let* () =
          fail ~error_code:"98ca2699"
            ~cant_do:(Printf.sprintf "find cached value `%s`" value_id)
            ~because:
              (Printf.sprintf "it is not present in the value store `%s`"
                 (MlFront_Core.FilePath.to_string
                    (BuildConfig.valuestore config)))
            ~error_locations
            ~recommendations:
              [
                "The value may have been evicted from the value store. Try \
                 rerunning with the `--integrity existence` or the \
                 `--integrity checksum` option.";
              ]
            ()
        in
        return None
    | Some fp ->
        (* let* sha256_result =
          lift_promise @@ BuildCore.Io.sha256_file (BuildCore.Io.disk_file fp)
        in
        match sha256_result with
        | `Error e ->
            let* () =
              fail ~error_code:"502ef6b2"
                ~cant_do:
                  (Printf.sprintf
                     "compute the checksum of the cached value `%s`" value_id)
                ~because:e ~error_locations ()
            in
            return None
        | `Sha256 sha256 -> return (Some (fp, `Sha256 sha256))
         *)
        return (Some fp)
  end

and output_constant ~key ~config ~initiator ~source
    ~(command_output :
       Fmlib_parse.Position.range * MlFront_Thunk.ThunkCommand.shell_output)
    ~archive_member ~constantid constantvalue =
  let open BuildInstance.Syntax in
  let output_range, shell_output = command_output in

  let write_constantfile ~what fp =
    let* () =
      mkdir ~source ~what output_range (MlFront_Core.FilePath.parent fp)
    in
    (* Write the constant value to the file. *)
    let* replace_result =
      lift_promise
      @@ BuildCore.Io.replace_all_string
           (BuildCore.Io.disk_file fp)
           constantvalue 0
           (String.length constantvalue)
    in
    match replace_result with
    | `Error e ->
        let* error_locations =
          range_into_problem_location ~source output_range
        in
        fail ~error_code:"1f193cdd" ~cant_do:"write constant to file" ~because:e
          ~error_locations ()
    | `IsDirectory _ ->
        let* error_locations =
          range_into_problem_location ~source output_range
        in
        fail ~error_code:"d644796b" ~cant_do:"write constant to file"
          ~because:"the file is a directory" ~error_locations ()
    | `WroteBytes -> return ()
  in

  (* In MlFront_ZipFile we do not (yet) support in-memory zip archives, so
     we stage the in-memory zip archives to a file when we have to do zip
     operations. *)
  let stage_constantfile () =
    let fp =
      MlFront_Core.FilePath.append_exn constantid
        (BuildTask.resolve_labeled_path ~config ~initiator `StagedConstant)
    in
    let* () = write_constantfile ~what:"staging directory for constants" fp in
    return fp
  in
  (* When an archive member is requested, stage the object into an intermediate
     zipfile and then extract the file/directory from that intermediate
     zipfile. *)
  match archive_member with
  | Some archive_member ->
      if MlFront_ZipFile.ZipFile.is_string_zip constantvalue then
        let* constantfile = stage_constantfile () in
        output_from_archive_member ~config ~initiator ~source ~command_output
          ~cant_do:
            (Printf.sprintf
               "copy the archive member `%s` of the zipped value `%s to the \
                output directory"
               archive_member
               (MlFront_Core.FilePath.to_string constantfile))
          ~srczip:constantfile archive_member
      else
        fail_no_archive_member_without_zip ~source ~archive_member output_range
          key
  | None ->
  match shell_output with
  | MlFront_Thunk.ThunkCommand.OutputFile file -> begin
      match BuildTask.eval_term_as_filepath ~config ~initiator file with
      | Ok destination ->
          let* () =
            write_constantfile ~what:"directory for output file" destination
          in
          return ()
      | Error e -> fail_bad_expression ~source ~because:e output_range
    end
  | MlFront_Thunk.ThunkCommand.OutputDir { dir; strip } ->
      if MlFront_ZipFile.ZipFile.is_string_zip constantvalue then
        let* constantfile = stage_constantfile () in
        output_from_filepath ~config ~initiator ~source ~command_output
          ~cant_do:
            (Printf.sprintf "copy the zipped value to the output directory `%s`"
               (MlFront_Core.FilePath.to_string constantfile))
          constantfile
      else begin
        let* () =
          if strip <> 0 then
            fail_no_strip_without_zip ~strip ~source
              (fun ppf () -> Format.fprintf ppf "the constant value")
              () output_range key
          else return ()
        in
        match BuildTask.eval_term_as_filepath ~config ~initiator dir with
        | Error e -> fail_bad_expression ~source ~because:e output_range
        | Ok destination ->
            let* () =
              write_constantfile ~what:"output directory"
                (MlFront_Core.FilePath.append_exn "OBJECT" destination)
            in
            return ()
      end

and output_object ~config ~initiator ~source
    ~(command_output :
       Fmlib_parse.Position.range * MlFront_Thunk.ThunkCommand.shell_output)
    ~cant_do ~archive_member sourcevalue =
  (* When an archive member is requested, stage the object into an intermediate
     zipfile and then extract the file/directory from that intermediate
     zipfile. *)
  match archive_member with
  | Some archive_member ->
      output_from_archive_member ~config ~initiator ~source ~command_output
        ~cant_do ~srczip:sourcevalue archive_member
  | None ->
      output_from_filepath ~config ~initiator ~source ~command_output ~cant_do
        sourcevalue

(** Stage the object into an intermediate zipfile and then extract the
    file/directory from that intermediate zipfile. *)
and output_from_archive_member ~config ~initiator ~source ~command_output
    ~cant_do ~srczip archive_member =
  let srczip_s = MlFront_Core.FilePath.to_string srczip in
  let destfile =
    BuildTask.resolve_labeled_path ~config ~initiator
      (`StagedArchiveMember archive_member)
  in
  MlFront_ZipFile.ZipFile.extract_file_exn ~srczip:srczip_s
    ~destfile:(MlFront_Core.FilePath.to_string destfile)
    archive_member;
  if Sys.file_exists (MlFront_Core.FilePath.to_string destfile) then
    output_from_filepath ~config ~initiator ~source ~command_output ~cant_do
      destfile
  else
    fail_archive_member_not_found ~source ~srczip ~cant_do ~archive_member
      (fst command_output)

and output_from_filepath ~config ~initiator ~source ~command_output ~cant_do fp
    =
  let open BuildInstance.Syntax in
  match command_output with
  | output_range, MlFront_Thunk.ThunkCommand.OutputFile file -> begin
      match BuildTask.eval_term_as_filepath ~config ~initiator file with
      | Error e -> fail_bad_expression ~source ~because:e output_range
      | Ok file ->
          let* () =
            mkdir ~source ~what:"directory of output file" output_range
              (MlFront_Core.FilePath.parent file)
          in
          copy_file_or_fail ~source ~src:fp ~dest:file ~cant_do output_range
    end
  | output_range, MlFront_Thunk.ThunkCommand.OutputDir { dir; strip } -> begin
      match BuildTask.eval_term_as_filepath ~config ~initiator dir with
      | Error e -> fail_bad_expression ~source ~because:e output_range
      | Ok destdir ->
          let sourcevalue_s = MlFront_Core.FilePath.to_string fp in
          let destdir_s = MlFront_Core.FilePath.to_string destdir in
          if MlFront_ZipFile.ZipFile.is_file_zip sourcevalue_s then
            let* () =
              mkdir ~source ~what:"output directory" output_range destdir
            in
            try
              MlFront_ZipFile.ZipFile.unzip_exn ~strip ~srczip:sourcevalue_s
                ~destdir:destdir_s ();
              return ()
            with MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) ->
              fail_cant_unzip ~source ~msg ~srczip:sourcevalue_s
                ~destdir:destdir_s output_range
          else fail_dest_is_dir_but_source_not_zip ~source ~cant_do output_range
    end

and fail_cant_unzip ?destdir ~source ~msg ~srczip range =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"ee3b4e89"
    ~cant_do:
      (match destdir with
      | Some destdir -> Printf.sprintf "unzip `%s` into `%s`" srczip destdir
      | None -> Printf.sprintf "unzip `%s`" srczip)
    ~because:msg ~error_locations ()

and fail_no_archive_member_without_zip ~source ~archive_member range key =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"88de79d8"
    ~cant_do:
      (Format.asprintf "get archive member `%s` from %a" archive_member
         BuildCore.Alacarte_3_2_apparatus.K.pp key)
    ~because:"the constant value is not a zipfile" ~error_locations ()

and fail_no_strip_without_zip ~source ~strip pp_target target range key =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"6a51c6c0"
    ~cant_do:
      (Format.asprintf "strip `%d` levels from %a" strip
         BuildCore.Alacarte_3_2_apparatus.K.pp key)
    ~because:(Format.asprintf "%a is not a zipfile" pp_target target)
    ~error_locations ()

and fail_dest_is_dir_but_source_not_zip ~source ~cant_do range =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"d105a5c5" ~cant_do
    ~because:"directories can't be an output if the source is not a zipfile"
    ~error_locations
    ~recommendations:
      [
        "Use `-d DIR` only when the source is a zipfile. Try `-f FILE` instead.";
      ]
    ()

and fail_archive_member_not_found ~source ~srczip ~cant_do ~archive_member range
    =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"73b4560b" ~cant_do
    ~because:
      (Printf.sprintf "the archive member `%s` was not found" archive_member)
    ~error_locations
    ~recommendations:
      [
        Printf.sprintf
          "Use `unzip -l` on Unix or your favorite zip tool (ex. WinZip, 7zip) \
           on Windows to list the archive members of `%s`. Make sure you use \
           the exact name listed, including any `./` prefix."
          (MlFront_Core.FilePath.to_string srczip);
      ]
    ()

and fail_bad_expression ~source ~because range =
  let open BuildInstance.Syntax in
  let* error_locations = range_into_problem_location ~source range in
  fail ~error_code:"42a341f3" ~cant_do:"evaluate the expression" ~because
    ~error_locations ()

and range_into_problem_location ~source 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;
            };
        ]

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

let output_get_object = output_value

(* The implementation of ["install-object"] is the same as ["get-object"].

  The real difference is how overlapping paths are treated, but that is the
  responsibility of {!BuildTask.verify_nonoverlapping_subpaths_for_getobject} *)
let output_install_object = output_value

let output_pipe_object ~config ~initiator ~source ~pipe ~archive_member key
    value =
  (* in the reference implementation we don't use pipes. We just have standard locations
     for regular files  *)
  let piperange, pipename = pipe in
  let regularfile =
    BuildTask.resolve_labeled_path ~config ~initiator
      (`PipeAsRegularFile pipename)
  in
  let shell_output : MlFront_Thunk.ThunkCommand.shell_output =
    OutputFile
      [
        MlFront_Thunk.ThunkCommand.Literal
          (MlFront_Core.FilePath.to_string regularfile);
      ]
  in
  let command_output = (piperange, shell_output) in
  (* copy the output *)
  output_value ~config ~source ~command_output ~archive_member ~initiator key
    value

let output_get_asset = output_value
let output_get_asset_file = output_value