Source file ThunkDist.ml

(** The contents of ["etc/dk/d/*.dist.json"]. It is a subset of the full
    distribution of ["distributions"] in a ["values.json"], which is represented
    by {!Dist}. *)
module DistCore = struct
  type application = {
    application_name : ThunkLexers.Ranges.t * string;
    application_version : ThunkLexers.Ranges.t * string;
  }

  type openbsd_signify_producer = {
    openbsd_signify_public_key : ThunkLexers.Ranges.t * string;
  }

  type github_slsa_v1_l2_producer = {
    github_slsa_v1_l2_repository : ThunkLexers.Ranges.t * string;
  }

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

  type producer = {
    producer_application : application option;
    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 = {
    spdx : (ThunkLexers.Ranges.t * string) option;
    plaintext : (ThunkLexers.Ranges.t * string) option;
    markdown : (ThunkLexers.Ranges.t * string) option;
  }

  type continuation_to_sign = {
    majmin : ThunkLexers.Ranges.t * int64 * int64;
    producer : producer;
  }

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

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

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

  type continuations_attestation = {
    continuations_attestation_openbsd_signify :
      openbsd_signify_attestation option;
  }

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

  type t = {
    id :
      (ThunkLexers.Ranges.t * MlFront_Core.LibraryId.t * ThunkSemver64.t) option;
    producer : producer;
    license : license;
    continuations : continuations;
  }

  let rec compare_continuation_to_sign
      ({ majmin = _range1, major1, minor1; producer = p1 } :
        continuation_to_sign)
      ({ majmin = _range2, major2, minor2; producer = p2 } :
        continuation_to_sign) =
    match Int64.compare major1 major2 with
    | 0 -> begin
        match Int64.compare minor1 minor2 with
        | 0 -> compare_producer p1 p2
        | c -> c
      end
    | c -> c

  and compare_producer
      ({
         producer_application = app1;
         producer_openbsd_signify = os1;
         producer_github_slsa_v1_l2 = g2l1;
         producer_github_slsa_v1_l3 = g3l1;
       } :
        producer)
      ({
         producer_application = app2;
         producer_openbsd_signify = os2;
         producer_github_slsa_v1_l2 = g2l2;
         producer_github_slsa_v1_l3 = g3l2;
       } :
        producer) =
    match compare_application app1 app2 with
    | 0 -> begin
        match compare_openbsd_signify os1 os2 with
        | 0 -> begin
            match compare_github_slsa_v1_l2 g2l1 g2l2 with
            | 0 -> compare_github_slsa_v1_l3 g3l1 g3l2
            | c -> c
          end
        | c -> c
      end
    | c -> c

  and compare_application (app1 : application option)
      (app2 : application option) =
    match (app1, app2) with
    | None, None -> 0
    | None, Some _ -> -1
    | Some _, None -> 1
    | ( Some { application_name = _, n1; application_version = _, v1 },
        Some { application_name = _, n2; application_version = _, v2 } ) ->
    match String.compare v1 v2 with 0 -> String.compare n1 n2 | c -> c

  and compare_openbsd_signify (os1 : openbsd_signify_producer option)
      (os2 : openbsd_signify_producer option) =
    match (os1, os2) with
    | None, None -> 0
    | None, Some _ -> -1
    | Some _, None -> 1
    | ( Some { openbsd_signify_public_key = _r1, v1 },
        Some { openbsd_signify_public_key = _r2, v2 } ) ->
        String.compare v1 v2

  and compare_github_slsa_v1_l2 (g2l1 : github_slsa_v1_l2_producer option)
      (g2l2 : github_slsa_v1_l2_producer option) =
    match (g2l1, g2l2) with
    | None, None -> 0
    | None, Some _ -> -1
    | Some _, None -> 1
    | ( Some { github_slsa_v1_l2_repository = _r1, v1 },
        Some { github_slsa_v1_l2_repository = _r2, v2 } ) ->
        String.compare v1 v2

  and compare_github_slsa_v1_l3_caller
      (a1 : [ `Organization of string | `Repository of string ])
      (a2 : [ `Organization of string | `Repository of string ]) =
    match (a1, a2) with
    | `Organization o1, `Organization o2 -> String.compare o1 o2
    | `Repository r1, `Repository r2 -> String.compare r1 r2
    | `Organization _, `Repository _ -> -1
    | `Repository _, `Organization _ -> 1

  and compare_github_slsa_v1_l3_signer
      (s1 : [ `Repository of string | `Workflow of string ])
      (s2 : [ `Repository of string | `Workflow of string ]) =
    match (s1, s2) with
    | `Repository r1, `Repository r2 -> String.compare r1 r2
    | `Workflow w1, `Workflow w2 -> String.compare w1 w2
    | `Repository _, `Workflow _ -> -1
    | `Workflow _, `Repository _ -> 1

  and compare_github_slsa_v1_l3 (g3l1 : github_slsa_v1_l3_producer option)
      (g3l2 : github_slsa_v1_l3_producer option) =
    match (g3l1, g3l2) with
    | None, None -> 0
    | None, Some _ -> -1
    | Some _, None -> 1
    | ( Some
          {
            github_slsa_v1_l3_caller = _r1, c1;
            github_slsa_v1_l3_signer = _s1, s1;
          },
        Some
          {
            github_slsa_v1_l3_caller = _r2, c2;
            github_slsa_v1_l3_signer = _s2, s2;
          } ) ->
    match compare_github_slsa_v1_l3_caller c1 c2 with
    | 0 -> compare_github_slsa_v1_l3_signer s1 s2
    | c -> c

  and compare_license ({ spdx = s1; plaintext = p1; markdown = m1 } : license)
      ({ spdx = s2; plaintext = p2; markdown = m2 } : license) =
    match Option.compare compare_snd_string s1 s2 with
    | 0 -> begin
        match Option.compare compare_snd_string p1 p2 with
        | 0 -> Option.compare compare_snd_string m1 m2
        | c -> c
      end
    | c -> c

  and compare_continuations_attestation
      ({ continuations_attestation_openbsd_signify = os1 } :
        continuations_attestation)
      ({ continuations_attestation_openbsd_signify = os2 } :
        continuations_attestation) =
    Option.compare compare_openbsd_signify_attestation os1 os2

  and compare_openbsd_signify_attestation (os1 : openbsd_signify_attestation)
      (os2 : openbsd_signify_attestation) =
    match (os1, os2) with
    | ( { openbsd_signify_signature = Some (_r1, v1) },
        { openbsd_signify_signature = Some (_r2, v2) } ) ->
        String.compare v1 v2
    | { openbsd_signify_signature = None }, { openbsd_signify_signature = None }
      ->
        0
    | ( { openbsd_signify_signature = None },
        { openbsd_signify_signature = Some _ } ) ->
        -1
    | ( { openbsd_signify_signature = Some _ },
        { openbsd_signify_signature = None } ) ->
        1

  and compare_snd_string (_, a) (_, b) = String.compare a b
end

module Dist = struct
  open DistCore

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

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

  type build_value = { value_path : ThunkLexers.Ranges.t * string }

  type build_store_group = {
    build_group_traces : build_trace list;
    build_group_values : build_value list;
  }

  type build_to_sign = {
    build_bundle_modver :
      ThunkLexers.Ranges.t
      * MlFront_Core.StandardModuleId.t
      * ThunkSemver64Rep.t;
    build_modules :
      (ThunkLexers.Ranges.t
      * MlFront_Core.StandardModuleId.t
      * ThunkSemver64Rep.t)
      list;
    build_producer_accepts : (ThunkLexers.Ranges.t * string) list;
    build_bundle_canonical : ThunkLexers.Ranges.t * string;
    build_distmeta : build_store_group;
    build_package : build_store_group;
  }

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

  type t = {
    id : ThunkLexers.Ranges.t * MlFront_Core.LibraryId.t * ThunkSemver64Rep.t;
    producer : producer;
    license : license;
    continuations : continuations;
    build : build;
  }

  let library_id ({ id = _range, library_id, _version; _ } : t) = library_id
  let version ({ id = _range, _library_id, version; _ } : t) = version

  let compare_build_value ({ value_path = a } : build_value)
      ({ value_path = b } : build_value) =
    String.compare (snd a) (snd b)

  let compare_build_trace ({ trace_tag = a; trace_path = ap } : build_trace)
      ({ trace_tag = b; trace_path = bp } : build_trace) =
    match String.compare (snd a) (snd b) with
    | 0 -> String.compare (snd ap) (snd bp)
    | c -> c

end

module Parsers = struct
  open ThunkParsers.JsonParsers

  let parse_major_minor s =
    match (String.split_on_char '.') s with
    | [ major; minor ] -> begin
        match (Int64.of_string_opt major, Int64.of_string_opt minor) with
        | Some major, Some minor when major >= 0L && minor >= 0L ->
            Ok (major, minor)
        | _ -> Error "The MAJOR.MINOR version must be in the form X.Y"
      end
    | _ -> Error "The MAJOR.MINOR version must be in the form X.Y"

  module Parser = struct
    (** Extend the JSON parser to also parse the contents of the JSON. *)
    module MakeCExtended
        (CJson' :
          ThunkParsers.JsonParsers.Parser.CJSON
            with type attr = AttrForFmlib.t
             and type json = JsonForFmlib.t) =
    struct
      open CJson'

      (** {2 DistCore} *)

      open DistCore

      let cast_application j =
        let* range_name, value_name = cast_string_field "name" j in
        let* range_version, value_version = cast_string_field "version" j in
        return
          {
            application_name = (range_name, value_name);
            application_version = (range_version, value_version);
          }

      let cast_openbsd_signify_public j =
        let* range, value = cast_string_field "public_key" j in
        return { openbsd_signify_public_key = (range, value) }

      let cast_github_slsa_v1_l2_public j =
        let* range, value = cast_string_field "repository" j in
        return { github_slsa_v1_l2_repository = (range, value) }

      let cast_github_slsa_v1_l3_public j =
        let* organization = getmember_opt "organization" j in
        let* repository = getmember_opt "repository" j in
        let* caller_range, caller_value =
          match (organization, repository) with
          | Some _, Some _ ->
              let* range = attr j in
              fail
                (ThunkParsers.Results.Semantic.create
                   (ThunkLexers.Ranges.inner_range range)
                   "GitHub SLSA v1.3 producer cannot have both `organization` \
                    and `repository`")
          | None, None ->
              let* range = attr j in
              fail
                (ThunkParsers.Results.Semantic.create
                   (ThunkLexers.Ranges.inner_range range)
                   "GitHub SLSA v1.3 producer must have either `organization` \
                    or `repository`")
          | Some org, None ->
              let* range = attr org in
              let* value = cast_string org in
              return (range, `Organization value)
          | None, Some repo ->
              let* range = attr repo in
              let* value = cast_string repo in
              return (range, `Repository value)
        in

        let* signer_repository = getmember_opt "signer_repository" j in
        let* signer_workflow = getmember_opt "signer_workflow" j in
        let* signer_range, signer_value =
          match (signer_repository, signer_workflow) with
          | Some _, Some _ ->
              let* range = attr j in
              fail
                (ThunkParsers.Results.Semantic.create
                   (ThunkLexers.Ranges.inner_range range)
                   "GitHub SLSA v1.3 producer cannot have both \
                    `signer_repository` and `signer_workflow`")
          | None, None ->
              let* range = attr j in
              fail
                (ThunkParsers.Results.Semantic.create
                   (ThunkLexers.Ranges.inner_range range)
                   "GitHub SLSA v1.3 producer must have either \
                    `signer_repository` or `signer_workflow`")
          | Some repo, None ->
              let* range = attr repo in
              let* value = cast_string repo in
              return (range, `Repository value)
          | None, Some workflow ->
              let* range = attr workflow in
              let* value = cast_string workflow in
              return (range, `Workflow value)
        in

        return
          {
            github_slsa_v1_l3_caller = (caller_range, caller_value);
            github_slsa_v1_l3_signer = (signer_range, signer_value);
          }

      let cast_producer j =
        let* application = getmember_opt "application" j in
        let* openbsd_signify = getmember_opt "openbsd_signify" j in
        let* github_slsa_v1_l2 = getmember_opt "github_slsa_v1_l2" j in
        let* github_slsa_v1_l3 = getmember_opt "github_slsa_v1_l3" j in
        let* application = if_some application cast_application in
        let* openbsd_signify =
          if_some openbsd_signify cast_openbsd_signify_public
        in
        let* github_slsa_v1_l2 =
          if_some github_slsa_v1_l2 cast_github_slsa_v1_l2_public
        in
        let* github_slsa_v1_l3 =
          if_some github_slsa_v1_l3 cast_github_slsa_v1_l3_public
        in
        match (openbsd_signify, github_slsa_v1_l2, github_slsa_v1_l3) with
        | None, None, None ->
            let* range = attr j in
            fail
              (ThunkParsers.Results.Semantic.create
                 (ThunkLexers.Ranges.inner_range range)
                 "Producer must have at least one attestation method")
        | ( producer_openbsd_signify,
            producer_github_slsa_v1_l2,
            producer_github_slsa_v1_l3 ) ->
            return
              {
                producer_application = application;
                producer_openbsd_signify;
                producer_github_slsa_v1_l2;
                producer_github_slsa_v1_l3;
              }

      let cast_license j =
        let* spdx = getmember_opt "spdx" j in
        let* plaintext = getmember_opt "plaintext" j in
        let* markdown = getmember_opt "markdown" j in
        let* spdx = if_some spdx cast_attr_string in
        let* plaintext = if_some plaintext cast_attr_string in
        let* markdown = if_some markdown cast_attr_string in
        match (spdx, plaintext, markdown) with
        | None, None, None ->
            let* range = attr j in
            fail
              (ThunkParsers.Results.Semantic.create
                 (ThunkLexers.Ranges.inner_range range)
                 "License must have at least one field")
        | _ -> return { spdx; plaintext; markdown }

      let cast_continuation_to_sign majmin j =
        let* producer = cast_producer j in
        return { majmin; producer }

      let cast_openbsd_signify_attestation j =
        let* signature_ = getmember_opt "signature" j in
        let* range_value = if_some signature_ cast_attr_string in
        return { openbsd_signify_signature = range_value }

      let cast_github_slsa_v1_l2_attestation j =
        let* github_slsa_v1_l2_doc = getmember_opt "doc" j in
        return { github_slsa_v1_l2_doc }

      let cast_github_slsa_v1_l3_attestation j =
        let* github_slsa_v1_l3_doc = getmember_opt "doc" j in
        return { github_slsa_v1_l3_doc }

      let cast_continuations_attestation j =
        let* openbsd_signify = getmember "openbsd_signify" j in
        let* continuations_attestation_openbsd_signify =
          cast_openbsd_signify_attestation openbsd_signify
        in
        return
          {
            continuations_attestation_openbsd_signify =
              Some continuations_attestation_openbsd_signify;
          }

      let cast_continuations j =
        let* continuations_attestation = getmember_opt "attestation" j in
        let* continuations_attestation =
          if_some continuations_attestation cast_continuations_attestation
        in
        let* continuations_to_sign = getmember "continuations_to_sign" j in
        let* continuations_to_sign =
          for_all_members
            (fun fieldname namerange value ->
              match parse_major_minor fieldname with
              | Error msg ->
                  fail
                    (ThunkParsers.Results.Semantic.create
                       (ThunkLexers.Ranges.inner_range namerange)
                       msg)
              | Ok (major, minor) ->
                  cast_continuation_to_sign (namerange, major, minor) value)
            continuations_to_sign
        in
        return { continuations_attestation; continuations_to_sign }

      let cast_dist_core j =
        let module ResultObserver =
          ThunkParsers.Results.MakeObserverWithDiagnoseErrors
            (Diagnose.Diagnose.ConsolePlainStyle) in
        let module_or =
          (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
        in
        let* state = get in
        let* idfield = getmember "id" j in
        let* idvaluerange = attr idfield in
        let* _idnamerange, id = cast_string_field "id" j in
        match
          ThunkCommand.InternalUse.parse_libraryversion_full module_or state
            (Some idvaluerange) id
        with
        | Error s -> fail s
        | Ok (id, version) ->
            let* producer = getmember "producer" j in
            let* license = getmember "license" j in
            let* continuations = getmember "continuations" j in
            let* producer = cast_producer producer in
            let* license = cast_license license in
            let* continuations = cast_continuations continuations in
            return
              {
                id = Some (idvaluerange, id, version);
                producer;
                license;
                continuations;
              }

      (** {2 Dist} *)

      open Dist

      let with_attr f j =
        let* range = attr j in
        let* v = f j in
        return (range, v)

      let module_or =
        let module ResultObserver =
          ThunkParsers.Results.MakeObserverWithDiagnoseErrors
            (Diagnose.Diagnose.ConsolePlainStyle) in
        (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)

      let cast_attr_module_version j =
        let* state = get in
        let* range, value = cast_attr_string j in
        match
          ThunkCommand.InternalUse.parse_moduleversion_full ~package_id_opt:None
            module_or state (Some range) value
        with
        | Error s -> fail s
        | Ok { id; version } -> return (range, id, version)

      let cast_build_attestation j =
        let* openbsd_signify = getmember_opt "openbsd_signify" j in
        let* github_slsa_v1_l2 = getmember_opt "github_slsa_v1_l2" j in
        let* github_slsa_v1_l3 = getmember_opt "github_slsa_v1_l3" j in
        let* attestation_openbsd_signify =
          if_some openbsd_signify (with_attr cast_openbsd_signify_attestation)
        in
        let* attestation_github_slsa_v1_l2 =
          if_some github_slsa_v1_l2
            (with_attr cast_github_slsa_v1_l2_attestation)
        in
        let* attestation_github_slsa_v1_l3 =
          if_some github_slsa_v1_l3
            (with_attr cast_github_slsa_v1_l3_attestation)
        in
        return
          {
            attestation_openbsd_signify;
            attestation_github_slsa_v1_l2;
            attestation_github_slsa_v1_l3;
          }

      let cast_build_trace j =
        let* trace_tag = cast_string_field "tag" j in
        let* trace_path = cast_string_field "path" j in
        return { trace_tag; trace_path }

      let cast_build_value j =
        let* value_path = cast_string_field "path" j in
        return { value_path }

      let cast_build_store_group j =
        let* build_traces0 = getmember "traces" j in
        let* build_values0 = getmember "values" j in
        let* build_traces = cast_array build_traces0 in
        let* build_traces = for_all build_traces cast_build_trace in
        let* build_values = cast_array build_values0 in
        let* build_values = for_all build_values cast_build_value in
        return
          {
            build_group_traces = build_traces;
            build_group_values = build_values;
          }

      let cast_build_to_sign j =
        let* build_bundle_modver =
          (* allow bundle_id until dk0 2.6. everything after 2.5.202602270700 is encoded as bundle_modver *)
          let* bundle_id_opt = getmember_opt "bundle_id" j in
          match bundle_id_opt with
          | Some bundle_id -> return bundle_id
          | None -> getmember "bundle_modver" j
        in
        let* build_bundle_modver =
          cast_attr_module_version build_bundle_modver
        in
        let* build_modules = getmember "modules" j in
        let* build_producer_accepts = getmember "producer_accepts" j in
        let* build_bundle_canonical = cast_string_field "bundle_canonical" j in
        let* build_modules = cast_array build_modules in
        let* build_modules = for_all build_modules cast_attr_module_version in
        let* build_producer_accepts = cast_array build_producer_accepts in
        let* build_producer_accepts =
          for_all build_producer_accepts cast_attr_string
        in
        let* build_distmeta_opt = getmember_opt "distmeta" j in
        let* build_package_opt = getmember_opt "package" j in
        let* build_traces_opt = getmember_opt "traces" j in
        let* build_values_opt = getmember_opt "values" j in
        let* build_distmeta, build_package =
          match (build_distmeta_opt, build_package_opt) with
          | Some distmeta, Some package ->
              let* build_distmeta = cast_build_store_group distmeta in
              let* build_package = cast_build_store_group package in
              return (build_distmeta, build_package)
          | Some distmeta, None ->
              let* build_distmeta = cast_build_store_group distmeta in
              return
                ( build_distmeta,
                  { build_group_traces = []; build_group_values = [] } )
          | None, Some package ->
              let* build_package = cast_build_store_group package in
              return
                ( { build_group_traces = []; build_group_values = [] },
                  build_package )
          | None, None -> begin
              let* build_traces0 =
                match build_traces_opt with
                | Some traces -> return traces
                | None -> getmember "traces" j
              in
              let* build_values0 =
                match build_values_opt with
                | Some values -> return values
                | None -> begin
                    let* values_opt = getmember_opt "values" j in
                    match values_opt with
                    | Some values -> return values
                    | None ->
                        return
                          (`Array ([], ThunkLexers.Ranges.Raw_range
                                          Fmlib_parse.Position.(start, start)))
                  end
              in
              let* build_traces = cast_array build_traces0 in
              let* build_traces = for_all build_traces cast_build_trace in
              let* build_values = cast_array build_values0 in
              let* build_values = for_all build_values cast_build_value in
              return
                ( { build_group_traces = build_traces; build_group_values = build_values },
                  { build_group_traces = []; build_group_values = [] } )
            end
        in
        return
          {
            build_bundle_modver;
            build_modules;
            build_producer_accepts;
            build_bundle_canonical;
            build_distmeta;
            build_package;
          }

      let cast_build j =
        let* build_attestation = getmember_opt "attestation" j in
        let* build_attestation =
          if_some build_attestation cast_build_attestation
        in
        let* build_to_sign = getmember "build_to_sign" j in
        let* build_to_sign = cast_build_to_sign build_to_sign in
        return { build_attestation; build_to_sign }

      let cast_dist j =
        let* state = get in
        let* idfield = getmember "id" j in
        let* idvaluerange = attr idfield in
        let* _idnamerange, id = cast_string_field "id" j in
        match
          ThunkCommand.InternalUse.parse_libraryversion_full module_or state
            (Some idvaluerange) id
        with
        | Error s -> fail s
        | Ok (id, version) ->
            let* producer = getmember "producer" j in
            let* license = getmember "license" j in
            let* continuations = getmember "continuations" j in
            let* producer = cast_producer producer in
            let* license = cast_license license in
            let* continuations = cast_continuations continuations in
            let* build = getmember "build" j in
            let* build = cast_build build in
            return
              {
                id = (idvaluerange, id, version);
                producer;
                license;
                continuations;
                build;
              }
    end

    module Core = struct
      module CJson = Parser.MakeCJson (DistCore) (AttrForFmlib) (JsonForFmlib)

      include CJson.Parser
      (** Include parsing functions to get the final value, etc. *)

      module CExtended = struct
        open CJson
        include MakeCExtended (CJson)

        let dist_core () : DistCore.t t =
          let* j = json () in
          cast_dist_core j
      end

      let parse sourcestate : t =
        CJson.make sourcestate (CExtended.dist_core ())
    end

    module CJson = Parser.MakeCJson (Dist) (AttrForFmlib) (JsonForFmlib)

    include CJson.Parser
    (** Include parsing functions to get the final value, etc. *)

    module CExtended = struct
      open CJson
      include MakeCExtended (CJson)

      let dist () : Dist.t t =
        let* j = json () in
        cast_dist j
    end

    let parse sourcestate : t = CJson.make sourcestate (CExtended.dist ())
  end

  (** The complete parser for {!DistCore}. *)
  module PLCore = struct
    open Fmlib_parse
    open ThunkLexers.JsonLexer
    open ThunkParsers

    include
      Parse_with_lexer.Make_utf8 (Results.State) (Token) (DistCore)
        (Results.Semantic)
        (Lexer)
        (Parser.Core)

    let start sourcestate rangeplus : t =
      make
        (Lexer.start_at ?pos:(Option.map ThunkLexers.Ranges.start rangeplus) ())
        (Parser.Core.parse sourcestate)
  end

  (** The complete parser for {!Dist}. *)
  module PL = struct
    open Fmlib_parse
    open ThunkLexers.JsonLexer
    open ThunkParsers

    include
      Parse_with_lexer.Make_utf8 (Results.State) (Token) (Dist)
        (Results.Semantic)
        (Lexer)
        (Parser)

    let start sourcestate rangeplus : t =
      make
        (Lexer.start_at ?pos:(Option.map ThunkLexers.Ranges.start rangeplus) ())
        (Parser.parse sourcestate)
  end
end

let rangeempty = Fmlib_parse.Position.(start, start)

module Io (M : BuildConstraints.MONAD_PROMISE) = struct
  open ThunkIo.Make (M)

  let parse ?downgrade_errors_into_warnings
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
      (file : file_object) : _ result M.t =
    let ( let* ) = M.bind in
    let* c = read_all file in
    match c with
    | `Content s ->
        Assumptions.core_distribution_has_unix_byte_positions ();
        let s = ThunkStrings.dos2unix s in
        let sourcestate =
          ThunkParsers.Results.State.create_with_source
            ?downgrade_errors_into_warnings ~origin:(file_origin file) s
        in
        let parser = Parsers.PL.start sourcestate None in
        let parser = Parsers.PL.run_on_string s parser in
        let module H = ResultObserver.Make (Parsers.PL) in
        let res =
          H.observe ~cant_do:"parse the distribution" ~source:s sourcestate
            parser
        in
        M.pure res
    | `Error msg ->
        M.pure (Error (ThunkParsers.Results.Semantic.create rangeempty msg))
    | `ExceededSizeLimit limit ->
        M.pure
          (Error
             (ThunkParsers.Results.Semantic.create rangeempty
                (Printf.sprintf "File size exceeded limit: %Ld" limit)))

  let parse_core ?downgrade_errors_into_warnings
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
      (file : file_object) : _ result M.t =
    let ( let* ) = M.bind in
    let* c = read_all file in
    match c with
    | `Content s ->
        Assumptions.core_distribution_has_unix_byte_positions ();
        let s = ThunkStrings.dos2unix s in
        let sourcestate =
          ThunkParsers.Results.State.create_with_source
            ?downgrade_errors_into_warnings ~origin:(file_origin file) s
        in
        let parser = Parsers.PLCore.start sourcestate None in
        let parser = Parsers.PLCore.run_on_string s parser in
        let module H = ResultObserver.Make (Parsers.PLCore) in
        let res =
          H.observe ~cant_do:"parse the dist" ~source:s sourcestate parser
        in
        M.pure res
    | `Error msg ->
        M.pure (Error (ThunkParsers.Results.Semantic.create rangeempty msg))
    | `ExceededSizeLimit limit ->
        M.pure
          (Error
             (ThunkParsers.Results.Semantic.create rangeempty
                (Printf.sprintf "File size exceeded limit: %Ld" limit)))
end

let canonical_producer : DistCore.producer -> YojsonI.Safe.t = function
  | {
      producer_application;
      producer_openbsd_signify;
      producer_github_slsa_v1_l2;
      producer_github_slsa_v1_l3;
    } ->
      let application =
        match producer_application with
        | Some { application_name = _, name; application_version = _, version }
          ->
            [
              ( "application",
                `Assoc [ ("name", `String name); ("version", `String version) ]
              );
            ]
        | None -> []
      in
      let openbsd_signify =
        match producer_openbsd_signify with
        | Some { openbsd_signify_public_key = _range, key } ->
            [ ("openbsd_signify", `Assoc [ ("public_key", `String key) ]) ]
        | None -> []
      in
      let github_slsa_v1_l2 =
        match producer_github_slsa_v1_l2 with
        | Some { github_slsa_v1_l2_repository = _range, repo } ->
            [ ("github_slsa_v1_l2", `Assoc [ ("repository", `String repo) ]) ]
        | None -> []
      in
      let github_slsa_v1_l3 =
        match producer_github_slsa_v1_l3 with
        | Some
            {
              github_slsa_v1_l3_caller = _range1, caller;
              github_slsa_v1_l3_signer = _range2, signer;
            } ->
            let caller_name, caller_value =
              match caller with
              | `Organization org -> ("organization", org)
              | `Repository repo -> ("repository", repo)
            in
            let signer_name, signer_value =
              match signer with
              | `Workflow wf -> ("signer_workflow", wf)
              | `Repository repo -> ("signer_repository", repo)
            in
            [
              ( "github_slsa_v1_l3",
                `Assoc
                  [
                    (caller_name, `String caller_value);
                    (signer_name, `String signer_value);
                  ] );
            ]
        | None -> []
      in
      (* dev: ensure lexographic order *)
      `Assoc
        (application @ github_slsa_v1_l2 @ github_slsa_v1_l3 @ openbsd_signify)

let canonical_license : DistCore.license -> YojsonI.Safe.t = function
  | { spdx; plaintext; markdown } ->
      let markdown =
        match markdown with
        | Some (_range, s) -> [ ("markdown", `String s) ]
        | None -> []
      in
      let plaintext =
        match plaintext with
        | Some (_range, s) -> [ ("plaintext", `String s) ]
        | None -> []
      in
      let spdx =
        match spdx with
        | Some (_range, s) -> [ ("spdx", `String s) ]
        | None -> []
      in
      `Assoc (markdown @ plaintext @ spdx)

let canonical_continuations_to_sign continuations_to_sign =
  let canonical_continuation_to_sign :
      DistCore.continuation_to_sign -> string * YojsonI.Safe.t = function
    | { majmin = _range, major, minor; producer } ->
        (Printf.sprintf "%Ld.%Ld" major minor, canonical_producer producer)
  in
  let to_sign_assoclist =
    let to_sign =
      List.map canonical_continuation_to_sign continuations_to_sign
    in
    (* sort by string(MAJOR.MINOR) *)
    List.sort (fun (a, _) (b, _) -> String.compare a b) to_sign
  in
  `Assoc to_sign_assoclist

let canonical_continuations : DistCore.continuations -> YojsonI.Safe.t =
  let canonical_continuations_attestation :
      DistCore.continuations_attestation -> YojsonI.Safe.t = function
    | {
        continuations_attestation_openbsd_signify =
          Some { openbsd_signify_signature = Some (_range, sigv) };
      } ->
        `Assoc [ ("openbsd_signify", `Assoc [ ("signature", `String sigv) ]) ]
    | { continuations_attestation_openbsd_signify = _ } ->
        `Assoc [ ("openbsd_signify", `Assoc []) ]
  in
  function
  | { continuations_attestation; continuations_to_sign } ->
      let attestation =
        match continuations_attestation with
        | None -> []
        | Some a -> [ ("attestation", canonical_continuations_attestation a) ]
      in
      `Assoc
        (attestation
        @ [
            ( "continuations_to_sign",
              canonical_continuations_to_sign continuations_to_sign );
          ])

(** For a canonical build attestation, each of the attestation types needs to be
    present and empty so that after-the-fact attestation like GitHub SLSA L2
    have an anchor point in the JSON. Without the anchor point, the attestation
    can't be detached cleanly (ie. the attestation verification must still work,
    and most of them are SHA256 based so the bytes must be exact). *)
let canonical_build_attestation :
    Dist.build_attestation option -> YojsonI.Safe.t =
  let assemble ~attestation_openbsd_signify ~attestation_github_slsa_v1_l2
      ~attestation_github_slsa_v1_l3 =
    let openbsd_signify =
      match
        (attestation_openbsd_signify
          : (ThunkLexers.Ranges.t * DistCore.openbsd_signify_attestation) option)
      with
      | Some (_range1, { openbsd_signify_signature = Some (_range2, sigv) }) ->
          [ ("openbsd_signify", `Assoc [ ("signature", `String sigv) ]) ]
      | _ -> [ ("openbsd_signify", `Assoc []) ]
    in
    let github_slsa_v1_l2 =
      match
        (attestation_github_slsa_v1_l2
          : (ThunkLexers.Ranges.t * DistCore.github_slsa_v1_l2_attestation)
            option)
      with
      | Some (_range, { github_slsa_v1_l2_doc = Some github_slsa_v1_l2_doc }) ->
          [
            ( "github_slsa_v1_l2",
              `Assoc
                [
                  ( "doc",
                    ThunkParsers.JsonParsers.json_for_fmlib_to_yojson
                      github_slsa_v1_l2_doc );
                ] );
          ]
      | _ -> [ ("github_slsa_v1_l2", `Assoc []) ]
    in
    let github_slsa_v1_l3 =
      match
        (attestation_github_slsa_v1_l3
          : (ThunkLexers.Ranges.t * DistCore.github_slsa_v1_l3_attestation)
            option)
      with
      | Some (_range, { github_slsa_v1_l3_doc = Some github_slsa_v1_l3_doc }) ->
          [
            ( "github_slsa_v1_l3",
              `Assoc
                [
                  ( "doc",
                    ThunkParsers.JsonParsers.json_for_fmlib_to_yojson
                      github_slsa_v1_l3_doc );
                ] );
          ]
      | _ -> [ ("github_slsa_v1_l3", `Assoc []) ]
    in
    (* dev: ensure lexographic order *)
    `Assoc (github_slsa_v1_l2 @ github_slsa_v1_l3 @ openbsd_signify)
  in
  function
  | Some
      {
        attestation_openbsd_signify;
        attestation_github_slsa_v1_l2;
        attestation_github_slsa_v1_l3;
      } ->
      assemble ~attestation_openbsd_signify ~attestation_github_slsa_v1_l2
        ~attestation_github_slsa_v1_l3
  | None ->
      assemble ~attestation_openbsd_signify:None
        ~attestation_github_slsa_v1_l2:None ~attestation_github_slsa_v1_l3:None

let id_of_library_version library_id version =
  Printf.sprintf "%s@%s"
    (MlFront_Core.LibraryId.full_name library_id)
    (ThunkSemver64.to_string version)

let yojson ~canonical:_ : Dist.t -> YojsonI.Safe.t =
  let build_yojson : Dist.build -> YojsonI.Safe.t = function
    | { build_attestation; build_to_sign } ->
        let build_trace_yojson : Dist.build_trace -> YojsonI.Safe.t = function
          | { trace_tag = _range, tag; trace_path = _range2, path } ->
              `Assoc [ ("tag", `String tag); ("path", `String path) ]
        in
        let build_value_yojson : Dist.build_value -> YojsonI.Safe.t = function
          | { value_path = _range, path } -> `Assoc [ ("path", `String path) ]
        in
        let build_store_group_yojson :
            Dist.build_store_group -> YojsonI.Safe.t = function
          | { build_group_traces; build_group_values } ->
              let build_traces =
                `List (List.map build_trace_yojson build_group_traces)
              in
              let build_values =
                `List (List.map build_value_yojson build_group_values)
              in
              `Assoc [ ("traces", build_traces); ("values", build_values) ]
        in
        let build_to_sign_yojson : Dist.build_to_sign -> YojsonI.Safe.t =
          function
          | {
              build_bundle_canonical = _range2, bundle_canonical;
              build_bundle_modver = _range, bundle_module_id, bundle_semver;
              build_modules;
              build_producer_accepts;
              build_distmeta;
              build_package;
            } ->
              let build_modules =
                `List
                  (List.map
                     (fun (_range, id, version) ->
                       `String
                         (Printf.sprintf "%s@%s"
                            (MlFront_Core.StandardModuleId.show_dot id)
                            (ThunkSemver64.to_string version)))
                     build_modules)
              in
              let build_producer_accepts =
                `List
                  (List.map
                     (fun (_range, s) -> `String s)
                     build_producer_accepts)
              in
              `Assoc
                [
                  ("bundle_canonical", `String bundle_canonical);
                  ( "bundle_modver",
                   `String
                       (Printf.sprintf "%s@%s"
                          (MlFront_Core.StandardModuleId.show_dot
                             bundle_module_id)
                          (ThunkSemver64.to_string bundle_semver)) );
                  ("modules", build_modules);
                  ("producer_accepts", build_producer_accepts);
                  ("distmeta", build_store_group_yojson build_distmeta);
                  ("package", build_store_group_yojson build_package);
                ]
        in
        let attestation =
          [ ("attestation", canonical_build_attestation build_attestation) ]
        in
        `Assoc
          (attestation
          @ [ ("build_to_sign", build_to_sign_yojson build_to_sign) ])
  in
  function
  | { id = _, library_id, version; producer; license; continuations; build } ->
      let id = id_of_library_version library_id version in
      `Assoc
        [
          ("build", build_yojson build);
          ("continuations", canonical_continuations continuations);
          ("id", `String id);
          ("license", canonical_license license);
          ("producer", canonical_producer producer);
        ]

let core_yojson ~canonical:_ : DistCore.t -> YojsonI.Safe.t = function
  | { id; producer; license; continuations } ->
      let id =
        match id with
        | Some (_, library_id, version) ->
            let id = id_of_library_version library_id version in
            [ ("id", `String id) ]
        | None -> []
      in
      `Assoc
        ([ ("continuations", canonical_continuations continuations) ]
        @ id
        @ [
            ("license", canonical_license license);
            ("producer", canonical_producer producer);
          ])

let promote_core (core : DistCore.t) (library_id : MlFront_Core.LibraryId.t)
    (version : ThunkSemver64.t) : Dist.t =
  let norange = ThunkLexers.Ranges.Raw_range rangeempty in
  let bundle_module_id =
    MlFront_Core.StandardModuleId.create_explicit ~library_id
      ~namespace_front:[] ~namespace_tail:"Distribution"
  in
  let build_bundle_modver = (norange, bundle_module_id, version) in
  let build_modules =
    Assumptions.distribution_bundle_must_be_an_exported_module ();
    [ build_bundle_modver ]
  in
  {
    id = (norange, library_id, version);
    producer = core.producer;
    license = core.license;
    continuations = core.continuations;
    build =
      {
        Dist.build_attestation = None;
        build_to_sign =
            {
              build_bundle_modver;
              build_modules;
              build_producer_accepts = [];
              build_bundle_canonical = (norange, "");
              build_distmeta =
                { build_group_traces = []; build_group_values = [] };
              build_package =
                { build_group_traces = []; build_group_values = [] };
            };
      };
  }

let build_traces ({ Dist.build_distmeta; build_package; _ } : Dist.build_to_sign) =
  build_distmeta.build_group_traces @ build_package.build_group_traces

let build_values ({ Dist.build_distmeta; build_package; _ } : Dist.build_to_sign)
    =
  build_distmeta.build_group_values @ build_package.build_group_values

let demote (dist : Dist.t) : DistCore.t =
  {
    id = Some dist.id;
    producer = dist.producer;
    license = dist.license;
    continuations = dist.continuations;
  }

let pp ppf t =
  let json = yojson ~canonical:false t in
  YojsonI.Safe.pretty_print ~std:true ppf json

let pp_core ppf t =
  let json = core_yojson ~canonical:false t in
  YojsonI.Safe.pretty_print ~std:true ppf json

let canonicalize_continuations_to_sign to_sign =
  YojsonI.Safe.to_string ~std:true (canonical_continuations_to_sign to_sign)

let canonical_continuations_to_sign_id to_sign =
  Digestif.SHA256.to_hex
  @@ Digestif.SHA256.digest_string (canonicalize_continuations_to_sign to_sign)

let canonicalize dist =
  YojsonI.Safe.to_string ~std:true (yojson ~canonical:true dist)

let canonical_id dist =
  Digestif.SHA256.to_hex @@ Digestif.SHA256.digest_string (canonicalize dist)

module InternalUse = struct
  module CDistExtensions
      (CJson :
        ThunkParsers.JsonParsers.Parser.CJSON
          with type attr = ThunkLexers.Ranges.t
           and type json = ThunkParsers.JsonParsers.json_for_fmlib) =
  struct
    let cast_dist (j : CJson.json) : Dist.t CJson.t =
      let module DParser = Parsers.Parser.MakeCExtended (CJson) in
      DParser.cast_dist j
  end

  let parse_major_minor = Parsers.parse_major_minor
  let id_of_library_version = id_of_library_version
end

include Dist