forked from
jonmsterling.com/ocaml-forester
ocaml
content addressing assets
+128
-100
+1
-1
bin/forester/main.ml
+1
-1
bin/forester/main.ml
···
39
39
let foreign_dirs = paths_of_dirs ~env config.foreign in
40
40
Forester.plant_raw_forest_from_dirs ~env ~host: config.host ~dev: false ~tree_dirs ~asset_dirs ~foreign_dirs;
41
41
let host = config.host in
42
-
Forester.export ~env ~host ~asset_dirs
42
+
Forester.export ~env ~host
43
43
44
44
let new_tree ~env config_filename dest_dir prefix template random =
45
45
let@ () = Reporter.silence in
-22
lib/compiler/Asset_content_addresser.ml
-22
lib/compiler/Asset_content_addresser.ml
···
1
-
open Forester_core
2
-
3
-
let router : (string, string * iri) Hashtbl.t = Hashtbl.create 100
4
-
5
-
let install ~source_path ~content =
6
-
match Hashtbl.find_opt router source_path with
7
-
| Some (filename, iri) -> (filename, iri)
8
-
| None ->
9
-
let hash = Result.get_ok @@ Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content) in
10
-
let cid = Cid.v ~version: `Cidv1 ~codec: `Raw ~base: `Base32 ~hash in
11
-
let cid_str = Cid.to_string cid in
12
-
let ext = Filename.extension source_path in
13
-
let filename = cid_str ^ ext in
14
-
let iri = Iri.iri ~path: (Relative ["content"; filename]) () in
15
-
Hashtbl.add router source_path (filename, iri);
16
-
filename, iri
17
-
18
-
let iri_of_asset ~source_path =
19
-
match Hashtbl.find_opt router source_path with
20
-
| Some (_, iri) -> iri
21
-
| None ->
22
-
Reporter.fatalf Resource_not_found "Asset located at `%s' does not have a content address" source_path
+22
lib/compiler/Asset_router.ml
+22
lib/compiler/Asset_router.ml
···
1
+
open Forester_core
2
+
3
+
let router : (string, iri) Hashtbl.t = Hashtbl.create 100
4
+
5
+
let install ~host ~source_path ~content =
6
+
match Hashtbl.find_opt router source_path with
7
+
| Some iri -> iri
8
+
| None ->
9
+
let hash = Result.get_ok @@ Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content) in
10
+
let cid = Cid.v ~version: `Cidv1 ~codec: `Raw ~base: `Base32 ~hash in
11
+
let cid_str = Cid.to_string cid in
12
+
let ext = Filename.extension source_path in
13
+
let filename = cid_str ^ ext in
14
+
let iri = Iri_scheme.hash_iri ~host filename in
15
+
Hashtbl.add router source_path iri;
16
+
iri
17
+
18
+
let iri_of_asset ~source_path =
19
+
match Hashtbl.find_opt router source_path with
20
+
| Some iri -> iri
21
+
| None ->
22
+
Reporter.fatalf Resource_not_found "Asset located at `%s' does not have a content address" source_path
+4
-4
lib/compiler/Eval.ml
+4
-4
lib/compiler/Eval.ml
···
262
262
in
263
263
emit_content_node ~loc @@ KaTeX (mode, content)
264
264
| Xml_tag (name, attrs, body) ->
265
-
let rec process : _ list -> T.xml_attr list = function
265
+
let rec process : _ list -> _ T.xml_attr list = function
266
266
| [] -> []
267
267
| (key, v) :: attrs ->
268
-
T.{ key; value = V.extract_text { node with value = eval_tape v } } :: process attrs
268
+
T.{ key; value = V.extract_content { node with value = eval_tape v } } :: process attrs
269
269
in
270
270
let name = T.{ prefix = name.prefix; uname = name.uname; xmlns = name.xmlns } in
271
271
let content = { node with value = eval_tape body } |> V.extract_content in
···
404
404
emit_content_node ~loc @@ T.Transclude transclusion
405
405
| Route_asset ->
406
406
let source_path = pop_text_arg ~loc in
407
-
let iri = Asset_content_addresser.iri_of_asset ~source_path in
408
-
emit_content_node ~loc @@ T.Text (Iri.to_string ~pctencode: false iri)
407
+
let iri = Asset_router.iri_of_asset ~source_path in
408
+
emit_content_node ~loc @@ T.Route_of_iri iri
409
409
| Object { self; methods } ->
410
410
let table =
411
411
let env = Lex_env.read () in
+1
-1
lib/compiler/Forester_compiler.ml
+1
-1
lib/compiler/Forester_compiler.ml
+1
-1
lib/core/Iri_scheme.ml
+1
-1
lib/core/Iri_scheme.ml
+1
-1
lib/core/Iri_scheme.mli
+1
-1
lib/core/Iri_scheme.mli
+12
-3
lib/core/Xml_tree.ml
+12
-3
lib/core/Xml_tree.ml
···
34
34
expanded = None
35
35
}
36
36
37
-
type xml_attr = { key: xml_qname; value: string }
37
+
type 'content xml_attr = { key: xml_qname; value: 'content }
38
38
[@@deriving show, repr]
39
39
40
40
type 'content xml_elt = {
41
41
name: xml_qname;
42
-
attrs: xml_attr list;
42
+
attrs: 'content xml_attr list;
43
43
content: 'content
44
44
}
45
45
[@@deriving show, repr]
···
83
83
}
84
84
[@@deriving show, repr]
85
85
86
+
type asset = { iri: iri; host: string; content: string }
87
+
[@@deriving show, repr]
88
+
89
+
type 'content resource =
90
+
| Article of 'content article
91
+
| Asset of asset
92
+
[@@deriving show, repr]
93
+
86
94
type 'content content_target =
87
95
| Full of section_flags
88
96
| Mainmatter
···
147
155
| Img of img
148
156
| Artefact of 'content artefact
149
157
| Iri of iri
158
+
| Route_of_iri of iri
150
159
| Datalog_script of (string, 'content vertex) Datalog_expr.script
151
160
| Results_of_datalog_query of (string, 'content vertex) Datalog_expr.query
152
161
[@@deriving show, repr]
···
253
262
| CDATA str -> Format.fprintf fmt "%s" str
254
263
| KaTeX (_, xs) -> pp_content fmt xs
255
264
| TeX_cs cs -> pp_tex_cs fmt cs
256
-
| Xml_elt _ | Transclude _ | Contextual_number _ | Results_of_query _ | Section _ | Prim _ | Link _ | Img _ | Artefact _ | Iri _ | Datalog_script _ | Results_of_datalog_query _ ->
265
+
| Xml_elt _ | Transclude _ | Contextual_number _ | Results_of_query _ | Section _ | Prim _ | Link _ | Img _ | Artefact _ | Iri _ | Route_of_iri _ | Datalog_script _ | Results_of_datalog_query _ ->
257
266
Reporter.fatalf Type_error "Cannot render this kind of content as TeX-like string"
258
267
259
268
let string_of_content =
+10
-14
lib/forest/Forest.ml
+10
-14
lib/forest/Forest.ml
···
4
4
module T = Xml_tree
5
5
module Q = Query
6
6
7
-
module type S = sig
8
-
type resource =
9
-
| Article of T.content T.article
10
-
| Asset of { iri: iri; contents: string; filename: string }
7
+
type resource = T.content T.resource
11
8
9
+
module type S = sig
12
10
val plant_resource : resource -> unit
13
11
14
12
val get_resource : Iri.t -> resource option
···
38
36
let run_datalog_query =
39
37
Datalog_eval.run_query Graphs.dl_db
40
38
41
-
type resource =
42
-
| Article of article
43
-
| Asset of { iri: iri; contents: string; filename: string }
44
-
45
39
let resources : (Iri.t, resource) Hashtbl.t =
46
40
Hashtbl.create 1000
47
41
···
56
50
57
51
let rec analyse_content_node (scope : Iri.t) (node : 'a T.content_node) : unit =
58
52
match node with
59
-
| Text _ | CDATA _ | Iri _ | Results_of_query _ | Results_of_datalog_query _ | TeX_cs _ | Img _ | Contextual_number _ -> ()
53
+
| Text _ | CDATA _ | Iri _ | Route_of_iri _ | Results_of_query _ | Results_of_datalog_query _ | TeX_cs _ | Img _ | Contextual_number _ -> ()
60
54
| Transclude transclusion ->
61
55
analyse_transclusion scope transclusion
62
56
| Xml_elt elt ->
···
70
64
analyse_content scope content
71
65
| KaTeX (_, content) ->
72
66
analyse_content scope content
73
-
| Artefact artefact ->
67
+
| Artefact artefact ->
74
68
analyse_artefact scope artefact
75
69
| Datalog_script script ->
76
70
execute_datalog_script script
···
145
139
analyse_content scope article.backmatter
146
140
147
141
let analyse_resource = function
148
-
| Article article -> analyse_article article
149
-
| Asset _ -> ()
142
+
| T.Article article -> analyse_article article
143
+
| T.Asset _ -> ()
150
144
151
145
let iri_for_resource = function
152
-
| Article article -> article.frontmatter.iri
153
-
| Asset asset -> Some asset.iri
146
+
| T.Article article -> article.frontmatter.iri
147
+
| T.Asset asset -> Some asset.iri
154
148
155
149
let plant_resource resource =
156
150
analyse_resource resource;
157
151
let@ iri = Option.iter @~ iri_for_resource resource in
152
+
let iri = Iri.normalize iri in
158
153
match Hashtbl.mem resources iri with
159
154
| false ->
160
155
Hashtbl.add resources iri resource
···
162
157
Reporter.emitf Duplicate_tree "Already planted resource at address %a" pp_iri iri
163
158
164
159
let get_resource iri =
160
+
let iri = Iri.normalize iri in
165
161
Hashtbl.find_opt resources iri
166
162
167
163
let get_all_resources () =
+2
-4
lib/forest/Forest.mli
+2
-4
lib/forest/Forest.mli
···
2
2
3
3
module T = Xml_tree
4
4
5
-
module type S = sig
6
-
type resource =
7
-
| Article of T.content T.article
8
-
| Asset of { iri: iri; contents: string; filename: string }
5
+
type resource = T.content T.resource
9
6
7
+
module type S = sig
10
8
val plant_resource : resource -> unit
11
9
val get_resource : iri -> resource option
12
10
val get_article : iri -> T.content T.article option
+1
-1
lib/forest/Forest_util.ml
+1
-1
lib/forest/Forest_util.ml
+3
-3
lib/forest/Json_client.ml
+3
-3
lib/forest/Json_client.ml
···
3
3
4
4
type t = {
5
5
host: string;
6
-
articles: T.content T.article list;
6
+
resources: T.content T.resource list;
7
7
}
8
8
[@@deriving repr]
9
9
10
-
let render_trees ~host articles =
11
-
Repr.to_json_string t { host; articles }
10
+
let render ~host resources =
11
+
Repr.to_json_string t { host; resources }
+2
-2
lib/forest/Json_client.mli
+2
-2
lib/forest/Json_client.mli
+1
-1
lib/forest/Json_manifest_client.ml
+1
-1
lib/forest/Json_manifest_client.ml
···
5
5
6
6
module Make (R: sig val route : Iri.t -> string end) (F: Forest.S) = struct
7
7
8
-
module PT = Plain_text_client.Make(F)
8
+
module PT = Plain_text_client.Make(F)(Plain_text_client.Default_params)
9
9
10
10
let render_tree ~dev ~host (doc : T.content T.article) =
11
11
let@ iri = Option.bind doc.frontmatter.iri in
+29
-19
lib/forest/Legacy_xml_client.ml
+29
-19
lib/forest/Legacy_xml_client.ml
···
20
20
21
21
module Make (Params: Params) (F: Forest.S) () : S = struct
22
22
23
-
module PT = Plain_text_client.Make(F)
24
23
module Util = Forest_util.Make(F)
25
24
26
25
module Xmlns = struct
···
79
78
Iri.equal ~normalize: true home_iri iri
80
79
| None -> false
81
80
81
+
let route_resource_iri ~suffix iri =
82
+
let host = Option.value ~default: "" @@ Iri.host iri in
83
+
let bare_route =
84
+
String.concat "-" @@
85
+
match Iri.path iri with
86
+
| Iri.Absolute xs -> xs
87
+
| Iri.Relative xs -> xs (* impossible? *)
88
+
in
89
+
begin
90
+
if host = Params.host then
91
+
if iri_is_home iri then "index.xml"
92
+
else
93
+
bare_route ^ suffix
94
+
else
95
+
"foreign-" ^ host ^ bare_route ^ suffix
96
+
end
97
+
82
98
let route iri =
83
99
match F.get_resource iri with
84
-
| Some (F.Article _) ->
85
-
let host = Option.value ~default: "" @@ Iri.host iri in
86
-
let bare_route =
87
-
String.concat "-" @@
88
-
match Iri.path iri with
89
-
| Iri.Absolute xs -> xs
90
-
| Iri.Relative xs -> xs (* impossible? *)
100
+
| Some resource ->
101
+
let suffix =
102
+
match resource with
103
+
| T.Article _ -> ".xml"
104
+
| T.Asset _ -> ""
91
105
in
92
-
begin
93
-
if host = Params.host then
94
-
if iri_is_home iri then "index.xml"
95
-
else
96
-
bare_route ^ ".xml"
97
-
else
98
-
"foreign-" ^ host ^ bare_route ^ ".xml"
99
-
end
100
-
| Some (F.Asset asset) ->
101
-
"content/" ^ asset.filename
106
+
route_resource_iri ~suffix iri
102
107
| None ->
103
108
Iri.to_uri iri
109
+
110
+
module PT = Plain_text_client.Make(F)(struct let route = route end)
104
111
105
112
let get_expanded_title frontmatter =
106
113
let scope = Scope.read () in
···
114
121
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
115
122
116
123
let render_xml_attr T.{ key; value } =
117
-
P.string_attr (render_xml_qname key) "%s" value
124
+
let str_value = PT.string_of_content value in
125
+
P.string_attr (render_xml_qname key) "%s" str_value
118
126
119
127
let render_prim_node p =
120
128
X.prim p []
···
195
203
let relativised = Iri_scheme.relativise_iri ~host: Params.host iri in
196
204
let str = Format.asprintf "%a" pp_iri relativised in
197
205
[P.txt "%s" str]
206
+
| Route_of_iri iri ->
207
+
[P.txt "%s" (route iri)]
198
208
| Xml_elt elt ->
199
209
let prefixes_to_add, (name, attrs, content) =
200
210
let@ () = Xmlns.within_scope in
+10
-1
lib/forest/Plain_text_client.ml
+10
-1
lib/forest/Plain_text_client.ml
···
2
2
3
3
module T = Xml_tree
4
4
5
+
module type Params = sig
6
+
val route : iri -> string
7
+
end
8
+
9
+
module Default_params: Params = struct
10
+
let route = Iri.to_uri
11
+
end
12
+
5
13
module type S = sig
6
14
val string_of_content : Xml_tree.content -> string
7
15
val pp_content : Format.formatter -> Xml_tree.content -> unit
8
16
end
9
17
10
-
module Make (F: Forest.S) : S = struct
18
+
module Make (F: Forest.S) (P: Params) : S = struct
11
19
12
20
let rec pp_content fmt = function
13
21
| T.Content c -> c |> List.iter @@ pp_content_node fmt
···
15
23
and pp_content_node fmt : 'a T.content_node -> unit = function
16
24
| Text txt | CDATA txt -> Format.pp_print_string fmt txt
17
25
| Iri iri -> pp_iri fmt iri
26
+
| Route_of_iri iri -> Format.fprintf fmt "%s" (P.route iri)
18
27
| KaTeX (_, content) -> pp_content fmt content
19
28
| TeX_cs cs -> Format.fprintf fmt "\\%a" TeX_cs.pp cs
20
29
| Xml_elt elt -> pp_content fmt elt.content
+7
-1
lib/forest/Plain_text_client.mli
+7
-1
lib/forest/Plain_text_client.mli
···
2
2
3
3
module T := Xml_tree
4
4
5
+
module type Params = sig
6
+
val route : iri -> string
7
+
end
8
+
9
+
module Default_params: Params
10
+
5
11
module type S = sig
6
12
val string_of_content : Xml_tree.content -> string
7
13
val pp_content : Format.formatter -> Xml_tree.content -> unit
8
14
end
9
15
10
-
module Make (_: Forest.S) : S
16
+
module Make (_: Forest.S) (_: Params) : S
+21
-20
lib/frontend/Forester.ml
+21
-20
lib/frontend/Forester.ml
···
7
7
module T = Xml_tree
8
8
module F = Forest.Make(Forest_graphs.Make ())
9
9
module FU = Forest_util.Make(F)
10
-
module PT = Plain_text_client.Make(F)
10
+
module PT = Plain_text_client.Make(F)(Plain_text_client.Default_params)
11
11
module C = T.Comparators(PT)
12
12
module EP = Eio.Path
13
13
···
91
91
let complete ~host prefix =
92
92
let@ article = Seq.filter_map @~ List.to_seq @@ get_all_articles () in
93
93
let@ iri = Option.bind article.frontmatter.iri in
94
-
let@ iri = Option.bind @@ Option_util.guard Iri_scheme.is_stable_iri iri in
94
+
let@ iri = Option.bind @@ Option_util.guard Iri_scheme.is_named_iri iri in
95
95
let iri = Iri_scheme.relativise_iri ~host iri in
96
96
let@ title = Option.bind article.frontmatter.title in
97
97
let title = Format.asprintf "%a" PT.pp_content title in
···
132
132
let source_path = String.concat "/" source_path in
133
133
let cwd = Eio.Stdenv.cwd env in
134
134
let content = EP.load EP.(cwd / source_path) in
135
-
let filename, iri = Forester_compiler.Asset_content_addresser.install ~source_path ~content in
136
-
F.plant_resource @@ F.Asset { iri; contents = content; filename }
135
+
let iri = Forester_compiler.Asset_router.install ~host ~source_path ~content in
136
+
F.plant_resource @@ T.Asset { iri; host; content }
137
137
end;
138
138
begin
139
139
let@ () = Reporter.profile "Expand, evaluate, and analyse forest" in
140
140
begin
141
141
let@ _, article = Seq.iter @~ Iri_map.to_seq @@ Forest_reader.read_trees ~host ~env parsed_trees in
142
-
F.plant_resource @@ F.Article article
142
+
F.plant_resource @@ T.Article article
143
143
end;
144
144
begin
145
145
let@ _foreign_dir = List.iter @~ foreign_dirs in
···
163
163
let cwd = Eio.Stdenv.cwd env in
164
164
let all_resources = List.of_seq @@ F.get_all_resources () in
165
165
begin
166
-
let all_articles = List.filter_map (function F.Article article -> Some article | _ -> None) all_resources in
166
+
let all_articles = List.filter_map (function T.Article article -> Some article | _ -> None) all_resources in
167
167
let json_string = Yojson.Basic.to_string @@ R.render_trees ~dev ~host all_articles in
168
168
let json_path = EP.(cwd / output_dir_name / "forest.json") in
169
169
Eio_util.ensure_context_of_path ~perm: 0o755 json_path;
···
173
173
let@ resource = Eio.Fiber.List.iter ~max_fibers: 20 @~ all_resources in
174
174
let@ () = Reporter.easy_run in
175
175
match resource with
176
-
| F.Article article ->
176
+
| T.Article article ->
177
177
let@ route = Option.iter @~ Option.map Client.route article.frontmatter.iri in
178
178
let path = EP.(cwd / output_dir_name / route) in
179
179
Eio_util.ensure_context_of_path ~perm: 0o755 path;
180
180
let@ flow = EP.with_open_out ~create: (`Or_truncate 0o644) path in
181
181
let@ writer = Eio.Buf_write.with_flow flow in
182
-
Client.pp_xml ~stylesheet:"default.xsl" (Eio.Buf_write.make_formatter writer) article
183
-
| F.Asset asset ->
182
+
Client.pp_xml ~stylesheet: "default.xsl" (Eio.Buf_write.make_formatter writer) article
183
+
| T.Asset asset ->
184
184
let route = Client.route asset.iri in
185
185
let dest = EP.(cwd / output_dir_name / route) in
186
186
if Eio_util.file_exists dest then ()
187
187
else
188
188
begin
189
189
Eio_util.ensure_context_of_path ~perm: 0o755 dest;
190
-
EP.save ~create: (`Or_truncate 0o644) dest asset.contents
190
+
EP.save ~create: (`Or_truncate 0o644) dest asset.content
191
191
end
192
192
end
193
193
194
-
let export ~env ~host ~asset_dirs : unit =
194
+
let export ~env ~host : unit =
195
195
let@ () = Reporter.profile "Export forest" in
196
-
let all_resources = List.of_seq @@ F.get_all_resources () in
197
-
let all_articles = List.filter_map (function F.Article article -> Some article | _ -> None) all_resources in
198
-
196
+
let local_resources =
197
+
let@ resource = Seq.filter @~ F.get_all_resources () in
198
+
match resource with
199
+
| T.Article { frontmatter = { iri = Some iri; _ }; _ } ->
200
+
Iri.host iri = Some host
201
+
| T.Asset asset -> asset.host = host
202
+
| _ -> false
203
+
in
199
204
let cwd = Eio.Stdenv.cwd env in
200
-
let result = Json_client.render_trees ~host all_articles in
205
+
let result = Json_client.render ~host @@ List.of_seq local_resources in
201
206
let dir = Eio.Path.(cwd / "export" / host) in
202
207
Eio.Path.mkdirs ~exists_ok: true ~perm: 0o755 dir;
203
-
Eio.Path.save ~create: (`Or_truncate 0o644) Eio.Path.(dir / "forest.json") result;
204
-
let@ dir_to_copy = List.iter @~ asset_dirs in
205
-
let source = EP.native_exn dir_to_copy in
206
-
let dest_dir = EP.native_exn dir in
207
-
Eio_util.copy_to_dir ~env ~cwd ~source ~dest_dir
208
+
Eio.Path.save ~create: (`Or_truncate 0o644) Eio.Path.(dir / "forest.json") result