Source file BuildInstance.ml

open BuildCore

module type THUNK_TASKS =
  MlFront_Thunk.BuildSystems.DYNAMIC_TASKS
    with type k = Alacarte_3_2_apparatus.K.t
     and type lifted_vc =
      Alacarte_3_2_apparatus.V.t
      Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t
     and type vc =
      Alacarte_3_2_apparatus.V.t
      Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t
     and type o = Alacarte_3_2_apparatus.O.t
     and type up = unit Alacarte_xpromise_apparatus.Promise.t

(** Meant to be opened. *)
module Syntax = struct
  include
    BuildCore.Traces (BuildCore.Alacarte_3_7_test_last.ThunkTrackingInterpreter)

  let ( let* ) = Alacarte_6_4_test.CSuspending.bind
  let lift_promise = Alacarte_6_4_test.CSuspending.lift_promise
  let return = Alacarte_6_4_test.CSuspending.return
  let get = Alacarte_6_4_test.CSuspending.get
  let parallel = Alacarte_6_4_test.CSuspending.parallel

  type 'a cont = 'a Alacarte_6_4_test.CSuspending.t
end

(** Saving and fetching values into the value store *)
module ValueStore = struct
  open struct
    let ( let* ) = Alacarte_xpromise_apparatus.Promise.bind
    let return = Alacarte_xpromise_apparatus.Promise.return

    let fail_exn ~because () =
      let bi : MlFront_Thunk.BuildWriters.Standard.backtrace_item =
        ErrorBacktraceItem'
          {
            error_code = "bf55338e";
            cant_do = "add to value store";
            because;
            error_locations = [];
            recommendations = [];
          }
      in
      raise
        (BuildExceptions.EngineShutdown
           { trace = [ bi ]; exitcode_posix = 3; exitcode_windows = 3 })
  end

  (** The "local" file is used to display errors, and is pretty printed to the
      screen with line and markers ... and for convenience for the user in an
      IDE that pretty print OBSERVER_RESULT should have a clickable file
      location. The value store is an OK fallback, but it won't let the user
      edit the original file.

      But we can't trust the "local" file. Since the trace may come from a
      remote source, either accidentally or maliciously an entry could be
      '/etc/passwd'. So only let the build system use the "local" file if the
      file matches the SHA256 checksum. *)
  let safe_local_values_file ~values_file_local ~values_file_sha256 =
    match MlFront_Core.FilePath.of_string values_file_local with
    | Error _ -> return None
    | Ok values_file_local_fp -> (
        let unvalidated_supposed_local_file =
          BuildCore.Io.disk_file values_file_local_fp
        in
        let* sha256_result =
          BuildCore.Io.checksum_file ~algo:`Sha256 ~strip_carriage_returns:()
            unvalidated_supposed_local_file
        in
        match sha256_result with
        | `Error _ -> return None
        | `Checksum (actual_sha256, _actual_size) ->
            if String.equal actual_sha256 values_file_sha256 then
              return (Some (`Validated unvalidated_supposed_local_file))
            else return None)

  let get_value_file ~valuestore ~value_id () =
    match MlFront_Core.FilePath.append value_id valuestore with
    | Error _ -> return None
    | Ok value_fp ->
        if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
          return (Some value_fp)
        else return None

  let put_value_file ~valuestore ~value_id contents =
    match MlFront_Core.FilePath.append value_id valuestore with
    | Error msg -> fail_exn ~because:msg ()
    | Ok value_fp -> (
        let value_file = BuildCore.Io.disk_file value_fp in
        let* added =
          if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
            return false
          else
            let* replace_result =
              BuildCore.Io.replace_all_bytes value_file
                (String.to_bytes contents) 0 (String.length contents)
            in
            match replace_result with
            | `Error msg -> fail_exn ~because:msg ()
            | `IsDirectory _ ->
                fail_exn
                  ~because:
                    (Printf.sprintf "the supposed file `%s` is a directory"
                       (BuildCore.Io.file_origin value_file))
                  ()
            | `WroteBytes -> return true
        in
        let sha256_result =
          MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file ~algo:`Sha256
            ~return:Fun.id
            (MlFront_Core.FilePath.to_string value_fp)
        in
        match sha256_result with
        | `Checksum cksum -> return (added, cksum)
        | `Error e ->
            fail_exn
              ~because:
                (Printf.sprintf "checksum failed on `%s`: %s"
                   (MlFront_Core.FilePath.to_string value_fp)
                   e)
              ())

  let get_constant0 ~valuestore_get ~value_id () =
    let ( let* ), return = Alacarte_xpromise_apparatus.Promise.(bind, return) in
    let* v_opt = valuestore_get value_id in
    match v_opt with
    | None -> return None
    | Some value_fp ->
    try
      In_channel.with_open_bin (MlFront_Core.FilePath.to_string value_fp)
        (fun ic -> return (Some (In_channel.input_all ic)))
    with Sys_error _ -> return None

  let get_constant ~valuestore ~value_id () =
    get_constant0
      ~valuestore_get:(fun value_id -> get_value_file ~valuestore ~value_id ())
      ~value_id ()

  (** Add an AST value to the value store. If already present it is not added.
  *)
  let add_generic_ast0 ~valuestore_put ~build_seckey ~value_id
      ~marshalled_ast_bytes () =
    (* Calculate file path *)
    let marshalled_ast_bytes = marshalled_ast_bytes () in
    (* Create bits for values' AST *)
    let buf = Buffer.create 4096 in
    (* B: SHA-256 checksum *)
    let sha256_raw =
      Digestif.SHA256.to_raw_string
        (Digestif.SHA256.digest_bytes marshalled_ast_bytes)
    in
    (* C: Sign checksum *)
    let signature =
      MlFront_Signify.Signify.sign_message_exn
        ~seckey:(match build_seckey with `SecretKey k -> k)
        ~message:sha256_raw ()
    in
    (* D: Write 4-byte version DKBA (dk build AST). *)
    Buffer.add_string buf "DKBA";
    (* E: Write 32-byte [SHA-256]. *)
    Buffer.add_string buf sha256_raw;
    (* F: Write [int32 BE length (SIGN)] and [SIGN]. *)
    Buffer.add_int32_be buf (Int32.of_int (String.length signature));
    Buffer.add_string buf signature;
    (* G: Write [int32 BE length (MARSHAL)] and [MARSHAL]. *)
    Buffer.add_int32_be buf (Int32.of_int (Bytes.length marshalled_ast_bytes));
    Buffer.add_bytes buf marshalled_ast_bytes;

    valuestore_put value_id (Buffer.contents buf)

  let add_generic_ast_exn ~valuestore ~build_seckey ~value_id
      ~marshalled_ast_bytes () =
    add_generic_ast0
      ~valuestore_put:(fun value_id -> put_value_file ~valuestore ~value_id)
      ~build_seckey ~value_id ~marshalled_ast_bytes ()

  (** Add a constant value to the value store. If already present it is not
      added.

      The constant location will be ["'c' || base32(value_id)"]. *)
  let add_constant_exn ~valuestore ~value_id value =
    match MlFront_Core.FilePath.append value_id valuestore with
    | Error msg -> fail_exn ~because:msg ()
    | Ok value_fp ->
        if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
          return ()
        else begin
          let value_file = BuildCore.Io.disk_file value_fp in
          let* replace_result =
            BuildCore.Io.replace_all_bytes value_file (String.to_bytes value) 0
              (String.length value)
          in
          match replace_result with
          | `Error msg -> fail_exn ~because:msg ()
          | `IsDirectory _ ->
              fail_exn
                ~because:
                  (Printf.sprintf "the supposed file `%s` is a directory"
                     (BuildCore.Io.file_origin value_file))
                ()
          | `WroteBytes -> return ()
        end

  (** Add values file to the value store. If already present it is not added.

      The location will be ["'v' || base32(sha256_hex(values_file))"]. *)
  let add_values_file_exn ~valuestore ~values_file_sha256 values_file =
    match
      MlFront_Core.FilePath.append
        (BuildCore.Alacarte_3_2_apparatus.V.get_valuesjsonfile_value_id
           ~values_file_sha256)
        valuestore
    with
    | Error msg -> fail_exn ~because:msg ()
    | Ok value_fp ->
        if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
          return false
        else begin
          let value_file = BuildCore.Io.disk_file value_fp in
          let* copy_result =
            BuildCore.Io.copy_but_error_if_dest_is_dir ~src:values_file
              ~dest:value_file ()
          in
          match copy_result with
          | `Error msg -> fail_exn ~because:msg ()
          | `SourceIsDirectory _ ->
              fail_exn
                ~because:
                  (Printf.sprintf "the supposed values file `%s` is a directory"
                     (BuildCore.Io.file_origin values_file))
                ()
          | `Copied -> return true
        end

  (** Add debug source file to the value store. If already present it is not
      added.

      The location will be ["'d' || base32(sha256_hex(source_file))"].

      The return value is [true] if and only if the source file was newly added.
  *)
  let add_debug_source_file_exn ~valuestore ~source_file_sha256 source_file =
    match
      MlFront_Core.FilePath.append
        (BuildCore.Alacarte_3_2_apparatus.V.get_source_file_value_id
           ~source_file_sha256)
        valuestore
    with
    | Error msg -> fail_exn ~because:msg ()
    | Ok value_fp ->
        if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
          return false
        else begin
          let value_file = BuildCore.Io.disk_file value_fp in
          let* copy_result =
            BuildCore.Io.copy_but_error_if_dest_is_dir ~src:source_file
              ~dest:value_file ()
          in
          match copy_result with
          | `Error msg -> fail_exn ~because:msg ()
          | `SourceIsDirectory _ ->
              fail_exn
                ~because:
                  (Printf.sprintf "the supposed source file `%s` is a directory"
                     (BuildCore.Io.file_origin source_file))
                ()
          | `Copied -> return true
        end

  let get_validated_ast_bytes_exn ~on_fail ~input_bytes ~input_byte
      ~build_pubkey () : bytes * Digestif.SHA256.t =
    let rolling_checksum = ref (Digestif.SHA256.init ()) in
    let b4 = Bytes.create 4 in
    let b32 = Bytes.create 32 in
    let read_int32be () =
      match input_bytes b4 0 4 with
      | None -> raise on_fail
      | Some () ->
          rolling_checksum := Digestif.SHA256.feed_bytes !rolling_checksum b4;
          Bytes.get_int32_be b4 0 |> Int32.to_int
    in
    let read_into_b32 () =
      match input_bytes b32 0 32 with
      | None -> raise on_fail
      | Some () ->
          rolling_checksum := Digestif.SHA256.feed_bytes !rolling_checksum b32;
          ()
    in
    (* Read 4-byte version DKBA *)
    let v1 = input_byte () in
    let v2 = input_byte () in
    let v3 = input_byte () in
    let v4 = input_byte () in
    (match (v1, v2, v3, v4) with
    | Some 0x44, Some 0x4B, Some 0x42, Some 0x41 ->
        Bytes.set_int8 b4 0 0x44;
        Bytes.set_int8 b4 1 0x4B;
        Bytes.set_int8 b4 2 0x42;
        Bytes.set_int8 b4 3 0x41;
        rolling_checksum := Digestif.SHA256.feed_bytes !rolling_checksum b4;
        ()
    | _ -> raise on_fail);

    (* Read [SHA-256] *)
    read_into_b32 ();
    let sha256 = Bytes.to_string b32 in

    (* Read [SIGN] *)
    let sign_len = read_int32be () in
    let sign = Bytes.create sign_len in
    (match input_bytes sign 0 sign_len with
    | None -> raise on_fail
    | Some () ->
        rolling_checksum :=
          Digestif.SHA256.feed_bytes ~len:sign_len !rolling_checksum sign;
        ());

    (* Get fingerprint so we can find the right public key.
      Implementors: In the reference implementation we use
      [build_pubkey] but you can use the fingerprint to lookup
      the public key in a database or directory. *)
    let fingerprint =
      (* fingerprint requires the last line of the public key, not the comment *)
      let true_sign =
        let lines =
          String.split_on_char '\n' (String.trim (String.of_bytes sign))
        in
        match List.rev lines with [] -> "" | x :: _ -> x
      in
      try
        MlFront_Signify.Signify.fingerprint_signature_exn
          (String.trim true_sign ^ "\n")
      with Invalid_argument _msg -> raise on_fail
    in
    ignore fingerprint;

    (* Verify [SHA-256] with [SIGN] and build_pubkey *)
    (match
       MlFront_Signify.Signify.verify_message
         ~pubkey:(match build_pubkey with `PublicKey k -> k)
         ~message:sha256 ~signature_:(Bytes.to_string sign) ()
     with
    | Ok () -> ()
    | Error _msg -> raise on_fail);

    (* Read [MARSHAL] *)
    let marshal_len = read_int32be () in
    let marshal = Bytes.create marshal_len in
    (match input_bytes marshal 0 marshal_len with
    | None -> raise on_fail
    | Some () ->
        rolling_checksum :=
          Digestif.SHA256.feed_bytes ~len:marshal_len !rolling_checksum marshal;
        ());

    let cksum = Digestif.SHA256.get !rolling_checksum in
    (marshal, cksum)

  let get_generic_ast0 (type a) ~build_pubkey ~valuestore_get ~value_id
      ~(unmarshal : bytes -> a) () :
      (a * [ `Sha256 of string ]) option Alacarte_xpromise_apparatus.Promise.t =
    let ( let* ), return = Alacarte_xpromise_apparatus.Promise.(bind, return) in
    let* v_opt = valuestore_get value_id in
    match v_opt with
    | None -> return None
    | Some value_fp -> (
        let exception BadAst in
        try
          In_channel.with_open_bin (MlFront_Core.FilePath.to_string value_fp)
            (fun ic ->
              let marshal, cksum =
                get_validated_ast_bytes_exn ~on_fail:BadAst
                  ~input_bytes:(In_channel.really_input ic)
                  ~input_byte:(fun () -> In_channel.input_byte ic)
                  ~build_pubkey ()
              in

              (* Unmarshal [MARSHAL] *)
              let ast = unmarshal marshal in

              (* Compute hex-encoded SHA-256 checksum of file *)
              let cksum = Digestif.SHA256.to_hex cksum in
              return (Some (ast, `Sha256 cksum)))
        with Sys_error _ | BadAst -> return None)

  let get_generic_ast (type a) ~valuestore ~build_pubkey ~value_id
      ~(unmarshal : bytes -> a) () :
      (a * [ `Sha256 of string ]) option Alacarte_xpromise_apparatus.Promise.t =
    get_generic_ast0 ~build_pubkey
      ~valuestore_get:(fun value_id -> get_value_file ~valuestore ~value_id ())
      ~value_id ~unmarshal ()

  (** [make_value_available ~valuestore ~value_id ~integrity ()] gets the value
      out of the possibly remote value store and gives it a local path.

      The [integrity] check can be [`Checksum] (check SHA-256), [`Existence]
      (check file exists) or [`None] (no check, assume the file is correct). If
      the file is not present or the check fails, the function will return None.

      The [`Checksum] integrity check uses the constructive trace store as the
      source of truth for the SHA-256 checksum of values. If the file is not in
      the constructive trace store, or if the file is not in the constructive
      trace store, the [`Checksum] integrity check will remove the corrupt value
      from the value store. *)
  let make_value_available ?buildlogtrace ~valuestore ~value_id ~value_sha256
      ~integrity () =
    let open Syntax in
    match MlFront_Core.FilePath.append value_id valuestore with
    | Error msg ->
        if buildlogtrace = Some () then
          Printf.eprintf "[buildlog] failed to make value `%s` available: %s\n"
            value_id msg;
        return None
    | Ok fp -> (
        let fp_s = MlFront_Core.FilePath.to_string fp in
        match integrity with
        | `Checksum -> (
            match
              MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file ~algo:`Sha256
                ~return:Fun.id fp_s
            with
            | `Checksum (cksum, _sz) -> (
                if
                  (* Check if cksum matches *)
                  String.equal
                    (String.lowercase_ascii value_sha256)
                    (String.lowercase_ascii cksum)
                then return (Some fp)
                else
                  (* Corrupt object in value store. Remove it gracefully *)
                  match
                    MlFront_Thunk_IoDisk.ThunkIoDisk.delete_local_file
                      ~return:Fun.id fp_s
                  with
                  | `Deleted ->
                      if buildlogtrace = Some () then
                        Printf.eprintf
                          "[buildlog] corrupt value store at `%s`. removed %s, \
                           expected %s\n"
                          fp_s cksum value_sha256;
                      return None
                  | `Error _ ->
                      if buildlogtrace = Some () then
                        Printf.eprintf
                          "[buildlog] corrupt value store at `%s`. skipped but \
                           kept since no permission to remove\n"
                          fp_s;
                      return None)
            | `Error _ -> return None)
        | `Existence ->
            if Sys.file_exists fp_s then return (Some fp) else return None
        | `None -> return (Some fp))

  (** [prepare_value_for_upload ~valuestore ~value_id ()] a place on the local
      filesystem that must be used to place an object file before
      {!upload_value}.

      For implementations without cloud storage, this may be optimized to be the
      local object storage. *)
  let prepare_value_for_upload ~valuestore ~value_id () =
    Alacarte_xpromise_apparatus.Promise.return
    @@ MlFront_Core.FilePath.append_exn value_id valuestore

  let upload_value ~valuestore:_ ~value_id:_ ~value_sha256:_
      (_local_path : MlFront_Core.FilePath.t) =
    Alacarte_xpromise_apparatus.Promise.return ()

  (** [download_value ~on_error ~valuestore ~download ~value_id success_value].

      The object location will be ["'o' || base32(value_id)"].

      If [download] return [`Failed] the failure must already be pending on the
      monad. *)
  let download_value ~on_error ~valuestore ~download ~value_id success_func =
    let open Syntax in
    (* Make directory *)
    let* createdir_result =
      lift_promise
      @@ BuildCore.Io.create_directory (BuildCore.Io.disk_dir valuestore)
    in
    match createdir_result with
    | `Error msg -> on_error msg
    | `Created -> begin
        match MlFront_Core.FilePath.append value_id valuestore with
        | Error msg -> on_error msg
        | Ok value_fp ->
            if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then begin
              let sha256_result =
                MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file
                  ~algo:`Sha256 ~return:Fun.id
                  (MlFront_Core.FilePath.to_string value_fp)
              in
              match sha256_result with
              | `Error e -> on_error e
              | `Checksum sha256 ->
                  return (`Success (success_func (`Sha256 sha256)))
            end
            else begin
              let* (status :
                     [ `Downloaded of [ `Sha256 of string * int64 ] | `Failed ])
                  =
                download value_fp
              in
              match status with
              | `Downloaded (`Sha256 sha256) ->
                  return (`Success (success_func (`Sha256 sha256)))
              | `Failed ->
                  (* Assumption: Failure has been raised by [download]. *)
                  return `Failed
            end
      end

  let add_generic_value ~on_error ~valuestore ~src_file_or_dir ~value_id
      ~staging_dir f =
    let open Syntax in
    (* Make directory *)
    let* createdir_result =
      lift_promise
      @@ BuildCore.Io.create_directory (BuildCore.Io.disk_dir valuestore)
    in
    match createdir_result with
    | `Error msg -> on_error msg
    | `Created -> begin
        match MlFront_Core.FilePath.append value_id valuestore with
        | Error msg -> on_error msg
        | Ok value_fp ->
            if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
              let sha256_result =
                MlFront_Thunk_IoDisk.ThunkIoDisk.checksum_local_file
                  ~algo:`Sha256 ~return:Fun.id
                  (MlFront_Core.FilePath.to_string value_fp)
              in
              match sha256_result with
              | `Error e -> on_error e
              | `Checksum (value_sha256, _value_size) ->
                  return (f ~value_id ~value_sha256)
            else begin
              let value_file = BuildCore.Io.disk_file value_fp in
              BuildCore.Io.copy_file_or_dir_to_file_and_sha256_or_fail
                ~src:src_file_or_dir ~dest:value_file
                ~staging_dir:(BuildCore.Io.disk_dir staging_dir) ~on_error
                (fun value_sha256 _value_size ->
                  return (f ~value_id ~value_sha256))
            end
      end

  let add_object ~on_error ~valuestore ~src_file_or_dir ~value_id ~staging_dir
      ~object_id ~object_range () =
    add_generic_value ~on_error ~valuestore ~src_file_or_dir ~value_id
      ~staging_dir (fun ~value_id ~value_sha256 ->
        BuildCore.Alacarte_3_2_apparatus.V.Object
          {
            value_id;
            value_sha256;
            value = Some { object_id; object_range; object_origin = None };
          })

  let add_bundle ~on_error ~valuestore ~src_file_or_dir ~value_id ~staging_dir
      ~bundle_id ~bundle_range ~bundle_values_canonical_id
      ~bundle_values_file_sha256 ~bundle_values_file_local () =
    add_generic_value ~on_error ~valuestore ~src_file_or_dir ~value_id
      ~staging_dir (fun ~value_id ~value_sha256 ->
        BuildCore.Alacarte_3_2_apparatus.V.Bundle
          {
            value_id;
            value_sha256;
            value =
              Some
                {
                  bundle_id;
                  bundle_range;
                  bundle_values_canonical_id;
                  bundle_values_file_sha256;
                  bundle_values_file_local;
                };
          })

  let evict_value ~on_error ~valuestore ~value_id () =
    match MlFront_Core.FilePath.append value_id valuestore with
    | Error msg -> on_error msg
    | Ok value_fp ->
        let return = Alacarte_xpromise_apparatus.Promise.return in
        if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
          let delete_result =
            MlFront_Thunk_IoDisk.ThunkIoDisk.delete_local_file ~return:Fun.id
              (MlFront_Core.FilePath.to_string value_fp)
          in
          match delete_result with
          | `Deleted -> return ()
          | `Error msg -> on_error msg
        else return ()

  type trace = Alacarte_6_4_test.StateSuspending.trace

  let hydrate_values ?buildlogtrace ~valuestore ~build_pubkey ~value_id
      ~value_sha256:_ ~values_file_sha256 ~values_file_local
      ({ canonical_id; _ } : MlFront_Thunk.ThunkAst.t) :
      Alacarte_3_2_apparatus.V.t option Alacarte_xpromise_apparatus.Promise.t =
    let open Alacarte_3_2_apparatus in
    let* values_file_opt =
      get_value_file ~valuestore
        ~value_id:(V.get_valuesjsonfile_value_id ~values_file_sha256)
        ()
    in
    match values_file_opt with
    | None -> return None
    | Some values_file ->
        let* values_opt =
          get_generic_ast ~valuestore ~build_pubkey
            ~value_id:(V.get_values_value_id ~values_canonical_id:canonical_id)
            ~unmarshal:(fun bs -> Marshal.from_bytes bs 0)
            ()
        in
        begin
          match values_opt with
          | None ->
              if buildlogtrace = Some () then
                Printf.eprintf
                  "[buildlog] [warning] missing form AST during retrieve %s\n"
                  value_id;
              return None
          | Some (values, `Sha256 value_sha256) ->
              let* values_file_local =
                match values_file_local with
                | None -> return None
                | Some vfl ->
                    Assumptions.no_trust_for_local_values_file ();
                    safe_local_values_file ~values_file_local:vfl
                      ~values_file_sha256
              in
              let values' =
                V.Values
                  {
                    value_id;
                    value_sha256;
                    value =
                      Some
                        {
                          values_canonical_id = canonical_id;
                          values_file_sha256;
                          values_file_local;
                          values_origin = None;
                          values_transient =
                            Some
                              { values; values_file = Io.disk_file values_file };
                        };
                  }
              in
              if buildlogtrace = Some () then
                Printf.eprintf "[buildlog] retrieve values %s\n" value_id;
              return (Some values')
        end

  (** [hydrate_traces ?buildlogtrace ~valuestore dehydrated_traces] restores
      [dehydrated_traces] traces from their dehydrated, persistent form using
      the value store [valuestore]. *)
  let hydrate_traces ?buildlogtrace ~valuestore ~build_pubkey dehydrated_traces
      : trace list Alacarte_xpromise_apparatus.Promise.t =
    let open Alacarte_3_2_apparatus in
    let ( let* ) = Alacarte_xpromise_apparatus.Promise.bind in
    let return = Alacarte_xpromise_apparatus.Promise.return in
    let f ({ key = k; dependencies = deps; result = v } : trace) :
        trace option Alacarte_xpromise_apparatus.Promise.t =
      let* v' =
        match (v : V.t) with
        | V.ValuesFile { value_id; value_sha256 = _; value = _ } ->
            if buildlogtrace = Some () then
              Printf.eprintf "[buildlog] retrieve values file %s\n" value_id;
            return (Some v)
        | V.Values
            {
              value_id;
              value_sha256;
              value =
                Some
                  {
                    values_canonical_id = _;
                    values_file_sha256;
                    values_file_local;
                    values_origin = None;
                    values_transient = Some { values; values_file = _ };
                  };
            } ->
            hydrate_values ?buildlogtrace ~valuestore ~build_pubkey ~value_id
              ~value_sha256 ~values_file_sha256
              ~values_file_local:
                (Option.map
                   (fun (`Validated o) -> Io.file_origin o)
                   values_file_local)
              values
        | V.Values _ -> return None
        | V.Distribution _ ->
            (* [Distribution] can be fully serialized since it must be stored
              entirely in the trace store. *)
            return (Some v)
        | V.Form _ ->
            (* [Form] can be fully serialized
                because their tasks implicitly hydrate themselves from a parsed
                ast and values file (ie. V.ValuesFile and V.Values). *)
            return (Some v)
        | V.Object { value_id; value_sha256 = _; value = Some _ } ->
            if buildlogtrace = Some () then
              Printf.eprintf "[buildlog] retrieve object %s\n" value_id;
            return (Some v)
        | V.Object { value_id = _; value_sha256 = _; value = None } ->
            return None
        | V.Bundle { value_id; value_sha256 = _; value = Some _ } ->
            if buildlogtrace = Some () then
              Printf.eprintf "[buildlog] retrieve bundle %s\n" value_id;
            return (Some v)
        | V.Bundle { value_id = _; value_sha256 = _; value = None } ->
            return None
        | V.Asset { value_id; value_sha256 = _; value = Some _ } ->
            if buildlogtrace = Some () then
              Printf.eprintf "[buildlog] retrieve asset %s\n" value_id;
            return (Some v)
        | V.Asset { value_id = _; value_sha256 = _; value = None } ->
            return None
        | V.Constant
            { value_id; value_sha256; value = Some { constant_transient = _ } }
          -> begin
            let* constant_opt = get_constant ~valuestore ~value_id () in
            match constant_opt with
            | None -> return None
            | Some constant_value ->
                if buildlogtrace = Some () then
                  Printf.eprintf "[buildlog] retrieve constant %s\n" value_id;
                return
                  (Some
                     (V.Constant
                        {
                          value_id;
                          value_sha256;
                          value =
                            Some
                              { constant_transient = Some { constant_value } };
                        }))
          end
        | V.Constant _ -> return None
        | V.Input_not_found _ | V.Failure_is_pending -> return None
      in
      return
        (Option.map
           (fun v'' : trace -> { key = k; dependencies = deps; result = v'' })
           v')
    in
    let* maybe_traces =
      Alacarte_xpromise_apparatus.Promise.parallel
        (List.map f dehydrated_traces)
    in
    return (List.filter_map Fun.id maybe_traces)

  let dehydrate_key ~valuestore
      ~(debug : ?suffix:string -> string -> string -> unit)
      ({ key_datum = _; debug_reference } as key : Alacarte_3_2_apparatus.K.t) :
      Alacarte_3_2_apparatus.K.t Alacarte_xpromise_apparatus.Promise.t =
    let open Alacarte_3_2_apparatus in
    match debug_reference with
    | None
    | Some
        {
          reference_range = _;
          reference_file_sha256 = _;
          reference_transient = None;
        } ->
        return key
    | Some
        {
          reference_range;
          reference_file_sha256;
          reference_transient = Some { reference_file };
        } ->
        (* The reference can't be serialized so it is copied into the
                 value store. *)
        let* added =
          add_debug_source_file_exn ~valuestore
            ~source_file_sha256:reference_file_sha256 reference_file
        in
        debug
          ~suffix:
            (":"
            ^ Format.asprintf "%a"
                (MlFront_Thunk.ThunkParsers.Results.pp_range None)
                reference_range
            ^ " " ^ K.show key)
          ("debug source" ^ if added then "" else " (dup)")
          (Io.file_origin reference_file);
        return key

  let dehydrate_value_values ~valuestore ~build_seckey
      ~(debug : ?suffix:string -> string -> string -> unit) key
      ({ value_id; value_sha256 = _; value } :
        Alacarte_3_2_apparatus.V.values Alacarte_3_2_apparatus.V.persistent) =
    let open Alacarte_3_2_apparatus in
    let ( let* ) = Alacarte_xpromise_apparatus.Promise.bind in
    let return = Alacarte_xpromise_apparatus.Promise.return in
    match value with
    | None -> return None
    | Some
        {
          values_canonical_id = _;
          values_file_sha256;
          values_file_local;
          values_origin = _;
          values_transient;
        } ->
    match values_transient with
    | None -> return None
    | Some { values = { canonical_id; _ } as values; values_file } ->
        let* (_added : bool) =
          (* Isn't the values file already in the value store at startup? Not for dynamic tasks. *)
          add_values_file_exn ~valuestore ~values_file_sha256 values_file
        in
        let* added, (value_sha256, _value_size) =
          add_generic_ast_exn ~valuestore ~build_seckey ~value_id
            ~marshalled_ast_bytes:(fun () -> Marshal.to_bytes values [])
            ()
        in
        debug
          ~suffix:(" " ^ K.show key)
          ("values" ^ if added then "" else " (dup)")
          value_id;
        let v =
          V.Values
            {
              value_id;
              value_sha256;
              value =
                Some
                  {
                    values_canonical_id = canonical_id;
                    values_file_sha256;
                    values_file_local;
                    values_origin = None;
                    values_transient = None;
                  };
            }
        in
        return (Some v)

  let dehydrate_value_object
      ~(debug : ?suffix:string -> string -> string -> unit) key
      ({ value_id; value; value_sha256 } :
        Alacarte_3_2_apparatus.V.object_ Alacarte_3_2_apparatus.V.persistent) =
    let open Alacarte_3_2_apparatus in
    let return = Alacarte_xpromise_apparatus.Promise.return in
    match value with
    | None -> return None
    | Some value ->
        debug
          ~suffix:
            (Format.asprintf " %s %a" (K.show key)
               (MlFront_Thunk.ThunkParsers.Results.pp_range None)
               value.object_range)
          "object" value_id;
        return (Some (V.Object { value_id; value = Some value; value_sha256 }))

  let dehydrate_value_bundle
      ~(debug : ?suffix:string -> string -> string -> unit) key
      ({ value_id; value_sha256; value } :
        Alacarte_3_2_apparatus.V.bundle Alacarte_3_2_apparatus.V.persistent) =
    let open Alacarte_3_2_apparatus in
    let return = Alacarte_xpromise_apparatus.Promise.return in
    match value with
    | None -> return None
    | Some value ->
        debug
          ~suffix:
            (Format.asprintf " %s %a" (K.show key)
               (MlFront_Thunk.ThunkParsers.Results.pp_range None)
               value.bundle_range)
          "bundle" value_id;
        return (Some (V.Bundle { value_id; value = Some value; value_sha256 }))

  let dehydrate_value_asset
      ~(debug : ?suffix:string -> string -> string -> unit) key
      ({ value_id; value_sha256; value } :
        Alacarte_3_2_apparatus.V.asset Alacarte_3_2_apparatus.V.persistent) =
    let open Alacarte_3_2_apparatus in
    let return = Alacarte_xpromise_apparatus.Promise.return in
    match value with
    | None -> return None
    | Some value ->
        debug
          ~suffix:
            (Format.asprintf " %s %a" (K.show key)
               (MlFront_Thunk.ThunkParsers.Results.pp_range None)
               value.asset_range)
          "asset" value_id;
        return (Some (V.Asset { value_id; value = Some value; value_sha256 }))

  (** [dehydrate_traces ?buildlogtrace ~valuestore traces] returns traces that
      can and should be persisted to a constructive trace log.

      Any potentially large items are saved in the [valuestore]. *)
  let dehydrate_traces ?buildlogtrace ~valuestore ~build_seckey
      (traces : trace list) : trace list Alacarte_xpromise_apparatus.Promise.t =
    let open Alacarte_3_2_apparatus in
    (* Make directory *)
    let* createdir_result =
      BuildCore.Io.create_directory (BuildCore.Io.disk_dir valuestore)
    in
    match createdir_result with
    | `Error msg -> fail_exn ~because:msg ()
    | `Created ->
        (* Can't have any closures in the traces. And can't have
           any incomplete values. *)
        let debug ?suffix =
          if buildlogtrace = Some () then fun name value_id ->
            Printf.eprintf "[buildlog] record %s %s%s\n" name value_id
              (match suffix with None -> "" | Some v -> v)
          else fun _ _ -> ()
        in
        let dehydrate_value key (value : V.t) :
            V.t option Alacarte_xpromise_apparatus.Promise.t =
          match value with
          | V.ValuesFile _ -> return (Some value)
          | V.Values values ->
              dehydrate_value_values ~valuestore ~build_seckey ~debug key values
          (* [Distribution] can be fully serialized since it must be stored
              entirely in the trace store. *)
          | V.Distribution
              {
                distribution_id = package_id, package_semver;
                distribution_json = _;
                distribution = _;
              } ->
              debug "distribution"
                (Printf.sprintf "%s@%s"
                   (MlFront_Core.PackageId.full_name package_id)
                   (MlFront_Thunk.ThunkSemver64.to_string package_semver));
              return (Some value)
          (* [Form] can be fully serialized
              because their tasks implicitly hydrate themselves from a parsed
              ast and values file (ie. V.ValuesFile and V.Values). *)
          | V.Form { form_id; _ } ->
              debug "form"
                (MlFront_Thunk.ThunkCommand.show_module_version form_id);
              return (Some value)
          | V.Object object_ -> dehydrate_value_object ~debug key object_
          | V.Bundle bundle -> dehydrate_value_bundle ~debug key bundle
          | V.Asset asset -> dehydrate_value_asset ~debug key asset
          | V.Constant
              {
                value_id;
                value_sha256;
                value = Some { constant_transient = Some { constant_value } };
              } ->
              (* [Constant] could be fully serialized, but we choose to
                 put the constantvalue into the value store. *)
              debug "constant" value_id;
              let* () = add_constant_exn ~valuestore ~value_id constant_value in
              return
                (Some
                   (V.Constant
                      {
                        value_id;
                        value_sha256;
                        value = Some { constant_transient = None };
                      }))
          | V.Constant _ -> return None
          | V.Input_not_found _ | V.Failure_is_pending -> return None
        in
        let* dehydrated_traces : trace list =
          List.fold_left
            (fun acc trace ->
              let { key = k; dependencies = deps; result } : trace = trace in
              let* acc = acc in
              let* dehydrated_v_opt = dehydrate_value k result in
              match dehydrated_v_opt with
              | None -> return acc
              | Some dehydrated_v ->
                  let* dehydrated_k = dehydrate_key ~valuestore ~debug k in
                  let* dehydrated_depk_kvhash_list =
                    Alacarte_xpromise_apparatus.Promise.parallel
                    @@ List.map
                         (fun (depk, kvhash) ->
                           let* dehydrated_depk =
                             dehydrate_key ~valuestore ~debug depk
                           in
                           return (dehydrated_depk, kvhash))
                         deps
                  in
                  let triple : trace =
                    {
                      key = dehydrated_k;
                      dependencies = dehydrated_depk_kvhash_list;
                      result = dehydrated_v;
                    }
                  in
                  return (triple :: acc))
            (return []) traces
        in
        return dehydrated_traces
end

(** Different ways of starting the build systems. *)
module Launcher = struct
  (** [run_continuation kont state] is the primary way of starting a build
      system. *)
  let run_continuation (type a) (kont : a Alacarte_6_4_test.CSuspending.t)
      (state : Alacarte_6_4_test.StateSuspending.state) :
      a * Alacarte_6_4_test.StateSuspending.state =
    let open Alacarte_6_4_test in
    let open Alacarte_xpromise_apparatus in
    let p : (a * CSuspending.state) CSuspending.promise =
      CSuspending.run_state_async kont state
    in
    Promise.run_promise p

  (** [run_isolated_promise p] runs the promise [p]. Some asynchronous systems
      like [Lwt] do not recommend running multiple promises (or event loops)
      simultaneously, so this function is meant to be used isolated from
      {!run_continuation}. That is, use [run_isolated_promise] strictly before
      or strictly after [run_continuation]. *)
  let run_isolated_promise (type a)
      (p : a Alacarte_6_4_test.CSuspending.promise) : a =
    let open Alacarte_3_2_apparatus in
    let open Alacarte_6_4_test in
    let open Alacarte_xasync_apparatus in
    let open Alacarte_xpromise_apparatus in
    let c = CSuspending.lift_promise p in
    let i = StoreInfo.create ~explain:false ~warnings_during_parsing:false in
    let store = MutableStore.initialise i in
    let ir = StateSuspendingAccess.make_from_store store in
    let p : (a * CSuspending.state) CSuspending.promise =
      CSuspending.run_state_async c ir
    in
    let a, state = Promise.run_promise p in
    ignore state;
    a
end