Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin serve: Tw_html DSL + GitHub OAuth with allowlist
HTML is now composed from tw.html's typed DSL (no raw strings, no
CDN scripts); /tw.css is generated at startup from a sample page.
Upload form is a plain <form action method POST enctype multipart>
that the browser submits natively.
GitHub OAuth wired via ocaml-auth:
- enabled when IRMIN_AUTH_CLIENT_ID/_SECRET/_BASE_URL/_COOKIE_SECRET
are all set; otherwise uploads are unauthenticated (dev mode).
- Auth.routes mounted under /auth/github*, /auth/signout.
- Auth DB at .irmin/auth.db (SQLite, single-process).
- Each page renders a header strip: "Sign in with GitHub" with no
session, "<email> [Sign out]" when signed in, nothing when off.
Upload allowlist lives inside the store at refs/meta/config,
file admin.toml (Gerrit convention). Format:
[[allow]]
email = "you@example.com"
Re-read on every upload, so editing and committing admin.toml
takes effect without restarting. Missing or empty allowlist means
no one is allowed (safe default).
Dependencies added: tw, tw.html, auth, oauth, requests, tomlt.
+251
-77
+247
-77
bin/cmd_serve.ml
+247
-77
bin/cmd_serve.ml
···
166
166
~tw:Tw.[ mt 8; text_center; text_xs; text ~shade:400 gray ]
167
167
[ H.txt "Served with Irmin" ]
168
168
169
+
(* Auth-aware header strip. Shown above the breadcrumb on every page:
170
+
- auth disabled : nothing
171
+
- auth enabled, no user : "Sign in with GitHub" link
172
+
- auth enabled, user : "<email> [Sign out]" with a POST form *)
173
+
let header_bar ~auth_enabled ~user =
174
+
if not auth_enabled then H.raw ""
175
+
else
176
+
let inner =
177
+
match user with
178
+
| None ->
179
+
[
180
+
H.a
181
+
~at:[ A.href "/auth/github" ]
182
+
~tw:Tw.[ text blue; hover [ underline ] ]
183
+
[ H.txt "Sign in with GitHub" ];
184
+
]
185
+
| Some (u : Auth.user) ->
186
+
[
187
+
H.span ~tw:Tw.[ text ~shade:600 gray ] [ H.txt u.email ];
188
+
H.form
189
+
~at:[ A.action "/auth/signout"; A.method' "POST" ]
190
+
~tw:Tw.[ inline_block; ml 3 ]
191
+
[
192
+
H.button
193
+
~at:[ A.type' "submit" ]
194
+
~tw:Tw.[ text blue; hover [ underline ] ]
195
+
[ H.txt "Sign out" ];
196
+
];
197
+
]
198
+
in
199
+
H.div ~tw:Tw.[ mb 3; text_sm; text_right; text ~shade:500 gray ] inner
200
+
169
201
let summary_p text =
170
202
H.p ~tw:Tw.[ text ~shade:500 gray; text_sm; mb 3 ] [ H.txt text ]
171
203
···
232
264
| Some (S.Step (_, parent_c)) ->
233
265
Irmin_git.Tree.classify_child parent_c name)
234
266
267
+
(* ── Auth ─────────────────────────────────────────────────────────── *)
268
+
269
+
(* GitHub OAuth is enabled when all four IRMIN_AUTH_* environment variables
270
+
are set. Without them, uploads are unauthenticated (useful for local
271
+
development). *)
272
+
273
+
type auth_ctx = {
274
+
full_cfg : Auth.config;
275
+
session_cfg : Auth.session_config;
276
+
store : Auth.Store.t;
277
+
}
278
+
279
+
let env_all keys =
280
+
let rec loop acc = function
281
+
| [] -> Some (List.rev acc)
282
+
| k :: rest -> (
283
+
match Sys.getenv_opt k with
284
+
| Some v when v <> "" -> loop (v :: acc) rest
285
+
| _ -> None)
286
+
in
287
+
loop [] keys
288
+
289
+
let init_auth ~sw ~fs ~http : auth_ctx option =
290
+
match
291
+
env_all
292
+
[
293
+
"IRMIN_AUTH_CLIENT_ID";
294
+
"IRMIN_AUTH_CLIENT_SECRET";
295
+
"IRMIN_AUTH_BASE_URL";
296
+
"IRMIN_AUTH_COOKIE_SECRET";
297
+
]
298
+
with
299
+
| None -> None
300
+
| Some [ client_id; client_secret; base_url; cookie_secret ] ->
301
+
let allow_insecure =
302
+
not (String.length base_url >= 8 && String.sub base_url 0 8 = "https://")
303
+
in
304
+
let db_path = Eio.Path.(fs / ".irmin" / "auth.db") in
305
+
(* Ensure the containing directory exists. *)
306
+
(try Eio.Path.mkdirs ~perm:0o755 ~exists_ok:true Eio.Path.(fs / ".irmin")
307
+
with _ -> ());
308
+
let store = Auth.Store.v ~sw db_path in
309
+
let full_cfg =
310
+
Auth.config ~oauth_provider:Oauth.Github ~client_id ~client_secret
311
+
~base_url ~cookie_secret ~http ~allow_insecure ()
312
+
in
313
+
let session_cfg = Auth.session full_cfg in
314
+
Some { full_cfg; session_cfg; store }
315
+
| Some _ -> None (* unreachable: env_all returns exactly N or None *)
316
+
317
+
let require_user ctx (req : Respond.post_request) =
318
+
match Auth.current_user ctx.session_cfg ctx.store req with
319
+
| Some u -> Ok u
320
+
| None -> Error "/auth/github"
321
+
322
+
let current_user_get ctx (req : Respond.get_request) =
323
+
Auth.current_user_from_params ctx.session_cfg ctx.store req.params req.headers
324
+
325
+
(* ── Admin config (refs/meta/config : admin.toml) ────────────────────
326
+
The upload allowlist lives inside the store itself, following the
327
+
Gerrit convention of a dedicated metadata ref. Commit to
328
+
[refs/meta/config] with an [admin.toml] like:
329
+
[[allow]]
330
+
email = "you@example.com"
331
+
to authorise that email for uploads. When the ref is absent or the
332
+
file unreadable, the allowlist is empty and no one can upload. *)
333
+
334
+
let read_admin_config heap : string option =
335
+
match Irmin.Heap.ref heap "refs/meta/config" with
336
+
| None -> None
337
+
| Some ref_hash ->
338
+
let tree_hash = Irmin_git.Tree.resolve_tree_hash heap ref_hash in
339
+
let root_c = Irmin_git.S.at heap Irmin_git.tree tree_hash in
340
+
Irmin_git.Tree.content root_c [ "admin.toml" ]
341
+
342
+
let parse_allowlist text : string list =
343
+
match Tomlt.decode_string Tomlt.value text with
344
+
| Error _ -> []
345
+
| Ok (Tomlt.Toml.Table fields) -> (
346
+
match List.assoc_opt "allow" fields with
347
+
| Some (Tomlt.Toml.Array entries) ->
348
+
List.filter_map
349
+
(function
350
+
| Tomlt.Toml.Table kvs -> (
351
+
match List.assoc_opt "email" kvs with
352
+
| Some (Tomlt.Toml.String s) -> Some s
353
+
| _ -> None)
354
+
| _ -> None)
355
+
entries
356
+
| _ -> [])
357
+
| Ok _ -> []
358
+
359
+
let upload_allowlist heap : string list =
360
+
match read_admin_config heap with
361
+
| None -> []
362
+
| Some text -> parse_allowlist text
363
+
364
+
let is_allowed allowlist (user : Auth.user) = List.mem user.email allowlist
365
+
235
366
(* ── Handlers ─────────────────────────────────────────────────────── *)
236
367
237
-
let branches_page heap _req =
368
+
let branches_page ?auth heap (req : Respond.get_request) =
369
+
let user = Option.bind auth (fun ctx -> current_user_get ctx req) in
238
370
let bs = S.branches heap in
239
371
let rows =
240
372
List.map
···
255
387
in
256
388
let body =
257
389
[
390
+
header_bar ~auth_enabled:(Option.is_some auth) ~user;
258
391
h1_title "Branches";
259
392
summary;
260
393
breadcrumb ~branch:None ~path:[];
···
263
396
in
264
397
Respond.Response.html (page ~title:"Branches" body)
265
398
266
-
let render_node ~branch ~path c =
399
+
let render_node ?auth ~user ~branch ~path c =
267
400
let entries = S.list c in
268
401
let base =
269
402
match path with
···
312
445
let target_dir = String.concat "/" path in
313
446
let body =
314
447
[
448
+
header_bar ~auth_enabled:(Option.is_some auth) ~user;
315
449
h1_title title;
316
450
summary;
317
451
breadcrumb ~branch:(Some branch) ~path;
···
328
462
let ct = Magic_mime.lookup name in
329
463
Respond.Response.raw ~status:200 ~content_type:ct bytes
330
464
331
-
let browse heap (req : Respond.get_request) =
465
+
let browse ?auth heap (req : Respond.get_request) =
466
+
let user = Option.bind auth (fun ctx -> current_user_get ctx req) in
332
467
let branch = List.assoc "branch" req.path_params in
333
468
let rest = try List.assoc "rest" req.path_params with Not_found -> "" in
334
469
let path = Common.path_of_string rest in
···
340
475
| `Node -> (
341
476
match navigate_path root_c path with
342
477
| None -> Respond.Response.not_found
343
-
| Some (S.Step (_, c)) -> render_node ~branch ~path c)
478
+
| Some (S.Step (_, c)) -> render_node ?auth ~user ~branch ~path c)
344
479
| `Leaf -> (
345
480
match navigate_path root_c path with
346
481
| None -> Respond.Response.not_found
···
372
507
in
373
508
if bad then Error (Fmt.str "unsafe upload filename: %S" name) else Ok name
374
509
375
-
let upload heap (req : Respond.post_request) =
376
-
let branch = List.assoc "branch" req.path_params in
377
-
match Http.Multipart.parse req.headers req.body with
378
-
| Error (`Msg m) ->
379
-
Respond.Response.bad_request (Fmt.str "multipart parse error: %s" m)
380
-
| Ok parts -> (
381
-
let files =
382
-
List.filter_map
383
-
(fun (p : Http.Multipart.part) ->
384
-
match p.filename with
385
-
| Some fn when fn <> "" -> Some (fn, p.body)
386
-
| _ -> None)
387
-
parts
388
-
in
389
-
let target_dir =
390
-
match
391
-
List.find_map
392
-
(fun (p : Http.Multipart.part) ->
393
-
if p.name = "dir" then Some p.body else None)
394
-
parts
395
-
with
396
-
| Some s -> Common.path_of_string s
397
-
| None -> []
398
-
in
399
-
if files = [] then Respond.Response.bad_request "no file part in upload"
400
-
else
401
-
let invalid =
402
-
List.find_map
403
-
(fun (fn, _) ->
404
-
match sanitize_filename fn with Ok _ -> None | Error m -> Some m)
405
-
files
406
-
in
407
-
match invalid with
408
-
| Some m -> Respond.Response.bad_request m
409
-
| None ->
410
-
let root_c =
411
-
match Common.checkout heap ~branch with
412
-
| Some c -> c
413
-
| None -> S.empty heap Irmin_git.tree
510
+
let upload ?auth heap (req : Respond.post_request) =
511
+
let authorized =
512
+
match auth with
513
+
| None -> Ok ()
514
+
| Some ctx -> (
515
+
match require_user ctx req with
516
+
| Error r -> Error (`Redirect r)
517
+
| Ok user ->
518
+
let allow = upload_allowlist heap in
519
+
if is_allowed allow user then Ok ()
520
+
else
521
+
Error
522
+
(`Forbidden
523
+
(Fmt.str "%s is not on the upload allowlist" user.email)))
524
+
in
525
+
match authorized with
526
+
| Error (`Redirect r) -> Respond.Response.redirect r
527
+
| Error (`Forbidden m) ->
528
+
Respond.Response.v ~status:403 ~content_type:"text/plain" m
529
+
| Ok () -> (
530
+
let branch = List.assoc "branch" req.path_params in
531
+
match Http.Multipart.parse req.headers req.body with
532
+
| Error (`Msg m) ->
533
+
Respond.Response.bad_request (Fmt.str "multipart parse error: %s" m)
534
+
| Ok parts -> (
535
+
let files =
536
+
List.filter_map
537
+
(fun (p : Http.Multipart.part) ->
538
+
match p.filename with
539
+
| Some fn when fn <> "" -> Some (fn, p.body)
540
+
| _ -> None)
541
+
parts
542
+
in
543
+
let target_dir =
544
+
match
545
+
List.find_map
546
+
(fun (p : Http.Multipart.part) ->
547
+
if p.name = "dir" then Some p.body else None)
548
+
parts
549
+
with
550
+
| Some s -> Common.path_of_string s
551
+
| None -> []
552
+
in
553
+
if files = [] then
554
+
Respond.Response.bad_request "no file part in upload"
555
+
else
556
+
let invalid =
557
+
List.find_map
558
+
(fun (fn, _) ->
559
+
match sanitize_filename fn with
560
+
| Ok _ -> None
561
+
| Error m -> Some m)
562
+
files
414
563
in
415
-
let steps_for name = target_dir @ [ name ] in
416
-
(* Apply each file sequentially, re-opening a cursor on the
564
+
match invalid with
565
+
| Some m -> Respond.Response.bad_request m
566
+
| None ->
567
+
let root_c =
568
+
match Common.checkout heap ~branch with
569
+
| Some c -> c
570
+
| None -> S.empty heap Irmin_git.tree
571
+
in
572
+
let steps_for name = target_dir @ [ name ] in
573
+
(* Apply each file sequentially, re-opening a cursor on the
417
574
latest tree hash each time so writes accumulate. *)
418
-
let final_tree =
419
-
List.fold_left
420
-
(fun acc_hash (name, bytes) ->
421
-
let c = S.at heap Irmin_git.tree acc_hash in
422
-
Common.set_path heap c (steps_for name) bytes)
423
-
(S.flush root_c heap) files
424
-
in
425
-
let msg =
426
-
match files with
427
-
| [ (fn, _) ] -> Fmt.str "Upload %s" fn
428
-
| _ -> Fmt.str "Upload %d files" (List.length files)
429
-
in
430
-
let _commit = Common.commit ~heap ~branch ~message:msg final_tree in
431
-
let target =
432
-
match files with
433
-
| [ (fn, _) ] ->
434
-
Fmt.str "/%s%s/%s" (url_escape branch)
435
-
(if target_dir = [] then ""
436
-
else
437
-
"/" ^ String.concat "/" (List.map url_escape target_dir))
438
-
(url_escape fn)
439
-
| _ ->
440
-
Fmt.str "/%s/%s" (url_escape branch)
441
-
(String.concat "/" (List.map url_escape target_dir))
442
-
in
443
-
Respond.Response.redirect target)
575
+
let final_tree =
576
+
List.fold_left
577
+
(fun acc_hash (name, bytes) ->
578
+
let c = S.at heap Irmin_git.tree acc_hash in
579
+
Common.set_path heap c (steps_for name) bytes)
580
+
(S.flush root_c heap) files
581
+
in
582
+
let msg =
583
+
match files with
584
+
| [ (fn, _) ] -> Fmt.str "Upload %s" fn
585
+
| _ -> Fmt.str "Upload %d files" (List.length files)
586
+
in
587
+
let _commit =
588
+
Common.commit ~heap ~branch ~message:msg final_tree
589
+
in
590
+
let target =
591
+
match files with
592
+
| [ (fn, _) ] ->
593
+
Fmt.str "/%s%s/%s" (url_escape branch)
594
+
(if target_dir = [] then ""
595
+
else
596
+
"/"
597
+
^ String.concat "/" (List.map url_escape target_dir))
598
+
(url_escape fn)
599
+
| _ ->
600
+
Fmt.str "/%s/%s" (url_escape branch)
601
+
(String.concat "/" (List.map url_escape target_dir))
602
+
in
603
+
Respond.Response.redirect target))
444
604
445
605
(* ── Entry point ──────────────────────────────────────────────────── *)
446
606
···
451
611
let net = Eio.Stdenv.net env in
452
612
Eio.Switch.run @@ fun sw ->
453
613
let heap = Common.open_store ~sw ~fs ~config in
614
+
let http = Requests.v ~sw env in
615
+
let auth = init_auth ~sw ~fs ~http in
616
+
let auth_routes =
617
+
match auth with
618
+
| None -> []
619
+
| Some ctx -> Auth.routes ctx.full_cfg ctx.store
620
+
in
454
621
let css = tw_stylesheet () in
455
622
let css_route =
456
623
Respond.get "/tw.css" (fun _ ->
457
624
Respond.Response.raw ~status:200 ~content_type:"text/css" css)
458
625
in
459
626
let routes =
460
-
Respond.
461
-
[
462
-
css_route;
463
-
get "/" (branches_page heap);
627
+
let open Respond in
628
+
[ css_route ] @ auth_routes
629
+
@ [
630
+
get "/" (branches_page ?auth heap);
464
631
get "/blocks/:hash" (raw_block heap);
465
-
post "/:branch/upload" (upload heap);
466
-
get "/:branch/**" (browse heap);
632
+
post "/:branch/upload" (upload ?auth heap);
633
+
get "/:branch/**" (browse ?auth heap);
467
634
]
468
635
in
636
+
(match auth with
637
+
| Some _ -> Common.success "GitHub OAuth enabled; uploads require sign-in"
638
+
| None -> Common.success "auth disabled (set IRMIN_AUTH_* env vars to enable)");
469
639
Log.info (fun m -> m "listening on http://localhost:%d" port);
470
640
Common.success "serving on http://localhost:%d" port;
471
641
Respond.run ~net ~port ~root:fs routes