Source file BuildEngine.ml

(** The reference implementation build engine.

    {3 Implementors of build engine}

    You will want to first read
    {{:https://discuss.ocaml.org/t/ocaml-version-of-the-build-systems-a-la-carte-paper/17042}OCaml
     version of the “Build systems à la carte” paper} first. For thunks we use
    the term "build engine", but it is interchangeable with the term "build
    system" used in the paper.

    The reference build engine uses the same components as
    ["tests/MlFront_Thunk/alacarte_6_4_test.ml"] to aid in understanding. All of
    those components are in {!BuildCore}. *)

module LuaJsonSupport =
  MlFront_Thunk.ThunkLuaLibJsonDk.Support (MlFront_Thunk.ThunkLuaScript.Value)

module Make (Ctx : BuildContext.S) = struct
  module BuildFinder' = BuildFinder.Make (Ctx)
  module BuildTaskFactory' = BuildTaskFactory.Make (Ctx)
  module BuildTaskScript' = BuildTaskScript.Make (Ctx)
  module BuildTaskUnresolved' = BuildTaskUnresolved.Make (Ctx)
  module BuildValues' = BuildValues.Make (Ctx)

  let log_debug msgf = Ctx.run_isolated_promise @@ Ctx.Log.debug msgf

  type parse_result =
    | HadWarnings
    | AddedValuesJsonFile of {
        values_file_sha256 : string;
        local_values_file : [ `Validated of Ctx.Io.file_object ];
      }
    | AddedValuesLuaFile of {
        values_file_sha256 : string;
        local_values_file : [ `Validated of Ctx.Io.file_object ];
      }

  let parse_valueslua_file_gracefully ctx ~values_file_sha256
      ~validated_values_file (module Tasks' : Ctx.THUNK_TASKS)
      (values_file : Ctx.Io.file_object) =
    (* Add tasks to mutable Tasks *)
    if Ctx.debug_task ctx then
      log_debug (fun l ->
          l "[task] %s parses `%s`"
            (Ctx.V.get_valuesluafile_value_id ~values_file_sha256)
            (Ctx.Io.file_origin values_file));
    BuildTaskFactory'.add_valuesluafile_tasks_gracefully ctx
      ~values_file:validated_values_file ~values_file_sha256
      ~add_task:
        (BuildTaskUnresolved'.add_task_if_missing
           (module Tasks' : Ctx.THUNK_TASKS))
      ()

  let parse_valuesjson_file_gracefully ?deny_deprecated_function_args ctx
      ~values_file_sha256 ~validated_values_file
      (module Tasks' : Ctx.THUNK_TASKS) (values_file : Ctx.Io.file_object) =
    (* Add tasks to mutable Tasks *)
    if Ctx.debug_task ctx then
      log_debug (fun l ->
          l "[task] %s parses `%s`"
            (Ctx.V.get_valuesjsonfile_value_id ~values_file_sha256)
            (Ctx.Io.file_origin values_file));

    BuildTaskFactory'.add_valuesjsonfile_tasks_gracefully
      ?deny_deprecated_function_args ctx ~values_file:validated_values_file
      ~values_file_sha256
      ~add_task:
        (BuildTaskUnresolved'.add_task_if_missing
           (module Tasks' : Ctx.THUNK_TASKS))
      ()

  type state = Ctx.State.t

  (** For .mli *)
  let create_key_for_object = Ctx.K.create_for_object

  (** For .mli *)
  let create_key_for_bundle = Ctx.K.create_for_bundle

  (** For .mli *)
  let create_key_for_asset = Ctx.K.create_for_asset

  (** For .mli *)
  let create_key_for_scriptmodule = Ctx.K.create_for_scriptmodule

  let parse_values_files_gracefully ctx (module Tasks' : Ctx.THUNK_TASKS) =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    (* Find values files *)
    let values_files =
      let f typ =
        List.map
          (BuildFinder'.get_values_files_in_dir_and_sublibraries
             ~explain:(Ctx.explain ctx) ~typ)
      in
      f `System (Ctx.sysincludedirs ctx)
      @ f `Workspace (Ctx.workspaceincludedirs ctx)
      @ f `User (Ctx.userincludedirs ctx)
      |> List.flatten
    in

    (* Parse values files into SourceAst, etc. input keys with values which we'll
     need for the StoreInfo.
     At the same time we'll create tasks for the related Form non-input keys
     and add them to (mutable) Tasks *)
    let f ({ file = values_file; subtyp } : BuildFinder'.t) =
      (* Get SHA256(values file). We can strip CR (13) because it is a JSON file.
       We must strip CR because Git is by default inconsistent with CRLF endings. *)
      let* sha256_result =
        Ctx.Io.checksum_file ~algo:`SHA256 ~dos2unix:() values_file
      in
      let values_file_type =
        match subtyp with ValuesJson _flags -> `Json | ValuesLua -> `Lua
      in
      let alert s =
        Printf.sprintf "%s: %s" (Ctx.Io.file_origin values_file) s
      in
      match sha256_result with
      | `Error err ->
          let* () = Ctx.Log.warn (fun l -> l "%s" (alert err)) in
          return HadWarnings
      | `Checksum (values_file_sha256, _values_file_sz) -> (
          (* add values file to value store *)
          let* (_added : bool) =
            BuildValues'.add_values_file_exn
              ~valuestore:(Ctx.valuestore_maybe_relto_basedir ctx)
              ~values_file_sha256 ~values_file_type values_file
          in

          (* trust: [values_file] is local and part of the user include path *)
          Assumptions.no_trust_for_local_values_file ();
          let validated_values_file = `Validated values_file in

          (* Do specialization based on subtyp *)
          let* values_result =
            match subtyp with
            | ValuesJson flags ->
                let deny_deprecated_function_args =
                  if List.mem `Allow_deprecated_toplevel_moduleid flags then
                    Some ()
                  else None
                in
                parse_valuesjson_file_gracefully ?deny_deprecated_function_args
                  ctx ~values_file_sha256 ~validated_values_file
                  (module Tasks')
                  values_file
            | ValuesLua ->
                parse_valueslua_file_gracefully ctx ~values_file_sha256
                  ~validated_values_file
                  (module Tasks')
                  values_file
          in
          match values_result with
          | Error msg ->
              let* () = Ctx.Log.warn (fun l -> l "%s" (alert msg)) in
              return HadWarnings
          | Ok `Json ->
              return
                (AddedValuesJsonFile
                   {
                     values_file_sha256;
                     local_values_file = validated_values_file;
                   })
          | Ok `Lua ->
              return
                (AddedValuesLuaFile
                   {
                     values_file_sha256;
                     local_values_file = validated_values_file;
                   }))
    in
    let* file_results = Ctx.Promise.parallel (List.map f values_files) in

    (* Add embedded values *)
    let* embedded_results =
      let embedded_parse_results =
        List.map f (BuildFinder'.get_embedded_values_files ctx)
      in
      Ctx.Promise.parallel embedded_parse_results
    in

    let final_result =
      List.fold_left
        (fun (acc_warnings, acc_keys) warnings_result ->
          match (acc_warnings, (warnings_result : parse_result)) with
          | `NoWarnings, HadWarnings -> (`HadWarnings, acc_keys)
          | `HadWarnings, HadWarnings -> (`HadWarnings, acc_keys)
          | _, AddedValuesJsonFile { values_file_sha256; local_values_file } ->
              ( acc_warnings,
                `ValuesJsonFileSHA256 (values_file_sha256, local_values_file)
                :: acc_keys )
          | _, AddedValuesLuaFile { values_file_sha256; local_values_file } ->
              ( acc_warnings,
                `ValuesLuaFileSHA256 (values_file_sha256, local_values_file)
                :: acc_keys ))
        (`NoWarnings, [])
        (file_results @ embedded_results)
    in
    Ctx.Promise.return final_result

  let troubleshoot_recursion =
    let counter = ref 0 in
    fun () ->
      incr counter;
      if !counter = 3 then failwith "stop at 3"
  [@@warning "-unused-value-declaration"]

  let register_scriptmodules ctx ~kont_state () =
    List.map
      (function
        | ({
             scriptmodule_values_canonical_id;
             scriptmodule_values_file_sha256;
             scriptmodule_id;
             scriptmodule_range;
             scriptmodule_file;
           } :
            Ctx.V.scriptmodule) ->
            BuildTaskScript'.register_scriptmodule ctx ~kont_state
              ~scriptmodule_values_canonical_id ~scriptmodule_values_file_sha256
              ~scriptmodule_id ~scriptmodule_range ~scriptmodule_file ())
      (Ctx.State.get_all_scriptmodule_values kont_state)

  (** For .mli *)
  let load_state_and_tasks_gracefully ?(lua_valuescan_origin = `UserRanBuild)
      ?(lua_allow_fetch = false) ctx ~traces () =
    (* let open Alacarte_3_7_test_last in
    let open Alacarte_xasync_apparatus in
    let module I = ThunkTrackingInterpreter in *)
    (* Create predetermined tasks *)
    let module Tasks = (val Ctx.tasks_module) in
    (* Precompile traces *)
    let precompiled_traces = Ctx.State.precompile_traces traces in

    (* Configure Lua. We need a forward reference to the state since Lua
     calls back into the build system. *)
    let build_state = ref None in
    let fetch_script_module =
      if lua_allow_fetch then
        Some
          (fun module_id module_semver ->
            match !build_state with
            | None -> Ok `NotFound
            | Some build_state ->
                let key =
                  Ctx.K.create_for_scriptmodule ~debug_reference:None ~module_id
                    ~module_semver ()
                in
                let cont =
                  BuildTaskUnresolved'.run_single ctx ~tasks:(module Tasks) key
                in
                let (_ : state) =
                  BuildTaskUnresolved'.run_unit_continuation cont build_state
                in
                Ok `Found)
      else None
    in

    (* Run the parsing promises. Simultaneously they'll update [Tasks] *)
    let parse_values_files_promise =
      parse_values_files_gracefully ctx (module Tasks)
    in
    let warnings_result, valuefiles =
      Ctx.run_isolated_promise parse_values_files_promise
    in
    (* This is a good spot to make sure all the prior stdout/stderr messages
     are flushed before we start the build process. If this were not a
     reference implementation, we might start a thread pool in the next
     step for the build tasks. *)
    flush_all ();
    (* Continue on configuring the build system ... *)
    (* let module CtRebuilder = CtRebuilderOfTasks (Tasks) in
    let module SuspendingScheduler =
      SuspendingSchedulerOfRebuilderAndTasks (CtRebuilder) (Tasks)
    in *)
    (* Addition: Configure the store which is part of the state. *)
    let store =
      Ctx.MutableStore.initialise
        (Ctx.StoreInfo.create ~explain:(Ctx.explain ctx)
           ~warnings_during_parsing:
             (match warnings_result with
             | `HadWarnings -> true
             | `NoWarnings -> false))
    in

    (* Continue on configuring the build system ... *)
    let kont_state =
      Ctx.State.create_with_precompiled_traces_and_lua_options
        ~valuescan_origin:lua_valuescan_origin ?fetch_script_module store
        precompiled_traces
    in
    build_state := Some kont_state;

    (* Accept known distributions *)
    Assumptions.accepted_distributions_are_present_in_trace_store ();
    Assumptions.distribution_entry_points_only_trace_stores_and_include_dirs ();
    Ctx.State.accept_known_distributions kont_state;

    (* Put real locations of local value files into the state *)
    let prefetch_keys =
      List.map
        (function
          | `ValuesJsonFileSHA256 (values_file_sha256, local_file) ->
              Ctx.State.assign_values_file_location ~values_file_sha256
                ~local_file kont_state;
              `ValuesJsonFileSHA256 values_file_sha256
          | `ValuesLuaFileSHA256 (values_file_sha256, local_file) ->
              Ctx.State.assign_values_file_location ~values_file_sha256
                ~local_file kont_state;
              `ValuesLuaFileSHA256 values_file_sha256)
        valuefiles
    in

    (* Evaluate and register Lua script modules. *)
    Assumptions
    .scriptmodule_in_tracestore_guarantees_lua_scriptmodule_registered ();
    (*    performance: this is all CPU except the registering into the
        Lua package registry. *)
    let promises = register_scriptmodules ctx ~kont_state () in
    let (_ : unit list) =
      Ctx.run_isolated_promise (Ctx.Promise.parallel promises)
    in

    (* Done *)
    (kont_state, (module Tasks : Ctx.THUNK_TASKS), prefetch_keys)

  (** For .mli *)
  let output_get_object ctx ~build_request ~source ~command_output
      ~archive_member key =
    let open Ctx.Syntax in
    let* state = get in
    let value = Ctx.MutableStore.get_value key (Ctx.State.store state) in
    Ctx.output_get_object ctx ~build_request ~source ~command_output
      ~archive_member key value

  (** For .mli *)
  let output_install_object ctx ~build_request ~source ~command_output
      ~archive_member key =
    let open Ctx.Syntax in
    let* state = get in
    let value = Ctx.MutableStore.get_value key (Ctx.State.store state) in
    Ctx.output_install_object ctx ~build_request ~source ~command_output
      ~archive_member key value

  (** For .mli *)
  let output_post_object ctx ~build_request ~source ~command_output
      ~archive_member key =
    let open Ctx.Syntax in
    let* state = get in
    let value = Ctx.MutableStore.get_value key (Ctx.State.store state) in
    Ctx.output_post_object ctx ~build_request ~source ~command_output
      ~archive_member key value

  (** For .mli *)
  let output_get_bundle ctx ~build_request ~source ~command_output key =
    let open Ctx.Syntax in
    let* state = get in
    let value = Ctx.MutableStore.get_value key (Ctx.State.store state) in
    Ctx.output_get_bundle ctx ~build_request ~source ~command_output key value

  (** For .mli *)
  let output_get_asset ctx ~build_request ~source ~command_output
      ~archive_member key =
    let open Ctx.Syntax in
    let* state = get in
    let value = Ctx.MutableStore.get_value key (Ctx.State.store state) in
    Ctx.output_get_asset ctx ~build_request ~source ~command_output
      ~archive_member key value

  (** For .mli *)
  let unzip_and_cache_value ctx ~source range key =
    let open Ctx.Syntax in
    let* state = get in
    let value = Ctx.MutableStore.get_value key (Ctx.State.store state) in
    Ctx.unzip_and_cache_value ctx ~source range value

  let remove_invalid_values ctx (state : state) =
    let valuestore = Ctx.valuestore_maybe_relto_basedir ctx in
    let buildlogtrace = if Ctx.buildlogtrace ctx then Some () else None in
    let cont =
      let open Ctx.Syntax in
      match Ctx.integrity ctx with
      | `None -> return ()
      | `Existence ->
          (* We don't need to check for existence since already done. *)
          Assumptions
          .persisted_values_are_checked_for_existence_during_trace_store_load ();
          return ()
      | `Checksum as integrity ->
          let integrity_name = "checksum" in
          if buildlogtrace = Some () then
            log_debug (fun l ->
                l "[buildlog] post load %s check start" integrity_name);
          let* state' = get in
          let _newgen, traces = Ctx.State.new_generation state' in
          let visited = Hashtbl.create (List.length traces) in
          let* () =
            List.fold_left
              (fun acc
                   ({ generation = _; key = k; dependencies = _; result = v } as
                    trace :
                     Ctx.State.trace) ->
                let* () = acc in
                match
                  (Ctx.V.value_id v, Ctx.V.maybe_cloud_persistent_hash k v)
                with
                | Some value_id, Some value_sha256 ->
                    if Hashtbl.mem visited value_id then return ()
                    else begin
                      Hashtbl.add visited value_id ();
                      let* (maybe_available : MlFront_Core.FilePath.t option) =
                        BuildValues'.make_value_available ?buildlogtrace
                          ~valuestore ~value_id ~value_sha256 ~integrity ()
                      in
                      match maybe_available with
                      | Some _available_fp -> return ()
                      | None ->
                          if buildlogtrace = Some () then
                            log_debug (fun l ->
                                l "[buildlog] remove trace %s" value_id);
                          let* state' = get in
                          Ctx.State.remove_trace state' trace;
                          return ()
                    end
                | _ -> return ())
              (return ()) traces
          in
          if buildlogtrace = Some () then
            log_debug (fun l ->
                l "[buildlog] post load %s check finished" integrity_name);
          return ()
    in
    let (), state' = Ctx.run_continuation cont state in
    state'
end