vblt.org
forked from
gazagnaire.org/irmin
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
1module Make (F : Codec.S) = struct
2 type hash = F.hash
3
4 module Tree = Tree.Make (F)
5 module Commit = Commit.Make (F)
6
7 type t = { backend : hash Backend.t }
8
9 let create ~backend = { backend }
10 let backend t = t.backend
11
12 let tree t ?at () =
13 match at with
14 | None -> Tree.empty ()
15 | Some h -> Tree.of_hash ~backend:t.backend h
16
17 let read_commit t h =
18 match t.backend.read h with
19 | None -> None
20 | Some data -> (
21 match Commit.of_bytes data with Ok c -> Some c | Error _ -> None)
22
23 let read_tree t h = Tree.of_hash ~backend:t.backend h
24
25 let checkout t ~branch =
26 match t.backend.get_ref ("refs/heads/" ^ branch) with
27 | None -> None
28 | Some commit_hash -> (
29 match read_commit t commit_hash with
30 | None -> None
31 | Some commit -> Some (read_tree t (Commit.tree commit)))
32
33 let commit t ~tree ~parents ~message ~author =
34 (* This is where delayed writes happen *)
35 let tree_hash = Tree.hash tree ~backend:t.backend in
36 let c = Commit.v ~tree:tree_hash ~parents ~author ~message () in
37 let data = Commit.to_bytes c in
38 let h = Commit.hash c in
39 t.backend.write h data;
40 h
41
42 let head t ~branch = t.backend.get_ref ("refs/heads/" ^ branch)
43 let set_head t ~branch h = t.backend.set_ref ("refs/heads/" ^ branch) h
44
45 let branches t =
46 t.backend.list_refs ()
47 |> List.filter_map (fun r ->
48 if String.length r > 11 && String.sub r 0 11 = "refs/heads/" then
49 Some (String.sub r 11 (String.length r - 11))
50 else None)
51
52 let update_branch t ~branch ~old ~new_ =
53 t.backend.test_and_set_ref ("refs/heads/" ^ branch) ~test:old
54 ~set:(Some new_)
55
56 (* Simple ancestry check - walks parent chain *)
57 let is_ancestor t ~ancestor ~descendant =
58 let rec walk visited h =
59 if F.hash_equal h ancestor then true
60 else if List.exists (F.hash_equal h) visited then false
61 else
62 match read_commit t h with
63 | None -> false
64 | Some c ->
65 let visited = h :: visited in
66 List.exists (walk visited) (Commit.parents c)
67 in
68 F.hash_equal ancestor descendant || walk [] descendant
69
70 (* Find merge base using simple BFS *)
71 let merge_base t h1 h2 =
72 let rec ancestors_of h visited =
73 if List.exists (F.hash_equal h) visited then visited
74 else
75 match read_commit t h with
76 | None -> h :: visited
77 | Some c ->
78 let visited = h :: visited in
79 List.fold_left
80 (fun acc p -> ancestors_of p acc)
81 visited (Commit.parents c)
82 in
83 let ancestors1 = ancestors_of h1 [] in
84 let rec find_common h =
85 if List.exists (F.hash_equal h) ancestors1 then Some h
86 else
87 match read_commit t h with
88 | None -> None
89 | Some c -> (
90 match Commit.parents c with [] -> None | p :: _ -> find_common p)
91 in
92 find_common h2
93
94 let commits_between t ~base ~head =
95 let rec count h n =
96 if F.hash_equal h base then n
97 else
98 match read_commit t h with
99 | None -> n
100 | Some c -> (
101 match Commit.parents c with [] -> n | p :: _ -> count p (n + 1))
102 in
103 count head 0
104
105 type diff_entry =
106 [ `Add of Tree.path * hash
107 | `Remove of Tree.path
108 | `Change of Tree.path * hash * hash ]
109
110 let diff t ~old ~new_ =
111 let old_tree = read_tree t old in
112 let new_tree = read_tree t new_ in
113
114 let rec diff_trees prefix old_tree new_tree =
115 let old_entries = Tree.list old_tree [] in
116 let new_entries = Tree.list new_tree [] in
117
118 let old_names = List.map fst old_entries in
119 let new_names = List.map fst new_entries in
120
121 (* Entries only in old -> Remove *)
122 let removed =
123 old_names
124 |> List.filter (fun name -> not (List.mem name new_names))
125 |> List.to_seq
126 |> Seq.map (fun name -> `Remove (prefix @ [ name ]))
127 in
128
129 (* Entries only in new -> Add *)
130 let added =
131 new_names
132 |> List.filter (fun name -> not (List.mem name old_names))
133 |> List.to_seq
134 |> Seq.filter_map (fun name ->
135 match Tree.find new_tree [ name ] with
136 | Some content ->
137 let hash = F.hash_contents content in
138 Some (`Add (prefix @ [ name ], hash))
139 | None ->
140 (* It's a subtree - handled by added_subtrees recursion below *)
141 None)
142 in
143
144 (* Entries in both -> check for changes *)
145 let common =
146 List.filter (fun name -> List.mem name new_names) old_names
147 in
148 let changes =
149 common |> List.to_seq
150 |> Seq.flat_map (fun name ->
151 let path = prefix @ [ name ] in
152 let old_kind = List.assoc name old_entries in
153 let new_kind = List.assoc name new_entries in
154 match (old_kind, new_kind) with
155 | `Contents, `Contents -> (
156 match
157 (Tree.find old_tree [ name ], Tree.find new_tree [ name ])
158 with
159 | Some old_c, Some new_c ->
160 let old_h = F.hash_contents old_c in
161 let new_h = F.hash_contents new_c in
162 if F.hash_equal old_h new_h then Seq.empty
163 else Seq.return (`Change (path, old_h, new_h))
164 | _ -> Seq.empty)
165 | `Node, `Node -> (
166 match
167 ( Tree.find_tree old_tree [ name ],
168 Tree.find_tree new_tree [ name ] )
169 with
170 | Some old_sub, Some new_sub -> diff_trees path old_sub new_sub
171 | _ -> Seq.empty)
172 | `Contents, `Node ->
173 (* Changed from contents to tree - remove old contents *)
174 Seq.return (`Remove path)
175 |> Seq.append
176 (match Tree.find_tree new_tree [ name ] with
177 | Some sub -> diff_trees path (Tree.empty ()) sub
178 | None -> Seq.empty)
179 | `Node, `Contents ->
180 (* Changed from tree to contents - add new contents *)
181 (match Tree.find new_tree [ name ] with
182 | Some c ->
183 let new_h = F.hash_contents c in
184 Seq.return (`Add (path, new_h))
185 | None -> Seq.empty)
186 |> Seq.append
187 (match Tree.find_tree old_tree [ name ] with
188 | Some sub -> diff_trees path sub (Tree.empty ())
189 | None -> Seq.empty))
190 in
191
192 (* Also recurse into added subtrees *)
193 let added_subtrees =
194 new_names
195 |> List.filter (fun name -> not (List.mem name old_names))
196 |> List.to_seq
197 |> Seq.flat_map (fun name ->
198 match Tree.find_tree new_tree [ name ] with
199 | Some sub -> diff_trees (prefix @ [ name ]) (Tree.empty ()) sub
200 | None -> Seq.empty)
201 in
202
203 (* Also recurse into removed subtrees *)
204 let removed_subtrees =
205 old_names
206 |> List.filter (fun name -> not (List.mem name new_names))
207 |> List.to_seq
208 |> Seq.flat_map (fun name ->
209 match Tree.find_tree old_tree [ name ] with
210 | Some sub -> diff_trees (prefix @ [ name ]) sub (Tree.empty ())
211 | None -> Seq.empty)
212 in
213
214 Seq.append removed
215 (Seq.append added
216 (Seq.append changes (Seq.append added_subtrees removed_subtrees)))
217 in
218 diff_trees [] old_tree new_tree
219end
220
221module Git = Make (Codec.Git)
222module Mst = Make (Codec.Mst)