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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
open Rresult
open Analyze
let src = Logs.Src.create "docteur.unix"
module Log = (val Logs.src_log src : Logs.LOG)
type t = {
fd : Lwt_unix.file_descr;
pack : (Lwt_unix.file_descr, SHA1.t) Carton.Dec.t;
buffers : Lwt_unix.file_descr buffers Lwt_pool.t;
directories : SHA1.t Art.t;
files : SHA1.t Art.t;
}
let disconnect t = Lwt_unix.close t.fd
let read fd buf ~off ~len =
let fd = Lwt_unix.unix_file_descr fd in
let res =
Unix.map_file fd
~pos:(Int64.of_int (SHA1.length + 8))
Bigarray.char Bigarray.c_layout false [| len |] in
let res = Bigarray.array1_of_genarray res in
Bigstringaf.blit_to_bytes res ~src_off:0 buf ~dst_off:off ~len ;
Scheduler.inj (Lwt.return len)
let get_block fd pos buf off len =
let fd = Lwt_unix.unix_file_descr fd in
let res =
Unix.map_file fd ~pos Bigarray.char Bigarray.c_layout false [| len |] in
let res = Bigarray.array1_of_genarray res in
Bigstringaf.blit res ~src_off:0 buf ~dst_off:off ~len ;
Ok ()
type key = Mirage_kv.Key.t
type error =
[ `Invalid_store
| `Msg of string
| `Dictionary_expected of key
| `Not_found of key
| `Value_expected of key ]
let pp_error ppf = function
| `Invalid_store -> Fmt.pf ppf "Invalid store"
| `Msg err -> Fmt.string ppf err
| `Not_found key -> Fmt.pf ppf "%a not found" Mirage_kv.Key.pp key
| `Dictionary_expected key ->
Fmt.pf ppf "%a is not a directory" Mirage_kv.Key.pp key
| `Value_expected key -> Fmt.pf ppf "%a is not a file" Mirage_kv.Key.pp key
let block_size = 512L
let connect ?(analyze = false) name =
let open Lwt.Infix in
let ( >>? ) = Lwt_result.bind in
Log.debug (fun m -> m "connect %S" name) ;
Lwt.catch (fun () ->
Lwt_unix.openfile name Unix.[ O_RDONLY ] 0o644 >>= fun fd ->
let capacity =
(Unix.LargeFile.fstat (Lwt_unix.unix_file_descr fd))
.Unix.LargeFile.st_size in
Log.debug (fun m -> m "Capacity of the given image disk: %Ld" capacity) ;
let hdr =
Unix.map_file
(Lwt_unix.unix_file_descr fd)
~pos:0L Bigarray.char Bigarray.c_layout false
[| SHA1.length + 8 |] in
let hdr = Bigarray.array1_of_genarray hdr in
Log.debug (fun m -> m "Header: %S" (Bigstringaf.to_string hdr)) ;
let commit =
SHA1.of_raw_string (Bigstringaf.substring hdr ~off:0 ~len:SHA1.length)
in
let index = Bigstringaf.get_int64_le hdr SHA1.length in
match analyze with
| true ->
Log.debug (fun m -> m "Start to analyze the given image disk.") ;
unpack fd ~read ~block_size ~get_block commit
>>? fun (buffers, pack, directories, files) ->
Lwt.return_ok { fd; pack; buffers; directories; files }
| false ->
Log.debug (fun m ->
m "Use the IDX file to reconstruct the file-system.") ;
iter fd ~block_size ~capacity ~get_block commit index
>>? fun (buffers, pack, directories, files) ->
Lwt.return_ok { fd; pack; buffers; directories; files })
@@ fun exn ->
Lwt.return_error (R.msgf "Internal error: %s" (Printexc.to_string exn))
let map fd ~pos len =
let fd = Lwt_unix.unix_file_descr fd in
let max = (Unix.LargeFile.fstat fd).Unix.LargeFile.st_size in
let len = min (Int64.of_int len) (Int64.sub max pos) in
let len = Int64.to_int len in
let res =
Unix.map_file fd ~pos Bigarray.char Bigarray.c_layout false [| len |] in
Bigarray.array1_of_genarray res
module Commit = Git.Commit.Make (Git.Hash.Make (SHA1))
module Tree = Git.Tree.Make (Git.Hash.Make (SHA1))
let load pack uid =
let open Rresult in
let weight = Carton.Dec.weight_of_uid ~map pack ~weight:Carton.Dec.null uid in
let raw = Carton.Dec.make_raw ~weight in
let v = Carton.Dec.of_uid ~map pack raw uid in
match Carton.Dec.kind v with
| `A ->
let parser = Encore.to_angstrom Commit.format in
Angstrom.parse_bigstring ~consume:All parser
(Bigstringaf.sub (Carton.Dec.raw v) ~off:0 ~len:(Carton.Dec.len v))
|> R.reword_error (fun _ -> R.msgf "Invalid commit (%a)" SHA1.pp uid)
>>| fun v -> `Commit v
| `B ->
let parser = Encore.to_angstrom Tree.format in
Angstrom.parse_bigstring ~consume:All parser
(Bigstringaf.sub (Carton.Dec.raw v) ~off:0 ~len:(Carton.Dec.len v))
|> R.reword_error (fun _ -> R.msgf "Invalid tree (%a)" SHA1.pp uid)
>>| fun v -> `Tree v
| `C ->
R.ok
(`Blob
(Bigstringaf.sub (Carton.Dec.raw v) ~off:0 ~len:(Carton.Dec.len v)))
| `D -> R.ok `Tag
let with_ressources pack uid buffers =
Lwt.catch (fun () ->
let pack = Carton.Dec.with_z buffers.z pack in
let pack = Carton.Dec.with_allocate ~allocate:buffers.allocate pack in
let pack = Carton.Dec.with_w buffers.w pack in
load pack uid |> Lwt.return)
@@ fun exn -> raise exn
let exists t key =
match
( Art.find_opt t.directories (Art.key (Mirage_kv.Key.to_string key)),
Art.find_opt t.files (Art.key (Mirage_kv.Key.to_string key)) )
with
| None, None -> Lwt.return_ok None
| Some _, None -> Lwt.return_ok (Some `Dictionary)
| None, Some _ -> Lwt.return_ok (Some `Value)
| Some _, Some _ -> assert false
let get t key =
let open Rresult in
let open Lwt.Infix in
match Art.find_opt t.files (Art.key (Mirage_kv.Key.to_string key)) with
| None -> Lwt.return_error (`Not_found key)
| Some hash -> (
Lwt_pool.use t.buffers (with_ressources t.pack hash) >>= function
| Ok (`Blob v) -> Lwt.return_ok (Bigstringaf.to_string v)
| Ok _ -> Lwt.return_error (`Value_expected key)
| Error _ as err -> Lwt.return err)
let list t key =
match Art.find_opt t.directories (Art.key (Mirage_kv.Key.to_string key)) with
| None -> Lwt.return_error (`Not_found key)
| Some hash -> (
let open Lwt.Infix in
Lwt_pool.use t.buffers (with_ressources t.pack hash) >>= function
| Ok (`Tree v) ->
let f acc { Git.Tree.name; perm; _ } =
match perm with
| `Everybody | `Normal -> (Mirage_kv.Key.v name, `Value) :: acc
| `Dir -> (Mirage_kv.Key.v name, `Dictionary) :: acc
| _ -> acc in
let lst = List.fold_left f [] (Git.Tree.to_list v) in
Lwt.return_ok lst
| Ok _ -> Lwt.return_error (`Dictionary_expected key)
| Error _ as err -> Lwt.return err)
let digest t key =
match
( Art.find_opt t.files (Art.key (Mirage_kv.Key.to_string key)),
Art.find_opt t.directories (Art.key (Mirage_kv.Key.to_string key)) )
with
| Some v, None -> Lwt.return_ok (SHA1.to_raw_string v)
| None, Some v -> Lwt.return_ok (SHA1.to_raw_string v)
| None, None -> Lwt.return_error (`Not_found key)
| Some _, Some _ -> assert false
let last_modified _t _key = Lwt.return_ok Ptime.epoch
open Lwt.Infix
let size t key =
get t key >|= function
| Ok v -> Ok (Optint.Int63.of_int (String.length v))
| Error _ as err -> err
let get_partial t key ~offset ~length =
get t key >|= function
| Ok v -> Ok (String.sub v (Optint.Int63.to_int offset) length)
| Error _ as err -> err