Source file BuildTraceStore.ml

module TraceStoreObserver =
  MlFront_Thunk.ThunkParsers.Results.MakeObserverWithErrorReporter

let unimplemented_read operation =
  raise
    (BuildExceptions.EngineShutdown
       {
         trace =
           [
             ErrorBacktraceItem'
               {
                 error_code = "2a794854";
                 cant_do = "read from the trace store";
                 because = Printf.sprintf "`%s` unimplemented" operation;
                 recommendations = [ "Please file a bug report." ];
                 error_locations = [];
               };
           ];
         exitcode_posix = 4;
         exitcode_windows = 4;
       })

let unimplemented_write operation =
  raise
    (BuildExceptions.EngineShutdown
       {
         trace =
           [
             ErrorBacktraceItem'
               {
                 error_code = "2a794854";
                 cant_do = "write to the trace store";
                 because = Printf.sprintf "`%s` unimplemented" operation;
                 recommendations = [ "Please file a bug report." ];
                 error_locations = [];
               };
           ];
         exitcode_posix = 4;
         exitcode_windows = 4;
       })

let package_version_to_proto ~package_id ~package_semver :
    Traces.package_version option =
  match
    ( (package_id : MlFront_Core.PackageId.t),
      (package_semver : MlFront_Thunk.ThunkSemver64.t) )
  with
  | ( { library_id; namespace; full_name = _; fixlen_name = _ },
      { major; minor; patch; prerelease; build } ) ->
      Some
        {
          package_id =
            Some
              {
                vendor = Some (MlFront_Core.LibraryId.vendor library_id);
                qualifier = Some (MlFront_Core.LibraryId.qualifier library_id);
                unit_ = Some (MlFront_Core.LibraryId.unit library_id);
                namespace;
              };
          package_semver =
            Some
              {
                major = Some major;
                minor = Some minor;
                patch = Some patch;
                prerelease;
                build;
              };
        }

let module_version_to_proto ~module_id ~module_semver :
    Traces.module_version option =
  match
    ( (module_id : MlFront_Core.StandardModuleId.t),
      (module_semver : MlFront_Thunk.ThunkSemver64.t) )
  with
  | ( { library_id; namespace_front; namespace_tail; definition = _ },
      { major; minor; patch; prerelease; build } ) ->
      Some
        {
          module_id =
            Some
              {
                vendor = Some (MlFront_Core.LibraryId.vendor library_id);
                qualifier = Some (MlFront_Core.LibraryId.qualifier library_id);
                unit_ = Some (MlFront_Core.LibraryId.unit library_id);
                namespace_front;
                namespace_tail = Some namespace_tail;
              };
          module_semver =
            Some
              {
                major = Some major;
                minor = Some minor;
                patch = Some patch;
                prerelease;
                build;
              };
        }

let parse_library_id ~vendor ~qualifier ~unit_ =
  match (vendor, qualifier, unit_) with
  | Some vendor, Some qualifier, Some unit_ ->
      MlFront_Core.LibraryId.parse (vendor ^ qualifier ^ "_" ^ unit_)
  | _ -> None

let parse_semver ~major ~minor ~patch ~prerelease ~build =
  match (major, minor, patch) with
  | Some major, Some minor, Some patch ->
      MlFront_Thunk.ThunkSemver64.from_parts major minor patch prerelease build
  | _ -> None

let package_version_from_proto :
    Traces.package_version ->
    (MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t) option = function
  | {
      package_id = Some { vendor; qualifier; unit_; namespace };
      package_semver = Some { major; minor; patch; prerelease; build };
    } -> begin
      match parse_library_id ~vendor ~qualifier ~unit_ with
      | None -> None
      | Some library_id -> (
          let package_id =
            MlFront_Core.PackageId.create ~library_id ~namespace
          in
          match parse_semver ~major ~minor ~patch ~prerelease ~build with
          | Some package_semver -> Some (package_id, package_semver)
          | None -> None)
    end
  | _ -> None

let module_version_from_proto :
    Traces.module_version ->
    (MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t) option =
  function
  | {
      module_id =
        Some
          {
            vendor;
            qualifier;
            unit_;
            namespace_front;
            namespace_tail = Some namespace_tail;
          };
      module_semver = Some { major; minor; patch; prerelease; build };
    } -> begin
      match parse_library_id ~vendor ~qualifier ~unit_ with
      | None -> None
      | Some library_id -> (
          let module_id =
            MlFront_Core.StandardModuleId.create_explicit ~library_id
              ~namespace_front ~namespace_tail
          in
          match parse_semver ~major ~minor ~patch ~prerelease ~build with
          | Some module_semver -> Some (module_id, module_semver)
          | None -> None)
    end
  | _ -> None

let object_slot_to_proto slot = MlFront_Thunk.ThunkCommand.object_slot_list slot

let object_slot_from_proto slot =
  MlFront_Thunk.ThunkCommand.InternalUse.parse_object_slot
    (module TraceStoreObserver)
    MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None slot
  |> Result.to_option

let position_to_proto : Fmlib_parse.Position.t -> Traces.position option =
  let open Fmlib_parse in
  let i32 x = Some (Int32.of_int x) in
  fun pos ->
    let line = Position.line pos in
    let byte_bol = Position.byte_offset_bol pos in
    let byte_col = Position.byte_column pos in
    let correction = Position.column pos - byte_col in
    Some
      {
        line = i32 line;
        byte_bol = i32 byte_bol;
        byte_col = i32 byte_col;
        correction = i32 correction;
      }

type fmlib_position = {
  line : int;
  byte_bol : int;
  byte_col : int;
  correction : int;
}
(** Hack for {!Obj.magic} until https://github.com/hbr/fmlib/issues/25 fixed *)

let () =
  let real = Fmlib_parse.Position.start in
  let sample = { line = 1; byte_bol = 2; byte_col = 3; correction = 4 } in
  let real_sz = Obj.size (Obj.repr real) in
  let sample_sz = Obj.size (Obj.repr sample) in
  assert (real_sz = sample_sz);
  let fake : fmlib_position = Obj.magic real in
  assert (
    fake.line = 0 && fake.byte_bol = 0 && fake.byte_col = 0
    && fake.correction = 0);
  let fake2 : Fmlib_parse.Position.t = Obj.magic sample in
  let open Fmlib_parse in
  assert (
    Position.line fake2 = 1
    && Position.byte_offset_bol fake2 = 2
    && Position.byte_column fake2 = 3
    && Position.column fake2 - Position.byte_column fake2 = 4)

let position_from_proto : Traces.position -> Fmlib_parse.Position.t option =
  function
  | {
      line = Some line;
      byte_bol = Some byte_bol;
      byte_col = Some byte_col;
      correction = Some correction;
    } ->
      let line = Int32.to_int line in
      let byte_bol = Int32.to_int byte_bol in
      let byte_col = Int32.to_int byte_col in
      let correction = Int32.to_int correction in
      let p : fmlib_position = { line; byte_bol; byte_col; correction } in
      Some (Obj.magic p)
  | _ -> None

let range_to_proto : Fmlib_parse.Position.range -> Traces.range option =
  function
  | start, end_ ->
  match (position_to_proto start, position_to_proto end_) with
  | Some start', Some end' -> Some { start = Some start'; end_ = Some end' }
  | _ -> None

let range_from_proto : Traces.range -> Fmlib_parse.Position.range option =
  function
  | { start = Some start'; end_ = Some end' } -> begin
      match (position_from_proto start', position_from_proto end') with
      | Some start'', Some end'' -> Some (start'', end'')
      | _ -> None
    end
  | _ -> None

let checksum_to_proto :
    Fmlib_parse.Position.range * string -> Traces.checksum option =
 fun (range, checksum) ->
  match range_to_proto range with
  | Some range' ->
      Some { checksum_value = Some checksum; checksum_range = Some range' }
  | None -> None

let checksum_from_proto :
    Traces.checksum -> (Fmlib_parse.Position.range * string) option =
 fun { checksum_value; checksum_range } ->
  match (checksum_value, checksum_range) with
  | Some checksum, Some range -> begin
      match range_from_proto range with
      | Some range' -> Some (range', checksum)
      | None -> None
    end
  | _ -> None

let k_to_proto : BuildCore.Alacarte_3_2_apparatus.K.t -> Traces.key =
  let open BuildCore.Alacarte_3_2_apparatus in
  function
  | { key_datum; debug_reference } -> (
      let debug_reference_range, debug_reference_file_sha256 =
        match debug_reference with
        | None -> (None, None)
        | Some reference ->
            ( range_to_proto reference.reference_range,
              Some reference.reference_file_sha256 )
      in
      match key_datum with
      | ChecksumKey
          {
            checksum_kind = ValuesFileKind;
            checksum_sha256_hex;
            checksum_sha256_base32 = _;
          } ->
          {
            values_canonical_id = None;
            module_version = None;
            package_version = None;
            keykind_slot = [];
            keykind_assetpath = None;
            debug_reference_range;
            debug_reference_file_sha256;
            keykind = Some Traces.Keykind_checksum_valuesfile;
            checksum_sha256 = Some checksum_sha256_hex;
          }
      | PackageKey
          { package_kind = DistributionPackageKind; package_id; package_semver }
        ->
          {
            checksum_sha256 = None;
            values_canonical_id = None;
            module_version = None;
            keykind_slot = [];
            keykind_assetpath = None;
            debug_reference_range;
            debug_reference_file_sha256;
            keykind = Some Traces.Keykind_package_dist;
            package_version =
              package_version_to_proto ~package_id ~package_semver;
          }
      | ModuleKey { module_kind; module_id; module_semver } -> begin
          let module_version =
            module_version_to_proto ~module_id ~module_semver
          in
          match module_kind with
          | UserFormKind { slot } ->
              {
                checksum_sha256 = None;
                values_canonical_id = None;
                package_version = None;
                debug_reference_range;
                debug_reference_file_sha256;
                keykind = Some Traces.Keykind_user_form;
                module_version;
                keykind_slot = object_slot_to_proto slot;
                keykind_assetpath = None;
              }
          | UserBundleKind ->
              {
                checksum_sha256 = None;
                values_canonical_id = None;
                package_version = None;
                debug_reference_range;
                debug_reference_file_sha256;
                keykind = Some Traces.Keykind_user_bundle;
                module_version =
                  module_version_to_proto ~module_id ~module_semver;
                keykind_slot = [];
                keykind_assetpath = None;
              }
          | UserAssetKind { asset_path } ->
              {
                checksum_sha256 = None;
                values_canonical_id = None;
                package_version = None;
                debug_reference_range;
                debug_reference_file_sha256;
                keykind = Some Traces.Keykind_user_asset;
                module_version;
                keykind_slot = [];
                keykind_assetpath = Some asset_path;
              }
        end)

let k_from_proto ~buildlogtrace ~valuestore_get :
    Traces.key ->
    ((unit -> string) * BuildCore.Alacarte_3_2_apparatus.K.t) option
    BuildCore.Alacarte_xpromise_apparatus.Promise.t =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  (* Do not transform the build metadata or do any other aliasing
     from the protobuf ... the traces are the authoritative source! *)
  let apply_aliases = None in
  let g_package_dist package_version post =
    match package_version_from_proto package_version with
    | None -> return None
    | Some (package_id, package_semver) -> begin
        let k =
          K.create_for_distribution ~debug_reference:None ~package_id
            ~package_semver ()
        in
        let* k = post k in
        return @@ Some ((fun () -> K.show k), k)
      end
  in
  let g_user_form keykind_slot module_version post =
    match
      ( object_slot_from_proto (String.concat "." keykind_slot),
        module_version_from_proto module_version )
    with
    | Some slot, Some (module_id, module_semver) ->
        let k =
          K.create_for_form ~apply_aliases ~debug_reference:None ~module_id
            ~module_semver ~slot ()
        in
        let* k = post k in
        return @@ Some ((fun () -> K.show k), k)
    | _ -> return None
  in
  let g_user_bundle module_version post =
    match module_version_from_proto module_version with
    | Some (module_id, module_semver) ->
        let k =
          K.create_for_bundle ~apply_aliases ~debug_reference:None ~module_id
            ~module_semver ()
        in
        let* k = post k in
        return @@ Some ((fun () -> K.show k), k)
    | _ -> return None
  in
  let g_user_asset asset_path module_version post =
    match module_version_from_proto module_version with
    | Some (module_id, module_semver) ->
        let k =
          K.create_for_asset ~apply_aliases ~debug_reference:None ~module_id
            ~module_semver ~asset_path ()
        in
        let* k = post k in
        return @@ Some ((fun () -> K.show k), k)
    | _ -> return None
  in
  let with_debug_reference ~debug_reference_range ~debug_reference_file_sha256
      key =
    match (debug_reference_range, debug_reference_file_sha256) with
    | Some range, Some sha256 -> (
        let* source_file_opt =
          valuestore_get key
            (V.get_source_file_value_id ~source_file_sha256:sha256)
        in
        match (source_file_opt, range_from_proto range) with
        | Some source_file, Some reference_range ->
            if buildlogtrace then
              Printf.eprintf "[buildlog] read source %s\n"
                (Format.asprintf "%a"
                   (MlFront_Thunk.ThunkParsers.Results.pp_range
                      (Some (MlFront_Core.FilePath.to_string source_file)))
                   reference_range);
            let r =
              {
                K.reference_range;
                reference_file_sha256 = sha256;
                reference_transient =
                  Some { reference_file = BuildCore.Io.disk_file source_file };
              }
            in
            return (K.with_debug_reference key r)
        | _ -> return key)
    | _ -> return key
  in
  function
  | { keykind = None; _ } -> return None
  | {
      keykind = Some Keykind_checksum_valuesfile;
      checksum_sha256 = Some values_file_sha256;
      values_canonical_id = _;
      module_version = _;
      package_version = _;
      keykind_slot = _;
      keykind_assetpath = _;
      debug_reference_range;
      debug_reference_file_sha256;
    } -> begin
      match
        K.create_checksum_for_values_file ~debug_reference:None
          ~values_file_sha256 ()
      with
      | Ok k ->
          let* k =
            with_debug_reference ~debug_reference_range
              ~debug_reference_file_sha256 k
          in
          return (Some ((fun () -> K.show k), k))
      | Error _ -> return None
    end
  | { keykind = Some Keykind_checksum_valuesfile; checksum_sha256 = None; _ } ->
      (* A KEYKIND_CHECKSUM_VALUESFILE with no checksum. *)
      return None
  | { keykind = Some Keykind_unspecified; _ } ->
      unimplemented_read "k_from_proto::Keykind_unspecified"
  | {
      keykind = Some Keykind_package_dist;
      checksum_sha256 = _;
      values_canonical_id = _;
      module_version = _;
      keykind_slot = _;
      keykind_assetpath = _;
      debug_reference_range;
      debug_reference_file_sha256;
      package_version = Some package_version;
    } ->
      g_package_dist package_version
        (with_debug_reference ~debug_reference_range
           ~debug_reference_file_sha256)
  | { keykind = Some Keykind_package_dist; package_version = None; _ } ->
      (* A KEYKIND_PACKAGE_DIST with no package_version. *)
      return None
  | {
      keykind = Some Keykind_user_form;
      checksum_sha256 = _;
      values_canonical_id = _;
      module_version = Some module_version;
      package_version = _;
      keykind_slot;
      keykind_assetpath = _;
      debug_reference_range;
      debug_reference_file_sha256;
    } ->
      g_user_form keykind_slot module_version
        (with_debug_reference ~debug_reference_range
           ~debug_reference_file_sha256)
  | {
      keykind = Some Keykind_user_bundle;
      checksum_sha256 = _;
      values_canonical_id = _;
      module_version = Some module_version;
      package_version = _;
      keykind_slot = _;
      keykind_assetpath = _;
      debug_reference_range;
      debug_reference_file_sha256;
    } ->
      g_user_bundle module_version
        (with_debug_reference ~debug_reference_range
           ~debug_reference_file_sha256)
  | {
      keykind = Some Keykind_user_asset;
      checksum_sha256 = _;
      values_canonical_id = _;
      module_version = Some module_version;
      package_version = _;
      keykind_slot = _;
      keykind_assetpath;
      debug_reference_range;
      debug_reference_file_sha256;
    } -> begin
      match keykind_assetpath with
      | None -> unimplemented_read "k_from_proto::Keykind_user_asset"
      | Some p ->
          g_user_asset p module_version
            (with_debug_reference ~debug_reference_range
               ~debug_reference_file_sha256)
    end
  | {
      keykind =
        Some (Keykind_user_form | Keykind_user_bundle | Keykind_user_asset);
      module_version = None;
      _;
    } ->
      (* A KEYKIND_USER_* with no module_version. *)
      return None

let k_kvhash_to_proto (k, kvhash) : Traces.dependency =
  { depkey = Some (k_to_proto k); kvhash = Some kvhash }

let k_kvhash_from_proto ~buildlogtrace ~valuestore_get :
    Traces.dependency ->
    (BuildCore.Alacarte_3_2_apparatus.K.t * _) option
    BuildCore.Alacarte_xpromise_apparatus.Promise.t =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | { depkey = Some depkey; kvhash = Some kvhash } -> begin
      let* depkey_result = k_from_proto ~buildlogtrace ~valuestore_get depkey in
      match (depkey_result, kvhash) with
      | Some (_show, k), _ -> return (Some (k, kvhash))
      | _ -> return None
    end
  | _ -> return None

let v_to_proto : BuildCore.Alacarte_3_2_apparatus.V.t -> Traces.value option =
  function
  | BuildCore.Alacarte_3_2_apparatus.V.ValuesFile
      { value_id; value_sha256; value = Some { valuesfile_canonical_id } } ->
      Some
        {
          valuetype = Some Traces.Valuetype_valuesfile;
          value_id = Some value_id;
          value_sha256 = Some value_sha256;
          valuesfile_canonical_id = Some valuesfile_canonical_id;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          object_id = None;
          object_range = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.ValuesFile _ ->
      unimplemented_write "v_to_proto::ValuesFile"
  | BuildCore.Alacarte_3_2_apparatus.V.Values
      {
        value_id;
        value_sha256;
        value =
          Some
            {
              values_canonical_id;
              values_file_sha256;
              values_file_local;
              values_origin = _;
              values_transient = _;
            };
      } ->
      (* prerr_endline
        ("v_to_proto::Values::"
        ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:()
            values_canonical_id); *)
      Some
        {
          valuetype = Some Traces.Valuetype_values;
          value_id = Some value_id;
          value_sha256 = Some value_sha256;
          values_canonical_id = Some values_canonical_id;
          values_file_sha256 = Some values_file_sha256;
          values_file_local =
            Option.map
              (fun (`Validated v) -> BuildCore.Io.file_origin v)
              values_file_local;
          valuesfile_canonical_id = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          object_id = None;
          object_range = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Values _ ->
      unimplemented_write "v_to_proto::Values"
  | BuildCore.Alacarte_3_2_apparatus.V.Distribution
      {
        distribution_id = package_id, package_semver;
        distribution_json;
        distribution = _;
      } ->
      Some
        {
          valuetype = Some Traces.Valuetype_distribution;
          value_id = None;
          value_sha256 = None;
          dist_id = package_version_to_proto ~package_id ~package_semver;
          dist_json = Some distribution_json;
          valuesfile_canonical_id = None;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          object_id = None;
          object_range = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Form
      { form_values_canonical_id; form_values_file_sha256; form_id } ->
      Some
        {
          valuetype = Some Traces.Valuetype_form;
          value_id = None;
          value_sha256 = None;
          form_values_file_sha256 = Some form_values_file_sha256;
          form_id =
            module_version_to_proto ~module_id:form_id.id
              ~module_semver:form_id.version;
          form_values_canonical_id = Some form_values_canonical_id;
          valuesfile_canonical_id = None;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          object_id = None;
          object_range = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Object
      {
        value_id;
        value_sha256;
        value = Some { object_id; object_range; object_origin = _ };
      } ->
      Some
        {
          valuetype = Some Traces.Valuetype_object;
          value_id = Some value_id;
          value_sha256 = Some value_sha256;
          object_id =
            module_version_to_proto ~module_id:object_id.id
              ~module_semver:object_id.version;
          object_range = range_to_proto object_range;
          valuesfile_canonical_id = None;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Object _ ->
      unimplemented_write "v_to_proto::Object"
  | BuildCore.Alacarte_3_2_apparatus.V.Constant
      { value_id; value_sha256; value = Some { constant_transient = _ } } ->
      Some
        {
          valuetype = Some Traces.Valuetype_constant;
          value_id = Some value_id;
          value_sha256 = Some value_sha256;
          valuesfile_canonical_id = None;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          object_id = None;
          object_range = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Constant _ ->
      unimplemented_write "v_to_proto::Constant"
  | BuildCore.Alacarte_3_2_apparatus.V.Bundle
      {
        value_id;
        value_sha256;
        value =
          Some
            {
              bundle_values_canonical_id;
              bundle_values_file_sha256;
              bundle_id;
              bundle_range;
              bundle_values_file_local;
            };
      } ->
      Some
        {
          valuetype = Some Traces.Valuetype_bundle;
          value_id = Some value_id;
          value_sha256 = Some value_sha256;
          bundle_values_canonical_id = Some bundle_values_canonical_id;
          bundle_values_file_sha256 = Some bundle_values_file_sha256;
          bundle_values_file_local =
            Option.map
              (fun (`Validated v) -> BuildCore.Io.file_origin v)
              bundle_values_file_local;
          bundle_id =
            module_version_to_proto ~module_id:bundle_id.id
              ~module_semver:bundle_id.version;
          bundle_range = range_to_proto bundle_range;
          valuesfile_canonical_id = None;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          object_id = None;
          object_range = None;
          asset_values_file_sha256 = None;
          asset_id = None;
          asset_path = None;
          asset_range = None;
          asset_values_canonical_id = None;
          asset_mirrors = [];
          asset_checksum_sha256 = None;
          asset_checksum_sha1 = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Bundle _ ->
      unimplemented_write "v_to_proto::Bundle"
  | BuildCore.Alacarte_3_2_apparatus.V.Asset
      {
        value_id;
        value_sha256;
        value =
          Some
            {
              asset_values_canonical_id;
              asset_values_file_sha256;
              asset_id;
              asset_path;
              asset_range;
              asset_mirrors;
              asset_checksum;
            };
      } ->
      Some
        {
          valuetype = Some Traces.Valuetype_asset;
          value_id = Some value_id;
          value_sha256 = Some value_sha256;
          asset_values_canonical_id = Some asset_values_canonical_id;
          asset_values_file_sha256 = Some asset_values_file_sha256;
          asset_id =
            module_version_to_proto ~module_id:asset_id.id
              ~module_semver:asset_id.version;
          asset_path = Some asset_path;
          asset_range = range_to_proto asset_range;
          asset_mirrors = fst asset_mirrors :: snd asset_mirrors;
          asset_checksum_sha256 =
            (match asset_checksum with
            | `Sha256 sha256 -> checksum_to_proto sha256
            | _ -> None);
          asset_checksum_sha1 =
            (match asset_checksum with
            | `Sha1 sha1 -> checksum_to_proto sha1
            | _ -> None);
          valuesfile_canonical_id = None;
          values_canonical_id = None;
          values_file_sha256 = None;
          values_file_local = None;
          form_values_file_sha256 = None;
          form_id = None;
          form_values_canonical_id = None;
          object_id = None;
          object_range = None;
          bundle_values_file_sha256 = None;
          bundle_values_file_local = None;
          bundle_id = None;
          bundle_range = None;
          bundle_values_canonical_id = None;
          dist_id = None;
          dist_json = None;
        }
  | BuildCore.Alacarte_3_2_apparatus.V.Asset _ ->
      unimplemented_write "v_to_proto::Asset"
  | BuildCore.Alacarte_3_2_apparatus.V.Input_not_found _ ->
      unimplemented_write "v_to_proto::Input_not_found"
  | BuildCore.Alacarte_3_2_apparatus.V.Failure_is_pending ->
      unimplemented_write "v_to_proto::Failure_is_pending"

module CstIo =
  MlFront_Thunk.ThunkCst.Io (BuildCore.Alacarte_xpromise_apparatus.Promise)

type exists_result = ValueNotNeeded | ValueExists | ValueMissing

let direct_valuesfile_from_proto ~value_existence_check ~key ~value_id
    ~value_sha256 ~valuesfile_canonical_id =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let* exists_result = value_existence_check key value_id in
  match exists_result with
  | ValueMissing -> return None
  | ValueNotNeeded | ValueExists -> begin
      let show = fun () -> "valuesfile" in
      return
        (Some
           ( show,
             ({
                value_id;
                value_sha256;
                value = Some { valuesfile_canonical_id };
              }
               : V.valuesfile V.persistent) ))
    end

let v_valuesfile_from_proto ~value_existence_check key : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  function
  | {
      valuetype = Some Valuetype_valuesfile;
      value_id = Some value_id;
      value_sha256 = Some value_sha256;
      valuesfile_canonical_id = Some valuesfile_canonical_id;
      values_canonical_id = _;
      values_file_sha256 = _;
      values_file_local = _;
      form_values_file_sha256 = _;
      form_id = _;
      form_values_canonical_id = _;
      object_id = _;
      object_range = _;
      bundle_values_file_sha256 = _;
      bundle_values_file_local = _;
      bundle_id = _;
      bundle_range = _;
      bundle_values_canonical_id = _;
      asset_values_file_sha256 = _;
      asset_id = _;
      asset_path = _;
      asset_range = _;
      asset_values_canonical_id = _;
      asset_mirrors = _;
      asset_checksum_sha256 = _;
      asset_checksum_sha1 = _;
      dist_id = _;
      dist_json = _;
    }
    when String.starts_with ~prefix:BuildPaths.prefix_valuesjsonfile value_id
    -> (
      let ( let* ), return =
        BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
      in
      let* show_and_v_opt =
        direct_valuesfile_from_proto ~value_existence_check ~key ~value_id
          ~value_sha256 ~valuesfile_canonical_id
      in
      match show_and_v_opt with
      | None -> return None
      | Some (show, v) -> return (Some (show, V.ValuesFile v)))
  | { value_id; value_sha256; _ } ->
      unimplemented_read
        (Printf.sprintf "v_from_proto::Valuetype_valuesfile::1::%b::%b"
           (value_id <> None) (value_sha256 <> None))

let direct_values_from_proto ~value_id ~value_sha256 ~values_canonical_id
    ~values_file_sha256 ~values_file_local ~values_file values =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let* safe_maybe_local_values_file =
    match values_file_local with
    | None -> return None
    | Some local_path ->
        BuildInstance.ValueStore.safe_local_values_file
          ~values_file_local:local_path ~values_file_sha256
  in
  let value : V.values =
    {
      values_canonical_id;
      values_file_sha256;
      values_file_local = safe_maybe_local_values_file;
      values_origin = None;
      values_transient =
        Some
          {
            values;
            values_file =
              Option.value
                ~default:(BuildCore.Io.disk_file values_file)
                (Option.map
                   (fun (`Validated v) -> v)
                   safe_maybe_local_values_file);
          };
    }
  in
  let show = fun () -> "values " ^ value_id in
  return (Some (show, V.Values { value_id; value_sha256; value = Some value }))

let v_values_from_proto ~parsetrace ~valuestore_get ~valuestore_put
    ~build_pubkey ~build_seckey key : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  let open BuildInstance in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | {
      valuetype = Some Valuetype_values;
      value_id = Some value_id;
      value_sha256 = Some expected_value_sha256;
      valuesfile_canonical_id = _;
      values_canonical_id = Some values_canonical_id;
      values_file_sha256 = Some values_file_sha256;
      values_file_local;
      form_values_file_sha256 = _;
      form_id = _;
      form_values_canonical_id = _;
      object_id = _;
      object_range = _;
      bundle_values_file_sha256 = _;
      bundle_values_file_local = _;
      bundle_id = _;
      bundle_range = _;
      bundle_values_canonical_id = _;
      asset_values_file_sha256 = _;
      asset_id = _;
      asset_path = _;
      asset_range = _;
      asset_values_canonical_id = _;
      asset_mirrors = _;
      asset_checksum_sha256 = _;
      asset_checksum_sha1 = _;
      dist_id = _;
      dist_json = _;
    }
    when String.starts_with ~prefix:BuildPaths.prefix_values value_id -> (
      let* values_opt =
        ValueStore.get_generic_ast0 ~valuestore_get:(valuestore_get key)
          ~build_pubkey ~value_id
          ~unmarshal:(fun bs -> Marshal.from_bytes bs 0)
          ()
      in
      let valuesjsonfile_value_id =
        V.get_valuesjsonfile_value_id ~values_file_sha256
      in
      match values_opt with
      | Some (values, `Sha256 value_sha256)
        when String.equal expected_value_sha256 value_sha256 -> (
          (* We have a validated Values AST [values] *)
          let* valuesfile_opt = valuestore_get key valuesjsonfile_value_id in
          match valuesfile_opt with
          | None -> return None
          | Some values_file ->
              direct_values_from_proto ~value_id ~value_sha256
                ~values_canonical_id ~values_file_sha256 ~values_file_local
                ~values_file values)
      | Some _ ->
          (* mismatch in SHA256 checksums between trace and value store. do not use the value. *)
          return None
      | None ->
          (* value not found, or signed AST is not valid.
             no warning since cache eviction may have been run on value store.
             fallback to parsing values file. *)
          begin
            (* get valuesfile *)
            Assumptions
            .parsed_values_are_reparsed_when_incompatible_with_runtime ();
            let* valuesfile_fp_opt =
              valuestore_get key valuesjsonfile_value_id
            in
            match valuesfile_fp_opt with
            | Some valuesfile_fp ->
                (* parse valuesfile to get values *)
                let valuesfile = BuildCore.Io.disk_file valuesfile_fp in
                let* parsed =
                  CstIo.parse ~downgrade_errors_into_warnings:()
                    (module TraceStoreObserver)
                    valuesfile
                in
                if parsetrace then
                  Printf.eprintf "[parse] %s b/c incompatible ast\n"
                    valuesjsonfile_value_id;
                begin
                  match parsed with
                  | Error _ -> return None
                  | Ok cst ->
                      (* check canonical id again after reparse *)
                      let values_canonical_id' =
                        MlFront_Thunk.ThunkCst.canonical_id cst
                      in
                      if String.equal values_canonical_id values_canonical_id'
                      then
                        match
                          MlFront_Thunk.ThunkAst.parse
                            ~downgrade_errors_into_warnings:()
                            ~origin:(Some (BuildCore.Io.file_origin valuesfile))
                            ~inferred_package_id_or_reason_whynone:
                              (Either.right
                                 "trace store loads do not have implicit \
                                  package ids")
                            (module TraceStoreObserver)
                            cst
                        with
                        | Error _ -> return None
                        | Ok values ->
                            let* _added, (value_sha256, _value_sz) =
                              BuildInstance.ValueStore.add_generic_ast0
                                ~valuestore_put:(valuestore_put key)
                                ~build_seckey ~value_id
                                ~marshalled_ast_bytes:(fun () ->
                                  Marshal.to_bytes values [])
                                ()
                            in
                            direct_values_from_proto ~value_id ~value_sha256
                              ~values_canonical_id ~values_file_sha256
                              ~values_file_local ~values_file:valuesfile_fp
                              values
                      else return None
                end
            | None -> return None
          end)
  | { value_id; values_file_sha256; values_canonical_id; _ } ->
      unimplemented_read
        (Printf.sprintf "v_from_proto::Valuetype_values::1::%b::%b::%b"
           (value_id <> None)
           (values_file_sha256 <> None)
           (values_canonical_id <> None))

let v_form_from_proto : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  let return = BuildCore.Alacarte_xpromise_apparatus.Promise.return in
  function
  | {
      valuetype = Some Valuetype_form;
      value_id = _;
      value_sha256 = _;
      valuesfile_canonical_id = _;
      values_canonical_id = _;
      values_file_sha256 = _;
      values_file_local = _;
      form_id = Some form_id;
      form_values_file_sha256 = Some form_values_file_sha256;
      form_values_canonical_id = Some form_values_canonical_id;
      object_id = _;
      object_range = _;
      bundle_values_file_sha256 = _;
      bundle_values_file_local = _;
      bundle_id = _;
      bundle_range = _;
      bundle_values_canonical_id = _;
      asset_values_file_sha256 = _;
      asset_id = _;
      asset_path = _;
      asset_range = _;
      asset_values_canonical_id = _;
      asset_mirrors = _;
      asset_checksum_sha256 = _;
      asset_checksum_sha1 = _;
      dist_id = _;
      dist_json = _;
    } -> (
      match module_version_from_proto form_id with
      | None ->
          (* value not found. no warning since cache eviction may have
             been run on value store. *)
          return None
      | Some (id, version) ->
          let value : V.form =
            {
              form_values_canonical_id;
              form_values_file_sha256;
              form_id = { id; version };
            }
          in
          let show = fun () -> "form" in
          return (Some (show, V.Form value)))
  | { value_id; form_values_file_sha256; form_id; form_values_canonical_id; _ }
    ->
      unimplemented_read
        (Printf.sprintf "v_from_proto::Valuetype_form::1::%b::%b::%b::%b"
           (value_id <> None)
           (form_values_file_sha256 <> None)
           (form_id <> None)
           (form_values_canonical_id <> None))

let v_bundle_from_proto ~value_existence_check key : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | {
      valuetype = Some Valuetype_bundle;
      value_id = Some value_id;
      value_sha256 = Some value_sha256;
      valuesfile_canonical_id = _;
      values_canonical_id = _;
      values_file_sha256 = _;
      values_file_local = _;
      form_id = _;
      form_values_file_sha256 = _;
      form_values_canonical_id = _;
      object_id = _;
      object_range = _;
      bundle_values_file_sha256 = Some bundle_values_file_sha256;
      bundle_values_file_local = Some bundle_values_file_local;
      bundle_id = Some id;
      bundle_range = Some range;
      bundle_values_canonical_id = Some bundle_values_canonical_id;
      asset_values_file_sha256 = _;
      asset_id = _;
      asset_path = _;
      asset_range = _;
      asset_values_canonical_id = _;
      asset_mirrors = _;
      asset_checksum_sha256 = _;
      asset_checksum_sha1 = _;
      dist_id = _;
      dist_json = _;
    }
    when String.starts_with ~prefix:BuildPaths.prefix_bundle value_id -> (
      match (module_version_from_proto id, range_from_proto range) with
      | Some (id, version), Some bundle_range -> begin
          let* exists_result1 = value_existence_check key value_id in
          let* exists_result2 =
            value_existence_check key
              (V.get_valuesjsonfile_value_id
                 ~values_file_sha256:bundle_values_file_sha256)
          in
          match (exists_result1, exists_result2) with
          | _, ValueMissing | ValueMissing, _ ->
              Assumptions
              .persisted_values_are_checked_for_existence_during_trace_store_load
                ();
              return None
          | (ValueNotNeeded | ValueExists), (ValueNotNeeded | ValueExists) ->
              let* bundle_values_file_local =
                Assumptions.no_trust_for_local_values_file ();
                BuildInstance.ValueStore.safe_local_values_file
                  ~values_file_local:bundle_values_file_local
                  ~values_file_sha256:bundle_values_file_sha256
              in
              let value : V.bundle option =
                Some
                  {
                    bundle_id = { id; version };
                    bundle_values_canonical_id;
                    bundle_values_file_sha256;
                    bundle_range;
                    bundle_values_file_local;
                  }
              in
              let show = fun () -> "bundle " ^ value_id in
              return (Some (show, V.Bundle { value_id; value_sha256; value }))
        end
      | _ -> return None)
  | _ -> unimplemented_read "v_from_proto::Valuetype_bundle"

let v_asset_from_proto ~value_existence_check key : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | {
      valuetype = Some Valuetype_asset;
      value_id = Some value_id;
      value_sha256 = Some value_sha256;
      valuesfile_canonical_id = _;
      values_canonical_id = _;
      values_file_sha256 = _;
      values_file_local = _;
      form_values_file_sha256 = _;
      form_id = _;
      form_values_canonical_id = _;
      object_id = _;
      object_range = _;
      bundle_values_file_sha256 = _;
      bundle_values_file_local = _;
      bundle_id = _;
      bundle_range = _;
      bundle_values_canonical_id = _;
      asset_values_file_sha256 = Some asset_values_file_sha256;
      asset_id = Some id;
      asset_path = Some asset_path;
      asset_range = Some range;
      asset_values_canonical_id = Some asset_values_canonical_id;
      asset_mirrors = first_mirror :: rest_mirrors;
      asset_checksum_sha256;
      asset_checksum_sha1;
      dist_id = _;
      dist_json = _;
    }
    when String.starts_with ~prefix:BuildPaths.prefix_asset value_id -> (
      match (module_version_from_proto id, range_from_proto range) with
      | Some (id, version), Some asset_range ->
          let file_checksum =
            match (asset_checksum_sha256, asset_checksum_sha1) with
            | Some sha256, _ ->
                checksum_from_proto sha256
                |> Option.map (fun sha256 -> `Sha256 sha256)
            | None, Some sha1 ->
                checksum_from_proto sha1 |> Option.map (fun sha1 -> `Sha1 sha1)
            | None, None -> None
          in
          begin
            let* exists_result = value_existence_check key value_id in
            match (exists_result, file_checksum) with
            | ValueMissing, _ | _, None -> return None
            | (ValueNotNeeded | ValueExists), Some file_checksum -> begin
                let value : V.asset option =
                  Some
                    {
                      asset_values_canonical_id;
                      asset_values_file_sha256;
                      asset_id = { id; version };
                      asset_path;
                      asset_range;
                      asset_mirrors = (first_mirror, rest_mirrors);
                      asset_checksum = file_checksum;
                    }
                in
                let show = fun () -> "asset " ^ value_id in
                return (Some (show, V.Asset { value_id; value_sha256; value }))
              end
          end
      | _ -> return None)
  | _ -> unimplemented_read "v_from_proto::Valuetype_asset"

let v_constant_from_proto ~valuestore_get key : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  let open BuildInstance in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | {
      valuetype = Some Valuetype_constant;
      value_id = Some value_id;
      value_sha256 = Some value_sha256;
      valuesfile_canonical_id = _;
      values_canonical_id = _;
      values_file_sha256 = _;
      values_file_local = _;
      form_values_file_sha256 = _;
      form_id = _;
      form_values_canonical_id = _;
      object_id = _;
      object_range = _;
      bundle_values_file_sha256 = _;
      bundle_values_file_local = _;
      bundle_id = _;
      bundle_range = _;
      bundle_values_canonical_id = _;
      asset_values_file_sha256 = _;
      asset_id = _;
      asset_path = _;
      asset_range = _;
      asset_values_canonical_id = _;
      asset_mirrors = _;
      asset_checksum_sha256 = _;
      asset_checksum_sha1 = _;
      dist_id = _;
      dist_json = _;
    }
    when String.starts_with ~prefix:BuildPaths.prefix_constant value_id -> (
      let* constant_opt =
        ValueStore.get_constant0 ~valuestore_get:(valuestore_get key) ~value_id
          ()
      in
      match constant_opt with
      | None ->
          (* value not found. no warning since cache eviction may have
             been run on value store. *)
          return None
      | Some constant_value ->
          let show = fun () -> "constant " ^ value_id in
          return
            (Some
               ( show,
                 V.Constant
                   {
                     value_id;
                     value_sha256;
                     value =
                       Some { constant_transient = Some { constant_value } };
                   } )))
  | _ -> unimplemented_read "v_from_proto::Valuetype_constant"

let v_distribution_from_proto value =
  match (value : Traces.value) with
  | {
   valuetype = _;
   value_id = _;
   value_sha256 = _;
   valuesfile_canonical_id = _;
   values_canonical_id = _;
   values_file_sha256 = _;
   values_file_local = _;
   form_values_file_sha256 = _;
   form_id = _;
   form_values_canonical_id = _;
   object_id = _;
   object_range = _;
   bundle_values_file_sha256 = _;
   bundle_id = _;
   bundle_range = _;
   bundle_values_canonical_id = _;
   bundle_values_file_local = _;
   asset_values_file_sha256 = _;
   asset_id = _;
   asset_path = _;
   asset_range = _;
   asset_values_canonical_id = _;
   asset_mirrors = _;
   asset_checksum_sha256 = _;
   asset_checksum_sha1 = _;
   dist_id = Some dist_id;
   dist_json = Some dist_json;
  } ->
      let open BuildCore.Alacarte_3_2_apparatus in
      let return = BuildCore.Alacarte_xpromise_apparatus.Promise.return in
      begin
        match package_version_from_proto dist_id with
        | None -> return None
        | Some (package_id, package_semver) -> (
            let show = fun () -> "distribution" in
            let jsonfile =
              BuildCore.Io.inmemory_file
                ~origin:
                  (MlFront_Core.FilePath.of_string_exn "/dev/null/tracestore")
                dist_json
            in
            let dist_result =
              BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
              @@ SecDist.DistIo.parse (module TraceStoreObserver) jsonfile
            in
            match dist_result with
            | Error _ -> return None
            | Ok distribution ->
                return
                  (Some
                     ( show,
                       V.Distribution
                         {
                           distribution_id = (package_id, package_semver);
                           distribution_json = dist_json;
                           distribution;
                         } )))
      end
  | _ -> unimplemented_read "v_from_proto::Valuetype_distribution"

let v_object_from_proto ~value_existence_check key : Traces.value -> _ =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | {
      valuetype = Some Valuetype_object;
      value_id = Some value_id;
      value_sha256 = Some value_sha256;
      valuesfile_canonical_id = _;
      values_canonical_id = _;
      values_file_sha256 = _;
      values_file_local = _;
      form_values_file_sha256 = _;
      form_id = _;
      form_values_canonical_id = _;
      object_id = Some id;
      object_range = Some range;
      bundle_values_file_sha256 = _;
      bundle_values_file_local = _;
      bundle_id = _;
      bundle_range = _;
      bundle_values_canonical_id = _;
      asset_values_file_sha256 = _;
      asset_id = _;
      asset_path = _;
      asset_range = _;
      asset_values_canonical_id = _;
      asset_mirrors = _;
      asset_checksum_sha256 = _;
      asset_checksum_sha1 = _;
      dist_id = _;
      dist_json = _;
    }
    when String.starts_with ~prefix:BuildPaths.prefix_object value_id -> (
      match (module_version_from_proto id, range_from_proto range) with
      | Some (id, version), Some object_range -> begin
          let* exists_result = value_existence_check key value_id in
          match exists_result with
          | ValueMissing -> return None
          | ValueNotNeeded | ValueExists ->
              let value : V.object_ option =
                Some
                  {
                    object_id = { id; version };
                    object_range;
                    object_origin = None;
                  }
              in
              let show = fun () -> "object " ^ value_id in
              return (Some (show, V.Object { value_id; value_sha256; value }))
        end
      | _ -> return None)
  | { valuetype = Some Valuetype_object; value_id = Some value_id; _ } ->
      unimplemented_read ("v_from_proto::Valuetype_object::" ^ value_id)
  | _ -> unimplemented_read "v_from_proto::Valuetype_object"

let v_from_proto ~parsetrace ~value_existence_check ~valuestore_get
    ~valuestore_put ~build_pubkey ~build_seckey key value :
    ((unit -> string) * BuildCore.Alacarte_3_2_apparatus.V.t) option
    BuildCore.Alacarte_xpromise_apparatus.Promise.t =
  Assumptions.persisted_values_are_checked_for_existence_during_trace_store_load
    ();
  let return = BuildCore.Alacarte_xpromise_apparatus.Promise.return in
  match (value : Traces.value) with
  | { valuetype = Some Valuetype_valuesfile; _ } ->
      v_valuesfile_from_proto ~value_existence_check key value
  | { valuetype = Some Valuetype_values; _ } ->
      v_values_from_proto ~parsetrace ~valuestore_get ~valuestore_put
        ~build_pubkey ~build_seckey key value
  | { valuetype = Some Valuetype_form; _ } -> v_form_from_proto value
  | { valuetype = Some Valuetype_bundle; _ } ->
      v_bundle_from_proto ~value_existence_check key value
  | { valuetype = Some Valuetype_asset; _ } ->
      v_asset_from_proto ~value_existence_check key value
  | { valuetype = Some Valuetype_constant; _ } ->
      v_constant_from_proto ~valuestore_get key value
  | { valuetype = Some Valuetype_object; _ } ->
      v_object_from_proto ~value_existence_check key value
  | { valuetype = Some Valuetype_distribution; _ } ->
      v_distribution_from_proto value
  | { valuetype = Some Valuetype_unspecified; _ } ->
      unimplemented_read "v_from_proto::Valuetype_unspecified"
  | { valuetype = Some _; _ } -> .
  | _ -> return None

let to_proto :
    BuildCore.Alacarte_6_4_test.StateSuspending.trace ->
    Traces.constructive_trace = function
  | { key; dependencies; result } ->
      {
        key = Some (k_to_proto key);
        dependencies = List.map k_kvhash_to_proto dependencies;
        value = v_to_proto result;
      }

let show_keykind : Traces.key_kind -> string = function
  | Keykind_unspecified -> "unspecified"
  | Keykind_user_form -> "user_form"
  | Keykind_user_bundle -> "user_bundle"
  | Keykind_user_asset -> "user_asset"
  | Keykind_checksum_valuesfile -> "checksum_valuesfile"
  | Keykind_package_dist -> "package_dist"

let show_dependency : Traces.dependency -> string = function
  | {
      depkey =
        Some
          {
            keykind;
            debug_reference_file_sha256 = _;
            checksum_sha256 = _;
            values_canonical_id;
            module_version = _;
            package_version = _;
            keykind_slot = _;
            keykind_assetpath = _;
            debug_reference_range = _;
          };
      kvhash = Some _;
    } ->
      Printf.sprintf "keykind=%s, values_canonical_id=%s"
        (Option.map show_keykind keykind |> Option.value ~default:"(no keykind)")
        (Option.value ~default:"<none>" values_canonical_id)
  | _ -> "(malformed dependency)"

let does_function_change_value ~valuestore_get ~build_pubkey
    ~values_canonical_id k f =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let* values_opt =
    BuildInstance.ValueStore.get_generic_ast0 ~valuestore_get:(valuestore_get k)
      ~build_pubkey
      ~value_id:(V.get_values_value_id ~values_canonical_id)
      ~unmarshal:(fun bs -> Marshal.from_bytes bs 0)
      ()
  in
  begin
    match values_opt with
    | None ->
        (* Can't find the value? Conservatively say it would have been transformed. *)
        return true
    | Some (values, `Sha256 _value_sha256) ->
    match f values with
    | `Unmodified -> return false
    | `Modified _ -> return true
  end

(** Check if a value has been transformed by a function.*)
let is_transformed_value ~valuestore_get ~build_pubkey ~transform_values k v =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  match transform_values with
  | None -> return false
  | Some f -> begin
      match (v : V.t) with
      | V.Values
          {
            value_id = _;
            value_sha256 = _;
            value =
              Some
                {
                  values_canonical_id = _;
                  values_file_sha256 = _;
                  values_file_local = _;
                  values_origin = _;
                  values_transient = Some { values; values_file = _ };
                };
          } -> (
          match f values with
          | `Unmodified -> return false
          | `Modified _ -> return true)
      | V.Bundle
          {
            value_id = _;
            value_sha256 = _;
            value =
              Some
                {
                  bundle_values_canonical_id;
                  bundle_values_file_sha256 = _;
                  bundle_id = _;
                  bundle_range = _;
                  bundle_values_file_local = _;
                };
          } ->
          let* changed =
            does_function_change_value ~valuestore_get ~build_pubkey
              ~values_canonical_id:bundle_values_canonical_id k f
          in
          if changed then return true else return false
      | V.Asset
          {
            value_id = _;
            value_sha256 = _;
            value =
              Some
                {
                  asset_values_canonical_id;
                  asset_values_file_sha256 = _;
                  asset_id = _;
                  asset_path = _;
                  asset_range = _;
                  asset_mirrors = _;
                  asset_checksum = _;
                };
          } ->
          let* changed =
            does_function_change_value ~valuestore_get ~build_pubkey
              ~values_canonical_id:asset_values_canonical_id k f
          in
          if changed then return true else return false
      | _ -> return false
    end

type reader_state = {
  buildlogtrace : bool;
  parsetrace : bool;
  value_existence_check :
    BuildCore.Alacarte_3_2_apparatus.K.t ->
    string ->
    exists_result BuildCore.Alacarte_xpromise_apparatus.Promise.t;
  valuestore_get :
    BuildCore.Alacarte_3_2_apparatus.K.t ->
    string ->
    MlFront_Core.FilePath.t option
    BuildCore.Alacarte_xpromise_apparatus.Promise.t;
  valuestore_put :
    BuildCore.Alacarte_3_2_apparatus.K.t ->
    string ->
    string ->
    (bool * (string * int64)) BuildCore.Alacarte_xpromise_apparatus.Promise.t;
  build_pubkey : [ `PublicKey of string ];
  build_seckey : [ `SecretKey of string ];
  transform_values :
    (MlFront_Thunk.ThunkAst.t ->
    [ `Modified of MlFront_Thunk.ThunkAst.t | `Unmodified ])
    option;
  keys_to_invalidate : (BuildCore.Alacarte_3_2_apparatus.K.t, unit) Hashtbl.t;
}

(** [keys_to_invalidate] is maintained so we can scan over all the traces and
    remove any matching ValuesFile. Confer
    {!Assumptions.cannot_assume_asset_and_assets_come_before_values_files_in_traces}.
*)
let from_proto
    ({
       buildlogtrace;
       parsetrace;
       value_existence_check;
       valuestore_get;
       valuestore_put;
       build_pubkey;
       build_seckey;
       transform_values;
       keys_to_invalidate;
     } :
      reader_state) :
    Traces.constructive_trace ->
    BuildInstance.ValueStore.trace option
    BuildCore.Alacarte_xpromise_apparatus.Promise.t =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  function
  | { key = None; dependencies = _; value = _ } ->
      if buildlogtrace then Printf.eprintf "[buildlog] no key\n";
      return None
  | { key = _; dependencies = _; value = None } ->
      if buildlogtrace then Printf.eprintf "[buildlog] no value\n";
      return None
  | { key = Some key; dependencies; value = Some value } -> (
      let* k_result = k_from_proto ~buildlogtrace ~valuestore_get key in
      match k_result with
      | None ->
          if buildlogtrace then Printf.eprintf "[buildlog] key miss\n";
          return None
      | Some (k_show, k) -> begin
          let maybe_deps_promises =
            List.map
              (k_kvhash_from_proto ~buildlogtrace ~valuestore_get)
              dependencies
          in
          let* maybe_deps =
            BuildCore.Alacarte_xpromise_apparatus.Promise.parallel
              maybe_deps_promises
          in
          let deps' = List.filter_map Fun.id maybe_deps in
          if List.length maybe_deps <> List.length deps' then begin
            (if buildlogtrace then
               let maybe_dep_rows = List.combine dependencies maybe_deps in
               let missing_deps =
                 List.filter_map
                   (fun (dep, dep_result) ->
                     match dep_result with
                     | None -> Some (show_dependency dep)
                     | Some _ -> None)
                   maybe_dep_rows
               in
               Printf.eprintf
                 "[buildlog] miss %s. %d of %d deps found. missing: %s\n"
                 (k_show ()) (List.length deps') (List.length maybe_deps)
                 (String.concat ", " missing_deps));
            return None
          end
          else begin
            (* All the dependencies are present. *)
            let* v_opt =
              v_from_proto ~parsetrace ~value_existence_check ~valuestore_get
                ~valuestore_put ~build_pubkey ~build_seckey k value
            in
            match v_opt with
            | None ->
                if buildlogtrace then
                  Printf.eprintf "[buildlog] value miss %s\n" (k_show ());
                return None
            | Some (v_show, v) ->
                (* Since a transformed trace is not a trace of a successful
                   build, a transformed trace does not belong in the traces! *)
                let* is_transformed =
                  is_transformed_value ~valuestore_get ~build_pubkey
                    ~transform_values k v
                in
                if is_transformed then (
                  Hashtbl.add keys_to_invalidate k ();
                  if buildlogtrace then
                    Printf.eprintf "[buildlog] skip changed %s\n" (k_show ());
                  return None)
                else (
                  if buildlogtrace then
                    Printf.eprintf "[buildlog] read %s %s. %d deps\n"
                      (v_show ()) (k_show ()) (List.length deps');
                  (* if buildlogtrace  then
                    Printf.eprintf "[buildlog] read %s %s. %d deps: %s\n"
                      (v_show ()) (k_show ()) (List.length deps')
                      (String.concat ", "
                         (List.map
                            (fun (k, _kvhash) ->
                              BuildCore.Alacarte_3_2_apparatus.K.show k)
                            deps')); *)
                  return
                    (Some
                       ({ key = k; dependencies = deps'; result = v }
                         : BuildCore.Alacarte_6_4_test.StateSuspending.trace)))
          end
        end)

let max_segment_size = 16777216 (* 16MiB *)
let stop_segment_size = 12582912 (* 12MiB *)

module StringSet = Set.Make (String)
module KeySet = Set.Make (BuildCore.Alacarte_3_2_apparatus.K)

let remove_pending_keys ~buildlogtrace ~keys_to_invalidate traces =
  let open BuildCore.Alacarte_3_2_apparatus in
  let ( let* ) = BuildCore.Alacarte_xpromise_apparatus.Promise.bind in
  let return = BuildCore.Alacarte_xpromise_apparatus.Promise.return in
  (* make ancestor graph from traces *)
  let graph =
    BuildCore.Alacarte_6_4_test.StateSuspending
    .create_ancestorgraph_from_trace_list traces
  in
  (* do a DFS (memory-efficient) on the keys that have to be removed.
     since we have an ancestor graph, DFS will get all the ancestors (consumers)
     of the keys that needed to be removed. *)
  let dfs_iter_once =
    CCGraph.Traverse.dfs ~tbl:(CCGraph.mk_map ~cmp:K.compare ()) ~graph
      (fun f ->
        Hashtbl.iter
          (fun key_to_invalidate () -> f key_to_invalidate)
          keys_to_invalidate)
  in
  (* ... while we build a set from the DFS search *)
  let key_removals = ref KeySet.empty in
  dfs_iter_once (fun transitive_key ->
      (* remove transitive ancestors *)
      key_removals := KeySet.add transitive_key !key_removals);

  (* filter any matching keys from the traces *)
  List.fold_left
    (fun acc
         ({ key; dependencies = _deps; result = _ } as trace :
           BuildInstance.ValueStore.trace) ->
      let* acc = acc in
      if KeySet.mem key !key_removals then (
        if buildlogtrace then
          (* Printf.eprintf "[buildlog] skip backtracked %s. deps: %s\n" (K.show key) (String.concat ", " (List.map (fun (k,_kvhash) -> K.show k) _deps)); *)
          Printf.eprintf "[buildlog] skip backtracked %s\n" (K.show key);
        return acc)
      else return (trace :: acc))
    (return []) traces

let read_segment_exn ~on_fail (reader_state : reader_state) bytes pos len =
  let safe_sub_segment_exn bytes pos len =
    try Bytes.sub bytes pos len
    with Invalid_argument _ -> raise (on_fail "premature end of segment")
  in
  let rec aux acc bytes pos len =
    (* +4 byte BE length *)
    if pos >= len then List.rev acc
    else begin
      (* N byte trace *)
      let tracesz_b = safe_sub_segment_exn bytes pos 4 in
      let tracesz32 = Bytes.get_int32_be tracesz_b 0 in
      if Int64.compare (Int64.of_int32 tracesz32) (Int64.of_int max_int) > 0
      then raise (on_fail "trace segment size too large");
      let tracesz = Int32.to_int tracesz32 in
      let trace_b = safe_sub_segment_exn bytes (pos + 4) tracesz in

      (* Convert to trace *)
      let nextpos = pos + 4 + tracesz in
      let decoder = Pbrt.Decoder.of_bytes trace_b in
      try
        let ctrace = Traces.decode_pb_constructive_trace decoder in
        let trace_promise = from_proto reader_state ctrace in
        let trace_and_sz_promise =
          BuildCore.Alacarte_xpromise_apparatus.Promise.map
            (fun x -> (x, `TraceSize tracesz))
            trace_promise
        in

        (* Continue until done *)
        aux (trace_and_sz_promise :: acc) bytes nextpos len
      with Pbrt.Decoder.Failure _msg -> aux acc bytes nextpos len
    end
  in
  aux [] bytes pos len

let read_exactly : Unix.file_descr -> bytes -> int -> int -> int =
 fun fd buf pos len ->
  let rec aux off total remaining =
    if remaining <= 0 then total
    else
      let got = Unix.read fd buf off remaining in
      if got = 0 then total else aux (off + got) (total + got) (remaining - got)
  in
  aux pos 0 len

let read_segment_frame ~on_finish ~on_fail ~on_more reader_state tracefd =
  (* +4 byte BE length *)
  let segmentsz_b = Bytes.create 4 in
  let was_read = read_exactly tracefd segmentsz_b 0 4 in
  if was_read = 0 then on_finish
  else begin
    if was_read <> 4 then raise (on_fail "failed to read trace size");

    (* 32 byte SHA256(segment) *)
    let segment_cksum_b = Bytes.create 32 in
    let was_read = read_exactly tracefd segment_cksum_b 0 32 in
    if was_read <> 32 then raise (on_fail "failed to read trace checksum");

    (* N byte segment *)
    let segmentsz32 = Bytes.get_int32_be segmentsz_b 0 in
    if Int64.compare (Int64.of_int32 segmentsz32) (Int64.of_int max_int) > 0
    then raise (on_fail "trace size too large");
    let segmentsz = Int32.to_int segmentsz32 in
    let trace_b = Bytes.create segmentsz in
    let was_read = read_exactly tracefd trace_b 0 segmentsz in
    if was_read <> segmentsz then
      raise
        (on_fail
           (Printf.sprintf
              "failed to read trace segment. %d bytes expected, %d bytes read"
              segmentsz was_read));

    (* Verify SHA256 *)
    let segment_cksum =
      String.to_bytes
        (Digestif.SHA256.to_raw_string (Digestif.SHA256.digest_bytes trace_b))
    in
    if not (Bytes.equal segment_cksum segment_cksum_b) then
      raise (on_fail "failed to verify trace segment checksum");

    (* Convert segment to traces *)
    let exception SegmentError of string in
    let moretraces_promises =
      try
        read_segment_exn
          ~on_fail:(fun s -> SegmentError s)
          reader_state trace_b 0 segmentsz
      with SegmentError msg -> raise (on_fail msg)
    in

    on_more (moretraces_promises, `SegmentSize segmentsz)
  end

let rec read_traces_into_list ~on_fail reader_state tracefd =
  let ( let* ), return =
    BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
  in
  let rec aux_partial_traces_exn acc =
    let* acc = acc in

    match
      read_segment_frame
        ~on_finish:(`Finished (return acc))
        ~on_fail:(on_fail acc)
        ~on_more:(fun ps -> `More ps)
        reader_state tracefd
    with
    | `Finished res -> res
    | `More (moretraces_promises, `SegmentSize _) ->
        (* run the conversion in parallel *)
        let* moretraces =
          BuildCore.Alacarte_xpromise_apparatus.Promise.parallel
            moretraces_promises
        in
        aux_partial_traces_exn (return (moretraces :: acc))
  in
  let* traces = aux_partial_traces_exn (return []) in
  from_option_list_list traces

and from_option_list_list :
    (BuildInstance.ValueStore.trace option * [ `TraceSize of int ]) list list ->
    BuildInstance.ValueStore.trace option list
    MlFront_Thunk.Promises.PromiseMinimal.t =
  let return = BuildCore.Alacarte_xpromise_apparatus.Promise.return in
  fun x -> return (List.map fst (List.flatten (List.rev x)))

let rec read_traces_gracefully ~preconfig ~transform_values tracefd =
  let buildlogtrace = BuildConfig.preconfig_buildlogtrace preconfig in
  let parsetrace = BuildConfig.preconfig_parsetrace preconfig in
  let valuestore = BuildConfig.preconfig_valuestore preconfig in
  let build_pubkey = BuildConfig.preconfig_build_pubkey preconfig in
  let build_seckey = BuildConfig.preconfig_build_seckey preconfig in

  (* Position 0. *)
  let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_SET in

  (* Interpret framing *)
  let keys_to_invalidate = Hashtbl.create 16 in

  (* Abstract value type *)
  let valuestore_get _key value_id =
    BuildInstance.ValueStore.get_value_file ~valuestore ~value_id ()
  in
  let valuestore_put _key value_id contents =
    BuildInstance.ValueStore.put_value_file ~valuestore ~value_id contents
  in
  let value_existence_check =
    let ( let* ), return =
      BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
    in
    match BuildConfig.preconfig_integrity preconfig with
    | `Existence -> (
        fun key value_id ->
          Assumptions
          .persisted_values_are_checked_for_existence_during_trace_store_load ();
          let* value_fp_opt = valuestore_get key value_id in
          match value_fp_opt with
          | None -> return ValueMissing
          | Some _value_fp -> return ValueExists)
    | `Checksum | `None -> fun _key _value_id -> return ValueNotNeeded
  in

  let reader_state : reader_state =
    {
      buildlogtrace;
      parsetrace;
      value_existence_check;
      valuestore_get;
      valuestore_put;
      build_pubkey;
      build_seckey;
      transform_values;
      keys_to_invalidate;
    }
  in

  let exception
    PartialTraces of
      (string
      * BuildInstance.ValueStore.trace option list
        MlFront_Thunk.Promises.PromiseMinimal.t)
  in
  match
    read_traces_into_list
      ~on_fail:(fun acc s -> PartialTraces (s, from_option_list_list acc))
      reader_state tracefd
  with
  | traces -> load_traces ~buildlogtrace ~keys_to_invalidate traces
  | exception PartialTraces (msg, traces) ->
      Printf.eprintf "[buildlog] [warning] failed to read all traces: %s\n" msg;
      load_traces ~buildlogtrace ~keys_to_invalidate traces

and load_traces ~buildlogtrace ~keys_to_invalidate traces =
  let traces' = BuildInstance.Launcher.run_isolated_promise traces in
  let traces' = List.filter_map Fun.id traces' in
  if Hashtbl.length keys_to_invalidate = 0 then traces'
  else
    BuildInstance.Launcher.run_isolated_promise
      (remove_pending_keys ~buildlogtrace ~keys_to_invalidate traces')

let visit_traces_in_file ~build_pubkey ~build_seckey ~valuestore_get
    ~valuestore_put tracefd visit_trace =
  let value_existence_check key value_id =
    let ( let* ), return =
      BuildCore.Alacarte_xpromise_apparatus.Promise.(bind, return)
    in
    let* value_fp_opt = valuestore_get key value_id in
    match value_fp_opt with
    | None -> return ValueMissing
    | Some _value_fp -> return ValueExists
  in
  let reader_state : reader_state =
    {
      buildlogtrace = false;
      parsetrace = false;
      value_existence_check;
      valuestore_get;
      valuestore_put;
      build_pubkey;
      build_seckey;
      transform_values = None;
      keys_to_invalidate = Hashtbl.create 0;
    }
  in
  let exception FailedRead of string in
  let rec aux_partial_traces_exn () =
    match
      read_segment_frame ~on_finish:(`Finished ())
        ~on_fail:(fun s -> FailedRead s)
        ~on_more:(fun ps -> `More ps)
        reader_state tracefd
    with
    | `Finished () -> ()
    | `More (moretraces_promises, `SegmentSize _) ->
        (* run the conversion in parallel *)
        let moretraces =
          BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
          @@ BuildCore.Alacarte_xpromise_apparatus.Promise.parallel
               moretraces_promises
        in
        List.iter
          (fun (trace, `TraceSize sz) ->
            match trace with
            | None -> ()
            | Some
                ({ key; dependencies; result } : BuildInstance.ValueStore.trace)
              ->
                visit_trace sz key dependencies result)
          moretraces;
        aux_partial_traces_exn ()
  in
  aux_partial_traces_exn ()

let save ~config traces tracefd =
  let buildlogtrace = BuildConfig.buildlogtrace config in
  let dtraces_promise =
    BuildInstance.ValueStore.dehydrate_traces
      ?buildlogtrace:(if buildlogtrace then Some () else None)
      ~valuestore:(BuildConfig.valuestore config)
      ~build_seckey:(BuildConfig.build_seckey config)
      traces
  in
  let dtraces = BuildInstance.Launcher.run_isolated_promise dtraces_promise in
  let exception CouldNotTrace of string in
  (* Position 0. *)
  let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_SET in
  let write _what buf pos len =
    let ret = Unix.write tracefd buf pos len in
    (* let pos = Unix.lseek tracefd 0 Unix.SEEK_CUR in
    if buildlogtrace then
      Printf.eprintf "[buildlog] wrote %s %d bytes. %d added\n" what pos ret; *)
    ret
  in
  try
    let buf = Buffer.create max_segment_size in
    let encoder = Pbrt.Encoder.create () in
    let flush_buffer len =
      let seg_b = Buffer.to_bytes buf in
      let segsz = Bytes.length seg_b in
      if segsz = 0 then len
      else begin
        (* 4 byte BE length *)
        if segsz > max_segment_size then
          raise (CouldNotTrace "Trace segment too large");
        let segsz_b = Bytes.create 4 in
        Bytes.set_int32_be segsz_b 0 (Int32.of_int segsz);
        let was_written = write "header" segsz_b 0 4 in
        if was_written <> 4 then
          raise (CouldNotTrace "Failed to write trace segment header");

        (* 32 byte SHA256(segment) *)
        let seg_cksum =
          Digestif.SHA256.to_raw_string (Digestif.SHA256.digest_bytes seg_b)
        in
        let was_written = write "checksum" (String.to_bytes seg_cksum) 0 32 in
        if was_written <> 32 then
          raise (CouldNotTrace "Failed to write trace segment checksum");

        (* N byte segment *)
        let was_written = write "segment" seg_b 0 segsz in
        if was_written <> segsz then
          raise (CouldNotTrace "Failed to write trace segment data");

        (* clear *)
        Buffer.clear buf;

        (* reset encoder to release its memory (unlike Encoder.clear),
         especially after a large encoding per its ocamldoc. *)
        Pbrt.Encoder.reset encoder;

        (* return new length of trace file. check for overflow *)
        let len' = len + 4 + 32 + segsz in
        if len' < 0 then raise (CouldNotTrace "Trace file length overflow");
        len'
      end
    in
    let add_buffer len trace =
      let trace' = to_proto trace in
      Pbrt.Encoder.clear encoder;
      Traces.encode_pb_constructive_trace trace' encoder;
      let bs = Pbrt.Encoder.to_bytes encoder in
      let bs_sz = Bytes.length bs in

      (* flush if needed; calculate new length of trace file.
         check for overflow. *)
      let len' =
        if len + Buffer.length buf > stop_segment_size then flush_buffer len
        else len
      in
      if len' < 0 then raise (CouldNotTrace "Trace file length overflow");

      (* 4 byte BE length *)
      Buffer.add_int32_be buf (Int32.of_int bs_sz);
      (* N byte trace *)
      Buffer.add_bytes buf bs;

      (* new length of trace file (if any) *)
      len'
    in
    let rec aux len = function
      | [] -> len
      | trace :: rest ->
          let len' = add_buffer len trace in
          aux len' rest
    in
    let newlen = aux 0 dtraces in
    (* if buildlogtrace then
      Printf.eprintf "[buildlog] after aux 0 = %d bytes\n" newlen; *)
    let newlen = flush_buffer newlen in
    (* if buildlogtrace then
      Printf.eprintf "[buildlog] after flush_buffer = %d bytes\n" newlen; *)

    (* Done *)
    if buildlogtrace then
      Printf.eprintf "[buildlog] trace store - %d bytes\n" newlen;
    Unix.ftruncate tracefd newlen;
    Unix.close tracefd
  with CouldNotTrace msg ->
    prerr_endline ("[warning] " ^ msg);
    Unix.close tracefd

let get_apply_aliases ~config =
  let open BuildInstance.Syntax in
  let* state = get in
  Assumptions
  .both_tracestore_and_lockfiles_resolve_build_metadata_for_user_module_keys ();
  return
    (BuildCore.Alacarte_6_4_test.StateSuspending.apply_aliases
       ~build_number:(BuildConfig.build_number config)
       state)