From fe1f7709a8db8457b93c190780c1b01e4e7e90a7 Mon Sep 17 00:00:00 2001 From: Kento Okura Date: Wed, 19 Aug 2026 12:00:18 +0200 Subject: [PATCH] Cache HTML mainmatter during rendering Since rendering is done across domains, the cache is a lock-free hash table from the Saturn library. The numbering logic had to be removed from the client to make it stateless. Numbers are now computed via CSS. Nice simplification in HTML_client. --- bin/forester/theme/style.css | 15 ++- lib/frontend/Headers.ml | 13 +-- lib/frontend/Html_client.ml | 203 ++++++++++++++++++++--------------- lib/frontend/Html_client.mli | 10 +- lib/frontend/dune | 3 +- lib/server/Server.ml | 15 +-- test/htmx-numbering.t | 30 ++---- test/ok.t | 18 +++- test/queries.t | 46 ++++---- test/section-numbering.t | 17 +-- test/transcluding-taxons.t | 4 +- 11 files changed, 206 insertions(+), 168 deletions(-) diff --git a/bin/forester/theme/style.css b/bin/forester/theme/style.css index 5091bd1..8775f39 100644 --- a/bin/forester/theme/style.css +++ b/bin/forester/theme/style.css @@ -250,11 +250,22 @@ span.taxon { font-weight: bolder; } +.mainmatter, +ul.block { + counter-reset: section-num; +} -.link-list>section>details>summary>header h1 { - font-size: 12pt; +.numbered { + counter-increment: section-num; +} + +.section-number::before { + content: " " counters(section-num, ".") ". "; } +.link-list > section > details > summary > header h1 { + font-size: 12pt; +} article>section>details>summary>header>h1 { font-size: 1.5em; diff --git a/lib/frontend/Headers.ml b/lib/frontend/Headers.ml index 0ba5dfc..e056d93 100644 --- a/lib/frontend/Headers.ml +++ b/lib/frontend/Headers.ml @@ -76,14 +76,11 @@ let parse_section_flags (header : Http.Header.t) : T.section_flags option = expanded; } -let of_numbering ~(number : int list) = - `Assoc - [("Number-Path", `String (String.concat "," (List.map string_of_int number)))] - -let parse_numbering (header : Http.Header.t) : int list = - match Http.Header.get header "Number-Path" with - | None | Some "" -> [] - | Some s -> String.split_on_char ',' s |> List.map int_of_string +let of_numbering ~(numbered : bool) = + `Assoc [("Numbered-Effective", `String (Bool.to_string numbered))] + +let parse_numbering (header : Http.Header.t) : bool = + parse_flag "Numbered-Effective" header let of_scope (scope : URI.t option) = match scope with diff --git a/lib/frontend/Html_client.ml b/lib/frontend/Html_client.ml index 058920a..872dc98 100644 --- a/lib/frontend/Html_client.ml +++ b/lib/frontend/Html_client.ml @@ -18,6 +18,7 @@ open struct module X = Xml_forester module H = P.HTML module Hx = P.Hx + module S = Saturn type query = (string, T.content T.vertex) Forester_core.Datalog_expr.query [@@deriving repr] @@ -30,15 +31,22 @@ type 'a control = type 'a client = 'a control -> P.node +type mainmatter_cache = (URI.t * bool, P.node list) S.Htbl.t + +let create_mainmatter_cache () : mainmatter_cache = S.Htbl.create () + +let default_xmlns () = + Xmlns.init ~reserved:[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] + type env = { forest: State.t; scope: URI.t option; loops: Loop_detection.t; xmlns: Xmlns.t; in_backmatter: bool; - number: int list; numbered: bool; mode: mode; + mainmatter_cache: mainmatter_cache; } let is_counted : T.section_flags -> _ = @@ -54,16 +62,10 @@ let section_flags_of_node : T.(content content_node) -> T.section_flags option = | T.Results_of_datalog_query _ | T.Xml_elt _ -> None -let number_node ~env node counter = +let numbered_node ~env node = match section_flags_of_node node with - | Some flags -> - if env.numbered && is_counted flags then begin - incr counter; - let n = !counter :: env.number in - (Some n, n, true) - end - else (None, env.number, false) - | None -> (None, env.number, env.numbered) + | Some flags -> env.numbered && is_counted flags + | None -> env.numbered (* Generate an id from a tree's frontmatter. The source_path field is omitted since it carries an absolute path since this changes with every cram test. @@ -191,7 +193,9 @@ let rec render_control : type a. env:env -> a client = function | Transclusion {href; target; range = _} -> let (`Assoc target_headers) = Headers.of_content_target target in - let (`Assoc number_headers) = Headers.of_numbering ~number:env.number in + let (`Assoc number_headers) = + Headers.of_numbering ~numbered:env.numbered + in let (`Assoc scope_headers) = Headers.of_scope env.scope in let headers = Yojson.Safe.to_string @@ -261,13 +265,11 @@ and default_env ~forest = forest; scope = None; loops = Loop_detection.empty; - xmlns = - Xmlns.init - ~reserved:[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}]; + xmlns = default_xmlns (); in_backmatter = false; mode = Static; - number = []; numbered = true; + mainmatter_cache = create_mainmatter_cache (); } and dynamic_env ~forest = {(default_env ~forest) with mode = Dynamic} @@ -281,39 +283,32 @@ and dynamic_env ~forest = {(default_env ~forest) with mode = Dynamic} *) and render_content ~env (Content content : T.content) = - render_content_nodes ~env ~counter:(ref 0) content + render_content_nodes ~env content -and render_content_nodes ~env ~counter content = +and render_content_nodes ~env content = List.concat @@ List.map (fun node -> - let number, prefix, numbered = number_node ~env node counter in - render_content_node - ~env:{env with number = prefix; numbered} - ~counter ~number node) + let numbered = numbered_node ~env node in + render_content_node ~env:{env with numbered} node) content and render_toc ~env (Content content : T.content) = assert (not env.in_backmatter); - match render_toc_entries ~env ~counter:(ref 0) content with + match render_toc_entries ~env content with | [] -> [] | items -> [H.ul [H.class_ "block"] items] -and render_toc_entries ~env ~counter content = +and render_toc_entries ~env content = List.concat @@ List.filter_map (fun node -> - let number, prefix, numbered = number_node ~env node counter in - let items = - render_toc_item - ~env:{env with number = prefix; numbered} - ~counter ~number node - in + let numbered = numbered_node ~env node in + let items = render_toc_item ~env:{env with numbered} node in if List.length items > 0 then Some items else None) content -and render_content_node ~env ~counter ~number (node : _ T.content_node) : - P.node list = +and render_content_node ~env (node : _ T.content_node) : P.node list = match node with | Text str -> [P.txt "%s" str] | CDATA str -> [P.txt "%s" str] @@ -323,7 +318,7 @@ and render_content_node ~env ~counter ~number (node : _ T.content_node) : let xmlns_attrs = Xmlns.xmlns_attrs_for_elt elt env.xmlns in let env = {env with xmlns = Xmlns.extend xmlns_attrs env.xmlns} in let (Content elt_content) = elt.content in - let content = render_content_nodes ~env ~counter elt_content in + let content = render_content_nodes ~env elt_content in [ P.std_tag name (List.map render_xmlns_prefix xmlns_attrs @@ -355,28 +350,30 @@ and render_content_node ~env ~counter ~number (node : _ T.content_node) : [P.txt "%s" tex]; ] | Artefact artefact -> render_content ~env @@ artefact.content - | Section section -> [render_section ?number ~env section] - | Transclude ({target = Full _; _} as t) -> begin - match env.mode with + | Section section -> [render_section ~numbered:env.numbered ~env section] + | Transclude ({target = Full _; _} as t) -> + begin match env.mode with | Dynamic -> [render_control ~env (Transclusion t)] - | Static -> begin - match State.get_section ~forest:env.forest t with - | Some section -> [render_section ?number ~env section] + | Static -> + begin match State.get_section ~forest:env.forest t with + | Some section -> [render_section ~numbered:env.numbered ~env section] | None -> Error.(yield @@ broken_transclusion t); [ P.txt "failed to render transclusion %s" (Format.asprintf "%a" URI.pp t.href); ] + end end - end | Transclude t -> [render_control ~env (Transclusion t)] | Link link -> [render_control ~env (Link link)] | Results_of_datalog_query q -> [render_control ~env (Query q)] | Datalog_script _ -> [] -and toc_item_template ~env ~number (T.{uri; title; _} as frontmatter) children = - H.li [] +and toc_item_template ~env ~numbered (T.{uri; title; _} as frontmatter) children + = + H.li + [conditional_ numbered (H.class_ "numbered")] [ H.a [ @@ -410,13 +407,14 @@ and toc_item_template ~env ~number (T.{uri; title; _} as frontmatter) children = [ H.span [H.class_ "taxon"] - [render_tree_taxon_with_number ~env ?number frontmatter]; + [render_tree_taxon_with_number ~env ~numbered frontmatter]; H.null @@ render_title ~env frontmatter; ]; children; ] -and render_toc_item ~env ~counter ~number node = +and render_toc_item ~env node = + let numbered = env.numbered in match node with | T.Transclude ({target = Full {included_in_toc = true; _}; _} as transclusion) -> begin @@ -424,7 +422,7 @@ and render_toc_item ~env ~counter ~number node = | Some T.{frontmatter; mainmatter; _} -> let scope = frontmatter.uri in let children = render_toc ~env:{env with scope} mainmatter in - [toc_item_template ~env ~number frontmatter (H.null children)] + [toc_item_template ~env ~numbered frontmatter (H.null children)] | None -> [] end | T.Transclude ({target = Mainmatter; _} as transclusion) -> begin @@ -432,7 +430,7 @@ and render_toc_item ~env ~counter ~number node = | Some T.{frontmatter; mainmatter; _} -> let scope = frontmatter.uri in let children = render_toc ~env:{env with scope} mainmatter in - [toc_item_template ~env ~number frontmatter (H.null children)] + [toc_item_template ~env ~numbered frontmatter (H.null children)] | None -> [] end | T.Section {frontmatter; mainmatter; flags = {included_in_toc; _}} -> @@ -441,9 +439,8 @@ and render_toc_item ~env ~counter ~number node = let children = render_toc ~env:{env with scope = frontmatter.uri} mainmatter in - [toc_item_template ~env ~number frontmatter (H.null children)] - | T.Xml_elt {content = Content content; _} -> - render_toc_entries ~env ~counter content + [toc_item_template ~env ~numbered frontmatter (H.null children)] + | T.Xml_elt {content = Content content; _} -> render_toc_entries ~env content | _ -> [] and render_query_result ~env q = @@ -629,17 +626,11 @@ and render_bibtex ~env frontmatter = optional (get_meta frontmatter "bibtex") (fun c -> H.pre [] (render_content ~env c)) -and render_tree_taxon_with_number ~env ?number +and render_tree_taxon_with_number ~env ?(numbered = false) (T.{taxon; _} : T.(content frontmatter)) = - let number = match number with Some [] -> None | n -> n in let show_taxon = Option.is_some taxon in - let dot = conditional (Option.is_some number || show_taxon) (P.txt ". ") in - let number = - match number with - | None -> H.null [] - | Some number -> - P.txt " %s" @@ String.concat "." (List.rev_map Int.to_string number) - in + let number = conditional numbered (H.span [H.class_ "section-number"] []) in + let dot = conditional (show_taxon && not numbered) (P.txt ". ") in let taxon = if show_taxon then optional taxon (fun c -> H.null (render_content ~env c)) else H.null [] @@ -664,14 +655,15 @@ and render_display_uri ~env ?(slug = false) uri : P.node = ] [P.txt "["; P.txt "%s" path_string; P.txt "]"] -and render_frontmatter ~env ?number (frontmatter : _ T.frontmatter) : P.node = +and render_frontmatter ~env ?(numbered = false) (frontmatter : _ T.frontmatter) + : P.node = H.header [] [ H.h1 [] [ H.span [H.class_ "taxon"] - [render_tree_taxon_with_number ~env ?number frontmatter]; + [render_tree_taxon_with_number ~env ~numbered frontmatter]; H.null @@ render_title ~env frontmatter; P.txt " "; render_display_uri ~env ~slug:true frontmatter.uri; @@ -696,7 +688,39 @@ and render_frontmatter ~env ?number (frontmatter : _ T.frontmatter) : P.node = ]; ] -and render_section ~env ?number +and render_mainmatter ~env ~numbered (frontmatter : _ T.frontmatter) mainmatter + : P.node list = + match frontmatter.uri with + | None -> + let env = + { + env with + loops = Loop_detection.add_seen_uri_opt frontmatter.uri env.loops; + scope = frontmatter.uri; + } + in + render_content ~env mainmatter + | Some uri -> begin + let key = (uri, numbered) in + match S.Htbl.find_opt env.mainmatter_cache key with + | Some nodes -> nodes + | None -> + let cache_env = + { + env with + loops = + Loop_detection.add_seen_uri_opt frontmatter.uri Loop_detection.empty; + scope = frontmatter.uri; + xmlns = default_xmlns (); + numbered; + } + in + let nodes = render_content ~env:cache_env mainmatter in + ignore @@ S.Htbl.try_add env.mainmatter_cache key nodes; + nodes + end + +and render_section ~env ?(numbered = false) ({flags; mainmatter; frontmatter} : T.content T.section) : P.node = let T.{metadata_shown; header_shown; expanded; hidden_when_empty; _} = flags @@ -713,8 +737,10 @@ and render_section ~env ?number else H.section [ - (if not metadata_shown then H.class_ "block hide-metadata" - else H.class_ "block"); + (let base = + if not metadata_shown then "block hide-metadata" else "block" + in + H.class_ "%s" (if numbered then base ^ " numbered" else base)); taxon_attr; ] [ @@ -724,17 +750,11 @@ and render_section ~env ?number H.details [open_; H.id "%s" @@ stable_id_of_frontmatter frontmatter] [ - H.summary [] [render_frontmatter ?number ~env frontmatter]; - (let env = - { - env with - loops = - Loop_detection.add_seen_uri_opt frontmatter.uri env.loops; - scope = frontmatter.uri; - } - in - H.null @@ render_content ~env mainmatter); - render_bibtex ~env frontmatter; + H.summary [] [render_frontmatter ~numbered ~env frontmatter]; + H.div + [H.class_ "mainmatter"] + (render_mainmatter ~env ~numbered frontmatter mainmatter + @ [render_bibtex ~env frontmatter]); ] else H.null @@ render_content ~env mainmatter); ] @@ -804,17 +824,21 @@ let render_article ~env (article : T.content T.article) : P.node = [H.class_ "block"] [ H.details [H.open_] - (H.summary [] [render_frontmatter ~env article.frontmatter] - :: render_content - ~env: - { - env with - loops = - Loop_detection.add_seen_uri_opt article.frontmatter.uri - env.loops; - } - article.mainmatter - @ [render_bibtex ~env article.frontmatter]); + [ + H.summary [] [render_frontmatter ~env article.frontmatter]; + H.div + [H.class_ "mainmatter"] + (render_content + ~env: + { + env with + loops = + Loop_detection.add_seen_uri_opt article.frontmatter.uri + env.loops; + } + article.mainmatter + @ [render_bibtex ~env article.frontmatter]); + ]; ]; conditional should_render_backmatter @@ H.footer [] [render_backmatter ~env article.backmatter]; @@ -829,9 +853,14 @@ let render_article_as_div ~(forest : State.t) (article : T.content T.article) : (List.map render_xmlns_prefix reserved) [H.null @@ render_content ~env article.mainmatter] -let render_article_and_toc ~forest ?(mode = Static) +let render_article_and_toc ~forest ?(mode = Static) ?mainmatter_cache ({frontmatter; mainmatter; _} as tree : _ T.article) = let env = {(default_env ~forest) with scope = frontmatter.uri; mode} in + let env = + match mainmatter_cache with + | Some mainmatter_cache -> {env with mainmatter_cache} + | None -> env + in let toc = render_toc ~env mainmatter in [ render_article ~env tree; @@ -878,7 +907,7 @@ let collect_and_report_errors ~(forest : State.t) (f : unit -> 'a) : report_errors ~forest errors; (result, errors) -let render_page ~forest ?(mode = Static) +let render_page ~forest ?(mode = Static) ?mainmatter_cache ({frontmatter; _} as tree : _ T.article) : P.node * Error.t list = let@ () = collect_errors in let env = {(default_env ~forest) with scope = frontmatter.uri; mode} in @@ -893,7 +922,7 @@ let render_page ~forest ?(mode = Static) in let is_home = is_home ~env frontmatter.uri in let dev = forest.dev in - let content = render_article_and_toc ~forest tree in + let content = render_article_and_toc ~forest ?mainmatter_cache tree in let ctx = Router.page_context ~forest ~mode ~dev in Templates.page ~ctx ~is_home ~title_string:ttl ~source_path:frontmatter.source_path content diff --git a/lib/frontend/Html_client.mli b/lib/frontend/Html_client.mli index e13f0e2..b236d7e 100644 --- a/lib/frontend/Html_client.mli +++ b/lib/frontend/Html_client.mli @@ -10,15 +10,19 @@ module X := Forester_compiler.Xml_forester module H := P.HTML module Hx := P.Hx +type mainmatter_cache + +val create_mainmatter_cache : unit -> mainmatter_cache + type env = { forest: Forester_compiler.State.t; scope: Forester_core.URI.t option; loops: Loop_detection.t; xmlns: Forester_xml_names.Xmlns.t; in_backmatter: bool; - number: int list; numbered: bool; mode: Forester_core.mode; + mainmatter_cache: mainmatter_cache; } val default_env : forest:Forester_compiler.State.t -> env @@ -34,6 +38,7 @@ val render_toc : env:env -> T.content -> P.node list val render_page : forest:Forester_compiler.State.t -> ?mode:Forester_core.mode -> + ?mainmatter_cache:mainmatter_cache -> T.content T.article -> P.node * Forester_compiler.Error.t list @@ -51,5 +56,4 @@ val html_redirect : path:string -> Pure_html.node val render_article : env:env -> T.content T.article -> P.node -val render_section : - env:env -> ?number:int list -> T.content T.section -> P.node +val render_section : env:env -> ?numbered:bool -> T.content T.section -> P.node diff --git a/lib/frontend/dune b/lib/frontend/dune index b0309da..9bf2315 100644 --- a/lib/frontend/dune +++ b/lib/frontend/dune @@ -45,4 +45,5 @@ pure-html logs uri - routes)) + routes + saturn)) diff --git a/lib/server/Server.ml b/lib/server/Server.ml index d00a5a9..363e1fa 100644 --- a/lib/server/Server.ml +++ b/lib/server/Server.ml @@ -97,20 +97,11 @@ let tree_handler ~(forest : State.t) ~request_headers ~href = let content, _errors = let@ () = Html_client.collect_and_report_errors ~forest in match Headers.parse_content_target request_headers with - | Some (T.Full flags as target) -> - (* Rendering this through State.get_content_of_transclusion - with a fresh counter would always yield "1" as the section number. - Instead we parse the numbering context from the headers. *) - let number = Headers.parse_numbering request_headers in - let env = {env with number; numbered = flags.numbered} in + | Some (T.Full _ as target) -> + let numbered = Headers.parse_numbering request_headers in Option.map (fun section -> - H.null - [ - Html_client.render_section ~env - ?number:(if flags.numbered then Some number else None) - section; - ]) + H.null [Html_client.render_section ~env ~numbered section]) (State.get_section ~forest {target; href; range = None}) | Some target -> Option.map (render >>> H.null) diff --git a/test/htmx-numbering.t b/test/htmx-numbering.t index 753e897..8678609 100644 --- a/test/htmx-numbering.t +++ b/test/htmx-numbering.t @@ -1,7 +1,5 @@ -Transclusions rendered in HTMX mode must not reset their section numbering to 1 -on every independent fetch. The HTML client encodes the number into the -hx-headers payload, and tree_handler decodes it to seed the fragment's render -with the right number instead of always starting over from a fresh counter. +Numbering is done via CSS, so this code just verifies that the appropriate CSS +classes are being set $ forester init > /dev/null @@ -32,28 +30,16 @@ This is what the server would do via the headers encoded in the page: $ curl -s -H "Hx-Request: true" -H "Full: true" -H "Included-In-Toc: true" \ > -H "Header-Shown: true" -H "Metadata-Shown: false" \ - > -H "Numbered: true" -H "Expanded: true" \ - > -H "Number-Path: 2" \ - > http://localhost:8082/preview/b/ | grep -oE '[^<]*' - 2. + > -H "Numbered-Effective: true" -H "Expanded: true" \ + > http://localhost:8082/preview/b/ | grep -oE '[^<]*()?[^<]*' + - -But we can request the section to be returned with arbitrary numbering: - - $ curl -s -H "Hx-Request: true" -H "Full: true" -H "Included-In-Toc: true" \ - > -H "Header-Shown: true" -H "Metadata-Shown: false" \ - > -H "Numbered: true" -H "Expanded: true" \ - > -H "Number-Path: 2,3,6" \ - > http://localhost:8082/preview/b/ | grep -oE '[^<]*' - 6.3.2. - -We can also disable numbering, via the Numbered flag: +We can also disable numbering, via the Numbered-Effective flag: $ curl -s -H "Hx-Request: true" -H "Full: true" -H "Included-In-Toc: true" \ > -H "Header-Shown: true" -H "Metadata-Shown: false" \ - > -H "Numbered: false" -H "Expanded: true" \ - > -H "Number-Path: 2" \ - > http://localhost:8082/preview/b/ | grep -oE '[^<]*' + > -H "Numbered-Effective: false" -H "Expanded: true" \ + > http://localhost:8082/preview/b/ | grep -oE '[^<]*()?[^<]*' $ kill $SERVER_PID diff --git a/test/ok.t b/test/ok.t index b814de0..a6a058b 100644 --- a/test/ok.t +++ b/test/ok.t @@ -30,7 +30,18 @@
-

[index]

    Hello, world!
    +
    + +
    +

    [index]

    +
    +
      +
    +
    +
    +     +
    Hello, world!
    +
    @@ -43,5 +54,6 @@ A tree with no metadata should have an empty metadata list rather than a stray meta-item that produces a leading bullet. - $ grep -o '
    .*
    ' output/index/index.html -
    + $ grep -c 'class="meta-item"' output/index/index.html + 0 + [1] diff --git a/test/queries.t b/test/queries.t index a01887e..0e71b74 100644 --- a/test/queries.t +++ b/test/queries.t @@ -72,27 +72,31 @@ TODO: use grep to verify what we want: -
    -
    - -
    -

    Reference. Some novel result [paper]

    -
    - -
    -
    -     -
    -
    +
    +
    +
    + +
    +

    Reference. Some novel result [paper]

    +
    + +
    +
    +     +
    +
    +
    +
    +
    diff --git a/test/section-numbering.t b/test/section-numbering.t index dcdc17a..5045d9b 100644 --- a/test/section-numbering.t +++ b/test/section-numbering.t @@ -16,10 +16,13 @@ $ forester build > /dev/null - $ grep -o '[^<]*' output/index/index.html - - One 1. - 2. - - 3. - 3.1. +The numbers themselves are computed with CSS, so this just checks that the +correct classes are set + + $ grep -o '
    /dev/null - $ grep -Fo '

    Person 1. Foo Bar [foo]

    ' output/index/index.html -

    Person 1. Foo Bar [foo]

    + $ grep -Fo '

    PersonFoo Bar [foo]

    ' output/index/index.html +

    PersonFoo Bar [foo]

    -- 2.51.2