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
29let git_value_of_data data =
30 match detect_object_type data with
31 | `Blob -> Git.Value.blob (Git.Blob.of_string data)
32 | `Tree -> Git.Value.tree (Git.Tree.of_string_exn data)
33 | `Commit -> Git.Value.commit (Git.Commit.of_string_exn data)
34
35let test_and_set_ref repo name ~test ~set =
36 let current = Git.Repository.read_ref repo name in
37 let matches =
38 match (test, current) with
39 | None, None -> true
40 | Some t, Some c -> Git.Hash.equal (git_hash_of_sha1 t) c
41 | _ -> false
42 in
43 if matches then (
44 (match set with
45 | None -> Git.Repository.delete_ref repo name
46 | Some h -> Git.Repository.write_ref repo name (git_hash_of_sha1 h));
47 true)
48 else false
49
50(* Create Git backend from a Git.Repository.t *)
51let git_backend (repo : Git.Repository.t) : Hash.sha1 Backend.t =
52 {
53 read =
54 (fun hash ->
55 let git_hash = git_hash_of_sha1 hash in
56 match Git.Repository.read repo git_hash with
57 | Ok value -> Some (Git.Value.to_string_without_header value)
58 | Error _ -> None);
59 write =
60 (fun _expected_hash data ->
61 ignore (Git.Repository.write repo (git_value_of_data data)));
62 exists =
63 (fun hash ->
64 let git_hash = git_hash_of_sha1 hash in
65 Git.Repository.exists repo git_hash);
66 get_ref =
67 (fun name ->
68 Option.map sha1_of_git_hash (Git.Repository.read_ref repo name));
69 set_ref =
70 (fun name hash ->
71 Git.Repository.write_ref repo name (git_hash_of_sha1 hash));
72 test_and_set_ref = test_and_set_ref repo;
73 list_refs = (fun () -> Git.Repository.list_refs repo);
74 write_batch =
75 (fun objects ->
76 List.iter
77 (fun (_expected_hash, data) ->
78 ignore (Git.Repository.write repo (git_value_of_data data)))
79 objects);
80 flush = (fun () -> ());
81 close = (fun () -> ());
82 }
83
84(* Public API *)
85
86let import_git ~sw:_ ~fs ~git_dir =
87 let repo = Git.Repository.open_bare ~fs git_dir in
88 let backend = git_backend repo in
89 Store.Git.create ~backend ()
90
91let open_git ~sw:_ ~fs ~path =
92 let repo = Git.Repository.open_repo ~fs path in
93 let backend = git_backend repo in
94 Store.Git.create ~backend ()
95
96let init_git ~sw:_ ~fs ~path =
97 let repo = Git.Repository.init ~fs path in
98 let backend = git_backend repo in
99 Store.Git.create ~backend ()
100
101let read_object ~sw:_ ~fs ~git_dir hash :
102 (string * string, [> `Msg of string ]) result =
103 let repo = Git.Repository.open_bare ~fs git_dir in
104 let git_hash = git_hash_of_sha1 hash in
105 match Git.Repository.read repo git_hash with
106 | Ok value ->
107 let kind =
108 match Git.Value.kind value with
109 | `Blob -> "blob"
110 | `Tree -> "tree"
111 | `Commit -> "commit"
112 | `Tag -> "tag"
113 in
114 Ok (kind, Git.Value.to_string_without_header value)
115 | Error (`Msg m) -> Error (`Msg m)
116
117let write_object ~sw:_ ~fs ~git_dir ~typ data =
118 let repo = Git.Repository.open_bare ~fs git_dir in
119 let value =
120 match typ with
121 | "blob" -> Git.Value.blob (Git.Blob.of_string data)
122 | "tree" -> Git.Value.tree (Git.Tree.of_string_exn data)
123 | "commit" -> Git.Value.commit (Git.Commit.of_string_exn data)
124 | "tag" -> Git.Value.tag (Git.Tag.of_string_exn data)
125 | _ -> invalid_arg ("unknown object type: " ^ typ)
126 in
127 let git_hash = Git.Repository.write repo value in
128 sha1_of_git_hash git_hash
129
130let read_ref ~sw:_ ~fs ~git_dir name =
131 let repo = Git.Repository.open_bare ~fs git_dir in
132 Option.map sha1_of_git_hash (Git.Repository.read_ref repo name)
133
134let write_ref ~sw:_ ~fs ~git_dir name hash =
135 let repo = Git.Repository.open_bare ~fs git_dir in
136 Git.Repository.write_ref repo name (git_hash_of_sha1 hash)
137
138let list_refs ~sw:_ ~fs ~git_dir =
139 let repo = Git.Repository.open_bare ~fs git_dir in
140 Git.Repository.list_refs repo