balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Data_encoding: rename Binary into Binary_writer

Browse Source
This commit is contained in:
Grégoire Henry 2018-05-12 17:48:50 +02:00 committed by Benjamin Canou
parent 1da0d0c8d7
commit 72fc71be67
15 changed files with 375 additions and 639 deletions

442
src/lib_data_encoding/binary.ml
View File

@ -1,442 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let apply_and_get_first_some ?(error=Encoding.No_case_matched) fs v =
let rec loop = function
| [] -> raise error
| f :: fs ->
match f v with
| Some l -> l
| None -> loop fs in
loop fs
type 'l writer = {
write: 'a. 'a Encoding.t -> 'a -> MBytes.t -> int -> int ;
}
(** Writer *)
module Writer = struct
let int8 v buf ofs =
if (v < - (1 lsl 7) || v >= 1 lsl 7) then
invalid_arg "Data_encoding.Binary.Writer.int8" ;
MBytes.set_int8 buf ofs v;
ofs + Binary_size.int8
let uint8 v buf ofs =
if (v < 0 || v >= 1 lsl 8) then
invalid_arg "Data_encoding.Binary.Writer.uint8" ;
MBytes.set_int8 buf ofs v;
ofs + Binary_size.uint8
let char v buf ofs =
MBytes.set_char buf ofs v;
ofs + Binary_size.char
let bool v buf ofs =
uint8 (if v then 255 else 0) buf ofs
let int16 v buf ofs =
if (v < - (1 lsl 15) || v >= 1 lsl 15) then
invalid_arg "Data_encoding.Binary.Writer.int16" ;
MBytes.set_int16 buf ofs v;
ofs + Binary_size.int16
let uint16 v buf ofs =
if (v < 0 || v >= 1 lsl 16) then
invalid_arg "Data_encoding.Binary.Writer.uint16" ;
MBytes.set_int16 buf ofs v;
ofs + Binary_size.uint16
let uint30 v buf ofs =
if v < 0 || (Sys.int_size > 31 && v >= 1 lsl 30) then
invalid_arg "Data_encoding.Binary.Writer.uint30" ;
MBytes.set_int32 buf ofs (Int32.of_int v);
ofs + Binary_size.uint30
let int31 v buf ofs =
if Sys.int_size > 31 && (v < ~- (1 lsl 30) || v >= 1 lsl 30) then
invalid_arg "Data_encoding.Binary.Writer.int31" ;
MBytes.set_int32 buf ofs (Int32.of_int v);
ofs + Binary_size.int31
let int32 v buf ofs =
MBytes.set_int32 buf ofs v;
ofs + Binary_size.int32
let int64 v buf ofs =
MBytes.set_int64 buf ofs v;
ofs + Binary_size.int64
let z v res ofs =
let sign = Z.sign v < 0 in
let bits = Z.numbits v in
if Z.equal v Z.zero then begin
MBytes.set_int8 res ofs 0x00 ;
ofs + 1
end else
let v = Z.abs v in
let get_chunk pos len = Z.to_int (Z.extract v pos len) in
let length = (bits + 1 + 6) / 7 in
MBytes.set_int8 res ofs
((if sign then 0x40 else 0x00)
lor (if bits > 6 then 0x80 else 0x00)
lor (get_chunk 0 6)) ;
for i = 1 to length - 1 do
let pos = 6 + (i - 1) * 7 in
let chunk_len = if i = length - 1 then bits - pos else 7 in
MBytes.set_int8 res (ofs + i)
((if i = bits / 7 then 0x00 else 0x80)
lor (get_chunk pos chunk_len))
done ;
ofs + length
(** write a float64 (double) **)
let float v buf ofs =
(*Here, float means float64, which is written using MBytes.set_double !!*)
MBytes.set_double buf ofs v;
ofs + Binary_size.float
let fixed_kind_bytes length s buf ofs =
if MBytes.length s <> length then invalid_arg "fixed_kind_bytes";
MBytes.blit s 0 buf ofs length;
ofs + length
let variable_length_bytes s buf ofs =
let length = MBytes.length s in
MBytes.blit s 0 buf ofs length ;
ofs + length
let fixed_kind_string length s buf ofs =
if String.length s <> length then invalid_arg "fixed_kind_string";
MBytes.blit_of_string s 0 buf ofs length;
ofs + length
let variable_length_string s buf ofs =
let length = String.length s in
MBytes.blit_of_string s 0 buf ofs length ;
ofs + length
let objs w1 w2 (v1,v2) buf ofs =
w1 v1 buf ofs |> w2 v2 buf
let array w a buf ofs =
Array.fold_left (fun ofs v -> w v buf ofs) ofs a
let list w l buf ofs =
List.fold_left (fun ofs v -> w v buf ofs) ofs l
let conv proj w v buf ofs =
w (proj v) buf ofs
let write_tag = function
| `Uint8 -> uint8
| `Uint16 -> uint16
let union w sz cases =
let open Encoding in
let writes_case = function
| Case { tag = Json_only } -> None
| Case { encoding = e ; proj ; tag = Tag tag } ->
let write = w.write e in
let write v buf ofs =
write_tag sz tag buf ofs |> write v buf in
Some (fun v ->
match proj v with
| None -> None
| Some v -> Some (write v)) in
apply_and_get_first_some (TzList.filter_map writes_case cases)
end
module BufferedWriter = struct
let int8 v buf =
if (v < - (1 lsl 7) || v >= 1 lsl 7) then
invalid_arg "Data_encoding.Binary.Writer.int8" ;
MBytes_buffer.write_int8 buf v
let uint8 v buf =
if (v < 0 || v >= 1 lsl 8) then
invalid_arg "Data_encoding.Binary.Writer.uint8" ;
MBytes_buffer.write_int8 buf v
let char v buf =
MBytes_buffer.write_char buf v
let bool v buf =
uint8 (if v then 255 else 0) buf
let int16 v buf =
if (v < - (1 lsl 15) || v >= 1 lsl 15) then
invalid_arg "Data_encoding.Binary.Writer.int16" ;
MBytes_buffer.write_int16 buf v
let uint16 v buf =
if (v < 0 || v >= 1 lsl 16) then
invalid_arg "Data_encoding.Binary.Writer.uint16" ;
MBytes_buffer.write_int16 buf v
let uint30 v buf =
if v < 0 || (Sys.int_size > 31 && v >= 1 lsl 30) then
invalid_arg "Data_encoding.Binary.Writer.uint30" ;
MBytes_buffer.write_int32 buf (Int32.of_int v)
let int31 v buf =
if Sys.int_size > 31 && (v < ~- (1 lsl 30) || v >= 1 lsl 30) then
invalid_arg "Data_encoding.Binary.Writer.int31" ;
MBytes_buffer.write_int32 buf (Int32.of_int v)
let int32 v buf =
MBytes_buffer.write_int32 buf v
let int64 v buf =
MBytes_buffer.write_int64 buf v
let z v buf =
let bits = Z.numbits v in
let length = (bits + 1 + 6) / 7 in
let res = MBytes.create length in
ignore (Writer.z v res 0) ;
MBytes_buffer.write_mbytes buf res 0 length
(** write a float64 (double) **)
let float v buf =
MBytes_buffer.write_double buf v
let fixed_kind_bytes length s buf =
if MBytes.length s <> length then invalid_arg "fixed_kind_bytes";
MBytes_buffer.write_mbytes buf s 0 length
let variable_length_bytes s buf =
let length = MBytes.length s in
MBytes_buffer.write_mbytes buf s 0 length
let fixed_kind_string length s buf =
if String.length s <> length then invalid_arg "fixed_kind_string";
MBytes_buffer.write_string_data buf s
let variable_length_string s buf =
MBytes_buffer.write_string_data buf s
let write_tag = function
| `Uint8 -> uint8
| `Uint16 -> uint16
end
let rec assoc_snd target = function
| [] -> raise Encoding.No_case_matched
| (value, hd) :: tl ->
if hd = target
then value
else assoc_snd target tl
let get_string_enum_case tbl v =
try
snd (Hashtbl.find tbl v)
with _ ->
raise Encoding.No_case_matched
let rec write_rec
: type a. a Encoding.t -> a -> MBytes.t -> int -> int = fun e ->
let open Encoding in
let open Writer in
match e.encoding with
| Null -> (fun () _buf ofs -> ofs)
| Empty -> (fun () _buf ofs -> ofs)
| Constant _ -> (fun () _buf ofs -> ofs)
| Ignore -> (fun () _buf ofs -> ofs)
| Bool -> bool
| Int8 -> int8
| Uint8 -> uint8
| Int16 -> int16
| Uint16 -> uint16
| Int31 -> int31
| Int32 -> int32
| Int64 -> int64
| Z -> z
| RangedInt { minimum ; maximum } ->
fun v ->
begin
if v < minimum || v > maximum
then invalid_arg (Printf.sprintf "Integer %d not in range [%d, %d]." v minimum maximum) ;
let v = if minimum >= 0 then v - minimum else v in
match Binary_size.range_to_size ~minimum ~maximum with
| `Uint8 -> uint8 v
| `Uint16 -> uint16 v
| `Uint30 -> uint30 v
| `Int8 -> int8 v
| `Int16 -> int16 v
| `Int31 -> int31 v
end
| Float -> float
| RangedFloat { minimum ; maximum } ->
fun v ->
if v < minimum || v > maximum
then invalid_arg (Printf.sprintf "Float %f not in range [%f, %f]." v minimum maximum) ;
float v
| Bytes (`Fixed n) -> fixed_kind_bytes n
| String (`Fixed n) -> fixed_kind_string n
| Bytes `Variable -> variable_length_bytes
| String `Variable -> variable_length_string
| Array t -> array (write_rec t)
| List t -> list (write_rec t)
| String_enum (tbl, arr) ->
(fun v ->
let value = get_string_enum_case tbl v in
match Binary_size.enum_size arr with
| `Uint30 -> uint30 value
| `Uint16 -> uint16 value
| `Uint8 -> uint8 value)
| Obj (Req (_, e)) -> write_rec e
| Obj (Opt (`Dynamic, _, e)) ->
let write = write_rec e in
(function None -> int8 0
| Some x -> fun buf ofs -> int8 1 buf ofs |> write x buf)
| Obj (Opt (`Variable, _, e)) ->
let write = write_rec e in
(function None -> fun _buf ofs -> ofs
| Some x -> write x)
| Obj (Dft (_, e, _)) -> write_rec e
| Objs (_, e1, e2) ->
objs (write_rec e1) (write_rec e2)
| Tup e -> write_rec e
| Tups (_, e1, e2) ->
objs (write_rec e1) (write_rec e2)
| Conv { encoding = e; proj } -> conv proj (write_rec e)
| Describe { encoding = e } -> write_rec e
| Def { encoding = e } -> write_rec e
| Splitted { encoding = e } -> write_rec e
| Union (_, sz, cases) -> union { write = write_rec } sz cases
| Mu (_, _, self) -> fun v buf ofs -> write_rec (self e) v buf ofs
| Dynamic_size e ->
let length = Binary_length.length e
and write = write_rec e in
fun v buf ofs ->
int32 (Int32.of_int @@ length v) buf ofs |> write v buf
| Delayed f -> write_rec (f ())
let rec write_rec_buffer
: type a. a Encoding.t -> a -> MBytes_buffer.t -> unit =
fun encoding value buffer ->
let open Encoding in
let open BufferedWriter in
match encoding.encoding with
| Null -> ()
| Empty -> ()
| Constant _ -> ()
| Ignore -> ()
| Bool -> bool value buffer
| Int8 -> int8 value buffer
| Uint8 -> uint8 value buffer
| Int16 -> int16 value buffer
| Uint16 -> uint16 value buffer
| Int31 -> int31 value buffer
| Int32 -> int32 value buffer
| Int64 -> int64 value buffer
| Z -> z value buffer
| Float -> float value buffer
| Bytes (`Fixed n) -> fixed_kind_bytes n value buffer
| String (`Fixed n) -> fixed_kind_string n value buffer
| Bytes `Variable -> variable_length_bytes value buffer
| String `Variable -> variable_length_string value buffer
| Array t -> Array.iter (fun x -> write_rec_buffer t x buffer) value
| List t -> List.iter (fun x -> write_rec_buffer t x buffer) value
| RangedInt { minimum ; maximum } ->
if value < minimum || value > maximum
then invalid_arg (Printf.sprintf "Integer %d not in range [%d, %d]."
value minimum maximum) ;
let value = if minimum >= 0 then value - minimum else value in
begin
match Binary_size.range_to_size ~minimum ~maximum with
| `Uint30 -> uint30 value buffer
| `Uint16 -> uint16 value buffer
| `Uint8 -> uint8 value buffer
| `Int8 -> int8 value buffer
| `Int16 -> int16 value buffer
| `Int31 -> int31 value buffer
end
| RangedFloat { minimum ; maximum } ->
if value < minimum || value > maximum
then invalid_arg (Printf.sprintf "Float %f not in range [%f, %f]."
value minimum maximum) ;
float value buffer
| String_enum (tbl, arr) ->
(match Binary_size.enum_size arr with
| `Uint30 -> BufferedWriter.uint30
| `Uint16 -> BufferedWriter.uint16
| `Uint8 -> BufferedWriter.uint8)
(get_string_enum_case tbl value)
buffer
| Obj (Req (_, e)) -> write_rec_buffer e value buffer
| Obj (Opt (`Dynamic, _, e)) ->
(match value with
| None -> int8 0 buffer
| Some x ->
begin
int8 1 buffer ;
write_rec_buffer e x buffer
end)
| Obj (Opt (`Variable, _, e)) ->
(match value with
| None -> ()
| Some x -> write_rec_buffer e x buffer)
| Obj (Dft (_, e, _)) -> write_rec_buffer e value buffer
| Objs (_, e1, e2) ->
let v1, v2 = value in
write_rec_buffer e1 v1 buffer ;
write_rec_buffer e2 v2 buffer
| Tup e -> write_rec_buffer e value buffer
| Tups (_, e1, e2) ->
let v1, v2 = value in
write_rec_buffer e1 v1 buffer ;
write_rec_buffer e2 v2 buffer
| Conv { encoding = e; proj } ->
write_rec_buffer e (proj value) buffer
| Describe { encoding = e } -> write_rec_buffer e value buffer
| Def { encoding = e } -> write_rec_buffer e value buffer
| Splitted { encoding = e } -> write_rec_buffer e value buffer
| Union (_, sz, cases) ->
let rec write_case = function
| [] -> raise No_case_matched
| Case { tag = Json_only } :: tl -> write_case tl
| Case { encoding = e ; proj ; tag = Tag tag } :: tl ->
begin
match proj value with
| None -> write_case tl
| Some data ->
write_tag sz tag buffer ;
write_rec_buffer e data buffer
end in
write_case cases
| Mu (_, _, self) ->
write_rec_buffer (self encoding) value buffer
| Dynamic_size e ->
MBytes_buffer.write_sized buffer (fun () -> write_rec_buffer e value buffer)
| Delayed f -> write_rec_buffer (f ()) value buffer
let write t v buf ofs =
try Some (write_rec t v buf ofs)
with _ -> None
let to_bytes t v =
let bytes = MBytes_buffer.create () in
write_rec_buffer t v bytes ;
MBytes_buffer.to_mbytes bytes
let fixed_length e =
match Encoding.classify e with
| `Fixed n -> Some n
| `Dynamic | `Variable -> None
let fixed_length_exn e =
match fixed_length e with
| Some n -> n
| None -> invalid_arg "Data_encoding.Binary.fixed_length_exn"

28
src/lib_data_encoding/binary_error.ml
View File

@ -36,3 +36,31 @@ let pp_read_error ppf = function
Format.fprintf ppf "Trailing zero in Z" Format.fprintf ppf "Trailing zero in Z"
exception Read_error of read_error exception Read_error of read_error
type write_error =
| Size_limit_exceeded
| No_case_matched
| Invalid_int of { min : int ; v : int ; max : int }
| Invalid_float of { min : float ; v : float ; max : float }
| Invalid_bytes_length of { expected : int ; found : int }
| Invalid_string_length of { expected : int ; found : int }
let pp_write_error ppf = function
| Size_limit_exceeded ->
Format.fprintf ppf "Size limit exceeded"
| No_case_matched ->
Format.fprintf ppf "No case matched"
| Invalid_int { min ; v ; max} ->
Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
| Invalid_float { min ; v ; max} ->
Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
| Invalid_bytes_length { expected ; found } ->
Format.fprintf ppf
"Invalid bytes length (expected: %d ; found %d)"
expected found
| Invalid_string_length { expected ; found } ->
Format.fprintf ppf
"Invalid string length (expected: %d ; found %d)"
expected found
exception Write_error of write_error

12
src/lib_data_encoding/binary_error.mli
View File

@ -21,3 +21,15 @@ type read_error =
| Trailing_zero | Trailing_zero
exception Read_error of read_error exception Read_error of read_error
val pp_read_error: Format.formatter -> read_error -> unit val pp_read_error: Format.formatter -> read_error -> unit
type write_error =
| Size_limit_exceeded
| No_case_matched
| Invalid_int of { min : int ; v : int ; max : int }
| Invalid_float of { min : float ; v : float ; max : float }
| Invalid_bytes_length of { expected : int ; found : int }
| Invalid_string_length of { expected : int ; found : int }
val pp_write_error : Format.formatter -> write_error -> unit
exception Write_error of write_error

4
src/lib_data_encoding/binary_length.ml
View File

@ -47,7 +47,7 @@ let rec length : type x. x Encoding.t -> x -> int =
length e1 v1 + length e2 v2 length e1 v1 + length e2 v2
| Union (`Dynamic, sz, cases) -> | Union (`Dynamic, sz, cases) ->
let rec length_case = function let rec length_case = function
| [] -> raise (Read_error No_case_matched) | [] -> raise (Write_error No_case_matched)
| Case { tag = Json_only } :: tl -> length_case tl | Case { tag = Json_only } :: tl -> length_case tl
| Case { encoding = e ; proj ; _ } :: tl -> | Case { encoding = e ; proj ; _ } :: tl ->
match proj value with match proj value with
@ -88,7 +88,7 @@ let rec length : type x. x Encoding.t -> x -> int =
end end
| Union (`Variable, sz, cases) -> | Union (`Variable, sz, cases) ->
let rec length_case = function let rec length_case = function
| [] -> raise (Read_error No_case_matched) | [] -> raise (Write_error No_case_matched)
| Case { tag = Json_only } :: tl -> length_case tl | Case { tag = Json_only } :: tl -> length_case tl
| Case { encoding = e ; proj ; _ } :: tl -> | Case { encoding = e ; proj ; _ } :: tl ->
match proj value with match proj value with

305
src/lib_data_encoding/binary_writer.ml Normal file
View File

@ -0,0 +1,305 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Binary_error
let raise error = raise (Write_error error)
(** Imperative state of the binary writer. *)
type state = {
mutable buffer : MBytes.t ;
(** The buffer where to write. *)
mutable offset : int ;
(** The offset of the next byte to be written in [buffer]. *)
mutable allowed_bytes : int option ;
(** Maximum number of bytes that are allowed to be write in [buffer]
(after [offset]) before to fail (None = illimited). *)
}
let check_allowed_bytes state size =
match state.allowed_bytes with
| Some len when len < size -> raise Size_limit_exceeded
| Some len -> state.allowed_bytes <- Some (len - size)
| None -> ()
(** [may_resize state size] will first ensure there is enough
space in [state.buffer] for writing [size] bytes (starting at
[state.offset]).
When the buffer does not have enough space for writing [size] bytes,
but still has enough [allowed_bytes], it will replace the buffer
with a buffer large enough.
@raise [Binary_error.Write_error Size_limit_exceeded] when there is
not enough allowed bytes to write [size] bytes. *)
let may_resize state size =
check_allowed_bytes state size ;
let buffer_len = MBytes.length state.buffer in
if buffer_len - state.offset < size then begin
let new_buffer =
MBytes.create (max (2 * buffer_len) (buffer_len + size)) in
MBytes.blit state.buffer 0 new_buffer 0 state.offset ;
state.buffer <- new_buffer
end ;
state.offset <- state.offset + size
(** Writer for all the atomic types. *)
module Atom = struct
let check_int_range min v max =
if (v < min || max < v) then
raise (Invalid_int { min ; v ; max })
let check_float_range min v max =
if (v < min || max < v) then
raise (Invalid_float { min ; v ; max })
let int8 state v =
check_int_range (- (1 lsl 7)) v (1 lsl 7 - 1) ;
let ofs = state.offset in
may_resize state Binary_size.int8 ;
MBytes.set_int8 state.buffer ofs v
let uint8 state v =
check_int_range 0 v (1 lsl 8 - 1) ;
let ofs = state.offset in
may_resize state Binary_size.uint8 ;
MBytes.set_int8 state.buffer ofs v
let char state v = int8 state (int_of_char v)
let bool state v = uint8 state (if v then 255 else 0)
let int16 state v =
check_int_range (- (1 lsl 15)) v (1 lsl 15 - 1) ;
let ofs = state.offset in
may_resize state Binary_size.int16 ;
MBytes.set_int16 state.buffer ofs v
let uint16 state v =
check_int_range 0 v (1 lsl 16 - 1) ;
let ofs = state.offset in
may_resize state Binary_size.uint16 ;
MBytes.set_int16 state.buffer ofs v
let uint30 state v =
check_int_range 0 v (1 lsl 30 - 1) ;
let ofs = state.offset in
may_resize state Binary_size.uint30 ;
MBytes.set_int32 state.buffer ofs (Int32.of_int v)
let int31 state v =
check_int_range (- (1 lsl 30)) v (1 lsl 30 - 1) ;
let ofs = state.offset in
may_resize state Binary_size.int31 ;
MBytes.set_int32 state.buffer ofs (Int32.of_int v)
let int32 state v =
let ofs = state.offset in
may_resize state Binary_size.int32 ;
MBytes.set_int32 state.buffer ofs v
let int64 state v =
let ofs = state.offset in
may_resize state Binary_size.int64 ;
MBytes.set_int64 state.buffer ofs v
let ranged_int ~minimum ~maximum state v =
check_int_range minimum v maximum ;
let v = if minimum >= 0 then v - minimum else v in
match Binary_size.range_to_size ~minimum ~maximum with
| `Uint8 -> uint8 state v
| `Uint16 -> uint16 state v
| `Uint30 -> uint30 state v
| `Int8 -> int8 state v
| `Int16 -> int16 state v
| `Int31 -> int31 state v
let z state v =
let sign = Z.sign v < 0 in
let bits = Z.numbits v in
if Z.equal v Z.zero then
uint8 state 0x00
else
let v = Z.abs v in
let get_chunk pos len = Z.to_int (Z.extract v pos len) in
let length = (bits + 1 + 6) / 7 in
let offset = state.offset in
may_resize state length ;
MBytes.set_int8 state.buffer offset
((if sign then 0x40 else 0x00)
lor (if bits > 6 then 0x80 else 0x00)
lor (get_chunk 0 6)) ;
for i = 1 to length - 1 do
let pos = 6 + (i - 1) * 7 in
let chunk_len = if i = length - 1 then bits - pos else 7 in
MBytes.set_int8 state.buffer (offset + i)
((if i = bits / 7 then 0x00 else 0x80)
lor (get_chunk pos chunk_len))
done
let float state v =
let ofs = state.offset in
may_resize state Binary_size.float ;
MBytes.set_double state.buffer ofs v
let ranged_float ~minimum ~maximum state v =
check_float_range minimum v maximum ;
float state v
let string_enum tbl arr state v =
let value =
try snd (Hashtbl.find tbl v)
with Not_found -> raise No_case_matched in
match Binary_size.enum_size arr with
| `Uint30 -> uint30 state value
| `Uint16 -> uint16 state value
| `Uint8 -> uint8 state value
let fixed_kind_bytes length state s =
if MBytes.length s <> length then
raise (Invalid_bytes_length { expected = length ;
found = MBytes.length s }) ;
let ofs = state.offset in
may_resize state length ;
MBytes.blit s 0 state.buffer ofs length
let fixed_kind_string length state s =
if String.length s <> length then
raise (Invalid_string_length { expected = length ;
found = String.length s }) ;
let ofs = state.offset in
may_resize state length ;
MBytes.blit_of_string s 0 state.buffer ofs length
let tag = function
| `Uint8 -> uint8
| `Uint16 -> uint16
end
(** Main recursive writing function. *)
let rec write_rec : type a. a Encoding.t -> state -> a -> unit =
fun e state value ->
let open Encoding in
match e.encoding with
| Null -> ()
| Empty -> ()
| Constant _ -> ()
| Ignore -> ()
| Bool -> Atom.bool state value
| Int8 -> Atom.int8 state value
| Uint8 -> Atom.uint8 state value
| Int16 -> Atom.int16 state value
| Uint16 -> Atom.uint16 state value
| Int31 -> Atom.int31 state value
| Int32 -> Atom.int32 state value
| Int64 -> Atom.int64 state value
| Z -> Atom.z state value
| Float -> Atom.float state value
| Bytes (`Fixed n) -> Atom.fixed_kind_bytes n state value
| Bytes `Variable ->
let length = MBytes.length value in
Atom.fixed_kind_bytes length state value
| String (`Fixed n) -> Atom.fixed_kind_string n state value
| String `Variable ->
let length = String.length value in
Atom.fixed_kind_string length state value
| RangedInt { minimum ; maximum } ->
Atom.ranged_int ~minimum ~maximum state value
| RangedFloat { minimum ; maximum } ->
Atom.ranged_float ~minimum ~maximum state value
| String_enum (tbl, arr) ->
Atom.string_enum tbl arr state value
| Array e ->
Array.iter (write_rec e state) value
| List e ->
List.iter (write_rec e state) value
| Obj (Req (_, e)) -> write_rec e state value
| Obj (Opt (`Dynamic, _, e)) -> begin
match value with
| None -> Atom.bool state false
| Some value -> Atom.bool state true ; write_rec e state value
end
| Obj (Opt (`Variable, _, e)) -> begin
match value with
| None -> ()
| Some value -> write_rec e state value
end
| Obj (Dft (_, e, _)) -> write_rec e state value
| Objs (_, e1, e2) ->
let (v1, v2) = value in
write_rec e1 state v1 ;
write_rec e2 state v2
| Tup e -> write_rec e state value
| Tups (_, e1, e2) ->
let (v1, v2) = value in
write_rec e1 state v1 ;
write_rec e2 state v2
| Conv { encoding = e ; proj } ->
write_rec e state (proj value)
| Union (_, sz, cases) ->
let rec write_case = function
| [] -> raise No_case_matched
| Case { tag = Json_only } :: tl -> write_case tl
| Case { encoding = e ; proj ; tag = Tag tag } :: tl ->
match proj value with
| None -> write_case tl
| Some value ->
Atom.tag sz state tag ;
write_rec e state value in
write_case cases
| Dynamic_size e ->
Atom.int32 state 0l ; (* place holder for [size] *)
let initial_offset = state.offset in
write_rec e state value ;
(* patch the written [size] *)
let size = state.offset - initial_offset in
(* FIXME overflow *)
MBytes.set_int32
state.buffer (initial_offset - Binary_size.int32)
(Int32.of_int size)
| Describe { encoding = e } -> write_rec e state value
| Def { encoding = e } -> write_rec e state value
| Splitted { encoding = e } -> write_rec e state value
| Mu (_, _, self) -> write_rec (self e) state value
| Delayed f -> write_rec (f ()) state value
(** ******************** *)
(** Various entry points *)
let write e v buffer offset len =
(* By harcoding [allowed_bytes] with the buffer length,
we ensure that [write] will never reallocate the buffer. *)
let state = { buffer ; offset ; allowed_bytes = Some len } in
try
write_rec e state v ;
Some state.offset
with Write_error _ -> None
let to_bytes e v =
match Encoding.classify e with
| `Fixed n -> begin
(* Preallocate the complete buffer *)
let state = { buffer = MBytes.create n ;
offset = 0 ; allowed_bytes = Some n } in
write_rec e state v ;
state.buffer
end
| `Dynamic | `Variable ->
(* Preallocate a minimal buffer and let's not hardcode a
limit to its extension. *)
let state = { buffer = MBytes.create 4096 ;
offset = 0 ; allowed_bytes = None } in
write_rec e state v ;
MBytes.sub state.buffer 0 state.offset

2
src/lib_data_encoding/binary.mli → src/lib_data_encoding/binary_writer.mli
View File

@ -10,5 +10,5 @@
(** This is for use *within* the data encoding library only. Instead, you should (** This is for use *within* the data encoding library only. Instead, you should
use the corresponding module intended for use: {Data_encoding.Binary}. *) use the corresponding module intended for use: {Data_encoding.Binary}. *)
val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int option val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int -> int option
val to_bytes : 'a Encoding.t -> 'a -> MBytes.t val to_bytes : 'a Encoding.t -> 'a -> MBytes.t

2
src/lib_data_encoding/data_encoding.ml
View File

@ -22,9 +22,9 @@ include Encoding
module Json = Json module Json = Json
module Bson = Bson module Bson = Bson
module Binary = struct module Binary = struct
include Binary
include Binary_error include Binary_error
include Binary_length include Binary_length
include Binary_writer
include Binary_reader include Binary_reader
include Binary_stream_reader include Binary_stream_reader
end end

25
src/lib_data_encoding/data_encoding.mli
View File

@ -528,9 +528,11 @@ end
module Binary: sig module Binary: sig
val length : 'a Encoding.t -> 'a -> int val length : 'a Encoding.t -> 'a -> int
val fixed_length : 'a Encoding.t -> int option
val fixed_length_exn : 'a Encoding.t -> int
val read : 'a Encoding.t -> MBytes.t -> int -> int -> (int * 'a) option val read : 'a Encoding.t -> MBytes.t -> int -> int -> (int * 'a) option
val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int option
val to_bytes : 'a Encoding.t -> 'a -> MBytes.t
val of_bytes : 'a Encoding.t -> MBytes.t -> 'a option val of_bytes : 'a Encoding.t -> MBytes.t -> 'a option
val of_bytes_exn : 'a Encoding.t -> MBytes.t -> 'a val of_bytes_exn : 'a Encoding.t -> MBytes.t -> 'a
@ -551,10 +553,23 @@ module Binary: sig
| Await of (MBytes.t -> 'ret status) | Await of (MBytes.t -> 'ret status)
| Error of read_error | Error of read_error
val read_stream: ?init:Binary_stream.t -> 'a Encoding.t -> 'a status val read_stream : ?init:Binary_stream.t -> 'a Encoding.t -> 'a status
val fixed_length : 'a Encoding.t -> int option val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int -> int option
val fixed_length_exn : 'a Encoding.t -> int
type write_error =
| Size_limit_exceeded
| No_case_matched
| Invalid_int of { min : int ; v : int ; max : int }
| Invalid_float of { min : float ; v : float ; max : float }
| Invalid_bytes_length of { expected : int ; found : int }
| Invalid_string_length of { expected : int ; found : int }
val pp_write_error : Format.formatter -> write_error -> unit
exception Write_error of write_error
val to_bytes : 'a Encoding.t -> 'a -> MBytes.t
end end

4
src/lib_data_encoding/test/helpers.ml
View File

@ -26,6 +26,10 @@ let no_exception f =
Alcotest.failf Alcotest.failf
"@[v 2>bytes reading failed:@ %a@]" "@[v 2>bytes reading failed:@ %a@]"
Binary.pp_read_error error Binary.pp_read_error error
| Binary.Write_error error ->
Alcotest.failf
"@[v 2>bytes writing failed:@ %a@]"
Binary.pp_write_error error
let check_raises expected f = let check_raises expected f =
match f () with match f () with

2
src/lib_p2p/p2p_socket.ml
View File

@ -119,7 +119,7 @@ module Connection_message = struct
let len = Crypto.header_length + encoded_message_len in let len = Crypto.header_length + encoded_message_len in
let buf = MBytes.create len in let buf = MBytes.create len in
match Data_encoding.Binary.write match Data_encoding.Binary.write
encoding message buf Crypto.header_length with encoding message buf Crypto.header_length len with
| None -> | None ->
fail P2p_errors.Encoding_error fail P2p_errors.Encoding_error
| Some last -> | Some last ->

2
src/lib_protocol_environment/sigs/v1/data_encoding.mli
View File

@ -237,8 +237,8 @@ module Binary : sig
val length : 'a encoding -> 'a -> int val length : 'a encoding -> 'a -> int
val fixed_length : 'a encoding -> int option val fixed_length : 'a encoding -> int option
val read : 'a encoding -> MBytes.t -> int -> int -> (int * 'a) option val read : 'a encoding -> MBytes.t -> int -> int -> (int * 'a) option
val write : 'a encoding -> 'a -> MBytes.t -> int -> int option
val to_bytes : 'a encoding -> 'a -> MBytes.t val to_bytes : 'a encoding -> 'a -> MBytes.t
val write : 'a encoding -> 'a -> MBytes.t -> int -> int -> int option
val of_bytes : 'a encoding -> MBytes.t -> 'a option val of_bytes : 'a encoding -> MBytes.t -> 'a option
end end

89
src/lib_stdlib/mBytes_buffer.ml
View File

@ -1,89 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = { mutable buffer : MBytes.t ;
mutable offset : int }
let create ?(initial_size=4096) () =
if initial_size <= 0
then invalid_arg "MBytes_buffer size must be greater than zero" ;
{ buffer = MBytes.create initial_size ;
offset = 0 }
let resize ?at_least_size buf =
let new_buf =
MBytes.create
(2 * (MBytes.length buf.buffer + Option.unopt ~default:0 at_least_size)) in
MBytes.blit buf.buffer 0 new_buf 0 buf.offset ;
buf.buffer <- new_buf
let resize_if_necessary buf bytes =
if buf.offset + bytes > MBytes.length buf.buffer
then resize ~at_least_size:bytes buf
else ()
let write_mbytes dst src srcoff len =
resize_if_necessary dst len ;
MBytes.blit src srcoff dst.buffer dst.offset len ;
dst.offset <- dst.offset + len
let write_char buf char =
resize_if_necessary buf 1 ;
MBytes.set_char buf.buffer buf.offset char ;
buf.offset <- buf.offset + 1
let write_int8 buf int =
resize_if_necessary buf 1 ;
MBytes.set_int8 buf.buffer buf.offset int ;
buf.offset <- buf.offset + 1
let write_int16 buf int =
resize_if_necessary buf 2 ;
MBytes.set_int16 buf.buffer buf.offset int ;
buf.offset <- buf.offset + 2
let write_int32 buf int =
resize_if_necessary buf 4 ;
MBytes.set_int32 buf.buffer buf.offset int ;
buf.offset <- buf.offset + 4
let write_int64 buf int =
resize_if_necessary buf 8 ;
MBytes.set_int64 buf.buffer buf.offset int ;
buf.offset <- buf.offset + 8
let write_float buf float =
resize_if_necessary buf 4 ;
MBytes.set_float buf.buffer buf.offset float ;
buf.offset <- buf.offset + 4
let write_double buf float =
resize_if_necessary buf 8 ;
MBytes.set_double buf.buffer buf.offset float ;
buf.offset <- buf.offset + 8
let write_string_data buf str =
let len = String.length str in
resize_if_necessary buf len ;
MBytes.blit_of_string str 0 buf.buffer buf.offset len ;
buf.offset <- buf.offset + len
let write_sized buffer (writer : unit -> unit) =
let initial_offset = buffer.offset in
write_int32 buffer Int32.zero ;
writer () ;
let ending_offset = buffer.offset in
let size = ending_offset - initial_offset - 4 in
let size32 = Int32.of_int size in
if (Int32.to_int size32) <> size
then failwith "Tried to write more than [Int32.max_int] bytes in sized location"
else MBytes.set_int32 buffer.buffer initial_offset size32
let to_mbytes buf =
MBytes.sub buf.buffer 0 buf.offset

63
src/lib_stdlib/mBytes_buffer.mli
View File

@ -1,63 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Low-level byte growing byte vector. Internally uses operations in
{!MBytes}. The vector is resized as needed.
All operations append to the end of the vector. **)
(** Type of vectors *)
type t
(** Create a vector with an initial size of [initial_size]. *)
val create : ?initial_size:int -> unit -> t
(** [write_mbytes t src src_offset len]
Copy a sequence of len bytes from [src] to [t] starting at [src_offset]. *)
val write_mbytes : t -> MBytes.t -> int -> int -> unit
(** Write a character to the vector *)
val write_char : t -> char -> unit
(** Write an 8-bit signed integer to the vector *)
val write_int8 : t -> int -> unit
(** Write an 16-bit signed integer to the vector *)
val write_int16 : t -> int -> unit
(** Write an 32-bit signed integer to the vector *)
val write_int32 : t -> int32 -> unit
(** Write an 64-bit signed integer to the vector *)
val write_int64 : t -> int64 -> unit
(** Write a single-precision float to the vector *)
val write_float : t -> float -> unit
(** Write a double-precision float to the vector *)
val write_double : t -> float -> unit
(** Write the characters from a string to the vector.
This does not copy the size. *)
val write_string_data : t -> string -> unit
(** Write a sized amount of data to the vector.
Size is a 32 bit integer.
Do not use [to_mbytes] in the writer function. *)
val write_sized : t -> (unit -> unit) -> unit
(** Convert the buffer to mBytes.
As all operations are append only, you can continue to add to the
buffer after this function has been called.
The buffer may be more than twice as large as necessary to contain
the written data. Calling [MBytes.copy] will create a new buffer
that is exactly the required size. *)
val to_mbytes : t -> MBytes.t

7
src/lib_stdlib/test/jbuild
View File

@ -2,7 +2,6 @@
(executables (executables
((names (test_tzList ((names (test_tzList
test_mbytes_buffer
test_lwt_pipe)) test_lwt_pipe))
(libraries (tezos-stdlib (libraries (tezos-stdlib
alcotest alcotest
@ -14,17 +13,12 @@
(alias (alias
((name buildtest) ((name buildtest)
(deps (test_tzList.exe (deps (test_tzList.exe
test_mbytes_buffer.exe
test_lwt_pipe.exe)))) test_lwt_pipe.exe))))
(alias (alias
((name runtest_tzList) ((name runtest_tzList)
(action (run ${exe:test_tzList.exe})))) (action (run ${exe:test_tzList.exe}))))
(alias
((name runtest_mbytes_buffer)
(action (run ${exe:test_mbytes_buffer.exe}))))
(alias (alias
((name runtest_lwt_pipe) ((name runtest_lwt_pipe)
(action (run ${exe:test_lwt_pipe.exe})))) (action (run ${exe:test_lwt_pipe.exe}))))
@ -32,7 +26,6 @@
(alias (alias
((name runtest) ((name runtest)
(deps ((alias runtest_tzList) (deps ((alias runtest_tzList)
(alias runtest_mbytes_buffer)
(alias runtest_lwt_pipe))))) (alias runtest_lwt_pipe)))))
(alias (alias

27
src/lib_stdlib/test/test_mbytes_buffer.ml
View File

@ -1,27 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let hex_of_buffer buf =
let `Hex s = MBytes.to_hex (MBytes_buffer.to_mbytes buf) in
s
let assert_hex_eq buf =
Assert.equal ~prn:(fun x -> x) (hex_of_buffer buf)
let () =
let buf1 = MBytes_buffer.create ~initial_size:1 () in
MBytes_buffer.write_char buf1 'a' ;
assert_hex_eq buf1 "61" ;
MBytes_buffer.write_char buf1 'Q' ;
assert_hex_eq buf1 "6151" ;
MBytes_buffer.write_int32 buf1 Int32.max_int ;
assert_hex_eq buf1 "61517fffffff" ;
let buf2 = MBytes_buffer.create ~initial_size:1 () in
MBytes_buffer.write_sized buf2 (fun () -> MBytes_buffer.write_string_data buf2 "abc") ;
assert_hex_eq buf2 "00000003616263"