Source file ShellImportGH2.ml

(** ["import-github-l2"].

    The verification is mostly running the equivalent of:

    + get-asset from https://github.com/cli/cli/releases/tag/v2.81.0 (re-use
      assets for downloading!)
    + Run ["gh attestation download"] from
      {:https://docs.github.com/en/actions/how-tos/secure-your-work/use-artifact-attestations/verify-attestations-offline}

    The only thing is that the GitHub CLI must come from a trusted source:

    - either the bundle specs are embedded in the code (which means it can't be
      upgraded without a code change)
    - the bundle specs are in an include directory (which means we must have a
      non-SLSA attestation like signify authenticate the bundle specs)

    For the reference implementation we choose the first option: we'll embed the
    bundle specs into code. That makes auditing easier. But we'll embed from a
    "built-ins" include directory that can be tested and upgraded with --autofix
    easily. Instructions for testing are in the ["src/DkZero_Exec/builtins/"]
    directory. *)

module Cmdline = struct
  (** A command line.

      The command line that gets run is {!native_cmdline} and may use absolute
      paths (on Windows an absolute path is required if the path exceeds 260
      characters).

      The command line that gets displayed is {!portable_cmdline}, and should
      use relative paths.

      The separation between {!native_cmdline} and {!portable_cmdline} is for
      two reasons:
      + In cram tests which are done in uniquely named Dune sandboxes, we want
        repeatable results across platforms and even across different language
        implementations.
      + Most importantly, we want the end-user to repeat the results in their
        own directories. What good are security tools like attestations if you
        can't repeat the results on your own? *)

  type t = { native_cmdline : string; portable_cmdline : string }

  (** [create ?stdout ?stdout_to_stderr ?executable_maybe_rel ?args_maybe_rel
       ~executable args] creates a command line.

      - [?stdout]: if present, redirect standard output to this file path. If
        not present, redirect standard output to standard error.
      - [?executable_maybe_rel]: if present, this file path (which should be a
        relative path) is used for display in the portable command line.
      - [?args_maybe_rel]: if present, these arguments (which should be relative
        path arguments) are used for display in the portable command line.
      - [~executable]: the absolute or relative file path of the executable to
        run.
      - [args]: the absolute or relative path arguments to pass to the
        executable. *)
  let create ?stdout ?executable_maybe_rel ?args_maybe_rel ~executable args =
    let os_translate =
      if Sys.win32 then MlFront_Core.FilePath.to_windows
      else MlFront_Core.FilePath.to_unix
    in
    let native_cmdline =
      let cl =
        Filename.quote_command ?stdout
          (MlFront_Core.FilePath.to_string (os_translate executable))
          args
      in
      match stdout with
      | None ->
          (* works in DOS batch and in Unix shells *)
          cl ^ " 1>&2"
      | _ -> cl
    in
    let portable_cmdline =
      let executable' = Option.value ~default:executable executable_maybe_rel in
      let args' = Option.value ~default:args args_maybe_rel in
      MlFront_Core.FilePath.to_string executable' :: args'
      |> List.map
           MlFront_Thunk.ThunkLexers.PosixShellLexer.Token
           .quote_literal_if_needed
      |> String.concat " "
    in
    { native_cmdline; portable_cmdline }
end

(** ["MlFront_Attestation.GitHubCLI@2.81.0"] *)
let attestation_requirements host_abi_slot =
  let id =
    match
      MlFront_Core.StandardModuleId.parse "MlFront_Attestation.GitHubCLI"
    with
    | Ok id -> id
    | Error (`Msg msg) -> invalid_arg msg
  in
  let version =
    (* 2.81.0 *)
    match MlFront_Thunk.ThunkSemver64.from_parts 2L 81L 0L [] [] with
    | Some version -> version
    | None -> failwith "Can't form 2.81.0 version"
  in
  [
    `Object
      ( host_abi_slot,
        ({ id; version } : MlFront_Thunk.ThunkCommand.module_version) );
  ]

let full_repo = ref None
let tag = ref None
let outdir = ref None

let speclist ~usage_msg =
  [
    ("-R", Arg.String (fun s -> full_repo := Some s), "");
    ("--repo", Arg.String (fun s -> full_repo := Some s), "");
    ("--tag", Arg.String (fun s -> tag := Some s), "");
    ("--outdir", Arg.String (fun s -> outdir := Some s), "");
    ( "-help",
      Arg.Unit
        (fun () ->
          print_endline usage_msg;
          exit 0),
      "" );
    ( "--help",
      Arg.Unit
        (fun () ->
          print_endline usage_msg;
          exit 0),
      "" );
  ]

let anon_fun _ = ()

module CstIo = MlFront_Thunk.ThunkCst.Io (Wiring.BuildContext.Promise)
module BuildIndex' = DkZero_Base.BuildIndex.Make (Wiring.BuildContext)

type import_result =
  MlFront_Core.LibraryId.t
  * MlFront_Thunk.ThunkSemver64.t
  * MlFront_Core.FilePath.t
  * ([ `BLAKE2b_256 | `SHA1 | `SHA256 ] * string) list

type fetchable_asset = {
  asset_value_id : string;
  asset_origin : string;
  asset_path : string;
  asset_checksum : MlFront_Thunk.ThunkAst.asset_checksum;
  asset_size : Fmlib_parse.Position.range * int64;
  asset_indexes : MlFront_Thunk.ThunkAst.asset_index list;
  asset_mirrors : string * string list;
}

type fetchable_asset_kind = [ `Asset | `AssetIndex ]

type value_zip_source =
  | LocalZip of MlFront_Core.FilePath.t
  | IndexedRemoteZip of {
      indexed_remote_asset : fetchable_asset;
      indexed_remote_index : MlFront_Core.FilePath.t;
    }

type value_zip_entry_source =
  | LocalZipEntry of { srczip : MlFront_Core.FilePath.t; zip_entry : string }
  | IndexedRemoteZipEntry of {
      indexed_remote_asset : fetchable_asset;
      indexed_remote_index : MlFront_Core.FilePath.t;
      zip_entry : string;
    }

type discovered_distribution = {
  discovered_library_id : MlFront_Core.LibraryId.t;
  discovered_version : MlFront_Thunk.ThunkSemver64.t;
  discovered_values_file_sha256 : string;
}

let materialized_import_sources : (string, value_zip_source list) Hashtbl.t =
  Hashtbl.create 16

let checksums_of_contents contents =
  [
    ( `BLAKE2b_256,
      MlFront_Thunk.ThunkChecksum.BLAKE2B_256.(to_hex (digest_string contents))
    );
    (`SHA256, Digestif.SHA256.(to_hex (digest_string contents)));
    (`SHA1, Digestif.SHA1.(to_hex (digest_string contents)));
  ]

let import_key library_id version =
  Printf.sprintf "%s@%s"
    (MlFront_Core.LibraryId.full_name library_id)
    (MlFront_Thunk.ThunkSemver64.to_string version)

let read_all_file_or_error file =
  match
    Wiring.BuildContext.Promise.run_promise
      (Wiring.BuildContext.Io.read_all file)
  with
  | `Content contents -> contents
  | `Error msg ->
      ShellCore.quick_error
        (Printf.sprintf "Could not read '%s': %s"
           (Wiring.BuildContext.Io.file_origin file)
           msg)
  | `ExceededSizeLimit limit ->
      ShellCore.quick_error
        (Printf.sprintf "Could not read '%s': exceeded size limit of %Ld bytes"
           (Wiring.BuildContext.Io.file_origin file)
           limit)

let fold_left_map_state f state xs =
  let rev_ys, state' =
    List.fold_left
      (fun (ys, state) x ->
        let y, state' = f state x in
        (y :: ys, state'))
      ([], state) xs
  in
  (List.rev rev_ys, state')

let start_phase3 ctx ~traces ~request_slot module_or : Wiring.ShellCore.phase3 =
  let initiator =
    DkZero_Base.BuildRequest.UserInitiated
      { agent = "dk0 command"; request_slot }
  in
  let state, tasks, prefetch_keys =
    Wiring.BuildEngine.load_state_and_tasks_gracefully ctx ~traces module_or
  in
  { ctx; initiator; state; tasks; prefetch_keys; prefetch2_lua_scripts = [] }

let common_prefix =
  (* heavily adapted from https://ocaml.org/p/lambda-term/3.3.1/doc/src/lambda-term/lTerm_read_line.ml.html#val-common_prefix *)
  (* 
Copyright (c) 2011, Jeremie Dimino <jeremie@dimino.org>
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in the
      documentation and/or other materials provided with the distribution.
    * Neither the name of Jeremie Dimino nor the names of his
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY
EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHOR AND CONTRIBUTORS BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  
  *)
  let common_prefix_one a b =
    let extract_next s ofs =
      if ofs >= String.length s then ('\000', ofs)
      else
        let ch = String.get s ofs in
        (ch, ofs + 1)
    in
    let rec loop ofs =
      if ofs = String.length a || ofs = String.length b then String.sub a 0 ofs
      else
        let ch1, ofs1 = extract_next a ofs and ch2, ofs2 = extract_next b ofs in
        if ch1 = ch2 && ofs1 = ofs2 then loop ofs1 else String.sub a 0 ofs
    in
    loop 0
  in
  function
  | [] -> ""
  | word :: rest -> List.fold_left common_prefix_one word rest

(** The request slot is "Release." + host ABI *)
let get_host_abi_slot_or_exit () =
  match Dkml_c_probe.C_abi.V3.get_abi_name () with
  | Error msg -> ShellCore.quick_error msg
  | Ok abi -> (
      (* darwin_arm64 to Darwin_arm64 *)
      let abi = "Release." ^ String.capitalize_ascii abi in
      match MlFront_Thunk.ThunkObjectSlot.parse_literal abi with
      | Some slot -> slot
      | None ->
          ShellCore.quick_error
            (Printf.sprintf "Invalid host ABI object slot: `%s`" abi))

type download_failure = {
  error_code : string;
  because : string;
  recommendations : string list;
}

let github_empty_response_retry_delays =
  [ 10.0; 10.0 *. 1.7; 10.0 *. 1.7 *. 1.7 ]

let is_curl_empty_response { error_code; because; recommendations = _ } =
  String.equal error_code "8ff6585f"
  && String.equal because "`curl` exited with code 52"

let retry_empty_response_download ~what ~failure delays retry =
  match (!failure, delays) with
  | Some failure, delay :: rest when is_curl_empty_response failure ->
      prerr_endline
        (Printf.sprintf
           "[github-attestation] %s failed with an empty response; retrying in \
            %.1f seconds"
           what delay);
      ignore (Unix.select [] [] [] delay);
      Some (retry rest)
  | _ -> None

let rec process_import_github_l2_command ~usage_msg ~mini_usage_msg ~baseconfig
    ~verbosity ~progress ~install ~random_seed ~build_number ~long_ids
    ~invalidations ~dump_ancestors_graph ~dump_dependency_graph debugmodes
    module_or args =
  (* Parse *)
  let current = ref 1 in
  let cmdline = "dk0" :: "import-github-l2" :: args in
  (try
     Arg.parse_argv ~current (Array.of_list cmdline) (speclist ~usage_msg)
       anon_fun mini_usage_msg
   with
  | Arg.Bad msg ->
      prerr_endline msg;
      exit 1
  | Arg.Help msg ->
      prerr_endline msg;
      exit 0);

  (* Parse more *)
  let outdir =
    match !outdir with
    | None ->
        MlFront_Core.FilePath.concat
          (DkZero_Base.Config.baseconfig_workspacedir baseconfig)
          ShellCore.workspace_import_dir
    | Some s -> MlFront_Core.FilePath.of_string_exn s
  in
  let full_repo, tag =
    match !full_repo with
    | None ->
        prerr_endline mini_usage_msg;
        exit 1
    | Some repo -> begin
        let full_repo =
          match ShellCore.GitHubRepo.parse repo with
          | Error s ->
              prerr_endline ("Invalid GitHub repository. " ^ s);
              exit 1
          | Ok r -> r
        in
        let tag =
          match Option.map ShellCore.SemVerGitTag.parse !tag with
          | Some (Ok v) -> Some v
          | Some (Error msg) ->
              Printf.eprintf "Invalid semver tag.\n%s\n" msg;
              exit 1
          | None -> None
        in
        (full_repo, tag)
      end
  in

  (* source *)
  let source_file, (_source_sha256, _vsl_source_sz) =
    let contents =
      List.map
        MlFront_Thunk.ThunkLexers.ValueShellLexer.Token.quote_literal_if_needed
        cmdline
      |> String.concat " "
    in
    let file =
      Wiring.BuildContext.Io.inmemory_file
        ~origin:
          (MlFront_Core.FilePath.append_exn
             MlFront_Thunk.ThunkIo.shmdir_for_inmem_filesystem "argv")
        contents
    in
    match
      Wiring.BuildContext.run_isolated_promise
        (Wiring.BuildContext.Io.checksum_file ~algo:`SHA256 file)
    with
    | `Error msg -> ShellCore.quick_error msg
    | `Checksum sha256 -> (file, sha256)
  in

  (* Keep track of what we were doing when an exception happens *)
  let latest_cant_do = ref "run dk0" in
  try
    (* Start phase 1 *)
    let ({ preconfig } : Wiring.ShellCore.phase1) =
      ShellVSL.start_phase1 ~baseconfig ~random_seed ~cells:[] ~install ()
    in

    (* Start transaction to get attestation requirements like GitHub CLI *)
    let ctx, target_keys, state' =
      Txn.with_txn ~mode:`Create ~wait:true baseconfig (fun txn ->
          let tracefd = Txn.tracefd txn in

          (* Load traces. *)
          let traces =
            Invalidations.load_traces_gracefully ~preconfig ~reader_generation:0
              ~invalidations tracefd
          in

          (* Start phase 2 *)
          let ctx =
            ShellVSL.start_phase2 ~preconfig ~autofix:false ~verbosity ~progress
              ~nobuiltininc:false ~nosysinc:true ~noworkspaceinc:true
              ~sysincludedirs:[] ~userincludedirs:[] ~local_packages:[]
              ~build_number ~long_ids ~import:`Eager debugmodes module_or
          in

          (* Start phase 3 (our own) *)
          let host_abi_slot = get_host_abi_slot_or_exit () in
          let shell =
            start_phase3 ctx ~traces ~request_slot:(Some host_abi_slot) ()
          in

          (* Start phase 4 *)
          let shell =
            let state2 = ShellVSL.start_phase4 ~shell ~baseconfig () in
            { shell with state = state2 }
          in

          (* Run get-asset to get requirements like GitHub CLI *)
          let target_keys, state' =
            Wiring.ShellCore.run_keys ~ctx ~state:shell.state ~tasks:shell.tasks
              (attestation_requirements host_abi_slot)
          in

          (* Dump graphs if requested *)
          Wiring.ShellCore.dump_graph ~dump_ancestors_graph
            ~dump_dependency_graph state' target_keys;

          (* Finish phase 1 *)
          let (_newgen : int) = ShellVSL.finish_phase1 ctx state' tracefd in
          (ctx, target_keys, state'))
    in

    fst
      (do_import ~ctx ~state:state' ~source_file ~target_keys ~baseconfig
         ~outdir ~full_repo ~tag module_or)
  with
  | DkZero_Base.Exceptions.EngineShutdown
      { trace; exitcode_posix; exitcode_windows }
  ->
    ShellBacktrace.process_exception ~trace ~exitcode_posix ~exitcode_windows
      ~cant_do:!latest_cant_do ~source_file ~autofix:false module_or

and do_import ~ctx ~state ~source_file ~target_keys ~baseconfig ~outdir
    ~full_repo ~tag module_or =
  (* Get directory with [gh.exe] GitHub CLI *)
  let _state', github_cli_key, github_cli_directory =
    get_github_cli_key_and_directory ctx ~source_file ~target_keys ~state ()
  in

  (* Run the [gh attestation trusted-root] command if needed *)
  let trusted_root_file, trusted_root_cache_key =
    get_github_trusted_root_file ctx ~github_cli_key ~github_cli_directory ()
  in
  prerr_endline
    (Format.asprintf "[github-attestation] offline trusted root: %a"
       MlFront_Core.FilePath.pp trusted_root_file);

  (* Download the values.json file from the GitHub repo and tag *)
  let unattested_valuesjson_fp, unattested_values_json_sha256 =
    download_values_json ~outdir ~full_repo ~tag ()
  in

  (* Split distributions *)
  let dists =
    Wiring.SecDist.split_distributions module_or unattested_valuesjson_fp
  in

  (* Save each distribution *)
  let direct_imports =
    List.map
      (save_distribution ~module_or ~unattested_valuesjson_fp
         ~unattested_values_json_sha256 ~ctx ~baseconfig ~outdir ~full_repo
         ~github_cli_directory ~trusted_root_cache_key ~trusted_root_file)
      dists
  in
  let transitive_imports, state' =
    discover_transitive_imports ~preserve_referenced_values:false ~ctx ~state
      ~module_or ~outdir direct_imports
  in
  let imports =
    match Wiring.BuildContext.import ctx with
    | `Eager -> transitive_imports @ direct_imports
    | `Lazy -> direct_imports @ transitive_imports
  in
  (imports, state')

and save_distribution ~module_or ~unattested_valuesjson_fp
    ~unattested_values_json_sha256 ~ctx ~baseconfig ~outdir ~full_repo
    ~github_cli_directory ~trusted_root_cache_key ~trusted_root_file
    (unattested_dist_contents, dist, unattested_cst) =
  (* Find empty `github_slsa_v1_l2: {}` *)
  let { splitted_range = pending_attestation_location; library_id; version } :
      DkZero_Base.SecDist.unattested_dist =
    match
      Wiring.SecDist.Locations.find_unattested_github_slsa_v1_l2_dist module_or
        ~contents:unattested_dist_contents unattested_valuesjson_fp
        unattested_cst
    with
    | Error msg -> ShellCore.quick_error msg
    | Ok unattested -> unattested
  in
  (* Download values.json attestation bundle. *)
  let `Relative attestation_bundle_rel, `Absolute attestation_bundle_abs =
    download_github_attestation_bundle ctx
      ~absbasepath:(DkZero_Base.Config.baseconfig_absbasepath baseconfig)
      ~unattested_valuesjson_fp ~unattested_values_json_sha256
      ~github_cli_directory ~trusted_root_cache_key ~full_repo ()
  in

  (* Parse attestation bundle (jsonl format) into an array of json *)
  let attestation_jsons =
    Wiring.SecDist.read_attestation_bundle attestation_bundle_abs
  in
  let attestation_replacement =
    get_attestation_replacement ~pending_attestation_location attestation_jsons
  in
  let autofix =
    DkZero_Base.Autofix.create ~problematic_text:"{}"
      ~replace_with:attestation_replacement ~condition:"only when the verified"
      ()
  in

  (* Do offline verification *)
  github_offline_verify ctx ~trusted_root_file ~unattested_valuesjson_fp
    ~attestation_bundle_rel ~attestation_bundle_abs ~github_cli_directory
    ~full_repo ();

  (* Embed with autofix *)
  let startloc = fst pending_attestation_location in
  let fix =
    ({
       autofix;
       line = Fmlib_parse.Position.line startloc + 1;
       col = Fmlib_parse.Position.column startloc + 1;
     }
      : DkZero_Base.Autofix.fix)
  in

  (* the filename will be an aggregate of the library ids *)
  let attested_valuesjson_fp =
    MlFront_Core.FilePath.append_exn outdir
      (Printf.sprintf "%s.%s.values.json"
         (MlFront_Core.LibraryId.full_name library_id)
         (MlFront_Thunk.ThunkSemver64.to_string version))
  in

  match
    DkZero_Base.Autofix.save_with_fixes
      ~file_path:(MlFront_Core.FilePath.to_string attested_valuesjson_fp)
      ~contents:unattested_dist_contents [ fix ]
  with
  | Ok checksums ->
      if Wiring.BuildContext.verbose ctx then
        prerr_endline
          (Format.asprintf
             "[github-attestation] original github_slsa_v1_l2 location %a"
             (MlFront_Thunk.ThunkRanges.pp_range
                (Some (MlFront_Core.FilePath.to_string attested_valuesjson_fp)))
             pending_attestation_location);
      prerr_endline
        (Format.asprintf "[github-attestation] verified and saved to `%a`"
           MlFront_Core.FilePath.pp attested_valuesjson_fp);
      ( MlFront_Thunk.ThunkDist.library_id dist,
        MlFront_Thunk.ThunkDist.version dist,
        attested_valuesjson_fp,
        checksums )
  | Error m -> ShellCore.quick_error m

and discover_transitive_imports ~preserve_referenced_values ~ctx ~state
    ~module_or ~outdir (direct_imports : import_result list) =
  let visited = Hashtbl.create 16 in
  List.iter
    (fun (library_id, version, _, _) ->
      Hashtbl.replace visited (import_key library_id version) ())
    direct_imports;
  let discovered, state' =
    List.fold_left
      (fun (discovered, state) (_, _, values_file, _) ->
        let (trace_files, value_zip_files), state =
          distribution_payload_files ~preserve_referenced_values ~ctx ~state
            ~module_or
            (Wiring.BuildContext.Io.disk_file values_file)
        in
        let discovered, state =
          List.fold_left
            (fun (discovered, state) distribution ->
              let imported, state' =
                materialize_dependency_import ~ctx ~state ~outdir
                  ~value_zip_files distribution
              in
              let library_id, version, _, _ = imported in
              Hashtbl.replace visited (import_key library_id version) ();
              (imported :: discovered, state'))
            (discovered, state)
            (discover_distributions_from_tracestores ~trace_files ~visited)
        in
        (discovered, state))
      ([], state) direct_imports
  in
  ( List.sort
      (fun (library_id1, version1, _, _) (library_id2, version2, _, _) ->
        match
          String.compare
            (MlFront_Core.LibraryId.full_name library_id1)
            (MlFront_Core.LibraryId.full_name library_id2)
        with
        | 0 -> compare version1 version2
        | cmp -> cmp)
      discovered,
    state' )

and import_result_of_values_file ~module_or values_file =
  let values_file_obj = Wiring.BuildContext.Io.disk_file values_file in
  let ast = parse_values_json_ast ~module_or values_file_obj in
  let distribution : MlFront_Thunk.ThunkAst.distribution =
    parse_single_distribution values_file_obj ast
  in
  let _range, library_id, version = distribution.distribution_id in
  let contents = read_all_file_or_error values_file_obj in
  (library_id, version, values_file, checksums_of_contents contents)

and imports_from_saved_values_files ~ctx ~state ~module_or ~outdir values_files
    =
  let direct_imports =
    List.map (import_result_of_values_file ~module_or) values_files
  in
  let transitive_imports, state' =
    discover_transitive_imports ~preserve_referenced_values:false ~ctx ~state
      ~module_or ~outdir direct_imports
  in
  let imports =
    match Wiring.BuildContext.import ctx with
    | `Eager -> transitive_imports @ direct_imports
    | `Lazy -> direct_imports @ transitive_imports
  in
  (imports, state')

and distribution_payload_files ~preserve_referenced_values ~ctx ~state
    ~module_or values_file =
  let ast = parse_values_json_ast ~module_or values_file in
  let distribution = parse_single_distribution values_file ast in
  let ( (distmeta_trace_assets, distmeta_value_assets),
        (package_trace_assets, package_value_assets) ) =
    distribution_assets_from_ast ~values_file ~ast distribution
  in
  let source_value_zip_files =
    Hashtbl.find_opt materialized_import_sources
      (Wiring.BuildContext.Io.file_origin values_file)
  in
  let active_trace_assets = distmeta_trace_assets @ package_trace_assets in
  let active_value_assets = distmeta_value_assets @ package_value_assets in
  let downloaded_trace_files, state =
    fold_left_map_state
      (fun state asset ->
        download_asset_to_valuestore ~ctx ~state ~create_index:false
          ~value_id:asset.asset_value_id ~expected_index_value_id:None asset)
      state active_trace_assets
  in
  let referenced_value_ids =
    referenced_value_ids_from_trace_files downloaded_trace_files
  in
  let resolve_value_id ~kind asset =
    match Hashtbl.find_opt referenced_value_ids (kind, asset.asset_path) with
    | Some value_id -> value_id
    | None -> asset.asset_value_id
  in
  let trace_files, state =
    fold_left_map_state
      (fun state (asset, downloaded_trace_file) ->
        let value_id = resolve_value_id ~kind:`Asset asset in
        if String.equal value_id asset.asset_value_id then
          (downloaded_trace_file, state)
        else
          let trace_file, state' =
            download_asset_to_valuestore ~ctx ~state ~create_index:false
              ~value_id ~expected_index_value_id:None asset
          in
          let provisional_path =
            MlFront_Core.FilePath.to_string downloaded_trace_file
          in
          if Sys.file_exists provisional_path then Sys.remove provisional_path;
          (trace_file, state'))
      state
      (List.combine active_trace_assets downloaded_trace_files)
  in
  let has_split_package_payload = package_value_assets <> [] in
  let needs_value_zip_files =
    if has_split_package_payload then true
    else
      preserve_referenced_values
      || Option.is_some source_value_zip_files
      ||
      let visited = Hashtbl.create 4 in
      discover_distributions_from_tracestores ~trace_files ~visited <> []
  in
  let value_zip_files, state =
    if not needs_value_zip_files then ([], state)
    else
      fold_left_map_state
        (fun state asset ->
          fetch_value_zip_source ~ctx ~state
            ~value_id:(resolve_value_id ~kind:`Asset asset)
            ~expected_index_value_id:
              (Hashtbl.find_opt referenced_value_ids
                 (`AssetIndex, asset.asset_path))
            asset)
        state active_value_assets
  in
  let state =
    if (not needs_value_zip_files) || not preserve_referenced_values then state
    else
      let replay_value_zip_files =
        value_zip_files @ Option.value ~default:[] source_value_zip_files
      in
      seed_referenced_values_from_source_zips ~ctx ~state ~trace_files
        ~source_value_zip_files:replay_value_zip_files
  in
  ((trace_files, value_zip_files), state)

and seed_referenced_values_from_source_zips ~ctx ~state ~trace_files
    ~source_value_zip_files =
  let valuestore = Wiring.BuildContext.valuestore_maybe_relto_basedir ctx in
  let referenced_value_ids =
    all_referenced_value_ids_from_trace_files trace_files
  in
  List.fold_left
    (fun state value_id ->
      let existing =
        Wiring.BuildContext.Promise.run_promise
          (Wiring.BuildContext.get_value_file ~valuestore ~value_id ())
      in
      match existing with
      | Some _ -> state
      | None ->
      match
        find_value_entry_in_zips ~value_zip_files:source_value_zip_files
          ~value_id
      with
      | None -> state
      | Some entry_source ->
          let destfile =
            Wiring.BuildContext.Promise.run_promise
              (Wiring.BuildValues.prepare_value_for_upload ~valuestore ~value_id
                 ())
          in
          extract_value_entry_to_file ~ctx ~state ~entry_source ~destfile)
    state referenced_value_ids

and referenced_value_ids_from_trace_files trace_files =
  let referenced_value_ids = Hashtbl.create 16 in
  let visit_trace_file trace_file =
    let tracefd =
      Unix.openfile
        (MlFront_Core.FilePath.to_string trace_file)
        [ Unix.O_RDONLY ] 0
    in
    Fun.protect
      ~finally:(fun () -> Unix.close tracefd)
      (fun () ->
        match
          Wiring.BuildTraceStore.visit_kvtraces_in_file tracefd
            (fun key ~value_id _kvtrace ->
              match
                ((value_id, key) : string option * Wiring.BuildContext.K.t)
              with
              | ( Some value_id,
                  {
                    key_datum =
                      Wiring.BuildContext.K.ModuleKey
                        {
                          module_kind =
                            DkZero_Base.DataModel.UserAssetKind { asset_path };
                          module_id = _;
                          module_semver = _;
                        };
                    debug_reference = _;
                  } ) ->
                  Hashtbl.replace referenced_value_ids (`Asset, asset_path)
                    value_id
              | ( Some value_id,
                  {
                    key_datum =
                      Wiring.BuildContext.K.ModuleKey
                        {
                          module_kind =
                            DkZero_Base.DataModel.IndexAssetKind
                              { asset_path; index_type = `Zip };
                          module_id = _;
                          module_semver = _;
                        };
                    debug_reference = _;
                  } ) ->
                  Hashtbl.replace referenced_value_ids (`AssetIndex, asset_path)
                    value_id
              | _ -> ())
        with
        | Ok () -> ()
        | Error msg ->
            ShellCore.quick_error
              (Printf.sprintf "Could not inspect imported tracestore '%s': %s"
                 (MlFront_Core.FilePath.to_string trace_file)
                 msg))
  in
  List.iter visit_trace_file trace_files;
  referenced_value_ids

and all_referenced_value_ids_from_trace_files trace_files =
  let referenced_value_ids = Hashtbl.create 16 in
  let visit_trace_file trace_file =
    let tracefd =
      Unix.openfile
        (MlFront_Core.FilePath.to_string trace_file)
        [ Unix.O_RDONLY ] 0
    in
    Fun.protect
      ~finally:(fun () -> Unix.close tracefd)
      (fun () ->
        match
          Wiring.BuildTraceStore.visit_kvtraces_in_file tracefd
            (fun _key ~value_id _kvtrace ->
              match value_id with
              | Some value_id ->
                  Hashtbl.replace referenced_value_ids value_id ()
              | None -> ())
        with
        | Ok () -> ()
        | Error msg ->
            ShellCore.quick_error
              (Printf.sprintf "Could not inspect imported tracestore '%s': %s"
                 (MlFront_Core.FilePath.to_string trace_file)
                 msg))
  in
  List.iter visit_trace_file trace_files;
  Hashtbl.to_seq_keys referenced_value_ids |> List.of_seq

and parse_values_json_ast ~module_or values_file =
  let values_cst =
    match
      Wiring.BuildContext.Promise.run_promise
        (CstIo.parse module_or values_file)
    with
    | Ok values_cst -> values_cst
    | Error sm ->
        ShellCore.quick_error
          (Printf.sprintf "The imported values file '%s' is invalid:\n%s\n"
             (Wiring.BuildContext.Io.file_origin values_file)
             (MlFront_Thunk.ThunkResults.Semantic.error_message sm))
  in
  let origin = Some (Wiring.BuildContext.Io.file_origin values_file) in
  let execution_context = DkZero_Base.Execution.context () in
  match
    MlFront_Thunk.ThunkAst.parse_values_json ~origin module_or execution_context
      values_cst
  with
  | Ok ast -> ast
  | Error sm ->
      ShellCore.quick_error
        (Printf.sprintf
           "The imported values file '%s' could not be parsed as values.json:\n\
            %s\n"
           (Wiring.BuildContext.Io.file_origin values_file)
           (MlFront_Thunk.ThunkResults.Semantic.error_message sm))

and parse_single_distribution values_file ast :
    MlFront_Thunk.ThunkAst.distribution =
  let distributions =
    MlFront_Thunk.ThunkAst.fold_distributions_with_ranges ast ~init:[]
      ~f:(fun distribution _ distributions -> distribution :: distributions)
    |> List.rev
  in
  match distributions with
  | [ distribution ] -> distribution
  | [] ->
      ShellCore.quick_error
        (Printf.sprintf
           "The imported values file '%s' did not contain a distribution."
           (Wiring.BuildContext.Io.file_origin values_file))
  | _ ->
      ShellCore.quick_error
        (Printf.sprintf
           "The imported values file '%s' contained multiple distributions."
           (Wiring.BuildContext.Io.file_origin values_file))

and distribution_assets_from_ast ~values_file ~ast distribution =
  let _range, bundle_module_id, bundle_semver =
    distribution.build.build_to_sign.build_bundle_modver
  in
  let bundle_modver =
    ({ id = bundle_module_id; version = bundle_semver }
      : MlFront_Thunk.ThunkCommand.module_version)
  in
  let _bundle =
    match MlFront_Thunk.ThunkAst.find_bundle ast bundle_modver with
    | Some (bundle, _range) -> bundle
    | None ->
        ShellCore.quick_error
          (Printf.sprintf
             "The imported values file '%s' is missing bundle '%s'."
             (Wiring.BuildContext.Io.file_origin values_file)
             (MlFront_Thunk.ThunkCommand.show_module_version bundle_modver))
  in
  let fetchable_asset_from_path = function
    | `Trace
        ({ trace_path = _asset_range, asset_path; _ } :
          MlFront_Thunk.ThunkDist.build_trace) ->
        let asset =
          match
            MlFront_Thunk.ThunkAst.find_asset ast bundle_modver asset_path
          with
          | Some (asset, origin, _range) -> (asset, origin)
          | None ->
              ShellCore.quick_error
                (Printf.sprintf
                   "The imported values file '%s' is missing asset '%s'."
                   (Wiring.BuildContext.Io.file_origin values_file)
                   asset_path)
        in
        let asset, origin = asset in
        let build = MlFront_Thunk.ThunkSemver64.build bundle_semver in
        {
          asset_value_id =
            DkZero_Base.BuildTask.asset_value_id ~cid:asset.file_canonical_id
              ~build ();
          asset_origin = asset.file_origin;
          asset_path = asset.file_path;
          asset_checksum = asset.file_checksum;
          asset_size = asset.file_sz;
          asset_indexes = asset.file_indexes;
          asset_mirrors = origin.origin_mirrors;
        }
    | `Value
        ({ value_path = _asset_range, asset_path } :
          MlFront_Thunk.ThunkDist.build_value) ->
        let asset =
          match
            MlFront_Thunk.ThunkAst.find_asset ast bundle_modver asset_path
          with
          | Some (asset, origin, _range) -> (asset, origin)
          | None ->
              ShellCore.quick_error
                (Printf.sprintf
                   "The imported values file '%s' is missing asset '%s'."
                   (Wiring.BuildContext.Io.file_origin values_file)
                   asset_path)
        in
        let asset, origin = asset in
        let build = MlFront_Thunk.ThunkSemver64.build bundle_semver in
        {
          asset_value_id =
            DkZero_Base.BuildTask.asset_value_id ~cid:asset.file_canonical_id
              ~build ();
          asset_origin = asset.file_origin;
          asset_path = asset.file_path;
          asset_checksum = asset.file_checksum;
          asset_size = asset.file_sz;
          asset_indexes = asset.file_indexes;
          asset_mirrors = origin.origin_mirrors;
        }
  in
  let build_group_assets
      ({ MlFront_Thunk.ThunkDist.build_group_traces; build_group_values } :
        MlFront_Thunk.ThunkDist.build_store_group) =
    ( List.map
        (fun (trace : MlFront_Thunk.ThunkDist.build_trace) ->
          fetchable_asset_from_path (`Trace trace))
        build_group_traces,
      List.map
        (fun (value : MlFront_Thunk.ThunkDist.build_value) ->
          fetchable_asset_from_path (`Value value))
        build_group_values )
  in
  let distmeta_trace_assets, distmeta_value_assets =
    build_group_assets distribution.build.build_to_sign.build_distmeta
  in
  let package_trace_assets, package_value_assets =
    build_group_assets distribution.build.build_to_sign.build_package
  in
  ( (distmeta_trace_assets, distmeta_value_assets),
    (package_trace_assets, package_value_assets) )

and download_asset_to_valuestore ~expected_index_value_id ~ctx ~state
    ~create_index ~value_id asset =
  let valuestore = Wiring.BuildContext.valuestore_maybe_relto_basedir ctx in
  let failure_message = ref None in
  let failure = ref None in
  let on_fail ~location_if_checksum_error:_ ~error_code ~because
      ~recommendations () =
    let open Wiring.BuildContext.Syntax in
    failure := Some { error_code; because; recommendations };
    failure_message :=
      Some
        (Printf.sprintf
           "[error %s] Failed to download imported asset '%s' from origin '%s' \
            because %s.\n\
            %s"
           error_code asset.asset_path asset.asset_origin because
           (String.concat "\n" recommendations));
    return ()
  in
  let download value_file =
    (Wiring.BuildContext.download ctx)
      ~on_fail ~file_origin:asset.asset_origin ~file_path:asset.asset_path
      ~file_checksum:
        (asset.asset_checksum
          :> DkZero_Base.BuildContext.weak_capable_asset_checksum)
      ~file_offset:None ~file_sz:(Some asset.asset_size) ~file_trailer:None
      ~origin_mirrors:asset.asset_mirrors
      (Wiring.BuildContext.rootprogressnode ctx)
      value_file
  in
  let on_error msg =
    let open Wiring.BuildContext.Syntax in
    failure_message := Some msg;
    return `Failed
  in
  let rec download_with_retry delays =
    failure := None;
    failure_message := None;
    let kont =
      Wiring.BuildValues.download_value ~on_error ~valuestore ~download
        ~value_id (fun (value_file, _sha256) -> value_file)
    in
    let result, state' = Wiring.BuildContext.run_continuation kont state in
    match result with
    | `Success value_file ->
        if not create_index then (value_file, state')
        else
          let index_kont =
            BuildIndex'.create_and_upload_index
              ~what:(fun () ->
                Printf.sprintf "imported asset `%s`" asset.asset_path)
              ~valuestore ~value_id ~value_file ~error_locations:[]
              ~recommendations:[] ~asset_range:(fst asset.asset_size) ()
          in
          let index_result, state'' =
            Wiring.BuildContext.run_continuation index_kont state'
          in
          begin
            match index_result with
            | `Ok index ->
                begin
                  match expected_index_value_id with
                  | Some expected_index_value_id
                    when not
                           (String.equal index.index_value_id
                              expected_index_value_id) ->
                      ShellCore.quick_error
                        (Printf.sprintf
                           "Imported asset '%s' expected zip index value '%s' \
                            but created '%s'."
                           asset.asset_path expected_index_value_id
                           index.index_value_id)
                  | _ -> ()
                end;
                (value_file, state'')
            | `Already_failed ->
                ShellCore.quick_error
                  (Printf.sprintf
                     "Failed to create index for imported asset '%s'."
                     asset.asset_path)
          end
    | `Failed ->
    match
      retry_empty_response_download
        ~what:(Printf.sprintf "imported asset `%s` download" asset.asset_path)
        ~failure delays download_with_retry
    with
    | Some retry_result -> retry_result
    | None ->
        ShellCore.quick_error
          (Option.value !failure_message
             ~default:
               (Printf.sprintf
                  "Failed to download imported asset '%s' from origin '%s'."
                  asset.asset_path asset.asset_origin))
  in
  download_with_retry github_empty_response_retry_delays

and discover_distributions_from_tracestores ~trace_files ~visited =
  let discovered = Hashtbl.create 16 in
  let on_problem _ = () in
  let value_existence_check _ _ =
    Wiring.BuildContext.Promise.return
      DkZero_Base.BuildTraceStore.ValueNotNeeded
  in
  let valuestore_get _ _ = Wiring.BuildContext.Promise.return None in
  List.iter
    (fun trace_file ->
      let tracefd =
        Unix.openfile
          (MlFront_Core.FilePath.to_string trace_file)
          [ Unix.O_RDONLY ] 0
      in
      let visit_result =
        Fun.protect
          ~finally:(fun () -> Unix.close tracefd)
          (fun () ->
            Wiring.BuildTraceStore.visit_kvtraces_in_file tracefd
              (fun key ~value_id:_ kvtrace ->
                match
                  Wiring.BuildContext.Promise.run_promise
                    (Wiring.BuildTraceStore.value_from_proto ~on_problem
                       ~value_existence_check ~valuestore_get key
                       (DkZero_Base.BuildTraceStore.KVTrace.value_trace kvtrace))
                with
                | Some
                    ( _,
                      Wiring.BuildContext.V.Distribution
                        {
                          distribution_id = package_id, version;
                          distribution_values_file_sha256;
                          _;
                        } ) ->
                    let library_id =
                      MlFront_Core.PackageId.library_id package_id
                    in
                    let key = import_key library_id version in
                    if
                      not (Hashtbl.mem visited key || Hashtbl.mem discovered key)
                    then
                      Hashtbl.add discovered key
                        {
                          discovered_library_id = library_id;
                          discovered_version = version;
                          discovered_values_file_sha256 =
                            distribution_values_file_sha256;
                        }
                | _ -> ()))
      in
      match visit_result with
      | Ok () -> ()
      | Error msg ->
          ShellCore.quick_error
            (Printf.sprintf "Could not inspect imported tracestore '%s': %s"
               (MlFront_Core.FilePath.to_string trace_file)
               msg))
    trace_files;
  Hashtbl.to_seq_values discovered |> List.of_seq

and materialize_dependency_import ~ctx ~state ~outdir ~value_zip_files
    distribution =
  let _ =
    Wiring.BuildContext.Promise.run_promise
      (Wiring.BuildContext.Io.create_directory
         (Wiring.BuildContext.Io.disk_dir outdir))
  in
  let value_id =
    Wiring.BuildContext.V.get_valuesjsonfile_value_id
      ~values_file_sha256:distribution.discovered_values_file_sha256
  in
  let entry_source =
    match find_value_entry_in_zips ~value_zip_files ~value_id with
    | Some located -> located
    | None ->
        ShellCore.quick_error
          (Printf.sprintf
             "Could not recover dependency distribution '%s@%s' from the \
              imported valuestore."
             (MlFront_Core.LibraryId.full_name
                distribution.discovered_library_id)
             (MlFront_Thunk.ThunkSemver64.to_string
                distribution.discovered_version))
  in
  let outfile =
    MlFront_Core.FilePath.append_exn outdir
      (Printf.sprintf "%s.%s.values.json"
         (MlFront_Core.LibraryId.full_name distribution.discovered_library_id)
         (MlFront_Thunk.ThunkSemver64.to_string distribution.discovered_version))
  in
  let state' =
    extract_value_entry_to_file ~ctx ~state ~entry_source ~destfile:outfile
  in
  let contents =
    read_all_file_or_error (Wiring.BuildContext.Io.disk_file outfile)
  in
  Hashtbl.replace materialized_import_sources
    (MlFront_Core.FilePath.to_string outfile)
    value_zip_files;
  ( ( distribution.discovered_library_id,
      distribution.discovered_version,
      outfile,
      checksums_of_contents contents ),
    state' )

and find_value_entry_in_zips ~value_zip_files ~value_id =
  let found = ref None in
  List.iter
    (fun value_zip_file ->
      if Option.is_none !found then
        let index, srczip =
          match value_zip_file with
          | LocalZip srczip -> (None, srczip)
          | IndexedRemoteZip
              { indexed_remote_asset = _; indexed_remote_index = srczip } ->
              (Some (), srczip)
        in
        MlFront_ZipFile.ZipFile.zip_fold_entries ?index
          ~srczip:(MlFront_Core.FilePath.to_string srczip)
          (fun () entry _is_dir _size ->
            let normalized_entry =
              if String.starts_with ~prefix:"./" entry then
                String.sub entry 2 (String.length entry - 2)
              else entry
            in
            if String.equal normalized_entry value_id then
              found :=
                Some
                  (match value_zip_file with
                  | LocalZip srczip ->
                      LocalZipEntry { srczip; zip_entry = entry }
                  | IndexedRemoteZip
                      { indexed_remote_asset; indexed_remote_index } ->
                      IndexedRemoteZipEntry
                        {
                          indexed_remote_asset;
                          indexed_remote_index;
                          zip_entry = entry;
                        }))
          ())
    value_zip_files;
  !found

and first_zip_index asset =
  List.find_map
    (fun ({ index_type; index_zip } : MlFront_Thunk.ThunkAst.asset_index) ->
      match index_type with `Zip -> Some index_zip)
    asset.asset_indexes

and fetch_value_zip_source ~expected_index_value_id ~ctx ~state ~value_id asset
    =
  match first_zip_index asset with
  | Some (_range, index_zip) ->
      let index_value_id =
        match expected_index_value_id with
        | Some expected_index_value_id -> expected_index_value_id
        | None -> Wiring.BuildContext.V.get_index_value_id ~value_id
      in
      let index_file, state' =
        download_asset_index_to_valuestore ~ctx ~state ~index_value_id asset
          index_zip
      in
      ( IndexedRemoteZip
          { indexed_remote_asset = asset; indexed_remote_index = index_file },
        state' )
  | None ->
      let value_file, state' =
        download_asset_to_valuestore ~ctx ~state ~create_index:true ~value_id
          ~expected_index_value_id asset
      in
      (LocalZip value_file, state')

and download_asset_index_to_valuestore ~ctx ~state ~index_value_id asset
    ({
       indexzip_localheader_offset;
       indexzip_centraldir_offset;
       indexzip_centraldir_eocd_size;
       indexzip_checksum;
     } :
      MlFront_Thunk.ThunkAst.index_zip) =
  let valuestore = Wiring.BuildContext.valuestore_maybe_relto_basedir ctx in
  let failure_message = ref None in
  let failure = ref None in
  let on_fail ~location_if_checksum_error:_ ~error_code ~because
      ~recommendations () =
    let open Wiring.BuildContext.Syntax in
    failure := Some { error_code; because; recommendations };
    failure_message :=
      Some
        (Printf.sprintf
           "[error %s] Failed to download imported asset index '%s' from \
            origin '%s' because %s.\n\
            %s"
           error_code asset.asset_path asset.asset_origin because
           (String.concat "\n" recommendations));
    return ()
  in
  let trailer =
    DkZero_Base.BuildIndex.zipfile_index_value_trailer
      ~localheader_offset:indexzip_localheader_offset ()
  in
  let download value_file =
    (Wiring.BuildContext.download ctx)
      ~on_fail ~file_origin:asset.asset_origin ~file_path:asset.asset_path
      ~file_checksum:
        ((indexzip_checksum : MlFront_Thunk.ThunkAst.indexzip_checksum)
          :> DkZero_Base.BuildContext.weak_capable_asset_checksum)
      ~file_offset:(Some indexzip_centraldir_offset)
      ~file_sz:(Some indexzip_centraldir_eocd_size) ~file_trailer:(Some trailer)
      ~origin_mirrors:asset.asset_mirrors
      (Wiring.BuildContext.rootprogressnode ctx)
      value_file
  in
  let on_error msg =
    let open Wiring.BuildContext.Syntax in
    failure_message := Some msg;
    return `Failed
  in
  let rec download_with_retry delays =
    failure := None;
    failure_message := None;
    let kont =
      Wiring.BuildValues.download_value ~on_error ~valuestore ~download
        ~value_id:index_value_id (fun (value_file, _sha256) -> value_file)
    in
    let result, state' = Wiring.BuildContext.run_continuation kont state in
    match result with
    | `Success value_file -> (value_file, state')
    | `Failed ->
    match
      retry_empty_response_download
        ~what:
          (Printf.sprintf "imported asset index `%s` download" asset.asset_path)
        ~failure delays download_with_retry
    with
    | Some retry_result -> retry_result
    | None ->
        ShellCore.quick_error
          (Option.value !failure_message
             ~default:
               (Printf.sprintf
                  "Failed to download imported asset index '%s' from origin \
                   '%s'."
                  asset.asset_path asset.asset_origin))
  in
  download_with_retry github_empty_response_retry_delays

and extract_value_entry_to_file ~ctx ~state ~entry_source ~destfile =
  match entry_source with
  | LocalZipEntry { srczip; zip_entry } ->
      MlFront_ZipFile.ZipFile.unzip_entry_exn
        ~srczip:(MlFront_Core.FilePath.to_string srczip)
        ~destfile:(MlFront_Core.FilePath.to_string destfile)
        zip_entry;
      state
  | IndexedRemoteZipEntry
      { indexed_remote_asset; indexed_remote_index; zip_entry } ->
      extract_indexed_remote_entry_to_file ~ctx ~state
        ~asset:indexed_remote_asset ~indexzip:indexed_remote_index ~zip_entry
        ~destfile

and extract_indexed_remote_entry_to_file ~ctx ~state ~asset ~indexzip ~zip_entry
    ~destfile =
  let download_range ~state ~file_offset ~file_sz ~destination_file =
    let failure_message = ref None in
    let on_fail ~location_if_checksum_error:_ ~error_code ~because
        ~recommendations () =
      let open Wiring.BuildContext.Syntax in
      failure_message :=
        Some
          (Printf.sprintf
             "[error %s] Failed to download imported zip entry '%s' from asset \
              '%s' because %s.\n\
              %s"
             error_code zip_entry asset.asset_path because
             (String.concat "\n" recommendations));
      return ()
    in
    let kont =
      (Wiring.BuildContext.download ctx)
        ~on_fail ~file_origin:asset.asset_origin ~file_path:asset.asset_path
        ~file_checksum:
          (DkZero_Base.BuildToDo
           .asset_range_download_of_zip_entry_from_zip_index_needs_a_secure_checksum
             (fst asset.asset_size))
        ~file_offset ~file_sz ~file_trailer:None
        ~origin_mirrors:asset.asset_mirrors
        (Wiring.BuildContext.rootprogressnode ctx)
        destination_file
    in
    let result, state' = Wiring.BuildContext.run_continuation kont state in
    match result with
    | `Downloaded (`SHA256 (_sha256, size)) -> (size, state')
    | `Failed ->
        ShellCore.quick_error
          (Option.value !failure_message
             ~default:
               (Printf.sprintf
                  "Failed to download imported zip entry '%s' from asset '%s'."
                  zip_entry asset.asset_path))
  in
  let indexzip = MlFront_Core.FilePath.to_string indexzip in
  let localheader_range =
    MlFront_ZipFile.ZipFile.getrange_localheader_from_index_exn ~indexzip
      ~entry:zip_entry ()
  in
  let temp_dir = Filename.dirname (MlFront_Core.FilePath.to_string destfile) in
  let localheader_temp =
    Filename.temp_file ~temp_dir "zip-localheader" ".tmp"
  in
  let filedata_temp = Filename.temp_file ~temp_dir "zip-filedata" ".tmp" in
  let localheader_file = MlFront_Core.FilePath.of_string_exn localheader_temp in
  let filedata_file = MlFront_Core.FilePath.of_string_exn filedata_temp in
  let cleanup filepath = if Sys.file_exists filepath then Sys.remove filepath in
  Fun.protect
    ~finally:(fun () ->
      cleanup localheader_temp;
      cleanup filedata_temp)
    (fun () ->
      let localheader_size, state' =
        download_range ~state
          ~file_offset:
            (Some
               (MlFront_ZipFile.ZipFile.LocalHeaderFileRangePlus.offset
                  localheader_range))
          ~file_sz:
            (Some
               ( fst asset.asset_size,
                 MlFront_ZipFile.ZipFile.LocalHeaderFileRangePlus.len
                   localheader_range ))
          ~destination_file:localheader_file
      in
      if localheader_size > 8192L then
        ShellCore.quick_error
          (Printf.sprintf
             "The local header for imported zip entry '%s' in asset '%s' is \
              larger than 8KB."
             zip_entry asset.asset_path);
      let localheader_bytes =
        In_channel.with_open_bin localheader_temp In_channel.input_all
      in
      let filedata_range =
        MlFront_ZipFile.ZipFile.getrange_data_from_localheader_exn
          ~localheader_bytes localheader_range
      in
      cleanup localheader_temp;
      let _filedata_size, state'' =
        download_range ~state:state'
          ~file_offset:
            (Some
               (MlFront_ZipFile.ZipFile.FileDataRangePlus.offset filedata_range))
          ~file_sz:
            (Some
               ( fst asset.asset_size,
                 MlFront_ZipFile.ZipFile.FileDataRangePlus.len filedata_range ))
          ~destination_file:filedata_file
      in
      (try
         MlFront_ZipFile.ZipFile.unzip_datafile_exn ~datafile:filedata_temp
           ~destfile:(MlFront_Core.FilePath.to_string destfile)
           filedata_range
       with MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) ->
         ShellCore.quick_error
           (Printf.sprintf
              "Could not decompress imported zip entry '%s' from asset '%s': %s"
              zip_entry asset.asset_path msg));
      state'')

and get_github_cli_key_and_directory ctx ~source_file ~target_keys ~state () =
  let github_cli_key =
    match target_keys with
    | [] -> ShellCore.quick_error "No target keys"
    | [ gh_key ] -> gh_key
    | _ -> ShellCore.quick_error "Expected one (1) target key"
  in
  (* The object directory will contain the [gh.exe] GitHub CLI *)
  let kont2 =
    Wiring.BuildEngine.unzip_and_cache_value ctx ~source:source_file
      Fmlib_parse.Position.(start, start)
      github_cli_key
  in
  let gh_dir_opt, state =
    Wiring.BuildTaskUnresolved.run_continuation kont2 state
  in
  match gh_dir_opt with
  | Some fp ->
      (* do [chmod] and maybe [codesign] on cached gh.exe *)
      let gh_exe = MlFront_Core.FilePath.append_exn fp "gh.exe" in
      let mkexec_promise =
        Wiring.FileMod.make_executable
          ~basedir:(Wiring.BuildContext.absbasepath ctx)
          ~codesign_tmp:(Wiring.BuildPaths.resolve_user_codesign_path ctx)
          ~on_error:(fun ~error_code ~cant_do ~because ->
            ShellCore.quick_error
              (Format.asprintf
                 "[%s]: Failed to set executable permissions on GitHub CLI \
                  `%a`: %s because %s"
                 error_code MlFront_Core.FilePath.pp gh_exe cant_do because))
          gh_exe
      in
      let _ : (unit, _) result =
        Wiring.BuildContext.Promise.run_promise mkexec_promise
      in
      ();
      (* done *)
      (state, github_cli_key, fp)
  | None ->
      ShellCore.quick_error
        (Format.asprintf
           "The GitHub CLI executable was not produced by the build.")

(** Run or re-use cached output from ["gh attestation trusted-root"].

    It would be nice to do this within the github attestation values.json file.
    However, [gh attestation trusted-root] writes to standard output and we
    don't have a way to capture that output and place it in a SLOT directory.
    With shells (PowerShell, etc.) we could do that, so no need to complicate
    our build system implementation with a redundant feature to capture standard
    output.

    The cache key is both:
    - the module_version of the GitHub attestation build key which is something
      like ["MlFront_Attestation.GitHubCLI@2.81.0+bn-20250101000000"] and
      includes the GitHub CLI version and the _first_ build number to
      successfully build the GitHub CLI.
    - the conventionally time-varying build number (ex. ["--build-period"]) from
      dk0 *)
and get_github_trusted_root_file ctx ~github_cli_key ~github_cli_directory () =
  let gh_exe = MlFront_Core.FilePath.append_exn github_cli_directory "gh.exe" in
  let cache_key1 =
    Wiring.BuildContext.K.module_version_exn github_cli_key
    |> MlFront_Thunk.ThunkCommand.show_module_version
  in
  let cache_key2 = Wiring.BuildContext.build_number ctx in
  let cache_key = Printf.sprintf "%s/%s" cache_key1 cache_key2 in
  if Wiring.BuildContext.verbose ctx then
    prerr_endline
      (Format.asprintf "[github-attestation] trusted root cache key: %s"
         cache_key);
  let trusted_root_filename = "trusted_root.jsonl" in
  let dbresult =
    MlFront_Cache.MetaDb.with_sync ~supercategory:"attest"
      (Wiring.BuildContext.metadb ctx)
      (fun
        ~data_ops:(module DataOps : MlFront_Cache.MetaOps.S)
        ~cache_ops:(module CacheOps : MlFront_Cache.MetaOps.S)
      ->
        CacheOps.cache_dir ~category:"github" ~key:cache_key
          ~cache_hit:(fun ~dir_for_upsert:_ _cdir -> Ok `Keep)
          ~cache_miss:(fun ~dir_for_upsert ->
            MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
              ~return:(function
                | `Created -> () | `Error e -> ShellCore.quick_error e)
              dir_for_upsert;

            let outfile =
              MlFront_Core.FilePath.append_exn dir_for_upsert
                trusted_root_filename
            in
            let cmdline =
              Cmdline.create
                ~stdout:(MlFront_Core.FilePath.to_string outfile)
                ~executable:gh_exe
                [ "attestation"; "trusted-root" ]
            in
            run_github_cli ctx ~command:"gh attestation trusted-root"
              (fun () -> Ok `Upsert)
              cmdline)
          ())
  in
  match dbresult with
  | Ok (Ok dir) ->
      (MlFront_Core.FilePath.append_exn dir trusted_root_filename, cache_key)
  | Ok (Error (`WrappableMsg defer)) | Error (`WrappableMsg defer) ->
      let msg = Format.asprintf "%a" defer () in
      ShellCore.quick_error msg

and download_values_json ~outdir ~full_repo ~tag () =
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(function `Created -> () | `Error e -> ShellCore.quick_error e)
    outdir;
  let unattested_valuesjson_fp =
    MlFront_Core.FilePath.append_exn outdir "values.unattested.json"
  in

  let url =
    match tag with
    | Some tag ->
        Printf.sprintf "https://%s/releases/download/%s"
          (ShellCore.GitHubRepo.to_string full_repo)
          (ShellCore.SemVerGitTag.to_string tag)
    | None ->
        Printf.sprintf "https://%s/releases/latest/download"
          (ShellCore.GitHubRepo.to_string full_repo)
  in
  let download_result =
    let file_path = "values.json" in
    let failure = ref None in
    let handle_fail ~error_code ~because ~recommendations () =
      failure := Some { error_code; because; recommendations };
      Error
        (Printf.sprintf
           "[error %s] Failed to download values.json because %s.\n%s"
           error_code because
           (String.concat "\n" recommendations)
        |> String.trim)
    in
    prerr_endline
      (Format.asprintf "[github-attestation] download %s/%s to %a" url file_path
         MlFront_Core.FilePath.pp unattested_valuesjson_fp);
    let rec download_with_retry delays =
      failure := None;
      let result =
        ShellCore.download_remote ~on_fail:handle_fail ~file_path
          ~file_offset:None ~file_sz:None ~file_trailer:None ~autofix:false
          ~return:(function
            | ShellCore.Downloaded
                { origin = _; origin_relfilepath = _; downloaded_checksum = _ }
              ->
                Ok ()
            | ShellCore.Failed e -> Error e
            | ShellCore.FailedRetryableAttempt
                {
                  error_code;
                  because;
                  recommendations;
                  location_if_checksum_error = _;
                } ->
                handle_fail ~error_code ~because ~recommendations ())
          ~mirror:url unattested_valuesjson_fp
      in
      match result with
      | Ok () -> Ok ()
      | Error _ ->
      match
        retry_empty_response_download ~what:"values.json download" ~failure
          delays download_with_retry
      with
      | Some retry_result -> retry_result
      | None -> result
    in
    download_with_retry github_empty_response_retry_delays
  in
  match download_result with
  | Error e -> ShellCore.quick_error (Printf.sprintf "download failed: %s" e)
  | Ok () ->
      let file_sha256, _file_sz =
        MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file ~algo:`SHA256
          ~return:(function
            | `Error e -> ShellCore.quick_error e | `Checksum cksum -> cksum)
          (MlFront_Core.FilePath.to_string unattested_valuesjson_fp)
      in
      (unattested_valuesjson_fp, file_sha256)

(** Dev note: GitHub likely uses the SHA256 of the values.json to download the
    attestation bundle, from some organization-wide repository (because owner is
    mandatory but not the repository).
    {b Do not assume that the attestation is done simply because the bundle is
       downloaded!} It may be possible that some other repository within the
    organization has attested the values.json file, or that the attestation was
    for an expired job, etc. *)
and download_github_attestation_bundle ctx ~absbasepath
    ~unattested_valuesjson_fp:unattested_values_json_maybe_rel
    ~unattested_values_json_sha256 ~github_cli_directory ~trusted_root_cache_key
    ~full_repo () =
  let gh_exe = MlFront_Core.FilePath.append_exn github_cli_directory "gh.exe" in
  let cache_key =
    Printf.sprintf "%s/%s" trusted_root_cache_key unattested_values_json_sha256
  in
  if Wiring.BuildContext.verbose ctx then
    prerr_endline
      (Format.asprintf "[github-attestation] attestation bundle cache key: %s"
         cache_key);

  (* A2: On Windows the superlong path segments can lead to MAX_PATH limits.
      Ex: Y:\source\dksdk-coder\_build\.sandbox\b9a447585ebdff8a60a823e160f77b58\default\ext\MlFront\tests\DkZero_Exec\import-gh-l2.t\target\cache\build.1\attest\github\6f923d6f-6809-4df1-8ec1-e2d224106974\sha256-2d41b75daa78d3d2a8119141f7c7781fd8a9611177daf22986a388e7b847a84c.jsonl
      Use https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation workaround. *)
  let pwd_abs_dn, pwd_abs_fn =
    match
      ( MlFront_Core.FilePath.absolute
        (* \\.\ works with Command Prompt (used by OCaml's Unix.system command) *)
          ~style:`WindowsDeviceNamespace ~base:absbasepath
          MlFront_Core.FilePath.empty,
        MlFront_Core.FilePath.absolute
        (* \\?\ works with OCaml's Sys.file_exists *)
          ~style:`WindowsFileNamespace ~base:absbasepath
          MlFront_Core.FilePath.empty )
    with
    | None, _ | _, None ->
        ShellCore.quick_error
          (Printf.sprintf "Could not make an absolute path from `%s`"
             (MlFront_Core.FilePath.to_string absbasepath))
    | Some pwd_abs_dn, Some pwd_abs_fn -> (pwd_abs_dn, pwd_abs_fn)
  in

  (* Not nice that the filename changes based on Windows or Unix!
     $ gh --version
     gh version 2.72.0 (2025-04-30)
     https://github.com/cli/cli/releases/tag/v2.72.0

     $ gh attestation download --help
     
     > Colons are special characters on Windows and cannot be used in
       file names. To accommodate, a dash will be used to separate the algorithm
       from the digest in the attestations file name. For example, if the digest
       is "sha256:1234", the file will be named "sha256-1234.jsonl". *)
  let expected_filename =
    if Sys.win32 then
      Printf.sprintf "sha256-%s.jsonl" unattested_values_json_sha256
    else Printf.sprintf "sha256:%s.jsonl" unattested_values_json_sha256
  in
  (* We want a consistent filename, and it must be shorter to mitigate
     MAX_PATH on Windows which leaks everywhere ... Dune can't remove
     the cache directory if it has files that exceed MAX_PATH. *)
  let final_filename = "gh.jsonl" in

  let dbresult =
    MlFront_Cache.MetaDb.with_sync ~supercategory:"attest"
      (Wiring.BuildContext.metadb ctx)
      (fun
        ~data_ops:(module DataOps : MlFront_Cache.MetaOps.S)
        ~cache_ops:(module CacheOps : MlFront_Cache.MetaOps.S)
      ->
        CacheOps.cache_dir ~category:"github" ~key:cache_key
          ~cache_hit:(fun ~dir_for_upsert:_ _cdir -> Ok `Keep)
          ~cache_miss:(fun ~dir_for_upsert ->
            MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
              ~return:(function
                | `Created -> () | `Error e -> ShellCore.quick_error e)
              dir_for_upsert;

            (* We'll need absolute paths since the attestation is very limited. See [A1]. *)
            let gh_abs_dn_exe =
              MlFront_Core.FilePath.concat pwd_abs_dn gh_exe
            in
            let unattested_values_json_abs_dn =
              MlFront_Core.FilePath.concat pwd_abs_dn
                unattested_values_json_maybe_rel
            in
            let dir_for_upsert_abs_fn =
              MlFront_Core.FilePath.concat pwd_abs_fn dir_for_upsert
            in
            let abs_fn_s filename =
              let fp' =
                MlFront_Core.FilePath.append_exn dir_for_upsert_abs_fn filename
              in
              MlFront_Core.FilePath.to_string fp'
            in
            let expected_filename_abs_fn_s = abs_fn_s expected_filename in
            let final_filename_abs_fn_s = abs_fn_s final_filename in

            let hostname_args = get_hostname_args full_repo in
            let cmdline_args ~unattested_valuesjson_fp =
              [
                "attestation";
                "download";
                MlFront_Core.FilePath.to_string unattested_valuesjson_fp;
                "-R";
                ShellCore.GitHubRepo.owner_and_repo full_repo;
              ]
              @ hostname_args
            in
            let cmdline =
              Cmdline.create ~executable_maybe_rel:gh_exe
                ~args_maybe_rel:
                  (cmdline_args
                     ~unattested_valuesjson_fp:unattested_values_json_maybe_rel)
                ~executable:gh_abs_dn_exe
                (cmdline_args
                   ~unattested_valuesjson_fp:unattested_values_json_abs_dn)
            in

            (* A1: I understand making the file a known checksum ("digest"), but
                       annoying that there is no way to specify the directory. *)
            Unix.chdir (MlFront_Core.FilePath.to_string dir_for_upsert);
            Fun.protect
              (fun () ->
                run_github_cli ctx ~command:"gh attestation download"
                  (fun () ->
                    if Sys.file_exists expected_filename_abs_fn_s then begin
                      Unix.rename expected_filename_abs_fn_s
                        final_filename_abs_fn_s;
                      Ok `Upsert
                    end
                    else
                      let defer ppf () =
                        Format.fprintf ppf
                          "The attestation bundle file `%s` in `%s` was not \
                           created by the GitHub CLI. This may be because the \
                           attestation bundle in GitHub CLI is in 'public \
                           preview'. Please upgrade to the latest dk0 version."
                          expected_filename
                          (MlFront_Core.FilePath.to_string dir_for_upsert)
                      in
                      Error (`WrappableMsg defer))
                  cmdline)
              ~finally:(fun () ->
                Unix.chdir (MlFront_Core.FilePath.to_string absbasepath)))
          ())
  in
  match dbresult with
  | Ok (Ok dir) ->
      let maybe_rel = MlFront_Core.FilePath.append_exn dir final_filename in
      ( `Relative maybe_rel,
        `Absolute (MlFront_Core.FilePath.concat pwd_abs_fn maybe_rel) )
  | Ok (Error (`WrappableMsg defer)) | Error (`WrappableMsg defer) ->
      let msg = Format.asprintf "%a" defer () in
      ShellCore.quick_error msg

and github_offline_verify ctx ~trusted_root_file ~unattested_valuesjson_fp
    ~attestation_bundle_rel ~attestation_bundle_abs ~github_cli_directory
    ~full_repo () =
  let gh_exe = MlFront_Core.FilePath.append_exn github_cli_directory "gh.exe" in
  let hostname_args = get_hostname_args full_repo in
  let run_result =
    let cmdline_args ~attestation_bundle =
      [
        "attestation";
        "verify";
        MlFront_Core.FilePath.to_string unattested_valuesjson_fp;
        "-R";
        ShellCore.GitHubRepo.owner_and_repo full_repo;
        "--bundle";
        MlFront_Core.FilePath.to_string attestation_bundle;
        "--custom-trusted-root";
        MlFront_Core.FilePath.to_string trusted_root_file;
      ]
      @ hostname_args
    in
    let cmdline =
      Cmdline.create
        ~args_maybe_rel:
          (cmdline_args ~attestation_bundle:attestation_bundle_rel)
        ~executable:gh_exe
        (cmdline_args ~attestation_bundle:attestation_bundle_abs)
    in
    run_github_cli ctx ~command:"gh attestation verify"
      (fun () -> Ok `Upsert)
      cmdline
  in
  match run_result with
  | Ok `Upsert -> ()
  | Error (`WrappableMsg defer) ->
      let msg = Format.asprintf "%a" defer () in
      ShellCore.quick_error msg

and run_github_cli ctx ~command on_success cmdline =
  (* Don't interfere with https://cli.github.com/manual/gh_help_environment
     since we want GH authentication available:
      GH_CONFIG_DIR: the directory where gh will store configuration files. If not specified, the default value will be one of the following paths (in order of precedence):

      $XDG_CONFIG_HOME/gh (if $XDG_CONFIG_HOME is set),
      $AppData/GitHub CLI (on Windows if $AppData is set), or
      $HOME/.config/gh. 
      
     But otherwise, keep GH side-effects isolated. *)
  let ensure_dir fp =
    MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
      ~return:(function `Created -> () | `Error e -> ShellCore.quick_error e)
      fp
  in
  let install_state = Wiring.BuildContext.install_state ctx in
  let install_cache = Wiring.BuildContext.install_cache ctx in
  let xdg_state_home = MlFront_Core.FilePath.append_exn install_state "xdg" in
  let xdg_cache_home = MlFront_Core.FilePath.append_exn install_cache "xdg" in
  List.iter ensure_dir [ xdg_state_home; xdg_cache_home ];
  let scoped_envs =
    [
      ("XDG_STATE_HOME", MlFront_Core.FilePath.to_string xdg_state_home);
      ("XDG_CACHE_HOME", MlFront_Core.FilePath.to_string xdg_cache_home);
    ]
  in
  let original_envs =
    List.map (fun (name, _value) -> (name, Sys.getenv_opt name)) scoped_envs
  in
  List.iter (fun (name, value) -> Unix.putenv name value) scoped_envs;
  if Wiring.BuildContext.verbose ctx then
    prerr_endline
      (Format.asprintf "[github-attestation] running command: %s"
         cmdline.portable_cmdline);
  Fun.protect
    ~finally:(fun () ->
      List.iter
        (fun (name, value_opt) ->
          Unix.putenv name (Option.value value_opt ~default:""))
        original_envs)
    (fun () ->
      match Unix.system cmdline.native_cmdline with
      | Unix.WEXITED 0 -> on_success ()
      | Unix.WEXITED exit_code ->
          let defer ppf () =
            Format.fprintf ppf
              "The GitHub CLI command `%s` exited with exit code %d." command
              exit_code
          in
          Error (`WrappableMsg defer)
      | Unix.WSIGNALED sc ->
          let defer ppf () =
            Format.fprintf ppf
              "The GitHub CLI command `%s` was killed by signal %d." command sc
          in
          Error (`WrappableMsg defer)
      | Unix.WSTOPPED sc ->
          let defer ppf () =
            Format.fprintf ppf
              "The GitHub CLI command `%s` was stopped by signal %d." command sc
          in
          Error (`WrappableMsg defer))

and get_hostname_args repo =
  match ShellCore.GitHubRepo.hostname repo with
  | None -> []
  | Some host -> [ "--hostname"; host ]

and get_attestation_replacement ~pending_attestation_location attestation_jsons
    =
  let col_left_curly =
    (* Zero-based column of the `{` in `{}` *)
    Fmlib_parse.Position.column (fst pending_attestation_location)
  in
  (* for pretty-printing we want:
     "github_slsa_v1_l2": {
       "docs": [
         ...jsonl line 1...,
         ...jsonl line 2...,
       ] } *)
  let col_github_slsa_v1_l2_indent1, indent =
    let col = col_left_curly - String.length {|"github_slsa_v1_l2": |} in
    (* use left column of `github_slsa_v1_l2` to estimate the indent level.
       default to 2. *)
    if col < 0 then (col_left_curly, 2)
    else if col <= 6 then (col + 1, 1)
    else if col <= 12 then (col + 2, 2)
    else (col + 4, 4)
  in
  let pad_github_slsa_v1_l2_indent2 =
    String.make (col_github_slsa_v1_l2_indent1 + indent) ' '
  in
  let buf = Buffer.create 4096 in
  Buffer.add_string buf "{\n";
  Buffer.add_string buf (String.make col_github_slsa_v1_l2_indent1 ' ');
  Buffer.add_string buf "\"docs\": [\n";
  let l = List.length attestation_jsons in
  List.iteri
    (fun lineno json ->
      Buffer.add_string buf pad_github_slsa_v1_l2_indent2;
      MlFront_Thunk.YojsonSafe.to_buffer buf json;
      if lineno < l - 1 then Buffer.add_char buf ',';
      Buffer.add_char buf '\n')
    attestation_jsons;
  Buffer.add_string buf (String.make col_github_slsa_v1_l2_indent1 ' ');
  Buffer.add_string buf "] }";
  Buffer.contents buf