Source file SecDist.ml

module DistIo =
  MlFront_Thunk.ThunkDist.Io (BuildCore.Alacarte_xpromise_apparatus.Promise)

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

let dist_dir_fp = MlFront_Core.FilePath.of_string_exn "etc/dk/d"

(** [scan_dist_dir module_or] scans the distribution directory for JSON files.

    If any distribution files are found, {b all} of the distribution packages
    must belong to a single package. The package library cannot be
    ["MlFront_Attestation"] or ["MlFront_Std"], or have the vendor ["Our"].
    Confer:
    {!Assumptions.distributions_fetched_for_all_modules_except_Our_vendor_and_mlfront_modules}.

    A pair [pkg_opt, registry] is returned.

    [pkg_opt] will be the single package [Some pkg] contained in the
    distribution directory, or [None] if there were no distribution files.

    [registry] is a package registry containing the single package [pkg], or
    empty if [pkg_opt = None].

    Any error will be printed and the process will be exited. *)
let scan_dist_dir module_or =
  let quick_error msg =
    let lines = String.split_on_char '\n' msg in
    Format.eprintf "@[<v 1>FATAL: Scanning distribution files failed.@;%a@]@."
      Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
      lines;
    exit 1
  in
  let files =
    try
      Sys.readdir (MlFront_Core.FilePath.to_string dist_dir_fp) |> Array.to_list
    with Sys_error _ -> []
  in
  let json_files =
    List.filter (fun f -> Filename.check_suffix f ".dist.json") files
  in
  let read_dist_file dist_file =
    let file = BuildCore.Io.disk_file dist_file in
    match
      BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
      @@ DistIo.parse_core module_or file
    with
    | Error { error_range = _; error_message; is_rendered = _ } ->
        quick_error error_message
    | Ok dist_core -> dist_core
  in
  let show
      ({ id; producer = _; license = _; continuations = _ } :
        MlFront_Thunk.ThunkDist.DistCore.t) dist_file =
    match id with
    | None ->
        Printf.sprintf "<no distribution core id> in `%s`"
          (MlFront_Core.FilePath.to_string dist_file)
    | Some (_range, lib, ver) ->
        Printf.sprintf "%s@%s in `%s`"
          (MlFront_Core.LibraryId.full_name lib)
          (MlFront_Thunk.ThunkSemver64.to_string ver)
          (MlFront_Core.FilePath.to_string dist_file)
  in
  let registry =
    List.fold_left
      (fun registry fn ->
        let dist_file = MlFront_Core.FilePath.append_exn fn dist_dir_fp in
        let dist_core = read_dist_file dist_file in

        (* error if distribution can't be distributed *)
        Assumptions
        .mlfrontattestation_modules_are_embedded_and_cannot_be_imported ();
        if SecPackageRegistry.package_id_for_distcore dist_core = None then
          quick_error
            (Printf.sprintf
               "Distribution `%s` cannot be distributed. Distributed modules \
                cannot belong to the vendor [`Our`] or be part of the library \
                [`MlFront_Attestation`]."
               (show dist_core dist_file));

        Assumptions.distribution_entry_points_only_trace_stores_and_include_dirs
          ();
        SecPackageRegistry.accept_if_not_present
          ~on_duplicate:(fun _dist_file' msg -> quick_error ("FATAL:" ^ msg))
          dist_core dist_file registry)
      (SecPackageRegistry.create ~show ())
      json_files
  in
  match SecPackageRegistry.get_package_ids registry with
  | [] -> (None, registry)
  | [ pkg ] -> (Some pkg, registry)
  | first :: second :: _ ->
      quick_error
        (Printf.sprintf "More than one distribution package found: %s and %s"
           (MlFront_Core.PackageId.full_name first)
           (MlFront_Core.PackageId.full_name second))

(** Finders of text locations in a distribution file. *)
module Locations = struct
  open struct
    let quick_error msg =
      let lines = String.split_on_char '\n' msg in
      Format.eprintf "@[<v 1>FATAL: Parsing distribution file failed.@;%a@]@."
        Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
        lines;
      exit 1

    let read_dist_file module_or dist_file =
      let file = BuildCore.Io.disk_file dist_file in
      match
        BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
        @@ CstIo.parse module_or file
      with
      | Error { error_range = _; error_message; is_rendered = _ } ->
          quick_error error_message
      | Ok dist_core -> dist_core
  end

  (** [find_empty_github_slsa_v1_l2_location] finds the text location of the
      ["github_slsa_v1_l2"] attestation, which must be empty and zero-width.

      The JSON structure is like this:
      {[
        "distributions": [
          {
            "build": {
              "attestation": {
                "github_slsa_v1_l2": {},
                "github_slsa_v1_l3": {},
                "openbsd_signify": {}
              }
            }
          }
        ]
      ]}

      An error will be returned if more than one distribution is present.

      An error will be returned if the ["github_slsa_v1_l2"] attestation is not
      empty and zero-width. That is, only ["{}"] is allowed as the value of the
      ["github_slsa_v1_l2"] field. *)
  let find_empty_github_slsa_v1_l2_location module_or dist_file =
    let dist_file_s = MlFront_Core.FilePath.to_string dist_file in
    let dist_file_s_opt = Some dist_file_s in
    let cst = read_dist_file module_or dist_file in
    let contents =
      match cst.contents with
      | Some contents -> contents
      | None ->
          quick_error
            (Printf.sprintf "Distribution file `%s` has no contents" dist_file_s)
    in
    let state =
      MlFront_Thunk.ThunkParsers.Results.State.create_with_source
        ~origin:dist_file_s contents
    in
    match cst with
    | {
     contents = _;
     schema = _;
     schema_version = _;
     forms = _;
     bundles = _;
     distributions = [];
    } ->
        Error "Distribution file has no distributions"
    | {
     contents = _;
     schema = _;
     schema_version = _;
     forms = _;
     bundles = _;
     distributions = (first_range, _) :: (second_range, _) :: _;
    } ->
        let r1 = MlFront_Thunk.ThunkLexers.Ranges.display_range first_range in
        let r2 = MlFront_Thunk.ThunkLexers.Ranges.display_range second_range in
        let rboth = Fmlib_parse.Position.merge r1 r2 in
        Error
          (Format.asprintf
             "Distribution file has two or more distributions at %a. Only one \
              distribution is allowed."
             (MlFront_Thunk.ThunkParsers.Results.pp_range dist_file_s_opt)
             rboth)
    | {
     contents = _;
     schema = _;
     schema_version = _;
     forms = _;
     bundles = _;
     distributions =
       [
         ( dist_range,
           {
             id = _id_range, library, version;
             producer = _;
             license = _;
             continuations = _;
             build = { build_to_sign = _; build_attestation };
           } );
       ];
    } -> begin
        let id =
          Printf.sprintf "%s@%s"
            (MlFront_Core.LibraryId.full_name library)
            (MlFront_Thunk.ThunkSemver64.to_string version)
        in
        match
          MlFront_Thunk.ThunkCommand.InternalUse.parse_library_version module_or
            MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None id
        with
        | Error msg ->
            Error
              (Format.asprintf "Distribution file has invalid `id` `%s`: %a" id
                 MlFront_Thunk.ThunkParsers.Results.Semantic.pp msg)
        | Ok (library_id, _ver) -> begin
            match build_attestation with
            | None ->
                Error
                  (MlFront_Thunk.ThunkParsers.Results.single_error
                     ~code:"ed954d30" ~msg:"No build attestation found"
                     ~brief_instruction:
                       "Add the build attestation `\"attestation\": { \
                        \"github_slsa_v1_l2\": {}` }."
                     module_or state dist_range)
            | Some
                {
                  attestation_openbsd_signify = _;
                  attestation_github_slsa_v1_l2 = None;
                  attestation_github_slsa_v1_l3 = _;
                } ->
                Error
                  (MlFront_Thunk.ThunkParsers.Results.single_error
                     ~code:"dd4c56e0"
                     ~msg:"No `github_slsa_v1_l2` attestation found"
                     ~brief_instruction:
                       "Add an empty `\"github_slsa_v1_l2\": {}` attestation."
                     module_or state dist_range)
            | Some
                {
                  attestation_openbsd_signify = _;
                  attestation_github_slsa_v1_l2 =
                    Some (range, { github_slsa_v1_l2_doc = Some _ });
                  attestation_github_slsa_v1_l3 = _;
                } ->
                Error
                  (MlFront_Thunk.ThunkParsers.Results.single_error
                     ~code:"ebfbc1e7"
                     ~msg:
                       "A non-empty `github_slsa_v1_l2` attestation was found"
                     ~brief_instruction:
                       "Empty the `github_slsa_v1_l2` attestation to just \
                        `\"github_slsa_v1_l2\": {}`."
                     module_or state range)
            | Some
                {
                  attestation_openbsd_signify = _;
                  attestation_github_slsa_v1_l2 =
                    Some (range, { github_slsa_v1_l2_doc = None });
                  attestation_github_slsa_v1_l3 = _;
                } ->
                let ((start_, end_) as r) =
                  MlFront_Thunk.ThunkLexers.Ranges.display_range range
                in
                (* We want the two characters `{}` in `"github_slsa_v1_l2": {}` on the same line. *)
                if
                  Fmlib_parse.Position.byte_offset start_ + 2
                  <> Fmlib_parse.Position.byte_offset end_
                  || Fmlib_parse.Position.line start_
                     <> Fmlib_parse.Position.line end_
                  || Fmlib_parse.Position.column start_ + 2
                     <> Fmlib_parse.Position.column end_
                then
                  Error
                    (MlFront_Thunk.ThunkParsers.Results.single_error
                       ~code:"d2274851"
                       ~msg:
                         "A non-zero-width `github_slsa_v1_l2` attestation was \
                          found"
                       ~brief_instruction:
                         "Make the `github_slsa_v1_l2` attestation empty and \
                          zero-width like this: `\"github_slsa_v1_l2\": {}`."
                       module_or state range)
                else Ok (r, library_id, contents)
          end
      end
end

let read_attestation_bundle attestation_bundle =
  let quick_error msg =
    let lines = String.split_on_char '\n' msg in
    Format.eprintf "@[<v 1>FATAL: Parsing attestation bundle failed.@;%a@]@."
      Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
      lines;
    exit 1
  in

  (* read lines from JSONL file *)
  let file = BuildCore.Io.disk_file attestation_bundle in
  let lines =
    match
      BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
      @@ BuildCore.Io.read_all file
    with
    | `Content s ->
        (* non-empty lines only *)
        String.split_on_char '\n' s |> List.filter (fun s -> s <> "")
    | `Error e -> quick_error e
    | `ExceededSizeLimit n ->
        quick_error
          (Printf.sprintf
             "Attestation bundle file exceeds size limit of %Ld bytes" n)
  in

  (* setup a JSON parser that will parse each line *)
  let parse_jsonl_line s =
    let state =
      MlFront_Thunk.ThunkParsers.Results.State.create_with_source
        ~origin:(BuildCore.Io.file_origin file)
        s
    in
    let module P = MlFront_Thunk.ThunkParsers.JsonParsers.JsonParser in
    let p =
      (* nit: we could read the JSONL lines with positions rather than [None] *)
      P.start state None
    in
    let p = P.run_on_string s p in
    let p = P.put_end p in
    if P.has_succeeded p then
      let final = P.final p in
      (* Printf.eprintf "autofix parsed: %s\n"
      (hint final : string); *)
      Ok final
    else begin
      let semantic_range error =
        MlFront_Thunk.ThunkParsers.Results.Semantic.error_range error
      in
      let semantic_message error =
        MlFront_Thunk.ThunkParsers.Results.Semantic.error_message error
        |> Fmlib_pretty.Print.text
      in
      (* Printf.eprintf "read has_succeeded %b\n" (P.has_succeeded p);
          Printf.eprintf "read has_consumed_end %b\n" (P.has_consumed_end p);
          Printf.eprintf "read has_failed_syntax %b\n" (P.has_failed_syntax p);
          Printf.eprintf "read has_failed_semantic %b\n" (P.has_failed_semantic p); *)

      let module Reporter = Fmlib_parse.Error_reporter.Make (P) in
      let s =
        Reporter.(
          (if P.has_failed_syntax p then make_syntax p
           else make semantic_range semantic_message p)
          |> run_on_string s
          |> Fmlib_pretty.Print.layout 80
          |> Fmlib_pretty.Print.string_of)
      in
      Error s
    end
  in
  let parse_line_result =
    List.fold_left
      (fun acc s ->
        match acc with
        | Error e -> Error e
        | Ok acc ->
        match parse_jsonl_line s with
        | Ok json -> Ok (json :: acc)
        | Error e -> Error e)
      (Ok []) lines
  in
  match parse_line_result with
  | Error e -> quick_error e
  | Ok fmlib_jsons ->
      let yojsons =
        List.map MlFront_Thunk.ThunkParsers.JsonParsers.json_for_fmlib_to_yojson
          fmlib_jsons
      in
      List.rev yojsons