Source file trace_common.ml
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
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
(** [Trace_common] contains utility to simplify the management of files using
the following layout:
{v
- Magic (Magic.t, 8 bytes)
- Version (int32, 4 bytes)
- Length of header (varint, >=1 byte)
- Header (header_t, _ bytes)
- Arbitrary long series of rows, of unspecified length, each prefixed by their length:
- Length of row (varint, >=1 byte)
- Row (row_t, _ bytes)
v}
This file is meant to be used from Tezos. OCaml version 4.09 and the 32bit
architecture should be supported.
{3 Example}
{[
module Example = struct
module V2 = struct
let version = 2
type header = unit [@@deriving repr]
type row = [ `A | `B | `C ] [@@deriving repr]
end
module V1 = struct
let version = 1
type header = unit [@@deriving repr]
type row = [ `A | `B ] [@@deriving repr]
let to_v2 x = (x :> V2.row)
end
module V0 = struct
let version = 0
type header = unit [@@deriving repr]
type row = [ `A of int | `B of int ] [@@deriving repr]
let to_v1 = function `A _ -> `A | `B _ -> `B
end
module Latest = V2
include Latest
include Trace_common.Io (struct
module Latest = Latest
let magic = Trace_common.Magic.of_string "Magique_"
let get_version_converter = function
| 2 ->
Trace_common.Version_converter
{
header_t = V2.header_t;
row_t = V2.row_t;
upgrade_header = Fun.id;
upgrade_row = Fun.id;
}
| 1 ->
Version_converter
{
header_t = V1.header_t;
row_t = V1.row_t;
upgrade_header = Fun.id;
upgrade_row = V1.to_v2;
}
| 0 ->
Version_converter
{
header_t = V0.header_t;
row_t = V0.row_t;
upgrade_header = Fun.id;
upgrade_row = (fun x -> V0.to_v1 x |> V1.to_v2);
}
| i -> Fmt.invalid_arg "Unknown Example version %d" i
end)
end
]} *)
module Seq = struct
include Seq
let rec unfold f u () =
match f u with None -> Nil | Some (x, u') -> Cons (x, unfold f u')
end
module Magic : sig
type t
val of_string : string -> t
val to_string : t -> string
val pp : Format.formatter -> t -> unit
end = struct
type t = string
let of_string s =
if String.length s <> 8 then
invalid_arg "Magic.of_string, string should have 8 chars";
s
let to_string s = s
let pp ppf s = Format.fprintf ppf "%s" (String.escaped s)
end
type ('latest_header, 'latest_row, 'header, 'row) version_converter' = {
header_t : 'header Repr.ty;
row_t : 'row Repr.ty;
upgrade_header : 'header -> 'latest_header;
upgrade_row : 'row -> 'latest_row;
}
(** Contains everything needed to read a file as if it is written with the
lastest version. *)
(** A box containing the above record *)
type ('latest_header, 'latest_row) version_converter =
| Version_converter :
('latest_header, 'latest_row, 'header, 'row) version_converter'
-> ('latest_header, 'latest_row) version_converter
module type File_format = sig
(** The latest up-to-date definition of the file format *)
module Latest : sig
val version : int
type row [@@deriving repr]
end
val magic : Magic.t
val get_version_converter :
int -> (Latest.header, Latest.row) version_converter
end
(** Very similar to what can be found in "repr/type_binary.ml", but working
straight off channels.
[Var_int.read_exn] reads the chars one by one from the provided [chan]. The
recursion stops as soon as a read char has its 8th bit equal to [0].
[Var_int.write] could be implemented using [Repr.encode_bin int], but since
[read_exn] isn't implemented using repr, [write] isn't either. *)
module Var_int = struct
let chars =
Array.init 256 (fun i -> Bytes.unsafe_to_string (Bytes.make 1 (Char.chr i)))
let write : int -> out_channel -> unit =
let int i k =
let rec aux n k =
if n >= 0 && n < 128 then k chars.(n)
else
let out = 128 lor (n land 127) in
k chars.(out);
aux (n lsr 7) k
in
aux i k
in
fun i chan -> int i (output_string chan)
let read_exn : in_channel -> int =
fun chan ->
let max_bits = Sys.word_size - 1 in
let rec aux n p =
if p >= max_bits then failwith "Failed to decode varint";
let i = input_char chan |> Char.code in
let n = n + ((i land 127) lsl p) in
if i >= 0 && i < 128 then n else aux n (p + 7)
in
aux 0 0
end
(** Derive the IO operations from a file format. Only the write operations are
performance sensitive, the read operations are not. *)
module Io (Ff : File_format) = struct
let decode_i32 = Repr.(decode_bin int32 |> unstage)
let encode_i32 = Repr.(encode_bin int32 |> unstage)
let = Repr.(encode_bin Ff.Latest.header_t |> unstage)
let encode_lrow = Repr.(encode_bin Ff.Latest.row_t |> unstage)
let magic = Ff.magic
let read_with_prefix_exn : (string -> int ref -> 'a) -> in_channel -> 'a =
fun decode chan ->
let len = Var_int.read_exn chan in
let pos_ref = ref 0 in
let v =
decode (really_input_string chan len) pos_ref
in
if len <> !pos_ref then
Fmt.failwith
"An value read in the Trace was expected to take %d bytes, but it took \
only %d."
len !pos_ref;
v
let decoded_seq_of_encoded_chan_with_prefixes :
'a Repr.ty -> in_channel -> 'a Seq.t =
fun repr chan ->
let decode = Repr.decode_bin repr |> Repr.unstage in
let produce_row () =
try
let row = read_with_prefix_exn decode chan in
Some (row, ())
with End_of_file -> None
in
Seq.unfold produce_row ()
let open_reader : string -> Ff.Latest.header * Ff.Latest.row Seq.t =
fun path ->
let chan = open_in_bin path in
let len = LargeFile.in_channel_length chan in
if len < 12L then
Fmt.invalid_arg "File '%s' should be at least 12 byte long." path;
let magic = Magic.of_string (really_input_string chan 8) in
if magic <> Ff.magic then
Fmt.invalid_arg "File '%s' has magic '%a'. Expected '%a'." path Magic.pp
magic Magic.pp Ff.magic;
let (Version_converter vc) =
let pos_ref = ref 0 in
let version = decode_i32 (really_input_string chan 4) pos_ref in
assert (!pos_ref = 4);
Ff.get_version_converter (Int32.to_int version)
in
let =
let = Repr.(decode_bin vc.header_t |> unstage) in
read_with_prefix_exn decode_header chan |> vc.upgrade_header
in
let seq =
decoded_seq_of_encoded_chan_with_prefixes vc.row_t chan
|> Seq.map vc.upgrade_row
in
(header, seq)
type writer = { path : string; channel : out_channel; buffer : Buffer.t }
let create_file path =
let channel = open_out path in
let buffer = Buffer.create 0 in
output_string channel (Magic.to_string Ff.magic);
encode_i32 (Int32.of_int Ff.Latest.version) (output_string channel);
encode_lheader header (Buffer.add_string buffer);
Var_int.write (Buffer.length buffer) channel;
output_string channel (Buffer.contents buffer);
Buffer.clear buffer;
{ path; channel; buffer }
let append_row { channel; buffer; _ } row =
encode_lrow row (Buffer.add_string buffer);
Var_int.write (Buffer.length buffer) channel;
output_string channel (Buffer.contents buffer);
Buffer.clear buffer
let flush { channel; _ } = flush channel
let close { channel; _ } = close_out channel
let remove { channel; path; _ } =
close_out channel;
Sys.remove path
end