diff --git a/src/lib_data_encoding/binary.ml b/src/lib_data_encoding/binary.ml deleted file mode 100644 index a8ada267c..000000000 --- a/src/lib_data_encoding/binary.ml +++ /dev/null @@ -1,442 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* 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" diff --git a/src/lib_data_encoding/binary_error.ml b/src/lib_data_encoding/binary_error.ml index 85509ed56..502cd51f3 100644 --- a/src/lib_data_encoding/binary_error.ml +++ b/src/lib_data_encoding/binary_error.ml @@ -36,3 +36,31 @@ let pp_read_error ppf = function Format.fprintf ppf "Trailing zero in Z" 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 diff --git a/src/lib_data_encoding/binary_error.mli b/src/lib_data_encoding/binary_error.mli index 69498bfe1..1d43ee274 100644 --- a/src/lib_data_encoding/binary_error.mli +++ b/src/lib_data_encoding/binary_error.mli @@ -21,3 +21,15 @@ type read_error = | Trailing_zero exception Read_error of read_error 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 diff --git a/src/lib_data_encoding/binary_length.ml b/src/lib_data_encoding/binary_length.ml index f5e9a430a..991da65ea 100644 --- a/src/lib_data_encoding/binary_length.ml +++ b/src/lib_data_encoding/binary_length.ml @@ -47,7 +47,7 @@ let rec length : type x. x Encoding.t -> x -> int = length e1 v1 + length e2 v2 | Union (`Dynamic, sz, cases) -> 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 { encoding = e ; proj ; _ } :: tl -> match proj value with @@ -88,7 +88,7 @@ let rec length : type x. x Encoding.t -> x -> int = end | Union (`Variable, sz, cases) -> 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 { encoding = e ; proj ; _ } :: tl -> match proj value with diff --git a/src/lib_data_encoding/binary_writer.ml b/src/lib_data_encoding/binary_writer.ml new file mode 100644 index 000000000..f9524095a --- /dev/null +++ b/src/lib_data_encoding/binary_writer.ml @@ -0,0 +1,305 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/lib_data_encoding/binary.mli b/src/lib_data_encoding/binary_writer.mli similarity index 91% rename from src/lib_data_encoding/binary.mli rename to src/lib_data_encoding/binary_writer.mli index 87f0b256a..e0a1c5723 100644 --- a/src/lib_data_encoding/binary.mli +++ b/src/lib_data_encoding/binary_writer.mli @@ -10,5 +10,5 @@ (** This is for use *within* the data encoding library only. Instead, you should 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 diff --git a/src/lib_data_encoding/data_encoding.ml b/src/lib_data_encoding/data_encoding.ml index 6019fd52e..46f34f63e 100644 --- a/src/lib_data_encoding/data_encoding.ml +++ b/src/lib_data_encoding/data_encoding.ml @@ -22,9 +22,9 @@ include Encoding module Json = Json module Bson = Bson module Binary = struct - include Binary include Binary_error include Binary_length + include Binary_writer include Binary_reader include Binary_stream_reader end diff --git a/src/lib_data_encoding/data_encoding.mli b/src/lib_data_encoding/data_encoding.mli index 8f1b96799..a7578c531 100644 --- a/src/lib_data_encoding/data_encoding.mli +++ b/src/lib_data_encoding/data_encoding.mli @@ -528,9 +528,11 @@ end module Binary: sig 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 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_exn : 'a Encoding.t -> MBytes.t -> 'a @@ -551,10 +553,23 @@ module Binary: sig | Await of (MBytes.t -> 'ret status) | 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 fixed_length_exn : 'a Encoding.t -> int + val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int -> int option + + 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 diff --git a/src/lib_data_encoding/test/helpers.ml b/src/lib_data_encoding/test/helpers.ml index e379d7d48..dd8c39463 100644 --- a/src/lib_data_encoding/test/helpers.ml +++ b/src/lib_data_encoding/test/helpers.ml @@ -26,6 +26,10 @@ let no_exception f = Alcotest.failf "@[v 2>bytes reading failed:@ %a@]" 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 = match f () with diff --git a/src/lib_p2p/p2p_socket.ml b/src/lib_p2p/p2p_socket.ml index 845368648..542e8b9e2 100644 --- a/src/lib_p2p/p2p_socket.ml +++ b/src/lib_p2p/p2p_socket.ml @@ -119,7 +119,7 @@ module Connection_message = struct let len = Crypto.header_length + encoded_message_len in let buf = MBytes.create len in match Data_encoding.Binary.write - encoding message buf Crypto.header_length with + encoding message buf Crypto.header_length len with | None -> fail P2p_errors.Encoding_error | Some last -> diff --git a/src/lib_protocol_environment/sigs/v1/data_encoding.mli b/src/lib_protocol_environment/sigs/v1/data_encoding.mli index 1075ddc9f..0441b3d4b 100644 --- a/src/lib_protocol_environment/sigs/v1/data_encoding.mli +++ b/src/lib_protocol_environment/sigs/v1/data_encoding.mli @@ -237,8 +237,8 @@ module Binary : sig val length : 'a encoding -> 'a -> int val fixed_length : 'a encoding -> int 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 write : 'a encoding -> 'a -> MBytes.t -> int -> int -> int option val of_bytes : 'a encoding -> MBytes.t -> 'a option end diff --git a/src/lib_stdlib/mBytes_buffer.ml b/src/lib_stdlib/mBytes_buffer.ml deleted file mode 100644 index 9950740ed..000000000 --- a/src/lib_stdlib/mBytes_buffer.ml +++ /dev/null @@ -1,89 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* 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 diff --git a/src/lib_stdlib/mBytes_buffer.mli b/src/lib_stdlib/mBytes_buffer.mli deleted file mode 100644 index c22c9059e..000000000 --- a/src/lib_stdlib/mBytes_buffer.mli +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* 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 diff --git a/src/lib_stdlib/test/jbuild b/src/lib_stdlib/test/jbuild index 629e8f3bc..91bd79112 100644 --- a/src/lib_stdlib/test/jbuild +++ b/src/lib_stdlib/test/jbuild @@ -2,7 +2,6 @@ (executables ((names (test_tzList - test_mbytes_buffer test_lwt_pipe)) (libraries (tezos-stdlib alcotest @@ -14,17 +13,12 @@ (alias ((name buildtest) (deps (test_tzList.exe - test_mbytes_buffer.exe test_lwt_pipe.exe)))) (alias ((name runtest_tzList) (action (run ${exe:test_tzList.exe})))) -(alias - ((name runtest_mbytes_buffer) - (action (run ${exe:test_mbytes_buffer.exe})))) - (alias ((name runtest_lwt_pipe) (action (run ${exe:test_lwt_pipe.exe})))) @@ -32,7 +26,6 @@ (alias ((name runtest) (deps ((alias runtest_tzList) - (alias runtest_mbytes_buffer) (alias runtest_lwt_pipe))))) (alias diff --git a/src/lib_stdlib/test/test_mbytes_buffer.ml b/src/lib_stdlib/test/test_mbytes_buffer.ml deleted file mode 100644 index 8b98ee813..000000000 --- a/src/lib_stdlib/test/test_mbytes_buffer.ml +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* 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"