js_top_worker / lib / findlibish.ml

(* Kinda findlib, sorta *)

type library = {
  name : string;
  meta_uri : Uri.t;
  archive_name : string option;
  dir : string option;
  deps : string list;
  children : library list;
  mutable loaded : bool;
}

let rec flatten_libs libs =
  let handle_lib l =
    let children = flatten_libs l.children in
    l :: children
  in
  List.map handle_lib libs |> List.flatten

(* Runtime check for packages compiled into the worker binary.
   When #require loads a package that is already linked into the worker,
   we must NOT call import_scripts on its .cma.js — doing so would
   re-register CMI files that are already in the virtual filesystem,
   causing a Sys_error "file already exists".

   Instead of maintaining a hand-written list, we use Symtable to check
   whether any of the package's toplevel modules are already in the
   bytecode global table (i.e. linked into the binary). *)

exception Crc_mismatch of string

let is_module_available module_name =
  match Hashtbl.find_opt Js_top_worker.Impl.symtable_memo module_name with
  | Some v -> v
  | None ->
      let v =
        let id = Ident.create_persistent module_name in
        let in_symtable =
          match Symtable.Global.of_ident id with
          | None -> false
          | Some g -> Symtable.is_global_defined g
        in
        if in_symtable then true
        else
          (* Symtable only knows about modules loaded via the bytecode linker.
             Modules statically compiled into the jsoo binary are registered
             in caml_global_data by caml_register_global but are invisible to
             Symtable.  Check the JS runtime as a fallback. *)
          let open Js_of_ocaml in
          let global_data = Js.Unsafe.pure_js_expr "globalThis.jsoo_runtime.caml_get_global_data()" in
          Js.Optdef.test (Js.Unsafe.get global_data (Js.string module_name))
      in
      Hashtbl.replace Js_top_worker.Impl.symtable_memo module_name v;
      v

let binary_crc module_name =
  match Js_top_worker.Impl.lookup_binary_crc module_name with
  | Some _ as v -> v
  | None ->
      let v =
        try Some (Digest.to_hex (Env.crc_of_unit (module_name |> Compilation_unit.Name.of_string)))
        with Not_found -> None
      in
      Option.iter (Js_top_worker.Impl.memo_binary_crc module_name) v;
      v

let universe_crc module_name (dcs : Js_top_worker.Impl.dynamic_cmis) =
  match Js_top_worker.Impl.lookup_server_crc module_name with
  | Some _ as v -> v
  | None -> List.assoc_opt module_name dcs.dcs_module_crcs

let is_package_preloaded (dcs : Js_top_worker.Impl.dynamic_cmis) =
  let open Js_top_worker.Impl in
  match check_preload_status
          ~is_available:is_module_available
          ~get_binary_crc:binary_crc
          ~get_universe_crc:(fun m -> universe_crc m dcs)
          dcs
  with
  | Preloaded -> true
  | Not_loaded -> false
  | Partially_loaded { loaded; missing } ->
      Jslib.log
        "WARNING: package partially preloaded (%d/%d modules). \
         Loaded: [%s], missing: [%s]"
        (List.length loaded) (List.length loaded + List.length missing)
        (String.concat ", " loaded)
        (String.concat ", " missing);
      false
  | Crc_mismatch ms ->
      raise (Crc_mismatch (Printf.sprintf
        "Package preloaded but CRC mismatch: %s"
        (String.concat ", " ms)))

(** Check if the implementation units from a specific CMA archive are already
    loaded in the toplevel. This is more precise than is_package_preloaded
    because it checks only the units in the actual archive, not all CMIs
    in the directory (which may contain units from other findlib packages). *)
let is_cma_preloaded units =
  match units with
  | [] -> false
  | _ -> List.for_all is_module_available units

let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
  try
    Jslib.log "Reading library: %s" library_name;
    let pkg_defs = pkg_expr.Fl_metascanner.pkg_defs in
    (* Try to find archive with various predicates.
       PPX packages often only define archive(ppx_driver,byte), so we need to
       check multiple predicate combinations to find the right archive. *)
    let archive_filename =
      (* First try with ppx_driver,byte - this catches PPX libraries like ppx_deriving.show *)
      try Some (Fl_metascanner.lookup "archive" [ "ppx_driver"; "byte" ] pkg_defs)
      with _ -> (
        (* Then try plain byte *)
        try Some (Fl_metascanner.lookup "archive" [ "byte" ] pkg_defs)
        with _ -> (
          (* Then try native as fallback *)
          try Some (Fl_metascanner.lookup "archive" [ "native" ] pkg_defs)
          with _ -> None))
    in

    (* Use -ppx_driver predicate for toplevel use - this ensures PPX packages
       pull in their runtime dependencies (e.g., ppx_deriving.show requires
       ppx_deriving.runtime when not using ppx_driver) *)
    let predicates = ["-ppx_driver"] in
    let deps_str =
      try Fl_metascanner.lookup "requires" predicates pkg_defs with _ -> "" in
    let deps = Astring.String.fields ~empty:false deps_str in
    let subdir =
      List.find_opt (fun d -> d.Fl_metascanner.def_var = "directory") pkg_defs
      |> Option.map (fun d -> d.Fl_metascanner.def_value)
    in
    let dir =
      match (dir, subdir) with
      | None, None -> None
      | Some d, None -> Some d
      | None, Some d -> Some d
      | Some d1, Some d2 -> Some (Filename.concat d1 d2)
    in
    let archive_name =
      Option.bind archive_filename (fun a ->
          let file_name_len = String.length a in
          if file_name_len > 0 then Some (Filename.chop_extension a) else None)
    in
    Jslib.log "Number of children: %d" (List.length pkg_expr.pkg_children);
    let children =
      List.filter_map
        (fun (n, expr) ->
          Jslib.log "Found child: %s" n;
          let library_name = library_name ^ "." ^ n in
          match
            read_libraries_from_pkg_defs ~library_name ~dir meta_uri expr
          with
          | Ok l -> Some l
          | Error (`Msg m) ->
              Jslib.log "Error reading sub-library: %s" m;
              None)
        pkg_expr.pkg_children
    in
    Ok
      {
        name = library_name;
        archive_name;
        dir;
        deps;
        meta_uri;
        loaded = false;
        children;
      }
  with Not_found -> Error (`Msg "Failed to read libraries from pkg_defs")

type t = library list

let dcs_filename = "dynamic_cmis.json"

let fetch_dynamic_cmis sync_get url =
  match sync_get url with
  | None -> Error (`Msg "Failed to fetch dynamic cmis")
  | Some json_str ->
      (try
        let json = Yojson.Safe.from_string json_str in
        let open Yojson.Safe.Util in
        let dcs_url = json |> member "dcs_url" |> to_string in
        let dcs_toplevel_modules =
          json |> member "dcs_toplevel_modules" |> to_list |> List.map to_string in
        let dcs_file_prefixes =
          json |> member "dcs_file_prefixes" |> to_list |> List.map to_string in
        let dcs_module_crcs =
          match json |> member "dcs_module_crcs" with
          | `Assoc pairs ->
              List.filter_map (fun (k, v) ->
                match v with `String s -> Some (k, s) | _ -> None) pairs
          | _ -> []
        in
        let dcs_cma_units =
          match json |> member "cma_units" with
          | `Assoc pairs ->
              List.filter_map (fun (k, v) ->
                match v with
                | `List units ->
                    Some (k, List.filter_map (fun u ->
                      match u with `String s -> Some s | _ -> None) units)
                | _ -> None) pairs
          | _ -> []
        in
        Ok { Js_top_worker.Impl.dcs_url; dcs_toplevel_modules; dcs_file_prefixes;
             dcs_module_crcs; dcs_cma_units }
      with e ->
        Error (`Msg (Printf.sprintf "Failed to parse dynamic_cmis JSON: %s" (Printexc.to_string e))))

let (let*) = Lwt.bind

(** Parse a findlib_index file (JSON or legacy text format) and return
    the list of META file paths and universe paths.

    JSON format: [{"meta_files": [...], "universes": [...]}]

    meta_files: direct paths to META files
    universes: paths to other universes (directories containing findlib_index) *)
let parse_findlib_index content =
  (* Try JSON format first *)
  try
    let json = Yojson.Safe.from_string content in
    let open Yojson.Safe.Util in
    (* Support both "meta_files" and "metas" for compatibility *)
    let meta_files =
      try json |> member "meta_files" |> to_list |> List.map to_string
      with _ ->
        try json |> member "metas" |> to_list |> List.map to_string
        with _ -> []
    in
    (* Support both "universes" and "deps" for compatibility *)
    let universes =
      try json |> member "universes" |> to_list |> List.map to_string
      with _ ->
        try json |> member "deps" |> to_list |> List.map to_string
        with _ -> []
    in
    (meta_files, universes)
  with _ ->
    (* Fall back to legacy whitespace-separated format (no universes) *)
    (Astring.String.fields ~empty:false content, [])

(** Load a single META file and parse it into a library *)
let load_meta async_get meta_path =
  let* res = async_get meta_path in
  match res with
  | Error (`Msg m) ->
      Jslib.log "Error fetching findlib meta %s: %s" meta_path m;
      Lwt.return_none
  | Ok meta_content ->
      match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference meta_path with
      | Ok uri -> (
          Jslib.log "Parsed uri: %s" (Uri.path uri);
          let path = Uri.path uri in
          let file = Fpath.v path in
          let base_library_name =
            if Fpath.basename file = "META" then
              Fpath.parent file |> Fpath.basename
            else Fpath.get_ext file
          in
          let lexing = Lexing.from_string meta_content in
          try
            let meta = Fl_metascanner.parse_lexing lexing in
            let libraries =
              read_libraries_from_pkg_defs ~library_name:base_library_name
                ~dir:None uri meta
            in
            Lwt.return (Result.to_option libraries)
          with _ ->
            Jslib.log "Failed to parse meta: %s" (Uri.path uri);
            Lwt.return_none)
      | Error m ->
          Jslib.log "Failed to parse uri: %s" m;
          Lwt.return_none

(** Resolve a path relative to the directory of the base URL.
    Used for meta_files which are relative to their findlib_index.
    e.g. base="http://host/demo1/base/findlib_index", path="lib/base/META"
    => "http://host/demo1/base/lib/base/META" *)
let resolve_relative_to_dir ~base path =
  match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference base with
  | Ok base_uri ->
      let base_path = Uri.path base_uri in
      let parent_dir =
        match Fpath.of_string base_path with
        | Ok p -> Fpath.parent p |> Fpath.to_string
        | Error _ -> "/"
      in
      let resolved = Filename.concat parent_dir path in
      Uri.with_path base_uri resolved |> Uri.to_string
  | Error _ -> path

(** Resolve a path as absolute from root (preserving scheme/host from base).
    Used for universe paths which are already full paths from root.
    e.g. base="http://host/demo1/findlib_index", path="demo1/base/findlib_index"
    => "http://host/demo1/base/findlib_index" *)
let resolve_from_root ~base path =
  match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference base with
  | Ok base_uri ->
      let resolved = "/" ^ path in
      Uri.with_path base_uri resolved |> Uri.to_string
  | Error _ -> "/" ^ path

let init (async_get : string -> (string, [>`Msg of string]) result Lwt.t) findlib_index : t Lwt.t =
  Jslib.log "Initializing findlib";
  (* Track visited universes to avoid infinite loops *)
  let visited = Hashtbl.create 16 in
  let rec load_universe index_url =
    if Hashtbl.mem visited index_url then
      Lwt.return []
    else begin
      Hashtbl.add visited index_url ();
      let* findlib_txt =
        let* result = async_get index_url in
        match result with
        | Ok _ as ok -> Lwt.return ok
        | Error _ when Filename.check_suffix index_url ".json" ->
            (* Backward compat: try without .json extension *)
            let legacy_url = Filename.chop_suffix index_url ".json" in
            Jslib.log "Retrying without .json: %s" legacy_url;
            async_get legacy_url
        | err -> Lwt.return err
      in
      match findlib_txt with
      | Error (`Msg m) ->
          Jslib.log "Error fetching findlib index %s: %s" index_url m;
          Lwt.return []
      | Ok content ->
          let meta_files, universes = parse_findlib_index content in
          Jslib.log "Loaded findlib_index %s: %d META files, %d universes"
            index_url (List.length meta_files) (List.length universes);
          (* Resolve META paths relative to findlib_index directory *)
          let resolved_metas =
            List.map (fun p -> resolve_relative_to_dir ~base:index_url p) meta_files
          in
          (* Load META files from this universe *)
          let* local_libs = Lwt_list.filter_map_p (load_meta async_get) resolved_metas in
          (* Resolve universe paths relative to this findlib_index's directory.
             Universe paths can be relative (e.g., "../stdlib") or absolute from
             root (e.g., "packages/stdlib").  Relative paths are the common case
             from opam-all; absolute paths are kept for backward compatibility. *)
          let universe_index_urls =
            List.map (fun u ->
              let index_path = Filename.concat u "findlib_index.json" in
              if String.length u > 0 && u.[0] = '.' then
                (* Relative path (e.g., "../stdlib") — resolve from this index's dir *)
                resolve_relative_to_dir ~base:index_url index_path
              else
                (* Absolute-from-root path — legacy behavior *)
                resolve_from_root ~base:index_url index_path)
              universes
          in
          let* universe_libs = Lwt_list.map_p load_universe universe_index_urls in
          Lwt.return (local_libs @ List.flatten universe_libs)
    end
  in
  let* all_libs = load_universe findlib_index in
  Lwt.return (flatten_libs all_libs)

let require ~import_scripts sync_get cmi_only v packages =
  let rec require dcss package :
      Js_top_worker.Impl.dynamic_cmis list =
    match List.find (fun lib -> lib.name = package) v with
    | exception Not_found ->
        Jslib.log "Package %s not found" package;
        let available =
          v
          |> List.map (fun lib ->
                 Printf.sprintf "%s (%d)" lib.name (List.length lib.children))
          |> String.concat ", "
        in
        Jslib.log "Available packages: %s" available;
        dcss
    | lib ->
        if lib.loaded then dcss
        else (
          Jslib.log "Loading package %s" lib.name;
          Jslib.log "lib.dir: %s" (Option.value ~default:"None" lib.dir);
          let dep_dcs = List.fold_left require dcss lib.deps in
          let path = Fpath.(v (Uri.path lib.meta_uri) |> parent) in
          let dir =
            match lib.dir with
            | None -> path
            | Some "+" -> Fpath.parent path  (* "+" means parent dir in findlib *)
            | Some d when String.length d > 0 && d.[0] = '^' ->
                (* "^" prefix means relative to stdlib dir - treat as parent *)
                Fpath.parent path
            | Some d -> Fpath.(path // v d)
          in
          let dcs = Fpath.(dir / dcs_filename |> to_string) in
          let uri = Uri.with_path lib.meta_uri dcs in
          Jslib.log "uri: %s" (Uri.to_string uri);
          match fetch_dynamic_cmis sync_get (Uri.to_string uri) with
          | Ok dcs ->
              (* Check whether to load the .cma.js archive.
                 We use per-archive unit lists (from .units.json) rather than
                 the directory-wide dynamic_cmis.json, because multiple findlib
                 packages may share a directory (e.g., compiler-libs.common and
                 compiler-libs.optcomp both live in compiler-libs/). *)
              Option.iter
                (fun archive ->
                  if not cmi_only then begin
                    let cma_name = archive ^ ".cma" in
                    let already_loaded =
                      match List.assoc_opt cma_name dcs.dcs_cma_units with
                      | Some units ->
                          let preloaded = is_cma_preloaded units in
                          if preloaded then
                            Jslib.log "Archive %s already preloaded (%d units), skipping"
                              cma_name (List.length units)
                          else
                            Jslib.log "Archive %s not preloaded, loading %d units"
                              cma_name (List.length units);
                          preloaded
                      | None ->
                          (* No cma_units in dynamic_cmis.json — fall back to directory-wide check *)
                          Jslib.log "No cma_units for %s, falling back to directory check" cma_name;
                          is_package_preloaded dcs
                    in
                    if not already_loaded then begin
                      let archive_js =
                        Fpath.(dir / (archive ^ ".cma.js") |> to_string)
                      in
                      import_scripts
                        [ Uri.with_path uri archive_js |> Uri.to_string ]
                    end
                  end)
                lib.archive_name;
              lib.loaded <- true;
              Jslib.log "Finished loading package %s" lib.name;
              dcs :: dep_dcs
          | Error (`Msg m) ->
              Jslib.log "Failed to unmarshal dynamic_cms from url %s: %s"
                (Uri.to_string uri) m;
              dcss)
  in
  List.fold_left require [] packages

let find_dcs_url v package_name =
  match List.find_opt (fun lib -> lib.name = package_name) v with
  | None -> None
  | Some lib ->
      let path = Fpath.(v (Uri.path lib.meta_uri) |> parent) in
      let dir =
        match lib.dir with
        | None -> path
        | Some "+" -> Fpath.parent path
        | Some d when String.length d > 0 && d.[0] = '^' ->
            Fpath.parent path
        | Some d -> Fpath.(path // v d)
      in
      let dcs = Fpath.(dir / dcs_filename |> to_string) in
      Some (Uri.with_path lib.meta_uri dcs |> Uri.to_string)