Source file ShellDistribute.ml

let mirror = ref None
let library_and_version = ref None
let forms = ref []
let request_slot = ref None
let anon_fun s = forms := s :: !forms

let parse_into_reference reference f s =
  match
    f
      (module ShellCore.MakeInitObserver
      : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
      MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None s
  with
  | Ok v -> reference := Some v
  | Error s ->
      raise
        (Arg.Bad
           (Format.asprintf "%a" MlFront_Thunk.ThunkParsers.Results.Semantic.pp
              s))

let speclist ~usage_msg =
  [
    ("--mirror", Arg.String (fun s -> mirror := Some s), "");
    ( "--library",
      Arg.String
        (parse_into_reference library_and_version
           MlFront_Thunk.ThunkCommand.InternalUse.parse_library_version),
      "" );
    ( "-s",
      Arg.String
        (parse_into_reference request_slot
           MlFront_Thunk.ThunkCommand.InternalUse.parse_object_slot),
      "" );
    ( "-help",
      Arg.Unit
        (fun () ->
          print_endline usage_msg;
          exit 0),
      "" );
    ( "--help",
      Arg.Unit
        (fun () ->
          print_endline usage_msg;
          exit 0),
      "" );
  ]

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_distribute_command ~usage_msg ~data_dir ~cache_dir ~valuestore
    ~tracestore ~verbose ~install ~keys_env ~keys_dir ~random_seed
    ~wait_trace_store ~nobuiltininc ~nosysinc ~sysincludedirs ~includedirs
    ~local_packages ~build_number ~integrity
    ~inferred_package_id_or_reason_whynone ~transform_values
    ~dump_ancestors_graph ~dump_dependency_graph debugmodes module_or args =
  (* Parse *)
  let current = ref 1 in
  let cmdline = "mlfront-shell" :: "distribute" :: 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);

  (* Validate *)
  let library_and_version =
    match !library_and_version with
    | Some v -> v
    | None -> begin
        prerr_endline "FATAL: Missing `--library LIBRARY@VERSION` option.";
        prerr_endline usage_msg;
        exit 1
      end
  in
  let majmin =
    match snd library_and_version with
    | { major; minor; patch; prerelease; build } ->
        if prerelease <> [] || build <> [] then begin
          Printf.eprintf
            "FATAL: The VERSION in `--library LIBRARY@VERSION` must not have \
             prerelease or build components (ex. %Ld.%Ld.202512310000 is ok).\n\
             %!"
            major minor;
          exit 1
        end;
        if Int64.equal patch 0L then begin
          Printf.eprintf
            "FATAL: The VERSION in `--library LIBRARY@VERSION` must have a \
             non-zero patch component (ex. %Ld.%Ld.202512310000 is ok).\n\
             %!"
            major minor;
          exit 1
        end;
        (major, minor)
  in
  if !forms = [] then begin
    prerr_endline "FATAL: Missing one or more form parameters.";
    prerr_endline usage_msg;
    exit 1
  end;
  let to_module_version (s : string) : MlFront_Thunk.ThunkCommand.module_version
      =
    match
      MlFront_Thunk.ThunkCommand.InternalUse.parse_module_version
        ~package_id_opt:None
        (module ShellCore.MakeInitObserver)
        MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None s
    with
    | Ok mv -> mv
    | Error msg ->
        Format.eprintf "FATAL: %a\n%!"
          MlFront_Thunk.ThunkParsers.Results.Semantic.pp msg;
        exit 1
  in
  let forms = List.map to_module_version !forms in
  let request_slot =
    match !request_slot with
    | Some rs -> rs
    | None ->
        prerr_endline "FATAL: Missing `-s SLOT` option with the request slot.";
        prerr_endline usage_msg;
        exit 1
  in

  (* add library to allowed packages *)
  let local_packages =
    let library_id, _version = library_and_version in
    match SecPackageRegistry.package_id_for_library library_id with
    | None -> local_packages
    | Some pkg -> pkg :: local_packages
  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

  (* scan distribution files *)
  let dist_core, dist_file =
    let pkg_opt, registry = SecDist.scan_dist_dir module_or in
    match pkg_opt with
    | None ->
        prerr_endline
          "FATAL: There are no distribution files. Use `prepare-version` first.";
        exit 1
    | Some pkg -> begin
        match SecPackageRegistry.characterize ~majmin pkg registry with
        | `Exists (dist_core, dist_file) -> (dist_core, dist_file)
        | `Continued _ ->
            Printf.eprintf
              "FATAL: You are distributing a version %Ld.%Ld that is a \
               continuation of older, released versions. However, you must use \
               `prepare-version` first.\n\
               %!"
              (fst majmin) (snd majmin);
            exit 1
        | `Error msg ->
            Printf.eprintf "FATAL: %s\n%!" msg;
            exit 1
        | `NoMatchingContinuation ->
            Printf.eprintf
              "FATAL: There are existing distribution files, but no releases \
               match %Ld.%Ld. Change the `distribute --library \
               LIBRARY@VERSION` to have a VERSION=MAJOR.MINOR.* that is \
               released.\n\
               %!"
              (fst majmin) (snd majmin);
            exit 1
        | `Superseded latest ->
            let ({ major; minor; _ } : MlFront_Thunk.ThunkSemver64Rep.t) =
              latest
            in
            Printf.eprintf
              "FATAL: The version %Ld.%Ld you are distributing is older than \
               the latest released version %s. Change the `distribute \
               --library LIBRARY@VERSION` to have a VERSION=%Ld.%Ld.* that \
               matches the latest released version, or use `prepare-version \
               ...` for a new version.\n\
               %!"
              (fst majmin) (snd majmin)
              (MlFront_Thunk.ThunkSemver64.to_string latest)
              major minor;
            exit 1
      end
  in

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

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

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

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

    (* Start phase 3 (our own) *)
    let shell =
      start_phase3 ~config ~traces ~request_slot:(Some request_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 ~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:shell.config state_after_run tracefd;

    (* Make bundle files *)
    let destdir = MlFront_Core.FilePath.of_string_exn "dk-dist" in
    let compat_tag = BuildCore.compatibility_tag () in
    let valuestore_zip = create_valuestore_zip ~config ~destdir request_slot in
    let tracestore =
      create_tracestore ~config:shell.config ~destdir ~compat_tag request_slot
    in

    (* Create values.json *)
    define_values ~library_version:library_and_version ~dist_core ~dist_file
      ~target_keys ~compat_tag ~valuestore_zip ~tracestore ~destdir
      ~request_slot ()
  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 create_valuestore_zip ~config ~destdir request_slot =
  let destzip =
    MlFront_Core.FilePath.append_exn
      (Printf.sprintf "%s.valuestore.zip"
         (MlFront_Thunk.ThunkCommand.object_slot_to_shell request_slot))
      destdir
  in
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(function
      | `Created -> ()
      | `Error msg ->
          prerr_endline ("FATAL: " ^ msg);
          exit 1)
    destdir;
  let srcdir = BuildConfig.valuestore config in
  let allowed_value_prefixes =
    (* Skip constant values since the end-users won't import them. *)
    Assumptions.imports_from_distributions_skip_constant_values ();
    BuildPaths.
      [
        prefix_object;
        prefix_bundle;
        prefix_asset;
        prefix_values;
        prefix_valuesjsonfile;
      ]
    |> List.map (fun s -> "./" ^ s)
  in
  MlFront_ZipFile.ZipFile.zip_exn ~deterministic:()
    ~filter:(function
      | "./.valuestore" -> false
      | s ->
          (* Printf.eprintf "Add to valuestore.zip? %s\n%!" s; *)
          List.exists
            (fun p -> String.starts_with ~prefix:p s)
            allowed_value_prefixes)
    ~destzip:(MlFront_Core.FilePath.to_string destzip)
    ~srcdir:(MlFront_Core.FilePath.to_string srcdir)
    ();
  destzip

and create_tracestore ~config ~destdir ~compat_tag request_slot =
  let desttracestore =
    MlFront_Core.FilePath.append_exn
      (Printf.sprintf "%s.%s.tracestore"
         (MlFront_Thunk.ThunkCommand.object_slot_to_shell request_slot)
         compat_tag)
      destdir
  in
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(function
      | `Created -> ()
      | `Error msg ->
          prerr_endline ("FATAL: " ^ msg);
          exit 1)
    destdir;
  let srcdir = BuildConfig.tracestore config in
  let srcfile =
    MlFront_Core.FilePath.append_exn (BuildConfig.tracefile config) srcdir
  in
  match
    BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
    @@ BuildCore.Io.copy
         ~src:(BuildCore.Io.disk_file srcfile)
         ~dest:(BuildCore.Io.disk_file desttracestore)
         ()
  with
  | `Copied -> desttracestore
  | `DestinationIsDirectory d ->
      Printf.eprintf "FATAL: Destination %s is a directory.\n%!"
        (BuildCore.Io.directory_origin d);
      exit 1
  | `Error msg ->
      Printf.eprintf "FATAL: %s\n%!" msg;
      exit 1
  | `SourceIsDirectory s ->
      Printf.eprintf "FATAL: Source %s is a directory.\n%!"
        (BuildCore.Io.directory_origin s);
      exit 1

and define_values ~library_version ~dist_core ~dist_file:_ ~target_keys
    ~compat_tag ~valuestore_zip ~tracestore ~destdir ~request_slot () =
  let rangeplus =
    MlFront_Thunk.ThunkLexers.Ranges.Raw_range
      Fmlib_parse.Position.(start, start)
  in
  let library_id, dist_version = library_version in

  (* Define first build trace *)
  let tracestore_path = MlFront_Core.FilePath.basename tracestore in
  let first_build_trace : MlFront_Thunk.ThunkDist.build_trace =
    {
      trace_tag = (rangeplus, compat_tag);
      trace_path = (rangeplus, tracestore_path);
    }
  in

  (* Start the distribution field *)
  let partial_dist =
    MlFront_Thunk.ThunkDist.promote_core dist_core library_id dist_version
      first_build_trace
  in

  (* Define the distribution bundle *)
  let valuestore_path = MlFront_Core.FilePath.basename valuestore_zip in
  let bundle : MlFront_Thunk.ThunkBundle.t =
    let _bundleid_range, bundle_module_id, bundle_semver =
      partial_dist.build.build_to_sign.build_bundle_id
    in
    let local_origin = "local" in
    let local_dir =
      MlFront_Core.FilePath.(parent valuestore_zip |> to_string)
    in
    let return = function
      | `Checksum s -> s
      | `Error msg -> ShellCore.quick_error msg
    in
    let valuestore_sha256, valuestore_sz =
      MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file ~algo:`Sha256 ~return
        (MlFront_Core.FilePath.to_string valuestore_zip)
    in
    let tracestore_sha256, tracestore_sz =
      MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file ~algo:`Sha256 ~return
        (MlFront_Core.FilePath.to_string tracestore)
    in
    {
      bundle_id =
        ( None,
          Printf.sprintf "%s@%s"
            (MlFront_Core.StandardModuleId.show_dot bundle_module_id)
            (MlFront_Thunk.ThunkSemver64.to_string bundle_semver) );
      listing =
        {
          origins =
            [ { origin_name = local_origin; origin_mirrors = (local_dir, []) } ];
        };
      files =
        [
          ( rangeplus,
            {
              file_sz = (rangeplus, valuestore_sz);
              file_origin = Some local_origin;
              file_checksum =
                {
                  checksum_sha256 = Some (rangeplus, valuestore_sha256);
                  checksum_sha1 = None;
                };
              file_path = valuestore_path;
            } );
          ( rangeplus,
            {
              file_sz = (rangeplus, tracestore_sz);
              file_origin = Some local_origin;
              file_checksum =
                {
                  checksum_sha256 = Some (rangeplus, tracestore_sha256);
                  checksum_sha1 = None;
                };
              file_path = tracestore_path;
            } );
        ];
    }
  in

  (* Define build modules _including_ the distribution bundle *)
  MlFront_Thunk.Assumptions.distribution_bundle_must_be_an_exported_module ();
  let build_modules =
    partial_dist.build.build_to_sign.build_modules
    @ List.filter_map
        (function
          | (({
                key_datum =
                  BuildCore.Alacarte_3_2_apparatus.K.ModuleKey
                    { module_kind = _; module_id; module_semver };
                debug_reference = _;
              } :
               BuildCore.Alacarte_3_2_apparatus.K.t) :
              BuildCore.Alacarte_3_2_apparatus.K.t) ->
              Some
                ( rangeplus,
                  module_id,
                  MlFront_Thunk.ThunkSemver64.with_dropped_bn_build_metadata
                    module_semver )
          | ({
               key_datum =
                 ( BuildCore.Alacarte_3_2_apparatus.K.ChecksumKey _
                 | BuildCore.Alacarte_3_2_apparatus.K.PackageKey _ );
               debug_reference = _;
             } :
              BuildCore.Alacarte_3_2_apparatus.K.t) ->
              None)
        target_keys
  in

  (* Finished the distribution field *)
  let dist : MlFront_Thunk.ThunkDist.t =
    {
      id = partial_dist.id;
      producer = partial_dist.producer;
      license = partial_dist.license;
      continuations = partial_dist.continuations;
      build =
        {
          build_attestation = partial_dist.build.build_attestation;
          build_to_sign =
            {
              build_bundle_id = partial_dist.build.build_to_sign.build_bundle_id;
              build_bundle_canonical =
                (rangeplus, MlFront_Thunk.ThunkBundle.canonical_id bundle);
              build_producer_accepts = [];
              build_modules;
              build_traces = partial_dist.build.build_to_sign.build_traces;
              build_values = [ { value_path = (rangeplus, valuestore_path) } ];
            };
        };
    }
  in

  (* Create the CST *)
  let cst : MlFront_Thunk.ThunkCst.t =
    {
      contents = None;
      schema =
        Some
          "https://github.com/diskuv/dk/raw/refs/heads/V2_4/etc/jsonschema/mlfront-values.json";
      schema_version = { smajor = 1; sminor = 0 };
      forms = [];
      bundles = [ (rangeplus, bundle) ];
      distributions = [ (rangeplus, dist) ];
    }
  in

  (* Show and save the values.json *)
  let contents =
    Format.asprintf "%a@."
      (MlFront_Thunk.ThunkCst.pp_full ~pretty:true ~schema:true)
      cst
  in
  flush stderr;
  print_endline contents;
  let values_file_fp =
    MlFront_Core.FilePath.append_exn
      (Printf.sprintf "%s.values.json"
         (MlFront_Thunk.ThunkCommand.object_slot_to_shell request_slot))
      destdir
  in
  ShellCore.save_file ~contents values_file_fp