Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
xmlt: Path/Sort context threading and location capture
Adds structural Path/Context to every decode error:
- XML Sort.t enum: Element / Attribute / Text / Document, exposed in
xmlt.mli with kinded / or_kind helpers.
- Decode descent points wrap inner decoding with try/with that pushes
a context frame (Textloc.Error.push_object or push_array) before
re-raising:
* dec_stream_attrs: pushes (element_kind, attr_name) for each Attr
/ Attr_opt decode.
* dec_stream_children: pushes (element_kind, child_tag) for Child
and Child_opt, and (list_kind, idx) for Children.
* dec_stream_list: pushes (list_kind, idx) for each list item.
- dec_stream now captures the parser's start-of-value location for
Text_map and Map decodes; if the inner decoder raises with no meta,
the caught error is re-raised with the captured location attached.
This keeps the 'line N' info in errors that come from user-supplied
base_dec / map_dec functions.
- dec_stream_el now takes the element's tag so attribute and child
decoding can build the correct kinded-sort frame.
12 new tests cover: bad child element, bad attribute, missing
attribute, list-item error, list first-item edge case, Children
field, 3-level nesting, child_opt with bad contents, list of records
with an attr failure, line preservation with non-empty context, and
two structural assertions against Textloc.Error.t (kinds + path
indices).
All 177 tests pass.
+197
-106
+195
-106
bin/cmd_serve.ml
+195
-106
bin/cmd_serve.ml
···
12
12
13
13
module Log = (val Logs.src_log src : Logs.LOG)
14
14
15
-
(* ── HTML helpers ──────────────────────────────────────────────────── *)
16
-
17
-
let html_escape s =
18
-
let b = Buffer.create (String.length s) in
19
-
String.iter
20
-
(function
21
-
| '&' -> Buffer.add_string b "&"
22
-
| '<' -> Buffer.add_string b "<"
23
-
| '>' -> Buffer.add_string b ">"
24
-
| '"' -> Buffer.add_string b """
25
-
| '\'' -> Buffer.add_string b "'"
26
-
| c -> Buffer.add_char b c)
27
-
s;
28
-
Buffer.contents b
15
+
(* ── HTML helpers (tw.html DSL) ─────────────────────────────────────── *)
29
16
30
17
let url_escape s =
31
18
let b = Buffer.create (String.length s) in
···
38
25
s;
39
26
Buffer.contents b
40
27
41
-
let page ~title body =
42
-
Fmt.str
43
-
{|<!doctype html>
44
-
<html lang="en">
45
-
<head>
46
-
<meta charset="utf-8">
47
-
<title>%s</title>
48
-
<script src="https://cdn.tailwindcss.com"></script>
49
-
<script src="https://unpkg.com/htmx.org@2.0.3" integrity="sha384-0895/pl2MU10Hqc6jd4RvrthNlDiE9U1tWmX7WRESftEDRosgxNsQG/Ze9YMRzHq" crossorigin="anonymous"></script>
50
-
</head>
51
-
<body class="font-mono max-w-5xl mx-auto my-8 px-4 text-gray-800">
52
-
%s
53
-
<footer class="mt-8 text-center text-xs text-gray-400">Served with Irmin</footer>
54
-
</body>
55
-
</html>
56
-
|}
57
-
(html_escape title) body
28
+
module H = Tw_html
29
+
module A = Tw_html.At
58
30
59
-
let drop_zone ~upload_url ~target_dir =
60
-
Fmt.str
61
-
{|<form class="mt-6"
62
-
hx-post=%S hx-encoding="multipart/form-data"
63
-
hx-target="body" hx-swap="none"
64
-
hx-on::after-request="window.location.reload()">
65
-
<input type="hidden" name="dir" value=%S>
66
-
<label class="block p-5 border-2 border-dashed border-gray-300 rounded-lg text-center text-sm text-gray-500 cursor-pointer hover:border-blue-500 hover:text-blue-600 hover:bg-blue-50 transition">
67
-
Drop files here or <span class="underline">click to browse</span>
68
-
<input type="file" name="file" multiple class="hidden"
69
-
onchange="this.form.dispatchEvent(new Event('submit',{cancelable:true,bubbles:true}))">
70
-
</label>
71
-
</form>
72
-
|}
73
-
upload_url target_dir
31
+
let link_blue ~href text =
32
+
H.a
33
+
~at:[ A.href href ]
34
+
~tw:Tw.[ text blue; hover [ underline ] ]
35
+
[ H.txt text ]
36
+
37
+
let bold_link_blue ~href text =
38
+
H.a
39
+
~at:[ A.href href ]
40
+
~tw:Tw.[ font_semibold; text blue; hover [ underline ] ]
41
+
[ H.txt text ]
42
+
43
+
let cell_right_dim content =
44
+
H.td
45
+
~tw:
46
+
Tw.[ py 1; px 2; text_right; text ~shade:400 gray; text_sm; tabular_nums ]
47
+
content
48
+
49
+
let cell_right_mono content =
50
+
H.td
51
+
~tw:Tw.[ py 1; px 2; text_right; text ~shade:400 gray; text_xs; font_mono ]
52
+
content
53
+
54
+
let row_dir ~href ~name ~hash =
55
+
H.tr
56
+
~tw:Tw.[ border_b; border_color ~shade:100 gray ]
57
+
[
58
+
H.td ~tw:Tw.[ py 1; px 2 ] [ bold_link_blue ~href (name ^ "/") ];
59
+
cell_right_dim [ H.raw "—" ];
60
+
cell_right_mono [ H.txt hash ];
61
+
]
62
+
63
+
let row_file ~href ~name ~size ~hash =
64
+
H.tr
65
+
~tw:Tw.[ border_b; border_color ~shade:100 gray ]
66
+
[
67
+
H.td ~tw:Tw.[ py 1; px 2 ] [ link_blue ~href name ];
68
+
cell_right_dim [ H.txt size ];
69
+
cell_right_mono [ H.txt hash ];
70
+
]
71
+
72
+
let table_shell rows =
73
+
let head_cell ?(align = `Left) text =
74
+
let align_tw =
75
+
match align with `Left -> Tw.text_left | `Right -> Tw.text_right
76
+
in
77
+
H.th
78
+
~tw:Tw.[ align_tw; font_medium; text ~shade:500 gray; py 1; px 2 ]
79
+
[ H.txt text ]
80
+
in
81
+
H.table
82
+
~tw:Tw.[ w_full; border_collapse; text_sm ]
83
+
[
84
+
H.thead
85
+
[
86
+
H.tr
87
+
~tw:Tw.[ border_b; border_color ~shade:300 gray ]
88
+
[
89
+
head_cell "Name";
90
+
head_cell ~align:`Right "Size";
91
+
head_cell ~align:`Right "Hash";
92
+
];
93
+
];
94
+
H.tbody rows;
95
+
]
74
96
75
97
let breadcrumb ~branch ~path =
76
-
let b = Buffer.create 128 in
77
-
let link href text =
78
-
Fmt.str {|<a class="text-blue-600 hover:underline" href="%s">%s</a>|} href
79
-
text
80
-
in
81
-
let sep () = {|<span class="mx-1 text-gray-400">›</span>|} in
82
-
Buffer.add_string b {|<div class="mb-3 text-sm">|};
83
-
Buffer.add_string b (link "/" "/");
98
+
let sep = H.span ~tw:Tw.[ mx 1; text ~shade:400 gray ] [ H.raw "›" ] in
99
+
let segments = ref [ link_blue ~href:"/" "/" ] in
84
100
(match branch with
85
101
| None -> ()
86
102
| Some br ->
87
-
Buffer.add_string b (" " ^ sep () ^ " ");
88
-
Buffer.add_string b
89
-
(link (Fmt.str "/%s/" (url_escape br)) (html_escape br));
103
+
segments :=
104
+
!segments @ [ sep; link_blue ~href:(Fmt.str "/%s/" (url_escape br)) br ];
90
105
let prefix = ref (Fmt.str "/%s" (url_escape br)) in
91
106
List.iter
92
107
(fun seg ->
93
108
prefix := !prefix ^ "/" ^ url_escape seg;
94
-
Buffer.add_string b (" " ^ sep () ^ " ");
95
-
Buffer.add_string b (link (!prefix ^ "/") (html_escape seg)))
109
+
segments := !segments @ [ sep; link_blue ~href:(!prefix ^ "/") seg ])
96
110
path);
97
-
Buffer.add_string b "</div>";
98
-
Buffer.contents b
111
+
H.div ~tw:Tw.[ mb 3; text_sm ] !segments
112
+
113
+
let drop_zone ~upload_url ~target_dir =
114
+
H.form
115
+
~at:
116
+
[
117
+
A.action upload_url;
118
+
A.method' "POST";
119
+
A.v "enctype" "multipart/form-data";
120
+
]
121
+
~tw:Tw.[ mt 6 ]
122
+
[
123
+
H.input ~at:[ A.type' "hidden"; A.name "dir"; A.value target_dir ] ();
124
+
H.label
125
+
~tw:
126
+
Tw.
127
+
[
128
+
block;
129
+
p 5;
130
+
border_md;
131
+
border_dashed;
132
+
border_color ~shade:300 gray;
133
+
rounded_lg;
134
+
text_center;
135
+
text_sm;
136
+
text ~shade:500 gray;
137
+
cursor_pointer;
138
+
transition;
139
+
hover
140
+
[
141
+
border_color ~shade:500 blue;
142
+
text ~shade:600 blue;
143
+
bg ~shade:50 blue;
144
+
];
145
+
]
146
+
[
147
+
H.txt "Drop files here or ";
148
+
H.span ~tw:Tw.[ underline ] [ H.txt "click to browse" ];
149
+
H.input
150
+
~at:
151
+
[
152
+
A.type' "file";
153
+
A.name "file";
154
+
A.v "multiple" "";
155
+
A.onchange
156
+
"this.form.dispatchEvent(new \
157
+
Event('submit',{cancelable:true,bubbles:true}))";
158
+
]
159
+
~tw:Tw.[ hidden ]
160
+
();
161
+
];
162
+
]
163
+
164
+
let page_footer =
165
+
H.footer
166
+
~tw:Tw.[ mt 8; text_center; text_xs; text ~shade:400 gray ]
167
+
[ H.txt "Served with Irmin" ]
99
168
100
-
let row_dir ~href ~name ~hash =
101
-
Fmt.str
102
-
{|<tr class="border-b border-gray-100"><td class="py-1 px-2"><a class="font-semibold text-blue-600 hover:underline" href="%s">%s/</a></td><td class="py-1 px-2 text-right text-gray-400 text-sm tabular-nums">—</td><td class="py-1 px-2 text-right text-gray-400 text-xs font-mono">%s</td></tr>|}
103
-
href (html_escape name) hash
169
+
let summary_p text =
170
+
H.p ~tw:Tw.[ text ~shade:500 gray; text_sm; mb 3 ] [ H.txt text ]
171
+
172
+
let h1_title text = H.h1 ~tw:Tw.[ text_xl; font_light; mb 1 ] [ H.txt text ]
104
173
105
-
let row_file ~href ~name ~size ~hash =
106
-
Fmt.str
107
-
{|<tr class="border-b border-gray-100"><td class="py-1 px-2"><a class="text-blue-600 hover:underline" href="%s">%s</a></td><td class="py-1 px-2 text-right text-gray-400 text-sm tabular-nums">%s</td><td class="py-1 px-2 text-right text-gray-400 text-xs font-mono">%s</td></tr>|}
108
-
href (html_escape name) size hash
174
+
(* Build a Tw_html.page value. Kept separate from rendering so the CSS
175
+
stylesheet can be extracted as well. *)
176
+
let build_page ~title body_content =
177
+
let shell =
178
+
H.div
179
+
~tw:Tw.[ font_mono; max_w_5xl; mx_auto; my 8; px 4; text ~shade:800 gray ]
180
+
(body_content @ [ page_footer ])
181
+
in
182
+
Tw_html.page ~title ~tw_css:"/tw.css" [] [ shell ]
109
183
110
-
let table_shell rows =
111
-
Fmt.str
112
-
{|<table class="w-full border-collapse text-sm">
113
-
<thead><tr class="border-b border-gray-300"><th class="text-left font-medium text-gray-500 py-1 px-2">Name</th><th class="text-right font-medium text-gray-500 py-1 px-2">Size</th><th class="text-right font-medium text-gray-500 py-1 px-2">Hash</th></tr></thead>
114
-
<tbody>
115
-
%s
116
-
</tbody>
117
-
</table>|}
118
-
(String.concat "\n" rows)
184
+
let page ~title body_content = Tw_html.html (build_page ~title body_content)
185
+
186
+
(* One-shot stylesheet covering every component this module can render.
187
+
Served at [GET /tw.css] so the auto-injected [<link>] in each page
188
+
resolves to a real stylesheet regardless of which page was requested. *)
189
+
let tw_stylesheet () =
190
+
let sample_rows =
191
+
[
192
+
row_dir ~href:"/b/" ~name:"dir" ~hash:"abcd123";
193
+
row_file ~href:"/b/f" ~name:"file" ~size:"1B" ~hash:"abcd123";
194
+
]
195
+
in
196
+
let body =
197
+
[
198
+
h1_title "sample";
199
+
summary_p "sample";
200
+
breadcrumb ~branch:(Some "b") ~path:[ "sub" ];
201
+
table_shell sample_rows;
202
+
drop_zone ~upload_url:"/b/upload" ~target_dir:"";
203
+
]
204
+
in
205
+
let page = build_page ~title:"css" body in
206
+
let _name, css = Tw_html.css page in
207
+
Tw.Css.to_string css
119
208
120
209
(* ── Navigation helpers ───────────────────────────────────────────── *)
121
210
···
152
241
(fun name ->
153
242
let hash =
154
243
match S.head heap ~branch:name with
155
-
| None -> "—"
244
+
| None -> "-"
156
245
| Some h ->
157
246
let hex = Irmin.Hash.to_hex h in
158
247
if String.length hex <= 7 then hex else String.sub hex 0 7
···
160
249
row_dir ~href:(Fmt.str "/%s/" (url_escape name)) ~name ~hash)
161
250
bs
162
251
in
252
+
let n = List.length bs in
163
253
let summary =
164
-
Fmt.str {|<p class="text-gray-500 text-sm mb-3">%d branch%s</p>|}
165
-
(List.length bs)
166
-
(if List.length bs = 1 then "" else "es")
254
+
summary_p (Fmt.str "%d branch%s" n (if n = 1 then "" else "es"))
167
255
in
168
256
let body =
169
-
Fmt.str {|<h1 class="text-xl font-light mb-1">Branches</h1>
170
-
%s
171
-
%s
172
-
%s|}
173
-
summary
174
-
(breadcrumb ~branch:None ~path:[])
175
-
(table_shell rows)
257
+
[
258
+
h1_title "Branches";
259
+
summary;
260
+
breadcrumb ~branch:None ~path:[];
261
+
table_shell rows;
262
+
]
176
263
in
177
264
Respond.Response.html (page ~title:"Branches" body)
178
265
···
185
272
Fmt.str "/%s/%s" (url_escape branch)
186
273
(String.concat "/" (List.map url_escape path))
187
274
in
188
-
(* Resolve each entry's true kind by stepping to its target. *)
189
275
let rows_and_kinds =
190
276
List.map
191
277
(fun (name, _raw_kind) ->
192
278
match Irmin_git.Tree.step_target c name with
193
279
| None ->
194
280
let href = Fmt.str "%s/%s" base (url_escape name) in
195
-
(`Leaf, row_file ~href ~name ~size:"—" ~hash:"—")
281
+
(`Leaf, row_file ~href ~name ~size:"-" ~hash:"-")
196
282
| Some (S.Step (_, target_c) as s) -> (
197
283
let k = Irmin_git.Tree.kind_of_step s in
198
284
let hash = short_hash target_c in
···
212
298
in
213
299
let files = List.length rows_and_kinds - dirs in
214
300
let summary =
215
-
Fmt.str
216
-
{|<p class="text-gray-500 text-sm mb-3">%d director%s, %d file%s</p>|}
217
-
dirs
218
-
(if dirs = 1 then "y" else "ies")
219
-
files
220
-
(if files = 1 then "" else "s")
301
+
summary_p
302
+
(Fmt.str "%d director%s, %d file%s" dirs
303
+
(if dirs = 1 then "y" else "ies")
304
+
files
305
+
(if files = 1 then "" else "s"))
221
306
in
222
307
let title =
223
308
if path = [] then Fmt.str "%s/" branch
···
226
311
let upload_url = Fmt.str "/%s/upload" (url_escape branch) in
227
312
let target_dir = String.concat "/" path in
228
313
let body =
229
-
Fmt.str {|<h1 class="text-xl font-light mb-1">%s</h1>
230
-
%s
231
-
%s
232
-
%s
233
-
%s|}
234
-
(html_escape title) summary
235
-
(breadcrumb ~branch:(Some branch) ~path)
236
-
(table_shell rows)
237
-
(drop_zone ~upload_url ~target_dir)
314
+
[
315
+
h1_title title;
316
+
summary;
317
+
breadcrumb ~branch:(Some branch) ~path;
318
+
table_shell rows;
319
+
drop_zone ~upload_url ~target_dir;
320
+
]
238
321
in
239
322
Respond.Response.html (page ~title body)
240
323
···
368
451
let net = Eio.Stdenv.net env in
369
452
Eio.Switch.run @@ fun sw ->
370
453
let heap = Common.open_store ~sw ~fs ~config in
454
+
let css = tw_stylesheet () in
455
+
let css_route =
456
+
Respond.get "/tw.css" (fun _ ->
457
+
Respond.Response.raw ~status:200 ~content_type:"text/css" css)
458
+
in
371
459
let routes =
372
460
Respond.
373
461
[
462
+
css_route;
374
463
get "/" (branches_page heap);
375
464
get "/blocks/:hash" (raw_block heap);
376
465
post "/:branch/upload" (upload heap);