1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
module SHA1 = Digestif.SHA1
module Reference = Git_reference
module Commit = Git_commit
module Tree = Git_tree
module Blob = Git_blob
module Tag = Git_tag
module Object = Git_object
module User = Git_user
module Endpoint = Git_endpoint
let src = Logs.Src.create "git.store"
module Log = (val Logs.src_log src : Logs.LOG)
type t = {
values: (SHA1.t, Git_object.t) Hashtbl.t;
refs: (Git_reference.t, [ `H of SHA1.t | `R of Git_reference.t ]) Hashtbl.t;
shallows: Git_shallow.t;
root: Fpath.t;
mutable head: Git_reference.contents option;
}
let read_exn t h = Hashtbl.find t.values h
let is_shallowed t hash = Git_shallow.exists t.shallows ~equal:SHA1.equal hash
let shallowed t = Git_shallow.get t.shallows
let shallow t hash = Git_shallow.append t.shallows hash
let unshallow t hash = Git_shallow.remove t.shallows ~equal:SHA1.equal hash
let read t h = try Ok (read_exn t h) with _ -> Error (`Not_found h)
let write t value =
let hash = Git_object.digest value in
Hashtbl.replace t.values hash value;
Ok hash
let v root =
{
values= Hashtbl.create 0x7ff;
refs= Hashtbl.create 0x7ff;
shallows= Git_shallow.make [];
root;
head= None;
}
|> Lwt.return_ok
module Traverse = Traverse_bfs.Make (struct
type nonrec t = t
let root {root; _} = root
let read_exn = read_exn
let is_shallowed = is_shallowed
end)
let fold = Traverse.fold
let iter = Traverse.iter
module Ref = struct
module Graph = Git_reference.Map
let list t =
Log.debug (fun l -> l "Ref.list.");
let graph, rest =
Hashtbl.fold
(fun k -> function
| `R ptr -> fun (a, r) -> a, (k, ptr) :: r
| `H hash -> fun (a, r) -> Graph.add k hash a, r)
t.refs (Graph.empty, [])
in
let graph =
List.fold_left
(fun a (k, ptr) ->
try
let v = Graph.find ptr a in
Graph.add k v a
with Not_found -> a)
graph rest
in
let r = Graph.fold (fun k v a -> (k, v) :: a) graph [] in
Lwt.return r
let mem t r =
Log.debug (fun l -> l "Ref.mem %a." Git_reference.pp r);
try
let _ = Hashtbl.find t.refs r in
Lwt.return true
with Not_found -> Lwt.return false
exception Cycle
let resolve t r =
let rec go ~visited r =
Log.debug (fun l -> l "Ref.resolve %a." Git_reference.pp r);
try
if List.exists (Git_reference.equal r) visited then raise Cycle;
match Hashtbl.find t.refs r with
| `H s ->
Log.debug (fun l ->
l "Ref.resolve %a found: %a." Git_reference.pp r SHA1.pp s);
Lwt.return_ok s
| `R r' ->
let visited = r :: visited in
go ~visited r'
with
| Not_found ->
Log.err (fun l -> l "%a not found." Git_reference.pp r);
Lwt.return_error (`Reference_not_found r)
| Cycle ->
Log.err (fun l -> l "Got a reference cycle");
Lwt.return_error `Cycle
in
go ~visited:[] r
let read t r =
try
match Hashtbl.find t.refs r with
| `H hash -> Lwt.return_ok (Git_reference.uid hash)
| `R refname -> Lwt.return_ok (Git_reference.ref refname)
with Not_found -> Lwt.return_error (`Reference_not_found r)
let remove t r =
Log.debug (fun l -> l "Ref.remove %a." Git_reference.pp r);
Hashtbl.remove t.refs r;
Lwt.return_ok ()
let write t r value =
Log.debug (fun l -> l "Ref.write %a." Git_reference.pp r);
let head_contents =
match value with
| Git_reference.Uid hash -> `H hash
| Ref refname -> `R refname
in
Hashtbl.replace t.refs r head_contents;
Lwt.return_ok ()
end
type error =
[ `Not_found of SHA1.t
| `Reference_not_found of Git_reference.t
| `Msg of string ]
let pp_error ppf = function
| `Not_found hash -> Fmt.pf ppf "%a not found" SHA1.pp hash
| `Reference_not_found ref ->
Fmt.pf ppf "Reference %a not found" Git_reference.pp ref
| `Msg str -> Fmt.string ppf str