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/MlFront_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 ?executable_maybe_rel ?args_maybe_rel ~executable args]
      creates a command line.

      - [?stdout]: if present, redirect standard output to this file path.
      - [?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 =
      Filename.quote_command ?stdout
        (MlFront_Core.FilePath.to_string (os_translate executable))
        args
    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.ThunkCommand.InternalUse.posix_quote_word
      |> String.concat " "
    in
    { native_cmdline; portable_cmdline }
end

(** ["MlFront_Attestation.GitHubCLI@2.81.0"] *)
let forms : MlFront_Thunk.ThunkCommand.module_version list =
  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
  [ { id; version } ]

let repo = ref None
let tag = ref None
let outdir = ref None

let speclist ~usage_msg =
  [
    ("-R", Arg.String (fun s -> repo := Some s), "");
    ("--repo", Arg.String (fun s -> 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 _ = ()

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

let rec process_import_github_l2_command ~usage_msg ~data_dir ~cache_dir
    ~valuestore ~tracestore ~verbose ~install ~keys_env ~keys_dir ~random_seed
    ~build_number ~transform_values ~dump_ancestors_graph ~dump_dependency_graph
    debugmodes module_or args =
  (* Parse *)
  let current = ref 1 in
  let cmdline = "mlfront-shell" :: "import-github-l2" :: args in
  (try
     Arg.parse_argv ~current (Array.of_list cmdline) (speclist ~usage_msg)
       anon_fun usage_msg
   with
  | Arg.Bad msg ->
      prerr_endline msg;
      exit 1
  | Arg.Help msg ->
      prerr_endline msg;
      exit 0);

  (* Parse more *)
  let repo, tag, outdir =
    match (!repo, !tag, !outdir) with
    | Some repo, Some tag, Some outdir -> begin
        let outdir = MlFront_Core.FilePath.of_string_exn outdir in
        let repo =
          match ShellCore.GitHubRepo.parse repo with
          | Error s ->
              prerr_endline ("Invalid GitHub repository. " ^ s);
              exit 1
          | Ok r -> r
        in
        let tag =
          match ShellCore.SemVerGitTag.parse tag with
          | Ok v -> v
          | Error semantic ->
              prerr_endline
                (Format.asprintf "Invalid semver tag: %a"
                   MlFront_Thunk.ThunkParsers.Results.Semantic.pp semantic);
              exit 1
        in
        (repo, tag, outdir)
      end
    | _ ->
        prerr_endline usage_msg;
        exit 1
  in

  (* source *)
  let source_file, (_source_sha256, _vsl_source_sz) =
    let contents =
      List.map MlFront_Thunk.ThunkCommand.InternalUse.posix_quote_word cmdline
      |> String.concat " "
    in
    let file =
      BuildCore.Io.inmemory_file
        ~origin:(MlFront_Core.FilePath.of_string_exn "/dev/argv")
        contents
    in
    match
      BuildInstance.Launcher.run_isolated_promise
        (BuildCore.Io.checksum_file ~algo:`Sha256 file)
    with
    | `Error msg -> ShellCore.quick_error msg
    | `Checksum sha256 -> (file, sha256)
  in

  (* The request slot is "Release." + host ABI *)
  let host_abi_slot =
    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.ThunkCommand.InternalUse.parse_object_slot module_or
            MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None abi
        with
        | Ok slot -> slot
        | Error semantic ->
            ShellCore.quick_error
              (Format.asprintf "%a"
                 MlFront_Thunk.ThunkParsers.Results.Semantic.pp semantic))
  in

  (* Keep track of what we were doing when an exception happens *)
  let latest_cant_do = ref "run mlfront-shell" in
  try
    (* Start phase 1 *)
    let ({ preconfig } : ShellCore.phase1) =
      ShellVSL.start_phase1 ~valuestore ~tracestore ~data_dir ~cache_dir
        ~install ~keys_env ~keys_dir ~random_seed ~integrity:`Checksum
        debugmodes
    in

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

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

    (* Start phase 2 *)
    let config =
      ShellVSL.start_phase2 ~preconfig ~autofix:false ~verbose
        ~nobuiltininc:false ~nosysinc:true ~sysincludedirs:[] ~includedirs:[]
        ~local_packages:[] ~build_number
        ~inferred_package_id_or_reason_whynone:
          (Either.right
             "When using the 'import-github-l2' command, the package id must \
              be present.")
        debugmodes module_or
    in

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

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

    (* Run modules *)
    let target_keys, state_after_run =
      ShellCore.run_modules ~request_slot:host_abi_slot ~forms shell module_or
    in

    (* Dump graphs if requested *)
    ShellCore.dump_graph ~dump_ancestors_graph ~dump_dependency_graph
      state_after_run target_keys;

    (* Finish phase 1 *)
    ShellVSL.finish_phase1 ~config state_after_run tracefd;

    (* Get directory with [gh.exe] GitHub CLI *)
    let github_cli_key, github_cli_directory =
      get_github_cli_key_and_directory ~config ~source_file ~target_keys
        ~state_after_run ()
    in

    (* Run the [gh attestation trusted-root] command if needed *)
    let trusted_root_file, trusted_root_cache_key =
      get_github_trusted_root_file ~config ~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_values_json, unattested_values_json_sha256 =
      download_values_json ~outdir ~repo ~tag ()
    in

    (* Find the `github_slsa_v1_l2: {}` location *)
    let location_result =
      SecDist.Locations.find_empty_github_slsa_v1_l2_location module_or
        unattested_values_json
    in
    let pending_attestation_location, library_id, unattested_contents =
      match location_result with
      | Ok l_c -> l_c
      | Error msg -> ShellCore.quick_error msg
    in
    if BuildConfig.verbose config then
      prerr_endline
        (Format.asprintf "[github-attestation] github_slsa_v1_l2 location: %a"
           (MlFront_Thunk.ThunkParsers.Results.pp_range
              (Some (MlFront_Core.FilePath.to_string unattested_values_json)))
           pending_attestation_location);

    (* Download values.json attestation bundle. *)
    let `Relative attestation_bundle_rel, `Absolute attestation_bundle_abs =
      download_github_attestation_bundle ~config ~unattested_values_json
        ~unattested_values_json_sha256 ~github_cli_directory
        ~trusted_root_cache_key ~repo ()
    in

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

    (* Do offline verification *)
    github_offline_verify ~config ~trusted_root_file ~unattested_values_json
      ~attestation_bundle_rel ~attestation_bundle_abs ~github_cli_directory
      ~repo ();

    (* Do embedding with autofix *)
    let attested_values_json =
      MlFront_Core.FilePath.append_exn
        (Printf.sprintf "%s.values.json"
           (MlFront_Core.LibraryId.full_name library_id))
        outdir
    in
    let startloc = fst pending_attestation_location in
    match
      Autofix.save_with_fix
        ~file_path:(MlFront_Core.FilePath.to_string attested_values_json)
        ~contents:unattested_contents
        ~line:(Fmlib_parse.Position.line startloc + 1)
        ~col:(Fmlib_parse.Position.column startloc + 1)
        autofix
    with
    | Ok () ->
        prerr_endline
          (Format.asprintf "[github-attestation] verified and saved to `%a`"
             MlFront_Core.FilePath.pp attested_values_json)
    | Error m -> ShellCore.quick_error m
  with
  | BuildExceptions.EngineShutdown { trace; exitcode_posix; exitcode_windows }
  ->
    ShellVSL.process_exception ~trace ~exitcode_posix ~exitcode_windows
      ~cant_do:!latest_cant_do ~source_file ~autofix:false module_or

and get_github_cli_key_and_directory ~config ~source_file ~target_keys
    ~state_after_run () =
  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 =
    BuildEngine.unzip_and_cache_value ~config ~source:source_file
      Fmlib_parse.Position.(start, start)
      (BuildEngine.cloak_key github_cli_key)
  in
  let gh_dir_opt, _state =
    BuildEngine.run_continuation kont2 (BuildEngine.cloak_state state_after_run)
  in
  match gh_dir_opt with
  | Some fp -> (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
      mlfront-shell *)
and get_github_trusted_root_file ~config ~github_cli_key ~github_cli_directory
    () =
  let gh_exe = MlFront_Core.FilePath.append_exn "gh.exe" github_cli_directory in
  let cache_key1 =
    BuildCore.Alacarte_3_2_apparatus.K.module_version_exn github_cli_key
    |> MlFront_Thunk.ThunkCommand.show_module_version
  in
  let cache_key2 = BuildConfig.build_number config in
  let cache_key = Printf.sprintf "%s/%s" cache_key1 cache_key2 in
  if BuildConfig.verbose config then
    prerr_endline
      (Format.asprintf "[github-attestation] trusted root cache key: %s"
         cache_key);
  let trusted_root_filename = "trusted_root.jsonl" in
  MlFront_Errors.Errors.Details.protect ~finally:Fun.id (fun () ->
      let dbresult =
        MlFront_Cache.MetaDb.with_ ~supercategory:"attest"
          (BuildConfig.metadb config)
          (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)
                  (MlFront_Core.FilePath.of_string_exn
                     (Fpath.to_string dir_for_upsert));

                let outfile = Fpath.(dir_for_upsert / trusted_root_filename) in
                let cmdline =
                  Cmdline.create ~stdout:(Fpath.to_string outfile)
                    ~executable:gh_exe
                    [ "attestation"; "trusted-root" ]
                in
                run_github_cli ~config ~command:"gh attestation trusted-root"
                  (fun () -> Ok `Upsert)
                  cmdline)
              ())
      in
      match dbresult with
      | Ok (Ok dir) ->
          ( MlFront_Core.FilePath.of_string_exn
              Fpath.(to_string (dir / trusted_root_filename)),
            cache_key )
      | Ok (Error `ErrorCaptured) | Error `ErrorCaptured ->
          ShellCore.quick_error
            (Format.asprintf "%a" MlFront_Errors.Errors.Details.pp ()))

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

  let url =
    Printf.sprintf "https://%s/releases/download/%s"
      (ShellCore.GitHubRepo.to_string repo)
      (ShellCore.SemVerGitTag.to_string tag)
  in
  let download_result =
    let file_path = "values.json" in
    let handle_fail ~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_values_json);
    ShellCore.download_remote ~on_fail:handle_fail ~file_path ~file_sz:None
      ~autofix:false
      ~return:(function
        | ShellCore.Downloaded { origin = _; 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_values_json
  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_values_json)
      in
      (unattested_values_json, 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 ~config
    ~unattested_values_json:unattested_values_json_maybe_rel
    ~unattested_values_json_sha256 ~github_cli_directory ~trusted_root_cache_key
    ~repo () =
  let gh_exe = MlFront_Core.FilePath.append_exn "gh.exe" github_cli_directory in
  let cache_key =
    Printf.sprintf "%s/%s" trusted_root_cache_key unattested_values_json_sha256
  in
  if BuildConfig.verbose config 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\MlFront_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 = Sys.getcwd () in
  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:(MlFront_Core.FilePath.of_string_exn pwd)
          (MlFront_Core.FilePath.of_string_exn ""),
        MlFront_Core.FilePath.absolute
        (* \\?\ works with OCaml's Sys.file_exists *)
          ~style:`WindowsFileNamespace
          ~base:(MlFront_Core.FilePath.of_string_exn pwd)
          (MlFront_Core.FilePath.of_string_exn "") )
    with
    | None, _ | _, None ->
        ShellCore.quick_error
          (Printf.sprintf "Could not make an absolute path from `%s`" pwd)
    | 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
  MlFront_Errors.Errors.Details.protect ~finally:Fun.id (fun () ->
      let dbresult =
        MlFront_Cache.MetaDb.with_ ~supercategory:"attest"
          (BuildConfig.metadb config)
          (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)
                  (MlFront_Core.FilePath.of_string_exn
                     (Fpath.to_string 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
                    (MlFront_Core.FilePath.of_string_exn
                       (Fpath.to_string dir_for_upsert))
                in
                let abs_fn_s filename =
                  let fp' =
                    MlFront_Core.FilePath.append_exn filename
                      dir_for_upsert_abs_fn
                  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 repo in
                let cmdline_args ~unattested_values_json =
                  [
                    "attestation";
                    "download";
                    MlFront_Core.FilePath.to_string unattested_values_json;
                    "-R";
                    ShellCore.GitHubRepo.owner_and_repo repo;
                  ]
                  @ hostname_args
                in
                let cmdline =
                  Cmdline.create ~executable_maybe_rel:gh_exe
                    ~args_maybe_rel:
                      (cmdline_args
                         ~unattested_values_json:
                           unattested_values_json_maybe_rel)
                    ~executable:gh_abs_dn_exe
                    (cmdline_args
                       ~unattested_values_json: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 (Fpath.to_string dir_for_upsert);
                Fun.protect
                  (fun () ->
                    run_github_cli ~config ~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 (
                          MlFront_Errors.Errors.Details.add_error (fun 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 mlfront-shell version."
                                expected_filename
                                (Fpath.to_string dir_for_upsert));
                          Error `ErrorCaptured))
                      cmdline)
                  ~finally:(fun () -> Unix.chdir pwd))
              ())
      in
      match dbresult with
      | Ok (Ok dir) ->
          let maybe_rel =
            MlFront_Core.FilePath.of_string_exn
              Fpath.(to_string (dir / final_filename))
          in
          ( `Relative maybe_rel,
            `Absolute (MlFront_Core.FilePath.concat pwd_abs_fn maybe_rel) )
      | Ok (Error `ErrorCaptured) | Error `ErrorCaptured ->
          ShellCore.quick_error
            (Format.asprintf "%a" MlFront_Errors.Errors.Details.pp ()))

and github_offline_verify ~config ~trusted_root_file ~unattested_values_json
    ~attestation_bundle_rel ~attestation_bundle_abs ~github_cli_directory ~repo
    () =
  let gh_exe = MlFront_Core.FilePath.append_exn "gh.exe" github_cli_directory in
  let hostname_args = get_hostname_args repo in
  let run_result =
    let cmdline_args ~attestation_bundle =
      [
        "attestation";
        "verify";
        MlFront_Core.FilePath.to_string unattested_values_json;
        "-R";
        ShellCore.GitHubRepo.owner_and_repo 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 ~config ~command:"gh attestation verify"
      (fun () -> Ok `Upsert)
      cmdline
  in
  match run_result with
  | Ok `Upsert -> ()
  | Error `ErrorCaptured ->
      ShellCore.quick_error
        (Format.asprintf "%a" MlFront_Errors.Errors.Details.pp ())

and run_github_cli ~config ~command on_success cmdline =
  if BuildConfig.verbose config then
    prerr_endline
      (Format.asprintf "[github-attestation] running command: %s"
         cmdline.portable_cmdline);
  match Unix.system cmdline.native_cmdline with
  | Unix.WEXITED 0 -> on_success ()
  | Unix.WEXITED exit_code ->
      MlFront_Errors.Errors.Details.add_error (fun ppf () ->
          Format.fprintf ppf
            "The GitHub CLI command `%s` exited with exit code %d." command
            exit_code);
      Error `ErrorCaptured
  | Unix.WSIGNALED sc ->
      MlFront_Errors.Errors.Details.add_error (fun ppf () ->
          Format.fprintf ppf
            "The GitHub CLI command `%s` was killed by signal %d." command sc);
      Error `ErrorCaptured
  | Unix.WSTOPPED sc ->
      MlFront_Errors.Errors.Details.add_error (fun ppf () ->
          Format.fprintf ppf
            "The GitHub CLI command `%s` was stopped by signal %d." command sc);
      Error `ErrorCaptured

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