Source file ThunkAstTypes.ml

open struct
let command_type = {embed|(** The type of the AST of a thunk.

    Any change to this module, including the documentation, will cause a change
    in {!ThunkAstTypes.id}. Doing so will make existing keys in AST caches
    mismatch (assuming {!ThunkAstTypes.id} is part of the cache key), all so
    that AST caches can use OCaml {!Marshal} as a fast read/write layer. *)

type t =
  | GetObject of {
      slot : object_slot;
      id : compare_free_range * module_version;
      command_output : compare_free_range * shell_output;
      archive_member : string option;
    }
  | InstallObject of {
      slot : object_slot;
      id : compare_free_range * module_version;
      command_output : compare_free_range * shell_output;
      archive_member : string option;
    }
  | PipeObject of {
      slot : object_slot;
      id : compare_free_range * module_version;
      pipe : compare_free_range * string;
      archive_member : string option;
    }
  | EnterObject of {
      slot : object_slot;
      id : compare_free_range * module_version;
    }
  | GetAsset of {
      id : compare_free_range * module_version;
      filepath : string;
      command_output : compare_free_range * shell_output;
      archive_member : string option;
    }
  | GetBundle of {
      id : compare_free_range * module_version;
      command_output : compare_free_range * shell_output;
    }

and compare_free_range = (Fmlib_parse.Position.range[@compare fun _a _b -> 0])
and object_slot = string list

and shell_output =
  | OutputDir of { dir : evalable_term; strip : int }
  | OutputFile of evalable_term

and evalable_term = evalable_item list

and evalable_item =
  | Literal of string
  | SlotRequest of compare_free_range
  | SlotNameRequest of compare_free_range
  | SlotVariable of object_slot * compare_free_range
  | PipeVariable of string * compare_free_range
  | MoreIncludesDir
  | MoreCommandsFile
  | DirectorySeperator
  | ExecutableSuffix
  | HomeDir
  | CacheDir
  | DataDir
  | ConfigDir
  | StateDir
  | RuntimeDir

and module_version = {
  id : MlFront_Core.StandardModuleId.t;
  version : ThunkSemver64.t;
}
[@@deriving ord]
|embed}

let ast_type = {embed|(** The type of the AST of a thunk.

    Any change to this module, including the documentation, will cause a change
    in {!ThunkAstTypes.id}. Doing so will make existing keys in AST caches
    mismatch (assuming {!ThunkAstTypes.id} is part of the cache key), all so
    that AST caches can use OCaml {!Marshal} as a fast read/write layer. *)

include ThunkAstAssetType
include ThunkAstFormType
include ThunkAstDistributionType

(** {3 Data Structures}

    Hash table? O(1) lookup. Since, at least for the OCaml implementation, the
    AST is parsed and serialized using OCaml's {!Marshal}, we rarely have to
    mutate but we often have to lookup.

    Persistent? We want to treat asset invalidations as a temporary user filter
    to help when patching or build watch mode or editor undo/redo, so
    invalidations should not change the underlying AST. *)

(** Data structure for a set of distributions.

    It is a persistent hash table mapping from package versions to a pair
    [range * distribution]. *)
module DistributionTable = CCPersistentHashtbl.Make (struct
  type t = MlFront_Core.PackageId.t * ThunkSemver64Rep.t

  let equal (a_id, a_version) (b_id, b_version) =
    MlFront_Core.PackageId.compare a_id b_id = 0
    && ThunkSemver64.compare a_version b_version = 0

  let hash (id, version) =
    Hashtbl.hash (MlFront_Core.PackageId.hash id, ThunkSemver64.hash version)
end)

(** Data structure for a bundle of assets.

    It is a persistent hash table mapping from {!ThunkCommand.module_version}
    (the [bundle_id]) to a pair [range * bundle]. *)
module BundleTable = CCPersistentHashtbl.Make (struct
  type t = ThunkCommand.module_version

  let equal a b = ThunkCommand.compare_module_version a b = 0
  let hash = ThunkCommand.hash_module_version
end)

(** Data structure for a set of assets.

    It is a persistent hash table mapping from {!ThunkCommand.module_version}
    (the [bundle_id]) and the asset path to a pair [range * asset_file2]. *)
module AssetTable = CCPersistentHashtbl.Make (struct
  type t = ThunkCommand.module_version * string

  let equal (a_id, a_path) (b_id, b_path) =
    ThunkCommand.compare_module_version a_id b_id = 0
    && String.equal a_path b_path

  let hash (id, path) = Hashtbl.hash (ThunkCommand.hash_module_version id, path)
end)

(** Data structure for a set of forms.

    It is a persistent hash table mapping from {!ThunkCommand.module_version}
    (the [form_id]) to a pair [range * form]. *)
module FormTable = CCPersistentHashtbl.Make (struct
  type t = ThunkCommand.module_version

  let equal a b = ThunkCommand.compare_module_version a b = 0
  let hash = ThunkCommand.hash_module_version
end)

(** {3 Types} *)

type forms = (compare_free_range * form) FormTable.t
type bundles = (compare_free_range * bundle) BundleTable.t
type distributions = (compare_free_range * distribution) DistributionTable.t
type assets = (compare_free_range * asset_file2 * asset_origin2) AssetTable.t

type t = {
  canonical_id : string;
  bundles : bundles;
  assets : assets;
  forms : forms;
  distributions : distributions;
}
|embed}

let ast_asset_type = {embed|type asset_listing_unencrypted = { bundle_id : ThunkCommand.module_version }
and asset_listing = { origins : asset_origin2 list }

and asset_origin2 = {
  origin_name : string;
  origin_mirrors : string * string list;
}

and asset_file2 = {
  file_canonical_id : string;
  file_origin : string;
  file_path : string;
  file_checksum : asset_checksum;
  file_sz : compare_free_range * int64;
}

and asset_checksum =
  [ `Sha256 of compare_free_range * string
  | `Sha1 of compare_free_range * string ]

and compare_free_range = (Fmlib_parse.Position.range[@compare fun _a _b -> 0])
[@@deriving ord]

type asset_files = (Fmlib_parse.Position.range * asset_file2) list

type bundle = {
  bundle_canonical_id : string;
  listing_unencrypted : asset_listing_unencrypted;
  listing : asset_listing;
  asset_files : asset_files;
}

let compare_asset { bundle_canonical_id = a1; _ } { bundle_canonical_id = a2; _ }
    =
  String.compare a1 a2
|embed}

let ast_form_type = {embed|type form = {
  form_canonical_id : string;
  form_id : ThunkCommand.module_version;
  precommands : precommands;
  function_ : (compare_free_range * function_) option;
  outputs : outputs;
}

and precommands = {
  private_ : precommand_instance list;
  public_ : precommand_instance list;
}

and precommand_instance = {
  precommand_canonical_id : string;
  precommand : compare_free_range * ThunkCommand.t;
}

and function_ = {
  args : ThunkCommand.evalable_term * ThunkCommand.evalable_term list;
  envmods : (compare_free_range * envmod) list;
}

and outputs = { files : compare_free_range * output * output list }

and output = {
  slots : ranged_slot * ranged_slot list;
  paths : ranged_path * ranged_path list;
}

and ranged_slot = compare_free_range * ThunkCommand.object_slot
and ranged_path = compare_free_range * string

and envmod =
  | AddEnv of { envname : string; envvalue : ThunkCommand.evalable_term }
  | RemoveEnv of string
  | PrependPathEnv of {
      pathenvname : string;
      pathenvvalue : ThunkCommand.evalable_term;
    }

and compare_free_range = (Fmlib_parse.Position.range[@compare fun _a _b -> 0])
[@@deriving ord]
|embed}

let ast_distribution_type = {embed|type openbsd_signify_producer = ThunkDist.DistCore.openbsd_signify_producer = {
  openbsd_signify_public_key : ThunkLexers.Ranges.range_plus * string;
}

type github_slsa_v1_l2_producer =
      ThunkDist.DistCore.github_slsa_v1_l2_producer = {
  github_slsa_v1_l2_repository : ThunkLexers.Ranges.range_plus * string;
}

type github_slsa_v1_l3_producer =
      ThunkDist.DistCore.github_slsa_v1_l3_producer = {
  github_slsa_v1_l3_caller :
    ThunkLexers.Ranges.range_plus
    * [ `Organization of string | `Repository of string ];
  github_slsa_v1_l3_signer :
    ThunkLexers.Ranges.range_plus
    * [ `Repository of string | `Workflow of string ];
}

type producer = ThunkDist.DistCore.producer = {
  producer_openbsd_signify : openbsd_signify_producer option;
  producer_github_slsa_v1_l2 : github_slsa_v1_l2_producer option;
  producer_github_slsa_v1_l3 : github_slsa_v1_l3_producer option;
}

type license = ThunkDist.DistCore.license = {
  spdx : (ThunkLexers.Ranges.range_plus * string) option;
  plaintext : (ThunkLexers.Ranges.range_plus * string) option;
  markdown : (ThunkLexers.Ranges.range_plus * string) option;
}

type continuation_to_sign = ThunkDist.DistCore.continuation_to_sign = {
  majmin : ThunkLexers.Ranges.range_plus * int64 * int64;
  producer : producer;
}

type openbsd_signify_attestation =
      ThunkDist.DistCore.openbsd_signify_attestation = {
  openbsd_signify_signature : (ThunkLexers.Ranges.range_plus * string) option;
}

type github_slsa_v1_l2_attestation =
      ThunkDist.DistCore.github_slsa_v1_l2_attestation = {
  github_slsa_v1_l2_doc : ThunkParsers.JsonParsers.json_for_fmlib option;
}

type github_slsa_v1_l3_attestation =
      ThunkDist.DistCore.github_slsa_v1_l3_attestation = {
  github_slsa_v1_l3_doc : ThunkParsers.JsonParsers.json_for_fmlib option;
}

type continuations_attestation =
      ThunkDist.DistCore.continuations_attestation = {
  continuations_attestation_openbsd_signify : openbsd_signify_attestation option;
}

type continuations = ThunkDist.DistCore.continuations = {
  continuations_attestation : continuations_attestation option;
  continuations_to_sign : continuation_to_sign list;
}

type dist_core = ThunkDist.DistCore.t = {
  id :
    (ThunkLexers.Ranges.range_plus
    * MlFront_Core.LibraryId.t
    * ThunkSemver64Rep.t)
    option;
  producer : producer;
  license : license;
  continuations : continuations;
}

type build_attestation = ThunkDist.build_attestation = {
  attestation_openbsd_signify :
    (ThunkLexers.Ranges.range_plus * openbsd_signify_attestation) option;
  attestation_github_slsa_v1_l2 :
    (ThunkLexers.Ranges.range_plus * github_slsa_v1_l2_attestation) option;
  attestation_github_slsa_v1_l3 :
    (ThunkLexers.Ranges.range_plus * github_slsa_v1_l3_attestation) option;
}

type build_trace = ThunkDist.build_trace = {
  trace_tag : ThunkLexers.Ranges.range_plus * string;
  trace_path : ThunkLexers.Ranges.range_plus * string;
}

type build_value = ThunkDist.build_value = {
  value_path : ThunkLexers.Ranges.range_plus * string;
}

type build_to_sign = ThunkDist.build_to_sign = {
  build_bundle_id :
    ThunkLexers.Ranges.range_plus
    * MlFront_Core.StandardModuleId.t
    * ThunkSemver64Rep.t;
  build_modules :
    (ThunkLexers.Ranges.range_plus
    * MlFront_Core.StandardModuleId.t
    * ThunkSemver64Rep.t)
    list;
  build_producer_accepts : (ThunkLexers.Ranges.range_plus * string) list;
  build_bundle_canonical : ThunkLexers.Ranges.range_plus * string;
  build_traces : build_trace * build_trace list;
  build_values : build_value list;
}

type build = ThunkDist.build = {
  build_attestation : build_attestation option;
  build_to_sign : build_to_sign;
}

type distribution = {
  distribution_canonical_id : string;
  distribution_id :
    compare_free_range * MlFront_Core.LibraryId.t * ThunkSemver64.t;
  producer : producer;
  license : license;
  continuations : continuations;
  build : build;
}

and compare_free_range = (Fmlib_parse.Position.range[@compare fun _a _b -> 0])

let compare_distribution { distribution_canonical_id = a1; _ }
    { distribution_canonical_id = a2; _ } =
  String.compare a1 a2
|embed}

let dos2unix s = let buf = Buffer.create (String.length s) in String.iter (fun c -> if c <> '\r' then Buffer.add_char buf c else ()) s; Buffer.contents buf

let normalize s = String.trim (dos2unix s)

let values_types = List.map normalize [command_type; ast_type; ast_asset_type; ast_form_type; ast_distribution_type]

(** Forms depend on ThunkCommand.module_version and more *) let form_types = List.map normalize [command_type; ast_form_type]

(** Assets depend on ThunkCommand.module_version *) let asset_types = List.map normalize [command_type; ast_asset_type]

let form_types_as_string = String.concat "\n" form_types

let asset_types_as_string = String.concat "\n" asset_types

let values_types_as_string = String.concat "\n" values_types

end

(** The identifier for all the types that would need to be serialized for a values AST. When the types change, the identifier changes. *)
let value_id = Digest.string values_types_as_string |> Digest.to_hex

(** The identifier for all the types that would need to be serialized for an bundle AST. When the types change, the identifier changes. *)
let bundle_id = Digest.string asset_types_as_string |> Digest.to_hex

(** The identifier for all the types that would need to be serialized for a form AST. When the types change, the identifier changes. *)
let form_id = Digest.string form_types_as_string |> Digest.to_hex