Data_encoding: implements bounded lists and arrays

src/lib_data_encoding/binary_description.ml

@@ -295,12 +295,12 @@ let describe (type x) (encoding : x Encoding.t) =
           fields ref_name recursives references encoding.encoding
       | Delayed func ->
           fields ref_name recursives references (func ()).encoding
-      | List { encoding } ->
+      | List (_, { encoding }) ->
           let (layout, references) =
             layout None recursives references encoding in
           ([ Anonymous_field (`Variable, Seq layout) ],
            references)
-      | Array { encoding } ->
+      | Array (_, { encoding }) ->
           let (layout, references) =
             layout None recursives references encoding in
           ([ Anonymous_field (`Variable, Seq layout) ],
@@ -436,11 +436,11 @@ let describe (type x) (encoding : x Encoding.t) =
           let size, cases = enum tbl encoding_array in
           let references = add_reference name (Int_enum { size ; cases }) references in
           (Enum (size, name), references)
-      | Array data ->
+      | Array (_, data) ->
           let (descr, references) =
             layout None recursives references data.encoding in
           (Seq descr, references)
-      | List data ->
+      | List (_, data) ->
           let layout, references =
             layout None recursives references data.encoding in
           (Seq layout, references)

src/lib_data_encoding/binary_error.ml

@@ -17,6 +17,7 @@ type read_error =
   | Invalid_float of { min : float ; v : float ; max : float }
   | Trailing_zero
   | Size_limit_exceeded
+  | Oversized_list
 
 let pp_read_error ppf = function
   | Not_enough_data ->
@@ -37,6 +38,8 @@ let pp_read_error ppf = function
       Format.fprintf ppf "Trailing zero in Z"
   | Size_limit_exceeded ->
       Format.fprintf ppf "Size limit exceeded"
+  | Oversized_list ->
+      Format.fprintf ppf "Size limit exceeded"
 
 exception Read_error of read_error
 
@@ -48,6 +51,7 @@ type write_error =
   | Invalid_bytes_length of { expected : int ; found : int }
   | Invalid_string_length of { expected : int ; found : int }
   | Invalid_natural
+  | Oversized_list
 
 let pp_write_error ppf = function
   | Size_limit_exceeded ->
@@ -68,5 +72,7 @@ let pp_write_error ppf = function
         expected found
   | Invalid_natural ->
       Format.fprintf ppf "Negative natural"
+  | Oversized_list ->
+      Format.fprintf ppf "Size limit exceeded"
 
 exception Write_error of write_error

src/lib_data_encoding/binary_error.mli

@@ -20,6 +20,7 @@ type read_error =
   | Invalid_float of { min : float ; v : float ; max : float }
   | Trailing_zero
   | Size_limit_exceeded
+  | Oversized_list
 exception Read_error of read_error
 val pp_read_error: Format.formatter -> read_error -> unit
 
@@ -31,6 +32,7 @@ type write_error =
   | Invalid_bytes_length of { expected : int ; found : int }
   | Invalid_string_length of { expected : int ; found : int }
   | Invalid_natural
+  | Oversized_list
 
 val pp_write_error : Format.formatter -> write_error -> unit
 

src/lib_data_encoding/binary_length.ml

@@ -71,11 +71,15 @@ let rec length : type x. x Encoding.t -> x -> int =
     | Ignore -> 0
     | Bytes `Variable -> MBytes.length value
     | String `Variable -> String.length value
-    | Array e ->
+    | Array (Some max_length, _e) when Array.length value > max_length ->
+        raise (Write_error Oversized_list)
+    | Array (_, e) ->
         Array.fold_left
           (fun acc v -> length e v + acc)
           0 value
-    | List e ->
+    | List (Some max_length, _e) when List.length value > max_length ->
+        raise (Write_error Oversized_list)
+    | List (_, e) ->
         List.fold_left
           (fun acc v -> length e v + acc)
           0 value

src/lib_data_encoding/binary_reader.ml

@@ -190,10 +190,13 @@ let rec read_rec : type ret. ret Encoding.t -> state -> ret
         Atom.ranged_float ~minimum ~maximum state
     | String_enum (_, arr) ->
         Atom.string_enum arr state
-    | Array e ->
+    | Array (max_length, e) ->
-        let l = read_list e state in
+        let max_length = Option.unopt ~default:max_int max_length in
+        let l = read_list max_length e state in
         Array.of_list l
-    | List e -> read_list e state
+    | List (max_length, e) ->
+        let max_length = Option.unopt ~default:max_int max_length in
+        read_list max_length e state
     | (Obj (Req { encoding = e })) -> read_rec e state
     | (Obj (Dft { encoding = e })) -> read_rec e state
     | (Obj (Opt { kind = `Dynamic ; encoding = e })) ->
@@ -300,15 +303,17 @@ and read_variable_pair
         (left, right)
     | _ -> assert false (* Should be rejected by [Encoding.Kind.combine] *)
 
-and read_list : type a. a Encoding.t -> state -> a list
+and read_list : type a. int -> a Encoding.t -> state -> a list
-  = fun e state ->
+  = fun max_length e state ->
-    let rec loop acc =
+    let rec loop max_length acc =
       if state.remaining_bytes = 0 then
         List.rev acc
+      else if max_length = 0 then
+        raise Oversized_list
       else
         let v = read_rec e state in
-        loop (v :: acc) in
+        loop (max_length - 1) (v :: acc) in
-    loop []
+    loop max_length []
 
 
 

src/lib_data_encoding/binary_stream_reader.ml

@@ -259,10 +259,13 @@ let rec read_rec
         Atom.ranged_float ~minimum ~maximum resume state k
     | String_enum (_, arr) ->
         Atom.string_enum arr resume state k
-    | Array e ->
+    | Array (max_length, e) ->
-        read_list e state @@ fun (l, state) ->
+        let max_length = Option.unopt ~default:max_int max_length in
+        read_list max_length e state @@ fun (l, state) ->
         k (Array.of_list l, state)
-    | List e -> read_list e state k
+    | List (max_length, e) ->
+        let max_length = Option.unopt ~default:max_int max_length in
+        read_list max_length e state k
     | (Obj (Req { encoding = e })) -> read_rec whole e state k
     | (Obj (Dft { encoding = e })) -> read_rec whole e state k
     | (Obj (Opt { kind = `Dynamic ; encoding = e })) ->
@@ -395,16 +398,18 @@ and read_variable_pair
 
 and read_list
   : type a ret.
-    a Encoding.t -> state -> ((a list * state) -> ret status) -> ret status
+    int -> a Encoding.t -> state -> ((a list * state) -> ret status) -> ret status
-  = fun e state k ->
+  = fun max_length e state k ->
-    let rec loop state acc =
+    let rec loop state acc max_length =
       let size = remaining_bytes state in
       if size = 0 then
         k (List.rev acc, state)
+      else if max_length = 0 then
+        raise Oversized_list
       else
         read_rec false e state @@ fun (v, state) ->
-        loop state (v :: acc) in
+        loop state (v :: acc) (max_length - 1) in
-    loop state []
+    loop state [] max_length
 
 let read_rec e state k =
   try read_rec false e state k

src/lib_data_encoding/binary_writer.ml

@@ -225,9 +225,13 @@ let rec write_rec : type a. a Encoding.t -> state -> a -> unit =
         Atom.ranged_float ~minimum ~maximum state value
     | String_enum (tbl, arr) ->
         Atom.string_enum tbl arr state value
-    | Array e ->
+    | Array (Some max_length, _e) when Array.length value > max_length ->
+        raise Oversized_list
+    | Array (_, e) ->
         Array.iter (write_rec e state) value
-    | List e ->
+    | List (Some max_length, _e) when List.length value > max_length ->
+        raise Oversized_list
+    | List (_, e) ->
         List.iter (write_rec e state) value
     | Obj (Req { encoding = e }) -> write_rec e state value
     | Obj (Opt { kind = `Dynamic ; encoding = e }) -> begin

src/lib_data_encoding/data_encoding.mli

@@ -170,7 +170,7 @@ module Encoding: sig
        prefixed its length in bytes
 
       @raise [Invalid_argument] if the inner encoding is variable. *)
-  val array : 'a encoding -> 'a array encoding
+  val array : ?max_length:int -> 'a encoding -> 'a array encoding
 
   (** List combinator.
       - encoded as an array in JSON
@@ -178,7 +178,7 @@ module Encoding: sig
        prefixed its length in bytes
 
       @raise [Invalid_argument] if the inner encoding is also variable. *)
-  val list : 'a encoding -> 'a list encoding
+  val list : ?max_length:int -> 'a encoding -> 'a list encoding
 
   (** Provide a transformer from one encoding to a different one.
 
@@ -419,16 +419,18 @@ module Encoding: sig
   (** Create encodings that produce data of a variable length when binary encoded.
       See the preamble for an explanation. *)
   module Variable : sig
+
     val string : string encoding
     val bytes : MBytes.t encoding
 
     (** @raises [Invalid_argument] if the encoding argument is variable length
         or may lead to zero-width representation in binary. *)
-    val array : 'a encoding -> 'a array encoding
+    val array : ?max_length:int -> 'a encoding -> 'a array encoding
 
     (** @raises [Invalid_argument] if the encoding argument is variable length
         or may lead to zero-width representation in binary. *)
-    val list : 'a encoding -> 'a list encoding
+    val list : ?max_length:int -> 'a encoding -> 'a list encoding
+
   end
 
   module Bounded : sig
@@ -631,6 +633,7 @@ module Binary: sig
     | Invalid_float of { min : float ; v : float ; max : float }
     | Trailing_zero
     | Size_limit_exceeded
+    | Oversized_list
   exception Read_error of read_error
   val pp_read_error: Format.formatter -> read_error -> unit
 
@@ -643,6 +646,7 @@ module Binary: sig
     | Invalid_bytes_length of { expected : int ; found : int }
     | Invalid_string_length of { expected : int ; found : int }
     | Invalid_natural
+    | Oversized_list
   val pp_write_error : Format.formatter -> write_error -> unit
   exception Write_error of write_error
 

src/lib_data_encoding/encoding.ml

@@ -85,8 +85,8 @@ type 'a desc =
   | String : Kind.length -> string desc
   | Padded : 'a t * int -> 'a desc
   | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
-  | Array : 'a t -> 'a array desc
+  | Array : int option * 'a t -> 'a array desc
-  | List : 'a t -> 'a list desc
+  | List : int option * 'a t -> 'a list desc
   | Obj : 'a field -> 'a desc
   | Objs : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc
   | Tup : 'a t -> 'a desc
@@ -303,14 +303,24 @@ module Variable = struct
         "Cannot insert potentially zero-sized element in %s." name
     else
       ()
-  let array e =
+  let array ?max_length e =
     check_not_variable "an array" e ;
     check_not_zeroable "an array" e ;
-    make @@ Array e
+    let encoding = make @@ Array (max_length, e) in
-  let list e =
+    match classify e, max_length with
+    | `Fixed n, Some max_length ->
+        let limit = n * max_length in
+        make @@ Check_size { limit ; encoding }
+    | _, _ -> encoding
+  let list ?max_length e =
     check_not_variable "a list" e ;
     check_not_zeroable "a list" e ;
-    make @@ List e
+    let encoding = make @@ List (max_length, e) in
+    match classify e, max_length with
+    | `Fixed n, Some max_length ->
+        let limit = n * max_length in
+        make @@ Check_size { limit ; encoding }
+    | _, _ -> encoding
 end
 
 let dynamic_size ?(kind = `Uint30) e =
@@ -350,8 +360,8 @@ let float = make @@ Float
 
 let string = dynamic_size Variable.string
 let bytes = dynamic_size Variable.bytes
-let array e = dynamic_size (Variable.array e)
+let array ?max_length e = dynamic_size (Variable.array ?max_length e)
-let list e = dynamic_size (Variable.list e)
+let list ?max_length e = dynamic_size (Variable.list ?max_length e)
 
 let string_enum = function
   | [] -> invalid_arg "data_encoding.string_enum: cannot have zero cases"

src/lib_data_encoding/encoding.mli

@@ -43,8 +43,8 @@ type 'a desc =
   | String : Kind.length -> string desc
   | Padded : 'a t * int -> 'a desc
   | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
-  | Array : 'a t -> 'a array desc
+  | Array : int option * 'a t -> 'a array desc
-  | List : 'a t -> 'a list desc
+  | List : int option * 'a t -> 'a list desc
   | Obj : 'a field -> 'a desc
   | Objs : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc
   | Tup : 'a t -> 'a desc
@@ -154,8 +154,8 @@ end
 module Variable : sig
   val string : string encoding
   val bytes : MBytes.t encoding
-  val array : 'a encoding -> 'a array encoding
+  val array : ?max_length:int -> 'a encoding -> 'a array encoding
-  val list : 'a encoding -> 'a list encoding
+  val list : ?max_length:int -> 'a encoding -> 'a list encoding
 end
 val dynamic_size :
   ?kind:Binary_size.unsigned_integer -> 'a encoding -> 'a encoding
@@ -248,8 +248,8 @@ val tup10 :
 
 val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding
 val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding
-val array : 'a encoding -> 'a array encoding
+val array : ?max_length:int -> 'a encoding -> 'a array encoding
-val list : 'a encoding -> 'a list encoding
+val list : ?max_length:int -> 'a encoding -> 'a list encoding
 
 val case :
   title:string ->

src/lib_data_encoding/json.ml

@@ -199,8 +199,8 @@ let rec json : type a. a Encoding.desc -> a Json_encoding.encoding =
       conv check check bytes_jsont
   | Bytes _ -> bytes_jsont
   | String_enum (tbl, _) -> string_enum (Hashtbl.fold (fun a (str, _) acc -> (str, a) :: acc) tbl [])
-  | Array e -> array (get_json e)
+  | Array (_, e) -> array (get_json e) (* FIXME TODO enforce max_length *)
-  | List e -> list (get_json e)
+  | List (_, e) -> list (get_json e)
   | Obj f -> obj1 (field_json f)
   | Objs { left ; right } ->
       merge_objs (get_json left) (get_json right)

src/lib_protocol_environment/sigs/v1/data_encoding.mli

@@ -54,8 +54,8 @@ end
 module Variable : sig
   val string : string encoding
   val bytes : MBytes.t encoding
-  val array : 'a encoding -> 'a array encoding
+  val array : ?max_length: int -> 'a encoding -> 'a array encoding
-  val list : 'a encoding -> 'a list encoding
+  val list : ?max_length: int -> 'a encoding -> 'a list encoding
 end
 
 module Bounded : sig
@@ -159,8 +159,8 @@ val tup10 :
 val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding
 val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding
 
-val array : 'a encoding -> 'a array encoding
+val array : ?max_length: int -> 'a encoding -> 'a array encoding
-val list : 'a encoding -> 'a list encoding
+val list : ?max_length: int -> 'a encoding -> 'a list encoding
 
 val assoc : 'a encoding -> (string * 'a) list encoding