forked from
jonmsterling.com/ocaml-forester
ocaml
Refactor HTTP server and Router
The routing type now distinguishes between static routes and routes that
depend on a forest.
Server logic should now be easier to read and more maintainable.
Other changes:
- Move theme_site to Forester_frontend.
- Add a `start` command, runs server and opens browser
+327
-380
+1
-6
bin/forester/dune
+1
-6
bin/forester/dune
···
2
2
;;;
3
3
;;; SPDX-License-Identifier: GPL-3.0-or-later
4
4
5
-
(generate_sites_module
6
-
(module theme_site)
7
-
(sites forester))
8
-
9
5
(install
10
6
(section
11
7
(site
···
34
30
(:standard -g))
35
31
(link_flags
36
32
(:standard -g))
37
-
(modules main theme_site)
33
+
(modules main)
38
34
(libraries
39
35
forester.prelude
40
36
forester.core
···
47
43
logs.cli
48
44
cmdliner
49
45
dune-build-info
50
-
dune-site
51
46
asai
52
47
eio
53
48
eio.core
+38
-1
bin/forester/main.ml
+38
-1
bin/forester/main.ml
···
310
310
let info = Cmd.info "lsp" ~version ~doc ~man in
311
311
Cmd.v info Term.(const (lsp ~env:env_) $ arg_logs $ arg_config)
312
312
313
+
let start ~env _arg_logs config port dev no_browser : unit =
314
+
Forester_server.serve ~env ~port ~dev ~no_browser ~config ()
315
+
316
+
let start_doc = "Start the Forester application."
317
+
let start_term ~env:env_ =
318
+
let doc = start_doc in
319
+
let arg_port =
320
+
Arg.(value & opt int 8080 & info ["p"; "port"] ~doc ~docv:"PORT")
321
+
in
322
+
let arg_dev =
323
+
let doc =
324
+
"Run forester in development mode; this will attach source file \
325
+
locations to the generated json."
326
+
in
327
+
Arg.value @@ Arg.flag @@ Arg.info ["dev"] ~doc
328
+
in
329
+
let arg_no_browser =
330
+
let doc = "Start forester without opening the browser" in
331
+
Arg.(value @@ flag @@ info ["no-browser"] ~doc)
332
+
in
333
+
Term.(
334
+
const (start ~env:env_)
335
+
$ arg_logs $ arg_config $ arg_port $ arg_dev $ arg_no_browser)
336
+
337
+
let start_cmd ~env =
338
+
let man =
339
+
[
340
+
`S Manpage.s_description;
341
+
`P
342
+
"The $(tname) command builds the forest in the same manner as $(b, \
343
+
forester build) and serves the forest via HTTP";
344
+
]
345
+
in
346
+
let info = Cmd.info "start" ~version ~doc:start_doc ~man in
347
+
Cmd.v info (start_term ~env)
348
+
313
349
let cmd ~env =
314
350
let doc = "a tool for tending mathematical forests" in
315
351
let man =
···
322
358
]
323
359
in
324
360
let info = Cmd.info "forester" ~version ~doc ~man in
325
-
Cmd.group info
361
+
Cmd.group ~default:(start_term ~env) info
326
362
[
327
363
build_cmd ~env;
328
364
new_tree_cmd ~env;
···
330
366
init_cmd ~env;
331
367
query_cmd ~env;
332
368
lsp_cmd ~env;
369
+
start_cmd ~env;
333
370
]
334
371
335
372
let () =
+8
lib/frontend/Forester_frontend.ml
+8
lib/frontend/Forester_frontend.ml
···
15
15
module Plain_text_client = Plain_text_client
16
16
module Legacy_xml_client = Legacy_xml_client
17
17
module Json_manifest_client = Json_manifest_client
18
+
19
+
module Theme_site : sig
20
+
module Sites : sig
21
+
val themes : string list
22
+
val docs : string list
23
+
end
24
+
end =
25
+
Theme_site
+43
-8
lib/frontend/Html_client.ml
+43
-8
lib/frontend/Html_client.ml
···
17
17
module H = P.HTML
18
18
end
19
19
20
-
type env = {
21
-
forest: State.t;
22
-
scope: URI.t option;
23
-
loops: Loop_detection.t;
24
-
xmlns: Xmlns.t;
25
-
in_backmatter: bool;
26
-
}
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
+
}
40
+
end
41
+
42
+
open Env
27
43
28
44
let generate_id (frontmatter : T.(content frontmatter)) =
29
45
let id = Hashtbl.hash frontmatter in
···
631
647
loops = Loop_detection.empty;
632
648
xmlns = Xmlns.init ~reserved;
633
649
in_backmatter = false;
650
+
htmx = false;
634
651
}
635
652
in
636
653
H.div
···
694
711
];
695
712
]
696
713
697
-
let render_page ~forest
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
698
731
({frontmatter; mainmatter = T.Content mainmatter; _} as tree : _ T.article)
699
732
: P.node =
700
733
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
···
705
738
loops = Loop_detection.empty;
706
739
xmlns = Xmlns.init ~reserved;
707
740
in_backmatter = false;
741
+
htmx = Option.value ~default:false htmx;
708
742
}
709
743
in
710
744
let ttl =
···
720
754
let is_home = is_home ~env frontmatter.uri in
721
755
let dev = forest.dev in
722
756
page_template ~dev ~is_home ~title:ttl ?source_path:frontmatter.source_path
757
+
~htmx
723
758
[
724
759
render_article ~env tree;
725
760
conditional (should_render_toc tree)
+21
-40
lib/frontend/Htmx_client.ml
+21
-40
lib/frontend/Htmx_client.ml
···
12
12
open struct
13
13
module T = Types
14
14
module P = Pure_html
15
+
module Env = Html_client.Env
15
16
let render_date = Html_client.render_date
16
17
let render_attributions = Html_client.render_attributions
17
18
end
···
121
122
implicitly_unnumbered = false;
122
123
}
123
124
124
-
let rec render_article ~(forest : State.t) (article : T.content T.article) :
125
+
let render_article ~forest ({frontmatter; _} as article : T.content T.article) :
125
126
node =
126
-
(* FIXME: What should reserved be here? *)
127
-
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
128
-
let env : Html_client.env =
129
-
{
130
-
forest;
131
-
scope = article.frontmatter.uri;
132
-
loops = Loop_detection.empty;
133
-
xmlns = Xmlns.init ~reserved;
134
-
in_backmatter = false;
135
-
}
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
+
}
136
138
in
137
-
HTML.article
138
-
[id "tree-container"]
139
-
[
140
-
(* FIXME: Should be reusing render_section *)
141
-
HTML.section
142
-
[class_ "block"]
143
-
[
144
-
details [(* TODO: check if expanded*) open_]
145
-
@@ summary [] [render_frontmatter ~env article.frontmatter]
146
-
:: render_content ~env article.mainmatter;
147
-
];
148
-
(match article.frontmatter.uri with
149
-
| None -> footer [] @@ render_backmatter ~env article.backmatter
150
-
| Some uri ->
151
-
if URI.equal (Config.home_uri env.forest.config) uri then null []
152
-
else footer [] @@ render_backmatter ~env article.backmatter);
153
-
]
139
+
Html_client.render_page_raw ~env article
154
140
155
-
and render_section ~env (section : T.content T.section) : node =
141
+
let rec render_section ~env (section : T.content T.section) : node =
156
142
match section with
157
143
| {frontmatter; mainmatter; flags} ->
158
144
let test k = function
···
185
171
(* null @@ render_content forest mainmatter; *)
186
172
]
187
173
188
-
(* Same as render_section, but adds the backmatter-section class *)
189
-
and render_backmatter ~env backmatter =
190
-
let@ node = List.map @~ render_content ~env backmatter in
191
-
let attrs = Format.asprintf "%s backmatter-section" node.@["class"] in
192
-
node +@ class_ "%s" attrs
193
-
194
-
and render_frontmatter ~env (frontmatter : T.content T.frontmatter) : node =
174
+
and render_frontmatter ~(env : Env.t) (frontmatter : T.content T.frontmatter) :
175
+
node =
195
176
let taxon =
196
177
Option.value ~default:[]
197
178
@@
···
434
415
(*TODO: Implement.*)
435
416
contextual_number _tree cfg
436
417
437
-
and _render_toc_item ~(env : Html_client.env) (item : T.content T.section) =
418
+
and _render_toc_item ~(env : Env.t) (item : T.content T.section) =
438
419
let to_str =
439
420
Plain_text_client.string_of_content ~forest:env.forest
440
421
~router:(Legacy_xml_client.route env.forest)
···
495
476
let string_of_content =
496
477
Plain_text_client.string_of_content ~forest ~router:(route forest)
497
478
end) in
498
-
let env : Html_client.env =
479
+
let env : Env.t =
499
480
{
500
481
forest;
501
482
scope = None;
···
504
485
Xmlns.init
505
486
~reserved:[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
506
487
in_backmatter = false;
488
+
htmx = true;
507
489
}
508
490
in
509
491
let make_section =
···
525
507
|> List.sort C.compare_article
526
508
|> List.map (Fun.compose (render_section ~env) make_section)
527
509
in
528
-
if List.length nodes = 0 then None
529
-
else Some (div [class_ "tree-content"] nodes)
510
+
div [class_ "tree-content"] nodes
+4
-52
lib/frontend/Htmx_client.mli
+4
-52
lib/frontend/Htmx_client.mli
···
7
7
open Forester_core
8
8
open Forester_compiler
9
9
module T := Types
10
+
module Env := Html_client.Env
10
11
11
-
(* type query = { *)
12
-
(* query : (string, T.content T.vertex) Forester_core.Datalog_expr.query; *)
13
-
(* } *)
14
-
(* val query_t : query Repr.ty *)
15
-
(* val local_path_components : Forester_core.URI.t -> string list *)
16
-
(* val route : *)
17
-
(* State.t -> Forester_core.URI.t -> Forester_core.URI.t *)
18
-
(* val title_flags_to_http_header : *)
19
-
(* T.title_flags -> [> `Assoc of (string * [> `String of string ]) list ] *)
20
-
(* val section_flags_to_http_header : *)
21
-
(* T.section_flags -> [> `Assoc of (string * [> `String of string ]) list ] *)
22
-
(* val content_target_to_http_header : *)
23
-
(* T.content_target -> [> `Assoc of (string * [> `String of string ]) list ] *)
24
-
(* val render_xml_qname : Forester_xml_names.xml_qname -> string *)
25
-
(* val render_xml_attr : T.content T.xml_attr -> Pure_html.attr *)
26
-
(* val render_xmlns_prefix : Forester_xml_names.xmlns_attr -> Pure_html.attr *)
27
-
(* type toc_config = { *)
28
-
(* suffix : string; *)
29
-
(* taxon : string; *)
30
-
(* number : string; *)
31
-
(* fallback_number : string; *)
32
-
(* in_backmatter : bool; *)
33
-
(* is_root : bool; *)
34
-
(* implicitly_unnumbered : bool; *)
35
-
(* } *)
36
-
(* val default_toc_config : *)
37
-
(* ?suffix:string -> *)
38
-
(* ?taxon:string -> *)
39
-
(* ?number:string -> *)
40
-
(* ?fallback_number:string -> ?in_backmatter:bool -> unit -> toc_config *)
41
-
val render_article :
42
-
forest:State.t-> T.content T.article -> Pure_html.node
43
-
(* val render_section : *)
44
-
(* env:Html_client.env -> T.content T.section -> Pure_html.node *)
45
-
(* val render_backmatter : *)
46
-
(* env:Html_client.env -> T.content -> Pure_html.node list *)
47
-
(* val render_frontmatter : *)
48
-
(* env:Html_client.env -> T.content T.frontmatter -> Pure_html.node *)
49
-
(* val render_transclusion : T.transclusion -> Pure_html.node list *)
50
-
val render_content : env:Html_client.env -> T.content -> Pure_html.node list
51
-
(* val render_content_node : *)
52
-
(* env:Html_client.env -> T.content T.content_node -> Pure_html.node list *)
53
-
(* val render_link : *)
54
-
(* env:Html_client.env -> T.content T.link -> Pure_html.node list *)
55
-
(* val contextual_number : T.content T.section -> toc_config -> Pure_html.node *)
56
-
(* val _tree_taxon_with_number : *)
57
-
(* T.content T.section -> toc_config -> Pure_html.node *)
58
-
(* val _render_toc_item : *)
59
-
(* env:Html_client.env -> T.content T.section -> Pure_html.node *)
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
60
14
val render_toc_mainmatter : T.content -> Pure_html.node
61
-
(* val render_toc : T.content T.section -> Pure_html.node *)
62
15
val render_query_result :
63
-
forest:State.t -> Forester_core.Vertex_set.t -> Pure_html.node option
64
-
16
+
forest:State.t -> Forester_core.Vertex_set.t -> Pure_html.node
+5
lib/frontend/dune
+5
lib/frontend/dune
···
2
2
;;;
3
3
;;; SPDX-License-Identifier: GPL-3.0-or-later
4
4
5
+
(generate_sites_module
6
+
(module theme_site)
7
+
(sites forester))
8
+
5
9
(library
6
10
(name Forester_frontend)
7
11
(public_name forester.frontend)
···
10
14
(preprocess
11
15
(pps ppx_deriving.show ppx_repr))
12
16
(libraries
17
+
dune-site
13
18
logs.fmt
14
19
http
15
20
cohttp-eio
+1
lib/server/Forester_server.ml
+1
lib/server/Forester_server.ml
···
1
+
let serve = Server.run
lib/server/Index.ml
lib/server/pages/Index.ml
lib/server/Index.ml
lib/server/pages/Index.ml
+13
-18
lib/server/Router.ml
+13
-18
lib/server/Router.ml
···
6
6
7
7
open Routes
8
8
9
-
type route =
10
-
| Index
11
-
| Font of string
9
+
(* Static content that should always be available *)
10
+
type static =
12
11
| Js_bundle
13
-
| Stylesheet
14
12
| Favicon
15
-
| Tree of string
16
-
| Search
17
-
| Searchmenu
18
-
| Nil
19
-
| Home
20
-
| Query
13
+
| Search_menu
21
14
| Htmx
15
+
| Stylesheet
16
+
| Font of string
17
+
18
+
type route = Static of static | Index | Tree of string | Home | Search | Query
22
19
23
20
let routes : route router =
24
21
one_of
25
22
[
26
23
route Routes.nil Index;
27
-
route (s "fonts" / str /? nil) (fun s -> Font s);
28
-
route (s "style.css" /? nil) Stylesheet;
29
-
route (s "min.js" /? nil) Js_bundle;
30
-
route (s "favicon.ico" /? nil) Favicon;
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);
31
28
route (s "trees" / str /? nil) (fun s -> Tree s);
32
29
route (s "search" /? nil) Search;
33
-
route (s "searchmenu" /? nil) Searchmenu;
34
-
route (s "nil" /? nil) Nil;
30
+
route (s "searchmenu" /? nil) (Static Search_menu);
35
31
route (s "home" /? nil) Home;
36
-
route (s "query" /? nil) Query;
37
-
route (s "htmx.js" /? nil) Htmx;
32
+
route (s "htmx.js" /? nil) (Static Htmx);
38
33
]
+171
-254
lib/server/Server.ml
+171
-254
lib/server/Server.ml
···
8
8
open Forester_core
9
9
open Forester_compiler
10
10
open Forester_frontend
11
-
open Forester_xml_names
12
11
13
12
open struct
14
13
module T = Types
15
14
module EP = Eio.Path
15
+
module Env = Html_client.Env
16
+
module H = Pure_html.HTML
16
17
end
17
18
18
-
type theme = {
19
-
stylesheet: string;
20
-
htmx: string;
21
-
js_bundle: string;
22
-
font_dir: string;
23
-
favicon: string;
24
-
}
19
+
let respond_html ~status ~body =
20
+
let body = Pure_html.to_string body in
21
+
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
22
+
Cohttp_eio.Server.respond_string ~headers ~status ~body
23
+
24
+
let theme_dir ~env =
25
+
let theme_site : string list = Theme_site.Sites.themes in
26
+
assert (List.length theme_site = 1);
27
+
let base_dir = List.hd theme_site in
28
+
EP.(env#fs / base_dir / "default")
29
+
30
+
let mimetype : Router.static -> string =
31
+
fun route ->
32
+
match route with
33
+
| Favicon -> "image/x-icon"
34
+
| Stylesheet -> "text/css"
35
+
| Search_menu -> "text/html"
36
+
| Htmx -> "application/javascript"
37
+
| Js_bundle -> "application/javascript"
38
+
| Font fontname -> (
39
+
let ext = Filename.extension fontname in
40
+
match ext with
41
+
| ".ttf" -> "font/ttf"
42
+
| ".woff" -> "font/woff"
43
+
| ".woff2" -> "font/woff2"
44
+
| _ -> assert false)
45
+
46
+
(* Routes that don depend on a forest*)
47
+
let static_handler ~env : Router.static -> Cohttp_eio.Server.response =
48
+
fun route ->
49
+
let load_file f = EP.(load (theme_dir ~env / f)) in
50
+
let mimetype = mimetype route in
51
+
let headers = Http.Header.of_list [("Content-Type", mimetype)] in
52
+
let body =
53
+
match route with
54
+
| Favicon -> load_file "favicon.ico"
55
+
| Font fontname ->
56
+
let font_dir = EP.(native_exn @@ (theme_dir ~env / "fonts")) in
57
+
EP.(load (env#fs / font_dir / fontname))
58
+
| Js_bundle -> load_file "min.js"
59
+
| Search_menu -> Search_menu.v
60
+
| Htmx -> load_file "htmx.js"
61
+
| Stylesheet -> load_file "style.css"
62
+
in
63
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body ()
25
64
26
-
let load_theme ~env theme_location =
27
-
assert (List.length theme_location = 1);
28
-
let base_dir = List.hd theme_location in
29
-
let theme_dir = EP.(env#fs / base_dir / "default") in
30
-
let load_file f = EP.(load (theme_dir / f)) in
31
-
let stylesheet = load_file "style.css" in
32
-
let htmx = load_file "htmx.js" in
33
-
let favicon = load_file "favicon.ico" in
34
-
let js_bundle = load_file "min.js" in
35
-
let font_dir = EP.(native_exn @@ (theme_dir / "fonts")) in
36
-
{stylesheet; htmx; js_bundle; font_dir; favicon}
65
+
let tree_handler ~(forest : State.t) ~headers uri =
66
+
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
72
+
in
73
+
let content =
74
+
match Headers.parse_content_target headers with
75
+
| Some target ->
76
+
Option.map
77
+
(Fun.compose H.null render)
78
+
(State.get_content_of_transclusion ~forest {target; href})
79
+
| None ->
80
+
Option.map
81
+
(Html_client.render_article ~env)
82
+
(State.get_article ~forest href)
83
+
in
84
+
let status = match content with None -> `Not_found | Some _ -> `OK in
85
+
match content with
86
+
| None -> Cohttp_eio.Server.respond_string ~status ~body:"" ()
87
+
| Some body -> respond_html ~status ~body ()
37
88
38
-
let lookup_font ~env theme font =
39
-
Eio.Path.(load (env#fs / theme.font_dir / font))
89
+
let query_handler ~forest ~resource =
90
+
let query_parser =
91
+
Repr.of_json_string
92
+
Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t))
93
+
in
94
+
let query =
95
+
Option.bind (Uri.get_query_param resource "query") (fun query ->
96
+
Result.to_option @@ query_parser @@ Uri.pct_decode @@ query)
97
+
in
98
+
let run_query ~forest q =
99
+
let result, _ = Driver.update (Query q) forest in
100
+
match result with Query_results vertex_set -> Some vertex_set | _ -> None
101
+
in
102
+
match query with
103
+
| None ->
104
+
Cohttp_eio.Server.respond_string ~status:`Bad_request ~body:"bad query" ()
105
+
| Some query -> begin
106
+
let delete_section_headers =
107
+
(* NOTE: When computing the backmatter, we will sometimes run queries
108
+
return the empty set. In this case, we want to hide the entire
109
+
backmatter section, heading included.*)
110
+
Http.Header.of_list
111
+
[
112
+
("Hx-Retarget", "closest section.backmatter-section");
113
+
("Hx-Swap", "delete");
114
+
]
115
+
in
116
+
match run_query ~forest query with
117
+
| None ->
118
+
Cohttp_eio.Server.respond_string ~status:`Internal_server_error
119
+
~body:
120
+
"Internal error: Running query returned something unexpected. This \
121
+
is a bug. Something is wrong with Driver.update"
122
+
()
123
+
| Some vs when Vertex_set.cardinal vs = 0 ->
124
+
Cohttp_eio.Server.respond_string ~headers:delete_section_headers
125
+
~status:`OK ~body:"" ()
126
+
| Some vertex_set ->
127
+
let body = Htmx_client.render_query_result ~forest vertex_set in
128
+
respond_html ~status:`OK ~body ()
129
+
end
40
130
41
131
let handler :
42
132
env:< fs : [> Eio.Fs.dir_ty] Eio.Path.t ; .. > ->
43
-
theme:theme ->
44
-
forest:State.t ->
133
+
forest:State.t option ref ->
45
134
Cohttp_eio.Server.conn ->
46
135
Http.Request.t ->
47
136
Cohttp_eio.Body.t ->
48
137
Cohttp_eio.Server.response =
49
-
fun ~env ~theme ~(forest : State.t) _socket request body ->
138
+
fun ~env ~forest _socket request _body ->
50
139
let resource = Uri.of_string request.resource in
51
140
let path = Uri.path resource in
141
+
let request_headers = Http.Request.headers request in
52
142
match Routes.match' ~target:path Router.routes with
53
-
| Routes.FullMatch r | Routes.MatchWithTrailingSlash r -> begin
54
-
match r with
55
-
| Font fontname ->
56
-
let body = lookup_font ~env theme fontname in
57
-
let headers =
58
-
let ext = Filename.extension fontname in
59
-
let mimetype =
60
-
match ext with
61
-
| ".ttf" -> "font/ttf"
62
-
| ".woff" -> "font/woff"
63
-
| ".woff2" -> "font/woff2"
64
-
| _ -> assert false
65
-
in
66
-
Http.Header.of_list [("Content-Type", mimetype)]
67
-
in
68
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body ()
69
-
| Stylesheet ->
70
-
let headers =
71
-
Http.Header.of_list [("Content-Type", "text/css"); ("charset", "utf-8")]
72
-
in
73
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK
74
-
~body:theme.stylesheet ()
75
-
| Js_bundle ->
76
-
let headers =
77
-
Http.Header.of_list [("Content-Type", "application/javascript")]
78
-
in
79
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK
80
-
~body:theme.js_bundle ()
81
-
| Index ->
82
-
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
83
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK
84
-
~body:(Pure_html.to_string (Index.v ()))
85
-
()
86
-
| Favicon ->
87
-
let headers = Http.Header.of_list [("Content-Type", "image/x-icon")] in
88
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:theme.favicon
89
-
()
90
-
| Tree s ->
91
-
let href = URI_scheme.named_uri ~base:forest.config.url s in
92
-
let request_headers = Http.Request.headers request in
93
-
let is_htmx =
94
-
(*If it is an HTMX request, we just send a fragment. If it is not an
95
-
HTMX request, we need to send the whole page. This happens for example
96
-
when the user opens a link via the URL bar of the browser.
97
-
*)
98
-
Option.is_some @@ Http.Header.get request_headers "Hx-Request"
99
-
in
100
-
begin if is_htmx then begin
101
-
(* We use custom headers to configure the transclusion. *)
102
-
match Headers.parse_content_target request_headers with
103
-
(* If we fail to parse a target, just render the article.*)
104
-
| None -> begin
105
-
match State.get_article ~forest href with
106
-
| None ->
107
-
(* TODO: Some sort of 404 template *)
108
-
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
109
-
| Some content ->
110
-
let response =
111
-
Pure_html.to_string @@ Htmx_client.render_article ~forest content
112
-
in
113
-
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()
114
-
end
115
-
| Some target -> (
116
-
match State.get_content_of_transclusion ~forest {target; href} with
117
-
| None ->
118
-
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
119
-
| Some content ->
120
-
(* TODO: Remove any sort of HTML generation from the handler. *)
121
-
let env : Html_client.env =
122
-
{
123
-
forest;
124
-
scope = Some href;
125
-
loops = Loop_detection.empty;
126
-
xmlns =
127
-
Xmlns.init
128
-
~reserved:
129
-
[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
130
-
in_backmatter = false;
131
-
}
132
-
in
133
-
let response =
134
-
Pure_html.(
135
-
to_string
136
-
@@ HTML.span [] (Htmx_client.render_content ~env content))
137
-
in
138
-
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ())
139
-
end
140
-
else
141
-
match State.get_article ~forest href with
142
-
| Some article ->
143
-
let content =
144
-
Pure_html.to_string
145
-
@@ Index.v ~c:(Htmx_client.render_article ~forest article) ()
146
-
in
143
+
| NoMatch -> Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
144
+
| Routes.FullMatch route | Routes.MatchWithTrailingSlash route -> begin
145
+
match route with
146
+
| Static route -> static_handler ~env route
147
+
| _ -> begin
148
+
match !forest with
149
+
| None ->
150
+
let body = Pure_html.to_string Pages.config_picker in
151
+
Cohttp_eio.Server.respond_string ~body ~status:`OK ()
152
+
| Some forest -> begin
153
+
match route with
154
+
| Static _ -> assert false
155
+
| Index ->
147
156
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
148
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content ()
149
-
| None ->
150
-
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
157
+
let body = Pure_html.to_string (Pages.index ()) in
158
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body ()
159
+
| Tree uri -> tree_handler ~forest ~headers:request_headers uri
160
+
| Home ->
161
+
tree_handler ~forest ~headers:request_headers
162
+
(URI.path_string forest.config.home)
163
+
| Search -> Cohttp_eio.Server.respond_string ~body:"" ~status:`OK ()
164
+
| Query -> query_handler ~forest ~resource
151
165
end
152
-
| Search ->
153
-
if request.meth = `POST then
154
-
let body = Eio.Flow.read_all body in
155
-
let get_param key =
156
-
Option.map (String.concat "")
157
-
@@ Option.map snd
158
-
@@ List.find_opt (fun (s, _) -> s = key) (Uri.query_of_encoded body)
159
-
in
160
-
let _search_term = Option.value ~default:"" @@ get_param "search" in
161
-
let search_for = get_param "search-for" in
162
-
let search_results =
163
-
match search_for with
164
-
| None -> []
165
-
| Some "title-text" ->
166
-
(* Forester_search.Index.search *)
167
-
(* forest.search_index *)
168
-
(* search_term *)
169
-
[]
170
-
| Some "full-text" ->
171
-
(* Forester_search.Index.search *)
172
-
(* forest.search_index *)
173
-
(* search_term *)
174
-
[]
175
-
| Some _ -> assert false
176
-
in
177
-
let response =
178
-
let env : Html_client.env =
179
-
{
180
-
forest;
181
-
scope = None;
182
-
loops = Loop_detection.empty;
183
-
xmlns =
184
-
Xmlns.init
185
-
~reserved:
186
-
[{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
187
-
in_backmatter = false;
188
-
}
189
-
in
190
-
Search_menu.results ~env (List.map snd search_results)
191
-
in
192
-
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()
193
-
else
194
-
Cohttp_eio.Server.respond_string ~status:`Method_not_allowed ~body:"" ()
195
-
| Searchmenu ->
196
-
Cohttp_eio.Server.respond_string ~status:`OK ~body:Search_menu.v ()
197
-
| Nil -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" ()
198
-
| Home -> begin
199
-
let home = URI_scheme.named_uri ~base:forest.config.url "index" in
200
-
match State.get_article ~forest home with
201
-
| None -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" ()
202
-
| Some home_tree ->
203
-
let content =
204
-
Pure_html.to_string @@ Htmx_client.render_article ~forest home_tree
205
-
in
206
-
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
207
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content ()
208
166
end
209
-
| Query ->
210
-
let q = Uri.get_query_param resource "query" in
211
-
let response =
212
-
q |> Option.get |> Uri.pct_decode
213
-
|> Repr.of_json_string
214
-
Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t))
215
-
|> function
216
-
| Ok _q ->
217
-
Logs.app (fun m -> m "parsed successfully");
218
-
(* let _, _, result = Driver.update (Query q) forest in *)
219
-
begin match None with
220
-
(* FIXME :*)
221
-
(* | `Vertex_set(vs : Vertex_set.t) -> Htmx_client.render_query_result forest vs *)
222
-
| Some (`Vertex_set vs) -> Htmx_client.render_query_result ~forest vs
223
-
| _ -> None
224
-
end
225
-
| Error (`Msg str) ->
226
-
Logs.app (fun m -> m "failed to parse: %s" str);
227
-
(* Pure_html.txt "failed to parse: %s" str *)
228
-
None
229
-
in
230
-
begin match response with
231
-
| Some nodes ->
232
-
Cohttp_eio.Server.respond_string ~status:`OK
233
-
~body:(Format.asprintf "%a" Pure_html.pp nodes)
234
-
()
235
-
| None ->
236
-
(* If result is empty, use
237
-
[hx-retarget](https://htmx.org/reference/#response_headers) to hide
238
-
the entire section. Right now I am just trying to get the backmatter
239
-
to render correctly, I don't know if this is compatible with the
240
-
other use cases of queries. I can think of multiple ways to work
241
-
around this. We could use a separate endpoint to get the backmatter,
242
-
or we could do some more HTMXing. I guess the question boils down to
243
-
which approach is more in line with our overarching goal of making
244
-
forester a genuine hypermedia format
245
-
*)
246
-
let headers =
247
-
Http.Header.of_list
248
-
[
249
-
("Hx-Retarget", "closest section.backmatter-section");
250
-
("Hx-Swap", "delete");
251
-
]
252
-
in
253
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:"" ()
254
-
end
255
-
| Htmx ->
256
-
let headers =
257
-
Http.Header.of_list [("Content-Type", "application/javascript")]
258
-
in
259
-
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:theme.htmx ()
260
167
end
261
-
| Routes.NoMatch ->
262
-
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
263
168
264
169
let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
265
170
266
-
let run ~env ~port ~forest theme_location =
171
+
let start_browser ~env url =
172
+
let browser =
173
+
match Sys.os_type with
174
+
| "Unix" -> Sys.getenv "BROWSER"
175
+
| "Win32" | "Cygwin" -> "cmd.exe /c start"
176
+
| _ -> assert false
177
+
in
178
+
let proc_mgr = Eio.Stdenv.process_mgr env in
179
+
Eio.Process.run proc_mgr [browser; url]
180
+
181
+
let run ~env ~port ~no_browser ~dev ?config () =
267
182
let@ sw = Eio.Switch.run ?name:None in
268
-
let port = ref port in
269
-
let theme = load_theme ~env theme_location in
183
+
let forest =
184
+
match config with
185
+
| None -> ref None
186
+
| Some config -> (
187
+
match Config_parser.parse_forest_config_file config with
188
+
| Error _ -> ref None
189
+
| Ok config ->
190
+
let forest = Driver.batch_run ~env ~dev ~config in
191
+
ref (Some forest))
192
+
in
270
193
let socket =
271
194
Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true
272
-
(`Tcp (Eio.Net.Ipaddr.V4.loopback, !port))
273
-
and server =
274
-
Cohttp_eio.Server.make ~callback:(handler ~env ~theme ~forest) ()
275
-
in
276
-
Eio.Fiber.both
277
-
(fun () -> Cohttp_eio.Server.run socket server ~on_error:log_warning)
278
-
(fun () ->
279
-
let local_url = Format.sprintf "locahost:%i" !port in
280
-
try
281
-
let browser =
282
-
match Sys.os_type with
283
-
| "Unix" -> Sys.getenv "BROWSER"
284
-
| "Win32" | "Cygwin" -> "cmd.exe /c start"
285
-
| _ -> assert false
286
-
in
287
-
Logs.app (fun m -> m "Opening %s in your browser." local_url);
288
-
let proc_mgr = Eio.Stdenv.process_mgr env in
289
-
Eio.Process.run proc_mgr [browser; local_url]
290
-
with _exn ->
291
-
Logs.app (fun m ->
292
-
m "To view your forest, open %s in your browser." local_url))
195
+
(`Tcp (Eio.Net.Ipaddr.V4.loopback, port))
196
+
and server = Cohttp_eio.Server.make ~callback:(handler ~env ~forest) () in
197
+
let local_url = Format.sprintf "http://localhost:%i" port in
198
+
if no_browser then begin
199
+
Logs.app (fun m -> m "Forester is running on %s" local_url);
200
+
Cohttp_eio.Server.run socket server ~on_error:log_warning
201
+
end
202
+
else
203
+
Eio.Fiber.both
204
+
(fun () -> Cohttp_eio.Server.run socket server ~on_error:log_warning)
205
+
(fun () ->
206
+
try start_browser ~env local_url
207
+
with _exn ->
208
+
Logs.app (fun m ->
209
+
m "To view your forest, open %s in your browser." local_url))
+1
lib/server/dune
+1
lib/server/dune
+5
lib/server/pages/Config_picker.ml
+5
lib/server/pages/Config_picker.ml