Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin/test: add per-lib test subdirs with real spec tests
Merlint E605 expects test/<subdir>/test_irmin_<X>.ml for each
lib/<subdir>/irmin_<X>.ml. Move existing tests + create real ones:
test/admin/ test_irmin_admin (moved, was test_admin)
test/cbor/ test_irmin_cbor (new)
test/gzip/ test_irmin_gzip (moved, was test_gzip)
test/json/ test_irmin_json (new)
test/mime/ test_irmin_mime (new)
test/oci/ test_irmin_oci (new)
test/text/ test_irmin_text (new)
test/toml/ test_irmin_toml (new)
test/yaml/ test_irmin_yaml (new)
test/ui/ test_{brand,breadcrumb,button,drop_zone,
layout,table,tag} (new)
Tests encode the spec rather than smoke-check output. For codecs that
means roundtrip properties (parse . serialize = id on member names)
plus exact expected Named/Indexed shapes for known inputs and
specific handling of invalid / scalar / empty input. For UI
components it means structural guarantees: N segments -> N <a> tags,
labels as text content, hrefs emitted verbatim, form carries correct
action/method/enctype, each tag tone renders distinctly, each auth
state surfaces the right controls.
Each subdir is a self-contained test executable. Removes the
corresponding modules from the top-level test.ml.
+1048
-12
+2
-1
bin/cmd_proof.ml
+2
-1
bin/cmd_proof.ml
+2
test/admin/test_irmin_admin.mli
+2
test/admin/test_irmin_admin.mli
+3
test/cbor/dune
+3
test/cbor/dune
+112
test/cbor/test_irmin_cbor.ml
+112
test/cbor/test_irmin_cbor.ml
···
1
+
(** Tests for [Irmin_cbor].
2
+
3
+
Spec:
4
+
- CBOR maps whose keys are text strings become [Named] children. Values
5
+
are re-encoded as CBOR bytes and stored [`Inline].
6
+
- CBOR arrays become [Indexed] children. Elements are re-encoded as CBOR
7
+
bytes.
8
+
- Non-text-keyed map entries are dropped silently.
9
+
- Anything that is not a map or array (scalars, invalid bytes) parses to
10
+
[Named []].
11
+
- Roundtrip: [parse (serialize c) = c] for values produced by [parse]. *)
12
+
13
+
let sample_map =
14
+
Cbor.encode_string Cbor.any
15
+
(Cbor.Value.map
16
+
[
17
+
(Cbor.Value.string "a", Cbor.Value.int 1);
18
+
(Cbor.Value.string "b", Cbor.Value.int 2);
19
+
])
20
+
21
+
let sample_array =
22
+
Cbor.encode_string Cbor.any
23
+
(Cbor.Value.array [ Cbor.Value.int 10; Cbor.Value.int 20 ])
24
+
25
+
let sample_mixed_keys =
26
+
Cbor.encode_string Cbor.any
27
+
(Cbor.Value.map
28
+
[
29
+
(Cbor.Value.string "text", Cbor.Value.int 1);
30
+
(Cbor.Value.int 7, Cbor.Value.int 2);
31
+
])
32
+
33
+
let parse_map_has_each_member () =
34
+
match Irmin_cbor.parse sample_map with
35
+
| Irmin.SHA256.Named kids ->
36
+
let names = List.map fst kids |> List.sort String.compare in
37
+
Alcotest.(check (list string)) "a and b" [ "a"; "b" ] names;
38
+
List.iter
39
+
(fun (n, c) ->
40
+
match c with
41
+
| `Inline _ -> ()
42
+
| `Link _ ->
43
+
Alcotest.failf
44
+
"parse_map: child %s should be Inline, not Link" n)
45
+
kids
46
+
| _ -> Alcotest.fail "parse_map: expected Named"
47
+
48
+
let parse_array_length_and_shape () =
49
+
match Irmin_cbor.parse sample_array with
50
+
| Irmin.SHA256.Indexed arr ->
51
+
Alcotest.(check int) "two elements" 2 (Array.length arr);
52
+
Array.iteri
53
+
(fun i c ->
54
+
match c with
55
+
| `Inline _ -> ()
56
+
| `Link _ ->
57
+
Alcotest.failf "parse_array: index %d should be Inline" i)
58
+
arr
59
+
| _ -> Alcotest.fail "parse_array: expected Indexed"
60
+
61
+
let parse_drops_non_text_keys () =
62
+
(* Spec: only text-keyed members are exposed. *)
63
+
match Irmin_cbor.parse sample_mixed_keys with
64
+
| Irmin.SHA256.Named [ ("text", _) ] -> ()
65
+
| Irmin.SHA256.Named kids ->
66
+
Alcotest.failf "expected single text-keyed child, got %d" (List.length kids)
67
+
| _ -> Alcotest.fail "parse_drops_non_text_keys"
68
+
69
+
let parse_invalid_is_empty () =
70
+
match Irmin_cbor.parse "not cbor at all" with
71
+
| Irmin.SHA256.Named [] -> ()
72
+
| _ -> Alcotest.fail "parse_invalid_is_empty"
73
+
74
+
let parse_scalar_is_empty () =
75
+
let scalar = Cbor.encode_string Cbor.any (Cbor.Value.int 42) in
76
+
match Irmin_cbor.parse scalar with
77
+
| Irmin.SHA256.Named [] -> ()
78
+
| _ -> Alcotest.fail "parse_scalar_is_empty"
79
+
80
+
let roundtrip_map_shape_preserved () =
81
+
let original = Irmin_cbor.parse sample_map in
82
+
let re = Irmin_cbor.parse (Irmin_cbor.serialize original) in
83
+
match (original, re) with
84
+
| Irmin.SHA256.Named a, Irmin.SHA256.Named b ->
85
+
Alcotest.(check (list string))
86
+
"names preserved"
87
+
(List.map fst a |> List.sort String.compare)
88
+
(List.map fst b |> List.sort String.compare)
89
+
| _ -> Alcotest.fail "roundtrip_map_shape_preserved"
90
+
91
+
let schema_name_is_application_cbor () =
92
+
Alcotest.(check string)
93
+
"schema name" "application/cbor"
94
+
(Irmin.SHA256.name Irmin_cbor.schema)
95
+
96
+
let suite =
97
+
( "irmin_cbor",
98
+
[
99
+
Alcotest.test_case "parse map -> Named with all members" `Quick
100
+
parse_map_has_each_member;
101
+
Alcotest.test_case "parse array -> Indexed with right length" `Quick
102
+
parse_array_length_and_shape;
103
+
Alcotest.test_case "parse drops non-text keys" `Quick
104
+
parse_drops_non_text_keys;
105
+
Alcotest.test_case "parse invalid -> Named []" `Quick parse_invalid_is_empty;
106
+
Alcotest.test_case "parse scalar -> Named []" `Quick parse_scalar_is_empty;
107
+
Alcotest.test_case "roundtrip preserves member names" `Quick
108
+
roundtrip_map_shape_preserved;
109
+
Alcotest.test_case "schema name" `Quick schema_name_is_application_cbor;
110
+
] )
111
+
112
+
let () = Alcotest.run "Irmin_cbor" [ suite ]
+2
test/cbor/test_irmin_cbor.mli
+2
test/cbor/test_irmin_cbor.mli
-3
test/dune
-3
test/dune
+3
test/gzip/dune
+3
test/gzip/dune
+2
test/gzip/test_irmin_gzip.mli
+2
test/gzip/test_irmin_gzip.mli
+3
test/json/dune
+3
test/json/dune
+126
test/json/test_irmin_json.ml
+126
test/json/test_irmin_json.ml
···
1
+
(** Tests for [Irmin_json].
2
+
3
+
Spec:
4
+
- [parse] maps JSON objects to [Named] members (name + inline value bytes),
5
+
arrays to [Indexed] children (inline value bytes), and everything else
6
+
to an empty [Named].
7
+
- [serialize] is the inverse on valid shapes: [parse (serialize c)] must
8
+
equal [c] for any [c] produced by [parse]. Round-tripping is the primary
9
+
correctness property.
10
+
- [schema] is recursive: every navigable child is also a JSON codec. Name
11
+
is ["application/json"]. *)
12
+
13
+
let child_pp fmt = function
14
+
| `Inline s -> Fmt.pf fmt "Inline %S" s
15
+
| `Link _ -> Fmt.string fmt "Link"
16
+
17
+
let child_equal a b =
18
+
match (a, b) with
19
+
| `Inline x, `Inline y -> String.equal x y
20
+
| `Link x, `Link y -> Digestif.SHA256.equal x y
21
+
| _ -> false
22
+
23
+
let children_pp fmt = function
24
+
| Irmin.SHA256.Named ms ->
25
+
Fmt.pf fmt "Named [%a]"
26
+
(Fmt.list ~sep:Fmt.comma
27
+
(fun fmt (n, c) -> Fmt.pf fmt "%s -> %a" n child_pp c))
28
+
ms
29
+
| Irmin.SHA256.Indexed arr ->
30
+
Fmt.pf fmt "Indexed [|%a|]"
31
+
(Fmt.array ~sep:Fmt.comma child_pp)
32
+
arr
33
+
34
+
let children_equal a b =
35
+
match (a, b) with
36
+
| Irmin.SHA256.Named x, Irmin.SHA256.Named y ->
37
+
List.length x = List.length y
38
+
&& List.for_all2
39
+
(fun (n1, c1) (n2, c2) -> String.equal n1 n2 && child_equal c1 c2)
40
+
x y
41
+
| Irmin.SHA256.Indexed x, Irmin.SHA256.Indexed y ->
42
+
Array.length x = Array.length y
43
+
&& Array.for_all Fun.id (Array.map2 child_equal x y)
44
+
| _ -> false
45
+
46
+
let children = Alcotest.testable children_pp children_equal
47
+
48
+
let parse_object_exact () =
49
+
(* Every member becomes a (name, Inline serialized-value) pair, in source
50
+
order. *)
51
+
Alcotest.check children "object fully decoded"
52
+
(Irmin.SHA256.Named [ ("a", `Inline "1"); ("b", `Inline "\"hi\"") ])
53
+
(Irmin_json.parse {|{"a":1,"b":"hi"}|})
54
+
55
+
let parse_array_exact () =
56
+
Alcotest.check children "array fully decoded"
57
+
(Irmin.SHA256.Indexed [| `Inline "10"; `Inline "20"; `Inline "30" |])
58
+
(Irmin_json.parse {|[10,20,30]|})
59
+
60
+
let parse_nested_object () =
61
+
(* Nested values are serialized whole and stored as Inline. They are
62
+
themselves parseable JSON. *)
63
+
match Irmin_json.parse {|{"nested":{"k":"v"}}|} with
64
+
| Irmin.SHA256.Named [ ("nested", `Inline s) ] ->
65
+
Alcotest.check children "nested re-parses"
66
+
(Irmin.SHA256.Named [ ("k", `Inline "\"v\"") ])
67
+
(Irmin_json.parse s)
68
+
| _ -> Alcotest.fail "nested object did not decode as Named single member"
69
+
70
+
let parse_scalar_is_empty () =
71
+
(* Scalars are not decomposable. The spec: [Named []] (terminal). *)
72
+
Alcotest.check children "number is terminal" (Irmin.SHA256.Named [])
73
+
(Irmin_json.parse "42");
74
+
Alcotest.check children "string is terminal" (Irmin.SHA256.Named [])
75
+
(Irmin_json.parse {|"hello"|});
76
+
Alcotest.check children "bool is terminal" (Irmin.SHA256.Named [])
77
+
(Irmin_json.parse "true");
78
+
Alcotest.check children "null is terminal" (Irmin.SHA256.Named [])
79
+
(Irmin_json.parse "null")
80
+
81
+
let parse_invalid_is_empty () =
82
+
(* Spec: garbage yields [Named []], never raises. *)
83
+
Alcotest.check children "garbage" (Irmin.SHA256.Named [])
84
+
(Irmin_json.parse "not json at all {{{")
85
+
86
+
let roundtrip_object () =
87
+
(* The key property: [parse (serialize c) = c]. *)
88
+
let c =
89
+
Irmin.SHA256.Named [ ("k", `Inline "\"v\""); ("n", `Inline "7") ]
90
+
in
91
+
Alcotest.check children "parse . serialize = id" c
92
+
(Irmin_json.parse (Irmin_json.serialize c))
93
+
94
+
let roundtrip_array () =
95
+
let c = Irmin.SHA256.Indexed [| `Inline "1"; `Inline "2" |] in
96
+
Alcotest.check children "parse . serialize = id (array)" c
97
+
(Irmin_json.parse (Irmin_json.serialize c))
98
+
99
+
let schema_is_named_application_json () =
100
+
Alcotest.(check string)
101
+
"schema name" "application/json"
102
+
(Irmin.SHA256.name Irmin_json.schema)
103
+
104
+
let schema_advertises_mime () =
105
+
Alcotest.(check (option string))
106
+
"schema mime" (Some "application/json")
107
+
(Irmin.SHA256.mime Irmin_json.schema)
108
+
109
+
let suite =
110
+
( "irmin_json",
111
+
[
112
+
Alcotest.test_case "parse object -> exact Named" `Quick parse_object_exact;
113
+
Alcotest.test_case "parse array -> exact Indexed" `Quick parse_array_exact;
114
+
Alcotest.test_case "parse nested re-parses" `Quick parse_nested_object;
115
+
Alcotest.test_case "parse scalar -> Named []" `Quick parse_scalar_is_empty;
116
+
Alcotest.test_case "parse invalid -> Named []" `Quick
117
+
parse_invalid_is_empty;
118
+
Alcotest.test_case "serialize then parse roundtrips (object)" `Quick
119
+
roundtrip_object;
120
+
Alcotest.test_case "serialize then parse roundtrips (array)" `Quick
121
+
roundtrip_array;
122
+
Alcotest.test_case "schema name" `Quick schema_is_named_application_json;
123
+
Alcotest.test_case "schema MIME" `Quick schema_advertises_mime;
124
+
] )
125
+
126
+
let () = Alcotest.run "Irmin_json" [ suite ]
+2
test/json/test_irmin_json.mli
+2
test/json/test_irmin_json.mli
+3
test/mime/dune
+3
test/mime/dune
+48
test/mime/test_irmin_mime.ml
+48
test/mime/test_irmin_mime.ml
···
1
+
(** Tests for [Irmin_mime].
2
+
3
+
Spec:
4
+
- Each exported MIME constant matches the IANA/OCI string that codecs and
5
+
[Magic_mime.lookup] agree on.
6
+
- [rules ()] returns the canonical codec-dispatch list in a stable order
7
+
(same call => same list). Must include at least one rule per declared
8
+
MIME (json/yaml/toml/cbor/tar/oci/text) plus gzip-wrapped patterns. *)
9
+
10
+
let check_mime name expected actual = Alcotest.(check string) name expected actual
11
+
12
+
let mime_strings () =
13
+
check_mime "json" "application/json" Irmin_mime.json;
14
+
check_mime "yaml" "application/yaml" Irmin_mime.yaml;
15
+
check_mime "toml" "application/toml" Irmin_mime.toml;
16
+
check_mime "cbor" "application/cbor" Irmin_mime.cbor;
17
+
check_mime "tar" "application/x-tar" Irmin_mime.tar;
18
+
check_mime "gzip" "application/gzip" Irmin_mime.gzip;
19
+
check_mime "oci_manifest" "application/vnd.oci.image.manifest.v1+json"
20
+
Irmin_mime.oci_manifest;
21
+
check_mime "text_plain" "text/plain" Irmin_mime.text_plain;
22
+
check_mime "text_markdown" "text/markdown" Irmin_mime.text_markdown;
23
+
check_mime "octet_stream" "application/octet-stream" Irmin_mime.octet_stream
24
+
25
+
let rules_count_is_stable () =
26
+
let a = Irmin_mime.rules () in
27
+
let b = Irmin_mime.rules () in
28
+
Alcotest.(check int) "same count on each call" (List.length a)
29
+
(List.length b)
30
+
31
+
let rules_include_all_declared_mimes () =
32
+
let n = List.length (Irmin_mime.rules ()) in
33
+
(* Spec: at least one rule per built-in codec (json, yaml, toml, cbor, tar,
34
+
oci_manifest, text_plain, text_markdown) plus gzip-wrapped dispatch
35
+
(tar.gz, tgz, json.gz, yaml.gz). That's at least 12. *)
36
+
Alcotest.(check bool) "at least 12 rules" true (n >= 12)
37
+
38
+
let suite =
39
+
( "irmin_mime",
40
+
[
41
+
Alcotest.test_case "MIME constants match spec" `Quick mime_strings;
42
+
Alcotest.test_case "rules () count is stable" `Quick
43
+
rules_count_is_stable;
44
+
Alcotest.test_case "rules include all built-in codecs" `Quick
45
+
rules_include_all_declared_mimes;
46
+
] )
47
+
48
+
let () = Alcotest.run "Irmin_mime" [ suite ]
+2
test/mime/test_irmin_mime.mli
+2
test/mime/test_irmin_mime.mli
+78
test/oci/test_irmin_oci.ml
+78
test/oci/test_irmin_oci.ml
···
1
+
(** Tests for [Irmin_oci].
2
+
3
+
Spec:
4
+
- An OCI manifest (JSON object) parses to [Named] with one child per
5
+
member. Values are re-serialized JSON kept [`Inline].
6
+
- A top-level array parses to [Indexed].
7
+
- Invalid / non-structural JSON parses to [Named []].
8
+
- Roundtrip: [parse (serialize c)] preserves member names. *)
9
+
10
+
let sample_manifest =
11
+
{|{"schemaVersion":2,"mediaType":"application/vnd.oci.image.manifest.v1+json","config":{"digest":"sha256:abc","size":10},"layers":[]}|}
12
+
13
+
let expected_manifest_members =
14
+
[ "config"; "layers"; "mediaType"; "schemaVersion" ]
15
+
16
+
let parse_manifest_has_exactly_these_members () =
17
+
match Irmin_oci.parse sample_manifest with
18
+
| Irmin.SHA256.Named kids ->
19
+
let names = List.map fst kids |> List.sort String.compare in
20
+
Alcotest.(check (list string))
21
+
"manifest members" expected_manifest_members names
22
+
| _ -> Alcotest.fail "parse_manifest_has_exactly_these_members"
23
+
24
+
let parse_manifest_values_are_inline_json () =
25
+
match Irmin_oci.parse sample_manifest with
26
+
| Irmin.SHA256.Named kids ->
27
+
List.iter
28
+
(fun (n, c) ->
29
+
match c with
30
+
| `Inline _ -> ()
31
+
| `Link _ ->
32
+
Alcotest.failf "member %s should be Inline, not Link" n)
33
+
kids
34
+
| _ -> Alcotest.fail "not Named"
35
+
36
+
let parse_array_length () =
37
+
match Irmin_oci.parse {|[{"x":1},{"x":2}]|} with
38
+
| Irmin.SHA256.Indexed arr ->
39
+
Alcotest.(check int) "two elements" 2 (Array.length arr)
40
+
| _ -> Alcotest.fail "parse_array_length"
41
+
42
+
let parse_invalid_is_empty () =
43
+
match Irmin_oci.parse "not json" with
44
+
| Irmin.SHA256.Named [] -> ()
45
+
| _ -> Alcotest.fail "parse_invalid_is_empty"
46
+
47
+
let roundtrip_preserves_members () =
48
+
let original = Irmin_oci.parse sample_manifest in
49
+
match Irmin_oci.parse (Irmin_oci.serialize original) with
50
+
| Irmin.SHA256.Named kids ->
51
+
let names = List.map fst kids |> List.sort String.compare in
52
+
Alcotest.(check (list string))
53
+
"members preserved" expected_manifest_members names
54
+
| _ -> Alcotest.fail "roundtrip_preserves_members"
55
+
56
+
let schema_has_oci_mime_name () =
57
+
Alcotest.(check string)
58
+
"schema name" "application/vnd.oci.image.manifest.v1+json"
59
+
(Irmin.SHA256.name Irmin_oci.schema)
60
+
61
+
let suite =
62
+
( "irmin_oci",
63
+
[
64
+
Alcotest.test_case "parse manifest exposes exactly its members" `Quick
65
+
parse_manifest_has_exactly_these_members;
66
+
Alcotest.test_case "manifest values are inline JSON bytes" `Quick
67
+
parse_manifest_values_are_inline_json;
68
+
Alcotest.test_case "parse array -> Indexed with right length" `Quick
69
+
parse_array_length;
70
+
Alcotest.test_case "parse invalid -> Named []" `Quick
71
+
parse_invalid_is_empty;
72
+
Alcotest.test_case "roundtrip preserves member names" `Quick
73
+
roundtrip_preserves_members;
74
+
Alcotest.test_case "schema name is OCI manifest MIME" `Quick
75
+
schema_has_oci_mime_name;
76
+
] )
77
+
78
+
let () = Alcotest.run "Irmin_oci" [ suite ]
+2
test/oci/test_irmin_oci.mli
+2
test/oci/test_irmin_oci.mli
-2
test/test.ml
-2
test/test.ml
+3
-1
test/test_admin.ml
test/admin/test_irmin_admin.ml
+3
-1
test/test_admin.ml
test/admin/test_irmin_admin.ml
···
103
103
(Irmin_admin.is_allowed cfg ~email:"Alice@example.com")
104
104
105
105
let suite =
106
-
( "admin",
106
+
( "irmin_admin",
107
107
[
108
108
Alcotest.test_case "parse valid entries" `Quick parse_valid;
109
109
Alcotest.test_case "parse skips missing email" `Quick
···
120
120
Alcotest.test_case "is_allowed case-sensitive" `Quick
121
121
is_allowed_case_sensitive;
122
122
] )
123
+
124
+
let () = Alcotest.run "Irmin_admin" [ suite ]
-2
test/test_admin.mli
-2
test/test_admin.mli
+3
-1
test/test_gzip.ml
test/gzip/test_irmin_gzip.ml
+3
-1
test/test_gzip.ml
test/gzip/test_irmin_gzip.ml
···
61
61
check_string "wrap preserves block bytes" gzipped children
62
62
63
63
let suite =
64
-
( "gzip",
64
+
( "irmin_gzip",
65
65
[
66
66
Alcotest.test_case "roundtrip empty" `Quick roundtrip_empty;
67
67
Alcotest.test_case "roundtrip small" `Quick roundtrip_small;
···
70
70
Alcotest.test_case "malformed rejected" `Quick malformed_rejected;
71
71
Alcotest.test_case "wrap json roundtrip" `Quick wrapped_json_roundtrip;
72
72
] )
73
+
74
+
let () = Alcotest.run "Irmin_gzip" [ suite ]
-2
test/test_gzip.mli
-2
test/test_gzip.mli
+3
test/text/dune
+3
test/text/dune
+32
test/text/test_irmin_text.ml
+32
test/text/test_irmin_text.ml
···
1
+
(** Tests for [Irmin_text].
2
+
3
+
Spec:
4
+
- [plain] is a leaf codec named ["text/plain"] with a line-level merge.
5
+
- [markdown] is a leaf codec named ["text/markdown"] with a line-level
6
+
merge.
7
+
- Both declare their MIME (so [Irmin.Schema.mime_rules] can pick them up).
8
+
- Merge: non-overlapping edits on different lines compose cleanly;
9
+
identical edits are a no-op; conflicting edits yield a [`Conflict]. *)
10
+
11
+
let name_and_mime codec expected_name =
12
+
Alcotest.(check string) (Fmt.str "%s name" expected_name) expected_name
13
+
(Irmin.SHA256.name codec);
14
+
Alcotest.(check (option string))
15
+
(Fmt.str "%s mime" expected_name)
16
+
(Some expected_name) (Irmin.SHA256.mime codec)
17
+
18
+
let plain_is_named_and_has_mime () = name_and_mime Irmin_text.plain "text/plain"
19
+
20
+
let markdown_is_named_and_has_mime () =
21
+
name_and_mime Irmin_text.markdown "text/markdown"
22
+
23
+
let suite =
24
+
( "irmin_text",
25
+
[
26
+
Alcotest.test_case "plain name and MIME" `Quick
27
+
plain_is_named_and_has_mime;
28
+
Alcotest.test_case "markdown name and MIME" `Quick
29
+
markdown_is_named_and_has_mime;
30
+
] )
31
+
32
+
let () = Alcotest.run "Irmin_text" [ suite ]
+2
test/text/test_irmin_text.mli
+2
test/text/test_irmin_text.mli
+3
test/toml/dune
+3
test/toml/dune
+74
test/toml/test_irmin_toml.ml
+74
test/toml/test_irmin_toml.ml
···
1
+
(** Tests for [Irmin_toml].
2
+
3
+
Spec:
4
+
- A top-level TOML table yields [Named] children, one per key.
5
+
- A top-level TOML array yields [Indexed] children.
6
+
- Empty / invalid / scalar input yields [Named []].
7
+
- [parse (serialize c) = c] on the keys of [c] (value bytes may reformat,
8
+
but the logical member set is preserved). *)
9
+
10
+
let parse_table_exact_names () =
11
+
match Irmin_toml.parse {|
12
+
name = "alice"
13
+
age = 30
14
+
|} with
15
+
| Irmin.SHA256.Named kids ->
16
+
let names = List.map fst kids |> List.sort String.compare in
17
+
Alcotest.(check (list string)) "names" [ "age"; "name" ] names
18
+
| _ -> Alcotest.fail "parse_table_exact_names"
19
+
20
+
let parse_scalars_stored_inline () =
21
+
match Irmin_toml.parse {|k = 1|} with
22
+
| Irmin.SHA256.Named [ ("k", `Inline _) ] -> ()
23
+
| _ -> Alcotest.fail "parse_scalars_stored_inline"
24
+
25
+
let parse_empty_is_empty_named () =
26
+
Alcotest.(check bool)
27
+
"empty -> Named []" true
28
+
(match Irmin_toml.parse "" with
29
+
| Irmin.SHA256.Named [] -> true
30
+
| _ -> false)
31
+
32
+
let parse_invalid_is_empty_named () =
33
+
Alcotest.(check bool)
34
+
"garbage -> Named []" true
35
+
(match Irmin_toml.parse "this is ::: not toml {{{" with
36
+
| Irmin.SHA256.Named [] -> true
37
+
| _ -> false)
38
+
39
+
let roundtrip_preserves_names () =
40
+
let original = Irmin_toml.parse {|
41
+
host = "localhost"
42
+
port = 8080
43
+
|} in
44
+
let re = Irmin_toml.parse (Irmin_toml.serialize original) in
45
+
match (original, re) with
46
+
| Irmin.SHA256.Named a, Irmin.SHA256.Named b ->
47
+
Alcotest.(check (list string))
48
+
"names preserved"
49
+
(List.map fst a |> List.sort String.compare)
50
+
(List.map fst b |> List.sort String.compare)
51
+
| _ -> Alcotest.fail "roundtrip_preserves_names"
52
+
53
+
let schema_name_is_application_toml () =
54
+
Alcotest.(check string)
55
+
"schema name" "application/toml"
56
+
(Irmin.SHA256.name Irmin_toml.schema)
57
+
58
+
let suite =
59
+
( "irmin_toml",
60
+
[
61
+
Alcotest.test_case "parse table -> exact names" `Quick
62
+
parse_table_exact_names;
63
+
Alcotest.test_case "parse stores scalar values inline" `Quick
64
+
parse_scalars_stored_inline;
65
+
Alcotest.test_case "parse empty -> Named []" `Quick
66
+
parse_empty_is_empty_named;
67
+
Alcotest.test_case "parse invalid -> Named []" `Quick
68
+
parse_invalid_is_empty_named;
69
+
Alcotest.test_case "roundtrip preserves member names" `Quick
70
+
roundtrip_preserves_names;
71
+
Alcotest.test_case "schema name" `Quick schema_name_is_application_toml;
72
+
] )
73
+
74
+
let () = Alcotest.run "Irmin_toml" [ suite ]
+2
test/toml/test_irmin_toml.mli
+2
test/toml/test_irmin_toml.mli
+10
test/ui/dune
+10
test/ui/dune
+37
test/ui/test_brand.ml
+37
test/ui/test_brand.ml
···
1
+
(** Tests for [Brand].
2
+
3
+
Spec:
4
+
- [logo] is a single anchor pointing at the site root ([href="/"]) and
5
+
contains the Irmin wordmark SVG.
6
+
- The SVG carries an accessible label (["Irmin"]) so screen readers
7
+
announce it. *)
8
+
9
+
let logo_is_a_single_anchor () =
10
+
let s = Tw_html.to_string Brand.logo in
11
+
Alcotest.(check bool) "starts with <a" true
12
+
(Astring.String.is_prefix ~affix:"<a " s);
13
+
Alcotest.(check bool) "ends with </a>" true
14
+
(Astring.String.is_suffix ~affix:"</a>" s)
15
+
16
+
let logo_links_to_root () =
17
+
let s = Tw_html.to_string Brand.logo in
18
+
Alcotest.(check bool) "href=\"/\"" true
19
+
(Astring.String.is_infix ~affix:"href=\"/\"" s)
20
+
21
+
let logo_embeds_accessible_svg () =
22
+
let s = Tw_html.to_string Brand.logo in
23
+
Alcotest.(check bool) "<svg" true (Astring.String.is_infix ~affix:"<svg" s);
24
+
Alcotest.(check bool) "aria-label=\"Irmin\"" true
25
+
(Astring.String.is_infix ~affix:"aria-label=\"Irmin\"" s)
26
+
27
+
let suite =
28
+
( "brand",
29
+
[
30
+
Alcotest.test_case "logo is a single anchor element" `Quick
31
+
logo_is_a_single_anchor;
32
+
Alcotest.test_case "logo links to /" `Quick logo_links_to_root;
33
+
Alcotest.test_case "logo embeds an accessible SVG" `Quick
34
+
logo_embeds_accessible_svg;
35
+
] )
36
+
37
+
let () = Alcotest.run "Brand" [ suite ]
+2
test/ui/test_brand.mli
+2
test/ui/test_brand.mli
+54
test/ui/test_drop_zone.ml
+54
test/ui/test_drop_zone.ml
···
1
+
(** Tests for [Drop_zone].
2
+
3
+
Spec:
4
+
- Renders a [<form>] with:
5
+
- [action] equal to [upload_url]
6
+
- [method="POST"]
7
+
- [enctype="multipart/form-data"]
8
+
- Carries a hidden [<input>] named [dir] whose value is [target_dir].
9
+
- Exposes a [<input type="file">] for selecting files.
10
+
- The file input auto-submits the form on change (so no JS framework is
11
+
required). *)
12
+
13
+
let form ~upload_url ~target_dir =
14
+
Tw_html.to_string (Drop_zone.v ~upload_url ~target_dir)
15
+
16
+
let form_post_action_enctype () =
17
+
let s = form ~upload_url:"/branch/upload" ~target_dir:"sub" in
18
+
Alcotest.(check bool) "<form" true
19
+
(Astring.String.is_infix ~affix:"<form" s);
20
+
Alcotest.(check bool) "action" true
21
+
(Astring.String.is_infix ~affix:"action=\"/branch/upload\"" s);
22
+
Alcotest.(check bool) "POST" true
23
+
(Astring.String.is_infix ~affix:"method=\"POST\"" s);
24
+
Alcotest.(check bool) "multipart" true
25
+
(Astring.String.is_infix ~affix:"enctype=\"multipart/form-data\"" s)
26
+
27
+
let hidden_dir_carries_target () =
28
+
let s = form ~upload_url:"/u" ~target_dir:"docs/src" in
29
+
Alcotest.(check bool) "hidden dir input" true
30
+
(Astring.String.is_infix ~affix:"type=\"hidden\"" s);
31
+
Alcotest.(check bool) "name=dir" true
32
+
(Astring.String.is_infix ~affix:"name=\"dir\"" s);
33
+
Alcotest.(check bool) "value=target" true
34
+
(Astring.String.is_infix ~affix:"value=\"docs/src\"" s)
35
+
36
+
let file_input_present_with_auto_submit () =
37
+
let s = form ~upload_url:"/u" ~target_dir:"" in
38
+
Alcotest.(check bool) "file input" true
39
+
(Astring.String.is_infix ~affix:"type=\"file\"" s);
40
+
Alcotest.(check bool) "auto-submit on change" true
41
+
(Astring.String.is_infix ~affix:"dispatchEvent" s)
42
+
43
+
let suite =
44
+
( "drop_zone",
45
+
[
46
+
Alcotest.test_case "form is POST multipart to upload_url" `Quick
47
+
form_post_action_enctype;
48
+
Alcotest.test_case "hidden dir input carries target_dir" `Quick
49
+
hidden_dir_carries_target;
50
+
Alcotest.test_case "file input auto-submits" `Quick
51
+
file_input_present_with_auto_submit;
52
+
] )
53
+
54
+
let () = Alcotest.run "Drop_zone" [ suite ]
+2
test/ui/test_drop_zone.mli
+2
test/ui/test_drop_zone.mli
+100
test/ui/test_layout.ml
+100
test/ui/test_layout.ml
···
1
+
(** Tests for [Layout].
2
+
3
+
Spec:
4
+
- [page ~title ~auth content] produces a [Tw_html.page] whose HTML
5
+
rendering:
6
+
- has a [<title>] matching [title];
7
+
- contains the content elements;
8
+
- renders auth controls per [auth]:
9
+
* [Off]: no sign-in button, no avatar;
10
+
* [Anon]: a "Sign in with GitHub" control, no avatar;
11
+
* [Signed_in {email; name; ...}]: displays the user's name (or
12
+
email fallback when name is empty) and a sign-out form.
13
+
- [title_h1 text] renders an [<h1>] containing [text].
14
+
- [summary text] renders a paragraph containing [text]. *)
15
+
16
+
let render ~title ~auth content =
17
+
Tw_html.html (Layout.page ~title ~auth content)
18
+
19
+
let title_wires_through_to_head () =
20
+
let s = render ~title:"Hello World" ~auth:Layout.Off [] in
21
+
Alcotest.(check bool) "<title>...</title>" true
22
+
(Astring.String.is_infix ~affix:"<title>Hello World</title>" s)
23
+
24
+
let content_is_rendered () =
25
+
let marker = Tw_html.txt "<<<unique-content-marker>>>" in
26
+
let s = render ~title:"t" ~auth:Layout.Off [ marker ] in
27
+
Alcotest.(check bool) "content visible" true
28
+
(Astring.String.is_infix ~affix:"<<<unique-content-marker>>>" s
29
+
|| Astring.String.is_infix ~affix:"<<<unique-content-marker>>>" s)
30
+
31
+
let auth_off_has_no_signin () =
32
+
let s = render ~title:"t" ~auth:Layout.Off [] in
33
+
Alcotest.(check bool) "no 'Sign in'" false
34
+
(Astring.String.is_infix ~affix:"Sign in" s)
35
+
36
+
let auth_anon_shows_signin () =
37
+
let s = render ~title:"t" ~auth:Layout.Anon [] in
38
+
Alcotest.(check bool) "Sign in" true
39
+
(Astring.String.is_infix ~affix:"Sign in" s)
40
+
41
+
let auth_signed_in_shows_name () =
42
+
let s =
43
+
render ~title:"t"
44
+
~auth:
45
+
(Layout.Signed_in
46
+
{ email = "alice@ex.com"; name = "Alice"; avatar_url = "" })
47
+
[]
48
+
in
49
+
Alcotest.(check bool) "name visible" true
50
+
(Astring.String.is_infix ~affix:"Alice" s);
51
+
Alcotest.(check bool) "Sign out form" true
52
+
(Astring.String.is_infix ~affix:"Sign out" s)
53
+
54
+
let auth_signed_in_email_fallback () =
55
+
(* When name is empty, the email is the visible label. *)
56
+
let s =
57
+
render ~title:"t"
58
+
~auth:
59
+
(Layout.Signed_in
60
+
{ email = "bob@ex.com"; name = ""; avatar_url = "" })
61
+
[]
62
+
in
63
+
Alcotest.(check bool) "email fallback visible" true
64
+
(Astring.String.is_infix ~affix:"bob@ex.com" s)
65
+
66
+
let title_h1_wraps_text () =
67
+
let s = Tw_html.to_string (Layout.title_h1 "Heading") in
68
+
Alcotest.(check bool) "<h1" true
69
+
(Astring.String.is_infix ~affix:"<h1" s);
70
+
Alcotest.(check bool) "heading text" true
71
+
(Astring.String.is_infix ~affix:"Heading" s)
72
+
73
+
let summary_is_a_paragraph () =
74
+
let s = Tw_html.to_string (Layout.summary "Short description.") in
75
+
Alcotest.(check bool) "<p" true
76
+
(Astring.String.is_infix ~affix:"<p" s);
77
+
Alcotest.(check bool) "summary text" true
78
+
(Astring.String.is_infix ~affix:"Short description." s)
79
+
80
+
let suite =
81
+
( "layout",
82
+
[
83
+
Alcotest.test_case "title appears in <title>" `Quick
84
+
title_wires_through_to_head;
85
+
Alcotest.test_case "content elements are rendered" `Quick
86
+
content_is_rendered;
87
+
Alcotest.test_case "Off hides sign-in controls" `Quick
88
+
auth_off_has_no_signin;
89
+
Alcotest.test_case "Anon shows Sign in" `Quick auth_anon_shows_signin;
90
+
Alcotest.test_case "Signed_in shows name + sign-out" `Quick
91
+
auth_signed_in_shows_name;
92
+
Alcotest.test_case "Signed_in falls back to email when name empty"
93
+
`Quick auth_signed_in_email_fallback;
94
+
Alcotest.test_case "title_h1 wraps its text in <h1>" `Quick
95
+
title_h1_wraps_text;
96
+
Alcotest.test_case "summary wraps its text in <p>" `Quick
97
+
summary_is_a_paragraph;
98
+
] )
99
+
100
+
let () = Alcotest.run "Layout" [ suite ]
+2
test/ui/test_layout.mli
+2
test/ui/test_layout.mli
+81
test/ui/test_table.ml
+81
test/ui/test_table.ml
···
1
+
(** Tests for [Table].
2
+
3
+
Spec:
4
+
- [head cols] renders a [<thead>] with one [<th>] per column, each
5
+
showing the column's label.
6
+
- [row cells] renders a [<tr>] containing the given cells.
7
+
- [cell] renders [<td>].
8
+
- [dim_cell] / [mono_cell] are specialised [<td>]s carrying their text.
9
+
- [wrap ~head rows] assembles a [<table>] containing [head] and [rows]. *)
10
+
11
+
let count_substring ~needle s =
12
+
let nlen = String.length needle in
13
+
let slen = String.length s in
14
+
let rec loop i acc =
15
+
if i + nlen > slen then acc
16
+
else if String.sub s i nlen = needle then loop (i + nlen) (acc + 1)
17
+
else loop (i + 1) acc
18
+
in
19
+
loop 0 0
20
+
21
+
let head_has_one_th_per_column () =
22
+
let h =
23
+
Table.head
24
+
[ ("Name", Table.Left); ("Size", Table.Right); ("Hash", Table.Right) ]
25
+
in
26
+
let s = Tw_html.to_string h in
27
+
Alcotest.(check int) "3 <th>" 3 (count_substring ~needle:"<th" s);
28
+
List.iter
29
+
(fun label ->
30
+
Alcotest.(check bool)
31
+
(Fmt.str "label %s visible" label)
32
+
true
33
+
(Astring.String.is_infix ~affix:label s))
34
+
[ "Name"; "Size"; "Hash" ]
35
+
36
+
let row_is_a_tr () =
37
+
let s = Tw_html.to_string (Table.row [ Table.cell [ Tw_html.txt "x" ] ]) in
38
+
Alcotest.(check bool) "<tr" true
39
+
(Astring.String.is_infix ~affix:"<tr" s);
40
+
Alcotest.(check bool) "<td" true
41
+
(Astring.String.is_infix ~affix:"<td" s);
42
+
Alcotest.(check bool) "cell content" true
43
+
(Astring.String.is_infix ~affix:">x<" s)
44
+
45
+
let dim_and_mono_cells_render_text () =
46
+
let d = Tw_html.to_string (Table.dim_cell "—") in
47
+
let m = Tw_html.to_string (Table.mono_cell "abcdef0") in
48
+
Alcotest.(check bool) "dim text" true (Astring.String.is_infix ~affix:"—" d);
49
+
Alcotest.(check bool) "mono text" true
50
+
(Astring.String.is_infix ~affix:"abcdef0" m);
51
+
Alcotest.(check bool) "dim differs from mono" true
52
+
(not (String.equal d m))
53
+
54
+
let wrap_produces_table_tag () =
55
+
let s =
56
+
Tw_html.to_string
57
+
(Table.wrap
58
+
~head:(Table.head [ ("c", Table.Left) ])
59
+
[ Table.row [ Table.cell [ Tw_html.txt "r" ] ] ])
60
+
in
61
+
Alcotest.(check bool) "<table" true
62
+
(Astring.String.is_infix ~affix:"<table" s);
63
+
Alcotest.(check bool) "contains head" true
64
+
(Astring.String.is_infix ~affix:"<th" s);
65
+
Alcotest.(check bool) "contains row" true
66
+
(Astring.String.is_infix ~affix:"<tr" s)
67
+
68
+
let suite =
69
+
( "table",
70
+
[
71
+
Alcotest.test_case "head: one <th> per column, all labels visible"
72
+
`Quick head_has_one_th_per_column;
73
+
Alcotest.test_case "row is a <tr> containing its cells" `Quick
74
+
row_is_a_tr;
75
+
Alcotest.test_case "dim_cell and mono_cell render distinctly" `Quick
76
+
dim_and_mono_cells_render_text;
77
+
Alcotest.test_case "wrap yields a <table> containing head + rows" `Quick
78
+
wrap_produces_table_tag;
79
+
] )
80
+
81
+
let () = Alcotest.run "Table" [ suite ]
+2
test/ui/test_table.mli
+2
test/ui/test_table.mli
+45
test/ui/test_tag.ml
+45
test/ui/test_tag.ml
···
1
+
(** Tests for [Tag].
2
+
3
+
Spec:
4
+
- [v ?tone text] renders [text] inside a rounded pill-shaped element.
5
+
- [mono ?tone text] is the monospace variant.
6
+
- Different tones produce visually distinct outputs (different CSS
7
+
classes/colours) even for the same [text]. *)
8
+
9
+
let v_renders_text () =
10
+
let s = Tw_html.to_string (Tag.v "preview") in
11
+
Alcotest.(check bool) "label visible" true
12
+
(Astring.String.is_infix ~affix:"preview" s)
13
+
14
+
let mono_renders_text () =
15
+
let s = Tw_html.to_string (Tag.mono "abcd1234") in
16
+
Alcotest.(check bool) "label visible" true
17
+
(Astring.String.is_infix ~affix:"abcd1234" s)
18
+
19
+
let tones_are_visually_distinct () =
20
+
let same_text = "x" in
21
+
let outs =
22
+
List.map
23
+
(fun tone -> Tw_html.to_string (Tag.v ~tone same_text))
24
+
[ Tag.Neutral; Tag.Primary; Tag.Accent; Tag.Muted; Tag.Danger ]
25
+
in
26
+
(* All five renderings must differ from each other. *)
27
+
let uniq = List.sort_uniq String.compare outs in
28
+
Alcotest.(check int) "all tones distinct" 5 (List.length uniq)
29
+
30
+
let mono_differs_from_v () =
31
+
let a = Tw_html.to_string (Tag.v "x") in
32
+
let b = Tw_html.to_string (Tag.mono "x") in
33
+
Alcotest.(check bool) "mono differs" true (not (String.equal a b))
34
+
35
+
let suite =
36
+
( "tag",
37
+
[
38
+
Alcotest.test_case "v renders its text" `Quick v_renders_text;
39
+
Alcotest.test_case "mono renders its text" `Quick mono_renders_text;
40
+
Alcotest.test_case "each tone produces distinct output" `Quick
41
+
tones_are_visually_distinct;
42
+
Alcotest.test_case "mono differs from v" `Quick mono_differs_from_v;
43
+
] )
44
+
45
+
let () = Alcotest.run "Tag" [ suite ]
+2
test/ui/test_tag.mli
+2
test/ui/test_tag.mli
+3
test/yaml/dune
+3
test/yaml/dune
+65
test/yaml/test_irmin_yaml.ml
+65
test/yaml/test_irmin_yaml.ml
···
1
+
(** Tests for [Irmin_yaml].
2
+
3
+
Spec (mirroring [Irmin_json] but with YAML surface syntax):
4
+
- A YAML mapping whose keys are strings yields [Named] children.
5
+
Non-string-keyed entries are dropped silently.
6
+
- A YAML sequence yields [Indexed] children.
7
+
- Scalar input yields [Named []].
8
+
- [parse (serialize c) = c] on member names (YAML re-emission may
9
+
reformat values but must preserve the logical member set). *)
10
+
11
+
let parse_mapping_exact_names () =
12
+
match Irmin_yaml.parse "name: alice\nage: 30\n" with
13
+
| Irmin.SHA256.Named kids ->
14
+
let names = List.map fst kids |> List.sort String.compare in
15
+
Alcotest.(check (list string)) "names" [ "age"; "name" ] names
16
+
| _ -> Alcotest.fail "parse_mapping_exact_names"
17
+
18
+
let parse_sequence_exact_length () =
19
+
match Irmin_yaml.parse "- a\n- b\n- c\n" with
20
+
| Irmin.SHA256.Indexed arr ->
21
+
Alcotest.(check int) "three items" 3 (Array.length arr);
22
+
Array.iteri
23
+
(fun i c ->
24
+
match c with
25
+
| `Inline _ -> ()
26
+
| `Link _ ->
27
+
Alcotest.failf "sequence index %d should be Inline" i)
28
+
arr
29
+
| _ -> Alcotest.fail "parse_sequence_exact_length"
30
+
31
+
let parse_scalar_is_empty () =
32
+
match Irmin_yaml.parse "42" with
33
+
| Irmin.SHA256.Named [] -> ()
34
+
| _ -> Alcotest.fail "parse_scalar_is_empty"
35
+
36
+
let roundtrip_preserves_names () =
37
+
let original = Irmin_yaml.parse "host: localhost\nport: 8080\n" in
38
+
let re = Irmin_yaml.parse (Irmin_yaml.serialize original) in
39
+
match (original, re) with
40
+
| Irmin.SHA256.Named a, Irmin.SHA256.Named b ->
41
+
Alcotest.(check (list string))
42
+
"names preserved"
43
+
(List.map fst a |> List.sort String.compare)
44
+
(List.map fst b |> List.sort String.compare)
45
+
| _ -> Alcotest.fail "roundtrip_preserves_names"
46
+
47
+
let schema_name_is_application_yaml () =
48
+
Alcotest.(check string)
49
+
"schema name" "application/yaml"
50
+
(Irmin.SHA256.name Irmin_yaml.schema)
51
+
52
+
let suite =
53
+
( "irmin_yaml",
54
+
[
55
+
Alcotest.test_case "parse mapping -> exact names" `Quick
56
+
parse_mapping_exact_names;
57
+
Alcotest.test_case "parse sequence -> exact length" `Quick
58
+
parse_sequence_exact_length;
59
+
Alcotest.test_case "parse scalar -> Named []" `Quick parse_scalar_is_empty;
60
+
Alcotest.test_case "roundtrip preserves member names" `Quick
61
+
roundtrip_preserves_names;
62
+
Alcotest.test_case "schema name" `Quick schema_name_is_application_yaml;
63
+
] )
64
+
65
+
let () = Alcotest.run "Irmin_yaml" [ suite ]