From aed9c6a559db3d6ca5ce2a7abf15b2a99e013dd8 Mon Sep 17 00:00:00 2001 From: Swrup Date: Sat, 27 Sep 2025 11:59:28 +0200 Subject: [PATCH] wip: custom static files crunching --- dune-project | 2 + src/assets/privacy/en/0.html | 11 ---- src/assets/terms/en/0.html | 11 ---- src/assets_script.ml | 117 +++++++++++++++++++++++++++++++++++ src/dune | 11 +++- 5 files changed, 127 insertions(+), 25 deletions(-) delete mode 100644 src/assets/privacy/en/0.html delete mode 100644 src/assets/terms/en/0.html create mode 100644 src/assets_script.ml diff --git a/dune-project b/dune-project index 8b2e9ddb..07270ac2 100644 --- a/dune-project +++ b/dune-project @@ -2,6 +2,8 @@ (name mte) +; (implicit_transitive_deps false) + (generate_opam_files true) ; (source diff --git a/src/assets/privacy/en/0.html b/src/assets/privacy/en/0.html deleted file mode 100644 index 829f6b79..00000000 --- a/src/assets/privacy/en/0.html +++ /dev/null @@ -1,11 +0,0 @@ - - - - - MTE terms - - -

MTE terms

- TODO - - diff --git a/src/assets/terms/en/0.html b/src/assets/terms/en/0.html deleted file mode 100644 index 829f6b79..00000000 --- a/src/assets/terms/en/0.html +++ /dev/null @@ -1,11 +0,0 @@ - - - - - MTE terms - - -

MTE terms

- TODO - - diff --git a/src/assets_script.ml b/src/assets_script.ml new file mode 100644 index 00000000..ea21f462 --- /dev/null +++ b/src/assets_script.ml @@ -0,0 +1,117 @@ +(* crunchy crunch ~ *) +(* we enforce a "complete" folder structure to keep it simple + (all languages must support the same mimetypes) *) +open Bos + +let terms_dir = Fpath.v "assets/terms/" +let privacy_dir = Fpath.v "assets/privacy/" +let etag = Fpath.v "0" + +let dir_contents dir = + match OS.Dir.contents ~rel:true dir with + | Error e -> Fmt.failwith "Error reading dir: %a" Rresult.R.pp_msg e + | Ok files -> files + +let read_tos_dir kind = + let dir = match kind with `Terms -> terms_dir | `Privacy -> privacy_dir in + (* + let l = OS.Dir.contents ~rel:true (Fpath.v ".") |> Rresult.R.get_ok in + List.iter (fun p -> Fmt.epr "%s, " (Fpath.to_string p)) l; + Fmt.epr "@."; + *) + let subdirs = + let files = dir_contents dir in + List.filter + (fun p -> OS.Dir.exists Fpath.(dir // p) |> Rresult.R.get_ok) + files + in + let lang_arr = subdirs |> List.sort Fpath.compare |> Array.of_list in + let fpaths_l = + lang_arr + |> Array.to_list + |> List.map (fun lang -> + let subdir = Fpath.(dir // lang) in + (* + Fmt.pr "subdir: %s\n" (Fpath.to_string lang) + (Fpath.to_string subdir); + *) + dir_contents subdir) + in + let ext_arr = + let exts_l = + fpaths_l + |> List.map (fun l -> + List.map Fpath.get_ext l |> List.sort String.compare) + in + let ext_l = + match exts_l with + | [] -> [] + | [ ext_l ] -> ext_l + | hd :: tl -> + let all_language_support_same_extensions = + List.for_all (List.equal String.equal hd) tl + in + if all_language_support_same_extensions then hd + else + Fmt.failwith "Invalid assets folder structure" |> Rresult.R.get_ok + in + ext_l |> List.sort String.compare |> Array.of_list + in + let content_mat = + Array.init_matrix (Array.length lang_arr) (Array.length ext_arr) (fun i j -> + let lang = lang_arr.(i) in + let ext = ext_arr.(j) in + let path = Fpath.(dir // lang // (etag + ext)) in + match OS.File.read path with + | Error e -> Fmt.failwith "Error reading dir: %a" Rresult.R.pp_msg e + | Ok data -> data) + in + let lang_arr = Array.map Fpath.to_string lang_arr in + (lang_arr, ext_arr, content_mat) + +let lang_arr, ext_arr, terms_mat, privacy_mat = + let lang_arr, ext_arr, terms_mat = read_tos_dir `Terms in + let lang_arr', ext_arr', privacy_mat = read_tos_dir `Privacy in + (* TODO stdlib no Array.equal *) + match + List.equal String.equal (Array.to_list lang_arr) (Array.to_list lang_arr') + && List.equal String.equal (Array.to_list ext_arr) (Array.to_list ext_arr') + with + | false -> + Fmt.failwith "terms and privacy folder does not have the same structure@." + | true -> (lang_arr, ext_arr, terms_mat, privacy_mat) + +let pp_string_data ppf s = + let open Fmt in + pf ppf "%S" s + +let pp_row ppf row = + let open Fmt in + pf ppf "[|%a|]" (array ~sep:(any "; ") pp_string_data) row + +let pp_mat ppf mat = + let open Fmt in + pf ppf "[|%a|]" (array ~sep:(any "; ") pp_row) mat + +let () = + Fmt.pr + {| +type t = | Terms | Privacy + +let get_static_file_content = + let lang_arr = %a in + let ext_arr = %a in + let terms_mat = %a in + let privacy_mat = %a in + fun ~lang ~ext kind -> + match + ( Array.find_index (String.equal lang) lang_arr + , Array.find_index (String.equal ext) ext_arr ) + with + | None, _ | _, None -> None + | Some i, Some j -> ( + match kind with + | Terms -> Some terms_mat.(i).(j) + | Privacy -> Some privacy_mat.(i).(j)) +|} + pp_row lang_arr pp_row ext_arr pp_mat terms_mat pp_mat privacy_mat diff --git a/src/dune b/src/dune index 397a7942..cf47d448 100644 --- a/src/dune +++ b/src/dune @@ -2,7 +2,12 @@ (public_name mte) (name mte) (modules assets mte config syntax) - (libraries vif fmt jsont cohttp)) + (libraries vif fmt fpath jsont cohttp)) + +(executable + (name assets_script) + (modules assets_script) + (libraries bos fmt fpath)) (rule (target assets.ml) @@ -10,5 +15,5 @@ (source_tree assets)) (action (with-stdout-to - %{null} - (run ocaml-crunch -m plain assets -o %{target})))) + %{target} + (run ./assets_script.exe))))