Source file ThunkBundle.ml

(* DEV NOTE: The [2] in [asset_file2], etc. is the DkAssets specification version. *)

type t = {
  bundle_id : ThunkLexers.Ranges.range_plus option * string;
      (** Until the deprecated version JSON object is removed (ie. thunk.json),
          the location is only provided for a ["MODULE@VERSION"] JSON string. *)
  listing : asset_listing;
  files : (compare_free_rangeplus * asset_file2) list;
}

and asset_listing = { origins : asset_origin2 list }

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

and asset_file2 = {
  file_path : string;
  file_checksum : asset_checksum;
  file_origin : string option;
  file_sz : ThunkLexers.Ranges.range_plus * int64;
}

and asset_checksum = {
  checksum_sha256 : (ThunkLexers.Ranges.range_plus * string) option;
  checksum_sha1 : (ThunkLexers.Ranges.range_plus * string) option;
}

and compare_free_rangeplus =
  (ThunkLexers.Ranges.range_plus[@compare fun _a _b -> 0])

module Parsers = struct
  open ThunkParsers.JsonParsers

  (** Logical representation of a CST *)
  module Bundle = struct
    type nonrec t = t
  end

  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) =
    struct
      open CJson'

      let cast_asset_checksum j =
        let* checksum_sha256 = getmember_opt "sha256" j in
        let* checksum_sha1 = getmember_opt "sha1" j in
        let* checksum_sha256 = if_some checksum_sha256 pair_attr in
        let* checksum_sha1 = if_some checksum_sha1 pair_attr in
        let* checksum_sha256 = if_some_snd checksum_sha256 cast_string in
        let* checksum_sha1 = if_some_snd checksum_sha1 cast_string in
        return { checksum_sha256; checksum_sha1 }

      let cast_asset_file2 j =
        let* file_path = getmember "path" j in
        let* file_checksum = getmember "checksum" j in
        let* file_origin = getmember_opt "origin" j in
        let* file_sz = getmember "size" j in
        let* file_path = cast_string file_path in
        let* file_checksum = cast_asset_checksum file_checksum in
        let* file_origin = if_some file_origin cast_string in
        let* file_sz =
          let* loc, _ = pair_attr file_sz in
          let* x = cast_int64 file_sz in
          return (loc, x)
        in

        return { file_origin; file_path; file_checksum; file_sz }

      let cast_asset_origin2 j =
        let* origin_name = getmember "name" j in
        let* mirrors_range, origin_mirrors = getmemberwithjson "mirrors" j in
        let* origin_name = cast_string origin_name in
        let* origin_mirrors = cast_array origin_mirrors in
        let* origin_mirrors = for_all origin_mirrors cast_string in
        let mirrors_range = ThunkLexers.Ranges.display_range mirrors_range in
        match origin_mirrors with
        | [] ->
            fail
              (ThunkParsers.Results.Semantic.create mirrors_range
                 (Printf.sprintf "No mirrors for origin %s" origin_name))
        | first :: rest ->
            return { origin_name; origin_mirrors = (first, rest) }

      let cast_asset_listing j =
        let* origins = getmember "origins" j in
        let* origins = cast_array origins in
        let* origins = for_all origins cast_asset_origin2 in
        return { origins }

      let cast_listing_unencrypted j =
        let* listing_name = getmember "name" j in
        let* listing_version = getmember "version" j in
        let* listing_name = cast_string listing_name in
        let* listing_version = cast_string listing_version in
        return (None, Printf.sprintf "%s@%s" listing_name listing_version)

      let cast_bundle j =
        let* state = get in
        let* listing_unencrypted = getmember_opt "listing_unencrypted" j in
        let* listing = getmember_opt "listing" j in
        let* files = getmember "assets" j in
        let* bundle_id =
          match
            ( listing_unencrypted,
              ThunkParsers.Results.State.allow_deprecated_toplevel_moduleid
                state )
          with
          | Some listing_unencrypted, true ->
              cast_listing_unencrypted listing_unencrypted
          | _ ->
              let* id = getmember "id" j in
              let* idrange, _ = pair_attr id in
              let* id = cast_string id in
              return (Some idrange, id)
        in
        let* listing = if_some listing cast_asset_listing in
        let* files = cast_array files in
        let* files =
          for_all files (fun json ->
              let* filerange, _ = pair_attr json in
              let* file = cast_asset_file2 json in
              return (filerange, file))
        in
        return
          {
            bundle_id;
            listing = Option.value ~default:{ origins = [] } listing;
            files;
          }
    end

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

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

    module CExtended = struct
      open CJson
      include MakeCExtended (CJson)

      let bundle () : Bundle.t t =
        let* j = json () in
        cast_bundle j
    end

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

  (** The complete parser *)
  module PL = struct
    open Fmlib_parse
    open ThunkLexers.JsonLexer
    open ThunkParsers

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

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

let asset_file2_id_yojson ~canonical
    {
      file_origin;
      file_path : string;
      file_checksum = { checksum_sha256; checksum_sha1 };
      file_sz;
    } : YojsonI.Safe.t =
  let checksum =
    match (checksum_sha256, checksum_sha1) with
    | Some (_range256, sha256), Some (_range1, sha1) ->
        `Assoc [ ("sha256", `String sha256); ("sha1", `String sha1) ]
    | Some (_range256, sha256), None -> `Assoc [ ("sha256", `String sha256) ]
    | None, Some (_range1, sha1) -> `Assoc [ ("sha1", `String sha1) ]
    | None, None -> `Assoc []
  in
  let origin =
    if canonical then []
    else
      match file_origin with
      | Some origin -> [ ("origin", `String origin) ]
      | None -> []
  in
  `Assoc
    ((("checksum", checksum) :: origin)
    @ [
        ("path", `String file_path);
        ("size", `Intlit (Int64.to_string (snd file_sz)));
      ])

let origins_yojson ~canonical { origin_name; origin_mirrors } =
  (* this is not part of canonical JSON.
     bonus: fields can be ordered naturally *)
  assert (not canonical);
  let mirrors =
    `List
      (let first, rest = origin_mirrors in
       `String first :: List.map (fun url -> `String url) rest)
  in
  `Assoc [ ("name", `String origin_name); ("mirrors", mirrors) ]

let yojson ~canonical =
  let compare_file
      { file_origin = _; file_path = p1; file_checksum = _; file_sz = _ }
      { file_origin = _; file_path = p2; file_checksum = _; file_sz = _ } =
    String.compare p1 p2
  in
  function
  | { bundle_id = _range, bundle_id; listing = { origins }; files } ->
      let listing =
        if canonical then []
        else
          [
            ( "listing",
              `Assoc
                [
                  ( "origins",
                    `List (List.map (origins_yojson ~canonical) origins) );
                ] );
          ]
      in
      `Assoc
        ([
           ( "assets",
             `List
               (List.map
                  (asset_file2_id_yojson ~canonical)
                  (List.sort compare_file (List.map snd files))) );
           ("id", `String bundle_id);
         ]
        @ listing)

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

let canonicalize_asset_file file =
  YojsonI.Safe.to_string ~std:true (asset_file2_id_yojson ~canonical:true file)

let canonical_asset_file_id file =
  Digestif.SHA256.to_hex
  @@ Digestif.SHA256.digest_string (canonicalize_asset_file file)

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

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

let compare a1 a2 = String.compare (canonicalize a1) (canonicalize a2)

module InternalUse = struct
  let parse_string
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) rangeplus s
      : (t, _) result =
    let sourcestate = ThunkParsers.Results.State.create_with_source s in
    let parser = Parsers.PL.start sourcestate rangeplus in
    let source, parser =
      let module Subparse = ThunkParsers.MakeSubparse (Parsers.PL) in
      Subparse.parse sourcestate rangeplus parser s
    in
    let module H = ResultObserver.Make (Parsers.PL) in
    H.observe ~cant_do:"parse the bundle" ~source sourcestate parser

  module CAssetExtensions
      (CJson :
        ThunkParsers.JsonParsers.Parser.CJSON
          with type attr = ThunkLexers.Ranges.range_plus) =
  struct
    module CExtended = Parsers.Parser.MakeCExtended (CJson)

    let cast_bundle : CJson.json -> t CJson.t = CExtended.cast_bundle
  end
end