forked from
jonmsterling.com/ocaml-forester
ocaml
Delete Htmx_client, WIP refactor of Html_client and Server
- The HTMX and HTML client only differed in the way they rendered the
hypermedia controls, so it was natural to introduce a "mode" type and
to have the renderer be parametrised over this type.
- Introduced the notion of hypermedia control at the type level.
- Added a template sublibrary.
- Added HTTP form utilities.
- Added a config route to the server. This will enable switching between
forests at runtime.
+656
-915
+2
lib/core/Base.ml
+2
lib/core/Base.ml
+1
lib/core/Base.mli
+1
lib/core/Base.mli
+8
-7
lib/frontend/Forester.ml
+8
-7
lib/frontend/Forester.ml
···
12
12
module M = URI.Map
13
13
module T = Types
14
14
module EP = Eio.Path
15
+
module P = Pure_html
15
16
end
16
17
17
18
type env = Eio_unix.Stdenv.base
···
19
20
type target = HTML | JSON | XML | STRING
20
21
21
22
let output_dir_name = "output"
23
+
24
+
module Theme_site = Theme_site
25
+
26
+
include Forest_util
22
27
23
28
let create_tree ~env ~dest_dir ~prefix ~template ~mode ~(forest : State.t) =
24
29
let next = URI_util.next_uri ~prefix ~mode ~forest in
···
103
108
| None -> []
104
109
| Some uri ->
105
110
let html_route = URI.append_path_component uri "index.html" in
106
-
let html_content =
107
-
Pure_html.to_string @@ Html_client.render_page ~forest article
108
-
in
111
+
let html_content = P.to_string @@ Html_client.render_page ~forest article in
109
112
let debug_route = URI.append_path_component uri "index.tree" in
110
113
let debug_content =
111
114
Format.asprintf "%a" Types.(pp_article pp_content) article
···
147
150
Atom_client.render_feed forest ~source_uri:syndication.source_uri
148
151
~feed_uri:syndication.feed_uri
149
152
in
150
-
let atom_content =
151
-
Format.asprintf "%a" (Pure_html.pp_xml ~header:true) atom_nodes
152
-
in
153
+
let atom_content = Format.asprintf "%a" (P.pp_xml ~header:true) atom_nodes in
153
154
[(syndication.feed_uri, atom_content)]
154
155
155
156
let outputs_for_syndication ~(forest : State.t) = function
···
183
184
let jobs =
184
185
let home_route = URI.append_path_component forest.config.url "index.html" in
185
186
let home_content =
186
-
Pure_html.to_string
187
+
P.to_string
187
188
@@ Html_client.html_redirect
188
189
~path:(uri_to_local_path ~forest forest.config.home)
189
190
in
+3
lib/frontend/Forester.mli
+3
lib/frontend/Forester.mli
+1
-1
lib/frontend/Forester_frontend.ml
+1
-1
lib/frontend/Forester_frontend.ml
···
11
11
module DSL = DSL
12
12
module Loop_detection = Loop_detection
13
13
module Html_client = Html_client
14
-
module Htmx_client = Htmx_client
15
14
module Plain_text_client = Plain_text_client
16
15
module Legacy_xml_client = Legacy_xml_client
17
16
module Json_manifest_client = Json_manifest_client
17
+
module Router = Router
18
18
19
19
module Theme_site : sig
20
20
module Sites : sig
+53
lib/frontend/Headers.ml
+53
lib/frontend/Headers.ml
···
1
+
open Forester_core
2
+
3
+
open struct
4
+
module T = Types
5
+
module P = Pure_html
6
+
module H = Pure_html.HTML
7
+
end
8
+
9
+
let of_title_flags (flags : T.title_flags) =
10
+
match flags with
11
+
| {empty_when_untitled} ->
12
+
`Assoc
13
+
[("Empty-When-Untitled", `String (Bool.to_string empty_when_untitled))]
14
+
15
+
(* I am encoding these headers to JSON because that is what HTMX requires, but
16
+
it would be more beautiful if we could directly use the header type*)
17
+
let of_section_flags (flags : T.section_flags) =
18
+
match flags with
19
+
| {
20
+
hidden_when_empty;
21
+
included_in_toc;
22
+
header_shown;
23
+
metadata_shown;
24
+
numbered;
25
+
expanded;
26
+
} ->
27
+
let to_header l t =
28
+
match t with
29
+
| Some v -> Some (l, `String (Bool.to_string v))
30
+
| None -> None
31
+
in
32
+
let headers =
33
+
[
34
+
to_header "Hidden-When-Empty" hidden_when_empty;
35
+
to_header "Included-In-Toc" included_in_toc;
36
+
to_header "Header-Shown" header_shown;
37
+
to_header "Metadata-Shown" metadata_shown;
38
+
to_header "Numbered" numbered;
39
+
to_header "Expanded" expanded;
40
+
]
41
+
in
42
+
`Assoc (List.filter_map Fun.id headers)
43
+
44
+
let of_content_target (target : T.content_target) =
45
+
match target with
46
+
| T.Full flags ->
47
+
let (`Assoc flags) = of_section_flags flags in
48
+
`Assoc (("Full", `String "true") :: flags)
49
+
| T.Mainmatter -> `Assoc [("Mainmatter", `String "true")]
50
+
| T.Title flags ->
51
+
let (`Assoc flags) = of_title_flags flags in
52
+
`Assoc (("Title", `String "true") :: flags)
53
+
| T.Taxon -> `Assoc [("Taxon", `String "true")]
+144
-201
lib/frontend/Html_client.ml
+144
-201
lib/frontend/Html_client.ml
···
9
9
open Forester_compiler
10
10
open Forester_xml_names
11
11
open State.Syntax
12
+
open Templates
13
+
open Combinators
12
14
13
15
open struct
14
16
module T = Types
17
+
module PT = Plain_text_client
15
18
module P = Pure_html
16
19
module X = Xml_forester
17
20
module H = P.HTML
18
-
end
21
+
module Hx = P.Hx
19
22
20
-
module Env = struct
21
-
type t = {
22
-
forest: State.t;
23
-
scope: URI.t option;
24
-
loops: Loop_detection.t;
25
-
xmlns: Xmlns.t;
26
-
in_backmatter: bool;
27
-
htmx: bool;
28
-
}
29
-
let default ~forest =
30
-
{
31
-
forest;
32
-
scope = None;
33
-
loops = Loop_detection.empty;
34
-
xmlns =
35
-
Xmlns.init
36
-
~reserved:[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
37
-
in_backmatter = false;
38
-
htmx = false;
39
-
}
23
+
type query = (string, T.content T.vertex) Forester_core.Datalog_expr.query
24
+
[@@deriving repr]
40
25
end
41
26
42
-
open Env
27
+
type 'a control =
28
+
| Transclusion : T.transclusion -> T.transclusion control
29
+
| Link : T.(content link) -> T.(content link) control
30
+
| Query : query -> query control
31
+
32
+
type 'a client = 'a control -> P.node
33
+
34
+
type env = {
35
+
forest: State.t;
36
+
scope: URI.t option;
37
+
loops: Loop_detection.t;
38
+
xmlns: Xmlns.t;
39
+
in_backmatter: bool;
40
+
mode: mode;
41
+
}
42
+
43
+
let htmx_router : type a. a control -> string * Yojson.Safe.t = function
44
+
| Transclusion {target; href} ->
45
+
( Routes.sprintf Router.(trees ()) URI.(path_string href),
46
+
Headers.of_content_target target )
47
+
| Link {href; _} ->
48
+
(Routes.sprintf Router.(trees ()) URI.(path_string href), `Assoc [])
49
+
| Query _ -> (Routes.sprintf Router.(query ()), `Assoc [])
43
50
44
51
let generate_id (frontmatter : T.(content frontmatter)) =
45
52
let id = Hashtbl.hash frontmatter in
46
53
Format.asprintf "id%i" id
47
-
48
-
let optional opt kont = match opt with None -> H.null [] | Some v -> kont v
49
-
let optional_ opt kont = match opt with None -> H.null_ | Some v -> kont v
50
-
51
-
let conditional test kont = if test then kont else H.null []
52
-
let conditional_ test kont = if test then kont else H.null_
53
54
54
55
let is_set_to test bopt = match bopt with None -> false | Some b -> b = test
55
56
···
82
83
mainmatter
83
84
84
85
(* FIXME: Handle the case when users deploy forests to subdirectories *)
86
+
(* Also clean this up, its ugly*)
85
87
let route ~env uri =
86
88
let is_local = URI.host uri = URI.host env.forest.config.url in
89
+
let is_docs = URI.host uri = Some "docs" in
87
90
if is_local then Format.asprintf "%sindex.html" (URI.path_string uri)
91
+
else if is_docs then
92
+
Format.asprintf "/foreign/docs%sindex.html" (URI.path_string uri)
88
93
else Format.asprintf "%a" URI.pp uri
89
94
90
95
let render_date ~env (date : Human_datetime.t) =
···
147
152
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
148
153
149
154
let render_xml_attr ~env T.{key; value} =
150
-
let str_value =
151
-
Plain_text_client.string_of_content ~forest:env.forest value
152
-
in
155
+
let str_value = PT.string_of_content ~forest:env.forest value in
153
156
P.string_attr (render_xml_qname key) "%s" str_value
154
157
155
158
let render_xmlns_prefix ({prefix; xmlns} : Forester_xml_names.xmlns_attr) =
156
159
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
157
160
P.string_attr attr "%s" xmlns
158
161
159
-
let rec render_content ~env (Content content : T.content) : P.node list =
162
+
let rec render_control : type a. env:env -> a client =
163
+
let htmx : type a. env:env -> a client =
164
+
fun ~env -> function
165
+
| Transclusion {href; target} as t ->
166
+
let headers =
167
+
Yojson.Safe.to_string @@ Headers.of_content_target target
168
+
in
169
+
let route, _ = htmx_router t in
170
+
H.span
171
+
[
172
+
Hx.get "%s" route;
173
+
Hx.trigger "load";
174
+
Hx.target "this";
175
+
Hx.swap "outerHTML";
176
+
Hx.headers "%s" headers;
177
+
]
178
+
[P.txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)]
179
+
| Link {href; content} ->
180
+
let is_local = URI.host href = URI.host env.forest.config.url in
181
+
let href =
182
+
if is_local then
183
+
H.href "%s" (Routes.sprintf Router.(trees ()) URI.(path_string href))
184
+
else H.href "%s" (Format.asprintf "%a" URI.pp href)
185
+
in
186
+
H.span
187
+
[
188
+
(if is_local then H.class_ "link local" else H.class_ "link external");
189
+
]
190
+
[H.a [href] @@ render_content ~env content]
191
+
| Query q ->
192
+
H.span
193
+
[
194
+
Hx.get "/query";
195
+
Hx.trigger "load";
196
+
Hx.swap "outerHTML";
197
+
Hx.target "this";
198
+
Hx.vals "%s" Repr.(to_json_string ~minify:true query_t q);
199
+
]
200
+
[]
201
+
and html : type a. env:env -> a client =
202
+
fun ~env -> function
203
+
| Transclusion t -> begin
204
+
match State.get_content_of_transclusion ~forest:env.forest t with
205
+
| None -> Reporter.fatal (Resource_not_found t.href)
206
+
| Some content -> H.null @@ render_content ~env content
207
+
end
208
+
| Link link -> render_link ~env link
209
+
| Query q -> render_query_result ~env q |> H.null
210
+
in
211
+
fun ~env -> match env.mode with Static -> html ~env | Dynamic -> htmx ~env
212
+
213
+
and default_env ~forest =
214
+
{
215
+
forest;
216
+
scope = None;
217
+
loops = Loop_detection.empty;
218
+
xmlns =
219
+
Xmlns.init
220
+
~reserved:[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
221
+
in_backmatter = false;
222
+
mode = Static;
223
+
}
224
+
225
+
and dynamic_env ~forest = {(default_env ~forest) with mode = Dynamic}
226
+
227
+
and render_content ~env (Content content : T.content) : P.node list =
160
228
match content with
161
229
| T.Text txt0 :: T.Text txt1 :: content ->
162
230
render_content ~env @@ Content (T.Text (txt0 ^ txt1) :: content)
···
199
267
| KaTeX (_, content) -> [P.HTML.code [] @@ render_content ~env content]
200
268
| Artefact artefact -> render_content ~env @@ artefact.content
201
269
| Section section -> [render_section ~env section]
202
-
| Transclude transclusion -> render_transclusion ~env transclusion
203
-
| Link link -> [render_link ~env link]
204
-
| Results_of_datalog_query q ->
205
-
let article_to_section =
206
-
T.article_to_section
207
-
~flags:
208
-
{
209
-
T.default_section_flags with
210
-
expanded = Some false;
211
-
numbered = Some false;
212
-
included_in_toc = Some false;
213
-
metadata_shown = Some true;
214
-
}
215
-
in
216
-
let results = Forest.run_datalog_query env.forest.graphs q in
217
-
let@ article =
218
-
List.map @~ Forest_util.get_sorted_articles ~forest:env.forest results
219
-
in
220
-
render_section ~env @@ article_to_section article
270
+
| Transclude t -> [render_control ~env (Transclusion t)]
271
+
| Link link -> [render_control ~env (Link link)]
272
+
| Results_of_datalog_query q -> [render_control ~env (Query q)]
221
273
| Datalog_script _ -> []
222
274
275
+
and render_query_result ~env q =
276
+
let to_section =
277
+
T.article_to_section
278
+
~flags:
279
+
{
280
+
T.default_section_flags with
281
+
expanded = Some false;
282
+
numbered = Some false;
283
+
included_in_toc = Some false;
284
+
metadata_shown = Some true;
285
+
}
286
+
in
287
+
let results = Forest.run_datalog_query env.forest.graphs q in
288
+
let@ article =
289
+
List.map @~ Forest_util.get_sorted_articles ~forest:env.forest results
290
+
in
291
+
render_section ~env @@ to_section article
292
+
223
293
and render_link ~env (link : T.content T.link) : P.node =
224
294
let is_local = URI.host link.href = URI.host env.forest.config.url in
225
295
let href =
···
230
300
[(if is_local then H.class_ "link local" else H.class_ "link external")]
231
301
[H.a [href] @@ render_content ~env link.content]
232
302
233
-
and render_transclusion ~env (transclusion : T.transclusion) : P.node list =
234
-
match State.get_content_of_transclusion ~forest:env.forest transclusion with
235
-
| None -> Reporter.fatal (Resource_not_found transclusion.href)
236
-
| Some content -> render_content ~env content
237
-
238
303
and _render_section_for_atom_client ~env (section : T.content T.section) :
239
304
P.node list =
240
305
let env = {env with scope = section.frontmatter.uri} in
···
263
328
];
264
329
]
265
330
266
-
and render_attributions ~env (attributions : T.content T.attribution list) =
267
-
let render_attribution attribution =
268
-
match attribution with
269
-
| T.{vertex; _} -> (
270
-
match vertex with
271
-
| T.Uri_vertex href ->
272
-
let content =
273
-
T.Content
274
-
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
275
-
in
276
-
render_link ~env T.{href; content}
277
-
| T.Content_vertex content -> H.null @@ render_content ~env content)
278
-
in
279
-
let authors, contributors =
280
-
attributions
281
-
|> List.partition_map @@ fun a ->
282
-
match T.(a.role) with T.Author -> Left a | Contributor -> Right a
283
-
in
284
-
H.li
285
-
[H.class_ "meta-item"]
286
-
[
287
-
H.address [H.class_ "author"]
288
-
@@ List.map render_attribution authors
289
-
@ begin if List.length contributors > 0 then
290
-
[P.txt "with contributions from "]
291
-
else []
292
-
end
293
-
@ List.map render_attribution contributors;
294
-
]
295
-
296
331
and default_meta_item ~env frontmatter meta =
297
332
optional (get_meta frontmatter meta) (fun content ->
298
333
H.li [H.class_ "meta-item"] (render_content ~env content))
···
343
378
344
379
and render_doi ~env frontmatter =
345
380
optional (get_meta frontmatter "doi") (fun c ->
346
-
let doi = Plain_text_client.string_of_content ~forest:env.forest c in
381
+
let doi = PT.string_of_content ~forest:env.forest c in
347
382
H.li
348
383
[H.class_ "meta-item"]
349
384
[
···
354
389
355
390
and render_orcid ~env frontmatter =
356
391
optional (get_meta frontmatter "orcid") (fun c ->
357
-
let orcid = Plain_text_client.string_of_content ~forest:env.forest c in
392
+
let orcid = PT.string_of_content ~forest:env.forest c in
358
393
H.li
359
394
[H.class_ "meta-item"]
360
395
[
···
365
400
366
401
and render_external ~env frontmatter =
367
402
optional (get_meta frontmatter "external") (fun c ->
368
-
let link = Plain_text_client.string_of_content ~forest:env.forest c in
403
+
let link = PT.string_of_content ~forest:env.forest c in
369
404
H.li
370
405
[H.class_ "meta-item"]
371
406
[
···
376
411
377
412
and render_slides ~env frontmatter =
378
413
optional (get_meta frontmatter "slides") (fun c ->
379
-
let link = Plain_text_client.string_of_content ~forest:env.forest c in
414
+
let link = PT.string_of_content ~forest:env.forest c in
380
415
H.li
381
416
[H.class_ "meta-item"]
382
417
[H.a [H.class_ "link external"; H.href "%s" link] [P.txt "Slides"]])
383
418
384
419
and render_video ~env frontmatter =
385
420
optional (get_meta frontmatter "video") (fun c ->
386
-
let link = Plain_text_client.string_of_content ~forest:env.forest c in
421
+
let link = PT.string_of_content ~forest:env.forest c in
387
422
H.li
388
423
[H.class_ "meta-item"]
389
424
[H.a [H.class_ "link external"; H.href "%s" link] [P.txt "Video"]])
···
603
638
| _ -> H.href "%s" id)
604
639
uri;
605
640
optional_ title (fun title ->
606
-
let title =
607
-
Plain_text_client.string_of_content ~forest:env.forest title
608
-
in
641
+
let title = PT.string_of_content ~forest:env.forest title in
609
642
let display_uri =
610
643
Option.value ~default:""
611
644
@@ Option.map
···
640
673
let render_article_as_div ~(forest : State.t) (article : T.content T.article) :
641
674
P.node =
642
675
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
643
-
let env =
644
-
{
645
-
forest;
646
-
scope = article.frontmatter.uri;
647
-
loops = Loop_detection.empty;
648
-
xmlns = Xmlns.init ~reserved;
649
-
in_backmatter = false;
650
-
htmx = false;
651
-
}
652
-
in
676
+
let env = {(default_env ~forest) with scope = article.frontmatter.uri} in
653
677
H.div
654
678
(List.map render_xmlns_prefix reserved)
655
679
[H.null @@ render_content ~env article.mainmatter]
656
680
657
-
(* I don't want these optional arguments to accumulate, but for now they are
658
-
necessary in order to keep the template agnostic but also allow modification
659
-
based on the content.*)
660
-
let page_template ~is_home ~dev ~title:ttl ?htmx ?source_path c =
661
-
let open H in
662
-
html []
663
-
[
664
-
head []
665
-
[
666
-
meta [http_equiv `content_type; content "text/html"; charset "UTF-8"];
667
-
meta
668
-
[name "viewport"; content "width=device-width, initial-scale=1.0"];
669
-
link [rel "stylesheet"; href "/style.css"];
670
-
link [rel "stylesheet"; href "/katex.min.css"];
671
-
(* script [type_ "module"; src "/forester.js"] ""; *)
672
-
optional source_path (fun path ->
673
-
script [type_ "module"] "window.sourcePath = '%s'" path);
674
-
script [type_ "module"; src "/min.js"] "";
675
-
optional htmx (fun _ -> script [type_ "module"; src "/htmx.js"] "");
676
-
H.title [] "%s" ttl;
677
-
];
678
-
body []
679
-
[
680
-
P.std_tag "ninja-keys"
681
-
[placeholder "Start typing a note title or ID"]
682
-
[];
683
-
header
684
-
[class_ "header"]
685
-
[
686
-
nav
687
-
[class_ "nav"]
688
-
[
689
-
conditional (not is_home)
690
-
(div
691
-
[class_ "logo"]
692
-
[
693
-
a
694
-
[href "/index/index.html"; title_ "home"]
695
-
[P.txt "« Home"];
696
-
]);
697
-
conditional dev
698
-
(div
699
-
[class_ "nav-right"]
700
-
[
701
-
a
702
-
[
703
-
href "/foreign/docs/index";
704
-
class_ "docs-button link local";
705
-
]
706
-
[P.txt "Docs"];
707
-
]);
708
-
];
709
-
];
710
-
div [id "grid-wrapper"] c;
711
-
];
712
-
]
713
-
714
-
let render_page_raw ~env
715
-
({mainmatter = T.Content mainmatter; _} as tree : _ T.article) =
716
-
let open H in
717
-
null
718
-
[
719
-
render_article ~env tree;
720
-
conditional (should_render_toc tree)
721
-
@@ nav
722
-
[id "toc"]
723
-
[
724
-
div
725
-
[class_ "block"]
726
-
[h1 [] [P.txt "Table of Contents"]; render_toc ~env mainmatter];
727
-
];
728
-
]
729
-
730
-
let render_page ~forest ?htmx
681
+
let render_page ~forest ?(mode = Static)
731
682
({frontmatter; mainmatter = T.Content mainmatter; _} as tree : _ T.article)
732
683
: P.node =
733
-
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
734
-
let env =
735
-
{
736
-
forest;
737
-
scope = frontmatter.uri;
738
-
loops = Loop_detection.empty;
739
-
xmlns = Xmlns.init ~reserved;
740
-
in_backmatter = false;
741
-
htmx = Option.value ~default:false htmx;
742
-
}
743
-
in
684
+
let env = {(default_env ~forest) with scope = frontmatter.uri; mode} in
744
685
let ttl =
745
686
match frontmatter.title with
746
687
| None -> (* FIXME: *) ""
···
748
689
let title =
749
690
State.get_expanded_title ?scope:env.scope frontmatter env.forest
750
691
in
751
-
Plain_text_client.string_of_content ~forest:env.forest title
692
+
PT.string_of_content ~forest:env.forest title
752
693
in
753
-
let open H in
754
694
let is_home = is_home ~env frontmatter.uri in
755
695
let dev = forest.dev in
756
-
page_template ~dev ~is_home ~title:ttl ?source_path:frontmatter.source_path
757
-
~htmx
696
+
let content =
758
697
[
759
698
render_article ~env tree;
760
-
conditional (should_render_toc tree)
761
-
@@ nav
762
-
[id "toc"]
763
-
[
764
-
div
765
-
[class_ "block"]
766
-
[h1 [] [P.txt "Table of Contents"]; render_toc ~env mainmatter];
767
-
];
699
+
(conditional (should_render_toc tree)
700
+
@@ H.(
701
+
nav
702
+
[id "toc"]
703
+
[
704
+
div
705
+
[class_ "block"]
706
+
[h1 [] [P.txt "Table of Contents"]; render_toc ~env mainmatter];
707
+
]));
768
708
]
709
+
in
710
+
Templates.page ~render_header:true ~dev ~is_home ~title_string:ttl
711
+
~source_path:frontmatter.source_path ~mode content
769
712
770
713
let html_redirect ~path =
771
714
H.html []
+40
lib/frontend/Html_client.mli
+40
lib/frontend/Html_client.mli
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
module T := Forester_core.Types
8
+
module P := Pure_html
9
+
module X := Forester_compiler.Xml_forester
10
+
module H := P.HTML
11
+
module Hx := P.Hx
12
+
13
+
type env = {
14
+
forest: Forester_compiler.State.t;
15
+
scope: Forester_core.URI.t option;
16
+
loops: Loop_detection.t;
17
+
xmlns: Forester_xml_names.Xmlns.t;
18
+
in_backmatter: bool;
19
+
mode: Forester_core.mode;
20
+
}
21
+
22
+
val default_env : forest:Forester_compiler.State.t -> env
23
+
val dynamic_env : forest:Forester_compiler.State.t -> env
24
+
25
+
val render_content : env:env -> T.content -> P.node list
26
+
27
+
val render_article_as_div :
28
+
forest:Forester_compiler.State.t -> T.content T.article -> P.node
29
+
30
+
val render_page :
31
+
forest:Forester_compiler.State.t ->
32
+
?mode:Forester_core.mode ->
33
+
T.content T.article ->
34
+
P.node
35
+
36
+
val html_redirect : path:string -> Pure_html.node
37
+
38
+
val render_article : env:env -> T.content T.article -> P.node
39
+
40
+
val render_section : env:env -> T.content T.section -> P.node
-510
lib/frontend/Htmx_client.ml
-510
lib/frontend/Htmx_client.ml
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
open Forester_prelude
8
-
open Forester_core
9
-
open Forester_compiler
10
-
open Forester_xml_names
11
-
12
-
open struct
13
-
module T = Types
14
-
module P = Pure_html
15
-
module Env = Html_client.Env
16
-
let render_date = Html_client.render_date
17
-
let render_attributions = Html_client.render_attributions
18
-
end
19
-
20
-
open Pure_html
21
-
open HTML
22
-
23
-
type query = {
24
-
query: (string, T.content T.vertex) Forester_core.Datalog_expr.query;
25
-
}
26
-
[@@deriving repr]
27
-
28
-
let local_path_components (uri : URI.t) =
29
-
let host =
30
-
match URI.host uri with Some host -> host | None -> assert false (* TODO*)
31
-
in
32
-
host :: URI.path_components uri
33
-
34
-
let route (forest : State.t) uri : URI.t =
35
-
let open State.Syntax in
36
-
match forest.={uri} with
37
-
| None -> uri
38
-
| Some _ ->
39
-
let path = "" :: local_path_components uri in
40
-
URI.make ~path ()
41
-
42
-
let title_flags_to_http_header (flags : T.title_flags) =
43
-
match flags with
44
-
| {empty_when_untitled} ->
45
-
`Assoc
46
-
[("Empty-When-Untitled", `String (Bool.to_string empty_when_untitled))]
47
-
48
-
(* I am encoding these headers to JSON because that is what HTMX requires, but
49
-
it would be more beautiful if we could directly use the header type*)
50
-
let section_flags_to_http_header (flags : T.section_flags) =
51
-
match flags with
52
-
| {
53
-
hidden_when_empty;
54
-
included_in_toc;
55
-
header_shown;
56
-
metadata_shown;
57
-
numbered;
58
-
expanded;
59
-
} ->
60
-
let to_header l t =
61
-
match t with
62
-
| Some v -> Some (l, `String (Bool.to_string v))
63
-
| None -> None
64
-
in
65
-
let headers =
66
-
[
67
-
to_header "Hidden-When-Empty" hidden_when_empty;
68
-
to_header "Included-In-Toc" included_in_toc;
69
-
to_header "Header-Shown" header_shown;
70
-
to_header "Metadata-Shown" metadata_shown;
71
-
to_header "Numbered" numbered;
72
-
to_header "Expanded" expanded;
73
-
]
74
-
in
75
-
`Assoc (List.filter_map Fun.id headers)
76
-
77
-
let content_target_to_http_header (target : T.content_target) =
78
-
match target with
79
-
| T.Full flags ->
80
-
let (`Assoc flags) = section_flags_to_http_header flags in
81
-
`Assoc (("Full", `String "true") :: flags)
82
-
| T.Mainmatter -> `Assoc [("Mainmatter", `String "true")]
83
-
| T.Title flags ->
84
-
let (`Assoc flags) = title_flags_to_http_header flags in
85
-
`Assoc (("Title", `String "true") :: flags)
86
-
| T.Taxon -> `Assoc [("Taxon", `String "true")]
87
-
88
-
let render_xml_qname = function
89
-
| {prefix = ""; uname; _} -> uname
90
-
| {prefix; uname; _} -> Format.sprintf "%s:%s" prefix uname
91
-
92
-
let render_xml_attr : T.content T.xml_attr -> _ =
93
-
fun T.{key; value = _} -> string_attr (render_xml_qname key) "todo"
94
-
(* "%a" render_content value *)
95
-
96
-
let render_xmlns_prefix ({prefix; xmlns} : xmlns_attr) =
97
-
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
98
-
string_attr attr "%s" xmlns
99
-
100
-
(*This type is just temporary until I figure out the logic *)
101
-
type toc_config = {
102
-
suffix: string;
103
-
taxon: string;
104
-
number: string;
105
-
fallback_number: string;
106
-
(* In XSL, hese require querying the ancestors. We can't do this here, so we
107
-
explicitly pass these parameters down*)
108
-
in_backmatter: bool;
109
-
is_root: bool;
110
-
implicitly_unnumbered: bool;
111
-
}
112
-
113
-
let default_toc_config ?(suffix = "") ?(taxon = "") ?(number = "")
114
-
?(fallback_number = "") ?(in_backmatter = false) () =
115
-
{
116
-
suffix;
117
-
taxon;
118
-
number;
119
-
fallback_number;
120
-
in_backmatter;
121
-
is_root = false;
122
-
implicitly_unnumbered = false;
123
-
}
124
-
125
-
let render_article ~forest ({frontmatter; _} as article : T.content T.article) :
126
-
node =
127
-
let env =
128
-
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
129
-
Env.
130
-
{
131
-
forest;
132
-
scope = frontmatter.uri;
133
-
loops = Loop_detection.empty;
134
-
xmlns = Xmlns.init ~reserved;
135
-
in_backmatter = false;
136
-
htmx = true;
137
-
}
138
-
in
139
-
Html_client.render_page_raw ~env article
140
-
141
-
let rec render_section ~env (section : T.content T.section) : node =
142
-
match section with
143
-
| {frontmatter; mainmatter; flags} ->
144
-
let test k = function
145
-
| Some true -> true
146
-
| Some false -> false
147
-
| None -> k
148
-
in
149
-
let class_ =
150
-
if test false flags.metadata_shown then class_ "block"
151
-
else class_ "block hide-metadata"
152
-
in
153
-
let data_taxon =
154
-
match frontmatter.taxon with
155
-
| None -> null_
156
-
| Some _c ->
157
-
(* string_attr "data-taxon" () *)
158
-
null_
159
-
in
160
-
HTML.section [class_; data_taxon]
161
-
[
162
-
(if test true flags.header_shown then
163
-
details
164
-
[(if test true flags.expanded then open_ else null_)]
165
-
[
166
-
summary [] [render_frontmatter ~env frontmatter];
167
-
null @@ render_content ~env mainmatter;
168
-
]
169
-
else null @@ render_content ~env mainmatter);
170
-
(* render_frontmatter forest frontmatter; *)
171
-
(* null @@ render_content forest mainmatter; *)
172
-
]
173
-
174
-
and render_frontmatter ~(env : Env.t) (frontmatter : T.content T.frontmatter) :
175
-
node =
176
-
let taxon =
177
-
Option.value ~default:[]
178
-
@@
179
-
let@ c = Option.map @~ frontmatter.taxon in
180
-
render_content ~env c @ [txt ". "]
181
-
in
182
-
let title =
183
-
Option.value ~default:[]
184
-
@@
185
-
let@ c = Option.map @~ frontmatter.title in
186
-
render_content ~env c
187
-
in
188
-
let uri =
189
-
match frontmatter.uri with
190
-
| None -> null []
191
-
| Some uri ->
192
-
let uri_str =
193
-
(* TODO: replace with proper routing from legacy xml client *)
194
-
Format.asprintf "%a" URI.pp (route env.forest uri)
195
-
in
196
-
a [class_ "slug"; href "%s" uri_str] [txt "[%s]" uri_str]
197
-
in
198
-
let source_path =
199
-
match frontmatter.source_path with
200
-
| Some path ->
201
-
[a [class_ "edit-button"; href "vscode://file%s" path] [txt "[edit]"]]
202
-
| None -> []
203
-
in
204
-
let find_meta key =
205
-
let@ str, content = List.find_map @~ frontmatter.metas in
206
-
if str = key then Some content else None
207
-
in
208
-
let render_meta key f =
209
-
Option.value ~default:(null []) (Option.map f (find_meta key))
210
-
in
211
-
let default_meta_item content =
212
-
li [class_ "meta-item"] (render_content ~env content)
213
-
in
214
-
let labelled_external_link ~href ~label =
215
-
li [class_ "meta-item"] [a [class_ "link external"; href] [txt "%s" label]]
216
-
in
217
-
let to_string =
218
-
Plain_text_client.string_of_content ~forest:env.forest
219
-
~router:(Legacy_xml_client.route env.forest)
220
-
in
221
-
let position = render_meta "position" default_meta_item in
222
-
let institution = render_meta "institution" default_meta_item in
223
-
let venue = render_meta "venue" default_meta_item in
224
-
let source = render_meta "source" default_meta_item in
225
-
let doi = render_meta "doi" default_meta_item in
226
-
let orcid =
227
-
render_meta "orcid" @@ fun c ->
228
-
let content = to_string c in
229
-
li
230
-
[class_ "meta-item"]
231
-
[
232
-
a
233
-
[class_ "doi link"; href "https://www.doi.org/%s" content]
234
-
[txt "%s" content];
235
-
]
236
-
in
237
-
let external_ =
238
-
render_meta "external" @@ fun c ->
239
-
let content = to_string c in
240
-
li
241
-
[class_ "meta-item"]
242
-
[a [class_ "link external"; href "%s" content] [txt "%s" content]]
243
-
in
244
-
let slides =
245
-
render_meta "slides" @@ fun c ->
246
-
labelled_external_link ~href:(href "%s" (to_string c)) ~label:"Slides"
247
-
in
248
-
let video =
249
-
render_meta "video" @@ fun c ->
250
-
labelled_external_link ~href:(href "%s" (to_string c)) ~label:"Video"
251
-
in
252
-
header []
253
-
[
254
-
h1 []
255
-
@@ [span [class_ "taxon"] taxon]
256
-
@ title
257
-
@ [txt " "; uri]
258
-
@ source_path;
259
-
div
260
-
[class_ "metadata"]
261
-
[
262
-
ul []
263
-
@@ List.map (render_date ~env) frontmatter.dates
264
-
@ [
265
-
render_attributions ~env frontmatter.attributions;
266
-
position;
267
-
institution;
268
-
venue;
269
-
source;
270
-
doi;
271
-
orcid;
272
-
external_;
273
-
slides;
274
-
video;
275
-
];
276
-
];
277
-
]
278
-
279
-
and render_transclusion transclusion =
280
-
match transclusion with
281
-
| T.{href; target} ->
282
-
let headers =
283
-
Yojson.Safe.to_string @@ content_target_to_http_header target
284
-
in
285
-
[
286
-
span
287
-
[
288
-
Hx.trigger "load";
289
-
Hx.get "/trees%s" (URI.path_string href);
290
-
Hx.target "this";
291
-
Hx.swap "outerHTML";
292
-
Hx.headers "%s" headers;
293
-
]
294
-
[txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)];
295
-
]
296
-
297
-
and render_content ~env (Content content : T.content) : node list =
298
-
List.concat_map (render_content_node ~env) content
299
-
300
-
and render_content_node ~env (node : 'a T.content_node) : node list =
301
-
match node with
302
-
| Text str -> [txt "%s" str]
303
-
| CDATA str -> [txt ~raw:true "<![CDATA[%s]]>" str]
304
-
| Xml_elt elt ->
305
-
let name = render_xml_qname elt.name in
306
-
let xmlns_attrs = Xmlns.xmlns_attrs_for_elt elt env.xmlns in
307
-
let env = {env with xmlns = Xmlns.extend xmlns_attrs env.xmlns} in
308
-
let content = render_content ~env elt.content in
309
-
[
310
-
P.std_tag name
311
-
(List.map render_xmlns_prefix xmlns_attrs
312
-
@ List.map render_xml_attr elt.attrs)
313
-
content;
314
-
]
315
-
| Transclude transclusion -> render_transclusion transclusion
316
-
| Contextual_number addr -> begin
317
-
match State.get_article ~forest:env.forest addr with
318
-
| Some a ->
319
-
[contextual_number (T.article_to_section a) (default_toc_config ())]
320
-
| None -> []
321
-
end
322
-
(* let custom_number = *)
323
-
(* article.frontmatter.number *)
324
-
(* in *)
325
-
(* let num = *)
326
-
(* match custom_number with *)
327
-
(* | None -> Format.asprintf "[%a]" URI.pp addr *)
328
-
(* | Some num -> num *)
329
-
(* in *)
330
-
(* [txt "%s" num] *)
331
-
| Link link -> render_link ~env link
332
-
| Section section -> [render_section ~env section]
333
-
| KaTeX (mode, content) ->
334
-
let body = Plain_text_client.string_of_content ~forest:env.forest content in
335
-
(* [txt ~raw: true "%s%s%s" l body r] *)
336
-
begin match mode with
337
-
| Inline -> [span [class_ "math"] [txt ~raw:true "%s" body]]
338
-
| Display -> [div [class_ "math"] [txt ~raw:true "%s" body]]
339
-
end
340
-
| Results_of_datalog_query q ->
341
-
(* We could just evaluate the query immediately. This is just experimental*)
342
-
[
343
-
span
344
-
[
345
-
Hx.get "/query";
346
-
Hx.trigger "load";
347
-
Hx.swap "outerHTML";
348
-
Hx.target "this";
349
-
Hx.vals "%s" Repr.(to_json_string ~minify:true query_t {query = q});
350
-
]
351
-
[];
352
-
]
353
-
| T.Datalog_script _ -> []
354
-
| T.Artefact _ | T.Uri _ | T.Route_of_uri _ -> [txt "todo"]
355
-
356
-
(* TODO: links need to be flattened in order to produce valid HTML. *)
357
-
and render_link ~env (link : T.content T.link) : node list =
358
-
let attrs =
359
-
match State.get_article ~forest:env.forest link.href with
360
-
| None ->
361
-
(* TODO: rendering of hrefs is suboptimal... *)
362
-
[href "%s" (Format.asprintf "%a" URI.pp link.href)]
363
-
| Some article -> begin
364
-
match article.frontmatter.uri with
365
-
| Some _uri ->
366
-
[
367
-
title_ "%s" @@ Option.value ~default:""
368
-
@@ Option.map
369
-
(Plain_text_client.string_of_content ~forest:env.forest
370
-
~router:(Legacy_xml_client.route env.forest))
371
-
article.frontmatter.title;
372
-
href "/trees%s" (Format.asprintf "%s" (URI.path_string link.href));
373
-
Hx.target "#tree-container";
374
-
Hx.swap "innerHTML";
375
-
]
376
-
| None -> [HTML.null_]
377
-
end
378
-
in
379
-
[span [class_ "link local"] [a attrs (render_content ~env link.content)]]
380
-
381
-
and contextual_number (_tree : T.content T.section) (cfg : toc_config) =
382
-
let should_number =
383
-
cfg.number <> ""
384
-
|| (not cfg.in_backmatter) && (not cfg.is_root)
385
-
&& not cfg.implicitly_unnumbered
386
-
in
387
-
let taxon =
388
-
if cfg.taxon <> "" then
389
-
cfg.taxon ^ if should_number || cfg.fallback_number <> "" then " " else ""
390
-
else ""
391
-
in
392
-
let number =
393
-
if should_number then
394
-
if cfg.number <> String.empty then cfg.number
395
-
else
396
-
(* TODO: Implement this: <xsl:number format="1.1"
397
-
count="f:tree[ancestor::f:tree and (not(@toc='false' or
398
-
@numbered='false'))]" level="multiple" />
399
-
*)
400
-
assert false
401
-
else if cfg.fallback_number <> String.empty then cfg.fallback_number
402
-
else ""
403
-
in
404
-
let suffix =
405
-
if
406
-
cfg.taxon <> String.empty
407
-
|| cfg.fallback_number <> String.empty
408
-
|| should_number
409
-
then cfg.suffix
410
-
else ""
411
-
in
412
-
null [txt "%s %s %s" taxon suffix number]
413
-
414
-
and _tree_taxon_with_number (_tree : T.content T.section) cfg =
415
-
(*TODO: Implement.*)
416
-
contextual_number _tree cfg
417
-
418
-
and _render_toc_item ~(env : Env.t) (item : T.content T.section) =
419
-
let to_str =
420
-
Plain_text_client.string_of_content ~forest:env.forest
421
-
~router:(Legacy_xml_client.route env.forest)
422
-
in
423
-
null
424
-
[
425
-
a
426
-
[
427
-
class_ "bullet";
428
-
href "";
429
-
title_ "%s%s"
430
-
(Option.value ~default:""
431
-
@@ Option.map to_str item.frontmatter.title)
432
-
(Option.value ~default:""
433
-
@@ Option.map (Format.asprintf "[%a]" URI.pp) item.frontmatter.uri);
434
-
]
435
-
[txt "■"];
436
-
span
437
-
[class_ "link local"]
438
-
[
439
-
span
440
-
[class_ "taxon"]
441
-
[_tree_taxon_with_number item (default_toc_config ())];
442
-
(* null @@ render_content forest item.mainmatter; *)
443
-
];
444
-
ul [] (render_content ~env item.mainmatter);
445
-
]
446
-
447
-
and render_toc_mainmatter content =
448
-
let (T.Content nodes) = content in
449
-
ul [class_ "block"]
450
-
@@
451
-
let@ node = List.filter_map @~ nodes in
452
-
match node with T.Section section -> Some (render_toc section) | _ -> None
453
-
454
-
and render_toc (section : T.content T.section) =
455
-
if
456
-
Some false
457
-
= List.find_map
458
-
(fun (k, v) ->
459
-
if k = "toc" && v = T.Content [T.Text "true"] then Some true else None)
460
-
section.frontmatter.metas
461
-
then null []
462
-
else
463
-
nav
464
-
[id "toc"; Hx.swap_oob "true"]
465
-
[
466
-
div
467
-
[class_ "block"]
468
-
[
469
-
h1 [] [txt "Table of contents"];
470
-
render_toc_mainmatter section.mainmatter;
471
-
];
472
-
]
473
-
474
-
let render_query_result ~forest (vs : Vertex_set.t) =
475
-
let module C = Types.Comparators (struct
476
-
let string_of_content =
477
-
Plain_text_client.string_of_content ~forest ~router:(route forest)
478
-
end) in
479
-
let env : Env.t =
480
-
{
481
-
forest;
482
-
scope = None;
483
-
loops = Loop_detection.empty;
484
-
xmlns =
485
-
Xmlns.init
486
-
~reserved:[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
487
-
in_backmatter = false;
488
-
htmx = true;
489
-
}
490
-
in
491
-
let make_section =
492
-
T.article_to_section
493
-
~flags:
494
-
{
495
-
T.default_section_flags with
496
-
expanded = Some false;
497
-
numbered = Some false;
498
-
included_in_toc = Some false;
499
-
metadata_shown = Some true;
500
-
}
501
-
in
502
-
let nodes =
503
-
vs |> Vertex_set.to_seq
504
-
|> Seq.filter_map Vertex.uri_of_vertex
505
-
|> Seq.filter_map (State.get_article ~forest)
506
-
|> List.of_seq
507
-
|> List.sort C.compare_article
508
-
|> List.map (Fun.compose (render_section ~env) make_section)
509
-
in
510
-
div [class_ "tree-content"] nodes
-16
lib/frontend/Htmx_client.mli
-16
lib/frontend/Htmx_client.mli
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
open Forester_core
8
-
open Forester_compiler
9
-
module T := Types
10
-
module Env := Html_client.Env
11
-
12
-
val render_article : forest:State.t -> T.content T.article -> Pure_html.node
13
-
val render_content : env:Env.t -> T.content -> Pure_html.node list
14
-
val render_toc_mainmatter : T.content -> Pure_html.node
15
-
val render_query_result :
16
-
forest:State.t -> Forester_core.Vertex_set.t -> Pure_html.node
+67
lib/frontend/Router.ml
+67
lib/frontend/Router.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
open Routes
8
+
9
+
(* Static content that should always be available *)
10
+
type static =
11
+
| Js_bundle
12
+
| Favicon
13
+
| Search_menu
14
+
| Htmx
15
+
| Stylesheet
16
+
| Font of string
17
+
| KaTeX_style
18
+
| KaTeX_bundle
19
+
20
+
type route =
21
+
| Static of static
22
+
| Index
23
+
| Tree of string
24
+
| Foreign_tree of string
25
+
| Home
26
+
| Search
27
+
| Query
28
+
| Config
29
+
| Json_manifest
30
+
31
+
let index () = nil
32
+
let font () = s "fonts" / str /? nil
33
+
let stylesheet () = s "style.css" /? nil
34
+
let js_bundle () = s "min.js" /? nil
35
+
let favicon () = s "favicon.ico" /? nil
36
+
let htmx () = s "htmx.js" /? nil
37
+
let config () = s "config" /? nil
38
+
let trees () = s "trees" / str /? nil
39
+
let foreign_trees () = s "trees" / s "foreign" / str /? nil
40
+
let search () = s "search" /? nil
41
+
let searchmenu () = s "searchmenu" /? nil
42
+
let home () = s "home" /? nil
43
+
let query () = s "query" /? nil
44
+
let json () = s "forest.json" /? nil
45
+
let katex_style () = s "katex.min.css" /? nil
46
+
let katex_bundle () = s "katex.min.js" /? nil
47
+
48
+
let routes : route router =
49
+
one_of
50
+
[
51
+
index () @--> Index;
52
+
(font () @--> fun s -> Static (Font s));
53
+
stylesheet () @--> Static Stylesheet;
54
+
js_bundle () @--> Static Js_bundle;
55
+
favicon () @--> Static Favicon;
56
+
htmx () @--> Static Htmx;
57
+
config () @--> Config;
58
+
(trees () @--> fun s -> Tree s);
59
+
(foreign_trees () @--> fun s -> Tree s);
60
+
search () @--> Search;
61
+
searchmenu () @--> Static Search_menu;
62
+
home () @--> Home;
63
+
query () @--> Query;
64
+
json () @--> Json_manifest;
65
+
katex_style () @--> Static KaTeX_style;
66
+
katex_bundle () @--> Static KaTeX_bundle;
67
+
]
+3
-1
lib/frontend/dune
+3
-1
lib/frontend/dune
+13
lib/frontend/templates/Combinators.ml
+13
lib/frontend/templates/Combinators.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
open Std_open
8
+
9
+
let optional opt kont = match opt with None -> H.null [] | Some v -> kont v
10
+
let optional_ opt kont = match opt with None -> H.null_ | Some v -> kont v
11
+
12
+
let conditional test kont = if test then kont else H.null []
13
+
let conditional_ test kont = if test then kont else H.null_
+22
lib/frontend/templates/Index.ml
+22
lib/frontend/templates/Index.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
open Pure_html
8
+
open HTML
9
+
10
+
let v =
11
+
Page.v
12
+
[
13
+
article
14
+
[
15
+
id "tree-container";
16
+
Hx.get "/home";
17
+
Hx.trigger "load";
18
+
Hx.target "this";
19
+
Hx.swap "outerHTML";
20
+
]
21
+
[];
22
+
]
+31
lib/frontend/templates/No_config_found.ml
+31
lib/frontend/templates/No_config_found.ml
···
1
+
open Std_open
2
+
open P
3
+
open H
4
+
5
+
let v =
6
+
div
7
+
[class_ "no-config-container"]
8
+
[
9
+
div []
10
+
[
11
+
h1 [class_ "title"] [txt "No configuration found"];
12
+
p [class_ "message"] [txt "Please enter a configuration file below:"];
13
+
form
14
+
[
15
+
class_ "config-form";
16
+
Hx.post "/config";
17
+
Hx.swap "innerHTML";
18
+
Hx.target "#grid-wrapper";
19
+
]
20
+
[
21
+
input
22
+
[
23
+
type_ "text";
24
+
name "config_name";
25
+
placeholder "Config name";
26
+
class_ "input";
27
+
];
28
+
input [type_ "submit"; value "Submit"; class_ "button"];
29
+
];
30
+
];
31
+
]
+59
lib/frontend/templates/Page.ml
+59
lib/frontend/templates/Page.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
open Combinators
8
+
open Forester_core
9
+
10
+
open struct
11
+
module P = Pure_html
12
+
module H = Pure_html.HTML
13
+
end
14
+
15
+
let page_header ~is_home ~dev =
16
+
let open H in
17
+
header
18
+
[class_ "header"]
19
+
[
20
+
nav
21
+
[class_ "nav"]
22
+
[
23
+
conditional (not is_home)
24
+
(div
25
+
[class_ "logo"]
26
+
[a [href "/index/index.html"; title_ "home"] [P.txt "« Home"]]);
27
+
conditional dev (div [class_ "nav-right"] [Doc_button.v]);
28
+
];
29
+
]
30
+
31
+
let v ?(dev = false) ?(is_home = false) ?(title_string = "") ?(mode = Static)
32
+
?(source_path = None) ?(render_header = false) c =
33
+
let open H in
34
+
html []
35
+
[
36
+
head []
37
+
[
38
+
meta [http_equiv `content_type; content "text/html"; charset "UTF-8"];
39
+
meta
40
+
[name "viewport"; content "width=device-width, initial-scale=1.0"];
41
+
link [rel "stylesheet"; href "/style.css"];
42
+
link [rel "stylesheet"; href "/katex.min.css"];
43
+
(match mode with
44
+
| Dynamic -> H.null [script [type_ "module"; src "/htmx.js"] ""]
45
+
| Static -> H.null []);
46
+
optional source_path (fun path ->
47
+
script [type_ "module"] "window.sourcePath = '%s'" path);
48
+
script [type_ "module"; src "/min.js"] "";
49
+
title [] "%s" title_string;
50
+
];
51
+
body []
52
+
[
53
+
P.std_tag "ninja-keys"
54
+
[placeholder "Start typing a note title or ID"]
55
+
[];
56
+
conditional render_header (page_header ~is_home ~dev);
57
+
div [id "grid-wrapper"] c;
58
+
];
59
+
]
+11
lib/frontend/templates/Std_open.ml
+11
lib/frontend/templates/Std_open.ml
+15
lib/frontend/templates/Templates.ml
+15
lib/frontend/templates/Templates.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
module Std_open = Std_open
8
+
module Combinators = Combinators
9
+
module Page = Page
10
+
module No_config_found = No_config_found
11
+
12
+
let doc_button = Doc_button.v
13
+
let page = Page.v
14
+
let no_config_found = No_config_found.v
15
+
let index = Index.v
+8
lib/frontend/templates/dune
+8
lib/frontend/templates/dune
+20
lib/server/Form.ml
+20
lib/server/Form.ml
···
1
+
let from_form_urlencoded string =
2
+
if string = "" then []
3
+
else
4
+
string |> Uri.query_of_encoded
5
+
|> List.map (fun (name, values) -> (name, String.concat "," values))
6
+
7
+
let get_field k = List.find_map (fun (k', v) -> if k = k' then Some v else None)
8
+
9
+
let parse headers request_body =
10
+
let status : Http.Status.t =
11
+
match Http.Header.get headers "Content-Type" with
12
+
| None -> `Bad_request
13
+
| Some content_type -> begin
14
+
match String.split_on_char ';' content_type with
15
+
| "application/x-www-form-urlencoded" :: _ -> `OK
16
+
| _ -> `Bad_request
17
+
end
18
+
in
19
+
let form = from_form_urlencoded request_body in
20
+
(status, form)
-33
lib/server/Router.ml
-33
lib/server/Router.ml
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
open Routes
8
-
9
-
(* Static content that should always be available *)
10
-
type static =
11
-
| Js_bundle
12
-
| Favicon
13
-
| Search_menu
14
-
| Htmx
15
-
| Stylesheet
16
-
| Font of string
17
-
18
-
type route = Static of static | Index | Tree of string | Home | Search | Query
19
-
20
-
let routes : route router =
21
-
one_of
22
-
[
23
-
route Routes.nil Index;
24
-
route (s "fonts" / str /? nil) (fun s -> Static (Font s));
25
-
route (s "style.css" /? nil) (Static Stylesheet);
26
-
route (s "min.js" /? nil) (Static Js_bundle);
27
-
route (s "favicon.ico" /? nil) (Static Favicon);
28
-
route (s "trees" / str /? nil) (fun s -> Tree s);
29
-
route (s "search" /? nil) Search;
30
-
route (s "searchmenu" /? nil) (Static Search_menu);
31
-
route (s "home" /? nil) Home;
32
-
route (s "htmx.js" /? nil) (Static Htmx);
33
-
]
+133
-64
lib/server/Server.ml
+133
-64
lib/server/Server.ml
···
8
8
open Forester_core
9
9
open Forester_compiler
10
10
open Forester_frontend
11
+
open State.Syntax
11
12
12
13
open struct
13
14
module T = Types
14
15
module EP = Eio.Path
15
-
module Env = Html_client.Env
16
+
module P = Pure_html
16
17
module H = Pure_html.HTML
18
+
module Hx = Pure_html.Hx
19
+
type env = Html_client.env
17
20
end
21
+
22
+
let respond_string = Cohttp_eio.Server.respond_string
18
23
19
24
let respond_html ~status ~body =
20
25
let body = Pure_html.to_string body in
21
26
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
22
-
Cohttp_eio.Server.respond_string ~headers ~status ~body
27
+
respond_string ~headers ~status ~body
28
+
29
+
let respond_json ~status ~body =
30
+
let body = Yojson.Safe.to_string body in
31
+
let headers = Http.Header.of_list [("Content-Type", "application/json")] in
32
+
respond_string ~headers ~status ~body
23
33
24
34
let theme_dir ~env =
25
35
let theme_site : string list = Theme_site.Sites.themes in
···
31
41
fun route ->
32
42
match route with
33
43
| Favicon -> "image/x-icon"
34
-
| Stylesheet -> "text/css"
44
+
| Stylesheet | KaTeX_style -> "text/css"
35
45
| Search_menu -> "text/html"
36
46
| Htmx -> "application/javascript"
37
-
| Js_bundle -> "application/javascript"
47
+
| Js_bundle | KaTeX_bundle -> "application/javascript"
38
48
| Font fontname -> (
39
49
let ext = Filename.extension fontname in
40
50
match ext with
···
56
66
let font_dir = EP.(native_exn @@ (theme_dir ~env / "fonts")) in
57
67
EP.(load (env#fs / font_dir / fontname))
58
68
| Js_bundle -> load_file "min.js"
69
+
| KaTeX_bundle -> load_file "katex.min.js"
70
+
| KaTeX_style -> load_file "katex.min.css"
59
71
| Search_menu -> Search_menu.v
60
72
| Htmx -> load_file "htmx.js"
61
73
| Stylesheet -> load_file "style.css"
62
74
in
63
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body ()
75
+
respond_string ~headers ~status:`OK ~body ()
64
76
65
-
let tree_handler ~(forest : State.t) ~headers uri =
77
+
let tree_handler ~(forest : State.t) ~request_headers uri =
66
78
let href = URI_scheme.named_uri ~base:forest.config.url uri in
67
-
let htmx = Option.is_some @@ Http.Header.get headers "Hx-Request" in
68
-
let env = Env.{(default ~forest) with htmx} in
69
-
let render =
70
-
if htmx then Htmx_client.render_content ~env
71
-
else Html_client.render_content ~env
79
+
let htmx = Option.is_some @@ Http.Header.get request_headers "Hx-Request" in
80
+
let env =
81
+
Html_client.
82
+
{(default_env ~forest) with mode = (if htmx then Dynamic else Static)}
72
83
in
84
+
let render = Html_client.render_content ~env in
73
85
let content =
74
-
match Headers.parse_content_target headers with
86
+
match Headers.parse_content_target request_headers with
75
87
| Some target ->
76
88
Option.map (render >>> H.null)
77
89
(State.get_content_of_transclusion ~forest {target; href})
···
82
94
in
83
95
let status = match content with None -> `Not_found | Some _ -> `OK in
84
96
match content with
85
-
| None -> Cohttp_eio.Server.respond_string ~status ~body:"" ()
97
+
| None -> respond_string ~status ~body:"" ()
86
98
| Some body -> respond_html ~status ~body ()
87
99
88
-
let query_handler ~forest ~resource =
100
+
let query_handler ~(env : env) ~resource =
89
101
let query_parser =
90
-
Repr.of_json_string
91
-
Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t))
102
+
let open Repr in
103
+
of_json_string @@ Datalog_expr.query_t string T.(vertex_t content_t)
92
104
in
93
105
let query =
94
106
Option.bind (Uri.get_query_param resource "query") (fun query ->
···
99
111
match result with Query_results vertex_set -> Some vertex_set | _ -> None
100
112
in
101
113
match query with
102
-
| None ->
103
-
Cohttp_eio.Server.respond_string ~status:`Bad_request ~body:"bad query" ()
114
+
| None -> respond_string ~status:`Bad_request ~body:"bad query" ()
104
115
| Some query -> begin
105
116
let delete_section_headers =
106
117
(* NOTE: When computing the backmatter, we will sometimes run queries
···
112
123
("Hx-Swap", "delete");
113
124
]
114
125
in
115
-
match run_query ~forest query with
126
+
match run_query ~forest:env.forest query with
116
127
| None ->
117
-
Cohttp_eio.Server.respond_string ~status:`Internal_server_error
128
+
respond_string ~status:`Internal_server_error
118
129
~body:
119
130
"Internal error: Running query returned something unexpected. This \
120
131
is a bug. Something is wrong with Driver.update"
121
132
()
122
133
| Some vs when Vertex_set.cardinal vs = 0 ->
123
-
Cohttp_eio.Server.respond_string ~headers:delete_section_headers
124
-
~status:`OK ~body:"" ()
134
+
respond_string ~headers:delete_section_headers ~status:`OK ~body:"" ()
125
135
| Some vertex_set ->
126
-
let body = Htmx_client.render_query_result ~forest vertex_set in
136
+
let to_section =
137
+
T.article_to_section
138
+
~flags:
139
+
{
140
+
T.default_section_flags with
141
+
expanded = Some false;
142
+
numbered = Some false;
143
+
included_in_toc = Some false;
144
+
metadata_shown = Some true;
145
+
}
146
+
in
147
+
let body =
148
+
H.div []
149
+
@@ List.map
150
+
(to_section >>> Html_client.render_section ~env)
151
+
(Forester.get_sorted_articles ~forest:env.forest vertex_set)
152
+
in
127
153
respond_html ~status:`OK ~body ()
128
154
end
129
155
130
-
let search_handler ~(request : Http.Request.t) ~forest ~body =
131
-
if request.meth = `POST then
132
-
let body = Eio.Flow.read_all body in
133
-
let get_param key =
134
-
Option.map (String.concat "")
135
-
@@ Option.map snd
136
-
@@ List.find_opt (fun (s, _) -> s = key) (Uri.query_of_encoded body)
137
-
in
138
-
let _search_term = Option.value ~default:"" @@ get_param "search" in
139
-
let search_for = get_param "search-for" in
140
-
let search_results =
141
-
match search_for with
142
-
| None -> []
143
-
| Some "title-text" ->
144
-
(* Forester_search.Index.search *)
145
-
(* forest.search_index *)
146
-
(* search_term *)
147
-
[]
148
-
| Some "full-text" ->
149
-
(* Forester_search.Index.search *)
150
-
(* forest.search_index *)
151
-
(* search_term *)
152
-
[]
153
-
| Some _ -> assert false
156
+
let search_handler ~forest ~body =
157
+
let body = Eio.Flow.read_all body in
158
+
let get_param key =
159
+
Option.map (String.concat "")
160
+
@@ Option.map snd
161
+
@@ List.find_opt (fun (s, _) -> s = key) (Uri.query_of_encoded body)
162
+
in
163
+
let _search_term = Option.value ~default:"" @@ get_param "search" in
164
+
let search_for = get_param "search-for" in
165
+
let search_results =
166
+
match search_for with
167
+
| None -> []
168
+
| Some "title-text" ->
169
+
(* Forester_search.Index.search *)
170
+
(* forest.search_index *)
171
+
(* search_term *)
172
+
[]
173
+
| Some "full-text" ->
174
+
(* Forester_search.Index.search *)
175
+
(* forest.search_index *)
176
+
(* search_term *)
177
+
[]
178
+
| Some _ -> assert false
179
+
in
180
+
let env = Html_client.default_env ~forest in
181
+
Search_menu.results ~env (List.map snd search_results)
182
+
183
+
(* Allows the user to enter a config file name and loads the forest *)
184
+
let config_handler ~env request_headers request_body forest =
185
+
let _, form = Form.parse request_headers (Eio.Flow.read_all request_body) in
186
+
match Form.get_field "config_name" form with
187
+
| None ->
188
+
let body = H.div [Hx.target "config-input"] [] in
189
+
respond_html ~body ~status:`Bad_request ()
190
+
| Some filename ->
191
+
let body, status =
192
+
(* This expects an absolute path, we should handle the case when
193
+
the user enters ~/forest/forest.toml *)
194
+
match Config_parser.parse_forest_config_file filename with
195
+
| Error exn ->
196
+
let error = Format.asprintf "%a" Eio.Exn.pp exn in
197
+
(H.div [] [P.txt "%s" error], `OK)
198
+
| Ok config ->
199
+
let@ () = Reporter.easy_run in
200
+
let f = Driver.batch_run ~env ~config ~dev:true in
201
+
forest := Some f;
202
+
let home =
203
+
match f.@{Config.home_uri config} with
204
+
| Some (Article article) -> article
205
+
| _ -> assert false
206
+
in
207
+
( Html_client.render_article
208
+
~env:Html_client.{(default_env ~forest:f) with mode = Dynamic}
209
+
home,
210
+
`OK )
154
211
in
155
-
let env = Env.default ~forest in
156
-
Search_menu.results ~env (List.map snd search_results)
157
-
else ""
212
+
respond_html ~body ~status ()
158
213
159
214
let handler :
160
215
env:< fs : [> Eio.Fs.dir_ty] Eio.Path.t ; .. > ->
···
168
223
let path = Uri.path resource in
169
224
let request_headers = Http.Request.headers request in
170
225
match Routes.match' ~target:path Router.routes with
171
-
| NoMatch -> Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
226
+
| NoMatch -> respond_string ~status:`Not_found ~body:"" ()
172
227
| Routes.FullMatch route | Routes.MatchWithTrailingSlash route -> begin
173
228
match route with
174
229
| Static route -> static_handler ~env route
230
+
| Config -> config_handler ~env request_headers request_body forest
175
231
| _ -> begin
176
232
match !forest with
177
-
| None ->
178
-
let body = Pure_html.to_string Pages.config_picker in
179
-
Cohttp_eio.Server.respond_string ~body ~status:`OK ()
233
+
| None -> begin
234
+
match route with
235
+
| Json_manifest -> respond_json ~status:`OK ~body:(`List []) ()
236
+
| _ ->
237
+
let body = Templates.(page ~mode:Dynamic [no_config_found]) in
238
+
respond_html ~body ~status:`OK ()
239
+
end
180
240
| Some forest -> begin
181
241
match route with
182
-
| Static _ -> assert false
242
+
| Static _ | Config -> assert false
183
243
| Index ->
184
-
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
185
-
let body = Pure_html.to_string (Pages.index ()) in
186
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body ()
187
-
| Tree uri -> tree_handler ~forest ~headers:request_headers uri
244
+
let body = Templates.index in
245
+
respond_html ~status:`OK ~body ()
246
+
| Json_manifest -> respond_json ~status:`OK ~body:(`List []) ()
247
+
| Tree uri -> tree_handler ~forest ~request_headers uri
248
+
(* FIXME: *)
249
+
| Foreign_tree uri -> tree_handler ~forest ~request_headers uri
188
250
| Home ->
189
-
tree_handler ~forest ~headers:request_headers
251
+
tree_handler ~forest ~request_headers
190
252
(URI.path_string forest.config.home)
191
253
| Search ->
192
254
let status =
193
255
if request.meth = `POST then `OK else `Method_not_allowed
194
256
in
195
-
let body = search_handler ~request ~forest ~body:request_body in
196
-
Cohttp_eio.Server.respond_string ~body ~status ()
197
-
| Query -> query_handler ~forest ~resource
257
+
let body = search_handler ~forest ~body:request_body in
258
+
respond_string ~body ~status ()
259
+
| Query ->
260
+
let env = Html_client.dynamic_env ~forest in
261
+
query_handler ~env ~resource
198
262
end
199
263
end
200
264
end
···
230
294
let local_url = Format.sprintf "http://localhost:%i" port in
231
295
if no_browser then begin
232
296
Logs.app (fun m -> m "Forester is running on %s" local_url);
297
+
let () = Logs.set_reporter (Logs_fmt.reporter ())
298
+
and () = Logs.Src.set_level Cohttp_eio.src (Some App) in
233
299
Cohttp_eio.Server.run socket server ~on_error:log_warning
234
300
end
235
301
else
236
302
Eio.Fiber.both
237
-
(fun () -> Cohttp_eio.Server.run socket server ~on_error:log_warning)
303
+
(fun () ->
304
+
let () = Logs.set_reporter (Logs_fmt.reporter ())
305
+
and () = Logs.Src.set_level Cohttp_eio.src (Some Debug) in
306
+
Cohttp_eio.Server.run socket server ~on_error:log_warning)
238
307
(fun () ->
239
308
try start_browser ~env local_url
240
309
with _exn ->
+5
-2
lib/server/dune
+5
-2
lib/server/dune
···
17
17
forester.frontend
18
18
forester.search
19
19
forester.xml_names
20
-
forester.server.pages
20
+
forester.human_datetime
21
+
forester.frontend.templates
21
22
pure-html
22
23
logs
24
+
logs.fmt
23
25
eio
24
26
eio.core
25
27
eio.unix
···
27
29
cohttp-eio
28
30
uri
29
31
fmt
30
-
spelll))
32
+
spelll
33
+
yojson))
-5
lib/server/pages/Config_picker.ml
-5
lib/server/pages/Config_picker.ml
-61
lib/server/pages/Index.ml
-61
lib/server/pages/Index.ml
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
open Pure_html
8
-
open HTML
9
-
10
-
let v ?c () =
11
-
html []
12
-
[
13
-
head []
14
-
[
15
-
meta [name "viewport"; content "width=device-width"];
16
-
link [rel "stylesheet"; href "/style.css"];
17
-
link [rel "icon"; type_ "image/x-icon"; href "/favicon.ico"];
18
-
script [type_ "module"; src "/min.js"] "";
19
-
script [src "/htmx.js"] "";
20
-
link
21
-
[
22
-
rel "stylesheet";
23
-
href
24
-
"https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.min.css";
25
-
integrity
26
-
"sha384-zh0CIslj+VczCZtlzBcjt5ppRcsAmDnRem7ESsYwWwg3m/OaJ2l4x7YBZl9Kxxib";
27
-
crossorigin `anonymous;
28
-
];
29
-
script
30
-
[
31
-
src "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.js";
32
-
integrity
33
-
"sha384-CAltQiu9myJj3FAllEacN6FT+rOyXo+hFZKGuR2p4HB8JvJlyUHm31eLfL4eEiJL";
34
-
crossorigin `anonymous;
35
-
]
36
-
"";
37
-
title [] "";
38
-
];
39
-
body
40
-
[Hx.boost true]
41
-
[
42
-
header [] [];
43
-
div
44
-
[id "grid-wrapper"]
45
-
[
46
-
(match c with
47
-
| Some stuff -> stuff
48
-
| None ->
49
-
article
50
-
[
51
-
id "tree-container";
52
-
Hx.get "/home";
53
-
Hx.trigger "load";
54
-
Hx.target "this";
55
-
Hx.swap "outerHTML";
56
-
]
57
-
[]);
58
-
];
59
-
div [id "modal-container"] [];
60
-
];
61
-
]