forked from
jonmsterling.com/ocaml-forester
ocaml
Canonical URIs and other changes
+ Replace forest:// scheme with canonical URLs
Canonical URLs are things like https://www.jonmsterling.com/foo, with no
extension. Avoiding a file extension (like xml or html) seems important
to avoid future URL breakage. I currently achieve this by putting
"index.xml" in a subdirectory like "foo"; unfortunately, servers do not
automatically treat "index.xml" as a directory index, so I need to
create a dummy index.html file that redirects. Obviously this is
unnecessary for a server deployment in which you can edit .htaccess or
.httpd, but I don't want to assume that all users will have that
ability.
+ Get rid of transclusion modifiers (sentence case, etc.)
+ Don't render anonymous trees at all! Inline only.
+ Store SVGs in files rather than inline
The architecture is cleaned up enough that this is now possible to do
cleanly.
+ Add a rudimentary atom client
References: https://todo.sr.ht/~jonsterling/forester/129
+726
-819
TODO.md
TODO.md
This is a binary file and will not be displayed.
+5
-36
bin/forester/main.ml
+5
-36
bin/forester/main.ml
···
52
52
Forester.render_forest ~dev ~forest;
53
53
Logs.app (fun m -> m "Success!")
54
54
55
-
let export ~env _ config_filename dev =
56
-
let config = Config_parser.parse_forest_config_file config_filename in
57
-
Logs.debug (fun m -> m "Parsed config file %s" config_filename);
58
-
let forest = Driver.batch_run ~env ~dev ~config in
59
-
forest.diagnostics
60
-
|> URI.Tbl.iter (fun _ d -> List.iter Reporter.Tty.display d);
61
-
Forester.export ~forest
62
-
63
55
let new_tree ~env config_filename dest_dir prefix template random =
64
56
let@ () = Reporter.silence in
65
57
let config = Config_parser.parse_forest_config_file config_filename in
···
86
78
trees = ["trees" ] # The directories in which your trees are stored
87
79
assets = ["assets"] # The directories in which your assets are stored
88
80
theme = "theme" # The directory in which your theme is stored
89
-
host = "CHANGEME"
90
-
91
-
[renderer]
92
-
home = "index"
81
+
url = "https://www.my-great-forest.net/" # Replace this with your own domain or web storage. If you don't have one, you can use "http://localhost/"; the URL given here does not matter unless you plan to publish your forest.
93
82
|}
94
83
95
84
let index_tree_str =
96
85
{|\title{Hello, World!}
97
86
\p{Welcome to your first tree! This tree is the root of your forest.}
98
87
\ul{
99
-
\li{[Build and view your forest for the first time](http://www.jonmsterling.com/jms-007D.xml)}
100
-
\li{[Overview of the Forester markup language](http://www.jonmsterling.com/jms-007N.xml)}
101
-
\li{[Creating new trees](http://www.jonmsterling.com/jms-007H.xml)}
102
-
\li{[Creating your personal biographical tree](http://www.jonmsterling.com/jms-007K.xml)}
88
+
\li{[Build and view your forest for the first time](https://www.jonmsterling.com/jms-007D)}
89
+
\li{[Overview of the Forester markup language](https://www.jonmsterling.com/jms-007N)}
90
+
\li{[Creating new trees](https://www.jonmsterling.com/jms-007H)}
91
+
\li{[Creating your personal biographical tree](https://www.jonmsterling.com/jms-007K)}
103
92
}
104
93
|}
105
94
···
212
201
$ arg_no_theme
213
202
)
214
203
215
-
let export_cmd ~env =
216
-
let arg_dev =
217
-
let doc = "Run forester in development mode; this will attach source file locations to the generated json." in
218
-
Arg.value @@ Arg.flag @@ Arg.info ["dev"] ~doc
219
-
in
220
-
let doc = "Export the forest" in
221
-
let man = [
222
-
]
223
-
in
224
-
let info = Cmd.info "export" ~version ~doc ~man in
225
-
Cmd.v
226
-
info
227
-
Term.(
228
-
const (export ~env)
229
-
$ arg_logs
230
-
$ arg_config
231
-
$ arg_dev
232
-
)
233
-
234
204
let new_tree_cmd ~env =
235
205
let arg_prefix =
236
206
let doc = "The namespace prefix for the created tree." in
···
374
344
info
375
345
[
376
346
build_cmd ~env;
377
-
export_cmd ~env;
378
347
new_tree_cmd ~env;
379
348
complete_cmd ~env;
380
349
init_cmd ~env;
+1
-1
bin/forester/test.t
+1
-1
bin/forester/test.t
···
1
1
SPDX-FileCopyrightText: 2024 The Forester Project Contributors
2
2
SPDX-License-Identifier: GPL-3.0-or-later
3
3
4
-
$ git clone https://git.sr.ht/~jonsterling/forester-notes.org
4
+
$ git clone --branch canonical-uris https://git.sr.ht/~jonsterling/forester-notes.org
5
5
Cloning into 'forester-notes.org'...
6
6
$ cd forester-notes.org
7
7
$ forester build
+2
-3
lib/compiler/Asset_router.ml
+2
-3
lib/compiler/Asset_router.ml
···
17
17
IO_error
18
18
~extra_remarks: [Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m]
19
19
20
-
let install ~host ~source_path ~content =
20
+
let install ~(config : Config.t) ~source_path ~content =
21
21
let normalized = normalize source_path in
22
22
match Hashtbl.find_opt router normalized with
23
23
| Some uri -> uri
···
26
26
let cid = Cid.v ~version: `Cidv1 ~codec: `Raw ~base: `Base32 ~hash in
27
27
let cid_str = Cid.to_string cid in
28
28
let ext = Filename.extension normalized in
29
-
let filename = cid_str ^ ext in
30
-
let uri = URI_scheme.hash_uri ~host filename in
29
+
let uri = URI_scheme.named_uri ~base: config.url (cid_str ^ ext) in
31
30
Hashtbl.add router normalized uri;
32
31
uri
33
32
+20
-30
lib/compiler/Cache.ml
+20
-30
lib/compiler/Cache.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
open Forester_prelude
7
8
open Forester_core
8
-
module T = Types
9
+
open struct module T = Types end
9
10
10
11
(*Inspired by
11
12
https://rustc-dev-guide.rust-lang.org/queries/incremental-compilation-in-detail.html
···
85
86
86
87
let pred t v = Dependecy_graph.pred t.graph v
87
88
88
-
let get_changed_paths
89
-
: host: string ->
90
-
t ->
91
-
Eio.Fs.dir_ty Eio.Path.t List.t ->
92
-
Eio.Fs.dir_ty Eio.Path.t Seq.t
93
-
= fun ~host cache dirs ->
94
-
Dir_scanner.scan_directories dirs
95
-
|> Seq.filter_map
96
-
(fun path ->
97
-
let path_str = Eio.Path.native_exn path in
98
-
let uri = URI_scheme.path_to_uri ~host path_str in
99
-
let last_modified = Eio.Path.(stat ~follow: true path).mtime in
100
-
(* "flipped" bind, by default returns the current path. IDK, I am being lazy. *)
101
-
let (let*) o f = match o with None -> Some path | Some v -> f v in
102
-
let* {timestamp; _} = Dependency_tbl.find_opt cache.tbl (Tree uri) in
103
-
let* last_seen = timestamp in
104
-
if last_modified > last_seen then
105
-
Some path
106
-
else
107
-
None
108
-
)
89
+
let get_changed_paths ~(config : Config.t) (cache : t) (dirs : Eio.Fs.dir_ty Eio.Path.t List.t) : Eio.Fs.dir_ty Eio.Path.t Seq.t =
90
+
let@ path = Seq.filter_map @~ Dir_scanner.scan_directories dirs in
91
+
let path_str = Eio.Path.native_exn path in
92
+
let uri = URI_scheme.path_to_uri ~base: config.url path_str in
93
+
let last_modified = Eio.Path.(stat ~follow: true path).mtime in
94
+
(* "flipped" bind, by default returns the current path. IDK, I am being lazy. *)
95
+
let (let*) o f = match o with None -> Some path | Some v -> f v in
96
+
let* {timestamp; _} = Dependency_tbl.find_opt cache.tbl (Tree uri) in
97
+
let* last_seen = timestamp in
98
+
if last_modified > last_seen then
99
+
Some path
100
+
else
101
+
None
109
102
110
103
let rec try_mark_green t node =
111
104
let exception Done of bool in
112
105
let dependencies =
113
-
List.filter_map
114
-
(fun v ->
115
-
match Dependency_tbl.find_opt t.tbl v with
116
-
| None -> None
117
-
| Some c ->
118
-
Some (v, c)
119
-
)
120
-
(pred t node)
106
+
let@ v = List.filter_map @~ pred t node in
107
+
match Dependency_tbl.find_opt t.tbl v with
108
+
| None -> None
109
+
| Some c ->
110
+
Some (v, c)
121
111
in
122
112
let result =
123
113
try
-28
lib/compiler/Config.ml
-28
lib/compiler/Config.ml
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
type t = {
8
-
host: string;
9
-
home: string option;
10
-
trees: string list;
11
-
assets: string list;
12
-
foreign: string list;
13
-
theme: string;
14
-
base_url: string;
15
-
prefixes: string list;
16
-
}
17
-
[@@deriving show, repr]
18
-
19
-
let default : t = {
20
-
host = "my-forest";
21
-
trees = ["trees"];
22
-
assets = [];
23
-
foreign = [];
24
-
theme = "theme";
25
-
home = None;
26
-
base_url = "/";
27
-
prefixes = [];
28
-
}
+5
-4
lib/compiler/Config.mli
lib/core/Config.mli
+5
-4
lib/compiler/Config.mli
lib/core/Config.mli
···
5
5
*)
6
6
7
7
type t = {
8
-
host: string;
9
-
home: string option;
10
8
trees: string list;
11
9
assets: string list;
12
10
foreign: string list;
13
11
theme: string;
14
-
base_url: string;
15
-
prefixes: string list;
12
+
url: URI.t;
13
+
home: URI.t option;
14
+
prefixes: string list; (* TODO: remove this as we no longer advocate using prefixes at all *)
16
15
}
17
16
[@@deriving show]
18
17
19
18
val default : t
19
+
20
+
val home_uri : t -> URI.t
+33
-48
lib/compiler/Diagnostic_store.ml
+33
-48
lib/compiler/Diagnostic_store.ml
···
5
5
*
6
6
*)
7
7
8
+
open Forester_prelude
8
9
open Forester_core
9
10
10
11
module Table = Hashtbl.Make(Lsp.Uri)
···
12
13
13
14
type t = Reporter.diagnostic list Table.t
14
15
15
-
let replace
16
-
: 'a list Table.t -> 'a list -> unit
17
-
= fun table fresh_diagnostics ->
16
+
let replace (table : 'a list Table.t) (fresh_diagnostics : 'a list) : unit =
18
17
let diags = Hashtbl.create 100 in
19
-
fresh_diagnostics
20
-
|> List.iter
21
-
(fun d ->
22
-
match Reporter.guess_uri d with
23
-
| None ->
24
-
Reporter.fatal
25
-
Internal_error
26
-
~extra_remarks: [Asai.Diagnostic.loctextf "Dropped a diagnostic because its URI could not be guessed"]
27
-
| Some uri ->
28
-
Hashtbl.replace diags uri [d]
29
-
);
30
-
diags
31
-
|> Hashtbl.to_seq
32
-
|> Seq.iter
33
-
(fun (uri, ds) ->
34
-
assert (not @@ Filename.is_relative (Lsp.Uri.to_path uri));
35
-
Table.replace table uri ds
36
-
)
18
+
begin
19
+
let@ d = List.iter @~ fresh_diagnostics in
20
+
match Reporter.guess_uri d with
21
+
| None ->
22
+
Reporter.fatal
23
+
Internal_error
24
+
~extra_remarks: [Asai.Diagnostic.loctextf "Dropped a diagnostic because its URI could not be guessed"]
25
+
| Some uri ->
26
+
Hashtbl.replace diags uri [d]
27
+
end;
28
+
let@ uri, ds = Seq.iter @~ Hashtbl.to_seq diags in
29
+
assert (not @@ Filename.is_relative (Lsp.Uri.to_path uri));
30
+
Table.replace table uri ds
37
31
38
-
let add
39
-
: 'a list Table.t -> 'a list -> unit
40
-
= fun table fresh_diagnostics ->
32
+
let add (table : 'a list Table.t) (fresh_diagnostics : 'a list) : unit =
41
33
let diagnostics = Hashtbl.create 100 in
42
-
fresh_diagnostics
43
-
|> List.iter
44
-
(fun d ->
45
-
match Reporter.guess_uri d with
46
-
| None ->
47
-
Reporter.fatal
48
-
Internal_error
49
-
~extra_remarks: [Asai.Diagnostic.loctextf "Dropped a diagnostic because its URI could not be guessed"]
50
-
| Some uri ->
51
-
match Hashtbl.find_opt diagnostics uri with
52
-
| None -> Hashtbl.replace diagnostics uri [d]
53
-
| Some t -> Hashtbl.replace diagnostics uri (d :: t)
54
-
);
55
-
diagnostics
56
-
|> Hashtbl.to_seq
57
-
|> Seq.iter
58
-
(fun (uri, ds) ->
59
-
assert (not @@ Filename.is_relative (Lsp.Uri.to_path uri));
60
-
match Table.find_opt table uri with
61
-
| None ->
62
-
Table.replace table uri ds
63
-
| Some previous ->
64
-
Table.replace table uri (ds @ previous)
65
-
)
34
+
begin
35
+
let@ d = List.iter @~ fresh_diagnostics in
36
+
match Reporter.guess_uri d with
37
+
| None ->
38
+
Reporter.fatal
39
+
Internal_error
40
+
~extra_remarks: [Asai.Diagnostic.loctextf "Dropped a diagnostic because its URI could not be guessed"]
41
+
| Some uri ->
42
+
let t = Option.value ~default: [] @@ Hashtbl.find_opt diagnostics uri in
43
+
Hashtbl.replace diagnostics uri (d :: t)
44
+
end;
45
+
let@ uri, ds = Seq.iter @~ Hashtbl.to_seq diagnostics in
46
+
assert (not @@ Filename.is_relative (Lsp.Uri.to_path uri));
47
+
Table.replace table uri @@
48
+
match Table.find_opt table uri with
49
+
| None -> ds
50
+
| Some previous -> ds @ previous
+1
lib/compiler/Dir_scanner.ml
+1
lib/compiler/Dir_scanner.ml
+9
-8
lib/compiler/Driver.ml
+9
-8
lib/compiler/Driver.ml
···
8
8
open Forester_prelude
9
9
open State.Syntax
10
10
11
-
module T = Types
11
+
open struct module T = Types end
12
12
13
13
let update (action : Action.t) (forest : State.t) =
14
14
let open Action in
15
-
let host = forest.config.host in
16
15
let forest = State.update_history forest action in
17
16
match action with
18
17
| Quit e ->
···
35
34
Seq.iter
36
35
(fun doc ->
37
36
let lsp_uri = Lsp.Text_document.documentUri doc in
38
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host lsp_uri in
37
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
39
38
URI.Tbl.replace forest.resolver uri (Lsp.Uri.to_path lsp_uri);
40
39
forest.={uri} <- Document doc
41
40
)
···
61
60
List.iter
62
61
(fun diag ->
63
62
let@ uri =
64
-
Option.iter @~ Option.map (URI_scheme.lsp_uri_to_uri ~host: forest.config.host) (Reporter.guess_uri diag)
63
+
Option.iter @~ Option.map (URI_scheme.lsp_uri_to_uri ~base: forest.config.url) (Reporter.guess_uri diag)
65
64
in
66
65
forest.?{uri} <- [diag]
67
66
)
···
113
112
Done, result
114
113
| Plant_assets ->
115
114
let@ () = Reporter.tracef "when planting assets" in
115
+
(* TODO: We really only need to plant the assets that are referred to (look for calls to Asset_router.uri_of_asset).*)
116
116
let paths =
117
117
Dir_scanner.scan_asset_directories
118
118
(Eio_util.paths_of_dirs ~env: forest.env forest.config.assets)
···
121
121
let module EP = Eio.Path in
122
122
begin
123
123
let@ path = Eio.Fiber.List.iter ~max_fibers: 20 @~ List.of_seq paths in
124
+
let@ () = Reporter.easy_run in
124
125
let content = EP.load path in
125
126
let source_path = EP.native_exn path in
126
-
let uri = Asset_router.install ~host: forest.config.host ~source_path ~content in
127
+
let uri = Asset_router.install ~config: forest.config ~source_path ~content in
127
128
Logs.debug (fun m -> m "Installed %s at %a" source_path URI.pp uri);
128
129
State.plant_resource (T.Asset {uri; content}) forest
129
130
end;
···
141
142
let doc = Imports.load_tree path in
142
143
Logs.debug (fun m -> m "%s" (Lsp.Text_document.text doc));
143
144
let lsp_uri = Lsp.Text_document.documentUri doc in
144
-
let uri = URI_scheme.lsp_uri_to_uri ~host lsp_uri in
145
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
145
146
forest.={uri} <- Document doc;
146
147
Parse lsp_uri, forest
147
148
| Parse uri ->
148
149
let@ () = Reporter.tracef "when parsing %s" (Lsp.Uri.to_string uri) in
149
150
Logs.debug (fun m -> m "Reparsing");
150
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host uri in
151
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in
151
152
begin
152
153
match Option.bind forest.={uri} Tree.to_doc with
153
154
| Some doc ->
154
155
begin
155
-
match Parse.parse_document ~host doc with
156
+
match Parse.parse_document ~config: forest.config doc with
156
157
| Ok code ->
157
158
forest.={uri} <- Parsed code;
158
159
forest.?{uri} <- [];
+63
-86
lib/compiler/Eval.ml
+63
-86
lib/compiler/Eval.ml
···
59
59
in
60
60
T.Content
61
61
[
62
-
make_section "references" @@ Builtin_queries.references_datalog vtx;
63
-
make_section "context" @@ Builtin_queries.context_datalog vtx;
64
-
make_section "backlinks" @@ Builtin_queries.backlinks_datalog vtx;
65
-
make_section "related" @@ Builtin_queries.related_datalog vtx;
66
-
make_section "contributions" @@ Builtin_queries.contributions_datalog vtx
62
+
make_section "References" @@ Builtin_queries.references_datalog vtx;
63
+
make_section "Context" @@ Builtin_queries.context_datalog vtx;
64
+
make_section "Backlinks" @@ Builtin_queries.backlinks_datalog vtx;
65
+
make_section "Related" @@ Builtin_queries.related_datalog vtx;
66
+
make_section "Contributions" @@ Builtin_queries.contributions_datalog vtx
67
67
]
68
68
69
69
type result = {articles: T.content T.article list; jobs: Job.job Range.located list} [@@deriving show]
···
71
71
module Tape = Tape_effect.Make ()
72
72
module Lex_env = Algaeff.Reader.Make(struct type t = Value.t Env.t end)
73
73
module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Env.t end)
74
-
module Host_env = Algaeff.Reader.Make(struct type t = string end)
74
+
module Config_env = Algaeff.Reader.Make(struct type t = Config.t end)
75
75
module Heap = Algaeff.State.Make(struct type t = Value.obj Env.t end)
76
-
module Anon_subtree_ix = Algaeff.State.Make(struct type t = int end)
77
76
module Emitted_trees = Algaeff.State.Make(struct type t = T.content T.article list end)
78
77
module Jobs = Algaeff.State.Make(struct type t = Job.job Range.located list end)
79
78
module Frontmatter = Algaeff.State.Make(struct type t = T.content T.frontmatter end)
···
96
95
}
97
96
98
97
let resolve_uri ~loc: _ str =
99
-
let base = let host = Host_env.read () in URI_scheme.base_uri ~host in
100
98
match URI.of_string_exn str with
101
-
| uri -> Ok (URI.resolve ~base uri)
102
-
| exception _ -> Error "Invalid URI"
99
+
| uri ->
100
+
match URI.host uri with
101
+
| Some _ -> Ok uri
102
+
| None ->
103
+
let config = Config_env.read () in
104
+
Result.ok @@ URI_scheme.named_uri ~base: config.url str
105
+
| exception _ -> Error "Invalid URI"
103
106
104
107
let extract_uri (node : located) =
105
108
let text = extract_text node in
···
131
134
let@ uri = Result.map @~ extract_uri node in
132
135
T.Uri_vertex uri
133
136
134
-
let anon_uri base =
135
-
let ix = Anon_subtree_ix.get () in
136
-
let ix' = ix + 1 in
137
-
Anon_subtree_ix.set ix';
138
-
let segment = Format.sprintf "%i" ix in
139
-
URI.with_path_components (URI.path_components base @ [segment]) base
140
-
141
137
let pp_tex_cs fmt = function
142
138
| TeX_cs.Symbol x -> Format.fprintf fmt "\\%c" x
143
139
| TeX_cs.Word x -> Format.fprintf fmt "\\%s " x
···
178
174
| Ref ->
179
175
begin
180
176
match eval_pop_arg ~loc |> extract_uri with
181
-
| Ok href when URI.scheme href = Some URI_scheme.scheme ->
177
+
| Ok href ->
182
178
let content =
183
179
T.Content
184
180
[
185
-
T.Transclude {href; target = T.Taxon; modifier = Sentence_case};
181
+
T.Transclude {href; target = T.Taxon};
186
182
T.Text " ";
187
183
T.Contextual_number href
188
184
]
189
185
in
190
186
emit_content_node ~loc @@ Link {href; content}
191
-
| Ok uri ->
192
-
Reporter.fatal
193
-
?loc
194
-
(Reference_error uri)
195
-
~extra_remarks: [Asai.Diagnostic.loctextf "Cannot refer to content with non-forester URI %a" URI.pp uri]
196
187
| Error _ ->
197
188
Reporter.fatal
198
189
?loc
···
200
191
~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in ref"]
201
192
end
202
193
| Link {title; dest} ->
203
-
let _host = Host_env.read () in
204
194
let dest = {node with value = dest} |> Range.map eval_tape in
205
195
let href =
206
196
match extract_uri dest with
···
214
204
in
215
205
let content =
216
206
match title with
217
-
| None -> T.Content [T.Transclude {href; target = T.Title {empty_when_untitled = false}; modifier = Identity}]
207
+
| None -> T.Content [T.Transclude {href; target = T.Title {empty_when_untitled = false}}]
218
208
| Some title -> {node with value = eval_tape title} |> extract_content
219
209
in
220
210
emit_content_node ~loc @@ Link {href; content}
···
239
229
let href_arg = eval_pop_arg ~loc in
240
230
let href =
241
231
match extract_uri href_arg with
242
-
| Ok uri when URI.scheme uri = Some URI_scheme.scheme -> uri
243
-
| Ok uri ->
244
-
Reporter.fatal ?loc (Type_error {got = None; expected = []}) ~extra_remarks: [Asai.Diagnostic.loctextf "Cannot transclude content with non-forester URI %a" URI.pp uri]
232
+
| Ok uri -> uri
245
233
| Error _ ->
246
234
Reporter.fatal ?loc (Type_error {got = None; expected = [`URI]}) ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in transclusion"]
247
235
in
248
-
emit_content_node ~loc @@ T.Transclude {href; target = Full flags; modifier = Identity}
236
+
emit_content_node ~loc @@ T.Transclude {href; target = Full flags}
249
237
| Subtree (addr_opt, nodes) ->
250
238
let flags = get_transclusion_flags ~loc in
251
-
let host = Host_env.read () in
239
+
let config = Config_env.read () in
252
240
let uri =
253
241
match addr_opt with
254
-
| Some addr -> URI_scheme.user_uri ~host addr
255
-
| None ->
256
-
let fm = Frontmatter.get () in
257
-
match fm.uri with
258
-
| None ->
259
-
(* Currently the only source of trees without URIs are the backmatter subtrees (backlinks, context, references, etc.). I believe that this case is therefore unreachable.*)
260
-
assert false
261
-
| Some current_uri ->
262
-
anon_uri current_uri
242
+
| Some addr -> Some (URI_scheme.named_uri ~base: config.url addr)
243
+
| None -> None
263
244
in
264
-
let subtree = eval_tree_inner ~uri nodes in
245
+
let subtree = eval_tree_inner ?uri nodes in
265
246
let frontmatter = Frontmatter.get () in
266
-
let subtree = {subtree with frontmatter = {subtree.frontmatter with uri = Some uri; designated_parent = frontmatter.uri}} in
267
-
Emitted_trees.modify @@ List.cons subtree;
268
-
let transclusion = T.{href = uri; target = Full flags; modifier = Identity} in
269
-
emit_content_node ~loc @@ Transclude transclusion
247
+
let subtree = {subtree with frontmatter = {subtree.frontmatter with uri; designated_parent = frontmatter.uri}} in
248
+
begin
249
+
match uri with
250
+
| Some uri ->
251
+
Emitted_trees.modify @@ List.cons subtree;
252
+
let transclusion = T.{href = uri; target = Full flags} in
253
+
emit_content_node ~loc @@ Transclude transclusion
254
+
| None ->
255
+
emit_content_node ~loc @@ T.Section (T.article_to_section ~flags subtree)
256
+
end
270
257
| Results_of_query ->
271
258
let arg = eval_pop_arg ~loc in
272
259
begin
···
287
274
| other -> Reporter.fatal ?loc: query_arg.loc (Type_error {expected = [`Dx_query]; got = Some other})
288
275
end
289
276
| Embed_tex ->
277
+
let config = Config_env.read () in
290
278
let preamble = pop_content_arg ~loc |> T.TeX_like.string_of_content in
291
279
let body = pop_content_arg ~loc |> T.TeX_like.string_of_content in
292
280
let source = LaTeX_template.to_string ~preamble ~body in
293
281
let hash = Digest.to_hex @@ Digest.string source in
294
-
let content ~svg =
295
-
let base64 = Base64.encode_string svg in
296
-
let content =
297
-
T.Content
298
-
[
299
-
T.Xml_elt
300
-
{
301
-
content = T.Content [];
302
-
name = {uname = "img"; prefix = "html"; xmlns = Some "http://www.w3.org/1999/xhtml"};
303
-
attrs = [
304
-
{
305
-
key = {uname = "src"; prefix = ""; xmlns = None};
306
-
value = T.Content [T.Text (Format.sprintf "data:image/svg+xml;base64,%s" base64)]
307
-
}
308
-
]
309
-
}
310
-
]
311
-
in
312
-
let sources = [
313
-
T.{type_ = "latex"; part = "preamble"; source = preamble};
314
-
T.{type_ = "latex"; part = "body"; source = body}
315
-
]
316
-
in
317
-
let artefact = T.{hash; content; sources} in
318
-
T.Content [T.Artefact artefact]
282
+
let job = Job.{hash; source} in
283
+
let uri = Job.uri_for_latex_to_svg_job ~base: config.url job in
284
+
let content =
285
+
T.Content
286
+
[
287
+
T.Xml_elt
288
+
{
289
+
content = T.Content [];
290
+
name = {uname = "img"; prefix = "html"; xmlns = Some "http://www.w3.org/1999/xhtml"};
291
+
attrs = [
292
+
{
293
+
key = {uname = "src"; prefix = ""; xmlns = None};
294
+
value = T.Content [T.Route_of_uri uri]
295
+
}
296
+
]
297
+
}
298
+
]
319
299
in
320
-
let job = Job.LaTeX_to_svg {hash; source; content} in
321
-
Jobs.modify (List.cons (Range.locate_opt loc job));
322
-
let transclusion =
323
-
let host = Host_env.read () in
324
-
let href = URI_scheme.hash_uri ~host hash in
325
-
let target = T.Mainmatter in
326
-
T.{href; target; modifier = Identity}
300
+
let sources = [
301
+
T.{type_ = "latex"; part = "preamble"; source = preamble};
302
+
T.{type_ = "latex"; part = "body"; source = body}
303
+
]
327
304
in
328
-
emit_content_node ~loc @@ T.Transclude transclusion
305
+
let artefact = T.{hash; content; sources} in
306
+
Jobs.modify (List.cons (Range.locate_opt loc (Job.LaTeX_to_svg job)));
307
+
emit_content_node ~loc @@ T.Artefact artefact
329
308
| Route_asset ->
330
309
let source_path = pop_text_arg ~loc in
331
310
let uri = Asset_router.uri_of_asset ?loc ~source_path () in
···
432
411
Frontmatter.modify (fun fm -> {fm with title = Some title});
433
412
process_tape ()
434
413
| Parent ->
435
-
let _host = Host_env.read () in
436
414
let parent_arg = eval_pop_arg ~loc in
437
415
let parent =
438
416
match extract_uri parent_arg with
···
607
585
and emit_content_node ~loc content =
608
586
emit_content_nodes ~loc [content]
609
587
610
-
and eval_tree_inner ~(uri : URI.t) (syn : Syn.t) : T.content T.article =
588
+
and eval_tree_inner ?(uri : URI.t option) (syn : Syn.t) : T.content T.article =
611
589
let attribution_is_author attr =
612
590
match T.(attr.role) with
613
591
| T.Author -> true
···
617
595
let attributions = List.filter attribution_is_author outer_frontmatter.attributions in
618
596
let frontmatter =
619
597
T.default_frontmatter
620
-
~uri
598
+
?uri
621
599
~attributions
622
600
?source_path: outer_frontmatter.source_path
623
601
~dates: outer_frontmatter.dates
624
602
()
625
603
in
626
-
let@ () = Anon_subtree_ix.run ~init: 0 in
627
604
let@ () = Frontmatter.run ~init: frontmatter in
628
605
let mainmatter = {value = eval_tape syn; loc = None} |> extract_content in
629
606
let frontmatter = Frontmatter.get () in
630
-
let backmatter = default_backmatter ~uri in
631
-
T.{frontmatter; mainmatter; backmatter}
607
+
let backmatter = match uri with Some uri -> default_backmatter ~uri | None -> Content [] in
608
+
T.{frontmatter; mainmatter; backmatter = backmatter}
632
609
633
610
let empty_result = {
634
611
articles = [];
···
636
613
}
637
614
638
615
let eval_tree
639
-
~(host : string)
616
+
~(config : Config.t)
640
617
~(uri : URI.t)
641
618
~(source_path : string option)
642
619
(tree : Syn.t)
···
656
633
let@ () = Heap.run ~init: Env.empty in
657
634
let@ () = Lex_env.run ~env: Env.empty in
658
635
let@ () = Dyn_env.run ~env: Env.empty in
659
-
let@ () = Host_env.run ~env: host in
636
+
let@ () = Config_env.run ~env: config in
660
637
let main = eval_tree_inner ~uri tree in
661
638
let side = Emitted_trees.get () in
662
639
let jobs = Jobs.get () in
+1
-1
lib/compiler/Eval.mli
+1
-1
lib/compiler/Eval.mli
+3
-4
lib/compiler/Expand.ml
+3
-4
lib/compiler/Expand.ml
···
155
155
| {value = Group (d, xs); loc} :: rest ->
156
156
{value = Syn.Group (d, expand xs); loc} :: expand rest
157
157
| {value = Subtree (addr, nodes); loc} :: rest ->
158
-
let host = (F.get ()).config.host in
158
+
let config = (F.get ()).config in
159
159
let parent_uri = Parent.read () in
160
160
let identity =
161
161
match addr with
162
-
| Some addr -> Tree.URI (URI_scheme.user_uri ~host addr)
162
+
| Some addr -> Tree.URI (URI_scheme.named_uri ~base: config.url addr)
163
163
| None -> Tree.Anonymous
164
164
in
165
165
let subtree =
···
240
240
{value = Syn.Call (expand obj, method_name); loc} :: expand rest
241
241
| {value = Import (vis, dep); loc} :: rest ->
242
242
let forest = F.get () in
243
-
let host = forest.config.host in
244
-
let dep_uri = URI_scheme.user_uri ~host dep in
243
+
let dep_uri = URI_scheme.named_uri ~base: forest.config.url dep in
245
244
begin
246
245
match forest./{dep_uri} with
247
246
| None ->
+1
-1
lib/compiler/Expand.mli
+1
-1
lib/compiler/Expand.mli
···
24
24
25
25
val suggestions : string list -> ('a, 'b) Trie.t -> (Trie.path * 'a * int) list
26
26
27
-
val expand_tree : forest:State.t -> Tree.code -> Tree.syn * Reporter.Message.t Asai.Diagnostic.t list
27
+
val expand_tree : forest: State.t -> Tree.code -> Tree.syn * Reporter.Message.t Asai.Diagnostic.t list
+27
-35
lib/compiler/Forest.ml
+27
-35
lib/compiler/Forest.ml
···
187
187
let section_symbol = "§"
188
188
189
189
let get_content_of_transclusion (transclusion : T.transclusion) forest =
190
-
let@ content =
191
-
Option.map @~
192
-
match transclusion.target with
193
-
| Full flags ->
194
-
let@ article = Option.map @~ get_article transclusion.href forest in
195
-
T.Content [T.Section (T.article_to_section article ~flags)]
196
-
| Mainmatter ->
197
-
let@ article = Option.map @~ get_article transclusion.href forest in
198
-
article.mainmatter
199
-
| Title flags ->
200
-
Option.some @@
201
-
begin
202
-
match get_article transclusion.href forest with
203
-
| None -> T.Content [T.Uri transclusion.href]
204
-
| Some article -> get_expanded_title ~flags article.frontmatter forest
205
-
end
206
-
| Taxon ->
207
-
let@ article = Option.map @~ get_article transclusion.href forest in
208
-
let default = T.Content [T.Text section_symbol] in
209
-
Option.value ~default article.frontmatter.taxon
210
-
in
211
-
T.apply_modifier_to_content transclusion.modifier content
190
+
match transclusion.target with
191
+
| Full flags ->
192
+
let@ article = Option.map @~ get_article transclusion.href forest in
193
+
T.Content [T.Section (T.article_to_section article ~flags)]
194
+
| Mainmatter ->
195
+
let@ article = Option.map @~ get_article transclusion.href forest in
196
+
article.mainmatter
197
+
| Title flags ->
198
+
Option.some @@
199
+
begin
200
+
match get_article transclusion.href forest with
201
+
| None -> T.Content [T.Uri transclusion.href]
202
+
| Some article -> get_expanded_title ~flags article.frontmatter forest
203
+
end
204
+
| Taxon ->
205
+
let@ article = Option.map @~ get_article transclusion.href forest in
206
+
let default = T.Content [T.Text section_symbol] in
207
+
Option.value ~default article.frontmatter.taxon
212
208
213
-
let get_title_or_content_of_vertex ?(not_found = fun _ -> None) ~modifier vertex forest =
214
-
let@ content =
215
-
Option.map @~
216
-
match vertex with
217
-
| T.Content_vertex content -> Some content
218
-
| T.Uri_vertex uri ->
219
-
begin
220
-
match get_article uri forest with
221
-
| Some article -> article.frontmatter.title
222
-
| None -> not_found uri
223
-
end
224
-
in
225
-
T.apply_modifier_to_content modifier content
209
+
let get_title_or_content_of_vertex ?(not_found = fun _ -> None) vertex forest =
210
+
match vertex with
211
+
| T.Content_vertex content -> Some content
212
+
| T.Uri_vertex uri ->
213
+
begin
214
+
match get_article uri forest with
215
+
| Some article -> article.frontmatter.title
216
+
| None -> not_found uri
217
+
end
226
218
227
219
let get_all_articles resources =
228
220
let extract_article = function
+2
-3
lib/compiler/Forest.mli
+2
-3
lib/compiler/Forest.mli
···
9
9
include module type of URI.Tbl
10
10
11
11
(**/**)
12
-
module T = Forester_core.Types
13
-
module Dx = Forester_core.Datalog_expr
12
+
module T := Types
13
+
module Dx := Datalog_expr
14
14
15
15
val execute_datalog_script : (module Forest_graphs.S) -> (string, Vertex.t) Dx.sequent list -> unit
16
16
(**/**)
···
55
55
56
56
val get_title_or_content_of_vertex :
57
57
?not_found: (key -> T.content option) ->
58
-
modifier: T.modifier ->
59
58
T.content T.vertex ->
60
59
T.content T.resource t ->
61
60
T.content option
-3
lib/compiler/Forester_compiler.ml
-3
lib/compiler/Forester_compiler.ml
+5
-6
lib/compiler/Imports.ml
+5
-6
lib/compiler/Imports.ml
···
54
54
| Some path ->
55
55
let doc = load_tree Eio.Path.(forest.env#fs / path) in
56
56
Result.to_option @@
57
-
Parse.parse_document ~host: forest.config.host doc
57
+
Parse.parse_document ~config: forest.config doc
58
58
| None ->
59
59
match Dir_scanner.find_tree dirs uri with
60
60
| Some path ->
···
62
62
URI.Tbl.add forest.resolver uri native;
63
63
let doc = load_tree path in
64
64
Result.to_option @@
65
-
Parse.parse_document ~host: forest.config.host doc
65
+
Parse.parse_document ~config: forest.config doc
66
66
| None ->
67
67
Reporter.fatal (Resource_not_found uri)
68
68
···
78
78
79
79
and analyse_node ~root (node : Code.node Asai.Range.located) =
80
80
let env = Analysis_env.read () in
81
-
let host = env.forest.config.host in
81
+
let config = env.forest.config in
82
82
match node.value with
83
83
| Import (_, dep) ->
84
-
(* NOTE: Doesn't this imply we can't import like \import{forest://foo/bar}?*)
85
-
let dep_uri = URI_scheme.user_uri ~host dep in
84
+
let dep_uri = URI_scheme.named_uri ~base: config.url dep in
86
85
let dependency = T.Uri_vertex dep_uri in
87
86
let target = T.Uri_vertex root in
88
87
Forest_graph.add_vertex env.graph dependency;
···
101
100
match addr with
102
101
| None -> Tree.Anonymous
103
102
| Some string ->
104
-
URI (URI_scheme.user_uri ~host string)
103
+
URI (URI_scheme.named_uri ~base: config.url string)
105
104
in
106
105
analyse_tree
107
106
{identity; origin = Subtree {parent = URI root}; nodes; timestamp = None;}
+3
-1
lib/compiler/Job.ml
+3
-1
lib/compiler/Job.ml
···
15
15
type latex_to_svg_job = {
16
16
hash: string;
17
17
source: string;
18
-
content: svg: string -> content
19
18
}
20
19
[@@deriving show]
20
+
21
+
let uri_for_latex_to_svg_job ~(base : URI.t) (job : latex_to_svg_job) =
22
+
URI_scheme.named_uri ~base @@ job.hash ^ ".svg"
21
23
22
24
type publication = {
23
25
name: string;
+2
-2
lib/compiler/Parse.ml
+2
-2
lib/compiler/Parse.ml
···
15
15
lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = filename};
16
16
parse lexbuf
17
17
18
-
let parse_document ~host doc =
18
+
let parse_document ~(config : Config.t) doc =
19
19
let uri = Lsp.Text_document.documentUri doc in
20
20
let path = Lsp.Uri.to_path uri in
21
21
let text = Lsp.Text_document.text doc in
···
26
26
Tree.{
27
27
nodes;
28
28
origin = Physical doc;
29
-
identity = URI (URI_scheme.path_to_uri ~host path);
29
+
identity = URI (URI_scheme.path_to_uri ~base: config.url path);
30
30
timestamp = Some (Unix.time ());
31
31
}
32
32
)
+2
-1
lib/compiler/Parse.mli
+2
-1
lib/compiler/Parse.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
open Forester_core
7
8
include module type of Forester_parser.Parse
8
9
9
10
val parse_document :
10
-
host: string ->
11
+
config: Config.t ->
11
12
Lsp.Text_document.t ->
12
13
(Forester_core.Tree.code, Forester_core.Reporter.diagnostic) result
13
14
+15
-24
lib/compiler/Phases.ml
+15
-24
lib/compiler/Phases.ml
···
18
18
|> Seq.map Imports.load_tree
19
19
20
20
let parse (forest : State.t) =
21
-
let host = forest.config.host in
22
21
let trees = forest.index |> URI.Tbl.to_seq_values |> List.of_seq in
23
22
let results =
24
23
let@ tree = List.filter_map @~ trees in
25
24
match tree with
26
-
| Document doc -> Some (Parse.parse_document ~host doc)
25
+
| Document doc -> Some (Parse.parse_document ~config: forest.config doc)
27
26
| Parsed _
28
27
| Expanded _
29
28
| Resource _ ->
···
36
35
37
36
let reparse (doc : Lsp.Text_document.t) (forest : State.t) =
38
37
Logs.debug (fun m -> m "reparsing");
39
-
let host = forest.config.host in
40
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host @@ Lsp.Text_document.documentUri doc in
38
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url @@ Lsp.Text_document.documentUri doc in
41
39
begin
42
-
match Parse.parse_document ~host doc with
40
+
match Parse.parse_document ~config: forest.config doc with
43
41
| Ok code ->
44
42
forest.={uri} <- Parsed code;
45
43
Imports.fixup code forest
···
117
115
118
116
let run_jobs (forest : State.t) jobs =
119
117
Logs.debug (fun m -> m "Running %d jobs" (List.length jobs));
120
-
(* All articles induced by LaTeX jobs must be planted prior to publication export. *)
121
-
let articles_to_plant =
118
+
(* All resources induced by LaTeX jobs must be planted prior to publication export. *)
119
+
let resources_to_plant =
122
120
let@ Range.{value; loc} = Eio.Fiber.List.filter_map ~max_fibers: 20 @~ jobs in
121
+
let@ () = Reporter.easy_run in
123
122
match value with
124
123
| Job.LaTeX_to_svg job ->
125
-
let@ () = Reporter.easy_run in
126
124
let svg = Build_latex.latex_to_svg ~env: forest.env ?loc job.source in
127
-
let uri = URI_scheme.hash_uri ~host: forest.config.host job.hash in
128
-
let frontmatter = T.default_frontmatter ~uri () in
129
-
let mainmatter = job.content ~svg in
130
-
let backmatter = T.Content [] in
131
-
Some T.{frontmatter; mainmatter; backmatter}
125
+
let uri = Job.uri_for_latex_to_svg_job ~base: forest.config.url job in
126
+
Some (T.Asset {uri; content = svg})
132
127
| Job.Publish _ -> None
133
128
in
134
129
begin
135
130
(* It is probably not save to plant the articles in parallel, so this is done sequentially! *)
136
-
let@ article = List.iter @~ articles_to_plant in
137
-
State.plant_resource (T.Article article) forest
131
+
let@ resource = List.iter @~ resources_to_plant in
132
+
State.plant_resource resource forest
138
133
end;
139
134
begin
140
135
(* Now that the articles have been planted, we can export publications. *)
141
136
let@ Range.{value; _} = Eio.Fiber.List.iter ~max_fibers: 20 @~ jobs in
137
+
let@ () = Reporter.easy_run in
142
138
match value with
143
139
| Publish publication ->
144
140
export_publication ~env: forest.env ~forest publication
···
146
142
end
147
143
148
144
let eval (forest : State.t) =
149
-
let host = forest.config.host in
150
145
let result =
151
146
State.get_all_unevaluated forest
152
147
|> Seq.filter Tree.is_expanded
···
161
156
else None
162
157
in
163
158
Eval.eval_tree
164
-
~host
159
+
~config: forest.config
165
160
~source_path
166
161
~uri
167
162
tree.nodes
···
178
173
(* NOTE: Not running jobs. *)
179
174
let Eval.{articles; jobs = _}, diagnostics =
180
175
Eval.eval_tree
181
-
~host: forest.config.host
176
+
~config: forest.config
182
177
~source_path: None
183
178
~uri
184
179
expanded.nodes
···
191
186
192
187
let check_status _uri (forest : State.t) =
193
188
match forest with
194
-
| {dependency_cache = _;
195
-
_;
196
-
} ->
189
+
| {dependency_cache = _; _} ->
197
190
forest, None
198
191
199
-
let implant_foreign
200
-
: State.t -> State.t * _
201
-
= fun state ->
192
+
let implant_foreign (state : State.t) : State.t * _ =
202
193
begin
203
194
let foreign_paths = Eio_util.paths_of_files ~env: state.env state.config.foreign in
204
195
Logs.debug (fun m -> m "implanting %i foreign paths" (List.length foreign_paths));
+28
-36
lib/compiler/State.ml
+28
-36
lib/compiler/State.ml
···
176
176
| _ -> None
177
177
178
178
let get_content_of_transclusion (transclusion : T.transclusion) forest =
179
-
let@ content =
180
-
Option.map @~
181
-
match transclusion.target with
182
-
| Full flags ->
183
-
let@ article = Option.map @~ get_article transclusion.href forest in
184
-
T.Content [T.Section (T.article_to_section article ~flags)]
185
-
| Mainmatter ->
186
-
let@ article = Option.map @~ get_article transclusion.href forest in
187
-
article.mainmatter
188
-
| Title flags ->
189
-
Option.some @@
190
-
begin
191
-
match get_article transclusion.href forest with
192
-
| None -> T.Content [T.Uri transclusion.href]
193
-
| Some article -> get_expanded_title ~flags article.frontmatter forest
194
-
end
195
-
| Taxon ->
196
-
let@ article = Option.map @~ get_article transclusion.href forest in
197
-
let default = T.Content [T.Text section_symbol] in
198
-
Option.value ~default article.frontmatter.taxon
199
-
in
200
-
T.apply_modifier_to_content transclusion.modifier content
179
+
match transclusion.target with
180
+
| Full flags ->
181
+
let@ article = Option.map @~ get_article transclusion.href forest in
182
+
T.Content [T.Section (T.article_to_section article ~flags)]
183
+
| Mainmatter ->
184
+
let@ article = Option.map @~ get_article transclusion.href forest in
185
+
article.mainmatter
186
+
| Title flags ->
187
+
Option.some @@
188
+
begin
189
+
match get_article transclusion.href forest with
190
+
| None -> T.Content [T.Uri transclusion.href]
191
+
| Some article -> get_expanded_title ~flags article.frontmatter forest
192
+
end
193
+
| Taxon ->
194
+
let@ article = Option.map @~ get_article transclusion.href forest in
195
+
let default = T.Content [T.Text section_symbol] in
196
+
Option.value ~default article.frontmatter.taxon
201
197
202
-
let get_title_or_content_of_vertex ?(not_found = fun _ -> None) ~modifier vertex forest =
203
-
let@ content =
204
-
Option.map @~
205
-
match vertex with
206
-
| T.Content_vertex content -> Some content
207
-
| T.Uri_vertex uri ->
208
-
begin
209
-
match get_article uri forest with
210
-
| Some article -> article.frontmatter.title
211
-
| None -> not_found uri
212
-
end
213
-
in
214
-
T.apply_modifier_to_content modifier content
198
+
let get_title_or_content_of_vertex ?(not_found = fun _ -> None) vertex forest =
199
+
match vertex with
200
+
| T.Content_vertex content -> Some content
201
+
| T.Uri_vertex uri ->
202
+
begin
203
+
match get_article uri forest with
204
+
| Some article -> article.frontmatter.title
205
+
| None -> not_found uri
206
+
end
215
207
216
208
let plant_resource resource forest =
217
209
let module Graphs = (val forest.graphs) in
···
264
256
(* let graphs = Forest_graphs.init dl_db in *)
265
257
paths
266
258
|> Seq.iter (fun _path ->
267
-
(* let uri = URI_scheme.path_to_uri ~host: config.host (Eio.Path.native_exn path) in *)
259
+
(* let uri = URI_scheme.path_to_uri ~base: config.url (Eio.Path.native_exn path) in *)
268
260
(* match URI.Tbl.find_opt forest uri with *)
269
261
(* | None -> () *)
270
262
(* | Some tree -> *)
+4
-2
lib/compiler/Xml_forester.ml
+4
-2
lib/compiler/Xml_forester.ml
···
56
56
let backmatter = f_std_tag "backmatter"
57
57
58
58
let taxon attrs = f_std_tag "taxon" attrs
59
-
let addr attrs = f_text_tag "addr" attrs
59
+
let uri attrs = f_text_tag "uri" attrs
60
+
let display_uri attrs = f_text_tag "display-uri" attrs
60
61
let route attrs = f_text_tag "route" attrs
61
62
let source_path attrs = f_text_tag "source-path" attrs
62
63
let href fmt = uri_attr "href" fmt
···
72
73
73
74
let link = f_std_tag "link"
74
75
let type_ fmt = string_attr "type" fmt
75
-
let addr_ fmt = string_attr "addr" fmt
76
+
let uri_ fmt = string_attr "uri" fmt
77
+
let display_uri_ fmt = string_attr "display-uri" fmt
76
78
let text_ fmt = string_attr "text" fmt
77
79
78
80
let number attrs = f_text_tag "number" attrs
+4
-2
lib/compiler/Xml_forester.mli
+4
-2
lib/compiler/Xml_forester.mli
···
34
34
val backmatter : std_tag
35
35
36
36
val taxon : std_tag
37
-
val addr : _ text_tag
37
+
val uri : _ text_tag
38
+
val display_uri : _ text_tag
38
39
val route : _ text_tag
39
40
val source_path : _ text_tag
40
41
val date : std_tag
···
52
53
53
54
val link : std_tag
54
55
val type_ : _ string_attr
55
-
val addr_ : _ string_attr
56
+
val uri_ : _ string_attr
57
+
val display_uri_ : _ string_attr
56
58
val title_ : _ string_attr
57
59
val text_ : _ string_attr
58
60
+1
-1
lib/compiler/test/Test_compiler.ml
+1
-1
lib/compiler/test/Test_compiler.ml
···
101
101
|> Driver.run_until_done Load_all_configured_dirs
102
102
in
103
103
let reparse_addr = "t8.tree" in
104
-
let reparse_uri = URI_scheme.path_to_uri ~host: config.host reparse_addr in
104
+
let reparse_uri = URI_scheme.path_to_uri ~base: config.url reparse_addr in
105
105
let vtx = T.Uri_vertex reparse_uri in
106
106
Alcotest.(check int)
107
107
"Number of vertices before reparsing"
+1
-1
lib/compiler/test/Test_import_graph.ml
+1
-1
lib/compiler/test/Test_import_graph.ml
···
14
14
15
15
let config = {Config.default with trees = ["imports"]}
16
16
17
-
let mk_vertex v = T.Uri_vertex (URI_scheme.user_uri ~host: config.host v)
17
+
let mk_vertex v = T.Uri_vertex (URI_scheme.named_uri ~base:config.url v)
18
18
19
19
let has_edge g v w =
20
20
Forest_graph.mem_edge g (mk_vertex v) (mk_vertex w)
+2
-2
lib/core/Builtin_relation.ml
+2
-2
lib/core/Builtin_relation.ml
···
29
29
open Dx.Notation
30
30
31
31
let reference_taxon : Vertex.t Dx.term =
32
-
Const (Content_vertex (Content [Text "reference"]))
32
+
Const (Content_vertex (Content [Text "Reference"]))
33
33
34
34
let person_taxon : Vertex.t Dx.term =
35
-
Const (Content_vertex (Content [Text "person_taxon"]))
35
+
Const (Content_vertex (Content [Text "Person"]))
36
36
37
37
let axioms : _ Dx.script = [
38
38
is_reference @* [var "X"] << [has_taxon @* [var "X"; reference_taxon]];
+1
-1
lib/core/Code.mli
+1
-1
lib/core/Code.mli
+34
lib/core/Config.ml
+34
lib/core/Config.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
type t = {
8
+
trees: string list;
9
+
assets: string list;
10
+
foreign: string list;
11
+
theme: string;
12
+
url: URI.t;
13
+
home: URI.t option;
14
+
prefixes: string list;
15
+
}
16
+
[@@deriving show, repr]
17
+
18
+
let default : t = {
19
+
trees = ["trees"];
20
+
assets = [];
21
+
foreign = [];
22
+
theme = "theme";
23
+
url = URI.of_string_exn "http://localhost/";
24
+
home = None;
25
+
prefixes = [];
26
+
}
27
+
28
+
(* TODO: validate beforehand *)
29
+
let base_uri {url; _} = url
30
+
31
+
let home_uri config =
32
+
match config.home with
33
+
| Some uri -> uri
34
+
| None -> URI_scheme.named_uri ~base: config.url "index"
+1
lib/core/Forester_core.ml
+1
lib/core/Forester_core.ml
+2
-2
lib/core/Tree.ml
+2
-2
lib/core/Tree.ml
···
60
60
| Expanded _ -> "expanded"
61
61
| Resource _ -> "resource"
62
62
63
-
let get_uri ~host = fun t ->
63
+
(* let get_uri ~host = fun t ->
64
64
let of_lsp_uri doc = Some (URI_scheme.lsp_uri_to_uri ~host (Lsp.Text_document.documentUri doc)) in
65
65
let uri_opt =
66
66
match t with
···
72
72
in
73
73
match uri_opt with
74
74
| Some uri -> uri
75
-
| None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "tried to get URI of an anonymous resource"]
75
+
| None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "tried to get URI of an anonymous resource"] *)
76
76
77
77
(* IDK if subtrees should resolve to their parent document*)
78
78
let to_doc : t -> Lsp.Text_document.t option = function
+2
-35
lib/core/Types.ml
+2
-35
lib/core/Types.ml
···
105
105
| Taxon
106
106
[@@deriving show, repr]
107
107
108
-
type modifier =
109
-
Sentence_case | Identity
110
-
[@@deriving show, repr]
111
-
112
108
type transclusion = {
113
109
href: URI.t;
114
-
target: content_target;
115
-
modifier: modifier
110
+
target: content_target
116
111
}
117
112
[@@deriving show, repr]
118
113
···
203
198
let article_to_section ?(flags = default_section_flags) (article : 'a article) =
204
199
let mainmatter =
205
200
match article.frontmatter.uri with
206
-
| Some href -> Content [Transclude {href; target = Mainmatter; modifier = Identity}]
201
+
| Some href -> Content [Transclude {href; target = Mainmatter}]
207
202
| None -> article.mainmatter
208
203
in
209
204
{
···
231
226
232
227
let compare_article = compare_frontmatter |> Compare.under @@ fun x -> x.frontmatter
233
228
end
234
-
235
-
let compose_modifier mod0 mod1 =
236
-
match mod0, mod1 with
237
-
| Identity, mod1 -> mod1
238
-
| mod0, Identity -> mod0
239
-
| Sentence_case, Sentence_case -> Sentence_case
240
-
241
-
let apply_modifier_to_string = function
242
-
| Sentence_case -> String_util.sentence_case
243
-
| Identity -> Fun.id
244
-
245
-
let rec apply_modifier_to_content_nodes modifier = function
246
-
| [] -> []
247
-
| Text txt1 :: Text txt2 :: content ->
248
-
apply_modifier_to_content_nodes modifier @@ Text (txt1 ^ txt2) :: content
249
-
| node :: content ->
250
-
apply_modifier_to_content_node modifier node :: content
251
-
252
-
and apply_modifier_to_content modifier =
253
-
map_content (apply_modifier_to_content_nodes modifier)
254
-
255
-
and apply_modifier_to_content_node modifier = function
256
-
| Text str -> Text (apply_modifier_to_string modifier str)
257
-
| Transclude transclusion ->
258
-
Transclude {transclusion with modifier = compose_modifier modifier transclusion.modifier}
259
-
| Link link -> Link {link with content = apply_modifier_to_content modifier link.content}
260
-
| Xml_elt elt -> Xml_elt {elt with content = apply_modifier_to_content modifier elt.content}
261
-
| node -> node
262
229
263
230
module TeX_like : sig
264
231
val pp_content : Format.formatter -> content -> unit
+6
-5
lib/core/URI.ml
+6
-5
lib/core/URI.ml
···
67
67
let path = Option.map (String.concat "/") path in
68
68
dehydrate @@ Uri.canonicalize @@ Uri.make ?scheme ?userinfo: user ?host ?port ?path ()
69
69
70
-
let relative_path_string ~(host : string) uri : string =
71
-
if scheme uri = Some "forest" && uri.host = Some host then
72
-
path_string uri
73
-
else
74
-
to_string uri
70
+
let relative_path_string ~(base : t) uri : string =
71
+
Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" @@ to_string uri
72
+
73
+
let display_path_string ~base uri =
74
+
Filename.remove_extension @@
75
+
relative_path_string ~base uri
75
76
end
76
77
77
78
module Set = Set.Make(Basics)
+2
-1
lib/core/URI.mli
+2
-1
lib/core/URI.mli
···
13
13
val with_path_components : string list -> t -> t
14
14
15
15
val canonicalise : t -> t
16
-
val relative_path_string : host: string -> t -> string
16
+
val relative_path_string : base: t -> t -> string
17
+
val display_path_string : base: t -> t -> string
17
18
val resolve : base: t -> t -> t
18
19
val equal : t -> t -> bool
19
20
val compare : t -> t -> int
+10
-32
lib/core/URI_scheme.ml
+10
-32
lib/core/URI_scheme.ml
···
6
6
7
7
open Forester_prelude
8
8
9
-
let scheme = "forest"
10
-
11
-
let base_uri ~host =
12
-
URI.make ~scheme ~host ()
13
-
14
-
let user_uri ~host str =
15
-
URI.make
16
-
~host
17
-
~scheme
18
-
~path: [str]
19
-
()
20
-
21
-
let hash_uri ~host hash_str =
22
-
URI.make
23
-
~host
24
-
~scheme
25
-
~path: ["hash"; hash_str]
26
-
()
27
-
28
-
let is_named_uri uri =
29
-
match URI.scheme uri, URI.path_components uri with
30
-
| sch, "hash" :: _ when sch = Some scheme -> false
31
-
| _ -> true
9
+
let named_uri ~base name =
10
+
URI.resolve ~base @@
11
+
URI.make ~path: [name] ()
32
12
33
13
let last_segment str =
34
14
str
···
39
19
let name (uri : URI.t) : string =
40
20
uri
41
21
|> URI.path_string
42
-
|> last_segment (* this is dodgy!*)
22
+
|> last_segment
23
+
|> Filename.remove_extension (* this is dodgy!*)
43
24
44
25
let split_addr (uri : URI.t) : (string option * int) option =
45
-
let name = last_segment @@ URI.path_string uri in
26
+
let name = name uri in
46
27
(* primitively check for address of form YYYY-MM-DD *)
47
28
let date_regex = Str.regexp {|^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$|} in
48
29
if Str.string_match date_regex name 0 then None
···
61
42
let@ key = Option.map @~ BaseN.Base36.int_of_string name in
62
43
None, key
63
44
64
-
let lsp_uri_to_uri ~(host : string) (uri : Lsp.Uri.t) : URI.t =
45
+
let lsp_uri_to_uri ~(base : URI.t) (uri : Lsp.Uri.t) : URI.t =
65
46
let uri =
66
47
uri
67
48
|> Lsp.Uri.to_path
68
49
|> Filename.chop_extension
69
50
|> last_segment
70
-
|> user_uri ~host
51
+
|> named_uri ~base
71
52
in
72
-
assert (Filename.extension (URI.path_string uri) = "");
73
53
uri
74
54
75
-
let path_to_uri ~host str =
55
+
let path_to_uri ~(base : URI.t) str =
76
56
str
77
57
|> last_segment
78
58
|> Filename.chop_extension
79
-
|> user_uri ~host
80
-
81
-
let source_path_to_addr p = Filename.(chop_extension @@ basename p)
59
+
|> named_uri ~base
+4
-21
lib/core/URI_scheme.mli
+4
-21
lib/core/URI_scheme.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Base
8
-
9
-
(** Forester uses an URI scheme that incorporates a host that demarcates the current forest. A typical tree has have an address like this: [forest://host/xxx-NNNN]. Resources such as PDFs or images will be referred to by their hash.*)
10
-
11
-
val scheme : string
12
-
13
-
val base_uri :
14
-
host: string ->
15
-
URI.t
16
-
17
-
val user_uri :
18
-
host: string ->
19
-
string ->
20
-
URI.t
21
-
22
-
val hash_uri :
23
-
host: string ->
7
+
val named_uri :
8
+
base: URI.t ->
24
9
string ->
25
10
URI.t
26
11
27
-
val is_named_uri : URI.t -> bool
28
-
29
12
val lsp_uri_to_uri :
30
-
host: string ->
13
+
base: URI.t ->
31
14
Lsp.Uri.t ->
32
15
URI.t
33
16
···
36
19
(string option * int) option
37
20
38
21
val path_to_uri :
39
-
host: string ->
22
+
base: URI.t ->
40
23
string ->
41
24
URI.t
42
25
+94
lib/frontend/Atom_client.ml
+94
lib/frontend/Atom_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_core
8
+
open Forester_compiler
9
+
10
+
open struct
11
+
module T = Types
12
+
module P = Pure_html
13
+
end
14
+
15
+
module Atom = struct
16
+
let feed attrs =
17
+
P.std_tag "feed" @@
18
+
P.string_attr "xmlns" "http://www.w3.org/2005/Atom" :: attrs
19
+
20
+
let title fmt = P.text_tag "title" fmt
21
+
let link = P.void_tag "title"
22
+
23
+
let href fmt = P.string_attr "href" fmt
24
+
25
+
let updated fmt = P.text_tag "updated" fmt
26
+
let published fmt = P.text_tag "published" fmt
27
+
let author = P.std_tag "author"
28
+
let contributor = P.std_tag "contributor"
29
+
let name fmt = P.text_tag "name" fmt
30
+
let uri fmt = P.uri_attr "uri" fmt
31
+
let email fmt = P.uri_attr "email" fmt
32
+
let id fmt = P.text_tag "id" fmt
33
+
let entry = P.std_tag "entry"
34
+
let summary = P.std_tag "summary"
35
+
let content = P.std_tag "content"
36
+
let type_ fmt = P.string_attr "type" fmt
37
+
let rel fmt = P.string_attr "rel" fmt
38
+
end
39
+
40
+
open struct module A = Atom end
41
+
42
+
let get_date_range (article : _ T.article) : (Human_datetime.t * Human_datetime.t) option =
43
+
let dates = List.sort Human_datetime.compare article.frontmatter.dates in
44
+
try
45
+
Some (List.hd dates, List.hd (List.rev dates))
46
+
with
47
+
| _ -> None
48
+
49
+
let render_entry (forest : State.t) (article : T.content T.article) : P.node =
50
+
A.entry
51
+
[]
52
+
[
53
+
A.title
54
+
[]
55
+
"%s"
56
+
begin
57
+
match article.frontmatter.title with
58
+
| None -> "Untitled"
59
+
| Some title -> Plain_text_client.string_of_content ~forest ~router: Fun.id title
60
+
end;
61
+
P.HTML.null
62
+
begin
63
+
match get_date_range article with
64
+
| None -> []
65
+
| Some (oldest, newest) ->
66
+
[
67
+
A.published [] "%s" @@ Format.asprintf "%a" Human_datetime.pp oldest;
68
+
A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp newest
69
+
]
70
+
end;
71
+
begin
72
+
match article.frontmatter.uri with
73
+
| None -> P.HTML.null []
74
+
| Some uri ->
75
+
let uri_string = URI.to_string uri in
76
+
P.HTML.null
77
+
[
78
+
A.link
79
+
[
80
+
A.rel "alternate";
81
+
A.type_ "text/html";
82
+
A.href "%s" uri_string
83
+
];
84
+
A.id [] "%s" uri_string
85
+
]
86
+
end;
87
+
A.content
88
+
[
89
+
A.type_ "xhtml"
90
+
]
91
+
[
92
+
Html_client.render_article forest article
93
+
]
94
+
]
+15
-23
lib/frontend/Config_parser.ml
+15
-23
lib/frontend/Config_parser.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
-
open Forester_compiler
10
9
11
10
let parse lexbuf filename =
12
11
match Toml.Parser.parse lexbuf filename with
···
18
17
let open Toml.Lenses in
19
18
let forest = key "forest" |-- table in
20
19
let renderer = key "renderer" |-- table in
21
-
let host =
22
-
match get tbl (forest |-- key "host" |-- string) with
23
-
| Some host -> String.lowercase_ascii host
24
-
| None -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "You need to set the `host' key in your configuration file; this is a global identifier that will be used to distinguish your forest from other forests (you can use your name, e.g. `johnqpublic')"]
25
-
in
26
-
let home = get tbl (renderer |-- key "home" |-- string) in
27
-
let _ =
28
-
match get tbl (forest |-- key "root" |-- string) with
29
-
| None -> ()
30
-
| Some _ ->
31
-
Reporter.emit Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "In your configuration file, change `root' key to `home' in the [forest] group."]
32
-
in
33
-
let _ =
34
-
match get tbl (forest |-- key "stylesheet" |-- string) with
35
-
| None -> ()
36
-
| Some _ ->
37
-
Reporter.emit Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "Custom XSL stylesheet injection is no longer supported; please remove the `stylesheet' key from the [forest] group."]
38
-
in
39
-
let base_url =
40
-
Option.value ~default: Config.default.base_url @@
41
-
get tbl (renderer |-- key "base_url" |-- string)
20
+
let url =
21
+
match get tbl (forest |-- key "url" |-- string) with
22
+
| Some url ->
23
+
begin
24
+
try
25
+
URI.of_string_exn url
26
+
with
27
+
| _ -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "Invalid URL specified in `url` key."]
28
+
end
29
+
| None -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "You need to set the `url' key in your configuration file; this should be a URL like `https://www.my-great-forest.org/` or `http://localhost/`. Even if you do not plan to publish your forest, please choose a URL."]
42
30
in
43
31
let trees =
44
32
Option.value ~default: Config.default.trees @@
···
56
44
Option.value ~default: Config.default.theme @@
57
45
get tbl (renderer |-- key "theme" |-- string)
58
46
in
47
+
let home =
48
+
Option.map (URI_scheme.named_uri ~base: url) @@
49
+
get tbl (renderer |-- key "home" |-- string)
50
+
in
59
51
let prefixes =
60
52
Option.value ~default: Config.default.prefixes @@
61
53
get tbl (forest |-- key "prefixes" |-- array |-- strings)
62
54
in
63
-
Config.{host; base_url; assets; trees; foreign; theme; home; prefixes}
55
+
Config.{url; assets; trees; foreign; theme; home; prefixes}
64
56
65
57
let parse_forest_config_string str =
66
58
let lexbuf = Lexing.from_string str in
+1
-1
lib/frontend/Config_parser.mli
+1
-1
lib/frontend/Config_parser.mli
+1
-2
lib/frontend/DSL.ml
+1
-2
lib/frontend/DSL.ml
+50
-39
lib/frontend/Forester.ml
+50
-39
lib/frontend/Forester.ml
···
8
8
open Forester_core
9
9
open Forester_compiler
10
10
11
-
module M = URI.Map
12
-
module T = Types
13
-
module EP = Eio.Path
11
+
open struct
12
+
module M = URI.Map
13
+
module T = Types
14
+
module EP = Eio.Path
15
+
end
14
16
15
17
type env = Eio_unix.Stdenv.base
16
18
type dir = Eio.Fs.dir_ty EP.t
···
51
53
let config = forest.config in
52
54
let@ article = List.filter_map @~ List.of_seq @@ State.get_all_articles forest in
53
55
let@ uri = Option.bind article.frontmatter.uri in
54
-
let@ uri = Option.bind @@ Option_util.guard URI_scheme.is_named_uri uri in
55
-
let uri = URI.relative_path_string ~host: config.host uri in
56
+
let short_uri = URI.display_path_string ~base: config.url uri in
56
57
let@ title = Option.bind article.frontmatter.title in
57
58
let title =
58
59
Plain_text_client.string_of_content
···
61
62
title
62
63
in
63
64
if String.starts_with ~prefix title then
64
-
Some (uri, title)
65
+
Some (short_uri, title)
65
66
else
66
67
None
67
68
···
86
87
|> (fun t -> `Assoc t)
87
88
|> Yojson.Safe.to_string
88
89
90
+
let html_redirect uri_string =
91
+
Pure_html.to_xml @@
92
+
let open Pure_html in
93
+
let open HTML in
94
+
html
95
+
[]
96
+
[
97
+
head
98
+
[]
99
+
[
100
+
meta
101
+
[
102
+
http_equiv `refresh;
103
+
content "0;url=%s" uri_string
104
+
]
105
+
]
106
+
]
107
+
89
108
let render_forest ~dev ~(forest : State.t) : unit =
90
109
let cwd = Eio.Stdenv.cwd forest.env in
91
110
let all_resources = forest |> State.get_all_resources in
···
97
116
Eio_util.ensure_context_of_path ~perm: 0o755 json_path;
98
117
EP.save ~create: (`Or_truncate 0o644) json_path json_string
99
118
end;
100
-
let module Graphs = (val forest.graphs) in
101
119
let jobs =
102
-
(* TODO: this takes a long time, but it does not seem to be the case that parallising helps at all. *)
103
-
let@ resource = Seq.filter_map @~ all_resources in
104
-
match resource with
105
-
| T.Article article ->
106
-
let@ uri = Option.map @~ article.frontmatter.uri in
107
-
let route = Legacy_xml_client.route forest uri in
108
-
let content = Format.asprintf "%a" Legacy_xml_client.(pp_xml ~forest ~stylesheet: "default.xsl") article in
109
-
route, content
110
-
| T.Asset asset ->
111
-
Option.some @@
112
-
let route = Legacy_xml_client.route forest asset.uri in
113
-
route, asset.content
120
+
let home_route = String.concat "/" @@ URI.path_components forest.config.url @ ["index.html"] in
121
+
let home_content = html_redirect @@ String.concat "/" @@ Legacy_xml_client.local_path_components forest.config (Config.home_uri forest.config) in
122
+
List.cons [home_route, home_content] @@
123
+
let@ resource = Eio.Fiber.List.map ~max_fibers: 40 @~ List.of_seq all_resources in
124
+
let@ () = Reporter.easy_run in
125
+
match resource with
126
+
| T.Article article ->
127
+
begin
128
+
match article.frontmatter.uri with
129
+
| None -> []
130
+
| Some uri ->
131
+
let path_components = Legacy_xml_client.local_path_components forest.config uri in
132
+
let xml_route = String.concat "/" @@ path_components @ ["index.xml"] in
133
+
let html_route = String.concat "/" @@ path_components @ ["index.html"] in
134
+
let xml_content = Format.asprintf "%a" (Legacy_xml_client.pp_xml ~forest ~stylesheet: "default.xsl") article in
135
+
let html_content = html_redirect "index.xml" in
136
+
[xml_route, xml_content; html_route, html_content]
137
+
end
138
+
| T.Asset asset ->
139
+
let route = URI.path_string @@ Legacy_xml_client.route forest asset.uri in
140
+
[route, asset.content]
114
141
in
115
-
Logs.debug (fun m -> m "Writing %i files to output" (Seq.length jobs));
142
+
Logs.debug (fun m -> m "Writing %i files to output" (List.length jobs));
116
143
begin
117
144
(* Note: this part appears to be fast! *)
118
-
let@ (route, content) = Eio.Fiber.List.iter ~max_fibers: 20 @~ (List.of_seq jobs) in
145
+
let@ items = Eio.Fiber.List.iter ~max_fibers: 20 @~ jobs in
146
+
let@ (route : string), content = List.iter @~ items in
119
147
let@ () = Reporter.easy_run in
120
-
let path = EP.(cwd / output_dir_name / URI.path_string route) in
148
+
let path = EP.(cwd / output_dir_name / route) in
121
149
Eio_util.ensure_context_of_path ~perm: 0o755 path;
122
150
EP.save ~create: (`Or_truncate 0o644) path content;
123
151
end
124
-
125
-
let export ~(forest : State.t) : unit =
126
-
Reporter.log Format.pp_print_string "Exporting forest";
127
-
let local_resources =
128
-
let@ resource = Seq.filter @~ State.get_all_resources forest in
129
-
match resource with
130
-
| T.Article {frontmatter = {uri = Some uri; _}; _} ->
131
-
URI.host uri = Some forest.config.host
132
-
| T.Asset asset -> URI.host asset.uri = Some forest.config.host
133
-
| _ -> false
134
-
in
135
-
let cwd = Eio.Stdenv.cwd forest.env in
136
-
let result = Repr.to_json_string ~minify: true (T.forest_t T.content_t) @@ List.of_seq local_resources in
137
-
let dir = Eio.Path.(cwd / "export") in
138
-
let filename = forest.config.host ^ ".json" in
139
-
Eio.Path.mkdirs ~exists_ok: true ~perm: 0o755 dir;
140
-
Eio.Path.save ~create: (`Or_truncate 0o644) Eio.Path.(dir / filename) result
-5
lib/frontend/Forester.mli
-5
lib/frontend/Forester.mli
···
30
30
forest: State.t ->
31
31
string
32
32
33
-
(* val export_publication : *)
34
-
(* env:< cwd : [> Eio.Fs.dir_ty ] Eio.Path.t; .. > -> Forester_compiler.Job.publication -> unit *)
35
-
36
33
val json_manifest :
37
34
dev: bool ->
38
35
forest: State.t ->
···
42
39
forest: State.t ->
43
40
string ->
44
41
(string * string) List.t
45
-
46
-
val export : forest: State.t -> unit
+73
-20
lib/frontend/Html_client.ml
+73
-20
lib/frontend/Html_client.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
(* open Forester_prelude
7
+
open Forester_prelude
8
8
open Forester_core
9
9
open Forester_compiler
10
10
open Forester_xml_names
11
+
open State.Syntax
11
12
12
13
open struct
13
14
module T = Types
···
17
18
18
19
module Xmlns = Xmlns_effect.Make ()
19
20
module Scope = Algaeff.Reader.Make(struct type t = URI.t option end)
21
+
module Section_depth = Algaeff.Reader.Make(struct type t = int end)
20
22
21
-
let route (forest : State.t) uri = failwith ""
23
+
module Loop_detection = Loop_detection_effect.Make ()
22
24
23
-
let uri_to_string ~(config : Config.t) uri =
24
-
match URI.host uri with
25
-
| Some host when URI.scheme uri = Some URI_scheme.scheme ->
26
-
if host = config.host then
27
-
URI.path_string uri
28
-
else
29
-
URI.to_string uri
30
-
| _ -> URI.to_string uri (* used to be not percent-encoded; does it matter? *)
25
+
let hx attrs children = P.std_tag (Format.sprintf "%i" @@ Section_depth.read ()) attrs children
26
+
27
+
let incr_section_depth k =
28
+
let i = Section_depth.read () in
29
+
Section_depth.run ~env: (i + 1) k
30
+
31
+
let route uri = URI.to_string uri
31
32
32
33
let get_expanded_title frontmatter forest =
33
34
let scope = Scope.read () in
34
-
let title = Forest.get_expanded_title ?scope ~flags: T.{empty_when_untitled = true} frontmatter forest in
35
-
T.apply_modifier_to_content Sentence_case title
35
+
Forest.get_expanded_title ?scope ~flags: T.{empty_when_untitled = true} frontmatter forest
36
36
37
37
let render_xml_qname qname =
38
38
let qname = Xmlns.normalise_qname qname in
···
41
41
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
42
42
43
43
let render_xml_attr (forest : State.t) T.{key; value} =
44
-
let str_value = Plain_text_client.string_of_content ~forest: forest.resources ~router: (route forest) value in
44
+
let str_value = Plain_text_client.string_of_content ~forest: forest ~router: Fun.id value in
45
45
P.string_attr (render_xml_qname key) "%s" str_value
46
46
47
47
let render_xmlns_prefix ({prefix; xmlns}: Forester_xml_names.xmlns_attr) =
···
66
66
| CDATA str ->
67
67
[P.txt ~raw: true "<![CDATA[%s]]>" str]
68
68
| Uri uri ->
69
-
[P.txt "%s" (URI.relative_path_string ~host: config.host uri)]
69
+
[P.txt "%s" (URI.to_string uri)]
70
70
| Xml_elt elt ->
71
71
let prefixes_to_add, (name, attrs, content) =
72
72
let@ () = Xmlns.within_scope in
···
80
80
in
81
81
[P.std_tag name attrs content]
82
82
| Route_of_uri uri ->
83
-
[P.txt "%s" (route forest uri)]
84
-
| Contextual_number addr ->
83
+
[P.txt "%s" (route uri)]
84
+
| Contextual_number uri ->
85
85
let custom_number =
86
-
let@ resource = Option.bind @@ Forest.find_opt forest.resources addr in
86
+
let@ resource = Option.bind @@ forest.@{uri} in
87
87
match resource with
88
88
| T.Article article ->
89
89
article.frontmatter.number
···
91
91
in
92
92
begin
93
93
match custom_number with
94
-
| None -> [P.txt "%s" @@ uri_to_string ~config addr]
94
+
| None -> [P.txt "%s" @@ URI.relative_path_string ~base: config.url uri]
95
95
| Some num -> [P.txt "%s" num]
96
96
end
97
-
| _ -> failwith ""
97
+
| KaTeX (_, content) ->
98
+
[P.HTML.code [] @@ render_content forest content]
99
+
| Artefact artefact -> render_content forest @@ artefact.content
100
+
| Section section -> render_section forest section
101
+
| Transclude transclusion -> render_transclusion forest transclusion
102
+
| Link link -> render_link forest link
103
+
| Results_of_datalog_query _ -> [] (* TODO: just make a list of links *)
104
+
| Datalog_script _ -> []
98
105
99
106
and render_link (forest : State.t) (link : T.content T.link) : P.node list = [
100
107
P.HTML.a
···
102
109
P.HTML.href "%s" (Format.asprintf "%a" URI.pp link.href);
103
110
] @@
104
111
render_content forest link.content
105
-
] *)
112
+
]
113
+
114
+
and render_transclusion (forest : State.t) (transclusion : T.transclusion) : P.node list =
115
+
match State.get_content_of_transclusion transclusion forest with
116
+
| None ->
117
+
Reporter.fatal (Resource_not_found transclusion.href)
118
+
| Some content ->
119
+
render_content forest content
120
+
121
+
and render_section forest (section : T.content T.section) : P.node list =
122
+
let@ _ = Xmlns.run ~reserved: [] in
123
+
let@ () = incr_section_depth in
124
+
[
125
+
P.HTML.section
126
+
[]
127
+
[
128
+
begin
129
+
match section.frontmatter.title with
130
+
| None -> P.HTML.null []
131
+
| Some title ->
132
+
P.HTML.header
133
+
[]
134
+
[
135
+
hx [] @@ render_content forest title
136
+
]
137
+
end;
138
+
if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
139
+
P.txt "Transclusion loop detected, rendering stopped."
140
+
else
141
+
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
142
+
P.HTML.null @@ render_content forest section.mainmatter
143
+
]
144
+
]
145
+
146
+
let render_article (forest : State.t) (article : T.content T.article) : P.node =
147
+
let@ () = Loop_detection.run in
148
+
let reserved = [
149
+
{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}
150
+
]
151
+
in
152
+
let@ () = Xmlns.run ~reserved in
153
+
P.HTML.article
154
+
(List.map render_xmlns_prefix reserved)
155
+
[
156
+
let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
157
+
P.HTML.null @@ render_content forest article.mainmatter
158
+
]
+26
-32
lib/frontend/Htmx_client.ml
+26
-32
lib/frontend/Htmx_client.ml
···
20
20
21
21
module Xmlns = Xmlns_effect.Make ()
22
22
23
-
let home_uri ~(config : Config.t) =
24
-
(* let config = State.get_config forest in *)
25
-
let@ root = Option.bind config.home in
26
-
let base = URI_scheme.base_uri ~host: config.host in
27
-
try
28
-
Option.some @@ URI.resolve ~base @@ URI.of_string_exn root
29
-
with
30
-
| _ -> None
31
-
32
-
let uri_is_home ~config uri =
33
-
match home_uri ~config with
34
-
| Some home_uri ->
35
-
(* By this point, any URIs should be in normal form. *)
36
-
URI.equal home_uri uri
37
-
| None -> false
23
+
let local_path_components (uri : URI.t) =
24
+
let host =
25
+
match URI.host uri with
26
+
| Some host -> host
27
+
| None -> assert false (* TODO*)
28
+
in
29
+
host :: URI.path_components uri
38
30
39
31
let route (forest : State.t) uri : URI.t =
40
-
let config = forest.config in
41
-
if Some uri = Option.map (URI_scheme.user_uri ~host: config.host) config.home then
42
-
URI.make ~scheme: "http" ~path: ["index.html"] ()
43
-
else
44
-
uri
32
+
let open State.Syntax in
33
+
match forest.={uri} with
34
+
| None -> uri
35
+
| Some _ ->
36
+
let path = "" :: local_path_components uri in
37
+
URI.make ~path ()
45
38
46
39
let title_flags_to_http_header (flags : T.title_flags) =
47
40
match flags with
···
190
183
[]
191
184
[render_frontmatter forest article.frontmatter] :: render_content forest article.mainmatter;
192
185
];
193
-
match Option.map (uri_is_home ~config: forest.config) article.frontmatter.uri with
194
-
| None ->
195
-
footer [] @@ render_backmatter forest article.backmatter
196
-
| Some false ->
197
-
footer [] @@ render_backmatter forest article.backmatter
198
-
| Some true ->
199
-
null []
186
+
match article.frontmatter.uri with
187
+
| None -> footer [] @@ render_backmatter forest article.backmatter
188
+
| Some uri ->
189
+
if URI.equal (Config.home_uri forest.config) uri then null []
190
+
else footer [] @@ render_backmatter forest article.backmatter
200
191
]
201
192
202
193
and render_section (forest : State.t) (section : T.content T.section) : node =
···
248
239
| T.{vertex; _} ->
249
240
match vertex with
250
241
| T.Uri_vertex href ->
251
-
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}; modifier = Identity}] in
242
+
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in
252
243
null @@ render_link forest T.{href; content}
253
244
| T.Content_vertex content ->
254
245
null @@ render_content forest content
···
277
268
let taxon =
278
269
Option.value ~default: [] @@
279
270
let@ c = Option.map @~ frontmatter.taxon in
280
-
render_content forest (T.apply_modifier_to_content T.Sentence_case c) @ [txt ". "]
271
+
render_content forest c @ [txt ". "]
281
272
in
282
273
let title =
283
274
Option.value ~default: [] @@
284
275
let@ c = Option.map @~ frontmatter.title in
285
-
render_content forest @@ T.apply_modifier_to_content T.Sentence_case c
276
+
render_content forest c
286
277
in
287
278
let uri =
288
279
match frontmatter.uri with
289
280
| None -> null []
290
281
| Some uri ->
291
-
let uri_str = URI.to_string uri in
282
+
let uri_str =
283
+
(* TODO: replace with proper routing from legacy xml client *)
284
+
Format.asprintf "%a" URI.pp uri
285
+
in
292
286
a
293
287
[class_ "slug"; href "%s" uri_str;]
294
288
[txt "[%s]" uri_str]
···
385
379
386
380
and render_transclusion transclusion =
387
381
match transclusion with
388
-
| T.{href; target; modifier = _} ->
382
+
| T.{href; target} ->
389
383
let headers = Yojson.Safe.to_string @@ content_target_to_http_header target in
390
384
[
391
385
span
+1
-1
lib/frontend/Htmx_client.mli
+1
-1
lib/frontend/Htmx_client.mli
+4
-7
lib/frontend/Json_manifest_client.ml
+4
-7
lib/frontend/Json_manifest_client.ml
···
13
13
module PT = Plain_text_client
14
14
15
15
let render_tree ~dev ~(forest : State.t) (doc : T.content T.article) : (string * Yojson.Safe.t) option =
16
-
let host = forest.config.host in
17
16
let@ uri = Option.bind doc.frontmatter.uri in
18
17
(* TODO : Check routing *)
19
18
let route = Legacy_xml_client.route forest uri in
20
19
let title_string =
21
-
String_util.sentence_case @@
22
20
PT.string_of_content ~forest ~router: Fun.id @@
23
-
State.get_expanded_title doc.frontmatter forest
21
+
State.get_expanded_title doc.frontmatter forest
24
22
in
25
23
let title = `String title_string in
26
24
let taxon =
27
25
match doc.frontmatter.taxon with
28
26
| None -> `Null
29
-
| Some vertex ->
30
-
let content = T.apply_modifier_to_content Sentence_case vertex in
27
+
| Some content ->
31
28
`String (PT.string_of_content ~forest ~router: Fun.id content)
32
29
in
33
30
let tags =
34
31
`List
35
32
begin
36
33
let@ tag = List.filter_map @~ doc.frontmatter.tags in
37
-
let@ content = Option.map @~ State.get_title_or_content_of_vertex ~modifier: Identity tag forest in
34
+
let@ content = Option.map @~ State.get_title_or_content_of_vertex tag forest in
38
35
`String (PT.string_of_content ~forest ~router: Fun.id content)
39
36
end
40
37
in
···
63
60
("metas", metas)
64
61
]
65
62
in
66
-
(URI.relative_path_string ~host: host uri, `Assoc fm)
63
+
(URI.display_path_string ~base: forest.config.url uri, `Assoc fm)
67
64
68
65
let render_trees ~(dev : bool) ~(forest : State.t) : Yojson.Safe.t =
69
66
let trees = List.of_seq @@ State.get_all_articles forest in
+1
-1
lib/frontend/Json_manifest_client.mli
+1
-1
lib/frontend/Json_manifest_client.mli
+54
-106
lib/frontend/Legacy_xml_client.ml
+54
-106
lib/frontend/Legacy_xml_client.ml
···
22
22
k X.reserved_xmlnss
23
23
end
24
24
25
-
let uri_to_string ~(config : Config.t) uri =
26
-
match URI.host uri with
27
-
| Some host when URI.scheme uri = Some URI_scheme.scheme ->
28
-
if host = config.host then
29
-
URI.path_string uri
30
-
else
31
-
URI.to_string uri
32
-
| _ -> URI.to_string uri (* used to be not percent-encoded; does it matter? *)
33
-
34
-
let home_uri ~(config : Config.t) =
35
-
let@ root = Option.bind config.home in
36
-
let base = URI_scheme.base_uri ~host: config.host in
37
-
try
38
-
Option.some @@ URI.resolve ~base @@ URI.of_string_exn root
39
-
with
40
-
| _ -> None
41
-
42
-
let uri_is_home ~config uri =
43
-
match home_uri ~config with
44
-
| Some home_uri ->
45
-
(* By this point, any URIs should be in normal form. *)
46
-
URI.equal home_uri uri
47
-
| None -> false
48
-
49
-
let rec map_last f xs =
50
-
match xs with
51
-
| [] -> []
52
-
| [x] -> [f x]
53
-
| x :: xs -> x :: map_last f xs
25
+
let local_path_components (config : Config.t) (uri : URI.t) =
26
+
let host = Option.get @@ URI.host uri in
27
+
let base_host = Option.get @@ URI.host config.url in
28
+
if host = base_host then
29
+
URI.path_components uri
30
+
else
31
+
"foreign" :: host :: URI.path_components uri
54
32
55
-
let route_resource_uri ~suffix (forest : State.t) uri =
56
-
let config = forest.config in
57
-
let host = Option.value ~default: "" @@ URI.host uri in
58
-
let components =
59
-
map_last (fun x -> x ^ suffix) @@
60
-
if uri_is_home ~config uri then ["index"]
61
-
else URI.path_components uri
62
-
in
63
-
let prefix_components =
64
-
if host = config.host then []
65
-
else ["foreign"; host]
66
-
in
67
-
prefix_components @ components
33
+
let local_base_url_string (config : Config.t) =
34
+
let path = "" :: URI.path_components config.url @ [""] in
35
+
String.concat "/" path
68
36
69
37
let route (forest : State.t) uri : URI.t =
70
-
let uri' =
71
-
match State.find_opt forest uri with
72
-
| Some (Resource resource) ->
73
-
let suffix =
74
-
match resource.tree with
75
-
| T.Article _ -> ".xml"
76
-
| T.Asset _ -> ""
77
-
in
78
-
let path = route_resource_uri ~suffix forest uri in
79
-
URI.make ~path ()
80
-
| Some _ -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a has not been evaluated yet" URI.pp uri]
81
-
| None when URI.scheme uri = Some URI_scheme.scheme ->
82
-
Reporter.emit (Broken_link uri) ~extra_remarks: [Asai.Diagnostic.loctextf "Could not route link to resource %a" URI.pp uri];
83
-
uri
84
-
| None -> uri
85
-
in
86
-
URI.resolve ~base: (URI.of_string_exn forest.config.base_url) uri'
38
+
match forest.={uri} with
39
+
| None -> uri
40
+
| Some _ ->
41
+
let path = "" :: local_path_components forest.config uri in
42
+
URI.make ~path ()
87
43
88
44
module Scope = Algaeff.Reader.Make(struct type t = URI.t option end)
89
-
module Loop_detection = Algaeff.Reader.Make(struct type t = URI.Set.t end)
45
+
module Loop_detection = Loop_detection_effect.Make ()
90
46
91
47
(* It's fine to have a global transclusion cache since URIs fully qualify a tree*)
92
48
let transclusion_cache = Hashtbl.create 1000
···
127
83
X.optional_ X.toc dict.included_in_toc;
128
84
X.optional_ X.numbered dict.numbered
129
85
]
130
-
131
-
let add_seen_uri uri kont =
132
-
let@ () = Loop_detection.scope @@ URI.Set.add uri in
133
-
kont ()
134
-
135
-
let add_seen_uri_opt uri_opt kont =
136
-
match uri_opt with
137
-
| None -> kont ()
138
-
| Some uri -> add_seen_uri uri kont
139
-
140
-
let have_seen_uri uri =
141
-
URI.Set.mem uri @@ Loop_detection.read ()
142
-
143
-
let have_seen_uri_opt uri_opt =
144
-
match uri_opt with
145
-
| None -> false
146
-
| Some uri -> have_seen_uri uri
147
-
148
86
let rec render_section forest (section : T.content T.section) : P.node =
149
87
let@ _ = Xmlns.run in
150
88
X.tree
···
153
91
render_frontmatter forest section.frontmatter;
154
92
let@ () = Scope.run ~env: section.frontmatter.uri in
155
93
X.mainmatter [] @@
156
-
if have_seen_uri_opt section.frontmatter.uri then
94
+
if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
157
95
[X.info [] [P.txt "Transclusion loop detected, rendering stopped."]]
158
96
else
159
-
let@ () = add_seen_uri_opt section.frontmatter.uri in
97
+
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
160
98
render_content forest section.mainmatter
161
99
]
162
100
163
101
and render_frontmatter (forest : State.t) (frontmatter : T.content T.frontmatter) : P.node =
164
-
let config = forest.config in
165
102
let result =
166
103
X.frontmatter
167
104
[]
···
169
106
render_attributions forest frontmatter.uri frontmatter.attributions;
170
107
render_dates forest frontmatter.dates;
171
108
X.conditional forest.dev (X.optional (X.source_path [] "%s") frontmatter.source_path);
172
-
X.optional (fun uri -> X.addr [] "%s" @@ uri_to_string ~config uri) frontmatter.uri;
109
+
X.optional (fun uri -> X.uri [] "%s" @@ URI.to_string uri) frontmatter.uri;
110
+
X.optional (fun uri -> X.display_uri [] "%s" @@ URI.display_path_string ~base: forest.config.url uri) frontmatter.uri;
173
111
X.optional (X.route [] "%s") @@ Option.map (Fun.compose URI.to_string (route forest)) frontmatter.uri;
174
112
begin
175
-
let title = State.get_expanded_title frontmatter forest in
176
-
X.title [X.text_ "%s" @@ Plain_text_client.string_of_content ~forest ~router: (route forest) title] @@
177
-
render_content forest title
113
+
match frontmatter.title with
114
+
| None -> X.null []
115
+
| Some _ ->
116
+
let title = State.get_expanded_title ?scope: (Scope.read ()) frontmatter forest in
117
+
X.title [X.text_ "%s" @@ Plain_text_client.string_of_content ~forest ~router: (route forest) title] @@
118
+
render_content forest title
178
119
end;
179
120
begin
180
121
match frontmatter.taxon with
181
122
| None -> X.null []
182
123
| Some taxon ->
183
-
X.taxon [] @@ render_content forest (T.apply_modifier_to_content T.Sentence_case taxon)
124
+
X.taxon [] @@ render_content forest taxon
184
125
end;
185
126
X.null @@ List.map (render_meta forest) frontmatter.metas
186
127
]
···
202
143
| [] -> []
203
144
204
145
and render_content_node (forest : State.t) (node : 'a T.content_node) : P.node list =
205
-
let config = forest.config in
206
146
match node with
207
147
| Text str ->
208
148
[P.txt "%s" str]
209
149
| CDATA str ->
210
150
[P.txt ~raw: true "<![CDATA[%s]]>" str]
211
151
| Uri uri ->
212
-
[P.txt "%s" (URI.relative_path_string ~host: config.host uri)]
152
+
[P.txt "%s" (URI.display_path_string ~base: forest.config.url uri)]
213
153
| Route_of_uri uri ->
214
154
[P.txt "%s" (URI.to_string (route forest uri))]
215
155
| Xml_elt elt ->
···
226
166
[P.std_tag name attrs content]
227
167
| Transclude transclusion ->
228
168
render_transclusion forest transclusion
229
-
| Contextual_number addr ->
169
+
| Contextual_number uri ->
230
170
let custom_number =
231
-
(* let@ resource = Option.bind @@ State.find_opt forest addr in *)
232
-
let@ resource = Option.bind @@ forest.@{addr} in
171
+
let@ resource = Option.bind @@ forest.@{uri} in
233
172
match resource with
234
173
| T.Article article ->
235
174
article.frontmatter.number
···
237
176
in
238
177
begin
239
178
match custom_number with
240
-
| None -> [X.contextual_number [X.addr_ "%s" @@ uri_to_string ~config addr]]
179
+
| None ->
180
+
[
181
+
X.contextual_number
182
+
[
183
+
X.uri_ "%s" @@ URI.to_string uri;
184
+
X.display_uri_ "%s" @@ URI.display_path_string ~base: forest.config.url uri
185
+
]
186
+
]
241
187
| Some num -> [P.txt "%s" num]
242
188
end
243
189
| Link link ->
···
296
242
nodes
297
243
298
244
and render_link (forest : State.t) (link : T.content T.link) : P.node list =
299
-
let config = forest.config in
300
-
let article_opt = Option.bind forest.={link.href} Tree.to_article in
245
+
let article_opt = State.get_article link.href forest in
301
246
let attrs =
302
247
match article_opt with
303
248
| None ->
···
309
254
[
310
255
X.optional_ (X.href "%s") @@ Option.map (Fun.compose URI.to_string @@ route forest) article.frontmatter.uri;
311
256
X.title_ "%s" @@
312
-
Plain_text_client.string_of_content ~forest ~router: (route forest) @@
313
-
State.get_expanded_title article.frontmatter forest;
314
-
X.optional_ (X.addr_ "%s") @@ Option.map (uri_to_string ~config) article.frontmatter.uri;
257
+
Plain_text_client.string_of_content ~forest: forest ~router: (route forest) @@
258
+
State.get_expanded_title ?scope: (Scope.read ()) article.frontmatter forest;
259
+
X.optional_ (X.uri_ "%s") @@ Option.map URI.to_string article.frontmatter.uri;
260
+
X.optional_ (X.display_uri_ "%s") @@ Option.map (URI.display_path_string ~base: forest.config.url) article.frontmatter.uri;
315
261
X.type_ "local"
316
262
]
317
263
in
···
356
302
and render_attribution_vertex (forest : State.t) vtx =
357
303
match vtx with
358
304
| T.Uri_vertex href ->
359
-
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}; modifier = Identity}] in
305
+
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in
360
306
render_link forest T.{href; content}
361
307
| T.Content_vertex content ->
362
308
render_content forest content
···
368
314
let config = forest.config in
369
315
let href_attr =
370
316
let str = Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date) in
371
-
let base = URI_scheme.base_uri ~host: config.host in
372
-
let uri = URI.resolve ~base (URI.of_string_exn str) in
317
+
let uri = URI_scheme.named_uri ~base: config.url str in
373
318
match State.get_article uri forest with
374
319
| None -> X.null_
375
320
| Some _ -> X.href "%s" @@ URI.to_string @@ route forest uri
···
385
330
let render_article (forest : State.t) (article : T.content T.article) : P.node =
386
331
let@ () = Reporter.tracef "when rendering article %a" Format.(pp_print_option URI.pp) article.frontmatter.uri in
387
332
let config = forest.config in
388
-
let@ () = Loop_detection.run ~env: URI.Set.empty in
333
+
let@ () = Loop_detection.run in
389
334
let@ () = Scope.run ~env: article.frontmatter.uri in
390
335
let@ xmlnss = Xmlns.run in
391
336
X.tree
392
337
begin
393
338
List.map render_xmlns_prefix xmlnss @
394
339
[
395
-
X.optional_ X.root @@ Option.map (uri_is_home ~config) article.frontmatter.uri;
396
-
P.string_attr "base-url" "%s" config.base_url
340
+
X.optional_ X.root @@
341
+
begin
342
+
let@ uri = Option.map @~ article.frontmatter.uri in
343
+
URI.equal (Config.home_uri config) uri
344
+
end;
345
+
P.string_attr "base-url" "%s" (local_base_url_string config)
397
346
]
398
347
end
399
348
[
400
349
render_frontmatter forest article.frontmatter;
401
350
X.mainmatter [] @@
402
351
begin
403
-
let@ () = add_seen_uri_opt article.frontmatter.uri in
352
+
let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
404
353
render_content forest article.mainmatter
405
354
end;
406
355
X.backmatter [] @@ render_content forest article.backmatter
···
411
360
Format.pp_print_newline fmt ();
412
361
begin
413
362
let@ xsl_path = Option.iter @~ stylesheet in
414
-
let base_url = forest.config.base_url in
415
-
Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s%s\"?>" base_url xsl_path
363
+
Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s%s\"?>" (local_base_url_string forest.config) xsl_path
416
364
end;
417
365
Format.pp_print_newline fmt ();
418
366
P.pp_xml fmt @@ render_article forest article
+2
lib/frontend/Legacy_xml_client.mli
+2
lib/frontend/Legacy_xml_client.mli
···
10
10
module T := Types
11
11
module P := Pure_html
12
12
13
+
val local_path_components : Config.t -> URI.t -> string list
13
14
val route : State.t -> URI.t -> URI.t
15
+
14
16
val render_article : State.t -> T.content T.article -> P.node
15
17
val render_content : State.t -> T.content -> P.node list
16
18
val pp_xml : forest: State.t -> ?stylesheet: string -> Format.formatter -> T.content T.article -> unit
+28
lib/frontend/Loop_detection_effect.ml
+28
lib/frontend/Loop_detection_effect.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_core
8
+
9
+
module Make () = struct
10
+
open Algaeff.Reader.Make(struct type t = URI.Set.t end)
11
+
let add_seen_uri uri =
12
+
scope @@ URI.Set.add uri
13
+
14
+
let add_seen_uri_opt uri_opt kont =
15
+
match uri_opt with
16
+
| None -> kont ()
17
+
| Some uri -> add_seen_uri uri kont
18
+
19
+
let have_seen_uri uri =
20
+
URI.Set.mem uri @@ read ()
21
+
22
+
let have_seen_uri_opt uri_opt =
23
+
match uri_opt with
24
+
| None -> false
25
+
| Some uri -> have_seen_uri uri
26
+
27
+
let run k = run ~env: URI.Set.empty k
28
+
end
+1
-1
lib/frontend/test/Test_DSL.ml
+1
-1
lib/frontend/test/Test_DSL.ml
···
91
91
T.prim `Figcaption @@ T.Content [Text "caption"];
92
92
CDATA "cdata";
93
93
Xml_elt {name = {prefix = ""; uname = "html"; xmlns = None}; attrs = []; content = (Content [])};
94
-
Transclude {href = URI.of_string_exn "foo-001"; target = Mainmatter; modifier = Identity};
94
+
Transclude {href = URI.of_string_exn "foo-001"; target = Mainmatter};
95
95
Contextual_number (URI.of_string_exn "chapter-3");
96
96
KaTeX (Inline, Content [Text "a = b"]);
97
97
Link {href = URI.of_string_exn "https://git.sr.ht/~jonsterling/ocaml-forester"; content = Content [Text "Forester"]};
+10
-26
lib/frontend/test/Test_config.ml
+10
-26
lib/frontend/test/Test_config.ml
···
6
6
7
7
open Forester_test
8
8
open Testables
9
-
open Forester_compiler
9
+
open Forester_core
10
10
open Forester_frontend
11
11
12
12
let extra_remarks_to_strings remarks =
···
16
16
Alcotest.(check config)
17
17
"is the same"
18
18
Config.{
19
-
host = "test";
20
19
trees = ["trees"];
21
-
home = Some "index";
22
20
prefixes = ["foo"; "bar"; "baz"];
23
21
assets = [];
24
-
base_url = "http://www.forester-notes.org/";
22
+
url = URI.of_string_exn "https://www.forester-notes.org/";
23
+
home = None;
25
24
foreign = ["foreign/forest.json"];
26
25
theme = "theme";
27
26
}
···
30
29
Config_parser.parse_forest_config_string
31
30
{|
32
31
[forest]
33
-
host = "test"
34
32
trees = ["trees"]
35
33
prefixes = ["foo", "bar", "baz"]
36
34
foreign = ["foreign/forest.json"]
37
-
38
-
[renderer]
35
+
url = "https://www.forester-notes.org/"
39
36
home = "index"
40
-
base_url = "http://www.forester-notes.org/"
41
37
|}
42
38
end
43
39
···
45
41
Alcotest.(check config)
46
42
"is the same"
47
43
Config.{
48
-
host = "test";
49
44
trees = ["trees"];
50
-
home = Some "index";
51
45
theme = "theme";
52
46
assets = [];
53
47
foreign = [];
54
-
base_url = "/";
48
+
url = URI.of_string_exn "/";
49
+
home = None;
55
50
prefixes = [];
56
51
}
57
52
(
···
59
54
Config_parser.parse_forest_config_string
60
55
{|
61
56
[forest]
62
-
host = "test"
63
57
trees = ["trees"]
64
-
[renderer]
65
-
home = "index"
66
58
|}
67
59
)
68
60
···
89
81
{|
90
82
[forest]
91
83
trees = ["trees"]
92
-
[renderer]
93
-
home = "index"
94
84
|}
95
85
in
96
86
assert false
···
125
115
Alcotest.(check config)
126
116
"is the same"
127
117
Config.{
128
-
host = "test";
129
118
trees = ["trees"];
130
-
home = Some "index";
131
119
theme = "theme";
132
-
base_url = "/";
120
+
url = URI.of_string_exn "/";
121
+
home = None;
133
122
assets = [];
134
123
foreign = [];
135
124
prefixes = [];
···
148
137
Forester_core.Reporter.run ~fatal ~emit @@ fun () ->
149
138
Config_parser.parse_forest_config_string
150
139
{|[forest]
151
-
host = "test"
152
140
trees = ["trees"]
153
141
stylesheet = "custom.xsl"
154
-
[renderer]
155
-
home = "index"
156
142
|}
157
143
end
158
144
···
160
146
Alcotest.(check config)
161
147
"is the same"
162
148
Config.{
163
-
host = "test";
164
149
trees = ["trees"];
150
+
theme = "theme";
151
+
url = URI.of_string_exn "/";
165
152
home = None;
166
-
theme = "theme";
167
-
base_url = "/";
168
153
assets = [];
169
154
foreign = [];
170
155
prefixes = [];
···
182
167
Forester_core.Reporter.run ~fatal ~emit @@ fun () ->
183
168
Config_parser.parse_forest_config_string
184
169
{|[forest]
185
-
host = "test"
186
170
trees = ["trees"]
187
171
root = "index"
188
172
|}
+22
-33
lib/frontend/test/Test_transclusion.ml
+22
-33
lib/frontend/test/Test_transclusion.ml
···
14
14
module T = Types
15
15
module HTML = Pure_html.HTML
16
16
17
-
let config = {Config.default with trees = ["transclude"]; host = "test"}
18
-
let host = config.host
17
+
let config = {Config.default with trees = ["transclude"]}
19
18
20
-
let href = URI_scheme.user_uri ~host "transcludee"
19
+
let href = URI_scheme.named_uri ~base:config.url "transcludee"
21
20
22
21
module Transclusions = struct
23
22
(* It would be cool to use quickcheck here, but no good way to test the result*)
24
23
open T
25
24
let full_default = {
26
25
href;
27
-
target = Full default_section_flags;
28
-
modifier = Identity
26
+
target = Full default_section_flags
29
27
}
30
28
31
29
let metadata_shown = {default_section_flags with
···
38
36
let@ env = Eio_main.run in
39
37
Logs.set_level (Some Debug);
40
38
let@ () = Reporter.easy_run in
41
-
let uri = URI_scheme.user_uri ~host "transcludee" in
39
+
let uri = URI_scheme.named_uri ~base:config.url "transcludee" in
42
40
let index = URI.Tbl.create 10 in
43
-
URI.Tbl.add
44
-
index
45
-
uri
46
-
(
47
-
Tree.Resource
48
-
(
41
+
URI.Tbl.add index uri @@
42
+
Tree.Resource
43
+
{
44
+
tree =
45
+
T.Article
49
46
{
50
-
tree = T.(
51
-
Article
52
-
{
53
-
frontmatter =
54
-
default_frontmatter
55
-
~uri: (URI.of_string_exn "forest://test/transcludee")
56
-
~title: (Content [Text "I am being transcluded"])
57
-
();
58
-
mainmatter = Content [Text "Hello"];
59
-
backmatter = Content []
60
-
}
61
-
);
62
-
expanded = None
63
-
}
64
-
)
65
-
);
47
+
frontmatter =
48
+
T.default_frontmatter
49
+
~uri: (URI.of_string_exn "forest://test/transcludee")
50
+
~title: (T.Content [Text "I am being transcluded"])
51
+
();
52
+
mainmatter = Content [Text "Hello"];
53
+
backmatter = Content []
54
+
};
55
+
expanded = None
56
+
};
66
57
let forest = {(State.make ~env ~config ~dev: false ()) with index} in
67
58
let print_transclusion : T.transclusion -> unit = fun t ->
68
59
let content = Option.get @@ State.get_content_of_transclusion t forest in
69
60
Format.printf
70
61
"%a"
71
-
Legacy_xml_client.(pp_xml ~forest ?stylesheet: None)
62
+
(Legacy_xml_client.pp_xml ~forest ?stylesheet:None)
72
63
(
73
64
T.{
74
65
frontmatter = default_frontmatter ~uri: href ();
···
85
76
print_transclusion
86
77
{
87
78
href = uri;
88
-
target = Title {empty_when_untitled = false};
89
-
modifier = Identity
79
+
target = Title {empty_when_untitled = false}
90
80
}
91
81
in
92
82
let test_full_metadata () =
93
83
print_transclusion
94
84
{
95
85
href = uri;
96
-
target = Full Transclusions.metadata_shown;
97
-
modifier = Identity
86
+
target = Full Transclusions.metadata_shown
98
87
}
99
88
in
100
89
List.iter
+3
-3
lib/language_server/Call_hierarchy.ml
+3
-3
lib/language_server/Call_hierarchy.ml
···
28
28
in
29
29
match item with
30
30
| {uri; _} ->
31
-
let uri = URI_scheme.path_to_uri ~host: config.host (Lsp.Uri.to_path uri) in
31
+
let uri = URI_scheme.path_to_uri ~base: config.url (Lsp.Uri.to_path uri) in
32
32
let vertex = T.Uri_vertex uri in
33
33
let run_query = Forest.run_datalog_query forest.graphs in
34
34
let fwdlinks = run_query @@ Builtin_queries.fwdlinks_datalog vertex in
···
54
54
in
55
55
match item with
56
56
| {uri; _} ->
57
-
let uri = URI_scheme.path_to_uri ~host: config.host (Lsp.Uri.to_path uri) in
57
+
let uri = URI_scheme.path_to_uri ~base: config.url (Lsp.Uri.to_path uri) in
58
58
let vertex = T.Uri_vertex uri in
59
59
let run_query = Forest.run_datalog_query forest.graphs in
60
60
let backlinks = run_query @@ Builtin_queries.backlinks_datalog vertex in
···
68
68
let Lsp_state.{forest; _} = Lsp_state.get () in
69
69
match params with
70
70
| {position; textDocument; _} ->
71
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host textDocument.uri in
71
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
72
72
match Imports.resolve_uri_to_code forest uri with
73
73
| None -> None
74
74
| Some tree ->
+2
-3
lib/language_server/Definitions.ml
+2
-3
lib/language_server/Definitions.ml
···
17
17
match params with
18
18
| {textDocument; position; _;} ->
19
19
let Lsp_state.{forest; _} = Lsp_state.get () in
20
-
let host = forest.config.host in
21
-
let uri = URI_scheme.lsp_uri_to_uri ~host textDocument.uri in
20
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
22
21
match forest.={uri} with
23
22
| None -> None
24
23
| Some tree ->
···
28
27
match Analysis.addr_at ~position nodes with
29
28
| None -> None
30
29
| Some {value = str; _} ->
31
-
let uri = URI_scheme.user_uri ~host str in
30
+
let uri = URI_scheme.named_uri ~base: forest.config.url str in
32
31
match URI.Tbl.find_opt forest.resolver uri with
33
32
| None -> None
34
33
| Some path ->
+1
-1
lib/language_server/Diagnostics.ml
+1
-1
lib/language_server/Diagnostics.ml
···
18
18
let compute (document : Lsp.Text_document.t) =
19
19
let Lsp_state.{forest; _} = Lsp_state.get () in
20
20
let lsp_uri = Lsp.Text_document.documentUri document in
21
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host lsp_uri in
21
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
22
22
match forest.?{uri} with
23
23
| [] ->
24
24
Eio.traceln "Clearing diagnostics for %s" (Lsp.Uri.to_path lsp_uri);
+1
-1
lib/language_server/Did_change.ml
+1
-1
lib/language_server/Did_change.ml
···
15
15
let Lsp_state.{forest; _} = Lsp_state.get () in
16
16
match params with
17
17
| {textDocument = {uri = lsp_uri; _}; contentChanges} ->
18
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host lsp_uri in
18
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
19
19
match forest.={uri} with
20
20
| None -> ()
21
21
| Some tree ->
+1
-2
lib/language_server/Did_create_files.ml
+1
-2
lib/language_server/Did_create_files.ml
···
15
15
let compute ({files}: L.CreateFilesParams.t) =
16
16
Eio.traceln "recieved DidCreateFiles notification";
17
17
Lsp_state.modify (fun ({forest; _} as lsp_state) ->
18
-
let host = forest.config.host in
19
18
let env = forest.env in
20
19
Eio.traceln "client created %d files" (List.length files);
21
20
begin
22
21
let@ {uri} = List.iter @~ files in
23
22
let lsp_uri = L.DocumentUri.of_string uri in
24
-
let uri = URI_scheme.lsp_uri_to_uri ~host lsp_uri in
23
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
25
24
let path = Eio.Path.(env#fs / (L.DocumentUri.to_path lsp_uri)) in
26
25
let doc = Imports.load_tree path in
27
26
forest.={uri} <- Document doc
+1
-1
lib/language_server/Did_open.ml
+1
-1
lib/language_server/Did_open.ml
···
19
19
~position_encoding: `UTF16
20
20
params
21
21
in
22
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host lsp_uri in
22
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
23
23
forest.={uri} <- Document document;
24
24
Lsp_state.modify (fun ({forest; _} as lsp_state) ->
25
25
let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in
+2
-2
lib/language_server/Document_link.ml
+2
-2
lib/language_server/Document_link.ml
···
27
27
| {textDocument; _} ->
28
28
let Lsp_state.{forest; _} = Lsp_state.get () in
29
29
let links =
30
-
let uri = URI_scheme.lsp_uri_to_uri ~host: config.host textDocument.uri in
30
+
let uri = URI_scheme.lsp_uri_to_uri ~base: config.url textDocument.uri in
31
31
(* match Imports.resolve_uri_to_code forest uri with *)
32
32
match Option.bind forest.={uri} Tree.to_code with
33
33
| None -> []
···
42
42
| Code.Group (Braces, [{value = Text addr; _}]) ->
43
43
(* TODO: Need to analyse syn *)
44
44
let range = (Lsp_shims.Loc.lsp_range_of_range node.loc) in
45
-
let uri = (URI_scheme.user_uri ~host: config.host addr) in
45
+
let uri = (URI_scheme.named_uri ~base: config.url addr) in
46
46
let* target = Option.map Lsp.Uri.of_path @@ URI.Tbl.find_opt forest.resolver uri in
47
47
let* {frontmatter; _} = State.get_article uri forest in
48
48
let* tooltip = Option.map (fun c -> render c) frontmatter.title in
+2
-2
lib/language_server/Document_symbols.ml
+2
-2
lib/language_server/Document_symbols.ml
···
20
20
let Lsp_state.{forest; _} = Lsp_state.get () in
21
21
match State.get_code
22
22
forest
23
-
(URI_scheme.lsp_uri_to_uri ~host: forest.config.host uri) with
23
+
(URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri) with
24
24
| None ->
25
25
URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index;
26
26
Logs.debug (fun m -> m "%s" (Lsp.Uri.to_string uri));
27
-
Logs.debug (fun m -> m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~host: forest.config.host uri));
27
+
Logs.debug (fun m -> m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri));
28
28
assert false
29
29
| Some {nodes; _} ->
30
30
let symbols =
+1
lib/language_server/Forester_lsp.ml
+1
lib/language_server/Forester_lsp.ml
+1
-1
lib/language_server/Forester_lsp.mli
+1
-1
lib/language_server/Forester_lsp.mli
+1
-1
lib/language_server/Highlight.ml
+1
-1
lib/language_server/Highlight.ml
···
17
17
let Lsp_state.{forest; _} = Lsp_state.get () in
18
18
match State.get_code
19
19
forest
20
-
(URI_scheme.lsp_uri_to_uri ~host: forest.config.host textDocument.uri) with
20
+
(URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri) with
21
21
| None -> None
22
22
| Some tree ->
23
23
let highlights =
+2
-4
lib/language_server/Hover.ml
+2
-4
lib/language_server/Hover.ml
···
23
23
~forest
24
24
~router: (Legacy_xml_client.route forest)
25
25
in
26
-
let config = forest.config in
27
-
let host = config.host in
28
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host textDocument.uri in
26
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
29
27
let* content =
30
28
match forest.={uri} with
31
29
| None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a is not in the index" URI.pp uri]
···
38
36
| Some node ->
39
37
let tree_under_cursor =
40
38
let* {value = addr; _} = Analysis.extract_addr node in
41
-
let uri_under_cursor = URI_scheme.user_uri ~host addr in
39
+
let uri_under_cursor = URI_scheme.named_uri ~base:forest.config.url addr in
42
40
State.get_article uri_under_cursor forest
43
41
in
44
42
match tree_under_cursor with
+2
-3
lib/language_server/Inlay_hint.ml
+2
-3
lib/language_server/Inlay_hint.ml
···
21
21
} ->
22
22
let Lsp_state.{forest; _} = Lsp_state.get () in
23
23
let config = forest.config in
24
-
let host = config.host in
25
-
let uri = URI_scheme.lsp_uri_to_uri ~host textDocument.uri in
24
+
let uri = URI_scheme.lsp_uri_to_uri ~base: config.url textDocument.uri in
26
25
(* match Forest.find_opt forest.parsed with *)
27
26
match Option.bind forest.={uri} Tree.to_code with
28
27
| None ->
···
41
40
match Analysis.extract_addr node with
42
41
| None -> None
43
42
| Some {value = str; _} ->
44
-
let uri = URI_scheme.user_uri ~host str in
43
+
let uri = URI_scheme.named_uri ~base: config.url str in
45
44
match State.get_article uri forest with
46
45
| None ->
47
46
None
+1
-1
lib/language_server/Publish.ml
+1
-1
lib/language_server/Publish.ml
···
34
34
let code = `String (Reporter.Message.short_code diag.message) in
35
35
let source =
36
36
let Lsp_state.{forest; _} = Lsp_state.get () in
37
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host uri in
37
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in
38
38
match Option.bind (State.find_opt forest uri) Tree.to_doc with
39
39
| None -> None
40
40
| Some doc ->
+2
-2
lib/language_server/Semantic_tokens.ml
+2
-2
lib/language_server/Semantic_tokens.ml
···
301
301
L.SemanticTokens.t option
302
302
= fun {uri} ->
303
303
let Lsp_state.{forest; _} = Lsp_state.get () in
304
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host uri in
304
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in
305
305
match Imports.resolve_uri_to_code forest uri with
306
306
| Some Tree.{nodes; _} ->
307
307
let tokens = tokens nodes in
···
327
327
textDocument
328
328
->
329
329
let Lsp_state.{forest; _} = Lsp_state.get () in
330
-
let uri = URI_scheme.lsp_uri_to_uri ~host: forest.config.host textDocument.uri in
330
+
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
331
331
match Imports.resolve_uri_to_code forest uri with
332
332
| None -> None
333
333
| Some tree ->
+4
-4
lib/language_server/test/Test_lsp.ml
+4
-4
lib/language_server/test/Test_lsp.ml
···
20
20
21
21
type test_env = {
22
22
dirs: Eio.Fs.dir_ty Eio.Path.t list;
23
-
config: Forester_compiler.Config.t;
23
+
config: Config.t;
24
24
position: L.Position.t;
25
25
}
26
26
···
28
28
let path =
29
29
Eio.Path.native_exn @@
30
30
Option.get @@
31
-
Dir_scanner.find_tree env.dirs (URI_scheme.user_uri ~host: env.config.host addr)
31
+
Dir_scanner.find_tree env.dirs (URI_scheme.named_uri ~base: env.config.url addr)
32
32
in
33
33
({uri = Lsp.Uri.of_path path}: L.TextDocumentIdentifier.t)
34
34
···
37
37
let find_tree addr =
38
38
let env = Test_env.get () in
39
39
let dirs = env.dirs in
40
-
let host = env.config.host in
41
-
Eio.Path.native_exn @@ Option.get @@ Dir_scanner.find_tree dirs (URI_scheme.user_uri ~host addr)
40
+
Eio.Path.native_exn @@ Option.get @@ Dir_scanner.find_tree dirs @@
41
+
URI_scheme.named_uri ~base: env.config.url addr
42
42
43
43
let test_code_actions () =
44
44
let@ () = Reporter.easy_run in
+1
-1
lib/language_server/test/dune
+1
-1
lib/language_server/test/dune
+1
-1
lib/language_server/test/test.t
+1
-1
lib/language_server/test/test.t
···
2
2
3
3
SPDX-License-Identifier: GPL-3.0-or-later
4
4
5
-
$ git clone https://git.sr.ht/~jonsterling/forester-notes.org
5
+
$ git clone --branch canonical-uris https://git.sr.ht/~jonsterling/forester-notes.org
6
6
Cloning into 'forester-notes.org'...
7
7
$ cd forester-notes.org
8
8
$ nvim --headless --clean -l ../test.lua
-6
lib/server/Headers.ml
-6
lib/server/Headers.ml
···
40
40
expanded
41
41
}
42
42
43
-
let parse_modifier (header : Http.Header.t) : T.modifier option =
44
-
match Http.Header.get header "Modifier" with
45
-
| Some "Identity" -> Some Identity
46
-
| Some "Sentence-Case" -> Some Sentence_case
47
-
| _ -> None
48
-
49
43
let parse_content_target (header : Http.Header.t) : T.content_target option =
50
44
let open Http in
51
45
match Header.get header "Taxon" with
+9
-14
lib/server/Server.ml
+9
-14
lib/server/Server.ml
···
47
47
= fun
48
48
~env
49
49
~theme
50
-
~forest
50
+
~(forest : State.t)
51
51
_socket
52
52
request
53
53
body
···
86
86
let headers = Http.Header.of_list ["Content-Type", "image/x-icon"] in
87
87
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.favicon ()
88
88
| Tree s ->
89
-
let href = URI_scheme.user_uri ~host: State.(forest.config.host) s in
89
+
let href = URI_scheme.named_uri ~base: forest.config.url s in
90
90
let request_headers = Http.Request.headers request in
91
91
let is_htmx =
92
92
(*If it is an HTMX request, we just send a fragment.
···
113
113
Cohttp_eio.Server.respond_string ~status: `OK ~body: response ()
114
114
end
115
115
| Some target ->
116
-
let modifier = Option.value ~default: T.Identity (Headers.parse_modifier request_headers) in
117
-
match State.get_content_of_transclusion {target; href; modifier;} forest with
116
+
match State.get_content_of_transclusion {target; href} forest with
118
117
| None -> Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" ()
119
118
| Some content ->
120
119
(* TODO: Remove any sort of HTML generation from the handler. *)
···
176
175
Cohttp_eio.Server.respond_string ~status: `OK ~body: "" ()
177
176
| Home ->
178
177
begin
179
-
match forest.config.home with
178
+
let home = URI_scheme.named_uri ~base: forest.config.url "index" in
179
+
match State.get_article home forest with
180
180
| None ->
181
181
Cohttp_eio.Server.respond_string ~status: `OK ~body: "" ()
182
-
| Some home ->
183
-
let home = URI_scheme.user_uri ~host: forest.config.host home in
184
-
match State.get_article home forest with
185
-
| None ->
186
-
Cohttp_eio.Server.respond_string ~status: `OK ~body: "" ()
187
-
| Some home_tree ->
188
-
let content = Pure_html.to_string @@ Htmx_client.render_article forest home_tree in
189
-
let headers = Http.Header.of_list ["Content-Type", "text/html"] in
190
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: content ()
182
+
| Some home_tree ->
183
+
let content = Pure_html.to_string @@ Htmx_client.render_article forest home_tree in
184
+
let headers = Http.Header.of_list ["Content-Type", "text/html"] in
185
+
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: content ()
191
186
end
192
187
| Query ->
193
188
let q = Uri.get_query_param resource "query" in