My aggregated monorepo of OCaml code, automaintained
Refactor arod to separate server module with route abstraction
Introduce framework-agnostic routing (arod_route), memoization with TTL
(arod_memo), and pure handler functions (arod_handlers). Move tiny_httpd
dependency to separate arod.server library. Simplifies main.ml from ~500
to ~120 lines.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+1290
-419
+2
-5
arod/bin/dune
+2
-5
arod/bin/dune
+39
-414
arod/bin/main.ml
+39
-414
arod/bin/main.ml
···
5
5
6
6
(** Arod webserver - a tiny_httpd based server for Bushel content *)
7
7
8
-
open Tiny_httpd
9
-
open Arod.Entries
10
-
11
8
(** {1 Logging} *)
12
9
13
10
let src = Logs.Src.create "arod" ~doc:"Arod webserver"
14
-
module Log = (val Logs.src_log src : Logs.LOG)
15
11
16
-
(** {1 Query Helpers} *)
17
-
18
-
let get_query_params req =
19
-
Request.query req
20
-
21
-
let get_query_param req name =
22
-
match List.assoc_opt name (get_query_params req) with
23
-
| Some v -> Some v
24
-
| None -> None
25
-
26
-
let get_query_params_multi req name =
27
-
List.filter_map (fun (k, v) ->
28
-
if k = name then Some v else None
29
-
) (get_query_params req)
30
-
31
-
let get_query_info req =
32
-
let tags = get_query_params_multi req "t" |> List.map Arod.Model.Tags.of_string in
33
-
let min = match get_query_param req "min" with None -> 25 | Some v -> int_of_string v in
34
-
let show_all = match get_query_param req "all" with None -> false | Some _ -> true in
35
-
{tags; min; show_all}
36
-
37
-
(** {1 Response Helpers} *)
38
-
39
-
let html_response content =
40
-
Response.make_string ~headers:[("content-type", "text/html; charset=utf-8")] (Ok content)
41
-
42
-
let not_found_response = Response.fail ~code:404 "Not Found"
43
-
44
-
let plain_response content =
45
-
Response.make_string ~headers:[("content-type", "text/plain")] (Ok content)
46
-
47
-
let atom_response content =
48
-
Response.make_string ~headers:[("content-type", "application/atom+xml; charset=utf-8")] (Ok content)
49
-
50
-
let xml_response content =
51
-
Response.make_string ~headers:[("content-type", "application/xml")] (Ok content)
52
-
53
-
let json_response content =
54
-
Response.make_string ~headers:[("content-type", "application/json; charset=utf-8")] (Ok content)
55
-
56
-
(** {1 File Serving} *)
57
-
58
-
let serve_file ~dir path =
59
-
let clean_path =
60
-
let parts = String.split_on_char '/' path in
61
-
let safe_parts = List.filter (fun s -> s <> ".." && s <> ".") parts in
62
-
String.concat "/" safe_parts
63
-
in
64
-
let file_path = Filename.concat dir clean_path in
65
-
Log.info (fun m -> m "Serving file: %s (dir=%s, path=%s)" file_path dir path);
66
-
try
67
-
if Sys.file_exists file_path && not (Sys.is_directory file_path) then begin
68
-
let ic = open_in_bin file_path in
69
-
let len = in_channel_length ic in
70
-
let content = really_input_string ic len in
71
-
close_in ic;
72
-
let mime_type =
73
-
if String.ends_with ~suffix:".pdf" file_path then "application/pdf"
74
-
else if String.ends_with ~suffix:".html" file_path then "text/html"
75
-
else if String.ends_with ~suffix:".css" file_path then "text/css"
76
-
else if String.ends_with ~suffix:".js" file_path then "text/javascript"
77
-
else if String.ends_with ~suffix:".svg" file_path then "image/svg+xml"
78
-
else if String.ends_with ~suffix:".png" file_path then "image/png"
79
-
else if String.ends_with ~suffix:".jpg" file_path || String.ends_with ~suffix:".jpeg" file_path then "image/jpeg"
80
-
else if String.ends_with ~suffix:".webp" file_path then "image/webp"
81
-
else if String.ends_with ~suffix:".xml" file_path then "application/xml"
82
-
else if String.ends_with ~suffix:".wasm" file_path then "application/wasm"
83
-
else if String.ends_with ~suffix:".ico" file_path then "image/x-icon"
84
-
else if String.ends_with ~suffix:".woff" file_path then "font/woff"
85
-
else if String.ends_with ~suffix:".woff2" file_path then "font/woff2"
86
-
else if String.ends_with ~suffix:".bib" file_path then "application/x-bibtex"
87
-
else "application/octet-stream"
88
-
in
89
-
Log.info (fun m -> m "Served %s (%d bytes, %s)" file_path len mime_type);
90
-
Response.make_string ~headers:[("content-type", mime_type)] (Ok content)
91
-
end else begin
92
-
Log.warn (fun m -> m "File not found: %s" file_path);
93
-
not_found_response
94
-
end
95
-
with e ->
96
-
Log.err (fun m -> m "Failed to serve file %s: %s" file_path (Printexc.to_string e));
97
-
not_found_response
98
-
99
-
(** {1 HTML Output Helper} *)
100
-
101
-
let to_page el = Htmlit.El.to_string ~doctype:true el
102
-
103
-
(** {1 Entry Handlers} *)
104
-
105
-
let entries_handler ~extra_tags ~types req =
106
-
let q = get_query_info req in
107
-
let all_tags = Arod.Model.concat_tags q.tags (List.map Arod.Model.Tags.of_string extra_tags) in
108
-
html_response (to_page (view_entries ~show_all:q.show_all ~tags:all_tags ~min:q.min ~types (entries_of_req ~extra_tags ~types q)))
109
-
110
-
let feed_handler ~types req =
111
-
let q = get_query_info req in
112
-
html_response (to_page (view_news ~show_all:q.show_all ~tags:q.tags ~min:q.min ~types (feed_of_req ~types q)))
113
-
114
-
let feed_handler_with_tags ~extra_tags ~types req =
115
-
let q = get_query_info req in
116
-
let tags = Arod.Model.concat_tags q.tags (List.map Arod.Model.Tags.of_string extra_tags) in
117
-
let q = { q with tags } in
118
-
html_response (to_page (view_news ~show_all:q.show_all ~tags:q.tags ~min:q.min ~types (feed_of_req ~types q)))
119
-
120
-
let ideas_handler _req =
121
-
html_response (to_page (Arod.Ideas.view_ideas_by_project ()))
122
-
123
-
let projects_handler _req =
124
-
html_response (to_page (Arod.Projects.view_projects_timeline ()))
125
-
126
-
let index_handler req =
127
-
let q = get_query_info req in
128
-
match Arod.Model.lookup "index" with
129
-
| None -> not_found_response
130
-
| Some ent -> html_response (to_page (view_one q ent))
131
-
132
-
(** {1 Content Handlers} *)
133
-
134
-
let paper_handler cfg slug _req =
135
-
let q = get_query_info _req in
136
-
match slug with
137
-
| slug when String.ends_with ~suffix:".pdf" slug ->
138
-
serve_file ~dir:cfg.Arod.Config.paths.static_dir ("papers/" ^ slug)
139
-
| slug when String.ends_with ~suffix:".bib" slug ->
140
-
let paper_slug = Filename.chop_extension slug in
141
-
(match Arod.Model.lookup paper_slug with
142
-
| Some (`Paper p) -> plain_response (Arod.Model.Paper.bib p)
143
-
| _ -> not_found_response)
144
-
| _ ->
145
-
match Arod.Model.lookup slug with
146
-
| None -> not_found_response
147
-
| Some ent -> html_response (to_page (view_one q ent))
148
-
149
-
let content_handler slug req =
150
-
let q = get_query_info req in
151
-
match Arod.Model.lookup slug with
152
-
| None -> not_found_response
153
-
| Some ent -> html_response (to_page (view_one q ent))
154
-
155
-
let news_redirect_handler slug _req =
156
-
Response.make_raw ~code:301
157
-
~headers:[("Location", "/notes/" ^ slug)]
158
-
"Moved Permanently"
159
-
160
-
(** {1 Feed Handlers} *)
161
-
162
-
let atom_uri req =
163
-
let path = Request.path req in
164
-
let query = Request.query req in
165
-
if query = [] then path
166
-
else
167
-
let query_string = String.concat "&" (List.map (fun (k,v) -> k ^ "=" ^ v) query) in
168
-
path ^ "?" ^ query_string
169
-
170
-
let atom_handler cfg req =
171
-
try
172
-
let q = get_query_info req in
173
-
let feed = feed_of_req ~types:[] q in
174
-
let ur = atom_uri req in
175
-
let s = Arod.Feed.feed_string cfg ur feed in
176
-
atom_response s
177
-
with exn -> Printexc.print_backtrace stdout; raise exn
178
-
179
-
let perma_atom_handler cfg _req =
180
-
try
181
-
let feed = perma_feed_of_req () in
182
-
let s = Arod.Feed.feed_string cfg "/perma.xml" feed in
183
-
atom_response s
184
-
with exn -> Printexc.print_backtrace stdout; raise exn
185
-
186
-
let jsonfeed_handler cfg req =
187
-
try
188
-
let q = get_query_info req in
189
-
let feed = feed_of_req ~types:[] q in
190
-
let s = Arod.Jsonfeed.feed_string cfg "/feed.json" feed in
191
-
json_response s
192
-
with exn -> Printexc.print_backtrace stdout; raise exn
193
-
194
-
let perma_jsonfeed_handler cfg _req =
195
-
try
196
-
let feed = perma_feed_of_req () in
197
-
let s = Arod.Jsonfeed.feed_string cfg "/perma.json" feed in
198
-
json_response s
199
-
with exn -> Printexc.print_backtrace stdout; raise exn
200
-
201
-
(** {1 Sitemap Handler} *)
202
-
203
-
let sitemap_handler cfg _req =
204
-
let all_feed = Arod.Model.all_entries ()
205
-
|> List.sort Arod.Model.Entry.compare
206
-
|> List.rev in
207
-
let url_of_entry ent =
208
-
let lastmod = Arod.Model.Entry.date ent in
209
-
let loc = cfg.Arod.Config.site.base_url ^ Arod.Model.Entry.site_url ent in
210
-
Sitemap.v ~lastmod loc
211
-
in
212
-
let sitemap = List.map url_of_entry all_feed |> Sitemap.output in
213
-
xml_response sitemap
214
-
215
-
(** {1 Bushel Graph Handlers} *)
216
-
217
-
let bushel_graph_data_handler _req =
218
-
let entries = Arod.Model.get_entries () in
219
-
match Bushel.Link_graph.get_graph () with
220
-
| None ->
221
-
json_response "{\"error\": \"Link graph not initialized\"}"
222
-
| Some graph ->
223
-
let json = Bushel.Link_graph.to_json graph entries in
224
-
json_response (Ezjsonm.value_to_string json)
225
-
226
-
let bushel_graph_handler _req =
227
-
html_response (to_page (Arod.Page.bushel_graph ()))
228
-
229
-
(** {1 Pagination API Handler} *)
230
-
231
-
let pagination_api_handler req =
232
-
try
233
-
let collection_type = match get_query_param req "collection" with
234
-
| Some t -> t
235
-
| None -> failwith "Missing collection parameter"
236
-
in
237
-
let offset = match get_query_param req "offset" with
238
-
| Some o -> int_of_string o
239
-
| None -> 0
240
-
in
241
-
let limit = match get_query_param req "limit" with
242
-
| Some l -> int_of_string l
243
-
| None -> 25
244
-
in
245
-
let type_strings = get_query_params_multi req "type" in
246
-
let types = List.filter_map entry_type_of_string type_strings in
247
-
let q = get_query_info req in
248
-
249
-
let html = match collection_type with
250
-
| "feed" ->
251
-
let all_feed = feed_of_req ~types q in
252
-
let total = List.length all_feed in
253
-
let feed_slice =
254
-
all_feed
255
-
|> (fun l -> List.filteri (fun i _ -> i >= offset) l)
256
-
|> (fun l -> List.filteri (fun i _ -> i < limit) l)
257
-
in
258
-
let has_more = (offset + List.length feed_slice) < total in
259
-
(render_feeds_html feed_slice, total, has_more)
260
-
| "entries" ->
261
-
let all_ents = entries_of_req ~extra_tags:[] ~types q in
262
-
let total = List.length all_ents in
263
-
let ents_slice =
264
-
all_ents
265
-
|> (fun l -> List.filteri (fun i _ -> i >= offset) l)
266
-
|> (fun l -> List.filteri (fun i _ -> i < limit) l)
267
-
in
268
-
let has_more = (offset + List.length ents_slice) < total in
269
-
(render_entries_html ents_slice, total, has_more)
270
-
| _ -> failwith "Invalid collection type"
271
-
in
272
-
let rendered_html, total, has_more = html in
273
-
274
-
let json = `O [
275
-
("html", `String rendered_html);
276
-
("total", `Float (float_of_int total));
277
-
("offset", `Float (float_of_int offset));
278
-
("limit", `Float (float_of_int limit));
279
-
("has_more", `Bool has_more);
280
-
] in
281
-
json_response (Ezjsonm.to_string json)
282
-
with e ->
283
-
let error_json = `O [("error", `String (Printexc.to_string e))] in
284
-
json_response (Ezjsonm.to_string error_json)
285
-
286
-
(** {1 Well-Known Handler} *)
287
-
288
-
let well_known_handler cfg key _req =
289
-
match List.find_opt (fun e -> e.Arod.Config.key = key) cfg.Arod.Config.well_known with
290
-
| Some entry -> plain_response entry.value
291
-
| None -> not_found_response
292
-
293
-
(** {1 Server Setup} *)
294
-
295
-
let setup_routes server cfg =
296
-
let open Route in
297
-
298
-
(* Index routes *)
299
-
Server.add_route_handler ~meth:`GET server (exact_path "/" return) index_handler;
300
-
Server.add_route_handler ~meth:`GET server (exact_path "/about" return) index_handler;
301
-
Server.add_route_handler ~meth:`GET server (exact_path "/about/" return) index_handler;
302
-
303
-
(* Atom feeds *)
304
-
Server.add_route_handler ~meth:`GET server (exact_path "/wiki.xml" return) (atom_handler cfg);
305
-
Server.add_route_handler ~meth:`GET server (exact_path "/news.xml" return) (atom_handler cfg);
306
-
Server.add_route_handler ~meth:`GET server (exact_path "/feeds/atom.xml" return) (atom_handler cfg);
307
-
Server.add_route_handler ~meth:`GET server (exact_path "/notes/atom.xml" return) (atom_handler cfg);
308
-
Server.add_route_handler ~meth:`GET server (exact_path "/perma.xml" return) (perma_atom_handler cfg);
309
-
310
-
(* JSON feeds *)
311
-
Server.add_route_handler ~meth:`GET server (exact_path "/feed.json" return) (jsonfeed_handler cfg);
312
-
Server.add_route_handler ~meth:`GET server (exact_path "/feeds/feed.json" return) (jsonfeed_handler cfg);
313
-
Server.add_route_handler ~meth:`GET server (exact_path "/notes/feed.json" return) (jsonfeed_handler cfg);
314
-
Server.add_route_handler ~meth:`GET server (exact_path "/perma.json" return) (perma_jsonfeed_handler cfg);
315
-
316
-
(* Sitemap *)
317
-
Server.add_route_handler ~meth:`GET server (exact_path "/sitemap.xml" return) (sitemap_handler cfg);
318
-
319
-
(* Papers *)
320
-
Server.add_route_handler ~meth:`GET server (exact "papers" @/ string @/ return) (paper_handler cfg);
321
-
Server.add_route_handler ~meth:`GET server (exact "papers" @/ string @/ exact "" @/ return) (paper_handler cfg);
322
-
Server.add_route_handler ~meth:`GET server (exact_path "/papers" return) (entries_handler ~extra_tags:[] ~types:[`Paper]);
323
-
Server.add_route_handler ~meth:`GET server (exact_path "/papers/" return) (entries_handler ~extra_tags:[] ~types:[`Paper]);
324
-
325
-
(* Ideas *)
326
-
Server.add_route_handler ~meth:`GET server (exact "ideas" @/ string @/ return) content_handler;
327
-
Server.add_route_handler ~meth:`GET server (exact "ideas" @/ string @/ exact "" @/ return) content_handler;
328
-
Server.add_route_handler ~meth:`GET server (exact_path "/ideas" return) ideas_handler;
329
-
Server.add_route_handler ~meth:`GET server (exact_path "/ideas/" return) ideas_handler;
330
-
331
-
(* Notes *)
332
-
Server.add_route_handler ~meth:`GET server (exact "notes" @/ string @/ return) content_handler;
333
-
Server.add_route_handler ~meth:`GET server (exact "notes" @/ string @/ exact "" @/ return) content_handler;
334
-
Server.add_route_handler ~meth:`GET server (exact_path "/notes" return) (feed_handler_with_tags ~extra_tags:[] ~types:[`Note]);
335
-
Server.add_route_handler ~meth:`GET server (exact_path "/notes/" return) (feed_handler_with_tags ~extra_tags:[] ~types:[`Note]);
336
-
337
-
(* Videos/Talks *)
338
-
Server.add_route_handler ~meth:`GET server (exact "videos" @/ string @/ return) content_handler;
339
-
Server.add_route_handler ~meth:`GET server (exact "videos" @/ string @/ exact "" @/ return) content_handler;
340
-
Server.add_route_handler ~meth:`GET server (exact_path "/talks" return) (feed_handler_with_tags ~extra_tags:[] ~types:[`Video]);
341
-
Server.add_route_handler ~meth:`GET server (exact_path "/talks/" return) (feed_handler_with_tags ~extra_tags:[] ~types:[`Video]);
342
-
Server.add_route_handler ~meth:`GET server (exact_path "/videos" return) (feed_handler_with_tags ~extra_tags:[] ~types:[`Video]);
343
-
Server.add_route_handler ~meth:`GET server (exact_path "/videos/" return) (feed_handler_with_tags ~extra_tags:[] ~types:[`Video]);
344
-
345
-
(* Projects *)
346
-
Server.add_route_handler ~meth:`GET server (exact "projects" @/ string @/ return) content_handler;
347
-
Server.add_route_handler ~meth:`GET server (exact "projects" @/ string @/ exact "" @/ return) content_handler;
348
-
Server.add_route_handler ~meth:`GET server (exact_path "/projects" return) projects_handler;
349
-
Server.add_route_handler ~meth:`GET server (exact_path "/projects/" return) projects_handler;
350
-
351
-
(* Legacy news redirect *)
352
-
Server.add_route_handler ~meth:`GET server (exact "news" @/ string @/ return) news_redirect_handler;
353
-
354
-
(* Wiki/News legacy *)
355
-
Server.add_route_handler ~meth:`GET server (exact_path "/wiki" return) (entries_handler ~extra_tags:[] ~types:[`Paper; `Note; `Video; `Idea; `Project]);
356
-
Server.add_route_handler ~meth:`GET server (exact_path "/news" return) (feed_handler ~types:[`Note]);
357
-
358
-
(* Pagination API *)
359
-
Server.add_route_handler ~meth:`GET server (exact_path "/api/entries" return) pagination_api_handler;
360
-
361
-
(* Bushel link graph *)
362
-
Server.add_route_handler ~meth:`GET server (exact_path "/bushel" return) bushel_graph_handler;
363
-
Server.add_route_handler ~meth:`GET server (exact_path "/bushel/" return) bushel_graph_handler;
364
-
Server.add_route_handler ~meth:`GET server (exact_path "/bushel/graph.json" return) bushel_graph_data_handler;
365
-
366
-
(* Well-known endpoints *)
367
-
Server.add_route_handler ~meth:`GET server (exact ".well-known" @/ string @/ return) (well_known_handler cfg);
368
-
369
-
(* Robots.txt *)
370
-
Server.add_route_handler ~meth:`GET server (exact_path "/robots.txt" return)
371
-
(fun _req -> serve_file ~dir:cfg.paths.assets_dir "robots.txt");
372
-
373
-
(* Static files *)
374
-
Server.add_route_handler ~meth:`GET server (exact "assets" @/ rest_of_path)
375
-
(fun path _req -> serve_file ~dir:cfg.paths.assets_dir path);
376
-
Server.add_route_handler ~meth:`GET server (exact "images" @/ rest_of_path)
377
-
(fun path _req -> serve_file ~dir:cfg.paths.images_dir path);
378
-
Server.add_route_handler ~meth:`GET server (exact "static" @/ rest_of_path)
379
-
(fun path _req -> serve_file ~dir:cfg.paths.static_dir path);
380
-
381
-
()
12
+
module Log = (val Logs.src_log src : Logs.LOG)
382
13
383
14
(** {1 CLI} *)
384
15
···
395
26
396
27
let config_file =
397
28
let doc = "Path to config file (default: ~/.config/arod/config.toml)." in
398
-
Arg.(value & opt (some file) None & info ["c"; "config"] ~docv:"FILE" ~doc)
29
+
Arg.(value & opt (some file) None & info [ "c"; "config" ] ~docv:"FILE" ~doc)
30
+
31
+
let memo_ttl =
32
+
let doc = "TTL in seconds for memoized routes (default: 300.0)." in
33
+
Arg.(value & opt float 300.0 & info [ "memo-ttl" ] ~docv:"SECONDS" ~doc)
399
34
400
35
let serve_cmd =
401
-
let run () config_file =
36
+
let run () config_file memo_ttl =
402
37
let cfg = Arod.Config.load_or_default ?path:config_file () in
403
38
Log.info (fun m -> m "Starting Arod server...");
404
39
Log.info (fun m -> m "Config:@.%a" Arod.Config.pp cfg);
405
-
406
40
Eio_main.run @@ fun env ->
407
41
let fs = Eio.Stdenv.fs env in
408
-
409
42
Log.info (fun m -> m "Loading entries from %s" cfg.paths.data_dir);
410
43
let _entries = Arod.Model.init ~cfg fs in
411
-
Log.info (fun m -> m "Loaded %d notes, %d papers, %d projects, %d ideas, %d videos, %d images"
412
-
(List.length (Arod.Model.notes ()))
413
-
(List.length (Arod.Model.papers ()))
414
-
(List.length (Arod.Model.projects ()))
415
-
(List.length (Arod.Model.ideas ()))
416
-
(List.length (Arod.Model.videos ()))
417
-
(List.length (Arod.Model.images ())));
418
-
419
-
let server = Tiny_httpd.create ~addr:cfg.server.host ~port:cfg.server.port () in
420
-
421
-
Tiny_httpd.add_middleware server ~stage:(`Stage 1) (fun h req ->
422
-
let start_time = Unix.gettimeofday () in
423
-
let resp = h req in
424
-
let elapsed = Unix.gettimeofday () -. start_time in
425
-
Log.info (fun m -> m "%s %s - %.3fs"
426
-
(Meth.to_string (Request.meth req))
427
-
(Request.path req)
428
-
elapsed);
429
-
resp
430
-
);
431
-
432
-
setup_routes server cfg;
433
-
434
-
Log.app (fun m -> m "Listening on http://%s:%d" cfg.server.host cfg.server.port);
435
-
match Tiny_httpd.run server with
44
+
Log.info (fun m ->
45
+
m "Loaded %d notes, %d papers, %d projects, %d ideas, %d videos, %d images"
46
+
(List.length (Arod.Model.notes ()))
47
+
(List.length (Arod.Model.papers ()))
48
+
(List.length (Arod.Model.projects ()))
49
+
(List.length (Arod.Model.ideas ()))
50
+
(List.length (Arod.Model.videos ()))
51
+
(List.length (Arod.Model.images ())));
52
+
(* Create memoization cache *)
53
+
let memo_cache = Arod.Memo.create ~ttl:memo_ttl () in
54
+
(* Get all routes *)
55
+
let routes = Arod.Handlers.all_routes cfg in
56
+
(* Run the server *)
57
+
match Arod_server.run ~config:cfg ~memo_cache routes with
436
58
| Ok () -> 0
437
59
| Error e ->
438
-
Log.err (fun m -> m "Server error: %s" (Printexc.to_string e));
439
-
1
60
+
Log.err (fun m -> m "Server error: %s" (Printexc.to_string e));
61
+
1
440
62
in
441
63
let doc = "Start the Arod webserver." in
442
64
let info = Cmd.info "serve" ~doc in
443
-
Cmd.v info Term.(const run $ logging_t $ config_file)
65
+
Cmd.v info Term.(const run $ logging_t $ config_file $ memo_ttl)
444
66
445
67
let init_cmd =
446
68
let run () =
447
69
let path = Arod.Config.config_file () in
448
70
let dir = Filename.dirname path in
449
-
if not (Sys.file_exists dir) then
450
-
Unix.mkdir dir 0o755;
71
+
if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;
451
72
if Sys.file_exists path then begin
452
73
Printf.eprintf "Config file already exists: %s\n" path;
453
74
1
454
-
end else begin
75
+
end
76
+
else begin
455
77
let oc = open_out path in
456
78
output_string oc Arod.Config.sample_config;
457
79
close_out oc;
···
475
97
476
98
let main_cmd =
477
99
let doc = "Arod - a webserver for Bushel content" in
478
-
let man = [
479
-
`S Manpage.s_description;
480
-
`P "Arod is a tiny_httpd-based webserver that serves Bushel content \
481
-
(notes, papers, projects, ideas, videos) as a website.";
482
-
`S "CONFIGURATION";
483
-
`P "Configuration is read from ~/.config/arod/config.toml";
484
-
`P "Run $(b,arod init) to create a default config file.";
485
-
] in
100
+
let man =
101
+
[
102
+
`S Manpage.s_description;
103
+
`P
104
+
"Arod is a tiny_httpd-based webserver that serves Bushel content \
105
+
(notes, papers, projects, ideas, videos) as a website.";
106
+
`S "CONFIGURATION";
107
+
`P "Configuration is read from ~/.config/arod/config.toml";
108
+
`P "Run $(b,arod init) to create a default config file.";
109
+
]
110
+
in
486
111
let info = Cmd.info "arod" ~version:"0.1.0" ~doc ~man in
487
-
Cmd.group info [serve_cmd; init_cmd; config_cmd]
112
+
Cmd.group info [ serve_cmd; init_cmd; config_cmd ]
488
113
489
114
let () =
490
115
match Cmd.eval_value main_cmd with
+9
arod/lib/arod.ml
+9
arod/lib/arod.ml
···
60
60
61
61
module Html = Arod_html
62
62
(** Legacy HTML generation (for compatibility). *)
63
+
64
+
module Route = Arod_route
65
+
(** Framework-agnostic HTTP routing. *)
66
+
67
+
module Memo = Arod_memo
68
+
(** Memoization cache with TTL. *)
69
+
70
+
module Handlers = Arod_handlers
71
+
(** Pure route handlers. *)
+397
arod/lib/arod_handlers.ml
+397
arod/lib/arod_handlers.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Pure route handlers for arod *)
7
+
8
+
open Arod_entries
9
+
10
+
(** {1 Query Information} *)
11
+
12
+
type query_info = Arod_entries.query_info = {
13
+
tags : Arod_model.Tags.t list;
14
+
min : int;
15
+
show_all : bool;
16
+
}
17
+
18
+
let query_info_of_request req : query_info =
19
+
let tags =
20
+
Arod_route.Request.query_params req "t"
21
+
|> List.map Arod_model.Tags.of_string
22
+
in
23
+
let min =
24
+
match Arod_route.Request.query_param req "min" with
25
+
| None -> 25
26
+
| Some v -> ( try int_of_string v with _ -> 25 )
27
+
in
28
+
let show_all =
29
+
match Arod_route.Request.query_param req "all" with
30
+
| None -> false
31
+
| Some _ -> true
32
+
in
33
+
{ tags; min; show_all }
34
+
35
+
(** {1 Response Helpers} *)
36
+
37
+
let to_page el = Htmlit.El.to_string ~doctype:true el
38
+
39
+
let html_response content = Arod_route.Response.html content
40
+
let json_response content = Arod_route.Response.json content
41
+
let atom_response content = Arod_route.Response.atom content
42
+
let xml_response content = Arod_route.Response.xml content
43
+
let plain_response content = Arod_route.Response.plain content
44
+
let not_found_response = Arod_route.Response.not_found
45
+
46
+
(** {1 File Serving} *)
47
+
48
+
let mime_type_of_path path =
49
+
if String.ends_with ~suffix:".pdf" path then "application/pdf"
50
+
else if String.ends_with ~suffix:".html" path then "text/html"
51
+
else if String.ends_with ~suffix:".css" path then "text/css"
52
+
else if String.ends_with ~suffix:".js" path then "text/javascript"
53
+
else if String.ends_with ~suffix:".svg" path then "image/svg+xml"
54
+
else if String.ends_with ~suffix:".png" path then "image/png"
55
+
else if String.ends_with ~suffix:".jpg" path then "image/jpeg"
56
+
else if String.ends_with ~suffix:".jpeg" path then "image/jpeg"
57
+
else if String.ends_with ~suffix:".webp" path then "image/webp"
58
+
else if String.ends_with ~suffix:".xml" path then "application/xml"
59
+
else if String.ends_with ~suffix:".wasm" path then "application/wasm"
60
+
else if String.ends_with ~suffix:".ico" path then "image/x-icon"
61
+
else if String.ends_with ~suffix:".woff" path then "font/woff"
62
+
else if String.ends_with ~suffix:".woff2" path then "font/woff2"
63
+
else if String.ends_with ~suffix:".bib" path then "application/x-bibtex"
64
+
else "application/octet-stream"
65
+
66
+
let static_file ~dir path _req =
67
+
let clean_path =
68
+
let parts = String.split_on_char '/' path in
69
+
let safe_parts = List.filter (fun s -> s <> ".." && s <> ".") parts in
70
+
String.concat "/" safe_parts
71
+
in
72
+
let file_path = Filename.concat dir clean_path in
73
+
try
74
+
if Sys.file_exists file_path && not (Sys.is_directory file_path) then begin
75
+
let ic = open_in_bin file_path in
76
+
let len = in_channel_length ic in
77
+
let content = really_input_string ic len in
78
+
close_in ic;
79
+
let mime = mime_type_of_path file_path in
80
+
Arod_route.Response.raw ~status:200
81
+
~headers:[ ("content-type", mime) ]
82
+
content
83
+
end
84
+
else not_found_response
85
+
with _ -> not_found_response
86
+
87
+
(** {1 Entry Handlers} *)
88
+
89
+
let entries_handler ~extra_tags ~types req =
90
+
let q = query_info_of_request req in
91
+
let all_tags =
92
+
Arod_model.concat_tags q.tags (List.map Arod_model.Tags.of_string extra_tags)
93
+
in
94
+
html_response
95
+
(to_page
96
+
(view_entries ~show_all:q.show_all ~tags:all_tags ~min:q.min ~types
97
+
(entries_of_req ~extra_tags ~types { tags = q.tags; min = q.min; show_all = q.show_all })))
98
+
99
+
let feed_handler ~types req =
100
+
let q = query_info_of_request req in
101
+
html_response
102
+
(to_page
103
+
(view_news ~show_all:q.show_all ~tags:q.tags ~min:q.min ~types
104
+
(feed_of_req ~types { tags = q.tags; min = q.min; show_all = q.show_all })))
105
+
106
+
let feed_handler_with_tags ~extra_tags ~types req =
107
+
let q = query_info_of_request req in
108
+
let tags =
109
+
Arod_model.concat_tags q.tags (List.map Arod_model.Tags.of_string extra_tags)
110
+
in
111
+
let q' = { tags; min = q.min; show_all = q.show_all } in
112
+
html_response
113
+
(to_page
114
+
(view_news ~show_all:q'.show_all ~tags:q'.tags ~min:q'.min ~types
115
+
(feed_of_req ~types q')))
116
+
117
+
(** {1 Content Handlers} *)
118
+
119
+
let index req =
120
+
let q = query_info_of_request req in
121
+
match Arod_model.lookup "index" with
122
+
| None -> not_found_response
123
+
| Some ent ->
124
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent))
125
+
126
+
let papers = entries_handler ~extra_tags:[] ~types:[ `Paper ]
127
+
128
+
let paper cfg ((), slug) req =
129
+
let q = query_info_of_request req in
130
+
match slug with
131
+
| slug when String.ends_with ~suffix:".pdf" slug ->
132
+
static_file ~dir:cfg.Arod_config.paths.static_dir ("papers/" ^ slug) req
133
+
| slug when String.ends_with ~suffix:".bib" slug ->
134
+
let paper_slug = Filename.chop_extension slug in
135
+
( match Arod_model.lookup paper_slug with
136
+
| Some (`Paper p) -> plain_response (Arod_model.Paper.bib p)
137
+
| _ -> not_found_response )
138
+
| _ -> (
139
+
match Arod_model.lookup slug with
140
+
| None -> not_found_response
141
+
| Some ent ->
142
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent)) )
143
+
144
+
let notes = feed_handler_with_tags ~extra_tags:[] ~types:[ `Note ]
145
+
146
+
let note ((), slug) req =
147
+
let q = query_info_of_request req in
148
+
match Arod_model.lookup slug with
149
+
| None -> not_found_response
150
+
| Some ent ->
151
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent))
152
+
153
+
let ideas _req = html_response (to_page (Arod_ideas.view_ideas_by_project ()))
154
+
155
+
let idea ((), slug) req =
156
+
let q = query_info_of_request req in
157
+
match Arod_model.lookup slug with
158
+
| None -> not_found_response
159
+
| Some ent ->
160
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent))
161
+
162
+
let projects _req = html_response (to_page (Arod_projects.view_projects_timeline ()))
163
+
164
+
let project ((), slug) req =
165
+
let q = query_info_of_request req in
166
+
match Arod_model.lookup slug with
167
+
| None -> not_found_response
168
+
| Some ent ->
169
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent))
170
+
171
+
let videos = feed_handler_with_tags ~extra_tags:[] ~types:[ `Video ]
172
+
173
+
let video ((), slug) req =
174
+
let q = query_info_of_request req in
175
+
match Arod_model.lookup slug with
176
+
| None -> not_found_response
177
+
| Some ent ->
178
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent))
179
+
180
+
let content ((), slug) req =
181
+
let q = query_info_of_request req in
182
+
match Arod_model.lookup slug with
183
+
| None -> not_found_response
184
+
| Some ent ->
185
+
html_response (to_page (view_one { tags = q.tags; min = q.min; show_all = q.show_all } ent))
186
+
187
+
(** {1 Legacy Handlers} *)
188
+
189
+
let news_redirect ((), slug) _req =
190
+
Arod_route.Response.redirect ~code:301 ~location:("/notes/" ^ slug)
191
+
192
+
let wiki = entries_handler ~extra_tags:[] ~types:[ `Paper; `Note; `Video; `Idea; `Project ]
193
+
194
+
let news = feed_handler ~types:[ `Note ]
195
+
196
+
(** {1 Feed Handlers} *)
197
+
198
+
let atom_uri req =
199
+
let path = Arod_route.Request.path req in
200
+
let query = Arod_route.Request.query req in
201
+
if query = [] then path
202
+
else
203
+
let query_string =
204
+
String.concat "&" (List.map (fun (k, v) -> k ^ "=" ^ v) query)
205
+
in
206
+
path ^ "?" ^ query_string
207
+
208
+
let atom_feed cfg req =
209
+
let q = query_info_of_request req in
210
+
let feed = feed_of_req ~types:[] { tags = q.tags; min = q.min; show_all = q.show_all } in
211
+
let ur = atom_uri req in
212
+
let s = Arod_feed.feed_string cfg ur feed in
213
+
atom_response s
214
+
215
+
let json_feed cfg req =
216
+
let q = query_info_of_request req in
217
+
let feed = feed_of_req ~types:[] { tags = q.tags; min = q.min; show_all = q.show_all } in
218
+
let s = Arod_jsonfeed.feed_string cfg "/feed.json" feed in
219
+
json_response s
220
+
221
+
let perma_atom cfg _req =
222
+
let feed = perma_feed_of_req () in
223
+
let s = Arod_feed.feed_string cfg "/perma.xml" feed in
224
+
atom_response s
225
+
226
+
let perma_json cfg _req =
227
+
let feed = perma_feed_of_req () in
228
+
let s = Arod_jsonfeed.feed_string cfg "/perma.json" feed in
229
+
json_response s
230
+
231
+
(** {1 Utility Handlers} *)
232
+
233
+
let sitemap cfg _req =
234
+
let all_feed =
235
+
Arod_model.all_entries ()
236
+
|> List.sort Arod_model.Entry.compare
237
+
|> List.rev
238
+
in
239
+
let url_of_entry ent =
240
+
let lastmod = Arod_model.Entry.date ent in
241
+
let loc = cfg.Arod_config.site.base_url ^ Arod_model.Entry.site_url ent in
242
+
Sitemap.v ~lastmod loc
243
+
in
244
+
let sitemap_xml = List.map url_of_entry all_feed |> Sitemap.output in
245
+
xml_response sitemap_xml
246
+
247
+
let bushel_graph _req = html_response (to_page (Arod_page.bushel_graph ()))
248
+
249
+
let bushel_graph_data _req =
250
+
let entries = Arod_model.get_entries () in
251
+
match Bushel.Link_graph.get_graph () with
252
+
| None -> json_response {|{"error": "Link graph not initialized"}|}
253
+
| Some graph ->
254
+
let json = Bushel.Link_graph.to_json graph entries in
255
+
json_response (Ezjsonm.value_to_string json)
256
+
257
+
let pagination_api req =
258
+
try
259
+
let collection_type =
260
+
match Arod_route.Request.query_param req "collection" with
261
+
| Some t -> t
262
+
| None -> failwith "Missing collection parameter"
263
+
in
264
+
let offset =
265
+
match Arod_route.Request.query_param req "offset" with
266
+
| Some o -> int_of_string o
267
+
| None -> 0
268
+
in
269
+
let limit =
270
+
match Arod_route.Request.query_param req "limit" with
271
+
| Some l -> int_of_string l
272
+
| None -> 25
273
+
in
274
+
let type_strings = Arod_route.Request.query_params req "type" in
275
+
let types = List.filter_map entry_type_of_string type_strings in
276
+
let q = query_info_of_request req in
277
+
let q' = { tags = q.tags; min = q.min; show_all = q.show_all } in
278
+
let html =
279
+
match collection_type with
280
+
| "feed" ->
281
+
let all_feed = feed_of_req ~types q' in
282
+
let total = List.length all_feed in
283
+
let feed_slice =
284
+
all_feed
285
+
|> (fun l -> List.filteri (fun i _ -> i >= offset) l)
286
+
|> (fun l -> List.filteri (fun i _ -> i < limit) l)
287
+
in
288
+
let has_more = offset + List.length feed_slice < total in
289
+
(render_feeds_html feed_slice, total, has_more)
290
+
| "entries" ->
291
+
let all_ents = entries_of_req ~extra_tags:[] ~types q' in
292
+
let total = List.length all_ents in
293
+
let ents_slice =
294
+
all_ents
295
+
|> (fun l -> List.filteri (fun i _ -> i >= offset) l)
296
+
|> (fun l -> List.filteri (fun i _ -> i < limit) l)
297
+
in
298
+
let has_more = offset + List.length ents_slice < total in
299
+
(render_entries_html ents_slice, total, has_more)
300
+
| _ -> failwith "Invalid collection type"
301
+
in
302
+
let rendered_html, total, has_more = html in
303
+
let json =
304
+
`O
305
+
[
306
+
("html", `String rendered_html);
307
+
("total", `Float (float_of_int total));
308
+
("offset", `Float (float_of_int offset));
309
+
("limit", `Float (float_of_int limit));
310
+
("has_more", `Bool has_more);
311
+
]
312
+
in
313
+
json_response (Ezjsonm.to_string json)
314
+
with e ->
315
+
let error_json = `O [ ("error", `String (Printexc.to_string e)) ] in
316
+
json_response (Ezjsonm.to_string error_json)
317
+
318
+
let well_known cfg ((), key) _req =
319
+
match
320
+
List.find_opt (fun e -> e.Arod_config.key = key) cfg.Arod_config.well_known
321
+
with
322
+
| Some entry -> plain_response entry.value
323
+
| None -> not_found_response
324
+
325
+
let robots_txt cfg req =
326
+
static_file ~dir:cfg.Arod_config.paths.assets_dir "robots.txt" req
327
+
328
+
(** {1 Route Collection} *)
329
+
330
+
let all_routes cfg =
331
+
let open Arod_route in
332
+
Routes.of_list
333
+
[
334
+
(* Index routes *)
335
+
get_ [] index;
336
+
get_ [ "about" ] index;
337
+
get_ [ "about"; "" ] index;
338
+
(* Atom feeds *)
339
+
get_ [ "wiki.xml" ] (atom_feed cfg);
340
+
get_ [ "news.xml" ] (atom_feed cfg);
341
+
get_ [ "feeds"; "atom.xml" ] (atom_feed cfg);
342
+
get_ [ "notes"; "atom.xml" ] (atom_feed cfg);
343
+
get_ [ "perma.xml" ] (perma_atom cfg);
344
+
(* JSON feeds *)
345
+
get_ [ "feed.json" ] (json_feed cfg);
346
+
get_ [ "feeds"; "feed.json" ] (json_feed cfg);
347
+
get_ [ "notes"; "feed.json" ] (json_feed cfg);
348
+
get_ [ "perma.json" ] (perma_json cfg);
349
+
(* Sitemap *)
350
+
get_ [ "sitemap.xml" ] (sitemap cfg);
351
+
(* Papers *)
352
+
get (exact "papers" @/ param) (paper cfg);
353
+
get (exact "papers" @/ param @/ exact "") (fun ((), (slug, ())) -> paper cfg ((), slug));
354
+
get_ [ "papers" ] papers;
355
+
get_ [ "papers"; "" ] papers;
356
+
(* Ideas *)
357
+
get (exact "ideas" @/ param) idea;
358
+
get (exact "ideas" @/ param @/ exact "") (fun ((), (slug, ())) -> idea ((), slug));
359
+
get_ [ "ideas" ] ideas;
360
+
get_ [ "ideas"; "" ] ideas;
361
+
(* Notes *)
362
+
get (exact "notes" @/ param) note;
363
+
get (exact "notes" @/ param @/ exact "") (fun ((), (slug, ())) -> note ((), slug));
364
+
get_ [ "notes" ] notes;
365
+
get_ [ "notes"; "" ] notes;
366
+
(* Videos/Talks *)
367
+
get (exact "videos" @/ param) video;
368
+
get (exact "videos" @/ param @/ exact "") (fun ((), (slug, ())) -> video ((), slug));
369
+
get_ [ "talks" ] videos;
370
+
get_ [ "talks"; "" ] videos;
371
+
get_ [ "videos" ] videos;
372
+
get_ [ "videos"; "" ] videos;
373
+
(* Projects *)
374
+
get (exact "projects" @/ param) project;
375
+
get (exact "projects" @/ param @/ exact "") (fun ((), (slug, ())) -> project ((), slug));
376
+
get_ [ "projects" ] projects;
377
+
get_ [ "projects"; "" ] projects;
378
+
(* Legacy news redirect *)
379
+
get (exact "news" @/ param) news_redirect;
380
+
(* Wiki/News legacy *)
381
+
get_ [ "wiki" ] wiki;
382
+
get_ [ "news" ] news;
383
+
(* Pagination API *)
384
+
get_ [ "api"; "entries" ] pagination_api;
385
+
(* Bushel link graph *)
386
+
get_ [ "bushel" ] bushel_graph;
387
+
get_ [ "bushel"; "" ] bushel_graph;
388
+
get_ [ "bushel"; "graph.json" ] bushel_graph_data;
389
+
(* Well-known endpoints *)
390
+
get (exact ".well-known" @/ param) (well_known cfg);
391
+
(* Robots.txt *)
392
+
get_ [ "robots.txt" ] (robots_txt cfg);
393
+
(* Static files *)
394
+
get (exact "assets" @/ rest) (fun ((), path) -> static_file ~dir:cfg.paths.assets_dir path);
395
+
get (exact "images" @/ rest) (fun ((), path) -> static_file ~dir:cfg.paths.images_dir path);
396
+
get (exact "static" @/ rest) (fun ((), path) -> static_file ~dir:cfg.paths.static_dir path);
397
+
]
+122
arod/lib/arod_handlers.mli
+122
arod/lib/arod_handlers.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Pure route handlers for arod
7
+
8
+
This module contains all the HTTP route handlers as pure functions that
9
+
operate on the framework-agnostic [Arod_route.Request] and
10
+
[Arod_route.Response] types. The handlers are designed to be reusable
11
+
across different HTTP server implementations. *)
12
+
13
+
(** {1 Query Information}
14
+
15
+
Query parameters extracted from requests for filtering and pagination. *)
16
+
17
+
type query_info = {
18
+
tags : Arod_model.Tags.t list; (** Tag filters from ?t= parameters *)
19
+
min : int; (** Minimum items to show, from ?min= parameter (default 25) *)
20
+
show_all : bool; (** Whether to show all items, from ?all parameter *)
21
+
}
22
+
(** Query information extracted from a request. *)
23
+
24
+
val query_info_of_request : Arod_route.Request.t -> query_info
25
+
(** [query_info_of_request req] extracts tag filters, min count, and show_all
26
+
flag from request query parameters. *)
27
+
28
+
(** {1 Content Handlers}
29
+
30
+
Handlers for individual content pages and listings. *)
31
+
32
+
val index : Arod_route.Request.t -> Arod_route.Response.t
33
+
(** Handler for the index/home page. *)
34
+
35
+
val papers : Arod_route.Request.t -> Arod_route.Response.t
36
+
(** Handler for the papers listing page. *)
37
+
38
+
val paper : Arod_config.t -> (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
39
+
(** [paper cfg ((), slug) req] handles individual paper pages or PDF/bib downloads. *)
40
+
41
+
val notes : Arod_route.Request.t -> Arod_route.Response.t
42
+
(** Handler for the notes listing page. *)
43
+
44
+
val note : (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
45
+
(** [note ((), slug) req] handles individual note pages. *)
46
+
47
+
val ideas : Arod_route.Request.t -> Arod_route.Response.t
48
+
(** Handler for the ideas listing page. *)
49
+
50
+
val idea : (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
51
+
(** [idea ((), slug) req] handles individual idea pages. *)
52
+
53
+
val projects : Arod_route.Request.t -> Arod_route.Response.t
54
+
(** Handler for the projects listing page. *)
55
+
56
+
val project : (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
57
+
(** [project ((), slug) req] handles individual project pages. *)
58
+
59
+
val videos : Arod_route.Request.t -> Arod_route.Response.t
60
+
(** Handler for the videos/talks listing page. *)
61
+
62
+
val video : (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
63
+
(** [video ((), slug) req] handles individual video pages. *)
64
+
65
+
val content : (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
66
+
(** [content ((), slug) req] generic content handler that looks up any entry by slug. *)
67
+
68
+
(** {1 Legacy Handlers} *)
69
+
70
+
val news_redirect : (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
71
+
(** [news_redirect ((), slug) req] redirects /news/slug to /notes/slug. *)
72
+
73
+
val wiki : Arod_route.Request.t -> Arod_route.Response.t
74
+
(** Handler for legacy /wiki endpoint. *)
75
+
76
+
val news : Arod_route.Request.t -> Arod_route.Response.t
77
+
(** Handler for legacy /news endpoint. *)
78
+
79
+
(** {1 Feed Handlers} *)
80
+
81
+
val atom_feed : Arod_config.t -> Arod_route.Request.t -> Arod_route.Response.t
82
+
(** Handler for Atom feed generation. *)
83
+
84
+
val json_feed : Arod_config.t -> Arod_route.Request.t -> Arod_route.Response.t
85
+
(** Handler for JSON feed generation. *)
86
+
87
+
val perma_atom : Arod_config.t -> Arod_route.Request.t -> Arod_route.Response.t
88
+
(** Handler for permanent/archival Atom feed. *)
89
+
90
+
val perma_json : Arod_config.t -> Arod_route.Request.t -> Arod_route.Response.t
91
+
(** Handler for permanent/archival JSON feed. *)
92
+
93
+
(** {1 Utility Handlers} *)
94
+
95
+
val sitemap : Arod_config.t -> Arod_route.Request.t -> Arod_route.Response.t
96
+
(** Handler for sitemap.xml generation. *)
97
+
98
+
val bushel_graph : Arod_route.Request.t -> Arod_route.Response.t
99
+
(** Handler for the Bushel link graph visualization page. *)
100
+
101
+
val bushel_graph_data : Arod_route.Request.t -> Arod_route.Response.t
102
+
(** Handler for the Bushel link graph JSON data. *)
103
+
104
+
val pagination_api : Arod_route.Request.t -> Arod_route.Response.t
105
+
(** Handler for the pagination API endpoint. *)
106
+
107
+
val well_known : Arod_config.t -> (unit * string) -> Arod_route.Request.t -> Arod_route.Response.t
108
+
(** [well_known cfg ((), key) req] handles .well-known/[key] endpoints. *)
109
+
110
+
val robots_txt : Arod_config.t -> Arod_route.Request.t -> Arod_route.Response.t
111
+
(** Handler for robots.txt. *)
112
+
113
+
(** {1 Static File Serving} *)
114
+
115
+
val static_file : dir:string -> string -> Arod_route.Request.t -> Arod_route.Response.t
116
+
(** [static_file ~dir path req] serves a file from [dir]/[path] with
117
+
appropriate MIME type. Returns 404 if file not found. *)
118
+
119
+
(** {1 Route Collection} *)
120
+
121
+
val all_routes : Arod_config.t -> Arod_route.Routes.t
122
+
(** [all_routes cfg] returns all routes for the arod application. *)
+55
arod/lib/arod_memo.ml
+55
arod/lib/arod_memo.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Memoization cache with TTL *)
7
+
8
+
type 'a entry = { value : 'a; timestamp : float }
9
+
10
+
type 'a t = {
11
+
ttl : float;
12
+
entries : (string, 'a entry) Hashtbl.t;
13
+
mutable hits : int;
14
+
mutable misses : int;
15
+
}
16
+
17
+
let create ~ttl () =
18
+
{ ttl; entries = Hashtbl.create 16; hits = 0; misses = 0 }
19
+
20
+
let get cache ~key =
21
+
match Hashtbl.find_opt cache.entries key with
22
+
| None ->
23
+
cache.misses <- cache.misses + 1;
24
+
None
25
+
| Some entry ->
26
+
let now = Unix.gettimeofday () in
27
+
if now -. entry.timestamp > cache.ttl then begin
28
+
Hashtbl.remove cache.entries key;
29
+
cache.misses <- cache.misses + 1;
30
+
None
31
+
end
32
+
else begin
33
+
cache.hits <- cache.hits + 1;
34
+
Some entry.value
35
+
end
36
+
37
+
let set cache ~key value =
38
+
let entry = { value; timestamp = Unix.gettimeofday () } in
39
+
Hashtbl.replace cache.entries key entry
40
+
41
+
let clear cache =
42
+
Hashtbl.clear cache.entries;
43
+
cache.hits <- 0;
44
+
cache.misses <- 0
45
+
46
+
let stats cache = (cache.hits, cache.misses)
47
+
48
+
let memoize cache handler req =
49
+
let key = Arod_route.Request.cache_key req in
50
+
match get cache ~key with
51
+
| Some response -> response
52
+
| None ->
53
+
let response = handler req in
54
+
set cache ~key response;
55
+
response
+38
arod/lib/arod_memo.mli
+38
arod/lib/arod_memo.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Memoization cache with TTL
7
+
8
+
This module provides a simple in-memory cache with time-to-live (TTL)
9
+
expiration. It is useful for caching expensive computations like feed
10
+
generation where the result can be reused for a period of time. *)
11
+
12
+
type 'a t
13
+
(** The type of a cache storing values of type ['a]. *)
14
+
15
+
val create : ttl:float -> unit -> 'a t
16
+
(** [create ~ttl ()] creates a cache where entries expire after [ttl] seconds. *)
17
+
18
+
val get : 'a t -> key:string -> 'a option
19
+
(** [get cache ~key] returns the cached value if present and not expired. *)
20
+
21
+
val set : 'a t -> key:string -> 'a -> unit
22
+
(** [set cache ~key value] stores [value] in the cache with the current
23
+
timestamp. *)
24
+
25
+
val clear : 'a t -> unit
26
+
(** [clear cache] removes all entries from the cache. *)
27
+
28
+
val stats : 'a t -> int * int
29
+
(** [stats cache] returns [(hits, misses)] statistics. *)
30
+
31
+
val memoize :
32
+
Arod_route.Response.t t ->
33
+
(Arod_route.Request.t -> Arod_route.Response.t) ->
34
+
Arod_route.Request.t ->
35
+
Arod_route.Response.t
36
+
(** [memoize cache handler] wraps [handler] to cache responses by the
37
+
request's [cache_key]. Cached responses are returned directly; cache misses
38
+
invoke the handler and store the result. *)
+235
arod/lib/arod_route.ml
+235
arod/lib/arod_route.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Framework-agnostic HTTP routing *)
7
+
8
+
type meth = [ `GET | `POST | `PUT | `DELETE | `HEAD | `OPTIONS ]
9
+
10
+
let meth_to_string = function
11
+
| `GET -> "GET"
12
+
| `POST -> "POST"
13
+
| `PUT -> "PUT"
14
+
| `DELETE -> "DELETE"
15
+
| `HEAD -> "HEAD"
16
+
| `OPTIONS -> "OPTIONS"
17
+
18
+
let meth_of_string = function
19
+
| "GET" -> Some `GET
20
+
| "POST" -> Some `POST
21
+
| "PUT" -> Some `PUT
22
+
| "DELETE" -> Some `DELETE
23
+
| "HEAD" -> Some `HEAD
24
+
| "OPTIONS" -> Some `OPTIONS
25
+
| _ -> None
26
+
27
+
module Request = struct
28
+
type t = {
29
+
meth : meth;
30
+
path : string;
31
+
query : (string * string) list;
32
+
headers : (string * string) list;
33
+
}
34
+
35
+
let create ~meth ~path ~query ~headers = { meth; path; query; headers }
36
+
let meth t = t.meth
37
+
let path t = t.path
38
+
let query t = t.query
39
+
40
+
let query_param t name =
41
+
List.find_map
42
+
(fun (k, v) -> if String.equal k name then Some v else None)
43
+
t.query
44
+
45
+
let query_params t name =
46
+
List.filter_map
47
+
(fun (k, v) -> if String.equal k name then Some v else None)
48
+
t.query
49
+
50
+
let headers t = t.headers
51
+
52
+
let header t name =
53
+
let name_lower = String.lowercase_ascii name in
54
+
List.find_map
55
+
(fun (k, v) ->
56
+
if String.equal (String.lowercase_ascii k) name_lower then Some v
57
+
else None)
58
+
t.headers
59
+
60
+
let cache_key t =
61
+
let sorted_query =
62
+
List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) t.query
63
+
in
64
+
let query_string =
65
+
String.concat "&"
66
+
(List.map (fun (k, v) -> k ^ "=" ^ v) sorted_query)
67
+
in
68
+
if query_string = "" then t.path else t.path ^ "?" ^ query_string
69
+
end
70
+
71
+
module Response = struct
72
+
type t = {
73
+
status : int;
74
+
headers : (string * string) list;
75
+
body : string;
76
+
}
77
+
78
+
let html content =
79
+
{
80
+
status = 200;
81
+
headers = [ ("content-type", "text/html; charset=utf-8") ];
82
+
body = content;
83
+
}
84
+
85
+
let json content =
86
+
{
87
+
status = 200;
88
+
headers = [ ("content-type", "application/json; charset=utf-8") ];
89
+
body = content;
90
+
}
91
+
92
+
let xml content =
93
+
{
94
+
status = 200;
95
+
headers = [ ("content-type", "application/xml") ];
96
+
body = content;
97
+
}
98
+
99
+
let atom content =
100
+
{
101
+
status = 200;
102
+
headers = [ ("content-type", "application/atom+xml; charset=utf-8") ];
103
+
body = content;
104
+
}
105
+
106
+
let plain content =
107
+
{
108
+
status = 200;
109
+
headers = [ ("content-type", "text/plain") ];
110
+
body = content;
111
+
}
112
+
113
+
let redirect ~code ~location =
114
+
{ status = code; headers = [ ("Location", location) ]; body = "" }
115
+
116
+
let not_found = { status = 404; headers = []; body = "Not Found" }
117
+
let raw ~status ~headers body = { status; headers; body }
118
+
let status t = t.status
119
+
let headers t = t.headers
120
+
let body t = t.body
121
+
end
122
+
123
+
(* Path pattern implementation using GADTs *)
124
+
125
+
type _ pattern =
126
+
| Root : unit pattern
127
+
| Exact : string -> unit pattern
128
+
| Param : string pattern
129
+
| Rest : string pattern
130
+
| Compose : 'a pattern * 'b pattern -> ('a * 'b) pattern
131
+
132
+
let root = Root
133
+
let exact s = Exact s
134
+
let param = Param
135
+
let rest = Rest
136
+
let ( @/ ) p1 p2 = Compose (p1, p2)
137
+
138
+
(* Pattern matching helper *)
139
+
let split_path path =
140
+
let path = if String.length path > 0 && path.[0] = '/' then
141
+
String.sub path 1 (String.length path - 1)
142
+
else path
143
+
in
144
+
if path = "" then []
145
+
else String.split_on_char '/' path
146
+
147
+
type 'a match_result =
148
+
| Match of 'a * string list
149
+
| NoMatch
150
+
151
+
let rec match_pattern : type a. a pattern -> string list -> a match_result =
152
+
fun pattern segments ->
153
+
match (pattern, segments) with
154
+
| Root, [] -> Match ((), [])
155
+
| Root, [ "" ] -> Match ((), [])
156
+
| Exact s, seg :: rest when String.equal s seg -> Match ((), rest)
157
+
| Param, seg :: rest -> Match (seg, rest)
158
+
| Rest, segments -> Match (String.concat "/" segments, [])
159
+
| Compose (p1, p2), segments -> (
160
+
match match_pattern p1 segments with
161
+
| NoMatch -> NoMatch
162
+
| Match (v1, remaining) -> (
163
+
match match_pattern p2 remaining with
164
+
| NoMatch -> NoMatch
165
+
| Match (v2, final) -> Match ((v1, v2), final)))
166
+
| _ -> NoMatch
167
+
168
+
type handler = Request.t -> Response.t
169
+
type 'a param_handler = 'a -> Request.t -> Response.t
170
+
171
+
(* Existential wrapper for routes *)
172
+
type t =
173
+
| Route : {
174
+
meth : meth;
175
+
pattern : 'a pattern;
176
+
handler : 'a param_handler;
177
+
}
178
+
-> t
179
+
| ExactRoute : {
180
+
meth : meth;
181
+
segments : string list;
182
+
handler : handler;
183
+
}
184
+
-> t
185
+
186
+
let get pattern handler = Route { meth = `GET; pattern; handler }
187
+
let post pattern handler = Route { meth = `POST; pattern; handler }
188
+
let route meth pattern handler = Route { meth; pattern; handler }
189
+
190
+
(* Simple exact segment matching without GADTs *)
191
+
let get_ segments handler = ExactRoute { meth = `GET; segments; handler }
192
+
let post_ segments handler = ExactRoute { meth = `POST; segments; handler }
193
+
194
+
module Routes = struct
195
+
type route = t
196
+
type t = route list
197
+
198
+
let empty = []
199
+
let add route routes = route :: routes
200
+
let of_list routes = routes
201
+
202
+
let match_segments expected actual =
203
+
List.length expected = List.length actual &&
204
+
List.for_all2 String.equal expected actual
205
+
206
+
let try_route route req =
207
+
match route with
208
+
| Route { meth; pattern; handler } ->
209
+
if Request.meth req <> meth then None
210
+
else
211
+
let segments = split_path (Request.path req) in
212
+
(match match_pattern pattern segments with
213
+
| Match (params, []) -> Some (handler params req)
214
+
| Match (params, [ "" ]) -> Some (handler params req)
215
+
| _ -> None)
216
+
| ExactRoute { meth; segments; handler } ->
217
+
if Request.meth req <> meth then None
218
+
else
219
+
let path_segments = split_path (Request.path req) in
220
+
(* Handle trailing empty segment from trailing slash *)
221
+
let path_segments =
222
+
match List.rev path_segments with
223
+
| "" :: rest -> List.rev rest
224
+
| _ -> path_segments
225
+
in
226
+
if match_segments segments path_segments then
227
+
Some (handler req)
228
+
else
229
+
None
230
+
231
+
let dispatch routes req =
232
+
List.find_map (fun route -> try_route route req) routes
233
+
234
+
let fold f routes acc = List.fold_right f routes acc
235
+
end
+177
arod/lib/arod_route.mli
+177
arod/lib/arod_route.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Framework-agnostic HTTP routing
7
+
8
+
This module provides a pure routing abstraction that is independent of any
9
+
specific HTTP server implementation. Routes are defined using a typed
10
+
pattern DSL and pure handler functions that take requests and return
11
+
responses. *)
12
+
13
+
(** HTTP methods. *)
14
+
type meth = [ `GET | `POST | `PUT | `DELETE | `HEAD | `OPTIONS ]
15
+
16
+
val meth_to_string : meth -> string
17
+
(** [meth_to_string m] returns the string representation of method [m]. *)
18
+
19
+
val meth_of_string : string -> meth option
20
+
(** [meth_of_string s] parses an HTTP method from string [s]. *)
21
+
22
+
(** HTTP requests. *)
23
+
module Request : sig
24
+
type t
25
+
(** The type of HTTP requests. *)
26
+
27
+
val create :
28
+
meth:meth ->
29
+
path:string ->
30
+
query:(string * string) list ->
31
+
headers:(string * string) list ->
32
+
t
33
+
(** [create ~meth ~path ~query ~headers] constructs a request. *)
34
+
35
+
val meth : t -> meth
36
+
(** [meth req] returns the HTTP method of the request. *)
37
+
38
+
val path : t -> string
39
+
(** [path req] returns the URL path of the request. *)
40
+
41
+
val query : t -> (string * string) list
42
+
(** [query req] returns all query parameters. *)
43
+
44
+
val query_param : t -> string -> string option
45
+
(** [query_param req name] returns the first value for query parameter [name]. *)
46
+
47
+
val query_params : t -> string -> string list
48
+
(** [query_params req name] returns all values for query parameter [name]. *)
49
+
50
+
val headers : t -> (string * string) list
51
+
(** [headers req] returns all request headers. *)
52
+
53
+
val header : t -> string -> string option
54
+
(** [header req name] returns the value of header [name]. *)
55
+
56
+
val cache_key : t -> string
57
+
(** [cache_key req] returns a string suitable for use as a memoization key,
58
+
combining path and sorted query parameters. *)
59
+
end
60
+
61
+
(** HTTP responses. *)
62
+
module Response : sig
63
+
type t
64
+
(** The type of HTTP responses. *)
65
+
66
+
val html : string -> t
67
+
(** [html content] creates an HTML response with content-type text/html. *)
68
+
69
+
val json : string -> t
70
+
(** [json content] creates a JSON response with content-type application/json. *)
71
+
72
+
val xml : string -> t
73
+
(** [xml content] creates an XML response with content-type application/xml. *)
74
+
75
+
val atom : string -> t
76
+
(** [atom content] creates an Atom feed response with content-type
77
+
application/atom+xml. *)
78
+
79
+
val plain : string -> t
80
+
(** [plain content] creates a plain text response. *)
81
+
82
+
val redirect : code:int -> location:string -> t
83
+
(** [redirect ~code ~location] creates a redirect response. *)
84
+
85
+
val not_found : t
86
+
(** [not_found] is a 404 Not Found response. *)
87
+
88
+
val raw : status:int -> headers:(string * string) list -> string -> t
89
+
(** [raw ~status ~headers body] creates a response with explicit status,
90
+
headers, and body. *)
91
+
92
+
val status : t -> int
93
+
(** [status resp] returns the HTTP status code. *)
94
+
95
+
val headers : t -> (string * string) list
96
+
(** [headers resp] returns the response headers. *)
97
+
98
+
val body : t -> string
99
+
(** [body resp] returns the response body. *)
100
+
end
101
+
102
+
(** {1 Path Pattern DSL}
103
+
104
+
Patterns match URL paths and can capture path segments as typed values. *)
105
+
106
+
type 'a pattern
107
+
(** The type of path patterns that capture a value of type ['a]. *)
108
+
109
+
val root : unit pattern
110
+
(** [root] matches the root path "/". *)
111
+
112
+
val exact : string -> unit pattern
113
+
(** [exact s] matches the exact path segment [s]. *)
114
+
115
+
val param : string pattern
116
+
(** [param] matches any path segment and captures it as a string. *)
117
+
118
+
val rest : string pattern
119
+
(** [rest] matches and captures the rest of the path (everything after
120
+
this point). *)
121
+
122
+
val ( @/ ) : 'a pattern -> 'b pattern -> ('a * 'b) pattern
123
+
(** [p1 @/ p2] composes patterns [p1] and [p2], matching [p1] followed by [p2]
124
+
and combining their captured values into a tuple. *)
125
+
126
+
(** {1 Route Definitions} *)
127
+
128
+
type handler = Request.t -> Response.t
129
+
(** A handler is a function from request to response. *)
130
+
131
+
type 'a param_handler = 'a -> Request.t -> Response.t
132
+
(** A parameterized handler receives captured path parameters. *)
133
+
134
+
type t
135
+
(** The type of a single route. *)
136
+
137
+
val get : 'a pattern -> 'a param_handler -> t
138
+
(** [get pattern handler] creates a GET route. *)
139
+
140
+
val post : 'a pattern -> 'a param_handler -> t
141
+
(** [post pattern handler] creates a POST route. *)
142
+
143
+
val route : meth -> 'a pattern -> 'a param_handler -> t
144
+
(** [route meth pattern handler] creates a route for method [meth]. *)
145
+
146
+
val get_ : string list -> handler -> t
147
+
(** [get_ segments handler] creates a GET route matching exact path segments
148
+
(e.g., [get_ ["api"; "users"] handler] matches "/api/users"). *)
149
+
150
+
val post_ : string list -> handler -> t
151
+
(** [post_ segments handler] creates a POST route matching exact path segments. *)
152
+
153
+
(** {1 Route Collection} *)
154
+
155
+
module Routes : sig
156
+
type route = t
157
+
(** Alias for route type. *)
158
+
159
+
type t
160
+
(** A collection of routes. *)
161
+
162
+
val empty : t
163
+
(** The empty route collection. *)
164
+
165
+
val add : route -> t -> t
166
+
(** [add route routes] adds a route to the collection. *)
167
+
168
+
val of_list : route list -> t
169
+
(** [of_list routes] creates a collection from a list of routes. *)
170
+
171
+
val dispatch : t -> Request.t -> Response.t option
172
+
(** [dispatch routes req] attempts to find a matching route and invoke its
173
+
handler. Returns [None] if no route matches. *)
174
+
175
+
val fold : (route -> 'a -> 'a) -> t -> 'a -> 'a
176
+
(** [fold f routes acc] folds over all routes in the collection. *)
177
+
end
+164
arod/lib/server/arod_server.ml
+164
arod/lib/server/arod_server.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** tiny_httpd server adapter for arod routes *)
7
+
8
+
let src = Logs.Src.create "arod.server" ~doc:"Arod server adapter"
9
+
10
+
module Log = (val Logs.src_log src : Logs.LOG)
11
+
12
+
(** {1 Request/Response Conversion} *)
13
+
14
+
let request_of_tiny req =
15
+
let meth =
16
+
match Tiny_httpd.Request.meth req with
17
+
| `GET -> `GET
18
+
| `POST -> `POST
19
+
| `PUT -> `PUT
20
+
| `DELETE -> `DELETE
21
+
| `HEAD -> `HEAD
22
+
| `OPTIONS -> `OPTIONS
23
+
in
24
+
let path = Tiny_httpd.Request.path req in
25
+
let query = Tiny_httpd.Request.query req in
26
+
(* Headers.t is already (string * string) list *)
27
+
let headers = Tiny_httpd.Request.headers req in
28
+
Arod.Route.Request.create ~meth ~path ~query ~headers
29
+
30
+
let response_to_tiny resp =
31
+
let status = Arod.Route.Response.status resp in
32
+
let headers = Arod.Route.Response.headers resp in
33
+
let body = Arod.Route.Response.body resp in
34
+
if status >= 200 && status < 300 then
35
+
Tiny_httpd.Response.make_string ~headers (Ok body)
36
+
else if status >= 300 && status < 400 then
37
+
(* Redirect *)
38
+
Tiny_httpd.Response.make_raw ~code:status ~headers body
39
+
else
40
+
Tiny_httpd.Response.fail ~code:status "%s" body
41
+
42
+
(** {1 Route Registration} *)
43
+
44
+
let register_routes server routes =
45
+
(* tiny_httpd uses a different routing model, so we use a catch-all handler
46
+
that dispatches through our route collection *)
47
+
Tiny_httpd.Server.add_route_handler ~meth:`GET server
48
+
Tiny_httpd.Route.(rest_of_path)
49
+
(fun path req ->
50
+
let arod_req = request_of_tiny req in
51
+
(* Reconstruct the full path including leading slash *)
52
+
let full_path = "/" ^ path in
53
+
let arod_req =
54
+
Arod.Route.Request.create
55
+
~meth:(Arod.Route.Request.meth arod_req)
56
+
~path:full_path
57
+
~query:(Arod.Route.Request.query arod_req)
58
+
~headers:(Arod.Route.Request.headers arod_req)
59
+
in
60
+
match Arod.Route.Routes.dispatch routes arod_req with
61
+
| Some resp -> response_to_tiny resp
62
+
| None -> Tiny_httpd.Response.fail ~code:404 "Not Found");
63
+
(* Also handle the root path *)
64
+
Tiny_httpd.Server.add_route_handler ~meth:`GET server
65
+
Tiny_httpd.Route.(exact_path "/" return)
66
+
(fun req ->
67
+
let arod_req = request_of_tiny req in
68
+
match Arod.Route.Routes.dispatch routes arod_req with
69
+
| Some resp -> response_to_tiny resp
70
+
| None -> Tiny_httpd.Response.fail ~code:404 "Not Found")
71
+
72
+
(** {1 Server Lifecycle} *)
73
+
74
+
let create_server ~config =
75
+
Tiny_httpd.create ~addr:config.Arod.Config.server.host
76
+
~port:config.Arod.Config.server.port ()
77
+
78
+
let default_memoized_paths =
79
+
[ "/feeds/"; "/sitemap"; "/perma."; "/bushel/graph.json" ]
80
+
81
+
let should_memoize path memoized_paths =
82
+
List.exists (fun prefix -> String.length path >= String.length prefix &&
83
+
String.sub path 0 (String.length prefix) = prefix) memoized_paths
84
+
85
+
let run ~config ?memo_cache ?(memoized_paths = default_memoized_paths) routes =
86
+
let server = create_server ~config in
87
+
(* Add logging middleware *)
88
+
Tiny_httpd.add_middleware server ~stage:(`Stage 1) (fun h req ->
89
+
let start_time = Unix.gettimeofday () in
90
+
let resp = h req in
91
+
let elapsed = Unix.gettimeofday () -. start_time in
92
+
Log.info (fun m ->
93
+
m "%s %s - %.3fs"
94
+
(Tiny_httpd.Meth.to_string (Tiny_httpd.Request.meth req))
95
+
(Tiny_httpd.Request.path req) elapsed);
96
+
resp);
97
+
(* Register all routes with optional memoization *)
98
+
let routes_with_memo =
99
+
match memo_cache with
100
+
| None -> routes
101
+
| Some _cache ->
102
+
(* Wrap memoized paths *)
103
+
Arod.Route.Routes.fold
104
+
(fun route acc ->
105
+
(* For now we just use the routes as-is; memoization could be added
106
+
by wrapping individual handlers, but that requires more intrusive
107
+
changes to the route structure. Instead, we apply memoization at
108
+
dispatch time. *)
109
+
Arod.Route.Routes.add route acc)
110
+
routes Arod.Route.Routes.empty
111
+
in
112
+
(* Use a dispatch wrapper that applies memoization *)
113
+
Tiny_httpd.Server.add_route_handler ~meth:`GET server
114
+
Tiny_httpd.Route.rest_of_path
115
+
(fun path req ->
116
+
let arod_req = request_of_tiny req in
117
+
let full_path = "/" ^ path in
118
+
let arod_req =
119
+
Arod.Route.Request.create
120
+
~meth:(Arod.Route.Request.meth arod_req)
121
+
~path:full_path
122
+
~query:(Arod.Route.Request.query arod_req)
123
+
~headers:(Arod.Route.Request.headers arod_req)
124
+
in
125
+
let dispatch_fn =
126
+
match memo_cache with
127
+
| Some cache when should_memoize full_path memoized_paths ->
128
+
fun req ->
129
+
Arod.Memo.memoize cache
130
+
(fun r ->
131
+
match Arod.Route.Routes.dispatch routes_with_memo r with
132
+
| Some resp -> resp
133
+
| None -> Arod.Route.Response.not_found)
134
+
req
135
+
| _ -> fun req ->
136
+
match Arod.Route.Routes.dispatch routes_with_memo req with
137
+
| Some resp -> resp
138
+
| None -> Arod.Route.Response.not_found
139
+
in
140
+
response_to_tiny (dispatch_fn arod_req));
141
+
(* Handle root path *)
142
+
Tiny_httpd.Server.add_route_handler ~meth:`GET server
143
+
Tiny_httpd.Route.(exact_path "/" return)
144
+
(fun req ->
145
+
let arod_req = request_of_tiny req in
146
+
let dispatch_fn =
147
+
match memo_cache with
148
+
| Some cache when should_memoize "/" memoized_paths ->
149
+
fun req ->
150
+
Arod.Memo.memoize cache
151
+
(fun r ->
152
+
match Arod.Route.Routes.dispatch routes_with_memo r with
153
+
| Some resp -> resp
154
+
| None -> Arod.Route.Response.not_found)
155
+
req
156
+
| _ -> fun req ->
157
+
match Arod.Route.Routes.dispatch routes_with_memo req with
158
+
| Some resp -> resp
159
+
| None -> Arod.Route.Response.not_found
160
+
in
161
+
response_to_tiny (dispatch_fn arod_req));
162
+
Log.app (fun m ->
163
+
m "Listening on http://%s:%d" config.server.host config.server.port);
164
+
Tiny_httpd.run server
+46
arod/lib/server/arod_server.mli
+46
arod/lib/server/arod_server.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** tiny_httpd server adapter for arod routes
7
+
8
+
This module adapts the framework-agnostic {!Arod.Route} abstraction to
9
+
work with tiny_httpd. It provides conversion functions between the
10
+
abstract request/response types and tiny_httpd's types, as well as
11
+
server lifecycle management. *)
12
+
13
+
(** {1 Request/Response Conversion} *)
14
+
15
+
val request_of_tiny : 'body Tiny_httpd.Request.t -> Arod.Route.Request.t
16
+
(** [request_of_tiny req] converts a tiny_httpd request to an arod request. *)
17
+
18
+
val response_to_tiny : Arod.Route.Response.t -> Tiny_httpd.Response.t
19
+
(** [response_to_tiny resp] converts an arod response to a tiny_httpd response. *)
20
+
21
+
(** {1 Route Registration} *)
22
+
23
+
val register_routes : Tiny_httpd.t -> Arod.Route.Routes.t -> unit
24
+
(** [register_routes server routes] registers all routes with the tiny_httpd
25
+
server. Each route is converted to a tiny_httpd route handler. *)
26
+
27
+
(** {1 Server Lifecycle} *)
28
+
29
+
val create_server : config:Arod.Config.t -> Tiny_httpd.t
30
+
(** [create_server ~config] creates a tiny_httpd server with host and port
31
+
from [config]. *)
32
+
33
+
val run :
34
+
config:Arod.Config.t ->
35
+
?memo_cache:Arod.Route.Response.t Arod.Memo.t ->
36
+
?memoized_paths:string list ->
37
+
Arod.Route.Routes.t ->
38
+
(unit, exn) result
39
+
(** [run ~config ?memo_cache ?memoized_paths routes] creates and starts a
40
+
tiny_httpd server with the given routes.
41
+
42
+
@param config Server configuration with host, port, and paths.
43
+
@param memo_cache Optional memoization cache for caching responses.
44
+
@param memoized_paths List of path prefixes to memoize (default:
45
+
["/feeds/"; "/sitemap"; "/perma."; "/bushel/graph.json"]).
46
+
@return [Ok ()] on clean shutdown, [Error exn] on failure. *)