Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin: drop phantom 'b from Heap.t, consolidate test suite
Heap.t: ('h, 'v, 'b) t → ('h, 'v) t. The phantom 'b parameter
served no purpose — layer, recording, and of_list produce heaps
with no meaningful backend tag. The record-of-closures is the
correct representation for this case (composable heaps can't be
expressed as a single BACKEND module).
Tests: move schema and tar tests from irmin/test/{schema,tar}/
into irmin/test/test_{schema,tar}.ml. All 19 tests now run from
a single `dune exec irmin/test/test.exe`.
+404
-411
+1
-1
bin/cmd_proof.ml
+1
-1
bin/cmd_proof.ml
···
56
56
57
57
(** Build a flat tree from key=value pairs. Each key is a direct child of the
58
58
root; values are stored as blobs. *)
59
-
let build_tree (heap : (Digestif.SHA256.t, string, _) Irmin.Heap.t)
59
+
let build_tree (heap : (Digestif.SHA256.t, string) Irmin.Heap.t)
60
60
(entries : (string * string) list) : Digestif.SHA256.t =
61
61
let children =
62
62
List.map
+1
-1
bin/common.ml
+1
-1
bin/common.ml
+1
-2
lib/atproto/irmin_atproto.ml
+1
-2
lib/atproto/irmin_atproto.ml
···
109
109
110
110
(* ===== MST bridge ===== *)
111
111
112
-
let mst_store (heap : (Atp.Cid.t, string, _) Irmin.Heap.t) : Atp.Cid.t Mst.store
113
-
=
112
+
let mst_store (heap : (Atp.Cid.t, string) Irmin.Heap.t) : Atp.Cid.t Mst.store =
114
113
{
115
114
get = Irmin.Heap.find heap;
116
115
put = (fun h d -> Irmin.Heap.put heap h d);
+4
-4
lib/atproto/irmin_atproto.mli
+4
-4
lib/atproto/irmin_atproto.mli
···
23
23
val record : S.children S.t
24
24
(** Recursive DAG-CBOR record schema. *)
25
25
26
-
val heap : Atp.Blockstore.writable -> (Atp.Cid.t, string, _) Irmin.Heap.t
26
+
val heap : Atp.Blockstore.writable -> (Atp.Cid.t, string) Irmin.Heap.t
27
27
(** Wrap an ATProto blockstore as an Irmin heap. *)
28
28
29
-
val mst_store : (Atp.Cid.t, string, _) Irmin.Heap.t -> Atp.Cid.t Mst.store
29
+
val mst_store : (Atp.Cid.t, string) Irmin.Heap.t -> Atp.Cid.t Mst.store
30
30
(** Bridge an Irmin heap to the MST library's store interface. *)
31
31
32
-
val memory : unit -> (Atp.Cid.t, string, _) Irmin.Heap.t
32
+
val memory : unit -> (Atp.Cid.t, string) Irmin.Heap.t
33
33
(** Create an in-memory ATProto heap. *)
34
34
35
-
val filesystem : _ Eio.Path.t -> (Atp.Cid.t, string, _) Irmin.Heap.t
35
+
val filesystem : _ Eio.Path.t -> (Atp.Cid.t, string) Irmin.Heap.t
36
36
(** Create a filesystem-backed ATProto heap at the given path. *)
+3
-3
lib/git/irmin_git.mli
+3
-3
lib/git/irmin_git.mli
···
41
41
val tree : S.children S.t
42
42
(** The default Git tree schema: recursive directories with entries. *)
43
43
44
-
val heap : Git.Repository.t -> (Irmin.Hash.sha1, string, _) Irmin.Heap.t
44
+
val heap : Git.Repository.t -> (Irmin.Hash.sha1, string) Irmin.Heap.t
45
45
(** Wrap a Git repository as an Irmin heap. *)
46
46
47
47
val init :
48
48
sw:Eio.Switch.t ->
49
49
fs:Eio.Fs.dir_ty Eio.Path.t ->
50
50
path:Fpath.t ->
51
-
(Irmin.Hash.sha1, string, _) Irmin.Heap.t
51
+
(Irmin.Hash.sha1, string) Irmin.Heap.t
52
52
(** Initialize a new Git repository and wrap it as an Irmin heap. *)
53
53
54
54
val open_ :
55
55
sw:Eio.Switch.t ->
56
56
fs:Eio.Fs.dir_ty Eio.Path.t ->
57
57
path:Fpath.t ->
58
-
(Irmin.Hash.sha1, string, _) Irmin.Heap.t
58
+
(Irmin.Hash.sha1, string) Irmin.Heap.t
59
59
(** Open an existing Git repository and wrap it as an Irmin heap. *)
+2
-2
lib/heap.ml
+2
-2
lib/heap.ml
···
16
16
val close : t -> unit
17
17
end
18
18
19
-
type ('h, 'v, 'b) t = {
19
+
type ('h, 'v) t = {
20
20
find : 'h -> 'v option;
21
21
put : 'h -> 'v -> unit;
22
22
mem : 'h -> bool;
···
46
46
let pp ppf _ = Fmt.pf ppf "<heap>"
47
47
48
48
module Make (B : BACKEND) = struct
49
-
let v (s : B.t) : (B.hash, B.block, _) t =
49
+
let v (s : B.t) : (B.hash, B.block) t =
50
50
{
51
51
find = B.find s;
52
52
put = B.put s;
+19
-20
lib/heap.mli
+19
-20
lib/heap.mli
···
22
22
23
23
(** {1:types Types} *)
24
24
25
-
type ('h, 'v, 'b) t
26
-
(** A heap parameterized by hash type ['h], block type ['v], and backend tag
27
-
['b]. *)
25
+
type ('h, 'v) t
26
+
(** A heap parameterized by hash type ['h] and block type ['v]. *)
28
27
29
-
val pp : Format.formatter -> _ t -> unit
28
+
val pp : Format.formatter -> (_, _) t -> unit
30
29
(** Pretty-print a heap (debug only — does not enumerate contents). *)
31
30
32
31
(** {1:blocks Blocks} *)
33
32
34
-
val find : ('h, 'v, _) t -> 'h -> 'v option
33
+
val find : ('h, 'v) t -> 'h -> 'v option
35
34
(** [find heap h] returns the block at [h], if present. *)
36
35
37
-
val put : ('h, 'v, _) t -> 'h -> 'v -> unit
36
+
val put : ('h, 'v) t -> 'h -> 'v -> unit
38
37
(** [put heap h v] stores [v] under [h]. *)
39
38
40
-
val mem : ('h, _, _) t -> 'h -> bool
39
+
val mem : ('h, _) t -> 'h -> bool
41
40
(** [mem heap h] is [true] iff [h] is in [heap]. *)
42
41
43
-
val batch : ('h, 'v, _) t -> ('h * 'v) list -> unit
42
+
val batch : ('h, 'v) t -> ('h * 'v) list -> unit
44
43
(** [batch heap pairs] stores all [pairs] atomically (best effort). *)
45
44
46
45
(** {1:refs Named References}
47
46
48
47
Mutable pointers into the heap. Used for branches, HEAD, etc. *)
49
48
50
-
val ref : ('h, _, _) t -> string -> 'h option
49
+
val ref : ('h, _) t -> string -> 'h option
51
50
(** [ref heap name] is the hash bound to [name], if any. *)
52
51
53
-
val set_ref : ('h, _, _) t -> string -> 'h -> unit
52
+
val set_ref : ('h, _) t -> string -> 'h -> unit
54
53
(** [set_ref heap name h] binds [name] to [h]. *)
55
54
56
-
val del_ref : ('h, _, _) t -> string -> unit
55
+
val del_ref : ('h, _) t -> string -> unit
57
56
(** [del_ref heap name] removes [name]. *)
58
57
59
-
val list_refs : (_, _, _) t -> string list
58
+
val list_refs : (_, _) t -> string list
60
59
(** [list_refs heap] lists all ref names. *)
61
60
62
-
val cas_ref : ('h, _, _) t -> string -> test:'h option -> set:'h option -> bool
61
+
val cas_ref : ('h, _) t -> string -> test:'h option -> set:'h option -> bool
63
62
(** Compare-and-set on a ref. *)
64
63
65
64
(** {1:lifecycle Lifecycle} *)
66
65
67
-
val flush : (_, _, _) t -> unit
66
+
val flush : (_, _) t -> unit
68
67
(** [flush heap] flushes pending writes to the backend. *)
69
68
70
-
val close : (_, _, _) t -> unit
69
+
val close : (_, _) t -> unit
71
70
(** [close heap] releases backend resources. *)
72
71
73
72
(** {1:backend Backend binding} *)
···
115
114
end
116
115
117
116
module Make (B : BACKEND) : sig
118
-
val v : B.t -> (B.hash, B.block, _) t
117
+
val v : B.t -> (B.hash, B.block) t
119
118
(** [v backend] wraps a backend instance into a typed heap. *)
120
119
end
121
120
···
123
122
124
123
Building blocks for Merkle proofs. *)
125
124
126
-
val recording : ('h, 'v, 'b) t -> ('h, 'v, 'b) t * (unit -> ('h * 'v) list)
125
+
val recording : ('h, 'v) t -> ('h, 'v) t * (unit -> ('h * 'v) list)
127
126
(** [recording heap] wraps [heap] so that every [get] call is recorded. Returns
128
127
the wrapped heap and a function that retrieves the recorded [(hash, block)]
129
128
pairs. *)
130
129
131
-
val of_list : equal:('h -> 'h -> bool) -> ('h * 'v) list -> ('h, 'v, 'b) t
130
+
val of_list : equal:('h -> 'h -> bool) -> ('h * 'v) list -> ('h, 'v) t
132
131
(** [of_list ~equal blocks] creates a heap backed by [blocks]. *)
133
132
134
-
val layer : ('h, 'v, _) t -> ('h, 'v, _) t -> ('h, 'v, _) t
133
+
val layer : ('h, 'v) t -> ('h, 'v) t -> ('h, 'v) t
135
134
(** [layer top bottom] reads from [top] first, then [bottom] on miss. Writes go
136
135
to [top]. Found blocks from [bottom] are cached in [top]. *)
137
136
138
-
val to_seq : ('h, 'v, _) t -> ('h * 'v) Seq.t
137
+
val to_seq : ('h, 'v) t -> ('h * 'v) Seq.t
139
138
(** [to_seq heap] enumerates the heap's blocks. *)
+7
-7
lib/schema.ml
+7
-7
lib/schema.ml
···
141
141
142
142
type step_result = Step : 'a t * 'a cursor -> step_result
143
143
144
-
let at (heap : (H.hash, H.block, _) Heap.t) schema (h : H.hash) =
144
+
let at (heap : (H.hash, H.block) Heap.t) schema (h : H.hash) =
145
145
{
146
146
heap = Heap.find heap;
147
147
schema;
···
151
151
cached_children = None;
152
152
}
153
153
154
-
let empty (heap : (H.hash, H.block, _) Heap.t) schema =
154
+
let empty (heap : (H.hash, H.block) Heap.t) schema =
155
155
let i = resolve schema in
156
156
let empty_block =
157
157
match i.shape with
···
353
353
let remove c name =
354
354
{ c with overlay = (name, `Remove) :: c.overlay; cached_children = None }
355
355
356
-
let flush (type a) (c : a cursor) (heap : (H.hash, H.block, _) Heap.t) =
356
+
let flush (type a) (c : a cursor) (heap : (H.hash, H.block) Heap.t) =
357
357
let i = resolve c.schema in
358
358
match i.shape with
359
359
| Leaf -> (
···
418
418
419
419
type resolution = { path : string list; value : H.block }
420
420
421
-
let merge (type a) (heap : (H.hash, H.block, _) Heap.t) (schema : a t)
421
+
let merge (type a) (heap : (H.hash, H.block) Heap.t) (schema : a t)
422
422
~(ancestor : a cursor) ~(ours : a cursor) ~(theirs : a cursor) =
423
423
let conflicts = ref [] in
424
424
let add_conflict ~path ~ancestor ~ours ~theirs message =
···
616
616
in
617
617
(at heap schema merged_hash, List.rev !conflicts)
618
618
619
-
let resolve_conflicts (type a) (heap : (H.hash, H.block, _) Heap.t)
619
+
let resolve_conflicts (type a) (heap : (H.hash, H.block) Heap.t)
620
620
(schema : a t) (cursor : a cursor) (resolutions : resolution list) :
621
621
a cursor =
622
622
let s = ref (Step (schema, cursor)) in
···
738
738
type proof = {
739
739
before : H.hash;
740
740
after : H.hash;
741
-
heap : (H.hash, H.block, unit) Heap.t;
741
+
heap : (H.hash, H.block) Heap.t;
742
742
}
743
743
744
-
let produce (type a) (heap : (H.hash, H.block, _) Heap.t) (schema : a t)
744
+
let produce (type a) (heap : (H.hash, H.block) Heap.t) (schema : a t)
745
745
(root : H.hash) (f : a cursor -> step_result * 'b) : proof * 'b =
746
746
let recording_heap, get_recorded = Heap.recording heap in
747
747
let c = at recording_heap schema root in
+11
-11
lib/schema.mli
+11
-11
lib/schema.mli
···
135
135
136
136
(** {2 Create} *)
137
137
138
-
val at : (H.hash, H.block, _) Heap.t -> 'a t -> H.hash -> 'a cursor
138
+
val at : (H.hash, H.block) Heap.t -> 'a t -> H.hash -> 'a cursor
139
139
(** [at heap codec root] is a cursor at [root] in [heap]. *)
140
140
141
-
val empty : (H.hash, H.block, _) Heap.t -> 'a t -> 'a cursor
141
+
val empty : (H.hash, H.block) Heap.t -> 'a t -> 'a cursor
142
142
(** [empty heap codec] is a cursor at an empty node (must be a Tree codec). *)
143
143
144
144
(** {2 Navigate} *)
···
195
195
val remove : 'a cursor -> string -> 'a cursor
196
196
(** [remove c name] removes child [name]. *)
197
197
198
-
val flush : _ cursor -> (H.hash, H.block, _) Heap.t -> H.hash
198
+
val flush : _ cursor -> (H.hash, H.block) Heap.t -> H.hash
199
199
(** [flush c heap] writes pending mutations to [heap] and returns the new root
200
200
hash. *)
201
201
···
203
203
204
204
Named mutable pointers into the heap. *)
205
205
206
-
val head : (H.hash, _, _) Heap.t -> branch:string -> H.hash option
206
+
val head : (H.hash, _) Heap.t -> branch:string -> H.hash option
207
207
(** [head heap ~branch] is the hash at the tip of [branch]. *)
208
208
209
-
val set_head : (H.hash, _, _) Heap.t -> branch:string -> H.hash -> unit
209
+
val set_head : (H.hash, _) Heap.t -> branch:string -> H.hash -> unit
210
210
(** [set_head heap ~branch h] advances [branch] to [h]. *)
211
211
212
-
val branches : (_, _, _) Heap.t -> string list
212
+
val branches : (_, _) Heap.t -> string list
213
213
(** [branches heap] lists all branches. *)
214
214
215
215
val update_branch :
216
-
(H.hash, _, _) Heap.t ->
216
+
(H.hash, _) Heap.t ->
217
217
branch:string ->
218
218
old:H.hash option ->
219
219
new_:H.hash ->
···
253
253
}
254
254
255
255
val merge :
256
-
(H.hash, H.block, _) Heap.t ->
256
+
(H.hash, H.block) Heap.t ->
257
257
'a t ->
258
258
ancestor:'a cursor ->
259
259
ours:'a cursor ->
···
264
264
any unresolved conflicts. *)
265
265
266
266
val resolve :
267
-
(H.hash, H.block, _) Heap.t ->
267
+
(H.hash, H.block) Heap.t ->
268
268
'a t ->
269
269
'a cursor ->
270
270
resolution list ->
···
315
315
type proof = {
316
316
before : H.hash; (** Root hash before the computation. *)
317
317
after : H.hash; (** Root hash after the computation. *)
318
-
heap : (H.hash, H.block, unit) Heap.t; (** The subheap. *)
318
+
heap : (H.hash, H.block) Heap.t; (** The subheap. *)
319
319
}
320
320
321
321
val produce :
322
-
(H.hash, H.block, _) Heap.t ->
322
+
(H.hash, H.block) Heap.t ->
323
323
'a t ->
324
324
H.hash ->
325
325
('a cursor -> step_result * 'b) ->
+1
-1
lib/tar/irmin_tar.ml
+1
-1
lib/tar/irmin_tar.ml
···
58
58
59
59
(** Build a Merkle tree from a list of (path, content) pairs. Writes all blobs
60
60
and tree nodes to the heap. Returns the root hash. *)
61
-
let of_entries (heap : (Digestif.SHA256.t, string, _) Irmin.Heap.t)
61
+
let of_entries (heap : (Digestif.SHA256.t, string) Irmin.Heap.t)
62
62
(entries : (string * string) list) : Digestif.SHA256.t =
63
63
(* Group entries by top-level directory *)
64
64
let split_path path =
+1
-1
lib/tar/irmin_tar.mli
+1
-1
lib/tar/irmin_tar.mli
···
15
15
(** Recursive tar tree schema. *)
16
16
17
17
val of_entries :
18
-
(Digestif.SHA256.t, string, _) Irmin.Heap.t ->
18
+
(Digestif.SHA256.t, string) Irmin.Heap.t ->
19
19
(string * string) list ->
20
20
Digestif.SHA256.t
21
21
(** [of_entries heap entries] builds a Merkle tree from [(path, content)] pairs,
+18
-2
test/dune
+18
-2
test/dune
···
1
1
(test
2
2
(name test)
3
-
(modules test test_hash test_heap test_irmin test_schema test_worktree)
4
-
(libraries irmin alcotest))
3
+
(modules
4
+
test
5
+
test_hash
6
+
test_heap
7
+
test_irmin
8
+
test_schema
9
+
test_tar
10
+
test_worktree)
11
+
(libraries
12
+
irmin
13
+
irmin_git
14
+
irmin_tar
15
+
git
16
+
alcotest
17
+
eio_main
18
+
jsont
19
+
jsont.bytesrw
20
+
digestif))
5
21
6
22
(cram
7
23
(package irmin)
-3
test/schema/dune
-3
test/schema/dune
-326
test/schema/test.ml
-326
test/schema/test.ml
···
1
-
(** Test the new schema2 API: node/=>/fix/self_describing.
2
-
3
-
Validates Git tree + JSON blob navigation and proof. *)
4
-
5
-
module S = Irmin.Schema.Make (struct
6
-
type hash = Irmin.Hash.sha1
7
-
type block = string
8
-
9
-
let hash_equal = Irmin.Hash.equal
10
-
11
-
let hash_block data =
12
-
Irmin.Hash.sha1_of_bytes
13
-
(Digestif.SHA1.to_raw_string (Digestif.SHA1.digest_string data))
14
-
end)
15
-
16
-
(* ===== Parse functions ===== *)
17
-
18
-
let git_hash h = Git.Hash.of_raw_string (Irmin.Hash.to_bytes h)
19
-
let irmin_hash h = Irmin.Hash.sha1_of_bytes (Git.Hash.to_raw_string h)
20
-
21
-
let git_tree_parse : S.dec =
22
-
fun data ->
23
-
match Git.Tree.of_string data with
24
-
| Ok tree ->
25
-
S.Named
26
-
(Git.Tree.to_list tree
27
-
|> List.map (fun (entry : Git.Tree.entry) ->
28
-
(entry.name, `Inline (Git.Tree.to_string (Git.Tree.v [ entry ])))))
29
-
| Error _ -> S.Named []
30
-
31
-
let git_entry_parse : S.dec =
32
-
fun data ->
33
-
match Git.Tree.of_string data with
34
-
| Ok tree -> (
35
-
match Git.Tree.to_list tree with
36
-
| [ entry ] ->
37
-
S.Named
38
-
[
39
-
("mode", `Inline (Git.Tree.perm_to_string entry.perm));
40
-
("target", `Link (irmin_hash entry.hash));
41
-
]
42
-
| _ -> S.Named [])
43
-
| Error _ -> S.Named []
44
-
45
-
let json_nv (type a) (n : a Jsont.node) : a = fst n
46
-
47
-
let json_parse : S.dec =
48
-
fun data ->
49
-
let enc c =
50
-
match Jsont_bytesrw.encode_string Jsont.json c with
51
-
| Ok s -> s
52
-
| Error _ -> ""
53
-
in
54
-
match Jsont_bytesrw.decode_string Jsont.json data with
55
-
| Ok (Jsont.Object obj) ->
56
-
S.Named
57
-
(List.map
58
-
(fun ((n, c) : Jsont.mem) -> (json_nv n, `Inline (enc c)))
59
-
(json_nv obj))
60
-
| Ok (Jsont.Array arr) ->
61
-
S.Indexed
62
-
(Array.of_list (List.map (fun c -> `Inline (enc c)) (json_nv arr)))
63
-
| _ -> S.Named []
64
-
65
-
(* ===== Domain combinators ===== *)
66
-
67
-
(* Serialize stubs — sufficient for read-only tests *)
68
-
let noop_serialize _ = ""
69
-
70
-
let directory rules =
71
-
S.node ~name:"application/x-git-tree" ~dec:git_tree_parse ~enc:noop_serialize
72
-
~rules ()
73
-
74
-
let entry rules =
75
-
S.node ~name:"application/x-git-entry" ~dec:git_entry_parse
76
-
~enc:noop_serialize ~rules ()
77
-
78
-
let json_node rules =
79
-
S.node ~name:"application/json" ~dec:json_parse ~enc:noop_serialize ~rules ()
80
-
81
-
(* ===== Schemas ===== *)
82
-
83
-
let ( => ) = S.( => )
84
-
let json = S.fix (fun self -> json_node [ "*" => self ])
85
-
let git_entry target = entry [ "mode" => S.opaque; "target" => target ]
86
-
87
-
let git_tree =
88
-
S.fix (fun self ->
89
-
directory [ "*.json" => git_entry json; "*" => git_entry self ])
90
-
91
-
(* ===== Test helpers ===== *)
92
-
93
-
let with_git_repo f =
94
-
Eio_main.run @@ fun env ->
95
-
Eio.Switch.run @@ fun sw ->
96
-
let fs = Eio.Stdenv.fs env in
97
-
let name = Fmt.str "/tmp/irmin-test-%d" (Random.int 1_000_000) in
98
-
let fpath = Fpath.v name in
99
-
let path = Eio.Path.(fs / name) in
100
-
let repo = Git.Repository.init ~sw ~fs fpath in
101
-
let heap = Irmin_git.heap repo in
102
-
let result = f repo heap in
103
-
(try Eio.Path.rmtree path with Eio.Io _ -> ());
104
-
result
105
-
106
-
(* ===== Tests ===== *)
107
-
108
-
let git_cursor () =
109
-
with_git_repo @@ fun repo heap ->
110
-
(* Build a tree with a JSON file and a regular file *)
111
-
let json_data = {|{"name":"irmin","version":2}|} in
112
-
let ml_data = "let () = ()" in
113
-
let json_blob = Git.Blob.of_string json_data in
114
-
let ml_blob = Git.Blob.of_string ml_data in
115
-
let json_hash = Git.Hash.digest_string ~kind:`Blob json_data in
116
-
let ml_hash = Git.Hash.digest_string ~kind:`Blob ml_data in
117
-
ignore (Git.Repository.write repo (Git.Value.blob json_blob));
118
-
ignore (Git.Repository.write repo (Git.Value.blob ml_blob));
119
-
let tree =
120
-
Git.Tree.v
121
-
[
122
-
Git.Tree.entry ~perm:`Normal ~name:"config.json" json_hash;
123
-
Git.Tree.entry ~perm:`Normal ~name:"main.ml" ml_hash;
124
-
]
125
-
in
126
-
ignore (Git.Repository.write repo (Git.Value.tree tree));
127
-
let root_hash = irmin_hash (Git.Tree.digest tree) in
128
-
129
-
(* Navigate: tree -> config.json -> target -> JSON -> name *)
130
-
let c = S.at heap git_tree root_hash in
131
-
132
-
(* Children of root *)
133
-
let kids = S.list c |> List.map fst |> List.sort String.compare in
134
-
Alcotest.(check (list string)) "root" [ "config.json"; "main.ml" ] kids;
135
-
136
-
(* Step into config.json entry *)
137
-
let (S.Step (_, c)) = S.step_any c "config.json" |> Option.get in
138
-
let entry_kids = S.list c |> List.map fst |> List.sort String.compare in
139
-
Alcotest.(check (list string)) "entry fields" [ "mode"; "target" ] entry_kids;
140
-
141
-
(* Mode *)
142
-
let (S.Step (_, c_mode)) = S.step_any c "mode" |> Option.get in
143
-
Alcotest.(check (option string)) "mode" (Some "100644") (S.get_block c_mode);
144
-
145
-
(* Follow target link -> JSON blob *)
146
-
let (S.Step (_, c_blob)) = S.step_any c "target" |> Option.get in
147
-
148
-
(* JSON navigation: object keys *)
149
-
let json_kids = S.list c_blob |> List.map fst |> List.sort String.compare in
150
-
Alcotest.(check (list string)) "json keys" [ "name"; "version" ] json_kids;
151
-
152
-
(* Step into JSON "name" *)
153
-
let (S.Step (_, c_name)) = S.step_any c_blob "name" |> Option.get in
154
-
Alcotest.(check (option string))
155
-
"json name" (Some {|"irmin"|}) (S.get_block c_name);
156
-
157
-
(* Go up: name -> blob -> entry -> tree *)
158
-
let (S.Step (_, c_up)) = S.up c_name |> Option.get in
159
-
let (S.Step (_, c_up)) = S.up c_up |> Option.get in
160
-
let (S.Step (_, c_up)) = S.up c_up |> Option.get in
161
-
let root_kids = S.list c_up |> List.map fst |> List.sort String.compare in
162
-
Alcotest.(check (list string))
163
-
"back to root"
164
-
[ "config.json"; "main.ml" ]
165
-
root_kids;
166
-
167
-
(* Path tracking *)
168
-
Alcotest.(check (list string))
169
-
"name path"
170
-
[ "config.json"; "target"; "name" ]
171
-
(S.path c_name)
172
-
173
-
let proof () =
174
-
with_git_repo @@ fun repo heap ->
175
-
let json_data = {|{"key":"value"}|} in
176
-
let blob = Git.Blob.of_string json_data in
177
-
let h = Git.Hash.digest_string ~kind:`Blob json_data in
178
-
ignore (Git.Repository.write repo (Git.Value.blob blob));
179
-
let tree = Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"data.json" h ] in
180
-
ignore (Git.Repository.write repo (Git.Value.tree tree));
181
-
let root_hash = irmin_hash (Git.Tree.digest tree) in
182
-
183
-
(* The computation: navigate to data.json -> target -> key *)
184
-
let read_key c =
185
-
let (S.Step (_, c)) = S.step_any c "data.json" |> Option.get in
186
-
let (S.Step (_, c)) = S.step_any c "target" |> Option.get in
187
-
let (S.Step (sc, c)) = S.step_any c "key" |> Option.get in
188
-
(S.Step (sc, c), S.get_block c)
189
-
in
190
-
191
-
(* Produce *)
192
-
let proof, value = S.produce heap git_tree root_hash read_key in
193
-
Alcotest.(check (option string)) "produced" (Some {|"value"|}) value;
194
-
195
-
(* Verify *)
196
-
match S.verify proof git_tree read_key with
197
-
| Ok value2 ->
198
-
Alcotest.(check (option string)) "verified" (Some {|"value"|}) value2
199
-
| Error (`Proof_failure msg) -> Alcotest.failf "verify failed: %s" msg
200
-
201
-
(* ===== Adversarial: try to break the type system ===== *)
202
-
203
-
let wrong_schema () =
204
-
(* Use git_tree schema on JSON data -- should return no children *)
205
-
with_git_repo @@ fun repo heap ->
206
-
(* Store raw JSON as a blob *)
207
-
let data = {|{"key":"value"}|} in
208
-
let blob = Git.Blob.of_string data in
209
-
let h = Git.Hash.digest_string ~kind:`Blob data in
210
-
ignore (Git.Repository.write repo (Git.Value.blob blob));
211
-
212
-
(* Navigate with git_tree schema on a JSON blob *)
213
-
let c = S.at heap git_tree (irmin_hash h) in
214
-
(* git_tree_parse will fail on JSON data -- no children *)
215
-
Alcotest.(check (list string))
216
-
"wrong schema = no children" []
217
-
(S.list c |> List.map fst)
218
-
219
-
let step_nonexistent () =
220
-
with_git_repo @@ fun repo heap ->
221
-
let tree =
222
-
Git.Tree.v
223
-
[
224
-
Git.Tree.entry ~perm:`Normal ~name:"a.ml"
225
-
(Git.Hash.digest_string ~kind:`Blob "hello");
226
-
]
227
-
in
228
-
ignore
229
-
(Git.Repository.write repo (Git.Value.blob (Git.Blob.of_string "hello")));
230
-
ignore (Git.Repository.write repo (Git.Value.tree tree));
231
-
let c = S.at heap git_tree (irmin_hash (Git.Tree.digest tree)) in
232
-
233
-
(* Step to nonexistent child *)
234
-
Alcotest.(check bool)
235
-
"nonexistent = None" true
236
-
(Option.is_none (S.step_any c "does_not_exist"));
237
-
238
-
(* Step to existing child, then nonexistent subchild *)
239
-
let (S.Step (_, c)) = S.step_any c "a.ml" |> Option.get in
240
-
Alcotest.(check bool)
241
-
"no such field" true
242
-
(Option.is_none (S.step_any c "nonexistent_field"))
243
-
244
-
let proof_tamper () =
245
-
with_git_repo @@ fun repo heap ->
246
-
let data = {|{"k":"v"}|} in
247
-
let blob = Git.Blob.of_string data in
248
-
let h = Git.Hash.digest_string ~kind:`Blob data in
249
-
ignore (Git.Repository.write repo (Git.Value.blob blob));
250
-
let tree = Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"f.json" h ] in
251
-
ignore (Git.Repository.write repo (Git.Value.tree tree));
252
-
let root = irmin_hash (Git.Tree.digest tree) in
253
-
254
-
let read c =
255
-
let (S.Step (_, c)) = S.step_any c "f.json" |> Option.get in
256
-
let (S.Step (_, c)) = S.step_any c "target" |> Option.get in
257
-
let (S.Step (sc, c)) = S.step_any c "k" |> Option.get in
258
-
(S.Step (sc, c), S.get_block c)
259
-
in
260
-
261
-
(* Produce a valid proof *)
262
-
let proof, _ = S.produce heap git_tree root read in
263
-
264
-
(* Tamper: change the after hash *)
265
-
let bad_proof = { proof with after = proof.before } in
266
-
match S.verify bad_proof git_tree read with
267
-
| Ok _ -> Alcotest.fail "tampered proof should fail"
268
-
| Error (`Proof_failure _) ->
269
-
Alcotest.(check pass) "tampered proof rejected" () ()
270
-
271
-
let set_flush () =
272
-
with_git_repo @@ fun repo heap ->
273
-
let data = "hello" in
274
-
let blob = Git.Blob.of_string data in
275
-
let h = Git.Hash.digest_string ~kind:`Blob data in
276
-
ignore (Git.Repository.write repo (Git.Value.blob blob));
277
-
let tree = Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"a.txt" h ] in
278
-
ignore (Git.Repository.write repo (Git.Value.tree tree));
279
-
let root = irmin_hash (Git.Tree.digest tree) in
280
-
281
-
(* Read original *)
282
-
let c = Irmin_git.S.at heap Irmin_git.tree root in
283
-
Alcotest.(check (list string))
284
-
"original children" [ "a.txt" ]
285
-
(Irmin_git.S.list c |> List.map fst);
286
-
287
-
(* Set a new child *)
288
-
let c' =
289
-
Irmin_git.S.set c "b.txt"
290
-
(Git.Tree.to_string
291
-
(Git.Tree.v
292
-
[
293
-
Git.Tree.entry ~perm:`Normal ~name:"b.txt"
294
-
(Git.Hash.digest_string ~kind:`Blob "world");
295
-
]))
296
-
in
297
-
298
-
(* Children should include both *)
299
-
let kids = Irmin_git.S.list c' |> List.map fst |> List.sort String.compare in
300
-
Alcotest.(check (list string)) "after set" [ "a.txt"; "b.txt" ] kids;
301
-
302
-
(* Flush to heap *)
303
-
let new_root = Irmin_git.S.flush c' heap in
304
-
Alcotest.(check bool)
305
-
"new root differs" false
306
-
(Irmin.Hash.equal root new_root);
307
-
308
-
(* Read back from new root *)
309
-
let c2 = Irmin_git.S.at heap Irmin_git.tree new_root in
310
-
let kids2 = Irmin_git.S.list c2 |> List.map fst |> List.sort String.compare in
311
-
Alcotest.(check (list string)) "after flush" [ "a.txt"; "b.txt" ] kids2
312
-
313
-
let () =
314
-
Alcotest.run "schema"
315
-
[
316
-
( "cursor",
317
-
[ Alcotest.test_case "git + json navigation" `Quick git_cursor ] );
318
-
("proof", [ Alcotest.test_case "produce and verify" `Quick proof ]);
319
-
("write", [ Alcotest.test_case "set and flush" `Quick set_flush ]);
320
-
( "adversarial",
321
-
[
322
-
Alcotest.test_case "wrong schema" `Quick wrong_schema;
323
-
Alcotest.test_case "step nonexistent" `Quick step_nonexistent;
324
-
Alcotest.test_case "proof tamper" `Quick proof_tamper;
325
-
] );
326
-
]
-3
test/tar/dune
-3
test/tar/dune
+13
-22
test/tar/test.ml
test/test_tar.ml
+13
-22
test/tar/test.ml
test/test_tar.ml
···
1
-
(** Test the tar→tree codec. *)
1
+
(** Test the tar->tree codec. *)
2
2
3
3
module S = Irmin_tar.S
4
4
···
89
89
90
90
(* ===== Composition: tar + JSON ===== *)
91
91
92
-
(* JSON parse function — defined here, not in the tar backend *)
92
+
(* JSON parse function -- defined here, not in the tar backend *)
93
93
let json_parse : S.dec =
94
94
fun data ->
95
95
let nv (type a) (n : a Jsont.node) : a = fst n in
···
142
142
in
143
143
let root = Irmin_tar.of_entries heap entries in
144
144
145
-
(* Navigate: tar root → package.json → dependencies → irmin → "x" *)
145
+
(* Navigate: tar root -> package.json -> dependencies -> irmin -> "x" *)
146
146
let c = S.at heap tar_json root in
147
147
148
148
(* Root has 3 children *)
···
152
152
[ "README.md"; "package.json"; "src" ]
153
153
kids;
154
154
155
-
(* Step into package.json — dispatches to JSON codec *)
155
+
(* Step into package.json -- dispatches to JSON codec *)
156
156
let (S.Step (_, pkg)) = S.step_any c "package.json" |> Option.get in
157
157
let pkg_kids = S.list pkg |> List.map fst |> List.sort String.compare in
158
158
Alcotest.(check (list string))
···
273
273
let ancestor = Irmin_tar.of_entries heap [ ("a.txt", "original") ] in
274
274
let ours = Irmin_tar.of_entries heap [ ("a.txt", "ours-edit") ] in
275
275
let theirs = Irmin_tar.of_entries heap [ ("a.txt", "theirs-edit") ] in
276
-
(* No merge function for opaque blobs → conflict *)
276
+
(* No merge function for opaque blobs -> conflict *)
277
277
let _merged, conflicts =
278
278
S.merge heap Irmin_tar.tree
279
279
~ancestor:(S.at heap Irmin_tar.tree ancestor)
···
282
282
in
283
283
Alcotest.(check bool) "has conflicts" true (conflicts <> [])
284
284
285
-
let () =
286
-
Alcotest.run "irmin-tar"
285
+
let suite =
286
+
( "tar",
287
287
[
288
-
( "tree",
289
-
[ Alcotest.test_case "merkle tree from entries" `Quick merkle_tree ] );
290
-
( "tar+json",
291
-
[
292
-
Alcotest.test_case "navigate and prove JSON in tar" `Quick
293
-
tar_json_proof;
294
-
] );
295
-
( "merge",
296
-
[
297
-
Alcotest.test_case "structural merge (add/add)" `Quick
298
-
merge_structural;
299
-
Alcotest.test_case "CRDT counter merge" `Quick merge_counter;
300
-
Alcotest.test_case "conflict on opaque leaf" `Quick merge_conflict;
301
-
] );
302
-
]
288
+
Alcotest.test_case "merkle tree from entries" `Quick merkle_tree;
289
+
Alcotest.test_case "navigate and prove JSON in tar" `Quick tar_json_proof;
290
+
Alcotest.test_case "structural merge (add/add)" `Quick merge_structural;
291
+
Alcotest.test_case "CRDT counter merge" `Quick merge_counter;
292
+
Alcotest.test_case "conflict on opaque leaf" `Quick merge_conflict;
293
+
] )
+1
test/test.ml
+1
test/test.ml
+321
-2
test/test_schema.ml
+321
-2
test/test_schema.ml
···
1
-
(** Schema tests. Covered by the schema test runner. *)
1
+
(** Test the new schema2 API: node/=>/fix/self_describing.
2
+
3
+
Validates Git tree + JSON blob navigation and proof. *)
4
+
5
+
module S = Irmin.Schema.Make (struct
6
+
type hash = Irmin.Hash.sha1
7
+
type block = string
8
+
9
+
let hash_equal = Irmin.Hash.equal
10
+
11
+
let hash_block data =
12
+
Irmin.Hash.sha1_of_bytes
13
+
(Digestif.SHA1.to_raw_string (Digestif.SHA1.digest_string data))
14
+
end)
15
+
16
+
(* ===== Parse functions ===== *)
17
+
18
+
let git_hash h = Git.Hash.of_raw_string (Irmin.Hash.to_bytes h)
19
+
let irmin_hash h = Irmin.Hash.sha1_of_bytes (Git.Hash.to_raw_string h)
20
+
21
+
let git_tree_parse : S.dec =
22
+
fun data ->
23
+
match Git.Tree.of_string data with
24
+
| Ok tree ->
25
+
S.Named
26
+
(Git.Tree.to_list tree
27
+
|> List.map (fun (entry : Git.Tree.entry) ->
28
+
(entry.name, `Inline (Git.Tree.to_string (Git.Tree.v [ entry ])))))
29
+
| Error _ -> S.Named []
30
+
31
+
let git_entry_parse : S.dec =
32
+
fun data ->
33
+
match Git.Tree.of_string data with
34
+
| Ok tree -> (
35
+
match Git.Tree.to_list tree with
36
+
| [ entry ] ->
37
+
S.Named
38
+
[
39
+
("mode", `Inline (Git.Tree.perm_to_string entry.perm));
40
+
("target", `Link (irmin_hash entry.hash));
41
+
]
42
+
| _ -> S.Named [])
43
+
| Error _ -> S.Named []
44
+
45
+
let json_nv (type a) (n : a Jsont.node) : a = fst n
46
+
47
+
let json_parse : S.dec =
48
+
fun data ->
49
+
let enc c =
50
+
match Jsont_bytesrw.encode_string Jsont.json c with
51
+
| Ok s -> s
52
+
| Error _ -> ""
53
+
in
54
+
match Jsont_bytesrw.decode_string Jsont.json data with
55
+
| Ok (Jsont.Object obj) ->
56
+
S.Named
57
+
(List.map
58
+
(fun ((n, c) : Jsont.mem) -> (json_nv n, `Inline (enc c)))
59
+
(json_nv obj))
60
+
| Ok (Jsont.Array arr) ->
61
+
S.Indexed
62
+
(Array.of_list (List.map (fun c -> `Inline (enc c)) (json_nv arr)))
63
+
| _ -> S.Named []
64
+
65
+
(* ===== Domain combinators ===== *)
66
+
67
+
(* Serialize stubs — sufficient for read-only tests *)
68
+
let noop_serialize _ = ""
69
+
70
+
let directory rules =
71
+
S.node ~name:"application/x-git-tree" ~dec:git_tree_parse ~enc:noop_serialize
72
+
~rules ()
73
+
74
+
let entry rules =
75
+
S.node ~name:"application/x-git-entry" ~dec:git_entry_parse
76
+
~enc:noop_serialize ~rules ()
77
+
78
+
let json_node rules =
79
+
S.node ~name:"application/json" ~dec:json_parse ~enc:noop_serialize ~rules ()
80
+
81
+
(* ===== Schemas ===== *)
82
+
83
+
let ( => ) = S.( => )
84
+
let json = S.fix (fun self -> json_node [ "*" => self ])
85
+
let git_entry target = entry [ "mode" => S.opaque; "target" => target ]
86
+
87
+
let git_tree =
88
+
S.fix (fun self ->
89
+
directory [ "*.json" => git_entry json; "*" => git_entry self ])
90
+
91
+
(* ===== Test helpers ===== *)
92
+
93
+
let with_git_repo f =
94
+
Eio_main.run @@ fun env ->
95
+
Eio.Switch.run @@ fun sw ->
96
+
let fs = Eio.Stdenv.fs env in
97
+
let name = Fmt.str "/tmp/irmin-test-%d" (Random.int 1_000_000) in
98
+
let fpath = Fpath.v name in
99
+
let path = Eio.Path.(fs / name) in
100
+
let repo = Git.Repository.init ~sw ~fs fpath in
101
+
let heap = Irmin_git.heap repo in
102
+
let result = f repo heap in
103
+
(try Eio.Path.rmtree path with Eio.Io _ -> ());
104
+
result
105
+
106
+
(* ===== Tests ===== *)
107
+
108
+
let git_cursor () =
109
+
with_git_repo @@ fun repo heap ->
110
+
(* Build a tree with a JSON file and a regular file *)
111
+
let json_data = {|{"name":"irmin","version":2}|} in
112
+
let ml_data = "let () = ()" in
113
+
let json_blob = Git.Blob.of_string json_data in
114
+
let ml_blob = Git.Blob.of_string ml_data in
115
+
let json_hash = Git.Hash.digest_string ~kind:`Blob json_data in
116
+
let ml_hash = Git.Hash.digest_string ~kind:`Blob ml_data in
117
+
ignore (Git.Repository.write repo (Git.Value.blob json_blob));
118
+
ignore (Git.Repository.write repo (Git.Value.blob ml_blob));
119
+
let tree =
120
+
Git.Tree.v
121
+
[
122
+
Git.Tree.entry ~perm:`Normal ~name:"config.json" json_hash;
123
+
Git.Tree.entry ~perm:`Normal ~name:"main.ml" ml_hash;
124
+
]
125
+
in
126
+
ignore (Git.Repository.write repo (Git.Value.tree tree));
127
+
let root_hash = irmin_hash (Git.Tree.digest tree) in
128
+
129
+
(* Navigate: tree -> config.json -> target -> JSON -> name *)
130
+
let c = S.at heap git_tree root_hash in
131
+
132
+
(* Children of root *)
133
+
let kids = S.list c |> List.map fst |> List.sort String.compare in
134
+
Alcotest.(check (list string)) "root" [ "config.json"; "main.ml" ] kids;
135
+
136
+
(* Step into config.json entry *)
137
+
let (S.Step (_, c)) = S.step_any c "config.json" |> Option.get in
138
+
let entry_kids = S.list c |> List.map fst |> List.sort String.compare in
139
+
Alcotest.(check (list string)) "entry fields" [ "mode"; "target" ] entry_kids;
140
+
141
+
(* Mode *)
142
+
let (S.Step (_, c_mode)) = S.step_any c "mode" |> Option.get in
143
+
Alcotest.(check (option string)) "mode" (Some "100644") (S.get_block c_mode);
144
+
145
+
(* Follow target link -> JSON blob *)
146
+
let (S.Step (_, c_blob)) = S.step_any c "target" |> Option.get in
147
+
148
+
(* JSON navigation: object keys *)
149
+
let json_kids = S.list c_blob |> List.map fst |> List.sort String.compare in
150
+
Alcotest.(check (list string)) "json keys" [ "name"; "version" ] json_kids;
151
+
152
+
(* Step into JSON "name" *)
153
+
let (S.Step (_, c_name)) = S.step_any c_blob "name" |> Option.get in
154
+
Alcotest.(check (option string))
155
+
"json name" (Some {|"irmin"|}) (S.get_block c_name);
156
+
157
+
(* Go up: name -> blob -> entry -> tree *)
158
+
let (S.Step (_, c_up)) = S.up c_name |> Option.get in
159
+
let (S.Step (_, c_up)) = S.up c_up |> Option.get in
160
+
let (S.Step (_, c_up)) = S.up c_up |> Option.get in
161
+
let root_kids = S.list c_up |> List.map fst |> List.sort String.compare in
162
+
Alcotest.(check (list string))
163
+
"back to root"
164
+
[ "config.json"; "main.ml" ]
165
+
root_kids;
166
+
167
+
(* Path tracking *)
168
+
Alcotest.(check (list string))
169
+
"name path"
170
+
[ "config.json"; "target"; "name" ]
171
+
(S.path c_name)
172
+
173
+
let proof () =
174
+
with_git_repo @@ fun repo heap ->
175
+
let json_data = {|{"key":"value"}|} in
176
+
let blob = Git.Blob.of_string json_data in
177
+
let h = Git.Hash.digest_string ~kind:`Blob json_data in
178
+
ignore (Git.Repository.write repo (Git.Value.blob blob));
179
+
let tree = Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"data.json" h ] in
180
+
ignore (Git.Repository.write repo (Git.Value.tree tree));
181
+
let root_hash = irmin_hash (Git.Tree.digest tree) in
182
+
183
+
(* The computation: navigate to data.json -> target -> key *)
184
+
let read_key c =
185
+
let (S.Step (_, c)) = S.step_any c "data.json" |> Option.get in
186
+
let (S.Step (_, c)) = S.step_any c "target" |> Option.get in
187
+
let (S.Step (sc, c)) = S.step_any c "key" |> Option.get in
188
+
(S.Step (sc, c), S.get_block c)
189
+
in
190
+
191
+
(* Produce *)
192
+
let proof, value = S.produce heap git_tree root_hash read_key in
193
+
Alcotest.(check (option string)) "produced" (Some {|"value"|}) value;
194
+
195
+
(* Verify *)
196
+
match S.verify proof git_tree read_key with
197
+
| Ok value2 ->
198
+
Alcotest.(check (option string)) "verified" (Some {|"value"|}) value2
199
+
| Error (`Proof_failure msg) -> Alcotest.failf "verify failed: %s" msg
200
+
201
+
(* ===== Adversarial: try to break the type system ===== *)
202
+
203
+
let wrong_schema () =
204
+
(* Use git_tree schema on JSON data -- should return no children *)
205
+
with_git_repo @@ fun repo heap ->
206
+
(* Store raw JSON as a blob *)
207
+
let data = {|{"key":"value"}|} in
208
+
let blob = Git.Blob.of_string data in
209
+
let h = Git.Hash.digest_string ~kind:`Blob data in
210
+
ignore (Git.Repository.write repo (Git.Value.blob blob));
211
+
212
+
(* Navigate with git_tree schema on a JSON blob *)
213
+
let c = S.at heap git_tree (irmin_hash h) in
214
+
(* git_tree_parse will fail on JSON data -- no children *)
215
+
Alcotest.(check (list string))
216
+
"wrong schema = no children" []
217
+
(S.list c |> List.map fst)
218
+
219
+
let step_nonexistent () =
220
+
with_git_repo @@ fun repo heap ->
221
+
let tree =
222
+
Git.Tree.v
223
+
[
224
+
Git.Tree.entry ~perm:`Normal ~name:"a.ml"
225
+
(Git.Hash.digest_string ~kind:`Blob "hello");
226
+
]
227
+
in
228
+
ignore
229
+
(Git.Repository.write repo (Git.Value.blob (Git.Blob.of_string "hello")));
230
+
ignore (Git.Repository.write repo (Git.Value.tree tree));
231
+
let c = S.at heap git_tree (irmin_hash (Git.Tree.digest tree)) in
232
+
233
+
(* Step to nonexistent child *)
234
+
Alcotest.(check bool)
235
+
"nonexistent = None" true
236
+
(Option.is_none (S.step_any c "does_not_exist"));
237
+
238
+
(* Step to existing child, then nonexistent subchild *)
239
+
let (S.Step (_, c)) = S.step_any c "a.ml" |> Option.get in
240
+
Alcotest.(check bool)
241
+
"no such field" true
242
+
(Option.is_none (S.step_any c "nonexistent_field"))
243
+
244
+
let proof_tamper () =
245
+
with_git_repo @@ fun repo heap ->
246
+
let data = {|{"k":"v"}|} in
247
+
let blob = Git.Blob.of_string data in
248
+
let h = Git.Hash.digest_string ~kind:`Blob data in
249
+
ignore (Git.Repository.write repo (Git.Value.blob blob));
250
+
let tree = Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"f.json" h ] in
251
+
ignore (Git.Repository.write repo (Git.Value.tree tree));
252
+
let root = irmin_hash (Git.Tree.digest tree) in
2
253
3
-
let suite = ("schema", [])
254
+
let read c =
255
+
let (S.Step (_, c)) = S.step_any c "f.json" |> Option.get in
256
+
let (S.Step (_, c)) = S.step_any c "target" |> Option.get in
257
+
let (S.Step (sc, c)) = S.step_any c "k" |> Option.get in
258
+
(S.Step (sc, c), S.get_block c)
259
+
in
260
+
261
+
(* Produce a valid proof *)
262
+
let proof, _ = S.produce heap git_tree root read in
263
+
264
+
(* Tamper: change the after hash *)
265
+
let bad_proof = { proof with after = proof.before } in
266
+
match S.verify bad_proof git_tree read with
267
+
| Ok _ -> Alcotest.fail "tampered proof should fail"
268
+
| Error (`Proof_failure _) ->
269
+
Alcotest.(check pass) "tampered proof rejected" () ()
270
+
271
+
let set_flush () =
272
+
with_git_repo @@ fun repo heap ->
273
+
let data = "hello" in
274
+
let blob = Git.Blob.of_string data in
275
+
let h = Git.Hash.digest_string ~kind:`Blob data in
276
+
ignore (Git.Repository.write repo (Git.Value.blob blob));
277
+
let tree = Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"a.txt" h ] in
278
+
ignore (Git.Repository.write repo (Git.Value.tree tree));
279
+
let root = irmin_hash (Git.Tree.digest tree) in
280
+
281
+
(* Read original *)
282
+
let c = Irmin_git.S.at heap Irmin_git.tree root in
283
+
Alcotest.(check (list string))
284
+
"original children" [ "a.txt" ]
285
+
(Irmin_git.S.list c |> List.map fst);
286
+
287
+
(* Set a new child *)
288
+
let c' =
289
+
Irmin_git.S.set c "b.txt"
290
+
(Git.Tree.to_string
291
+
(Git.Tree.v
292
+
[
293
+
Git.Tree.entry ~perm:`Normal ~name:"b.txt"
294
+
(Git.Hash.digest_string ~kind:`Blob "world");
295
+
]))
296
+
in
297
+
298
+
(* Children should include both *)
299
+
let kids = Irmin_git.S.list c' |> List.map fst |> List.sort String.compare in
300
+
Alcotest.(check (list string)) "after set" [ "a.txt"; "b.txt" ] kids;
301
+
302
+
(* Flush to heap *)
303
+
let new_root = Irmin_git.S.flush c' heap in
304
+
Alcotest.(check bool)
305
+
"new root differs" false
306
+
(Irmin.Hash.equal root new_root);
307
+
308
+
(* Read back from new root *)
309
+
let c2 = Irmin_git.S.at heap Irmin_git.tree new_root in
310
+
let kids2 = Irmin_git.S.list c2 |> List.map fst |> List.sort String.compare in
311
+
Alcotest.(check (list string)) "after flush" [ "a.txt"; "b.txt" ] kids2
312
+
313
+
let suite =
314
+
( "schema",
315
+
[
316
+
Alcotest.test_case "git + json navigation" `Quick git_cursor;
317
+
Alcotest.test_case "produce and verify" `Quick proof;
318
+
Alcotest.test_case "set and flush" `Quick set_flush;
319
+
Alcotest.test_case "wrong schema" `Quick wrong_schema;
320
+
Alcotest.test_case "step nonexistent" `Quick step_nonexistent;
321
+
Alcotest.test_case "proof tamper" `Quick proof_tamper;
322
+
] )