Source file ShellVSL.ml

type parsed_command = {
  module_id :
    Fmlib_parse.Position.range * MlFront_Thunk.ThunkCommand.module_version;
  request_slot : MlFront_Thunk.ThunkObjectSlot.t option;
  runner :
    context:Wiring.ValueContext.t ->
    tasks:(module Wiring.BuildContext.THUNK_TASKS) ->
    Wiring.BuildContext.K.t Wiring.BuildContext.cont;
}

let tdir = MlFront_Core.FilePath.of_string_exn "t"

let zig_progress_initial_delay_ns =
  (* 32-bit OCaml safe way of representing 0.2 seconds.
     We keep startup responsive so short-lived early phases are visible. *)
  Int64.(mul (of_int 200_000) (of_int 1000))

let mk_parsed_user_command command : parsed_command =
  let request_slot = MlFront_Thunk.ThunkCommand.object_slot command in
  let quick_resolve (_range, rterm) =
    match MlFront_Thunk.ThunkCommand.literal_resolved_term_as_string rterm with
    | Ok str -> str
    | Error msg -> ShellCore.quick_error (Printf.sprintf "%s" msg)
  in
  match command with
  | RGetObject { slot = _, slot; id; command_output; archive_member } ->
      let archive_member = Option.map quick_resolve archive_member in
      {
        module_id = id;
        request_slot;
        runner = Wiring.XGetObject.run ~slot ~command_output ~archive_member;
      }
  | RInstallObject { slot = _, slot; id; command_output; archive_member } ->
      let archive_member = Option.map quick_resolve archive_member in
      {
        module_id = id;
        request_slot;
        runner = Wiring.XInstallObject.run ~slot ~command_output ~archive_member;
      }
  | RPostObject { id; command_output; archive_member; request } ->
      let archive_member = Option.map quick_resolve archive_member in
      {
        module_id = id;
        request_slot;
        runner =
          Wiring.XPostObject.run ~command_output ~archive_member
            ~request_parameters:request;
      }
  | REnterObject { slot = _, slot; id } ->
      { module_id = id; request_slot; runner = Wiring.XEnterObject.run ~slot }
  | RGetBundle { id; command_output } ->
      {
        module_id = id;
        request_slot;
        runner = Wiring.XGetBundle.run ~command_output;
      }
  | RGetAsset { id; filepath; command_output; archive_member } ->
      let archive_member = Option.map quick_resolve archive_member in
      let filepath = quick_resolve filepath in
      {
        module_id = id;
        request_slot;
        runner = Wiring.XGetAsset.run ~filepath ~command_output ~archive_member;
      }

let run_command ctx ~build_request ~vsl_source ~vsl_source_sha256 ~tasks
    parsed_command : Wiring.BuildContext.K.t Wiring.BuildContext.cont =
  let ({ module_id; runner; request_slot = _ } : parsed_command) =
    parsed_command
  in
  let value_context =
    Wiring.ValueContext.create ~id:module_id ~source:vsl_source
      ~source_sha256:vsl_source_sha256 ctx ~build_request
  in
  runner ~context:value_context ~tasks

(** [parse_argv module_or command_line] parses the value shell command line
    [command_line].

    Any slots in the command line will have access to the ["execution_abi"]
    wildcard. *)
let parse_argv module_or command_line =
  let execution_context = DkZero_Base.Execution.context () in
  match
    MlFront_Thunk.ThunkCommand.parse_argv ~extra_usage:ShellCore.extra_usage
      ~origin:"<dk0>" module_or execution_context
      (Array.of_list command_line)
  with
  | Error sm ->
      ShellCore.quick_error
        (MlFront_Thunk.ThunkResults.Semantic.error_message sm)
  | Ok ((GetObject _ as v), `CanonicalId _) -> (v, "get object")
  | Ok ((InstallObject _ as v), `CanonicalId _) -> (v, "install object")
  | Ok ((PostObject _ as v), `CanonicalId _) -> (v, "post object")
  | Ok ((EnterObject _ as v), `CanonicalId _) -> (v, "enter object")
  | Ok ((GetBundle _ as v), `CanonicalId _) -> (v, "get bundle")
  | Ok ((GetAsset _ as v), `CanonicalId _) -> (v, "get asset")

let start_phase1 ~baseconfig ~random_seed ~cells ~install () :
    Wiring.ShellCore.phase1 =
  let preconfig =
    Wiring.Cfg.preconfigure ~baseconfig ~cells ~install ~random_seed ()
  in
  (* Create trace store directory *)
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(Wiring.Cfg.fatal_return ~error_code:"d41d8cd9")
    (DkZero_Base.Config.baseconfig_tracestore baseconfig);
  (* Create [.tracestore] so autofix can avoid this directory *)
  let dot_tracestore =
    MlFront_Core.FilePath.append_exn
      (DkZero_Base.Config.baseconfig_tracestore baseconfig)
      ".tracestore"
  in
  Out_channel.with_open_bin (MlFront_Core.FilePath.to_string dot_tracestore)
    (fun _oc -> ());
  ({ preconfig } : Wiring.ShellCore.phase1)

(** Starts phase 2 and returns a build configuration. *)
let start_phase2 ?progress_root_name ?progress_root_estimated_total_items
    ~preconfig ~autofix ~verbosity ~progress ~nobuiltininc ~nosysinc
    ~noworkspaceinc ~sysincludedirs ~userincludedirs ~local_packages
    ~build_number ~long_ids ~import debugmodes observer_result =
  let baseconfig = DkZero_Base.Config.preconfig_baseconfig preconfig in
  let explain = if List.mem `Explain debugmodes then Some () else None in
  let assettrace = if List.mem `AssetTrace debugmodes then Some () else None in
  let debug_connection =
    if List.mem `Connection debugmodes then Some () else None
  in
  let intermediate =
    if List.mem `Intermediate debugmodes then Some () else None
  in
  let importtrace = if List.mem `Import debugmodes then Some () else None in
  let importtrace2 = if List.mem `Import2 debugmodes then Some () else None in
  let nobuiltininc = if nobuiltininc then Some () else None in
  let nosysinc = if nosysinc then Some () else None in
  let noworkspaceinc = if noworkspaceinc then Some () else None in
  let workspaceincludedirs =
    [
      MlFront_Core.FilePath.to_string
        (MlFront_Core.FilePath.concat
           (DkZero_Base.Config.baseconfig_workspacedir baseconfig)
           ShellCore.workspace_import_dir);
      MlFront_Core.FilePath.to_string
        (MlFront_Core.FilePath.concat
           (DkZero_Base.Config.baseconfig_workspacedir baseconfig)
           ShellCore.workspace_values_dir);
    ]
  in

  (* Temporary space for the running process. We allow multiple simultaneous runs
     by using the PID of the running process, and try to be a somewhat nice citizen
     of the users' disk space by re-using space. A non-reference implementation
     should use LRU caching, garbage collection or something similar. *)
  let threaddir =
    let pid = Unix.getpid () in
    let d =
      (* short to mitigate Win32 260 MAX_PATH limits *)
      MlFront_Core.FilePath.appendn_exn tdir [ "p"; string_of_int pid ]
    in
    MlFront_Thunk_IoDisk.ThunkIoDisk.remove_file_or_directory_recursively
      ~return:(Wiring.Cfg.fatal_return ~error_code:"0c12f056")
      d;
    d
  in
  (* Initialize build context *)
  let ctx =
    let rootprogressnode_res =
      match progress with
      | `Silent ->
          MlFront_Progress.Progress.silent_root_node
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | `Plain ->
          MlFront_Progress.Progress.plain_root_node
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | `Auto ->
      match Sys.getenv_opt "MLFRONT_PROGRESS_BACKEND" with
      | Some "silent" ->
          MlFront_Progress.Progress.silent_root_node
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | Some "plain" ->
          MlFront_Progress.Progress.plain_root_node
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | Some "period" ->
          MlFront_ProgressPeriod.root_node
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | Some "zig" ->
          MlFront_ProgressZig.root_node
            ~initial_delay_ns:zig_progress_initial_delay_ns
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | _ ->
      match Sys.getenv_opt "ZIG_PROGRESS" with
      | Some _ ->
          MlFront_ProgressZig.root_node
            ~initial_delay_ns:zig_progress_initial_delay_ns
            ?estimated_total_items:progress_root_estimated_total_items
            ?root_name:progress_root_name ()
      | None ->
          if Sys.getenv_opt "CI" = Some "true" then
            (* CI tests should be repeatable, so no indeterminate periodic progress *)
            MlFront_Progress.Progress.plain_root_node
              ?estimated_total_items:progress_root_estimated_total_items
              ?root_name:progress_root_name ()
          else if Unix.isatty (Unix.descr_of_out_channel stderr) then
            MlFront_ProgressZig.root_node
              ~initial_delay_ns:zig_progress_initial_delay_ns
              ?estimated_total_items:progress_root_estimated_total_items
              ?root_name:progress_root_name ()
          else
            (* Periodic progress is the fallback *)
            MlFront_ProgressPeriod.root_node
              ?estimated_total_items:progress_root_estimated_total_items
              ?root_name:progress_root_name ()
    in
    let rootprogressnode =
      match rootprogressnode_res with
      | Ok node -> node
      | Error msg ->
          ShellCore.quick_error ("Failed to initialize progress backend: " ^ msg)
    in
    let download =
      Download.download ?debug_connection ?intermediate ?assettrace ~verbosity
        ~autofix
        ~absbasepath:(DkZero_Base.Config.baseconfig_absbasepath baseconfig)
        ~cells:(DkZero_Base.Config.preconfig_cells preconfig)
        ~celldirf:(DkZero_Base.Config.preconfig_celldirf preconfig)
        ~selfassetdir:(DkZero_Base.Config.preconfig_selfassetdir preconfig)
    in
    Wiring.Cfg.create ?explain ?intermediate ?importtrace ?importtrace2
      ?nobuiltininc ?nosysinc ?noworkspaceinc ~verbosity ~preconfig
      ~sysincludedirs ~workspaceincludedirs ~userincludedirs ~local_packages
      ~build_number ~long_ids ~threaddir ~download ~observer_result
      ~rootprogressnode ~import ()
  in
  (* Create value store directory *)
  MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
    ~return:(Wiring.Cfg.fatal_return ~error_code:"bcd6b2d4")
    (Wiring.BuildContext.valuestore_maybe_relto_basedir ctx);
  (* Create [.valuestore] so autofix can avoid this directory *)
  let dot_valuestore =
    MlFront_Core.FilePath.append_exn
      (Wiring.BuildContext.valuestore_maybe_relto_basedir ctx)
      ".valuestore"
  in
  Out_channel.with_open_bin (MlFront_Core.FilePath.to_string dot_valuestore)
    (fun _oc -> ());
  ctx

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

let start_phase4 ~(shell : Wiring.ShellCore.phase3) ~baseconfig () =
  (* Post-load integrity checks *)
  let state1 = Wiring.BuildEngine.remove_invalid_values shell.ctx shell.state in

  (* Make tasks from values files and script modules *)
  let state2 =
    let system_kont =
      Wiring.BuildTaskUnresolved.make_tasks_from_prefetch_keys shell.ctx
        ~tasks:shell.tasks ~build_request:shell.initiator shell.prefetch_keys
    in
    Wiring.BuildTaskUnresolved.run_unit_continuation system_kont state1
  in
  if DkZero_Base.Config.baseconfig_debug_task baseconfig then
    Printf.eprintf "[task] %d system task%s complete\n"
      (List.length shell.prefetch_keys)
      (if List.length shell.prefetch_keys = 1 then "" else "s");
  state2

let finish_phase1 ctx state_after_run tracefd =
  let newgen, all_traces =
    Wiring.BuildContext.State.new_generation state_after_run
  in
  Wiring.BuildTraceStore.save ctx all_traces tracefd;
  newgen

let with_progress_step parent_progress label f =
  let step_progress = MlFront_Progress.Progress.start parent_progress label in
  let succeeded = ref false in
  Fun.protect
    ~finally:(fun () ->
      MlFront_Progress.Progress.end_ step_progress;
      if !succeeded then MlFront_Progress.Progress.complete_one parent_progress)
    (fun () ->
      let result = f step_progress in
      succeeded := true;
      result)

let progress_root_name vsl_command_line =
  match vsl_command_line with
  | _dk0 :: rest ->
      DkZero_Base.BuildProgress.abbreviate_label (String.concat " " rest)
  | [] ->
      "shell command"

let process_value_shell_command ~baseconfig ~autofix ~verbosity ~progress
    ~install ~random_seed ~wait_trace_store ~nobuiltininc ~nosysinc
    ~noworkspaceinc ~sysincludedirs ~userincludedirs ~cells ~local_packages
    ~build_number ~long_ids ~invalidations ~dump_ancestors_graph
    ~dump_dependency_graph ~import debugmodes module_or vsl_command_line =
  (* source *)
  let vsl_source, (vsl_source_sha256, _vsl_source_sz) =
    let contents =
      List.map
        MlFront_Thunk.ThunkLexers.ValueShellLexer.Token.quote_literal_if_needed
        vsl_command_line
      |> 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

  let latest_cant_do = ref "run dk0" in
  try
    (* Start phase 1 *)
    let ({ preconfig } : Wiring.ShellCore.phase1) =
      start_phase1 ~baseconfig ~random_seed ~cells ~install ()
    in

    (* Start transaction with trace file *)
    let rootprogressnode, newgen =
      Txn.with_txn ~mode:`Create ~wait:wait_trace_store 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 =
            start_phase2 ~progress_root_name:(progress_root_name vsl_command_line)
              ~progress_root_estimated_total_items:1 ~preconfig ~autofix
              ~verbosity ~nobuiltininc ~nosysinc ~noworkspaceinc
              ~sysincludedirs ~userincludedirs ~local_packages ~build_number
              ~long_ids ~progress ~import debugmodes module_or
          in
          let command_progress =
            MlFront_Progress.Progress.start ~estimated_total:4 ~no_rollup:true
              (Wiring.BuildContext.rootprogressnode ctx)
              "run command"
          in
          Fun.protect
            ~finally:(fun () -> MlFront_Progress.Progress.end_ command_progress)
            (fun () ->
              let ctx_for_command =
                Wiring.BuildContext.with_rootprogressnode ctx command_progress
              in

              (* Parse the command. We will need the request slot. *)
              let command, cant_do = parse_argv module_or vsl_command_line in
              latest_cant_do := cant_do;

              (* Resolve the command as a literal (no variables or subshells). *)
              let resolved_command =
                match MlFront_Thunk.ThunkCommand.literal_as_resolved command with
                | Ok v -> v
                | Error (range, msg) ->
                    let text =
                      MlFront_Thunk.ThunkResults.single_error ~code:"7da99547"
                        ~msg
                        ~brief_instruction:
                          "Remove variables and subshells from the command, or \
                           place the command into a values.json file inside \
                           `forms` and run that instead."
                        module_or MlFront_Thunk.ThunkResults.State.none
                        (MlFront_Thunk.ThunkRanges.raw_range range)
                    in
                    ShellCore.quick_error text
              in
              let resolved_command_line =
                MlFront_Thunk.ThunkCommand.resolved_to_valueshell resolved_command
              in
              MlFront_Progress.Progress.set_name command_progress
                (DkZero_Base.BuildProgress.abbreviate_label resolved_command_line);
              let parsed_command = mk_parsed_user_command resolved_command in

              (* Start phase 3 *)
              let shell =
                with_progress_step command_progress "initialize build engine"
                  (fun _ -> start_phase3 ctx_for_command ~traces parsed_command)
              in

              (* Start phase 4 *)
              let shell =
                with_progress_step command_progress "initialize shell state"
                  (fun _ ->
                    let state2 = start_phase4 ~shell ~baseconfig () in
                    { shell with state = state2 })
              in

              (* Recognize the command line as a valid values file so errors can be reported. *)
              Wiring.BuildContext.State.assign_values_file_location
                ~values_file_sha256:vsl_source_sha256
                ~local_file:(`Validated vsl_source) shell.state;

              (* Run user task *)
              let target_key, state_after_run =
                let user_kont =
                  run_command shell.ctx ~build_request:shell.initiator
                    ~vsl_source ~vsl_source_sha256 ~tasks:shell.tasks
                    parsed_command
                in
                Wiring.BuildTaskUnresolved.run_continuation user_kont shell.state
              in
              MlFront_Progress.Progress.complete_one command_progress;

              (* A convenient point to flush all output *)
              flush_all ();

              (* Dump graphs if requested *)
              (match dump_ancestors_graph with
              | None -> ()
              | Some where ->
                  ShellCore.with_ppf
                    (fun ppf ->
                      Wiring.BuildContext.State.pp_graph_of_key `Ancestors ppf
                        state_after_run target_key)
                    where);
              (match dump_dependency_graph with
              | None -> ()
              | Some where ->
                  ShellCore.with_ppf
                    (fun ppf ->
                      Wiring.BuildContext.State.pp_graph_of_key `Dependencies ppf
                        state_after_run target_key)
                    where);

              (* Finish phase 1 *)
              let newgen =
                with_progress_step command_progress "save tracestore" (fun _ ->
                    finish_phase1 shell.ctx state_after_run tracefd)
              in
              (Wiring.BuildContext.rootprogressnode ctx, newgen)))
    in
    MlFront_Progress.Progress.end_ rootprogressnode;
    newgen
  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:vsl_source ~autofix module_or