vblt.org
forked from
gazagnaire.org/irmin
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
1(** Git interoperability using ocaml-git.
2
3 Provides bidirectional support for reading and writing Git repositories. *)
4
5(* Convert between irmin Hash.sha1 and Git.Hash.t *)
6let git_hash_of_sha1 (h : Hash.sha1) : Git.Hash.t =
7 Git.Hash.of_raw_string (Hash.to_bytes h)
8
9let sha1_of_git_hash (h : Git.Hash.t) : Hash.sha1 =
10 Hash.sha1_of_bytes (Git.Hash.to_raw_string h)
11
12(* Detect object type from content.
13 Commits start with "tree ", trees have binary format with mode prefixes.
14 Inode marker \x02 and inlined-tree marker \x01 are internal formats
15 that cannot be stored in a git repository. *)
16let detect_object_type data =
17 if String.length data >= 5 && String.sub data 0 5 = "tree " then `Commit
18 else if String.length data >= 2 && data.[0] >= '1' && data.[0] <= '7' then
19 (* Tree entries start with mode like "100644 " or "40000 " *)
20 `Tree
21 else if
22 String.length data >= 1 && (data.[0] = '\x01' || data.[0] = '\x02')
23 then
24 failwith
25 "git_interop: cannot write internal tree format (inlined or inode) to \
26 git; use inline_threshold:0 for git backends"
27 else `Blob
28
29(* Create Git backend from a Git.Repository.t *)
30let git_backend (repo : Git.Repository.t) : Hash.sha1 Backend.t =
31 {
32 read =
33 (fun hash ->
34 let git_hash = git_hash_of_sha1 hash in
35 match Git.Repository.read repo git_hash with
36 | Ok value -> Some (Git.Value.to_string_without_header value)
37 | Error _ -> None);
38 write =
39 (fun _expected_hash data ->
40 (* Detect object type and write with correct Git wrapper *)
41 let value =
42 match detect_object_type data with
43 | `Blob -> Git.Value.blob (Git.Blob.of_string data)
44 | `Tree -> Git.Value.tree (Git.Tree.of_string_exn data)
45 | `Commit -> Git.Value.commit (Git.Commit.of_string_exn data)
46 in
47 let _git_hash = Git.Repository.write repo value in
48 ());
49 exists =
50 (fun hash ->
51 let git_hash = git_hash_of_sha1 hash in
52 Git.Repository.exists repo git_hash);
53 get_ref =
54 (fun name ->
55 Option.map sha1_of_git_hash (Git.Repository.read_ref repo name));
56 set_ref =
57 (fun name hash ->
58 Git.Repository.write_ref repo name (git_hash_of_sha1 hash));
59 test_and_set_ref =
60 (fun name ~test ~set ->
61 let current = Git.Repository.read_ref repo name in
62 let matches =
63 match (test, current) with
64 | None, None -> true
65 | Some t, Some c -> Git.Hash.equal (git_hash_of_sha1 t) c
66 | _ -> false
67 in
68 if matches then (
69 (match set with
70 | None -> Git.Repository.delete_ref repo name
71 | Some h -> Git.Repository.write_ref repo name (git_hash_of_sha1 h));
72 true)
73 else false);
74 list_refs = (fun () -> Git.Repository.list_refs repo);
75 write_batch =
76 (fun objects ->
77 List.iter
78 (fun (_expected_hash, data) ->
79 let value =
80 match detect_object_type data with
81 | `Blob -> Git.Value.blob (Git.Blob.of_string data)
82 | `Tree -> Git.Value.tree (Git.Tree.of_string_exn data)
83 | `Commit -> Git.Value.commit (Git.Commit.of_string_exn data)
84 in
85 let _git_hash = Git.Repository.write repo value in
86 ())
87 objects);
88 flush = (fun () -> ());
89 close = (fun () -> ());
90 }
91
92(* Public API *)
93
94let import_git ~sw:_ ~fs ~git_dir =
95 let repo = Git.Repository.open_bare ~fs git_dir in
96 let backend = git_backend repo in
97 Store.Git.create ~backend ()
98
99let open_git ~sw:_ ~fs ~path =
100 let repo = Git.Repository.open_repo ~fs path in
101 let backend = git_backend repo in
102 Store.Git.create ~backend ()
103
104let init_git ~sw:_ ~fs ~path =
105 let repo = Git.Repository.init ~fs path in
106 let backend = git_backend repo in
107 Store.Git.create ~backend ()
108
109let read_object ~sw:_ ~fs ~git_dir hash :
110 (string * string, [> `Msg of string ]) result =
111 let repo = Git.Repository.open_bare ~fs git_dir in
112 let git_hash = git_hash_of_sha1 hash in
113 match Git.Repository.read repo git_hash with
114 | Ok value ->
115 let kind =
116 match Git.Value.kind value with
117 | `Blob -> "blob"
118 | `Tree -> "tree"
119 | `Commit -> "commit"
120 | `Tag -> "tag"
121 in
122 Ok (kind, Git.Value.to_string_without_header value)
123 | Error (`Msg m) -> Error (`Msg m)
124
125let write_object ~sw:_ ~fs ~git_dir ~typ data =
126 let repo = Git.Repository.open_bare ~fs git_dir in
127 let value =
128 match typ with
129 | "blob" -> Git.Value.blob (Git.Blob.of_string data)
130 | "tree" -> Git.Value.tree (Git.Tree.of_string_exn data)
131 | "commit" -> Git.Value.commit (Git.Commit.of_string_exn data)
132 | "tag" -> Git.Value.tag (Git.Tag.of_string_exn data)
133 | _ -> invalid_arg ("unknown object type: " ^ typ)
134 in
135 let git_hash = Git.Repository.write repo value in
136 sha1_of_git_hash git_hash
137
138let read_ref ~sw:_ ~fs ~git_dir name =
139 let repo = Git.Repository.open_bare ~fs git_dir in
140 Option.map sha1_of_git_hash (Git.Repository.read_ref repo name)
141
142let write_ref ~sw:_ ~fs ~git_dir name hash =
143 let repo = Git.Repository.open_bare ~fs git_dir in
144 Git.Repository.write_ref repo name (git_hash_of_sha1 hash)
145
146let list_refs ~sw:_ ~fs ~git_dir =
147 let repo = Git.Repository.open_bare ~fs git_dir in
148 Git.Repository.list_refs repo