Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin.admin: extract allowlist parsing to its own sublib with tests
The allowlist parser was inline in cmd_serve.ml and therefore untestable
without starting a server. Move it to a new Irmin_admin sublib and add
11 unit tests covering:
- valid multi-entry arrays
- entries with missing or non-string email fields (silently skipped)
- wrong top-level shape ([allow] table instead of [[allow]] array)
- entirely absent [allow] key
- malformed TOML (garbage input) and empty input
- declaration-order preservation
- is_allowed on empty, populated, and case-sensitive inputs
cmd_serve.ml now delegates to Irmin_admin.parse / is_allowed.
Uses Tomlt_bytesrw.decode_string rather than Tomlt.decode_string so
the streaming parser is actually linked (Tomlt's default is a lazy
ref that raises until the bytesrw backend registers itself).
+184
-22
+5
-21
bin/cmd_serve.ml
+5
-21
bin/cmd_serve.ml
···
339
339
let root_c = Irmin_git.S.at heap Irmin_git.tree tree_hash in
340
340
Irmin_git.Tree.content root_c [ "admin.toml" ]
341
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 =
342
+
let upload_allowlist heap : Irmin_admin.config =
360
343
match read_admin_config heap with
361
-
| None -> []
362
-
| Some text -> parse_allowlist text
344
+
| None -> Irmin_admin.empty
345
+
| Some text -> Irmin_admin.parse text
363
346
364
-
let is_allowed allowlist (user : Auth.user) = List.mem user.email allowlist
347
+
let is_allowed allowlist (user : Auth.user) =
348
+
Irmin_admin.is_allowed allowlist ~email:user.email
365
349
366
350
(* ── Handlers ─────────────────────────────────────────────────────── *)
367
351
+1
-1
bin/dune
+1
-1
bin/dune
+4
lib/admin/dune
+4
lib/admin/dune
+27
lib/admin/irmin_admin.ml
+27
lib/admin/irmin_admin.ml
···
1
+
(** Server admin config parsing. *)
2
+
3
+
type config = { allow_emails : string list }
4
+
5
+
let empty = { allow_emails = [] }
6
+
7
+
let parse text =
8
+
match Tomlt_bytesrw.decode_string Tomlt.value text with
9
+
| Error _ -> empty
10
+
| Ok (Tomlt.Toml.Table fields) -> (
11
+
match List.assoc_opt "allow" fields with
12
+
| Some (Tomlt.Toml.Array entries) ->
13
+
let emails =
14
+
List.filter_map
15
+
(function
16
+
| Tomlt.Toml.Table kvs -> (
17
+
match List.assoc_opt "email" kvs with
18
+
| Some (Tomlt.Toml.String s) -> Some s
19
+
| _ -> None)
20
+
| _ -> None)
21
+
entries
22
+
in
23
+
{ allow_emails = emails }
24
+
| _ -> empty)
25
+
| Ok _ -> empty
26
+
27
+
let is_allowed cfg ~email = List.mem email cfg.allow_emails
+26
lib/admin/irmin_admin.mli
+26
lib/admin/irmin_admin.mli
···
1
+
(** Server admin config parsed from [refs/meta/config:admin.toml].
2
+
3
+
Exposes one value: the list of email addresses authorised to mutate the
4
+
store via the HTTP API (e.g. [POST /:branch/upload]). An empty list means no
5
+
one is allowed, which is what callers should treat as the default when the
6
+
config ref is absent or unreadable. *)
7
+
8
+
type config = { allow_emails : string list }
9
+
10
+
val empty : config
11
+
12
+
val parse : string -> config
13
+
(** [parse toml_text] extracts the allowlist from a TOML document of the form:
14
+
{v
15
+
[[allow]]
16
+
email = "a@example.com"
17
+
[[allow]]
18
+
email = "b@example.com"
19
+
v}
20
+
Invalid TOML, a missing or wrong-shape [allow] array, or entries without an
21
+
[email] string are silently ignored and yield {!empty} (or the subset that
22
+
parses). Never raises. *)
23
+
24
+
val is_allowed : config -> email:string -> bool
25
+
(** [is_allowed cfg ~email] is [true] when [email] appears in
26
+
[cfg.allow_emails]. Comparison is case-sensitive. *)
+2
test/dune
+2
test/dune
+1
test/test.ml
+1
test/test.ml
+118
test/test_admin.ml
+118
test/test_admin.ml
···
1
+
(** Tests for [Irmin_admin.parse]. *)
2
+
3
+
let check_string_list = Alcotest.(check (list string))
4
+
let check_bool = Alcotest.(check bool)
5
+
6
+
let parse_valid () =
7
+
let toml =
8
+
{|[[allow]]
9
+
email = "a@example.com"
10
+
[[allow]]
11
+
email = "b@example.com"
12
+
|}
13
+
in
14
+
let cfg = Irmin_admin.parse toml in
15
+
check_string_list "both emails"
16
+
[ "a@example.com"; "b@example.com" ]
17
+
cfg.allow_emails
18
+
19
+
let parse_missing_email_field () =
20
+
(* Entries without an [email] field are silently skipped; valid entries
21
+
alongside still come through. *)
22
+
let toml =
23
+
{|[[allow]]
24
+
name = "no email here"
25
+
[[allow]]
26
+
email = "valid@example.com"
27
+
|}
28
+
in
29
+
let cfg = Irmin_admin.parse toml in
30
+
check_string_list "only the valid one" [ "valid@example.com" ]
31
+
cfg.allow_emails
32
+
33
+
let parse_non_string_email () =
34
+
let toml = {|[[allow]]
35
+
email = 42
36
+
|} in
37
+
let cfg = Irmin_admin.parse toml in
38
+
check_string_list "int email skipped" [] cfg.allow_emails
39
+
40
+
let parse_wrong_shape () =
41
+
let toml = {|[allow]
42
+
email = "a@example.com"
43
+
|} in
44
+
let cfg = Irmin_admin.parse toml in
45
+
check_string_list "not an array-of-tables" [] cfg.allow_emails
46
+
47
+
let parse_missing_allow () =
48
+
let toml = {|[other]
49
+
k = "v"
50
+
|} in
51
+
let cfg = Irmin_admin.parse toml in
52
+
check_string_list "no allow key" [] cfg.allow_emails
53
+
54
+
let parse_malformed_toml () =
55
+
let cfg = Irmin_admin.parse "not { valid = toml [[[" in
56
+
check_string_list "garbage yields empty" [] cfg.allow_emails
57
+
58
+
let parse_empty () =
59
+
let cfg = Irmin_admin.parse "" in
60
+
check_string_list "empty yields empty" [] cfg.allow_emails
61
+
62
+
let parse_preserves_order () =
63
+
let toml =
64
+
{|[[allow]]
65
+
email = "c@example.com"
66
+
[[allow]]
67
+
email = "a@example.com"
68
+
[[allow]]
69
+
email = "b@example.com"
70
+
|}
71
+
in
72
+
let cfg = Irmin_admin.parse toml in
73
+
check_string_list "declaration order preserved"
74
+
[ "c@example.com"; "a@example.com"; "b@example.com" ]
75
+
cfg.allow_emails
76
+
77
+
let is_allowed_basic () =
78
+
let cfg = Irmin_admin.parse {|[[allow]]
79
+
email = "me@example.com"
80
+
|} in
81
+
check_bool "listed email allowed" true
82
+
(Irmin_admin.is_allowed cfg ~email:"me@example.com");
83
+
check_bool "other email denied" false
84
+
(Irmin_admin.is_allowed cfg ~email:"nope@example.com")
85
+
86
+
let is_allowed_empty () =
87
+
check_bool "empty list denies everyone" false
88
+
(Irmin_admin.is_allowed Irmin_admin.empty ~email:"any@example.com")
89
+
90
+
let is_allowed_case_sensitive () =
91
+
(* Documented behaviour: comparison is case-sensitive. Callers who want
92
+
case-insensitive matching should normalise before calling. *)
93
+
let cfg = Irmin_admin.parse {|[[allow]]
94
+
email = "Alice@example.com"
95
+
|} in
96
+
check_bool "lowercase mismatch" false
97
+
(Irmin_admin.is_allowed cfg ~email:"alice@example.com");
98
+
check_bool "exact match" true
99
+
(Irmin_admin.is_allowed cfg ~email:"Alice@example.com")
100
+
101
+
let suite =
102
+
( "admin",
103
+
[
104
+
Alcotest.test_case "parse valid entries" `Quick parse_valid;
105
+
Alcotest.test_case "parse skips missing email" `Quick
106
+
parse_missing_email_field;
107
+
Alcotest.test_case "parse skips non-string email" `Quick
108
+
parse_non_string_email;
109
+
Alcotest.test_case "parse rejects wrong shape" `Quick parse_wrong_shape;
110
+
Alcotest.test_case "parse missing allow" `Quick parse_missing_allow;
111
+
Alcotest.test_case "parse malformed toml" `Quick parse_malformed_toml;
112
+
Alcotest.test_case "parse empty" `Quick parse_empty;
113
+
Alcotest.test_case "parse preserves order" `Quick parse_preserves_order;
114
+
Alcotest.test_case "is_allowed basic" `Quick is_allowed_basic;
115
+
Alcotest.test_case "is_allowed empty" `Quick is_allowed_empty;
116
+
Alcotest.test_case "is_allowed case-sensitive" `Quick
117
+
is_allowed_case_sensitive;
118
+
] )