Source file BuildTraceStore.ml

module TraceStoreObserver =
  MlFront_Thunk.ThunkParsers.Results.MakeObserverWithErrorReporter

type value_exists = ValueNotNeeded | ValueExists | ValueMissing

module Problem = struct
  type t =
    | NoScriptFileForChunk of {
        chunk_modver : MlFront_Thunk.ThunkCommand.module_version;
        expected_valuesluafile_value_id : string;
      }
    | NoTraceStoreCorrespondenceInValueStore of {
        key : string;
        value_id : string option;
      }
    | UnimplementedOperation of string

  let show = function
    | NoScriptFileForChunk { chunk_modver; expected_valuesluafile_value_id } ->
        Printf.sprintf
          "no script file found for chunk %s; expected Lua file with value id \
           `%s`"
          (MlFront_Thunk.ThunkCommand.show_module_version chunk_modver)
          expected_valuesluafile_value_id
    | NoTraceStoreCorrespondenceInValueStore { key; value_id } ->
        Printf.sprintf
          "missing correspondence for trace store key `%s`: value %s" key
          (match value_id with
          | Some vid -> Printf.sprintf "`%s` missing in value store" vid
          | None -> "has no value id")
    | UnimplementedOperation operation ->
        Printf.sprintf "unimplemented operation `%s`" operation

  let is_missing_script_file_for_chunk = function
    | NoScriptFileForChunk _ -> true
    | NoTraceStoreCorrespondenceInValueStore _ | UnimplementedOperation _ ->
        false
end

module KVTrace = struct
  type t = {
    key_id : string;
    key_description : string;
    num_dependenices : int;
    tracesz : int;
    value_trace : Messages_.Reader.Value.t;
  }

  let create ~key_id ~key_description ~num_dependenices ~tracesz ~value_trace =
    { key_id; key_description; num_dependenices; tracesz; value_trace }

  let compare (a : t) (b : t) = String.compare a.key_id b.key_id
  let key_id (t : t) = t.key_id
  let key_description (t : t) = t.key_description
  let num_dependencies (t : t) = t.num_dependenices
  let tracesz (t : t) = t.tracesz
  let value_trace (t : t) = t.value_trace
end

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 parse_segment_frame_exn ~on_finish ~on_fail ~on_more tracefd f =
  (* +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");

    (* y = f(segment). Example: y = traces *)
    let y = f trace_b 0 segmentsz in
    on_more (y, `SegmentSize segmentsz)
  end

let parse_segment_exn ~on_fail bytes pos len f =
  if pos < 0 || len < 0 || pos > Bytes.length bytes - len then
    raise (on_fail "invalid trace segment bounds")
  else
    match Messages_.deserialize_message bytes pos len with
    | Error msg -> raise (on_fail ("failed to parse trace segment: " ^ msg))
    | Ok msg ->
        let ctrace = Messages_.Reader.ConstructiveTrace.of_message msg in
        [ f ~tracesz32:(Int32.of_int len) ~tracesz:len ctrace ]

module Make (Ctx : BuildContext.S) = struct
  module BuildTrace' = BuildTrace.Make (Ctx)
  module BuildValues' = BuildValues.Make (Ctx)
  module SecDist' = SecDist.Make (Ctx)

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

  let unimplemented_write operation =
    raise
      (Exceptions.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 :
      Messages_.Reader.PackageVersion.t 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 } ) ->
        let pv = Messages_.Builder.PackageVersion.init_root () in
        let pi = Messages_.Builder.PackageVersion.package_id_init pv in
        Messages_.Builder.PackageId.vendor_set pi
          (MlFront_Core.LibraryId.vendor library_id);
        Messages_.Builder.PackageId.qualifier_set pi
          (MlFront_Core.LibraryId.qualifier library_id);
        Messages_.Builder.PackageId.unit_set pi
          (MlFront_Core.LibraryId.unit library_id);
        ignore (Messages_.Builder.PackageId.namespace_set_list pi namespace);
        let sv = Messages_.Builder.PackageVersion.package_semver_init pv in
        Messages_.Builder.Semver.major_set sv major;
        Messages_.Builder.Semver.minor_set sv minor;
        Messages_.Builder.Semver.patch_set sv patch;
        ignore (Messages_.Builder.Semver.prerelease_set_list sv prerelease);
        ignore (Messages_.Builder.Semver.build_set_list sv build);
        Some (Messages_.Builder.PackageVersion.to_reader pv)

  let module_version_to_proto ~module_id ~module_semver :
      Messages_.Reader.ModuleVersion.t =
    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 } ) ->
        let mv = Messages_.Builder.ModuleVersion.init_root () in
        let mi = Messages_.Builder.ModuleVersion.module_id_init mv in
        Messages_.Builder.StandardModuleId.vendor_set mi
          (MlFront_Core.LibraryId.vendor library_id);
        Messages_.Builder.StandardModuleId.qualifier_set mi
          (MlFront_Core.LibraryId.qualifier library_id);
        Messages_.Builder.StandardModuleId.unit_set mi
          (MlFront_Core.LibraryId.unit library_id);
        ignore
          (Messages_.Builder.StandardModuleId.namespace_front_set_list mi
             namespace_front);
        Messages_.Builder.StandardModuleId.namespace_tail_set mi namespace_tail;
        let sv = Messages_.Builder.ModuleVersion.module_semver_init mv in
        Messages_.Builder.Semver.major_set sv major;
        Messages_.Builder.Semver.minor_set sv minor;
        Messages_.Builder.Semver.patch_set sv patch;
        ignore (Messages_.Builder.Semver.prerelease_set_list sv prerelease);
        ignore (Messages_.Builder.Semver.build_set_list sv build);
        Messages_.Builder.ModuleVersion.to_reader mv

  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 (pv : Messages_.Reader.PackageVersion.t) :
      (MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t) option =
    if
      Messages_.Reader.PackageVersion.has_package_id pv
      && Messages_.Reader.PackageVersion.has_package_semver pv
    then
      let pi = Messages_.Reader.PackageVersion.package_id_get pv in
      let sv = Messages_.Reader.PackageVersion.package_semver_get pv in
      let vendor =
        if Messages_.Reader.PackageId.has_vendor pi then
          Some (Messages_.Reader.PackageId.vendor_get pi)
        else None
      in
      let qualifier =
        if Messages_.Reader.PackageId.has_qualifier pi then
          Some (Messages_.Reader.PackageId.qualifier_get pi)
        else None
      in
      let unit_ =
        if Messages_.Reader.PackageId.has_unit pi then
          Some (Messages_.Reader.PackageId.unit_get pi)
        else None
      in
      let namespace = Messages_.Reader.PackageId.namespace_get_list pi in
      let major = Messages_.Reader.Semver.major_get sv in
      let minor = Messages_.Reader.Semver.minor_get sv in
      let patch = Messages_.Reader.Semver.patch_get sv in
      let prerelease = Messages_.Reader.Semver.prerelease_get_list sv in
      let build = Messages_.Reader.Semver.build_get_list sv in
      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:(Some major) ~minor:(Some minor)
                ~patch:(Some patch) ~prerelease ~build
            with
            | Some package_semver -> Some (package_id, package_semver)
            | None -> None)
      end
    else None

  let module_version_from_proto (mv : Messages_.Reader.ModuleVersion.t) :
      (MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t) option =
    if
      Messages_.Reader.ModuleVersion.has_module_id mv
      && Messages_.Reader.ModuleVersion.has_module_semver mv
    then
      let mi = Messages_.Reader.ModuleVersion.module_id_get mv in
      let sv = Messages_.Reader.ModuleVersion.module_semver_get mv in
      let vendor =
        if Messages_.Reader.StandardModuleId.has_vendor mi then
          Some (Messages_.Reader.StandardModuleId.vendor_get mi)
        else None
      in
      let qualifier =
        if Messages_.Reader.StandardModuleId.has_qualifier mi then
          Some (Messages_.Reader.StandardModuleId.qualifier_get mi)
        else None
      in
      let unit_ =
        if Messages_.Reader.StandardModuleId.has_unit mi then
          Some (Messages_.Reader.StandardModuleId.unit_get mi)
        else None
      in
      let namespace_front =
        Messages_.Reader.StandardModuleId.namespace_front_get_list mi
      in
      if Messages_.Reader.StandardModuleId.has_namespace_tail mi then
        let namespace_tail =
          Messages_.Reader.StandardModuleId.namespace_tail_get mi
        in
        let major = Messages_.Reader.Semver.major_get sv in
        let minor = Messages_.Reader.Semver.minor_get sv in
        let patch = Messages_.Reader.Semver.patch_get sv in
        let prerelease = Messages_.Reader.Semver.prerelease_get_list sv in
        let build = Messages_.Reader.Semver.build_get_list sv in
        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:(Some major) ~minor:(Some minor)
                  ~patch:(Some patch) ~prerelease ~build
              with
              | Some module_semver -> Some (module_id, module_semver)
              | None -> None)
        end
      else None
    else None

  let object_slot_to_proto slot =
    MlFront_Thunk.ThunkObjectSlot.as_stringlist slot

  let object_slot_from_proto slot =
    match slot with
    | [] -> None
    | _ -> MlFront_Thunk.ThunkObjectSlot.of_stringlist slot

  let show_value_trace (value : Messages_.Reader.Value.t) =
    let value_id_opt =
      if Messages_.Reader.Value.has_value_id value then
        Some (Messages_.Reader.Value.value_id_get value)
      else None
    in
    let show_value_id make = Option.map make value_id_opt in
    let show_unloaded prefix =
      show_value_id (fun value_id ->
          DataValueTerse.unloaded ~kind:prefix ~value_id)
    in
    match Messages_.Reader.Value.valuetype_get value with
    | Messages_.Reader.ValueType.Valuesjsonfile ->
        show_value_id (fun value_id -> DataValueTerse.valuesjsonfile ~value_id)
    | Messages_.Reader.ValueType.Valuesluafile ->
        show_value_id (fun value_id -> DataValueTerse.valuesluafile ~value_id)
    | Messages_.Reader.ValueType.Scriptmodule ->
        if Messages_.Reader.Value.has_scriptmodule_id value then
          module_version_from_proto
            (Messages_.Reader.Value.scriptmodule_id_get value)
          |> Option.map (fun (module_id, module_semver) ->
                 DataValueTerse.scriptmodule
                   ~module_version:{ id = module_id; version = module_semver })
        else None
    | Messages_.Reader.ValueType.Distribution ->
        if Messages_.Reader.Value.has_dist_id value then
          package_version_from_proto (Messages_.Reader.Value.dist_id_get value)
          |> Option.map (fun (package_id, package_semver) ->
                 DataValueTerse.distribution ~package_id ~package_semver)
        else None
    | Messages_.Reader.ValueType.Form ->
        if Messages_.Reader.Value.has_form_id value then
          module_version_from_proto (Messages_.Reader.Value.form_id_get value)
          |> Option.map (fun (module_id, module_semver) ->
                 DataValueTerse.form
                   ~module_version:{ id = module_id; version = module_semver })
        else None
    | Messages_.Reader.ValueType.Bundle ->
        if Messages_.Reader.Value.has_bundle_modver value then
          match
            module_version_from_proto
              (Messages_.Reader.Value.bundle_modver_get value)
          with
          | Some (module_id, module_semver) ->
              show_value_id (fun value_id ->
                  DataValueTerse.bundle ~value_id
                    ~module_version:{ id = module_id; version = module_semver })
          | None -> show_unloaded "bundle:"
        else show_unloaded "bundle:"
    | Messages_.Reader.ValueType.Asset ->
        if
          Messages_.Reader.Value.has_asset_id value
          && Messages_.Reader.Value.has_asset_path value
        then
          match
            module_version_from_proto
              (Messages_.Reader.Value.asset_id_get value)
          with
          | Some (module_id, module_semver) ->
              Some
                (DataValueTerse.asset
                   ~module_version:{ id = module_id; version = module_semver }
                   ~asset_path:(Messages_.Reader.Value.asset_path_get value))
          | None -> show_unloaded "asset:"
        else show_unloaded "asset:"
    | Messages_.Reader.ValueType.Assetindex ->
        if
          Messages_.Reader.Value.has_assetindex_modver value
          && Messages_.Reader.Value.has_assetindex_path value
        then
          match
            module_version_from_proto
              (Messages_.Reader.Value.assetindex_modver_get value)
          with
          | Some (module_id, module_semver) ->
              Some
                (DataValueTerse.asset_index
                   ~module_version:{ id = module_id; version = module_semver }
                   ~asset_path:
                     (Messages_.Reader.Value.assetindex_path_get value))
          | None -> show_unloaded "assetindex:"
        else show_unloaded "assetindex:"
    | Messages_.Reader.ValueType.Object ->
        if
          Messages_.Reader.Value.has_object_id value
          && Messages_.Reader.Value.has_object_slot value
        then
          match
            ( module_version_from_proto
                (Messages_.Reader.Value.object_id_get value),
              object_slot_from_proto
                (Messages_.Reader.Value.object_slot_get_list value) )
          with
          | Some (module_id, module_semver), Some object_slot ->
              show_value_id (fun value_id ->
                  DataValueTerse.object_ ~value_id ~object_slot
                    ~module_version:{ id = module_id; version = module_semver })
          | _ -> show_unloaded "object:"
        else show_unloaded "object:"
    | Messages_.Reader.ValueType.Constant -> show_unloaded "constant"
    | Messages_.Reader.ValueType.Unspecified
    | Messages_.Reader.ValueType.Undefined _ ->
        None

  let position_to_proto :
      Fmlib_parse.Position.t -> Messages_.Reader.Position.t option =
    let open Fmlib_parse 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
      let pb = Messages_.Builder.Position.init_root () in
      Messages_.Builder.Position.line_set_int_exn pb line;
      Messages_.Builder.Position.byte_bol_set_int_exn pb byte_bol;
      Messages_.Builder.Position.byte_col_set_int_exn pb byte_col;
      Messages_.Builder.Position.correction_set_int_exn pb correction;
      Some (Messages_.Builder.Position.to_reader pb)

  let position_from_proto (pos : Messages_.Reader.Position.t) :
      Fmlib_parse.Position.t option =
    let line = Messages_.Reader.Position.line_get_int_exn pos in
    let byte_bol = Messages_.Reader.Position.byte_bol_get_int_exn pos in
    let byte_col = Messages_.Reader.Position.byte_col_get_int_exn pos in
    let correction = Messages_.Reader.Position.correction_get_int_exn pos in
    let p =
      Fmlib_parse.Position.make line (byte_col + correction) byte_bol byte_col
    in
    Some p

  let range_to_proto :
      Fmlib_parse.Position.range -> Messages_.Reader.Range.t option = function
    | start, end_ ->
    match (position_to_proto start, position_to_proto end_) with
    | Some start', Some end' ->
        let rb = Messages_.Builder.Range.init_root () in
        ignore (Messages_.Builder.Range.start_set_reader rb start');
        ignore (Messages_.Builder.Range.end_set_reader rb end');
        Some (Messages_.Builder.Range.to_reader rb)
    | _ -> None

  let range_from_proto (range : Messages_.Reader.Range.t) :
      Fmlib_parse.Position.range option =
    if
      Messages_.Reader.Range.has_start range
      && Messages_.Reader.Range.has_end range
    then
      let start' = Messages_.Reader.Range.start_get range in
      let end' = Messages_.Reader.Range.end_get range in
      match (position_from_proto start', position_from_proto end') with
      | Some start'', Some end'' -> Some (start'', end'')
      | _ -> None
    else None

  let checksum_to_proto :
      Fmlib_parse.Position.range * string -> Messages_.Reader.Checksum.t option
      =
   fun (range, checksum) ->
    match range_to_proto range with
    | Some range' ->
        let cb = Messages_.Builder.Checksum.init_root () in
        Messages_.Builder.Checksum.checksum_value_set cb checksum;
        ignore (Messages_.Builder.Checksum.checksum_range_set_reader cb range');
        Some (Messages_.Builder.Checksum.to_reader cb)
    | None -> None

  let checksum_from_proto (cksum : Messages_.Reader.Checksum.t) :
      (Fmlib_parse.Position.range * string) option =
    if
      Messages_.Reader.Checksum.has_checksum_value cksum
      && Messages_.Reader.Checksum.has_checksum_range cksum
    then
      let checksum = Messages_.Reader.Checksum.checksum_value_get cksum in
      let range = Messages_.Reader.Checksum.checksum_range_get cksum in
      match range_from_proto range with
      | Some range' -> Some (range', checksum)
      | None -> None
    else None

  let valuesfiletype_to_proto = function
    | `Json -> Messages_.Reader.ValuesFileType.Json
    | `Lua -> Messages_.Reader.ValuesFileType.Lua

  let valuesfiletype_from_proto :
      Messages_.Reader.ValuesFileType.t -> [ `Json | `Lua ] option = function
    | Json -> Some `Json
    | Lua -> Some `Lua
    | Unspecified | Undefined _ -> None

  let k_to_proto : Ctx.K.t -> Messages_.Reader.Key.t option = function
    | { key_datum; debug_reference } -> (
        let set_debug_reference kb =
          match debug_reference with
          | None -> ()
          | Some reference ->
              (match range_to_proto reference.reference_range with
              | Some r ->
                  ignore
                    (Messages_.Builder.Key.debug_reference_range_set_reader kb r)
              | None -> ());
              Messages_.Builder.Key.debug_reference_file_sha256_set kb
                reference.reference_file_sha256
        in
        match key_datum with
        | FailureIsPending _ -> None
        | ChecksumKey
            {
              checksum_kind = ValuesJsonFileKind;
              checksum_sha256_hex;
              checksum_sha256_base32 = _;
            } ->
            let kb = Messages_.Builder.Key.init_root () in
            Messages_.Builder.Key.keykind_set kb
              Messages_.Builder.KeyKind.ChecksumValuesjsonfile;
            Messages_.Builder.Key.checksum_sha256_set kb checksum_sha256_hex;
            set_debug_reference kb;
            Some (Messages_.Builder.Key.to_reader kb)
        | ChecksumKey
            {
              checksum_kind = ValuesLuaFileKind;
              checksum_sha256_hex;
              checksum_sha256_base32 = _;
            } ->
            let kb = Messages_.Builder.Key.init_root () in
            Messages_.Builder.Key.keykind_set kb
              Messages_.Builder.KeyKind.ChecksumValuesluafile;
            Messages_.Builder.Key.checksum_sha256_set kb checksum_sha256_hex;
            set_debug_reference kb;
            Some (Messages_.Builder.Key.to_reader kb)
        | PackageKey
            {
              package_kind = DistributionPackageKind;
              package_id;
              package_semver;
            } ->
            let kb = Messages_.Builder.Key.init_root () in
            Messages_.Builder.Key.keykind_set kb
              Messages_.Builder.KeyKind.PackageDist;
            (match package_version_to_proto ~package_id ~package_semver with
            | Some pv ->
                ignore (Messages_.Builder.Key.package_version_set_reader kb pv)
            | None -> ());
            set_debug_reference kb;
            Some (Messages_.Builder.Key.to_reader kb)
        | ModuleKey { module_kind; module_id; module_semver } -> begin
            let module_version =
              module_version_to_proto ~module_id ~module_semver
            in
            let kb = Messages_.Builder.Key.init_root () in
            ignore
              (Messages_.Builder.Key.module_version_set_reader kb module_version);
            set_debug_reference kb;
            match module_kind with
            | UserObjectKind { slot } ->
                Messages_.Builder.Key.keykind_set kb
                  Messages_.Builder.KeyKind.UserObject;
                ignore
                  (Messages_.Builder.Key.keykind_slot_set_list kb
                     (object_slot_to_proto slot));
                Some (Messages_.Builder.Key.to_reader kb)
            | UserBundleKind ->
                Messages_.Builder.Key.keykind_set kb
                  Messages_.Builder.KeyKind.UserBundle;
                Some (Messages_.Builder.Key.to_reader kb)
            | UserAssetKind { asset_path } ->
                Messages_.Builder.Key.keykind_set kb
                  Messages_.Builder.KeyKind.UserAsset;
                Messages_.Builder.Key.keykind_assetpath_set kb asset_path;
                Some (Messages_.Builder.Key.to_reader kb)
            | UserScriptModuleKind ->
                Messages_.Builder.Key.keykind_set kb
                  Messages_.Builder.KeyKind.UserScriptmodule;
                Some (Messages_.Builder.Key.to_reader kb)
            | UserRuleKind
                { user_request_value = _; user_request_json; user_request_slot }
              ->
                let rule_user_request_json =
                  MlFront_Thunk.ThunkJsonRep.to_string user_request_json
                in
                let rule_user_request_slot =
                  match user_request_slot with
                  | None -> []
                  | Some s -> object_slot_to_proto s
                in
                Messages_.Builder.Key.keykind_set kb
                  Messages_.Builder.KeyKind.UserRule;
                Messages_.Builder.Key.rule_user_request_json_set kb
                  rule_user_request_json;
                ignore
                  (Messages_.Builder.Key.rule_user_request_slot_set_list kb
                     rule_user_request_slot);
                Some (Messages_.Builder.Key.to_reader kb)
            | IndexAssetKind { asset_path; index_type } ->
                Messages_.Builder.Key.keykind_set kb
                  Messages_.Builder.KeyKind.IndexAsset;
                Messages_.Builder.Key.keykind_assetpath_set kb asset_path;
                Messages_.Builder.Key.keykind_indextype_set kb
                  (match index_type with
                  | `Zip -> Messages_.Builder.IndexType.Zip);
                Some (Messages_.Builder.Key.to_reader kb)
          end)

  module IdentityMonad = struct
    type 'a t = 'a

    let bind x f = f x
    let return x = x
  end

  module MakeKeyProto (M : sig
    type 'a t

    val bind : 'a t -> ('a -> 'b t) -> 'b t
    val return : 'a -> 'a t
  end) =
  struct
    let ( let* ) = M.bind
    let return = M.return

    let k_from_proto ~on_problem ~buildlogtrace ~debug_reference_valuestore_get
        : Messages_.Reader.Key.t -> ((unit -> string) * Ctx.K.t) option M.t =
      (* 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 =
              Ctx.K.create_for_distribution ~debug_reference:None ~package_id
                ~package_semver ()
            in
            let* k = post k in
            return @@ Some ((fun () -> Ctx.K.show k), k)
          end
      in
      let g_user_form keykind_slot module_version post =
        match
          ( object_slot_from_proto keykind_slot,
            module_version_from_proto module_version )
        with
        | Some slot, Some (module_id, module_semver) ->
            let k =
              Ctx.K.create_for_object ~apply_aliases ~debug_reference:None
                ~module_id ~module_semver ~slot ()
            in
            let* k = post k in
            return @@ Some ((fun () -> Ctx.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 =
              Ctx.K.create_for_bundle ~apply_aliases ~debug_reference:None
                ~module_id ~module_semver ()
            in
            let* k = post k in
            return @@ Some ((fun () -> Ctx.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 =
              Ctx.K.create_for_asset ~apply_aliases ~debug_reference:None
                ~module_id ~module_semver ~asset_path ()
            in
            let* k = post k in
            return @@ Some ((fun () -> Ctx.K.show k), k)
        | _ -> return None
      in
      let g_index_asset asset_path index_type module_version post =
        match module_version_from_proto module_version with
        | Some (module_id, module_semver) -> begin
            match index_type with
            | Messages_.Reader.IndexType.Zip ->
                let k =
                  Ctx.K.create_for_asset_index ~apply_aliases
                    ~debug_reference:None ~module_id ~module_semver ~asset_path
                    ~index_type:`Zip ()
                in
                let* k = post k in
                return @@ Some ((fun () -> Ctx.K.show k), k)
            | _ -> return None
          end
        | _ -> return None
      in
      let g_user_scriptmodule module_version post =
        match module_version_from_proto module_version with
        | Some (module_id, module_semver) ->
            let k =
              Ctx.K.create_for_scriptmodule ~debug_reference:None ~module_id
                ~module_semver ()
            in
            let* k = post k in
            return @@ Some ((fun () -> Ctx.K.show k), k)
        | _ -> return None
      in
      let g_user_rule module_version post user_request_slot user_request_json =
        match module_version_from_proto module_version with
        | Some (module_id, module_semver) -> begin
            match
              MlFront_Thunk.ThunkLuaScript.user_request_value user_request_json
            with
            | Error _ -> return None
            | Ok user_request_value ->
                let k =
                  Ctx.K.create_for_rule ~apply_aliases ~debug_reference:None
                    ~module_id ~module_semver ~user_request_json
                    ~user_request_value ~user_request_slot ()
                in
                let* k = post k in
                return @@ Some ((fun () -> Ctx.K.show k), k)
          end
        | _ -> return None
      in
      let with_debug_reference key ~has_range ~get_range ~has_sha256 ~get_sha256
          =
        match (has_range, has_sha256) with
        | true, true -> (
            let range = get_range () in
            let sha256 = get_sha256 () in
            let* source_file_opt =
              debug_reference_valuestore_get key
                (Ctx.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
                  log_debug (fun l ->
                      l "[buildlog] read source %s"
                        (Format.asprintf "%a"
                           (MlFront_Thunk.ThunkRanges.pp_range
                              (Some
                                 (MlFront_Core.FilePath.to_string source_file)))
                           reference_range));
                let r =
                  {
                    Ctx.K.reference_range;
                    reference_file_sha256 = sha256;
                    reference_transient =
                      Some { reference_file = Ctx.disk_file source_file };
                  }
                in
                return (Ctx.K.with_debug_reference key r)
            | _ -> return key)
        | _ -> return key
      in
      let with_debug_ref k key =
        with_debug_reference key
          ~has_range:(Messages_.Reader.Key.has_debug_reference_range k)
          ~get_range:(fun () ->
            Messages_.Reader.Key.debug_reference_range_get k)
          ~has_sha256:(Messages_.Reader.Key.has_debug_reference_file_sha256 k)
          ~get_sha256:(fun () ->
            Messages_.Reader.Key.debug_reference_file_sha256_get k)
      in
      fun k ->
        match Messages_.Reader.Key.keykind_get k with
        | Messages_.Reader.KeyKind.ChecksumValuesjsonfile -> begin
            if Messages_.Reader.Key.has_checksum_sha256 k then
              let values_file_sha256 =
                Messages_.Reader.Key.checksum_sha256_get k
              in
              match
                Ctx.K.create_checksum_for_valuesjson_file ~debug_reference:None
                  ~values_file_sha256 ()
              with
              | Ok key ->
                  let* key = with_debug_ref k key in
                  return (Some ((fun () -> Ctx.K.show key), key))
              | Error _ -> return None
            else return None
          end
        | Messages_.Reader.KeyKind.ChecksumValuesluafile -> begin
            if Messages_.Reader.Key.has_checksum_sha256 k then
              let values_file_sha256 =
                Messages_.Reader.Key.checksum_sha256_get k
              in
              match
                Ctx.K.create_checksum_for_valueslua_file ~debug_reference:None
                  ~values_file_sha256 ()
              with
              | Ok key ->
                  let* key = with_debug_ref k key in
                  return (Some ((fun () -> Ctx.K.show key), key))
              | Error _ -> return None
            else return None
          end
        | Messages_.Reader.KeyKind.Unspecified ->
            on_problem
              (Problem.UnimplementedOperation
                 "k_from_proto::Keykind_unspecified");
            return None
        | Messages_.Reader.KeyKind.PackageDist ->
            if Messages_.Reader.Key.has_package_version k then
              g_package_dist
                (Messages_.Reader.Key.package_version_get k)
                (with_debug_ref k)
            else
              (* A KEYKIND_PACKAGE_DIST with no package_version. *)
              return None
        | Messages_.Reader.KeyKind.UserObject ->
            if Messages_.Reader.Key.has_module_version k then
              g_user_form
                (Messages_.Reader.Key.keykind_slot_get_list k)
                (Messages_.Reader.Key.module_version_get k)
                (with_debug_ref k)
            else return None
        | Messages_.Reader.KeyKind.UserBundle ->
            if Messages_.Reader.Key.has_module_version k then
              g_user_bundle
                (Messages_.Reader.Key.module_version_get k)
                (with_debug_ref k)
            else return None
        | Messages_.Reader.KeyKind.UserAsset -> begin
            if
              Messages_.Reader.Key.has_module_version k
              && Messages_.Reader.Key.has_keykind_assetpath k
            then
              g_user_asset
                (Messages_.Reader.Key.keykind_assetpath_get k)
                (Messages_.Reader.Key.module_version_get k)
                (with_debug_ref k)
            else begin
              if not (Messages_.Reader.Key.has_keykind_assetpath k) then
                on_problem
                  (Problem.UnimplementedOperation
                     "k_from_proto::Keykind_user_asset");
              return None
            end
          end
        | Messages_.Reader.KeyKind.IndexAsset -> begin
            if
              Messages_.Reader.Key.has_module_version k
              && Messages_.Reader.Key.has_keykind_assetpath k
            then
              g_index_asset
                (Messages_.Reader.Key.keykind_assetpath_get k)
                (Messages_.Reader.Key.keykind_indextype_get k)
                (Messages_.Reader.Key.module_version_get k)
                (with_debug_ref k)
            else begin
              if not (Messages_.Reader.Key.has_keykind_assetpath k) then
                on_problem
                  (Problem.UnimplementedOperation
                     "k_from_proto::Keykind_index_asset");
              return None
            end
          end
        | Messages_.Reader.KeyKind.UserScriptmodule ->
            if Messages_.Reader.Key.has_module_version k then
              g_user_scriptmodule
                (Messages_.Reader.Key.module_version_get k)
                (with_debug_ref k)
            else return None
        | Messages_.Reader.KeyKind.UserRule -> begin
            if Messages_.Reader.Key.has_module_version k then begin
              let module_version = Messages_.Reader.Key.module_version_get k in
              let g =
                g_user_rule module_version (with_debug_ref k)
                  (object_slot_from_proto
                     (Messages_.Reader.Key.rule_user_request_slot_get_list k))
              in
              if Messages_.Reader.Key.has_rule_user_request_json k then begin
                let json_s =
                  Messages_.Reader.Key.rule_user_request_json_get k
                in
                let json_opt = MlFront_Thunk.ThunkJson.of_string json_s in
                match json_opt with
                | None -> return None
                | Some rule_user_request_json -> g rule_user_request_json
              end
              else
                (* an empty rule_user_request_json is the JSON object {} *)
                g (`Assoc [])
            end
            else return None
          end
        | Messages_.Reader.KeyKind.Undefined _ -> return None

    let k_kvhash_from_proto ~on_problem ~buildlogtrace
        ~debug_reference_valuestore_get :
        Messages_.Reader.Dependency.t -> (Ctx.K.t * _) option M.t =
     fun dep ->
      if
        Messages_.Reader.Dependency.has_depkey dep
        && Messages_.Reader.Dependency.has_kvhash dep
      then begin
        let depkey = Messages_.Reader.Dependency.depkey_get dep in
        let kvhash = Messages_.Reader.Dependency.kvhash_get dep in
        let* depkey_result =
          k_from_proto ~on_problem ~buildlogtrace
            ~debug_reference_valuestore_get depkey
        in
        match depkey_result with
        | Some (_show, k) -> return (Some (k, kvhash))
        | _ -> return None
      end
      else return None

    let kvtrace_valueid_pair_of_proto_trace ~on_problem ~tracesz :
        Messages_.Reader.ConstructiveTrace.t ->
        (Ctx.K.t * KVTrace.t * [ `ValueId of string option ]) option M.t =
     fun trace ->
      if not (Messages_.Reader.ConstructiveTrace.has_key trace) then
        (* no key *)
        return None
      else if not (Messages_.Reader.ConstructiveTrace.has_value trace) then
        (* no value *)
        return None
      else
        let k = Messages_.Reader.ConstructiveTrace.key_get trace in
        let value_trace = Messages_.Reader.ConstructiveTrace.value_get trace in
        let dependencies =
          Messages_.Reader.ConstructiveTrace.dependencies_get_list trace
        in
        let value_id =
          if Messages_.Reader.Value.has_value_id value_trace then
            Some (Messages_.Reader.Value.value_id_get value_trace)
          else None
        in
        let* k_opt =
          k_from_proto ~on_problem ~buildlogtrace:false
            ~debug_reference_valuestore_get:(fun _ _ -> return None)
            k
        in
        match k_opt with
        | None -> return None
        | Some (k_show, k) ->
            let key_id = Ctx.K.id k in
            let key_description = k_show () in
            let kvtrace =
              KVTrace.create ~key_id ~key_description
                ~num_dependenices:(List.length dependencies) ~tracesz
                ~value_trace
            in
            return (Some (k, kvtrace, `ValueId value_id))
  end

  let k_kvhash_to_proto (k, kvhash) : Messages_.Reader.Dependency.t option =
    match k_to_proto k with
    | None -> None
    | Some proto_of_k ->
        let db = Messages_.Builder.Dependency.init_root () in
        ignore (Messages_.Builder.Dependency.depkey_set_reader db proto_of_k);
        Messages_.Builder.Dependency.kvhash_set db kvhash;
        Some (Messages_.Builder.Dependency.to_reader db)

  let v_to_proto : Ctx.V.t -> Messages_.Reader.Value.t option =
    let mk_value () = Messages_.Builder.Value.init_root () in
    let finish vb = Some (Messages_.Builder.Value.to_reader vb) in
    function
    | ValuesJsonFile
        { value_id; value_sha256; value = Some { valuesjsonfile_canonical_id } }
      ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Valuesjsonfile;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        Messages_.Builder.Value.valuesjsonfile_canonical_id_set vb
          valuesjsonfile_canonical_id;
        finish vb
    | ValuesJsonFile _ -> unimplemented_write "v_to_proto::ValuesJsonFile"
    | ValuesLuaFile
        { value_id; value_sha256; value = Some { valuesluafile_canonical_id } }
      ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Valuesluafile;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        Messages_.Builder.Value.valuesluafile_canonical_id_set vb
          valuesluafile_canonical_id;
        finish vb
    | ValuesLuaFile _ -> unimplemented_write "v_to_proto::ValuesLuaFile"
    | Values _ -> unimplemented_write "v_to_proto::Values"
    | Distribution
        {
          distribution_id = package_id, package_semver;
          distribution_values_file_sha256;
          distribution_json;
          distribution = _;
        } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Distribution;
        (match package_version_to_proto ~package_id ~package_semver with
        | Some pv -> ignore (Messages_.Builder.Value.dist_id_set_reader vb pv)
        | None -> ());
        Messages_.Builder.Value.dist_json_set vb distribution_json;
        Messages_.Builder.Value.dist_values_file_sha256_set vb
          distribution_values_file_sha256;
        finish vb
    | Form { form_values_canonical_id; form_values_file_sha256; form_id } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Form;
        Messages_.Builder.Value.form_values_file_sha256_set vb
          form_values_file_sha256;
        ignore
          (Messages_.Builder.Value.form_id_set_reader vb
             (module_version_to_proto ~module_id:form_id.id
                ~module_semver:form_id.version));
        Messages_.Builder.Value.form_values_canonical_id_set vb
          form_values_canonical_id;
        finish vb
    | ScriptModule
        {
          scriptmodule_values_file_sha256;
          scriptmodule_id;
          scriptmodule_range;
          scriptmodule_values_canonical_id;
          scriptmodule_file = _;
        } ->
        Assumptions.hostscript_filepath_not_saved_in_trace_or_valuestore ();
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Scriptmodule;
        ignore
          (Messages_.Builder.Value.scriptmodule_id_set_reader vb
             (module_version_to_proto ~module_id:scriptmodule_id.id
                ~module_semver:scriptmodule_id.version));
        Messages_.Builder.Value.scriptmodule_values_file_sha256_set vb
          scriptmodule_values_file_sha256;
        (match range_to_proto scriptmodule_range with
        | Some r ->
            ignore (Messages_.Builder.Value.scriptmodule_range_set_reader vb r)
        | None -> ());
        Messages_.Builder.Value.scriptmodule_values_canonical_id_set vb
          scriptmodule_values_canonical_id;
        finish vb
    | Object
        {
          value_id;
          value_sha256;
          value =
            Some { object_id; object_slot; object_range; object_origin = _ };
        } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Object;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        ignore
          (Messages_.Builder.Value.object_id_set_reader vb
             (module_version_to_proto ~module_id:object_id.id
                ~module_semver:object_id.version));
        ignore
          (Messages_.Builder.Value.object_slot_set_list vb
             (object_slot_to_proto object_slot));
        (match range_to_proto object_range with
        | Some r ->
            ignore (Messages_.Builder.Value.object_range_set_reader vb r)
        | None -> ());
        finish vb
    | Object _ -> unimplemented_write "v_to_proto::Object"
    | Constant
        { value_id; value_sha256; value = Some { constant_transient = _ } } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Constant;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        finish vb
    | Constant _ -> unimplemented_write "v_to_proto::Constant"
    | Bundle
        {
          value_id;
          value_sha256;
          value =
            Some
              {
                bundle_values_canonical_id;
                bundle_values_file_sha256;
                bundle_modver;
                bundle_range;
                bundle_values_file_local;
              };
        } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Bundle;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        Messages_.Builder.Value.bundle_values_canonical_id_set vb
          bundle_values_canonical_id;
        Messages_.Builder.Value.bundle_values_file_sha256_set vb
          bundle_values_file_sha256;
        (match bundle_values_file_local with
        | Some (`Validated v) ->
            Messages_.Builder.Value.bundle_values_file_local_set vb
              (Ctx.Io.file_origin v)
        | None -> ());
        ignore
          (Messages_.Builder.Value.bundle_modver_set_reader vb
             (module_version_to_proto ~module_id:bundle_modver.id
                ~module_semver:bundle_modver.version));
        (match range_to_proto bundle_range with
        | Some r ->
            ignore (Messages_.Builder.Value.bundle_range_set_reader vb r)
        | None -> ());
        finish vb
    | Bundle _ -> unimplemented_write "v_to_proto::Bundle"
    | Asset
        {
          value_id;
          value_sha256;
          value =
            Some
              {
                asset_values_canonical_id;
                asset_values_file_type;
                asset_values_file_sha256;
                asset_id;
                asset_path;
                asset_range;
                asset_origin_name;
                asset_mirrors;
                asset_checksum;
              };
        } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Asset;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        Messages_.Builder.Value.asset_values_canonical_id_set vb
          asset_values_canonical_id;
        Messages_.Builder.Value.asset_values_file_type_set vb
          (valuesfiletype_to_proto asset_values_file_type);
        Messages_.Builder.Value.asset_values_file_sha256_set vb
          asset_values_file_sha256;
        ignore
          (Messages_.Builder.Value.asset_id_set_reader vb
             (module_version_to_proto ~module_id:asset_id.id
                ~module_semver:asset_id.version));
        Messages_.Builder.Value.asset_path_set vb asset_path;
        (match range_to_proto asset_range with
        | Some r -> ignore (Messages_.Builder.Value.asset_range_set_reader vb r)
        | None -> ());
        Messages_.Builder.Value.asset_origin_name_set vb asset_origin_name;
        ignore
          (Messages_.Builder.Value.asset_mirrors_set_list vb
             (fst asset_mirrors :: snd asset_mirrors));
        (match asset_checksum with
        | `SHA256 sha256 -> (
            match checksum_to_proto sha256 with
            | Some c ->
                ignore
                  (Messages_.Builder.Value.asset_checksum_sha256_set_reader vb c)
            | None -> ())
        | `SHA1 sha1 -> (
            match checksum_to_proto sha1 with
            | Some c ->
                ignore
                  (Messages_.Builder.Value.asset_checksum_sha1_set_reader vb c)
            | None -> ())
        | `BLAKE2b_256 blake2b256 ->
        match checksum_to_proto blake2b256 with
        | Some c ->
            ignore
              (Messages_.Builder.Value.asset_checksum_blake2b256_set_reader vb c)
        | None -> ());
        finish vb
    | Asset _ -> unimplemented_write "v_to_proto::Asset"
    | AssetIndex
        {
          value_id;
          value_sha256;
          value =
            Some
              {
                asset_index_values_canonical_id;
                asset_index_values_file_type;
                asset_index_values_file_sha256;
                asset_index_modver;
                asset_index_path;
                asset_index_type = `Zip;
                asset_index_range;
                asset_index_checksum;
              };
        } ->
        let vb = mk_value () in
        Messages_.Builder.Value.valuetype_set vb
          Messages_.Builder.ValueType.Assetindex;
        Messages_.Builder.Value.value_id_set vb value_id;
        Messages_.Builder.Value.value_sha256_set vb value_sha256;
        Messages_.Builder.Value.assetindex_values_file_type_set vb
          (valuesfiletype_to_proto asset_index_values_file_type);
        Messages_.Builder.Value.assetindex_values_file_sha256_set vb
          asset_index_values_file_sha256;
        ignore
          (Messages_.Builder.Value.assetindex_modver_set_reader vb
             (module_version_to_proto ~module_id:asset_index_modver.id
                ~module_semver:asset_index_modver.version));
        Messages_.Builder.Value.assetindex_path_set vb asset_index_path;
        (match range_to_proto asset_index_range with
        | Some r ->
            ignore (Messages_.Builder.Value.assetindex_range_set_reader vb r)
        | None -> ());
        Messages_.Builder.Value.assetindex_values_canonical_id_set vb
          asset_index_values_canonical_id;
        (match asset_index_checksum with
        | `BLAKE2b_256 blake2b256 -> (
            match checksum_to_proto blake2b256 with
            | Some c ->
                ignore
                  (Messages_.Builder.Value
                   .assetindex_checksum_blake2b256_set_reader vb c)
            | None -> ())
        | _ -> .);
        Messages_.Builder.Value.assetindex_type_set vb
          Messages_.Builder.IndexType.Zip;
        finish vb
    | AssetIndex _ -> unimplemented_write "v_to_proto::AssetIndex"
    | Input_not_found _ -> unimplemented_write "v_to_proto::Input_not_found"
    | Failure_is_pending -> unimplemented_write "v_to_proto::Failure_is_pending"
    | Ephemeral_ui_response ->
        unimplemented_write "v_to_proto::Ephemeral_ui_response"

  module CstIo = MlFront_Thunk.ThunkCst.Io (Ctx.Promise)

  let direct_valuesfile_from_proto ~show ~construct ~value_existence_check ~key
      ~value_id ~value_sha256 ~valuesfile_canonical_id =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let* exists_result = value_existence_check key value_id in
    match exists_result with
    | ValueMissing -> return None
    | ValueNotNeeded | ValueExists -> begin
        return
          (Some
             (show, construct ~value_id ~value_sha256 ~valuesfile_canonical_id))
      end

  let direct_valuesjsonfile_from_proto =
    let show () = "valuesjsonfile" in
    direct_valuesfile_from_proto ~show
      ~construct:(fun ~value_id ~value_sha256 ~valuesfile_canonical_id ->
        ({
           value_id;
           value_sha256;
           value =
             Some { valuesjsonfile_canonical_id = valuesfile_canonical_id };
         }
          : Ctx.V.valuesjsonfile Ctx.V.persistent))

  let direct_valuesluafile_from_proto =
    let show () = "valuesluafile" in
    direct_valuesfile_from_proto ~show
      ~construct:(fun ~value_id ~value_sha256 ~valuesfile_canonical_id ->
        ({
           value_id;
           value_sha256;
           value = Some { valuesluafile_canonical_id = valuesfile_canonical_id };
         }
          : Ctx.V.valuesluafile Ctx.V.persistent))

  let v_valuesjsonfile_from_proto ~on_problem ~value_existence_check key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
        && Messages_.Reader.Value.has_valuesjsonfile_canonical_id value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        let valuesfile_canonical_id =
          Messages_.Reader.Value.valuesjsonfile_canonical_id_get value
        in
        if String.starts_with ~prefix:Paths.prefix_valuesjsonfile value_id then begin
          let* show_and_v_opt =
            direct_valuesjsonfile_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, Ctx.V.ValuesJsonFile v))
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation
               (Printf.sprintf "v_valuesjsonfile_from_proto::1::true::true"));
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation
             (Printf.sprintf "v_valuesjsonfile_from_proto::1::%b::%b"
                (Messages_.Reader.Value.has_value_id value)
                (Messages_.Reader.Value.has_value_sha256 value)));
        return None
      end

  let v_valuesluafile_from_proto ~on_problem ~value_existence_check key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
        && Messages_.Reader.Value.has_valuesluafile_canonical_id value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        let valuesfile_canonical_id =
          Messages_.Reader.Value.valuesluafile_canonical_id_get value
        in
        if String.starts_with ~prefix:Paths.prefix_valuesluafile value_id then begin
          let* show_and_v_opt =
            direct_valuesluafile_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, Ctx.V.ValuesLuaFile v))
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation
               (Printf.sprintf "v_valuesluafile_from_proto::1::true::true"));
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation
             (Printf.sprintf "v_valuesluafile_from_proto::1::%b::%b"
                (Messages_.Reader.Value.has_value_id value)
                (Messages_.Reader.Value.has_value_sha256 value)));
        return None
      end

  let v_scriptmodule_from_proto ~on_problem ~valuestore_get :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_scriptmodule_id value
        && Messages_.Reader.Value.has_scriptmodule_values_file_sha256 value
        && Messages_.Reader.Value.has_scriptmodule_range value
        && Messages_.Reader.Value.has_scriptmodule_values_canonical_id value
      then
        let scriptmodule_id =
          Messages_.Reader.Value.scriptmodule_id_get value
        in
        let scriptmodule_values_file_sha256 =
          Messages_.Reader.Value.scriptmodule_values_file_sha256_get value
        in
        let scriptmodule_range =
          Messages_.Reader.Value.scriptmodule_range_get value
        in
        let scriptmodule_values_canonical_id =
          Messages_.Reader.Value.scriptmodule_values_canonical_id_get value
        in
        begin
          match
            ( Ctx.K.create_checksum_for_valueslua_file ~debug_reference:None
                ~values_file_sha256:scriptmodule_values_file_sha256 (),
              module_version_from_proto scriptmodule_id,
              range_from_proto scriptmodule_range )
          with
          | Ok k_checksum, Some (id, version), Some scriptmodule_range ->
              let* script_file_opt =
                valuestore_get k_checksum
                  (Ctx.V.get_valuesluafile_value_id
                     ~values_file_sha256:scriptmodule_values_file_sha256)
              in
              begin
                let chunk_modver : MlFront_Thunk.ThunkCommand.module_version =
                  { id; version }
                in
                match script_file_opt with
                | None ->
                    on_problem
                      (Problem.NoScriptFileForChunk
                         {
                           chunk_modver;
                           expected_valuesluafile_value_id =
                             Ctx.V.get_valuesluafile_value_id
                               ~values_file_sha256:
                                 scriptmodule_values_file_sha256;
                         });
                    return None
                | Some scriptmodule_file ->
                    let value : Ctx.V.scriptmodule =
                      {
                        scriptmodule_values_canonical_id;
                        scriptmodule_values_file_sha256;
                        scriptmodule_id = chunk_modver;
                        scriptmodule_range;
                        scriptmodule_file = Ctx.disk_file scriptmodule_file;
                      }
                    in
                    let show = fun () -> "chunk" in
                    return (Some (show, Ctx.V.ScriptModule value))
              end
          | _ -> return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation
             (Printf.sprintf
                "v_from_proto::VALUETYPE_CHUNK::1::%b::%b::%b::%b::%b"
                (Messages_.Reader.Value.has_value_id value)
                (Messages_.Reader.Value.has_scriptmodule_values_file_sha256
                   value)
                (Messages_.Reader.Value.has_scriptmodule_id value)
                (Messages_.Reader.Value.has_scriptmodule_range value)
                (Messages_.Reader.Value.has_scriptmodule_values_canonical_id
                   value)));
        return None
      end

  let v_form_from_proto ~on_problem : Messages_.Reader.Value.t -> _ =
    let return = Ctx.Promise.return in
    fun value ->
      if
        Messages_.Reader.Value.has_form_id value
        && Messages_.Reader.Value.has_form_values_file_sha256 value
        && Messages_.Reader.Value.has_form_values_canonical_id value
      then
        let form_id = Messages_.Reader.Value.form_id_get value in
        let form_values_file_sha256 =
          Messages_.Reader.Value.form_values_file_sha256_get value
        in
        let form_values_canonical_id =
          Messages_.Reader.Value.form_values_canonical_id_get value
        in
        begin
          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 : Ctx.V.form =
                {
                  form_values_canonical_id;
                  form_values_file_sha256;
                  form_id = { id; version };
                }
              in
              let show = fun () -> "form" in
              return (Some (show, Ctx.V.Form value))
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation
             (Printf.sprintf "v_from_proto::Valuetype_form::1::%b::%b::%b::%b"
                (Messages_.Reader.Value.has_value_id value)
                (Messages_.Reader.Value.has_form_values_file_sha256 value)
                (Messages_.Reader.Value.has_form_id value)
                (Messages_.Reader.Value.has_form_values_canonical_id value)));
        return None
      end

  let v_bundle_from_proto ~on_problem ~value_existence_check key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
        && Messages_.Reader.Value.has_bundle_values_file_sha256 value
        && Messages_.Reader.Value.has_bundle_modver value
        && Messages_.Reader.Value.has_bundle_range value
        && Messages_.Reader.Value.has_bundle_values_canonical_id value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        let bundle_values_file_sha256 =
          Messages_.Reader.Value.bundle_values_file_sha256_get value
        in
        let bundle_values_file_local =
          if Messages_.Reader.Value.has_bundle_values_file_local value then
            Some (Messages_.Reader.Value.bundle_values_file_local_get value)
          else None
        in
        let id = Messages_.Reader.Value.bundle_modver_get value in
        let range = Messages_.Reader.Value.bundle_range_get value in
        let bundle_values_canonical_id =
          Messages_.Reader.Value.bundle_values_canonical_id_get value
        in
        if String.starts_with ~prefix:Paths.prefix_bundle value_id then begin
          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
                  (Ctx.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 =
                    match bundle_values_file_local with
                    | None -> return None
                    | Some values_file_local ->
                        Assumptions.no_trust_for_local_values_file ();
                        BuildValues'.safe_local_values_file ~values_file_local
                          ~values_file_sha256:bundle_values_file_sha256
                  in
                  let value : Ctx.V.bundle option =
                    Some
                      {
                        bundle_modver = { 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, Ctx.V.Bundle { value_id; value_sha256; value }))
            end
          | _ -> return None
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation
               (Printf.sprintf
                  "v_from_proto::Valuetype_bundle::1::true::true::true::true::true::true::true::true"));
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation
             (Printf.sprintf
                "v_from_proto::Valuetype_bundle::1::true::%b::%b::%b::%b::%b::%b::%b"
                (Messages_.Reader.Value.has_value_id value)
                (Messages_.Reader.Value.has_value_sha256 value)
                (Messages_.Reader.Value.has_bundle_values_file_sha256 value)
                (Messages_.Reader.Value.has_bundle_values_file_local value)
                (Messages_.Reader.Value.has_bundle_modver value)
                (Messages_.Reader.Value.has_bundle_range value)
                (Messages_.Reader.Value.has_bundle_values_canonical_id value)));
        return None
      end

  let v_asset_from_proto ~on_problem ~value_existence_check key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
        && Messages_.Reader.Value.has_asset_values_file_sha256 value
        && Messages_.Reader.Value.has_asset_id value
        && Messages_.Reader.Value.has_asset_path value
        && Messages_.Reader.Value.has_asset_range value
        && Messages_.Reader.Value.has_asset_values_canonical_id value
        && Messages_.Reader.Value.has_asset_mirrors value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        let asset_values_file_type =
          Messages_.Reader.Value.asset_values_file_type_get value
        in
        let asset_values_file_sha256 =
          Messages_.Reader.Value.asset_values_file_sha256_get value
        in
        let id = Messages_.Reader.Value.asset_id_get value in
        let asset_path = Messages_.Reader.Value.asset_path_get value in
        let range = Messages_.Reader.Value.asset_range_get value in
        let asset_values_canonical_id =
          Messages_.Reader.Value.asset_values_canonical_id_get value
        in
        let asset_origin_name =
          if Messages_.Reader.Value.has_asset_origin_name value then
            Messages_.Reader.Value.asset_origin_name_get value
          else ""
        in
        let mirrors = Messages_.Reader.Value.asset_mirrors_get_list value in
        if String.starts_with ~prefix:Paths.prefix_asset value_id then begin
          match mirrors with
          | first_mirror :: rest_mirrors -> begin
              match
                ( module_version_from_proto id,
                  range_from_proto range,
                  valuesfiletype_from_proto asset_values_file_type )
              with
              | ( Some (id, version),
                  Some asset_range,
                  Some asset_values_file_type ) ->
                  let file_checksum =
                    if Messages_.Reader.Value.has_asset_checksum_sha256 value
                    then
                      let sha256 =
                        Messages_.Reader.Value.asset_checksum_sha256_get value
                      in
                      checksum_from_proto sha256
                      |> Option.map (fun sha256 -> `SHA256 sha256)
                    else if Messages_.Reader.Value.has_asset_checksum_sha1 value
                    then
                      let sha1 =
                        Messages_.Reader.Value.asset_checksum_sha1_get value
                      in
                      checksum_from_proto sha1
                      |> Option.map (fun sha1 -> `SHA1 sha1)
                    else if
                      Messages_.Reader.Value.has_asset_checksum_blake2b256 value
                    then
                      let blake2b256 =
                        Messages_.Reader.Value.asset_checksum_blake2b256_get
                          value
                      in
                      checksum_from_proto blake2b256
                      |> Option.map (fun blake2b256 -> `BLAKE2b_256 blake2b256)
                    else None
                  in
                  begin
                    let* value_exists_result =
                      value_existence_check key value_id
                    in
                    match (value_exists_result, file_checksum) with
                    | ValueMissing, _ | _, None -> return None
                    | (ValueNotNeeded | ValueExists), Some file_checksum ->
                      begin
                        let value : Ctx.V.asset option =
                          Some
                            {
                              asset_values_canonical_id;
                              asset_values_file_type;
                              asset_values_file_sha256;
                              asset_id = { id; version };
                              asset_path;
                              asset_range;
                              asset_origin_name;
                              asset_mirrors = (first_mirror, rest_mirrors);
                              asset_checksum = file_checksum;
                            }
                        in
                        let show = fun () -> "asset " ^ value_id in
                        return
                          (Some
                             ( show,
                               Ctx.V.Asset { value_id; value_sha256; value } ))
                      end
                  end
              | _ -> return None
            end
          | [] ->
              on_problem
                (Problem.UnimplementedOperation "v_from_proto::Valuetype_asset");
              return None
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation "v_from_proto::Valuetype_asset");
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation "v_from_proto::Valuetype_asset");
        return None
      end

  let v_assetindex_from_proto ~on_problem ~value_existence_check key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
        && Messages_.Reader.Value.has_assetindex_values_file_sha256 value
        && Messages_.Reader.Value.has_assetindex_modver value
        && Messages_.Reader.Value.has_assetindex_path value
        && Messages_.Reader.Value.has_assetindex_range value
        && Messages_.Reader.Value.has_assetindex_values_canonical_id value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        let asset_index_values_file_type =
          Messages_.Reader.Value.assetindex_values_file_type_get value
        in
        let asset_index_values_file_sha256 =
          Messages_.Reader.Value.assetindex_values_file_sha256_get value
        in
        let assetindex_type =
          Messages_.Reader.Value.assetindex_type_get value
        in
        let modver = Messages_.Reader.Value.assetindex_modver_get value in
        let asset_index_path =
          Messages_.Reader.Value.assetindex_path_get value
        in
        let range = Messages_.Reader.Value.assetindex_range_get value in
        let asset_index_values_canonical_id =
          Messages_.Reader.Value.assetindex_values_canonical_id_get value
        in
        if
          String.starts_with ~prefix:Paths.prefix_assetindex value_id
          && assetindex_type = Messages_.Reader.IndexType.Zip
        then begin
          match
            ( module_version_from_proto modver,
              range_from_proto range,
              valuesfiletype_from_proto asset_index_values_file_type )
          with
          | ( Some (id, version),
              Some asset_index_range,
              Some asset_index_values_file_type ) ->
              let file_checksum =
                if
                  Messages_.Reader.Value.has_assetindex_checksum_blake2b256
                    value
                then
                  let blake2b256 =
                    Messages_.Reader.Value.assetindex_checksum_blake2b256_get
                      value
                  in
                  checksum_from_proto blake2b256
                  |> Option.map (fun blake2b256 -> `BLAKE2b_256 blake2b256)
                else None
              in
              begin
                let* value_exists_result = value_existence_check key value_id in
                match (value_exists_result, file_checksum) with
                | ValueMissing, _ | _, None -> return None
                | (ValueNotNeeded | ValueExists), Some file_checksum -> begin
                    let value : Ctx.V.asset_index option =
                      Some
                        {
                          asset_index_values_canonical_id;
                          asset_index_values_file_type;
                          asset_index_values_file_sha256;
                          asset_index_modver = { id; version };
                          asset_index_path;
                          asset_index_type = `Zip;
                          asset_index_range;
                          asset_index_checksum = file_checksum;
                        }
                    in
                    let show = fun () -> "asset index " ^ value_id in
                    return
                      (Some
                         ( show,
                           Ctx.V.AssetIndex { value_id; value_sha256; value } ))
                  end
              end
          | _ -> return None
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation "v_from_proto::Valuetype_assetindex");
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation "v_from_proto::Valuetype_assetindex");
        return None
      end

  let v_constant_from_proto ~on_problem ~valuestore_get key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        if String.starts_with ~prefix:Paths.prefix_constant value_id then begin
          let* constant_opt =
            BuildValues'.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,
                     Ctx.V.Constant
                       {
                         value_id;
                         value_sha256;
                         value =
                           Some { constant_transient = Some { constant_value } };
                       } ))
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation "v_from_proto::Valuetype_constant");
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation "v_from_proto::Valuetype_constant");
        return None
      end

  let v_distribution_from_proto ~on_problem value =
    let return = Ctx.Promise.return in
    let value : Messages_.Reader.Value.t = value in
    if
      Messages_.Reader.Value.has_dist_id value
      && Messages_.Reader.Value.has_dist_json value
    then
      let dist_id = Messages_.Reader.Value.dist_id_get value in
      let dist_json = Messages_.Reader.Value.dist_json_get value in
      let dist_values_file_sha256 =
        if Messages_.Reader.Value.has_dist_values_file_sha256 value then
          Some (Messages_.Reader.Value.dist_values_file_sha256_get value)
        else None
      in
      begin
        match (package_version_from_proto dist_id, dist_values_file_sha256) with
        | None, _ -> return None
        | Some (package_id, package_semver), None ->
            log_warn (fun l ->
                l
                  "[warning]: distribution %s@%s is missing \
                   dist_values_file_sha256; not loaded from trace store. \
                   https://github.com/diskuv/dk/issues/98\n\
                   %!"
                  (MlFront_Core.PackageId.show_dot package_id)
                  (MlFront_Thunk.ThunkSemver64.to_string package_semver));
            return None
        | Some (package_id, package_semver), Some values_file_sha256 -> (
            let show = fun () -> "distribution" in
            let jsonfile =
              Ctx.Io.inmemory_file
                ~origin:
                  (MlFront_Core.FilePath.append_exn
                     MlFront_Thunk.ThunkIo.shmdir_for_inmem_filesystem
                     "tracestore")
                dist_json
            in
            let dist_result =
              Ctx.run_isolated_promise
              @@ SecDist'.DistIo.parse (module TraceStoreObserver) jsonfile
            in
            match dist_result with
            | Error _ -> return None
            | Ok distribution ->
                return
                  (Some
                     ( show,
                       Ctx.V.Distribution
                         {
                           distribution_id = (package_id, package_semver);
                           distribution_values_file_sha256 = values_file_sha256;
                           distribution_json = dist_json;
                           distribution;
                         } )))
      end
    else begin
      on_problem
        (Problem.UnimplementedOperation "v_from_proto::Valuetype_distribution");
      return None
    end

  let v_object_from_proto ~on_problem ~value_existence_check key :
      Messages_.Reader.Value.t -> _ =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    fun value ->
      if
        Messages_.Reader.Value.has_value_id value
        && Messages_.Reader.Value.has_value_sha256 value
        && Messages_.Reader.Value.has_object_slot value
        && Messages_.Reader.Value.has_object_id value
        && Messages_.Reader.Value.has_object_range value
      then
        let value_id = Messages_.Reader.Value.value_id_get value in
        let value_sha256 = Messages_.Reader.Value.value_sha256_get value in
        let object_slot = Messages_.Reader.Value.object_slot_get_list value in
        let id = Messages_.Reader.Value.object_id_get value in
        let range = Messages_.Reader.Value.object_range_get value in
        if String.starts_with ~prefix:Paths.prefix_object value_id then begin
          match
            ( module_version_from_proto id,
              range_from_proto range,
              object_slot_from_proto object_slot )
          with
          | Some (id, version), Some object_range, Some object_slot -> begin
              let* value_exists_result = value_existence_check key value_id in
              match value_exists_result with
              | ValueMissing -> return None
              | ValueNotNeeded | ValueExists ->
                  let value : Ctx.V.object_ option =
                    Some
                      {
                        object_id = { id; version };
                        object_slot;
                        object_range;
                        object_origin = None;
                      }
                  in
                  let show = fun () -> "object " ^ value_id in
                  return
                    (Some (show, Ctx.V.Object { value_id; value_sha256; value }))
            end
          | _ -> return None
        end
        else begin
          on_problem
            (Problem.UnimplementedOperation
               ("v_from_proto::Valuetype_object::" ^ value_id));
          return None
        end
      else begin
        on_problem
          (Problem.UnimplementedOperation "v_from_proto::Valuetype_object");
        return None
      end

  let value_from_proto ~on_problem ~value_existence_check ~valuestore_get key
      value : ((unit -> string) * Ctx.V.t) option Ctx.Promise.t =
    Assumptions
    .persisted_values_are_checked_for_existence_during_trace_store_load ();
    let return = Ctx.Promise.return in
    let value : Messages_.Reader.Value.t = value in
    match Messages_.Reader.Value.valuetype_get value with
    | Messages_.Reader.ValueType.Valuesjsonfile ->
        v_valuesjsonfile_from_proto ~on_problem ~value_existence_check key value
    | Messages_.Reader.ValueType.Valuesluafile ->
        v_valuesluafile_from_proto ~on_problem ~value_existence_check key value
    | Messages_.Reader.ValueType.Scriptmodule ->
        v_scriptmodule_from_proto ~on_problem ~valuestore_get value
    | Messages_.Reader.ValueType.Form -> v_form_from_proto ~on_problem value
    | Messages_.Reader.ValueType.Bundle ->
        v_bundle_from_proto ~on_problem ~value_existence_check key value
    | Messages_.Reader.ValueType.Asset ->
        v_asset_from_proto ~on_problem ~value_existence_check key value
    | Messages_.Reader.ValueType.Assetindex ->
        v_assetindex_from_proto ~on_problem ~value_existence_check key value
    | Messages_.Reader.ValueType.Constant ->
        v_constant_from_proto ~on_problem ~valuestore_get key value
    | Messages_.Reader.ValueType.Object ->
        v_object_from_proto ~on_problem ~value_existence_check key value
    | Messages_.Reader.ValueType.Distribution ->
        v_distribution_from_proto ~on_problem value
    | Messages_.Reader.ValueType.Unspecified ->
        on_problem
          (Problem.UnimplementedOperation "v_from_proto::Valuetype_unspecified");
        return None
    | Messages_.Reader.ValueType.Undefined _ -> return None

  let to_proto : Ctx.State.trace -> Messages_.Builder.ConstructiveTrace.t option
      = function
    | { generation = _; key; dependencies; result } ->
    match k_to_proto key with
    | None -> None
    | Some proto_of_k ->
        let maybe_deps = List.map k_kvhash_to_proto dependencies in
        if List.exists (fun d -> d = None) maybe_deps then None
        else
          let tb = Messages_.Builder.ConstructiveTrace.init_root () in
          let _ =
            Messages_.Builder.ConstructiveTrace.key_set_reader tb proto_of_k
          in
          let dep_readers = List.map Option.get maybe_deps in
          let n = List.length dep_readers in
          let arr =
            Messages_.Builder.ConstructiveTrace.dependencies_init tb n
          in
          List.iteri
            (fun i dep ->
              let slot = Capnp.Array.get arr i in
              let _ =
                Messages_.Builder.Dependency.depkey_set_reader slot
                  (Messages_.Reader.Dependency.depkey_get dep)
              in
              Messages_.Builder.Dependency.kvhash_set slot
                (Messages_.Reader.Dependency.kvhash_get dep))
            dep_readers;
          let value_reader_opt = v_to_proto result in
          (match value_reader_opt with
          | Some value_reader ->
              let _ =
                Messages_.Builder.ConstructiveTrace.value_set_reader tb
                  value_reader
              in
              ()
          | None -> ());
          Some tb

  let show_keykind : Messages_.Reader.KeyKind.t -> string = function
    | Unspecified -> "unspecified"
    | UserObject -> "user_form"
    | UserBundle -> "user_bundle"
    | UserAsset -> "user_asset"
    | UserScriptmodule -> "user_script"
    | UserRule -> "user_rule"
    | ChecksumValuesjsonfile -> "checksum_valuesjsonfile"
    | ChecksumValuesluafile -> "checksum_valuesluafile"
    | PackageDist -> "package_dist"
    | IndexAsset -> "index_asset"
    | Undefined _ -> "undefined"

  let show_dependency (dep : Messages_.Reader.Dependency.t) : string =
    if
      Messages_.Reader.Dependency.has_depkey dep
      && Messages_.Reader.Dependency.has_kvhash dep
    then
      let depkey = Messages_.Reader.Dependency.depkey_get dep in
      let keykind = Messages_.Reader.Key.keykind_get depkey in
      let values_canonical_id =
        if Messages_.Reader.Key.has_values_canonical_id depkey then
          Messages_.Reader.Key.values_canonical_id_get depkey
        else "<none>"
      in
      Printf.sprintf "keykind=%s, values_canonical_id=%s" (show_keykind keykind)
        values_canonical_id
    else "(malformed dependency)"

  let asset_trace_matches_invalidation ~invalidate_asset_path ~asset_origin_name
      ~asset_path ~asset_mirrors =
    let first_mirror, rest_mirrors = asset_mirrors in
    let mirrors = first_mirror :: rest_mirrors in
    invalidate_asset_path ~origin_name:asset_origin_name ~asset_path
    || List.exists
         (fun origin_name -> invalidate_asset_path ~origin_name ~asset_path)
         mirrors

  type reader_state = {
    reader_generation : int;
    buildlogtrace : bool;
    value_existence_check : Ctx.K.t -> string -> value_exists Ctx.Promise.t;
    valuestore_get :
      Ctx.K.t -> string -> MlFront_Core.FilePath.t option Ctx.Promise.t;
  }

  let complete_valuetrace ~on_problem ~k ~k_show ~deps ~tracesz32
      ({
         reader_generation;
         buildlogtrace;
         value_existence_check;
         valuestore_get;
       } :
        reader_state) value =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    (* All the dependencies are present. *)
    let* v_opt =
      value_from_proto ~on_problem ~value_existence_check ~valuestore_get k
        value
    in
    match v_opt with
    | None ->
        on_problem
          (Problem.NoTraceStoreCorrespondenceInValueStore
             {
               key = k_show ();
               value_id =
                 (if Messages_.Reader.Value.has_value_id value then
                    Some (Messages_.Reader.Value.value_id_get value)
                  else None);
             });
        if buildlogtrace then
          log_debug (fun l -> l "[buildlog] value miss %s" (k_show ()));
        return None
    | Some (v_show, v) ->
        if buildlogtrace then
          log_debug (fun l ->
              l "[buildlog] read %s %s. %d deps. %ld b" (v_show ()) (k_show ())
                (List.length deps) tracesz32);
        return
          (Some
             ({
                generation = reader_generation;
                key = k;
                dependencies = deps;
                result = v;
              }
               : Ctx.State.trace))

  (** [value_trace_of_proto_trace reader_state tracesz trace] converts the
      protobuf [trace] into a {!Ctx.State.trace}.

      Invalidation based on asset origins/paths is handled after the trace list
      is loaded so it depends only on serialized trace data. *)
  let valuetrace_of_proto_trace ~on_problem
      (({
          reader_generation = _;
          buildlogtrace;
          value_existence_check = _;
          valuestore_get;
        } :
         reader_state) as reader) tracesz32 :
      Messages_.Reader.ConstructiveTrace.t ->
      Ctx.State.trace option Ctx.Promise.t =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let module KP = MakeKeyProto (Ctx.Promise) in
    fun ctrace ->
      let has_key = Messages_.Reader.ConstructiveTrace.has_key ctrace in
      let has_value = Messages_.Reader.ConstructiveTrace.has_value ctrace in
      match (has_key, has_value) with
      | false, _ ->
          if buildlogtrace then log_debug (fun l -> l "[buildlog] no key");
          return None
      | _, false ->
          if buildlogtrace then log_debug (fun l -> l "[buildlog] no value");
          return None
      | true, true -> (
          let key = Messages_.Reader.ConstructiveTrace.key_get ctrace in
          let dependencies =
            Messages_.Reader.ConstructiveTrace.dependencies_get_list ctrace
          in
          let value = Messages_.Reader.ConstructiveTrace.value_get ctrace in
          let* k_result =
            KP.k_from_proto ~on_problem ~buildlogtrace
              ~debug_reference_valuestore_get:valuestore_get key
          in
          match k_result with
          | None ->
              if buildlogtrace then log_debug (fun l -> l "[buildlog] key miss");
              return None
          | Some (k_show, k) -> begin
              let* maybe_deps =
                (* regardless of what is in the trace store, never load dependencies
               for assets and bundles. *)
                if Ctx.K.is_asset k || Ctx.K.is_bundle k then (
                  Assumptions
                  .assets_and_bundles_have_no_dependencies_especially_on_distributions
                    ();
                  return [])
                else
                  let maybe_deps_promises =
                    List.map
                      (KP.k_kvhash_from_proto ~on_problem ~buildlogtrace
                         ~debug_reference_valuestore_get:valuestore_get)
                      dependencies
                  in
                  Ctx.Promise.parallel maybe_deps_promises
              in
              let key_kvhash_deps = List.filter_map Fun.id maybe_deps in
              if List.length maybe_deps <> List.length key_kvhash_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
                   log_debug (fun l ->
                       l "[buildlog] miss %s. %d of %d deps found. missing: %s"
                         (k_show ())
                         (List.length key_kvhash_deps)
                         (List.length maybe_deps)
                         (String.concat ", " missing_deps)));
                return None
              end
              else
                complete_valuetrace ~on_problem ~k ~k_show ~deps:key_kvhash_deps
                  ~tracesz32 reader value
            end)

  let nodebug_reference_valuestore_get _k _value_id = Ctx.Promise.return None

  let semitrace_of_proto_trace ~on_problem ~tracesz ~tracesz32 :
      Messages_.Reader.ConstructiveTrace.t ->
      BuildTrace'.semitrace option Ctx.Promise.t =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let module KP = MakeKeyProto (Ctx.Promise) in
    fun ctrace ->
      let has_key = Messages_.Reader.ConstructiveTrace.has_key ctrace in
      let has_value = Messages_.Reader.ConstructiveTrace.has_value ctrace in
      match (has_key, has_value) with
      | false, _ -> return None
      | _, false -> return None
      | true, true -> (
          let key = Messages_.Reader.ConstructiveTrace.key_get ctrace in
          let dependencies =
            Messages_.Reader.ConstructiveTrace.dependencies_get_list ctrace
          in
          let raw_value = Messages_.Reader.ConstructiveTrace.value_get ctrace in
          let* k_result =
            KP.k_from_proto ~on_problem ~buildlogtrace:false
              ~debug_reference_valuestore_get:nodebug_reference_valuestore_get
              key
          in
          match k_result with
          | None -> return None
          | Some (_k_show, k) -> begin
              let maybe_deps_promises =
                List.map
                  (KP.k_kvhash_from_proto ~on_problem ~buildlogtrace:false
                     ~debug_reference_valuestore_get:
                       nodebug_reference_valuestore_get)
                  dependencies
              in
              let* maybe_deps = Ctx.Promise.parallel maybe_deps_promises in
              let key_kvhash_deps = List.filter_map Fun.id maybe_deps in
              if List.length maybe_deps <> List.length key_kvhash_deps then
                return None
              else
                return
                  (Some
                     {
                       BuildTrace'.key = k;
                       key_kvhash_deps;
                       raw_sz32 = tracesz32;
                       raw_sz = tracesz;
                       raw_value;
                     })
            end)

  let max_segment_size = 16777216 (* 16MiB *)

  module StringSet = Set.Make (String)
  module KeySet = Set.Make (Ctx.K)
  module G = CCGraph.Map (Ctx.K)

  let remove_pending_keys ~buildlogtrace ~keys_to_invalidate traces =
    let ( let* ) = Ctx.Promise.bind in
    let return = Ctx.Promise.return in
    (* make ancestor graph from traces *)
    let graph = Ctx.State.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:Ctx.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
           ({ generation = _; key; dependencies = _deps; result = _ } as trace :
             Ctx.State.trace) ->
        let* acc = acc in
        if KeySet.mem key !key_removals then (
          if buildlogtrace then
            (* Printf.eprintf "[buildlog] skip backtracked %s. deps: %s\n" (Ctx.K.show key) (String.concat ", " (List.map (fun (k,_kvhash) -> Ctx.K.show k) _deps)); *)
            log_debug (fun l ->
                l "[buildlog] skip backtracked %s" (Ctx.K.show key));
          return acc)
        else return (trace :: acc))
      (return []) traces

  let create_ancestorgraph_from_semitrace_list semitraces =
    List.fold_left
      (fun g
           ({ key; key_kvhash_deps; raw_sz32 = _; raw_sz = _; raw_value = _ } :
             BuildTrace'.semitrace) ->
        List.fold_left
          (fun g (dep_key, dep_kvhash) -> G.add_edge dep_key dep_kvhash key g)
          g key_kvhash_deps)
      G.empty semitraces
    |> G.as_graph

  let remove_key_ids_and_dependents_from_semitraces ~key_ids semitraces =
    if StringSet.is_empty key_ids then (semitraces, 0)
    else
      let graph = create_ancestorgraph_from_semitrace_list semitraces in
      let dfs_iter_once =
        CCGraph.Traverse.dfs ~tbl:(CCGraph.mk_map ~cmp:Ctx.K.compare ()) ~graph
          (fun f ->
            List.iter
              (fun ({
                      key;
                      key_kvhash_deps = _;
                      raw_sz32 = _;
                      raw_sz = _;
                      raw_value = _;
                    } :
                     BuildTrace'.semitrace) ->
                if StringSet.mem (Ctx.K.id key) key_ids then f key)
              semitraces)
      in
      let key_removals = ref KeySet.empty in
      dfs_iter_once (fun transitive_key ->
          key_removals := KeySet.add transitive_key !key_removals);
      let filtered =
        List.filter
          (fun ({
                  key;
                  key_kvhash_deps = _;
                  raw_sz32 = _;
                  raw_sz = _;
                  raw_value = _;
                } :
                 BuildTrace'.semitrace) -> not (KeySet.mem key !key_removals))
          semitraces
      in
      (filtered, KeySet.cardinal !key_removals)

  let valuetraces_of_segment_exn ~on_problem ~on_fail
      (reader_state : reader_state) bytes pos len =
    parse_segment_exn ~on_fail bytes pos len (fun ~tracesz32 ~tracesz ctrace ->
        let trace_promise =
          valuetrace_of_proto_trace ~on_problem reader_state tracesz32 ctrace
        in
        Ctx.Promise.map (fun x -> (x, `TraceSize tracesz)) trace_promise)

  let semitraces_of_segment_exn ~on_problem bytes pos len =
    parse_segment_exn
      ~on_fail:(fun s -> Failure s)
      bytes pos len
      (fun ~tracesz32 ~tracesz ctrace ->
        let semi_trace_promise =
          semitrace_of_proto_trace ~on_problem ~tracesz ~tracesz32 ctrace
        in
        Ctx.Promise.map (fun x -> (x, `TraceSize tracesz)) semi_trace_promise)

  let kvtrace_valueid_pairs_of_segment ~on_problem bytes pos len =
    let exception SegmentError of string in
    let module KP = MakeKeyProto (IdentityMonad) in
    try
      let pairs =
        parse_segment_exn
          ~on_fail:(fun s -> SegmentError s)
          bytes pos len
          (fun ~tracesz32:_ ~tracesz ctrace ->
            KP.kvtrace_valueid_pair_of_proto_trace ~on_problem ~tracesz ctrace)
      in
      Ok pairs
    with SegmentError msg -> Error msg

  let read_segment_frame_into_valuetraces_exn ~on_finish ~on_fail ~on_more
      reader_state tracefd =
    parse_segment_frame_exn ~on_finish ~on_fail ~on_more tracefd
      (fun trace_b pos len ->
        let exception SegmentError of string in
        try
          valuetraces_of_segment_exn
            ~on_problem:(fun problem ->
              raise (SegmentError (Problem.show problem)))
            ~on_fail:(fun s -> SegmentError s)
            reader_state trace_b pos len
        with SegmentError msg -> raise (on_fail msg))

  let read_segment_frace_into_semitraces_exn ~on_finish ~on_fail ~on_more
      tracefd =
    parse_segment_frame_exn ~on_finish ~on_fail ~on_more tracefd
      (fun trace_b pos len ->
        let exception SegmentError of string in
        try
          semitraces_of_segment_exn
            ~on_problem:(fun problem ->
              raise (SegmentError (Problem.show problem)))
            trace_b pos len
        with SegmentError msg -> raise (on_fail msg))

  let keyvalue_ids_of_segment_frame ~on_problem tracefd =
    let exception SegmentFrameError of string in
    try
      parse_segment_frame_exn ~on_finish:(`Finished [])
        ~on_fail:(fun s -> SegmentFrameError s)
        ~on_more:(fun ps -> `More ps)
        tracefd
        (kvtrace_valueid_pairs_of_segment ~on_problem)
    with SegmentFrameError msg -> `Failed msg

  let fold_over_kvtraces_in_file ~init
      ~(f : value_id:string option -> KVTrace.t -> 'a -> 'a) ~error tracefd =
    let has_problem = ref None in
    let rec aux acc =
      match
        ( !has_problem,
          keyvalue_ids_of_segment_frame
            ~on_problem:(fun problem ->
              if !has_problem = None then has_problem := Some problem)
            tracefd )
      with
      | Some problem, _ -> error (Problem.show problem) acc
      | None, `Finished keyvalue_ids ->
          List.fold_left
            (fun acc keyvalue_id_opt ->
              match keyvalue_id_opt with
              | None -> acc
              | Some (_key, kvtrace, `ValueId value_id) ->
                  f ~value_id kvtrace acc)
            acc keyvalue_ids
      | None, `Failed msg -> error msg acc
      | None, `More (more_keyvalue_ids_result, `SegmentSize _) -> begin
          match more_keyvalue_ids_result with
          | Ok keyvalue_id_promises ->
              let acc' =
                List.fold_left
                  (fun acc keyvalue_id_opt ->
                    match keyvalue_id_opt with
                    | None -> acc
                    | Some (_key, kvtrace, `ValueId value_id) ->
                        f ~value_id kvtrace acc)
                  acc keyvalue_id_promises
              in
              aux acc'
          | Error msg -> error msg acc
        end
    in
    let results = aux init in
    match !has_problem with
    | None -> results
    | Some problem -> error (Problem.show problem) results

  let rec read_valuetraces_exn ~on_fail reader_state tracefd =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let rec aux_partial_traces_exn acc =
      let* acc = acc in

      match
        read_segment_frame_into_valuetraces_exn
          ~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 = Ctx.Promise.parallel moretraces_promises in
          aux_partial_traces_exn (return (moretraces :: acc))
    in
    let* traces = aux_partial_traces_exn (return []) in
    from_valuetrace_option_list_list traces

  and read_semitraces_exn ~on_fail tracefd =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let rec aux_partial_semitraces_exn acc =
      let* acc = acc in

      match
        read_segment_frace_into_semitraces_exn
          ~on_finish:(`Finished (return acc))
          ~on_fail:(on_fail acc)
          ~on_more:(fun ps -> `More ps)
          tracefd
      with
      | `Finished res -> res
      | `More (moresemitraces_promises, `SegmentSize _) ->
          (* run the conversion in parallel *)
          let* moresemitraces = Ctx.Promise.parallel moresemitraces_promises in
          aux_partial_semitraces_exn (return (moresemitraces :: acc))
    in
    let* semitraces = aux_partial_semitraces_exn (return []) in
    from_semitrace_option_list_list semitraces

  and from_valuetrace_option_list_list :
      (Ctx.State.trace option * [ `TraceSize of int ]) list list ->
      Ctx.State.trace option list Ctx.Promise.t =
    let return = Ctx.Promise.return in
    fun x -> return (List.map fst (List.flatten (List.rev x)))

  and from_semitrace_option_list_list :
      (BuildTrace'.semitrace option * [ `TraceSize of int ]) list list ->
      BuildTrace'.semitrace option list Ctx.Promise.t =
    let return = Ctx.Promise.return in
    fun x -> return (List.map fst (List.flatten (List.rev x)))

  let invalidate_changed_trace_values ~buildlogtrace ~invalidate_asset_path
      traces =
    let invalidated_values = Hashtbl.create 16 in
    List.iter
      (fun ({ result; _ } : Ctx.State.trace) ->
        match result with
        | Ctx.V.Asset
            {
              value =
                Some
                  {
                    asset_values_canonical_id;
                    asset_origin_name;
                    asset_path;
                    asset_mirrors;
                    asset_checksum = _;
                    asset_id = _;
                    asset_range = _;
                    asset_values_file_type = _;
                    asset_values_file_sha256 = _;
                  };
              _;
            } ->
            if
              asset_trace_matches_invalidation ~invalidate_asset_path
                ~asset_origin_name ~asset_path ~asset_mirrors
            then Hashtbl.replace invalidated_values asset_values_canonical_id ()
        | _ -> ())
      traces;
    if Hashtbl.length invalidated_values = 0 then Ctx.Promise.return traces
    else
      let keys_to_invalidate = Hashtbl.create 16 in
      List.iter
        (fun ({ key; result; _ } : Ctx.State.trace) ->
          let values_canonical_id_opt =
            match result with
            | Ctx.V.Bundle { value = Some { bundle_values_canonical_id; _ }; _ }
              ->
                Some bundle_values_canonical_id
            | Ctx.V.Asset { value = Some { asset_values_canonical_id; _ }; _ }
              ->
                Some asset_values_canonical_id
            | _ -> None
          in
          match values_canonical_id_opt with
          | Some values_canonical_id
            when Hashtbl.mem invalidated_values values_canonical_id ->
              Hashtbl.replace keys_to_invalidate key ();
              if buildlogtrace then
                log_debug (fun l ->
                    l "[buildlog] skip changed %s" (Ctx.K.show key))
          | _ -> ())
        traces;
      remove_pending_keys ~buildlogtrace ~keys_to_invalidate traces

  let rec read_traces_gracefully ~preconfig ~reader_generation
      ~invalidate_asset_path tracefd =
    let baseconfig = Config.preconfig_baseconfig preconfig in
    let buildlogtrace = Config.baseconfig_buildlogtrace baseconfig in
    let valuestore = Config.baseconfig_valuestore baseconfig in

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

    (* Abstract value type *)
    let valuestore_get _key value_id =
      Ctx.get_value_file ~valuestore ~value_id ()
    in
    let value_existence_check =
      let ( let* ), return = Ctx.Promise.(bind, return) in
      match Config.baseconfig_integrity baseconfig 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 =
      {
        reader_generation;
        buildlogtrace;
        value_existence_check;
        valuestore_get;
      }
    in

    let exception
      PartialTraces of (string * Ctx.State.trace option list Ctx.Promise.t)
    in
    match
      read_valuetraces_exn
        ~on_fail:(fun acc s ->
          PartialTraces (s, from_valuetrace_option_list_list acc))
        reader_state tracefd
    with
    | traces -> load_valuetraces ~buildlogtrace ~invalidate_asset_path traces
    | exception PartialTraces (msg, traces) ->
        log_warn (fun l ->
            l "[buildlog] [warning] failed to read all traces: %s" msg);
        load_valuetraces ~buildlogtrace ~invalidate_asset_path traces

  and load_valuetraces ~buildlogtrace ~invalidate_asset_path traces =
    let traces' = Ctx.run_isolated_promise traces in
    let traces' = List.filter_map Fun.id traces' in
    match invalidate_asset_path with
    | None -> traces'
    | Some invalidate_asset_path ->
        Ctx.run_isolated_promise
          (invalidate_changed_trace_values ~buildlogtrace ~invalidate_asset_path
             traces')

  and load_semitraces semitraces =
    let semitraces' = Ctx.run_isolated_promise semitraces in
    let semitraces' = List.filter_map Fun.id semitraces' in
    semitraces'

  let visit_kvtraces_in_file ?topological_order tracefd visit_kvtrace =
    match topological_order with
    | None -> (
        let exception FailedRead of string in
        try
          let rec aux () =
            match
              keyvalue_ids_of_segment_frame ~on_problem:(fun _ -> ()) tracefd
            with
            | `Finished keyvalue_ids ->
                List.iter
                  (function
                    | None -> ()
                    | Some (key, kvtrace, `ValueId value_id) ->
                        visit_kvtrace key ~value_id kvtrace)
                  keyvalue_ids;
                ()
            | `More (Ok keyvalue_ids, `SegmentSize _) ->
                List.iter
                  (function
                    | None -> ()
                    | Some (key, kvtrace, `ValueId value_id) ->
                        visit_kvtrace key ~value_id kvtrace)
                  keyvalue_ids;
                aux ()
            | `More (Error msg, _) | `Failed msg -> raise (FailedRead msg)
          in
          aux ();
          Ok ()
        with FailedRead msg -> Error msg)
    | Some () -> (
        let exception PartialTraces of string in
        match
          read_semitraces_exn ~on_fail:(fun _acc s -> PartialTraces s) tracefd
        with
        | traces ->
            let unsorted_traces = load_semitraces traces in
            begin
              match
                BuildTrace'.sort_semitraces_topologically unsorted_traces
              with
              | Error msg -> Error msg
              | Ok sorted_traces ->
                  List.iter
                    (fun ({
                            key;
                            key_kvhash_deps;
                            raw_sz32 = _;
                            raw_sz;
                            raw_value;
                          } :
                           BuildTrace'.semitrace) ->
                      let value_id =
                        if Messages_.Reader.Value.has_value_id raw_value then
                          Some (Messages_.Reader.Value.value_id_get raw_value)
                        else None
                      in
                      let kvtrace =
                        KVTrace.create ~key_id:(Ctx.K.id key)
                          ~key_description:(Ctx.K.show key)
                          ~num_dependenices:(List.length key_kvhash_deps)
                          ~tracesz:raw_sz ~value_trace:raw_value
                      in
                      visit_kvtrace key ~value_id kvtrace)
                    sorted_traces;
                  Ok ()
            end
        | exception PartialTraces msg -> Error msg)

  let valuesfile_value_id ~values_file_type ~values_file_sha256 =
    match values_file_type with
    | `Json -> Ctx.V.get_valuesjsonfile_value_id ~values_file_sha256
    | `Lua -> Ctx.V.get_valuesluafile_value_id ~values_file_sha256

  let required_value_ids_of_raw_value value =
    let add_if_some acc = function Some value_id -> value_id :: acc | None -> acc in
    let acc = [] in
    let acc =
      if Messages_.Reader.Value.has_value_id value then
        Messages_.Reader.Value.value_id_get value :: acc
      else acc
    in
    let acc =
      if Messages_.Reader.Value.has_dist_values_file_sha256 value then
        add_if_some acc
          (Some
             (Ctx.V.get_valuesjsonfile_value_id
                ~values_file_sha256:
                  (Messages_.Reader.Value.dist_values_file_sha256_get value)))
      else acc
    in
    let acc =
      if Messages_.Reader.Value.has_form_values_file_sha256 value then
        add_if_some acc
          (Some
             (Ctx.V.get_valuesjsonfile_value_id
                ~values_file_sha256:
                  (Messages_.Reader.Value.form_values_file_sha256_get value)))
      else acc
    in
    let acc =
      if Messages_.Reader.Value.has_bundle_values_file_sha256 value then
        add_if_some acc
          (Some
             (Ctx.V.get_valuesjsonfile_value_id
                ~values_file_sha256:
                  (Messages_.Reader.Value.bundle_values_file_sha256_get value)))
      else acc
    in
    let acc =
      if Messages_.Reader.Value.has_scriptmodule_values_file_sha256 value then
        add_if_some acc
          (Some
             (Ctx.V.get_valuesluafile_value_id
                ~values_file_sha256:
                  (Messages_.Reader.Value.scriptmodule_values_file_sha256_get
                     value)))
      else acc
    in
    let acc =
      if
        Messages_.Reader.Value.has_asset_values_file_sha256 value
      then
        add_if_some acc
          (valuesfiletype_from_proto
             (Messages_.Reader.Value.asset_values_file_type_get value)
          |> Option.map (fun values_file_type ->
                 valuesfile_value_id ~values_file_type
                   ~values_file_sha256:
                     (Messages_.Reader.Value.asset_values_file_sha256_get value)))
      else acc
    in
    let acc =
      if
        Messages_.Reader.Value.has_assetindex_values_file_sha256 value
      then
        add_if_some acc
          (valuesfiletype_from_proto
             (Messages_.Reader.Value.assetindex_values_file_type_get value)
          |> Option.map (fun values_file_type ->
                 valuesfile_value_id ~values_file_type
                   ~values_file_sha256:
                     (Messages_.Reader.Value.assetindex_values_file_sha256_get
                        value)))
      else acc
    in
    List.sort_uniq String.compare acc

  let filter_semitraces_with_dependency_closure semitraces ~primary_trace_filter
      ~dependency_trace_filter =
    let semitrace_by_key_id = Hashtbl.create (List.length semitraces) in
    List.iter
      (fun ({ BuildTrace'.key; _ } as semitrace) ->
        Hashtbl.replace semitrace_by_key_id (Ctx.K.id key) semitrace)
      semitraces;
    let included_key_ids = Hashtbl.create (List.length semitraces) in
    let rec include_by_key key =
      let key_id = Ctx.K.id key in
      if not (Hashtbl.mem included_key_ids key_id) then begin
        Hashtbl.replace included_key_ids key_id ();
        match Hashtbl.find_opt semitrace_by_key_id key_id with
        | None -> ()
        | Some ({ key_kvhash_deps; _ } : BuildTrace'.semitrace) ->
            List.iter
              (fun (depkey, _kvhash) ->
                let depkey_id = Ctx.K.id depkey in
                match Hashtbl.find_opt semitrace_by_key_id depkey_id with
                | Some ({ key; raw_value; _ } : BuildTrace'.semitrace)
                  when dependency_trace_filter key raw_value ->
                    include_by_key depkey
                | _ -> ())
              key_kvhash_deps
      end
    in
    List.iter
      (fun ({ key; raw_value; _ } : BuildTrace'.semitrace) ->
        if primary_trace_filter key raw_value then include_by_key key)
      semitraces;
    List.filter
      (fun ({ BuildTrace'.key; _ } : BuildTrace'.semitrace) ->
        Hashtbl.mem included_key_ids (Ctx.K.id key))
      semitraces

  let collect_required_value_ids_in_file ?topological_order
      ?(visit_trace_filter = fun _key _raw_value -> true)
      ?dependency_trace_filter tracefd =
    let exception PartialTraces of string in
    let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_SET in
    match
      read_semitraces_exn ~on_fail:(fun _acc s -> PartialTraces s) tracefd
    with
    | traces -> begin
        let semitraces = load_semitraces traces in
        let semitraces =
          match topological_order with
          | None -> semitraces
          | Some () -> begin
              match BuildTrace'.sort_semitraces_topologically semitraces with
              | Ok sorted -> sorted
              | Error msg -> raise (PartialTraces msg)
            end
        in
        let semitraces =
          match dependency_trace_filter with
          | None ->
              List.filter
                (fun ({ key; raw_value; _ } : BuildTrace'.semitrace) ->
                  visit_trace_filter key raw_value)
                semitraces
          | Some dependency_trace_filter ->
              filter_semitraces_with_dependency_closure semitraces
                ~primary_trace_filter:visit_trace_filter
                ~dependency_trace_filter
        in
        let tbl = Hashtbl.create 32 in
        List.iter
          (fun ({ raw_value; _ } : BuildTrace'.semitrace) ->
            List.iter (fun value_id -> Hashtbl.replace tbl value_id ())
              (required_value_ids_of_raw_value raw_value))
          semitraces;
        Ok (Hashtbl.to_seq_keys tbl |> List.of_seq |> List.sort String.compare)
      end
    | exception PartialTraces msg -> Error msg

  let semitrace_to_proto
      ({ key; key_kvhash_deps; raw_sz32 = _; raw_sz = _; raw_value } :
        BuildTrace'.semitrace) =
    match k_to_proto key with
    | None -> None
    | Some proto_of_k ->
        let maybe_deps = List.map k_kvhash_to_proto key_kvhash_deps in
        if List.exists (fun d -> d = None) maybe_deps then None
        else
          let tb = Messages_.Builder.ConstructiveTrace.init_root () in
          let _ =
            Messages_.Builder.ConstructiveTrace.key_set_reader tb proto_of_k
          in
          let dep_readers = List.map Option.get maybe_deps in
          let n = List.length dep_readers in
          let arr =
            Messages_.Builder.ConstructiveTrace.dependencies_init tb n
          in
          List.iteri
            (fun i dep ->
              let slot = Capnp.Array.get arr i in
              let _ =
                Messages_.Builder.Dependency.depkey_set_reader slot
                  (Messages_.Reader.Dependency.depkey_get dep)
              in
              Messages_.Builder.Dependency.kvhash_set slot
                (Messages_.Reader.Dependency.kvhash_get dep))
            dep_readers;
          let _ =
            Messages_.Builder.ConstructiveTrace.value_set_reader tb raw_value
          in
          Some tb

  let write_proto_traces ~buildlogtrace trace_builders tracefd =
    let exception CouldNotTrace of string in
    let write _what buf pos len =
      let ret = Unix.write tracefd buf pos len in
      ret
    in
    try
      let write_segment len seg_b =
        let segsz = Bytes.length seg_b in
        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");

        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");

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

        let len' = len + 4 + 32 + segsz in
        if len' < 0 then raise (CouldNotTrace "Trace file length overflow");
        len'
      in
      let write_trace len trace_builder_opt =
        let bs_str =
          match trace_builder_opt with
          | None -> ""
          | Some tb ->
              Messages_.serialize_message ~packing:()
                (Messages_.Builder.ConstructiveTrace.to_message tb)
        in
        let bs = Bytes.unsafe_of_string bs_str in
        if Bytes.length bs = 0 then len else write_segment len bs
      in
      let newlen = List.fold_left write_trace 0 trace_builders in
        if buildlogtrace then
          log_debug (fun l -> l "[buildlog] trace store - total %d bytes" newlen);
        Ok newlen
      with CouldNotTrace msg -> Error msg

  let copy_filtered_traces_in_file ?topological_order ~filter
      ?dependency_trace_filter ~srcfd ~destfd () =
    let exception PartialTraces of string in
    let (_offset : int) = Unix.lseek srcfd 0 Unix.SEEK_SET in
    match
      read_semitraces_exn ~on_fail:(fun _acc s -> PartialTraces s) srcfd
    with
    | traces -> begin
        let semitraces = load_semitraces traces in
        let semitraces =
          match topological_order with
          | None -> semitraces
          | Some () -> begin
              match BuildTrace'.sort_semitraces_topologically semitraces with
              | Ok sorted -> sorted
              | Error msg -> raise (PartialTraces msg)
            end
        in
        let filtered =
          match dependency_trace_filter with
          | None ->
              List.filter
                (fun ({ key; raw_value; _ } : BuildTrace'.semitrace) ->
                  filter key raw_value)
                semitraces
          | Some dependency_trace_filter ->
              filter_semitraces_with_dependency_closure semitraces
                ~primary_trace_filter:filter
                ~dependency_trace_filter
        in
        let (_offset : int) = Unix.lseek destfd 0 Unix.SEEK_SET in
        begin
          match
            write_proto_traces ~buildlogtrace:false
              (List.map semitrace_to_proto filtered)
              destfd
          with
          | Error msg -> Error msg
          | Ok newlen ->
              Unix.ftruncate destfd newlen;
              Ok (List.length filtered)
        end
      end
    | exception PartialTraces msg -> Error msg

  let remove_key_ids_and_dependents_in_file tracefd key_ids =
    let key_ids = StringSet.of_list key_ids in
    if StringSet.is_empty key_ids then Ok 0
    else
      let exception PartialTraces of string in
      let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_SET in
      match
        read_semitraces_exn ~on_fail:(fun _acc s -> PartialTraces s) tracefd
      with
      | traces -> (
          let semitraces = load_semitraces traces in
          let filtered, removed =
            remove_key_ids_and_dependents_from_semitraces ~key_ids semitraces
          in
          if removed = 0 then Ok 0
          else
            let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_SET in
            match
              write_proto_traces ~buildlogtrace:false
                (List.map semitrace_to_proto filtered)
                tracefd
            with
            | Error msg -> Error msg
            | Ok newlen ->
                Unix.ftruncate tracefd newlen;
                Ok removed)
      | exception PartialTraces msg -> Error msg

  let mk_value_existence_check ~valuestore_get key value_id =
    let ( let* ), return = Ctx.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

  let visit_traces_in_file0 ~build_pubkey:_ ~valuestore_get ~valuecache_get:_
      tracefd visit_trace =
    let reader_state : reader_state =
      {
        reader_generation = 0;
        buildlogtrace = false;
        value_existence_check = mk_value_existence_check ~valuestore_get;
        valuestore_get;
      }
    in
    let exception FailedRead of string in
    try
      let rec aux_partial_traces_exn () =
        match
          read_segment_frame_into_valuetraces_exn ~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 =
              Ctx.run_isolated_promise
              @@ Ctx.Promise.parallel moretraces_promises
            in
            List.iter
              (fun (trace, `TraceSize sz) ->
                match trace with
                | None -> ()
                | Some
                    ({ generation = _; key; dependencies; result } :
                      Ctx.State.trace) ->
                    visit_trace sz key dependencies result)
              moretraces;
            aux_partial_traces_exn ()
      in
      aux_partial_traces_exn ();
      Ok ()
    with FailedRead msg -> Error msg

  let visit_traces_in_file ?topological_order
      ?(visit_trace_filter = fun _key _raw_value -> true) ~build_pubkey
      ~valuestore_get ~valuecache_get tracefd visit_trace =
    match topological_order with
    | None ->
        visit_traces_in_file0 ~build_pubkey ~valuestore_get ~valuecache_get
          tracefd visit_trace
    | Some () -> (
        (* unordered read all traces *)
        let ( let* ), return = Ctx.Promise.(bind, return) in

        let exception PartialTraces of string in
        match
          read_semitraces_exn ~on_fail:(fun _acc s -> PartialTraces s) tracefd
        with
        | traces ->
            (* load traces from the file *)
            let unsorted_traces = load_semitraces traces in
            (* List.iter
            (fun ({
                    BuildTrace.key;
                    key_kvhash_deps = _;
                    raw_sz32 = _;
                    raw_sz = _;
                    raw_value = _;
                  } :
                   BuildTrace'.semitrace) ->
              Printf.eprintf "[troubleshoot] unsorted trace %s\n"
                (Ctx.K.show key))
            unsorted_traces; *)
            (* sort them *)
            let toposort_result =
              BuildTrace'.sort_semitraces_topologically unsorted_traces
            in
            begin
              match toposort_result with
              | Ok sorted_traces ->
                  (* List.iter
                  (fun ({
                          BuildTrace.key;
                          key_kvhash_deps = _;
                          raw_sz32 = _;
                          raw_sz = _;
                          raw_value = _;
                        } :
                         BuildTrace'.semitrace) ->
                    Printf.eprintf "[troubleshoot] sorted trace %s\n"
                      (Ctx.K.show key))
                  sorted_traces; *)
                  (* construct reader state *)
                  let rstate : reader_state =
                    {
                      reader_generation = 0;
                      buildlogtrace = false;
                      value_existence_check =
                        mk_value_existence_check ~valuestore_get;
                      valuestore_get;
                    }
                  in
                  (* visit sorted traces. queue up the problems since:

                   1. the
                   [valuestore_get] or [valuecache_get] may be accumulating
                   "good" results for callers like the [query] command.
                   2. we want to run [visit_trace]. *)
                  let problems = Queue.create () in
                  let g
                      ({ key; key_kvhash_deps; raw_sz32; raw_sz; raw_value } :
                        BuildTrace'.semitrace) =
                    if visit_trace_filter key raw_value then
                      let* maybe_valuetrace =
                        complete_valuetrace
                          ~on_problem:(fun s ->
                            if Queue.length problems < 10 then
                              Queue.add s problems)
                          ~k:key
                          ~k_show:(fun () -> Ctx.K.show key)
                          ~deps:key_kvhash_deps ~tracesz32:raw_sz32 rstate
                          raw_value
                      in
                      match maybe_valuetrace with
                      | None ->
                          (* Printf.eprintf
                          "[troubleshoot] could not complete sorted trace %s\n"
                          (Ctx.K.show key); *)
                          return None
                      | Some valuetrace -> return (Some (raw_sz, valuetrace))
                    else return None
                  in
                  let sorted_promises = List.map g sorted_traces in
                  let sorted_valuetraces =
                    Ctx.run_isolated_promise
                      (Ctx.Promise.parallel sorted_promises)
                  in
                  List.iter
                    (fun ( raw_sz,
                           ({ generation = _; key; dependencies; result } :
                             Ctx.State.trace) ) ->
                      (* Printf.eprintf
                      "[troubleshoot] visit sorted trace %s. %d deps. %ld b\n"
                      (Ctx.K.show key)
                      (List.length dependencies) (Int32.of_int raw_sz); *)
                      visit_trace raw_sz key dependencies result)
                    (List.filter_map Fun.id sorted_valuetraces);

                  (* spill out problems, if any *)
                  if Queue.is_empty problems then Ok ()
                  else
                    let msgs =
                      Queue.fold
                        (fun acc p -> ("[problem] " ^ Problem.show p) :: acc)
                        [] problems
                    in
                    Error (String.concat "\n" (List.rev msgs))
              | Error msg -> Error msg
            end
        | exception PartialTraces msg -> Error msg)

  let get_apply_aliases ctx =
    let open Ctx.Syntax in
    let* state = get in
    Assumptions
    .both_tracestore_and_lockfiles_resolve_build_metadata_for_user_module_keys
      ();
    return (Ctx.State.apply_aliases ~build_number:(Ctx.build_number ctx) state)

  let write_traces ctx traces tracefd =
    let buildlogtrace = Ctx.buildlogtrace ctx in
    let valuestore = Ctx.valuestore_maybe_relto_basedir ctx in
    let dtraces_promise =
      let ( let* ), return = Ctx.Promise.(bind, return) in
      let* createdir_result =
        Ctx.Io.create_directory (Ctx.disk_dir valuestore)
      in
      match createdir_result with
      | `Error msg -> return (Error msg)
      | `Created ->
          let* traces =
            BuildTrace'.dehydrate_traces
              ?buildlogtrace:(if buildlogtrace then Some () else None)
              ~valuestore
              ~add_constant_exn:(BuildValues'.add_constant_exn ~valuestore)
              ~add_source_file_exn:
                (BuildValues'.add_source_file_exn ~valuestore)
              traces
          in
          return (Ok traces)
    in
    let dtraces_result = Ctx.run_isolated_promise dtraces_promise in
    match dtraces_result with
    | Error msg -> Error msg
    | Ok traces ->
        write_proto_traces ~buildlogtrace (List.map to_proto traces) tracefd

  let save ctx traces tracefd =
    (* Overwrite trace file by seeking to position 0. *)
    let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_SET in
    match write_traces ctx traces tracefd with
    | Error msg -> prerr_endline ("[warning] " ^ msg)
    | Ok newlen ->
        (* erase everything after [newlen] *)
        Unix.ftruncate tracefd newlen

  let append ctx traces tracefd =
    let buildlogtrace = Ctx.buildlogtrace ctx in
    (* Seek to end of file *)
    let (_offset : int) = Unix.lseek tracefd 0 Unix.SEEK_END in
    match write_traces ctx traces tracefd with
    | Error msg -> prerr_endline ("[warning] " ^ msg)
    | Ok newlen ->
        if buildlogtrace then
          log_debug (fun l ->
              l "[buildlog] trace store - added %d bytes" newlen)
end