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 Store = Store.Make (F)
5 module Tree = Store.Tree
6 module Commit = Store.Commit
7
8 type status =
9 [ `In_sync
10 | `Local_ahead of int
11 | `Remote_ahead of int
12 | `Diverged of int * int (* local, remote *)
13 | `Trees_differ ]
14
15 (* Extract subtree at prefix from a tree *)
16 let extract_subtree tree prefix = Tree.find_tree tree prefix
17
18 (* Check if a commit touches the given prefix *)
19 let commit_touches_prefix store commit prefix =
20 let tree = Store.read_tree store (Commit.tree commit) in
21 Option.is_some (Tree.find_tree tree prefix)
22
23 (* Split: Extract subtree history into a new store *)
24 let split store ~prefix =
25 let backend = Backend.Memory.create_with_hash F.hash_to_hex F.hash_equal in
26 let new_store = Store.create ~backend () in
27
28 (* Walk commits and rewrite those touching prefix *)
29 let rec rewrite_commit old_hash rewritten =
30 if List.mem_assoc old_hash rewritten then
31 (List.assoc old_hash rewritten, rewritten)
32 else
33 match Store.read_commit store old_hash with
34 | None -> (old_hash, rewritten)
35 | Some commit -> (
36 if not (commit_touches_prefix store commit prefix) then
37 (* Skip commits not touching prefix *)
38 match Commit.parents commit with
39 | [] -> (old_hash, rewritten)
40 | p :: _ -> rewrite_commit p rewritten
41 else
42 (* Rewrite parents first *)
43 let parents, rewritten =
44 List.fold_left
45 (fun (parents, rw) p ->
46 let new_p, rw = rewrite_commit p rw in
47 (new_p :: parents, rw))
48 ([], rewritten) (Commit.parents commit)
49 in
50 let parents = List.rev parents in
51
52 (* Extract subtree *)
53 let tree = Store.read_tree store (Commit.tree commit) in
54 match extract_subtree tree prefix with
55 | None -> (old_hash, rewritten)
56 | Some subtree ->
57 let new_hash =
58 Store.commit new_store ~tree:subtree ~parents
59 ~message:(Commit.message commit)
60 ~author:(Commit.author commit)
61 in
62 (new_hash, (old_hash, new_hash) :: rewritten))
63 in
64
65 (* Start from main branch head *)
66 (match Store.head store ~branch:"main" with
67 | Some head ->
68 let new_head, _ = rewrite_commit head [] in
69 Store.set_head new_store ~branch:"main" new_head
70 | None -> ());
71
72 new_store
73
74 (* Add: Add external repo as subtree *)
75 let add store ~prefix ~source =
76 match Store.head source ~branch:"main" with
77 | None -> failwith "Source has no main branch"
78 | Some source_head -> (
79 match Store.read_commit source source_head with
80 | None -> failwith "Cannot read source commit"
81 | Some source_commit ->
82 let source_tree =
83 Store.read_tree source (Commit.tree source_commit)
84 in
85
86 (* Get current tree or empty *)
87 let current_tree =
88 match Store.head store ~branch:"main" with
89 | None -> Tree.empty ()
90 | Some h -> (
91 match Store.read_commit store h with
92 | None -> Tree.empty ()
93 | Some c -> Store.read_tree store (Commit.tree c))
94 in
95
96 (* Add source tree at prefix *)
97 let new_tree = Tree.add_tree current_tree prefix source_tree in
98
99 let parents =
100 match Store.head store ~branch:"main" with
101 | None -> []
102 | Some h -> [ h ]
103 in
104
105 let message =
106 Printf.sprintf "Add '%s' from external source"
107 (String.concat "/" prefix)
108 in
109
110 let new_head =
111 Store.commit store ~tree:new_tree ~parents ~message
112 ~author:"irmin-subtree"
113 in
114 Store.set_head store ~branch:"main" new_head;
115 new_head)
116
117 (* Pull: Update subtree from external source *)
118 let pull store ~prefix ~source =
119 match Store.head source ~branch:"main" with
120 | None -> Error (`Conflict [])
121 | Some source_head -> (
122 match Store.read_commit source source_head with
123 | None -> Error (`Conflict [])
124 | Some source_commit ->
125 let source_tree =
126 Store.read_tree source (Commit.tree source_commit)
127 in
128
129 let current_tree =
130 match Store.head store ~branch:"main" with
131 | None -> Tree.empty ()
132 | Some h -> (
133 match Store.read_commit store h with
134 | None -> Tree.empty ()
135 | Some c -> Store.read_tree store (Commit.tree c))
136 in
137
138 (* Replace subtree at prefix *)
139 let new_tree =
140 let without = Tree.remove current_tree prefix in
141 Tree.add_tree without prefix source_tree
142 in
143
144 let parents =
145 match Store.head store ~branch:"main" with
146 | None -> []
147 | Some h -> [ h ]
148 in
149
150 let message =
151 Printf.sprintf "Pull updates into '%s'" (String.concat "/" prefix)
152 in
153
154 let new_head =
155 Store.commit store ~tree:new_tree ~parents ~message
156 ~author:"irmin-subtree"
157 in
158 Store.set_head store ~branch:"main" new_head;
159 Ok new_head)
160
161 (* Push: Push subtree changes to external repo *)
162 let push store ~prefix ~target =
163 match Store.head store ~branch:"main" with
164 | None -> failwith "Store has no main branch"
165 | Some head -> (
166 match Store.read_commit store head with
167 | None -> failwith "Cannot read store commit"
168 | Some commit -> (
169 let tree = Store.read_tree store (Commit.tree commit) in
170 match extract_subtree tree prefix with
171 | None -> failwith "No subtree at prefix"
172 | Some subtree ->
173 let parents =
174 match Store.head target ~branch:"main" with
175 | None -> []
176 | Some h -> [ h ]
177 in
178
179 let message =
180 Printf.sprintf "Push from '%s'" (String.concat "/" prefix)
181 in
182
183 let new_head =
184 Store.commit target ~tree:subtree ~parents ~message
185 ~author:"irmin-subtree"
186 in
187 Store.set_head target ~branch:"main" new_head;
188 new_head))
189
190 (* Status: Compare subtree with external repo *)
191 let status store ~prefix ~external_ =
192 let local_head = Store.head store ~branch:"main" in
193 let remote_head = Store.head external_ ~branch:"main" in
194
195 match (local_head, remote_head) with
196 | None, None -> `In_sync
197 | None, Some _ -> `Remote_ahead 1
198 | Some _, None -> `Local_ahead 1
199 | Some lh, Some rh -> (
200 (* Get subtree hash from local *)
201 let local_tree_hash =
202 match Store.read_commit store lh with
203 | None -> None
204 | Some c -> (
205 let tree = Store.read_tree store (Commit.tree c) in
206 match Tree.find_tree tree prefix with
207 | None -> None
208 | Some t -> Some (Tree.hash t ~backend:(Store.backend store)))
209 in
210
211 (* Get tree hash from remote *)
212 let remote_tree_hash =
213 match Store.read_commit external_ rh with
214 | None -> None
215 | Some c -> Some (Commit.tree c)
216 in
217
218 match (local_tree_hash, remote_tree_hash) with
219 | None, None -> `In_sync
220 | None, Some _ -> `Remote_ahead 1
221 | Some _, None -> `Local_ahead 1
222 | Some lt, Some rt ->
223 if F.hash_equal lt rt then `In_sync
224 else if
225 (* Check ancestry *)
226 Store.is_ancestor external_ ~ancestor:rt ~descendant:lt
227 then
228 `Local_ahead (Store.commits_between external_ ~base:rt ~head:lt)
229 else if Store.is_ancestor external_ ~ancestor:lt ~descendant:rt then
230 `Remote_ahead (Store.commits_between external_ ~base:lt ~head:rt)
231 else `Trees_differ)
232end
233
234module Git = Make (Codec.Git)
235module Mst = Make (Codec.Mst)