From 2f5fa5b6342922dd64ed43810b13314e9a0bb876 Mon Sep 17 00:00:00 2001 From: Thomas Letan Date: Sat, 2 Jul 2022 16:34:17 +0200 Subject: [PATCH 1/7] Scoru_wasm: Implement thunks for type-safe deep merklisation --- src/lib_scoru_wasm/thunk.ml | 659 +++++++++++++++++++++++++++++++++++ src/lib_scoru_wasm/thunk.mli | 165 +++++++++ 2 files changed, 824 insertions(+) create mode 100644 src/lib_scoru_wasm/thunk.ml create mode 100644 src/lib_scoru_wasm/thunk.mli diff --git a/src/lib_scoru_wasm/thunk.ml b/src/lib_scoru_wasm/thunk.ml new file mode 100644 index 000000000000..8abcf5cc7008 --- /dev/null +++ b/src/lib_scoru_wasm/thunk.ml @@ -0,0 +1,659 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Copyright (c) 2022 Trili Tech, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* The use of polymorphic variant in these two (opaque) phantom types + is motivated by the need to circumvent warning 37 + ([unused-constructor]). *) + +type 'a value = [`Value of 'a] + +type ('a, 'b) dict = [`Dict of 'a * 'b] + +module Make (T : Tree.S) = struct + type tree = T.tree + + module Schema = struct + type 'a decoder = tree -> 'a option Lwt.t + + type 'a encoder = tree -> string list -> 'a -> tree Lwt.t + + type !'a t = {folders : string list; descr : 'a schema} + + and !'a schema = + | Value_s : 'a encoder * 'a decoder -> 'a value schema + | Tup2_s : 'a field * 'b field -> ('a * 'b) schema + | Tup3_s : 'a field * 'b field * 'c field -> ('a * 'b * 'c) schema + | Tup4_s : + 'a field * 'b field * 'c field * 'd field + -> ('a * 'b * 'c * 'd) schema + | Tup5_s : + 'a field * 'b field * 'c field * 'd field * 'e field + -> ('a * 'b * 'c * 'd * 'e) schema + | Dict_s : ('a -> string) * 'b t -> ('a, 'b) dict schema + + and !'a field = {directory : string; schema : 'a t} + + let encoding : 'a Data_encoding.t -> 'a value t = + fun encoding -> + let encoder tree key value = + T.add tree key (Data_encoding.Binary.to_bytes_exn encoding value) + in + let decoder tree = + let open Lwt_syntax in + let* bytes = T.find tree [] in + match bytes with + | Some bytes -> + Lwt.return + @@ Some (Data_encoding.Binary.of_bytes_exn encoding bytes) + | None -> Lwt.return None + in + {folders = []; descr = Value_s (encoder, decoder)} + + let custom ~encoder ~decoder = + {folders = []; descr = Value_s (encoder, decoder)} + + let req directory schema = {directory; schema} + + let folders str {folders; descr} = {folders = folders @ List.rev str; descr} + + let obj2 b1 b2 = {folders = []; descr = Tup2_s (b1, b2)} + + let obj3 b1 b2 b3 = {folders = []; descr = Tup3_s (b1, b2, b3)} + + let obj4 b1 b2 b3 b4 = {folders = []; descr = Tup4_s (b1, b2, b3, b4)} + + let obj5 b1 b2 b3 b4 b5 = + {folders = []; descr = Tup5_s (b1, b2, b3, b4, b5)} + + let dict encoder schema = {folders = []; descr = Dict_s (encoder, schema)} + end + + type 'a schema = 'a Schema.t + + type !'a shallow = + | Shallow : tree option -> 'a shallow + (** [Shalow (Some tree)] encodes a piece of data that has not + been fetched from [tree]. [Shallow None] encodes a piece + of data that is absent from the original tree, or that has + been cut from the tree. *) + | Tup2 : 'a t * 'b t -> ('a * 'b) shallow + | Tup3 : 'a t * 'b t * 'c t -> ('a * 'b * 'c) shallow + | Tup4 : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) shallow + | Tup5 : + 'a t * 'b t * 'c t * 'd t * 'e t + -> ('a * 'b * 'c * 'd * 'e) shallow + | Value : 'a -> 'a value shallow + | Dict : tree option * ('a * 'b t) list -> ('a, 'b) dict shallow + + and !'a t = {value : 'a shallow ref; schema : 'a schema} + + type !'a thunk = 'a t + + let shallow_t tree schema = {value = ref (Shallow tree); schema} + + let decode : 'a schema -> tree -> 'a thunk = + fun schema tree -> shallow_t (Some tree) schema + + let encode : type a. tree -> a thunk -> tree Lwt.t = + fun tree -> + let rec encode : type a. string list -> tree -> a thunk -> tree Lwt.t = + fun prefix tree thunk -> + let open Lwt_syntax in + let tree_prefix = prefix in + let value_prefix = thunk.schema.folders @ tree_prefix in + match (!(thunk.value), thunk.schema.descr) with + | Shallow (Some tree'), _ -> + let* tree = T.add_tree tree (List.rev tree_prefix) tree' in + return tree + | Shallow None, _ -> + let* tree = T.remove tree (List.rev tree_prefix) in + return tree + | Value x, Value_s (encoder, _) -> + let* tree = encoder tree (List.rev value_prefix) x in + return tree + | Dict (Some tree', assoc), Dict_s (key_encoder, _schema) -> + let* tree' = + Lwt_list.fold_left_s + (fun tree' (k, v) -> + encode (key_encoder k :: thunk.schema.folders) tree' v) + tree' + assoc + in + let* tree = T.add_tree tree (List.rev tree_prefix) tree' in + return tree + | Dict (None, assoc), Dict_s (key_encoder, _schema) -> + let* tree = T.remove tree (List.rev tree_prefix) in + let* tree = + Lwt_list.fold_left_s + (fun tree (k, v) -> encode (key_encoder k :: value_prefix) tree v) + tree + assoc + in + return tree + | Tup2 (x, y), Tup2_s (fst, snd) -> + let* tree = encode (fst.directory :: value_prefix) tree x in + let* tree = encode (snd.directory :: value_prefix) tree y in + return tree + | Tup3 (x, y, z), Tup3_s (fst, snd, thd) -> + let* tree = encode (fst.directory :: value_prefix) tree x in + let* tree = encode (snd.directory :: value_prefix) tree y in + let* tree = encode (thd.directory :: value_prefix) tree z in + return tree + | Tup4 (a, b, c, d), Tup4_s (a_s, b_s, c_s, d_s) -> + let* tree = encode (a_s.directory :: value_prefix) tree a in + let* tree = encode (b_s.directory :: value_prefix) tree b in + let* tree = encode (c_s.directory :: value_prefix) tree c in + let* tree = encode (d_s.directory :: value_prefix) tree d in + return tree + | Tup5 (a, b, c, d, e), Tup5_s (a_s, b_s, c_s, d_s, e_s) -> + let* tree = encode (a_s.directory :: value_prefix) tree a in + let* tree = encode (b_s.directory :: value_prefix) tree b in + let* tree = encode (c_s.directory :: value_prefix) tree c in + let* tree = encode (d_s.directory :: value_prefix) tree d in + let* tree = encode (e_s.directory :: value_prefix) tree e in + return tree + in + encode [] tree + + let find : type a. a value t -> a option Lwt.t = + fun thunk -> + let open Lwt_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Value x, Value_s (_, _) -> return (Some x) + | Shallow (Some tree), Value_s (_, decoder) -> ( + let* tree = T.find_tree tree (List.rev thunk.schema.folders) in + match tree with + | Some tree -> + let* x = decoder tree in + (thunk.value := + match x with Some x -> Value x | None -> Shallow None) ; + return x + | None -> return None) + | Shallow None, Value_s (_, _decoder) -> return None + + let get thunk = + let open Lwt_syntax in + let* x = find thunk in + match x with + | Some x -> return x + | None -> raise (Invalid_argument "get: missing value") + + let set : type a. a value t -> a -> unit = + fun thunk x -> + match !(thunk.value) with Value _ | Shallow _ -> thunk.value := Value x + + let cut : type a. a t -> unit = fun thunk -> thunk.value := Shallow None + + type ('a, 'b) lens = 'a thunk -> 'b thunk Lwt.t + + let ( ^. ) : ('a, 'b) lens -> ('b, 'c) lens -> ('a, 'c) lens = + fun l1 l2 thunk -> + let open Lwt_syntax in + let* thunk = l1 thunk in + l2 thunk + + let tup2_0 : type a b. (a * b, a) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup2 (x, _y), _ -> return x + | Shallow (Some tree), Tup2_s (x, y) -> + let* tree_x = T.find_tree tree (prefix x.directory) in + let* tree_y = T.find_tree tree (prefix y.directory) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + thunk.value := Tup2 (x, y) ; + return @@ x + | Shallow None, Tup2_s (x, y) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + thunk.value := Tup2 (x, y) ; + return @@ x + + let tup2_1 : type a b. (a * b, b) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup2 (_x, y), _ -> return y + | Shallow (Some tree), Tup2_s (x, y) -> + let* tree_x = T.find_tree tree (prefix x.directory) in + let* tree_y = T.find_tree tree (prefix y.directory) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + thunk.value := Tup2 (x, y) ; + return y + | Shallow None, Tup2_s (x, y) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + thunk.value := Tup2 (x, y) ; + return y + + let tup3_0 : type a b c. (a * b * c, a) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup3 (x, _y, _z), _ -> return x + | Shallow (Some tree), Tup3_s (x, y, z) -> + let* tree_x = T.find_tree tree (prefix x.directory) in + let* tree_y = T.find_tree tree (prefix y.directory) in + let* tree_z = T.find_tree tree (prefix z.directory) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + let z = shallow_t tree_z z.schema in + thunk.value := Tup3 (x, y, z) ; + return x + | Shallow None, Tup3_s (x, y, z) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + let z = shallow_t None z.schema in + thunk.value := Tup3 (x, y, z) ; + return x + + let tup3_1 : type a b c. (a * b * c, b) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup3 (_x, y, _z), _ -> return y + | Shallow (Some tree), Tup3_s (x, y, z) -> + let* tree_x = T.find_tree tree (prefix x.directory) in + let* tree_y = T.find_tree tree (prefix y.directory) in + let* tree_z = T.find_tree tree (prefix z.directory) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + let z = shallow_t tree_z z.schema in + thunk.value := Tup3 (x, y, z) ; + return y + | Shallow None, Tup3_s (x, y, z) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + let z = shallow_t None z.schema in + thunk.value := Tup3 (x, y, z) ; + return y + + let tup3_2 : type a b c. (a * b * c, c) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup3 (_x, _y, z), _ -> return z + | Shallow (Some tree), Tup3_s (x, y, z) -> + let* tree_x = T.find_tree tree (prefix x.directory) in + let* tree_y = T.find_tree tree (prefix y.directory) in + let* tree_z = T.find_tree tree (prefix z.directory) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + let z = shallow_t tree_z z.schema in + thunk.value := Tup3 (x, y, z) ; + return z + | Shallow None, Tup3_s (x, y, z) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + let z = shallow_t None z.schema in + thunk.value := Tup3 (x, y, z) ; + return z + + let tup4_0 : type a b c d. (a * b * c * d, a) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (a, _b, _c, _d), _ -> return a + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return a + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return a + + let tup4_1 : type a b c d. (a * b * c * d, b) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (_a, b, _c, _d), _ -> return b + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return b + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return b + + let tup4_2 : type a b c d. (a * b * c * d, c) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (_a, _b, c, _d), _ -> return c + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return c + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return c + + let tup4_3 : type a b c d. (a * b * c * d, d) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (_a, _b, _c, d), _ -> return d + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return d + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return d + + let tup5_0 : type a b c d e. (a * b * c * d * e, a) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup5 (a, _b, _c, _d, _e), _ -> return a + | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let* tree_e = T.find_tree tree (prefix e_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + let e = shallow_t tree_e e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return a + | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + let e = shallow_t None e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return a + + let tup5_1 : type a b c d e. (a * b * c * d * e, b) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup5 (_a, b, _c, _d, _e), _ -> return b + | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let* tree_e = T.find_tree tree (prefix e_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + let e = shallow_t tree_e e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return b + | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + let e = shallow_t None e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return b + + let tup5_2 : type a b c d e. (a * b * c * d * e, c) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup5 (_a, _b, c, _d, _e), _ -> return c + | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let* tree_e = T.find_tree tree (prefix e_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + let e = shallow_t tree_e e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return c + | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + let e = shallow_t None e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return c + + let tup5_3 : type a b c d e. (a * b * c * d * e, d) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup5 (_a, _b, _c, d, _e), _ -> return d + | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let* tree_e = T.find_tree tree (prefix e_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + let e = shallow_t tree_e e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return d + | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + let e = shallow_t None e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return d + + let tup5_4 : type a b c d e. (a * b * c * d * e, e) lens = + fun thunk -> + let open Lwt_syntax in + let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in + match (!(thunk.value), thunk.schema.descr) with + | Tup5 (_a, _b, _c, _d, e), _ -> return e + | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let* tree_a = T.find_tree tree (prefix a_f.directory) in + let* tree_b = T.find_tree tree (prefix b_f.directory) in + let* tree_c = T.find_tree tree (prefix c_f.directory) in + let* tree_d = T.find_tree tree (prefix d_f.directory) in + let* tree_e = T.find_tree tree (prefix e_f.directory) in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + let e = shallow_t tree_e e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return e + | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + let e = shallow_t None e_f.schema in + thunk.value := Tup5 (a, b, c, d, e) ; + return e + + let entry : type a b. a -> ((a, b) dict, b) lens = + fun k thunk -> + let open Lwt_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Dict (Some tree, assoc), Dict_s (encoder, schema) -> ( + match List.assq_opt k assoc with + | Some v -> return v + | None -> + let entry = encoder k in + let* tree' = T.find_tree tree (entry :: thunk.schema.folders) in + let v = shallow_t tree' schema in + thunk.value := Dict (Some tree, (k, v) :: assoc) ; + return v) + | Shallow (Some tree), Dict_s (encoder, schema) -> + let entry = encoder k in + let* tree' = T.find_tree tree (entry :: thunk.schema.folders) in + let v = shallow_t tree' schema in + thunk.value := Dict (Some tree, [(k, v)]) ; + return v + | (Dict (None, []) | Shallow None), Dict_s (_encoder, schema) -> + let v = shallow_t None schema in + thunk.value := Dict (None, [(k, v)]) ; + return v + | Dict (None, assoc), Dict_s (_encoder, schema) -> ( + match List.assq_opt k assoc with + | Some v -> return v + | None -> + let v = shallow_t None schema in + thunk.value := Dict (None, (k, v) :: assoc) ; + return v) + + module Lazy_list = struct + type 'a t = int32 value * (int32, 'a) dict + + let schema : 'a schema -> 'a t schema = + fun schema -> + let open Schema in + obj2 + (req "len" @@ encoding Data_encoding.int32) + (req "contents" (dict Int32.to_string schema)) + + let length : 'a t thunk -> int32 Lwt.t = + fun thunk -> + let open Lwt_syntax in + let* len = tup2_0 thunk in + let* len = find len in + return @@ Option.value ~default:0l len + + let nth ~check idx : ('a t, 'a) lens = + fun thunk -> + let open Lwt_syntax in + let* c = length thunk in + if (not check) || idx < c then + (tup2_1 ^. entry Int32.(pred @@ sub c idx)) thunk + else + raise + (Invalid_argument + ("nth: index " ^ Int32.to_string idx ^ " out of bound")) + + let alloc_cons : 'a t thunk -> (int32 * 'a thunk) Lwt.t = + fun thunk -> + let open Lwt_syntax in + let* c = length thunk in + let* len = tup2_0 thunk in + let () = set len (Int32.succ c) in + let* cons = (tup2_1 ^. entry c) thunk in + return (c, cons) + + let cons : 'a value t thunk -> 'a -> int32 Lwt.t = + fun thunk x -> + let open Lwt_syntax in + let* idx, cell = alloc_cons thunk in + let () = set cell x in + return idx + end + + module Syntax = struct + let ( ^-> ) x f = f x + + let ( let*^? ) x k = + let open Lwt_syntax in + let* x = x in + let* x = find x in + k x + + let ( let*^ ) x k = + let open Lwt_syntax in + let* x = x in + let* x = get x in + k x + + let ( ^:= ) x v = + let open Lwt_syntax in + let* x = x in + set x v ; + return () + end +end diff --git a/src/lib_scoru_wasm/thunk.mli b/src/lib_scoru_wasm/thunk.mli new file mode 100644 index 000000000000..f59b84326e63 --- /dev/null +++ b/src/lib_scoru_wasm/thunk.mli @@ -0,0 +1,165 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Copyright (c) 2022 Trili Tech, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* TODO: https://gitlab.com/tezos/tezos/-/issues/3388 + Provide a docstring for every functions and types introduced by + this module. *) + +(** This module provides a means of transparently manipulating a + hierarchy of values stored in a tree. These values are lazily + loaded on demand, modified in-place, and then encoded back in the + tree once the computation is done. + + In a nutshell, a ['a thunk] is a lazily loaded collection of + values whose hierarchy is determined by ['a]. A ['a schema] is a + declarative description of your data model, that is how to encode + and decode your values. Developers familiar with [Data_encoding] + will find the API of [schema] familiar. Then, ['a lens] is a way + to traverse a [thunk], reading what’s needing from a tree, and + modifying in-place your datas. *) + +(** ['a value] denotes a value in a data-model of type ['a] that can be + read from and write to a tree. *) +type 'a value + +(** [('a, 'b) dict] denotes a dictionary in a data-model that + associates sub-hierarchies of value determined by type [b] to keys + of type [a] (said keys need to be serializable to [string]). *) +type ('a, 'b) dict + +module Make (T : Tree.S) : sig + type tree = T.tree + + module Schema : sig + type !'a t + + val encoding : 'a Data_encoding.t -> 'a value t + + val custom : + encoder:(tree -> string list -> 'a -> tree Lwt.t) -> + decoder:(tree -> 'a option Lwt.t) -> + 'a value t + + type !'a field + + val folders : string list -> 'a t -> 'a t + + val req : string -> 'a t -> 'a field + + val obj2 : 'a field -> 'b field -> ('a * 'b) t + + val obj3 : 'a field -> 'b field -> 'c field -> ('a * 'b * 'c) t + + val obj4 : + 'a field -> 'b field -> 'c field -> 'd field -> ('a * 'b * 'c * 'd) t + + val obj5 : + 'a field -> + 'b field -> + 'c field -> + 'd field -> + 'e field -> + ('a * 'b * 'c * 'd * 'e) t + + val dict : ('a -> string) -> 'b t -> ('a, 'b) dict t + end + + type 'a schema = 'a Schema.t + + type !'a t + + type !'a thunk = 'a t + + val decode : 'a schema -> tree -> 'a thunk + + val encode : tree -> 'a thunk -> tree Lwt.t + + val find : 'a value thunk -> 'a option Lwt.t + + val get : 'a value thunk -> 'a Lwt.t + + val set : 'a value thunk -> 'a -> unit + + val cut : 'a thunk -> unit + + type ('a, 'b) lens = 'a thunk -> 'b thunk Lwt.t + + val ( ^. ) : ('a, 'b) lens -> ('b, 'c) lens -> ('a, 'c) lens + + val tup2_0 : ('a * 'b, 'a) lens + + val tup2_1 : ('a * 'b, 'b) lens + + val tup3_0 : ('a * 'b * 'c, 'a) lens + + val tup3_1 : ('a * 'b * 'c, 'b) lens + + val tup3_2 : ('a * 'b * 'c, 'c) lens + + val tup4_0 : ('a * 'b * 'c * 'd, 'a) lens + + val tup4_1 : ('a * 'b * 'c * 'd, 'b) lens + + val tup4_2 : ('a * 'b * 'c * 'd, 'c) lens + + val tup4_3 : ('a * 'b * 'c * 'd, 'd) lens + + val tup5_0 : ('a * 'b * 'c * 'd * 'e, 'a) lens + + val tup5_1 : ('a * 'b * 'c * 'd * 'e, 'b) lens + + val tup5_2 : ('a * 'b * 'c * 'd * 'e, 'c) lens + + val tup5_3 : ('a * 'b * 'c * 'd * 'e, 'd) lens + + val tup5_4 : ('a * 'b * 'c * 'd * 'e, 'e) lens + + val entry : 'a -> (('a, 'b) dict, 'b) lens + + module Lazy_list : sig + type !'a t + + val schema : 'a schema -> 'a t schema + + val length : 'a t thunk -> int32 Lwt.t + + val nth : check:bool -> int32 -> ('a t, 'a) lens + + val alloc_cons : 'a t thunk -> (int32 * 'a thunk) Lwt.t + + val cons : 'a value t thunk -> 'a -> int32 Lwt.t + end + + module Syntax : sig + val ( ^-> ) : 'a thunk -> ('a, 'b) lens -> 'b thunk Lwt.t + + val ( let*^ ) : 'a value thunk Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + + val ( let*^? ) : 'a value thunk Lwt.t -> ('a option -> 'b Lwt.t) -> 'b Lwt.t + + val ( ^:= ) : 'a value thunk Lwt.t -> 'a -> unit Lwt.t + end +end -- GitLab From 1688fb32642337f10b7463d71960d8ed2227a32f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Thomas=20P=C3=A9cseli?= Date: Tue, 5 Jul 2022 13:36:08 +0200 Subject: [PATCH 2/7] SCORU: WASM: Load kernel image from boot sector and inbox messages Co-authored-by: Thomas Letan --- .../environment_V6.ml | 2 +- src/lib_scoru_wasm/gather_floppies.ml | 316 ++++++++++++++++++ src/lib_scoru_wasm/gather_floppies.mli | 55 +++ src/lib_scoru_wasm/tezos_scoru_wasm.ml | 35 +- src/lib_scoru_wasm/tezos_scoru_wasm.mli | 70 +--- src/lib_scoru_wasm/wasm_pvm.ml | 54 +++ src/lib_scoru_wasm/wasm_pvm.mli | 78 +++++ 7 files changed, 517 insertions(+), 93 deletions(-) create mode 100644 src/lib_scoru_wasm/gather_floppies.ml create mode 100644 src/lib_scoru_wasm/gather_floppies.mli create mode 100644 src/lib_scoru_wasm/wasm_pvm.ml create mode 100644 src/lib_scoru_wasm/wasm_pvm.mli diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 52cbeefd0f2b..2efa5705b769 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1142,7 +1142,7 @@ struct let get_output {outbox_level; message_index} (tree : Tree.tree) = Wasm.get_output {outbox_level; message_index} tree - let convert_input : Tezos_scoru_wasm.input -> input = function + let convert_input : Tezos_scoru_wasm.input_info -> input = function | {inbox_level; message_counter} -> {inbox_level; message_counter} let get_info (tree : Tree.tree) = diff --git a/src/lib_scoru_wasm/gather_floppies.ml b/src/lib_scoru_wasm/gather_floppies.ml new file mode 100644 index 000000000000..801f879fc5f5 --- /dev/null +++ b/src/lib_scoru_wasm/gather_floppies.ml @@ -0,0 +1,316 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +exception Malformed_origination_message of Data_encoding.Binary.read_error + +exception Malformed_inbox_message of Data_encoding.Binary.read_error + +exception Compute_step_expected_input + +exception Set_input_step_expected_compute_step + +exception Encoding_error of Data_encoding.Binary.write_error + +exception Malformed_input_info_record + +module Make (T : Tree.S) (Wasm : Wasm_pvm.S with type tree = T.tree) : + Wasm_pvm.S with type tree = T.tree = struct + type tree = Wasm.tree + + type 'a value = 'a Thunk.value + + module Thunk = Thunk.Make (T) + module Decoding = Tree_decoding.Make (T) + include Wasm_pvm + + (* TYPES *) + + type internal_status = Gathering_floppies | Not_gathering_floppies + + let internal_status_encoding = + Data_encoding.string_enum + [ + ("GatheringFloppies", Gathering_floppies); + ("NotGatheringFloppies", Not_gathering_floppies); + ] + + (* An at most 4,096-byte fragment of a kernel. *) + type chunk = bytes + + let chunk_encoding = Data_encoding.Bounded.bytes 4_096 + + type floppy = {chunk : chunk; signature : Tezos_crypto.Signature.t} + + let floppy_encoding = + Data_encoding.( + conv + (fun {chunk; signature} -> (chunk, signature)) + (fun (chunk, signature) -> {chunk; signature}) + (obj2 + (req "chunk" chunk_encoding) + (req "signature" Tezos_crypto.Signature.encoding))) + + (* Encoding for message in "boot sector" *) + type origination_message = + | Complete_kernel of bytes + | Incomplete_kernel of chunk * Tezos_crypto.Signature.Public_key.t + + let boot_sector_encoding = + let open Data_encoding in + union + [ + case + ~title:"complete" + (Tag 0) + (obj1 @@ req "complete_kernel" chunk_encoding) + (function Complete_kernel s -> Some s | _ -> None) + (fun s -> Complete_kernel s); + case + ~title:"incomplete" + (Tag 1) + (obj2 + (req "first_chunk" chunk_encoding) + (req "public_key" Tezos_crypto.Signature.Public_key.encoding)) + (function Incomplete_kernel (s, pk) -> Some (s, pk) | _ -> None) + (fun (s, pk) -> Incomplete_kernel (s, pk)); + ] + + let input_encoding = + let open Data_encoding in + conv + (fun {inbox_level; message_counter} -> + ( Tezos_base.Bounded.Int32.NonNegative.to_int32 inbox_level, + message_counter )) + (fun (inbox_level, message_counter) -> + match Tezos_base.Bounded.Int32.NonNegative.of_int32 inbox_level with + | Some v -> {inbox_level = v; message_counter} + | None -> raise Malformed_input_info_record) + (tup2 int32 z) + + (* STORAGE KEYS *) + + type state = + (internal_status value * Tezos_crypto.Signature.Public_key.t value) + * string value + * input_info value + * Z.t value + (* TODO: https://gitlab.com/tezos/tezos/-/issues/3362 + Replace the [lazy_list] with [Chunked_byte_vector] to compose + better with the [lib_webassembly]. *) + * bytes value Thunk.Lazy_list.t + + let state_schema : state Thunk.schema = + let open Thunk.Schema in + obj5 + (req + "pvm" + (obj2 + (req "status" @@ encoding internal_status_encoding) + (req "public-key" + @@ encoding Tezos_crypto.Signature.Public_key.encoding))) + (req "boot-sector" @@ encoding Data_encoding.string) + (req "last-input-info" @@ encoding input_encoding) + (req "internal-loading-kernel-tick" @@ encoding Data_encoding.n) + (req "durable" + @@ folders ["kernel"; "boot.wasm"] + @@ Thunk.Lazy_list.schema (encoding chunk_encoding)) + + let status_l : (state, internal_status value) Thunk.lens = + Thunk.(tup5_0 ^. tup2_0) + + let public_key_l : + (state, Tezos_crypto.Signature.Public_key.t value) Thunk.lens = + Thunk.(tup5_0 ^. tup2_1) + + let boot_sector_l : (state, string value) Thunk.lens = Thunk.tup5_1 + + let last_input_info_l : (state, input_info value) Thunk.lens = Thunk.tup5_2 + + let internal_tick_l : (state, Z.t value) Thunk.lens = Thunk.tup5_3 + + let chunks_l : (state, bytes value Thunk.Lazy_list.t) Thunk.lens = + Thunk.tup5_4 + + (* STORAGE/TREE INTERACTION *) + + let check_signature payload signature state = + let open Lwt_syntax in + let open Thunk.Syntax in + let*^ pk = state ^-> public_key_l in + return @@ Tezos_crypto.Signature.check pk signature payload + + let store_chunk state chunk = + let open Lwt_syntax in + let open Thunk.Syntax in + let* chunks = state ^-> chunks_l in + let* _ = Thunk.Lazy_list.cons chunks chunk in + return () + + let store_bytes state : bytes -> unit Lwt.t = + let rec aux bytes = + let open Lwt_syntax in + let open Thunk.Syntax in + let len = Bytes.length bytes in + let* chunks = state ^-> chunks_l in + if len = 0 then return () + else if len < 4_096 then + let* _ = Thunk.Lazy_list.cons chunks bytes in + return () + else + let chunk = Bytes.sub bytes 0 4_096 in + let rst = Bytes.sub bytes 4_096 (len - 4_096) in + let* _ = Thunk.Lazy_list.cons chunks chunk in + aux rst + in + aux + + let get_internal_ticks state = + let open Lwt_syntax in + let open Thunk.Syntax in + let*^? tick = state ^-> internal_tick_l in + return @@ Option.value ~default:Z.zero tick + + let increment_ticks state = + let open Lwt_syntax in + let open Thunk.Syntax in + let* tick = get_internal_ticks state in + (state ^-> internal_tick_l) ^:= Z.succ tick + + (* PROCESS MESSAGES *) + + (* Process and store the kernel image in the origination message + This message contains either the entire (small) kernel image or + the first chunk of it. *) + let origination_kernel_loading_step state = + let open Lwt_syntax in + let open Thunk.Syntax in + let* () = increment_ticks state in + let*^ boot_sector = state ^-> boot_sector_l in + let boot_sector = + Data_encoding.Binary.of_string_opt boot_sector_encoding boot_sector + in + match boot_sector with + | Some (Complete_kernel kernel) -> + let* () = store_bytes state kernel in + (state ^-> status_l) ^:= Not_gathering_floppies + | Some (Incomplete_kernel (chunk, _boot_pk)) when Bytes.length chunk = 4_096 + -> + (* Despite claiming the boot sector is not a complete kernel, + it is not large enough to fill a chunk. *) + let* () = store_chunk state chunk in + (state ^-> status_l) ^:= Not_gathering_floppies + | Some (Incomplete_kernel (chunk, boot_pk)) -> + let* () = store_chunk state chunk in + let* () = (state ^-> public_key_l) ^:= boot_pk in + (state ^-> status_l) ^:= Gathering_floppies + | None -> + (* TODO: Add a proper [status] constructor *) + return () + + (* Process one sub-sequent kernel image chunks. If the chunk has + zero length it * means we're done and we have the entire kernel + image. *) + let kernel_loading_step input message state = + let open Lwt_syntax in + let open Thunk.Syntax in + let* () = (state ^-> last_input_info_l) ^:= input in + let* () = increment_ticks state in + match Data_encoding.Binary.of_string floppy_encoding message with + | Error error -> raise (Malformed_inbox_message error) + | Ok {chunk; signature} -> + let* check = check_signature chunk signature state in + if check then + let* () = + if 0 < Bytes.length chunk then store_chunk state chunk + else return () + in + if Bytes.length chunk < 4_096 then + (state ^-> status_l) ^:= Not_gathering_floppies + else return () + else return () + + (* Encapsulated WASM *) + + let compute_step tree = + let open Lwt_syntax in + let open Thunk.Syntax in + let state = Thunk.decode state_schema tree in + let*^? status = state ^-> status_l in + match status with + | Some Gathering_floppies -> raise Compute_step_expected_input + | Some Not_gathering_floppies -> Wasm.compute_step tree + | None -> + let* () = origination_kernel_loading_step state in + Thunk.encode tree state + + let set_input_step input message tree = + let open Lwt_syntax in + let open Thunk.Syntax in + let state = Thunk.decode state_schema tree in + let*^? status = state ^-> status_l in + match status with + | Some Gathering_floppies -> + let* () = kernel_loading_step input message state in + Thunk.encode tree state + | Some Not_gathering_floppies -> Wasm.set_input_step input message tree + | None -> raise Set_input_step_expected_compute_step + + let get_output = Wasm.get_output + + let get_info tree = + let open Lwt_syntax in + let open Thunk.Syntax in + let state = Thunk.decode state_schema tree in + let*^? status = state ^-> status_l in + let* ticks = get_internal_ticks state in + let*^? last_boot_read = state ^-> last_input_info_l in + match status with + | Some Gathering_floppies -> + return + { + current_tick = ticks; + last_input_read = last_boot_read; + input_request = Input_required; + } + | Some Not_gathering_floppies -> + let* inner_info = Wasm.get_info tree in + return + { + inner_info with + current_tick = Z.(add inner_info.current_tick ticks); + last_input_read = + Option.fold + ~none:last_boot_read + ~some:(fun x -> Some x) + inner_info.last_input_read; + } + | None -> + return + { + current_tick = ticks; + last_input_read = None; + input_request = No_input_required; + } +end diff --git a/src/lib_scoru_wasm/gather_floppies.mli b/src/lib_scoru_wasm/gather_floppies.mli new file mode 100644 index 000000000000..d02e282caee9 --- /dev/null +++ b/src/lib_scoru_wasm/gather_floppies.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Raised when the origination message contains neither a complete nor an + incomplete kernel message. *) +exception Malformed_origination_message of Data_encoding.Binary.read_error + +(** Raised when a message containing a kernel image chunk was expected, but + the message in the inbox contained something else. *) +exception Malformed_inbox_message of Data_encoding.Binary.read_error + +(** Raised when [compute_step] was called when the floppy gathering module + expected input. *) +exception Compute_step_expected_input + +(** Raised when the floppy gathering module wasn't expecting input, but input + was given using [set_input_step]. A [compute_step] is needed right after + origination. *) +exception Set_input_step_expected_compute_step + +(** Generic internal error. Some data in storage had errornous encoding. *) +exception Encoding_error of Data_encoding.Binary.write_error + +(** Internal error. Raised if the [input_info] record that is stored somehow + gets overwritten with something malformed. *) +exception Malformed_input_info_record + +(** [Make] encapsulates a WASM PVM to give it the ability to load a kernel + image as either a complete kernel in the origination message or a kernel + image divided into chunks and provided via both origination- and inbox- + messages. *) +module Make (T : Tree.S) (Wasm : Wasm_pvm.S with type tree = T.tree) : + Wasm_pvm.S with type tree = T.tree diff --git a/src/lib_scoru_wasm/tezos_scoru_wasm.ml b/src/lib_scoru_wasm/tezos_scoru_wasm.ml index b44d6db3568c..e552afb80bc7 100644 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.ml +++ b/src/lib_scoru_wasm/tezos_scoru_wasm.ml @@ -23,44 +23,17 @@ (* *) (*****************************************************************************) +open Tezos_webassembly_interpreter +open Instance + (* This library acts as a dependency to the protocol environment. Everything that must be exposed to the protocol via the environment shall be added here. *) -open Tezos_webassembly_interpreter -open Instance - -type input = { - inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - message_counter : Z.t; -} - -type output = { - outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - message_index : Z.t; -} -type input_request = No_input_required | Input_required - -type info = { - current_tick : Z.t; - last_input_read : input option; - input_request : input_request; -} - -module type S = sig - type tree - - val compute_step : tree -> tree Lwt.t - - val set_input_step : input -> string -> tree -> tree Lwt.t - - val get_output : output -> tree -> string Lwt.t - - val get_info : tree -> info Lwt.t -end +include Wasm_pvm module Make (T : Tree.S) : S with type tree = T.tree = struct type tree = T.tree diff --git a/src/lib_scoru_wasm/tezos_scoru_wasm.mli b/src/lib_scoru_wasm/tezos_scoru_wasm.mli index 36a2c9517fd4..b1c6fcd1f76d 100644 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.mli +++ b/src/lib_scoru_wasm/tezos_scoru_wasm.mli @@ -31,70 +31,18 @@ WASM VM related that must be exposed to the protocol via the environment shall be added here. *) -(** Represents the location of an input message. *) -type input = { - inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - (** The inbox level at which the message exists.*) - message_counter : Z.t; (** The index of the message in the inbox. *) -} - -(** Represents the location of an output message. *) -type output = { - outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - (** The outbox level at which the message exists.*) - message_index : Z.t; (** The index of the message in the outbox. *) -} - -(** Represents the state of input requests. *) -type input_request = - | No_input_required (** The VM does not expect any input. *) - | Input_required (** The VM needs input in order to progress. *) - -(** Represents the state of the VM. *) -type info = { - current_tick : Z.t; - (** The number of ticks processed by the VM, zero for the initial state. - [current_tick] must be incremented for each call to [step] *) - last_input_read : input option; - (** The last message to be read by the VM, if any. *) - input_request : input_request; (** The current VM input request. *) -} - -(** This module type defines a WASM VM API used for smart-contract rollups. *) -module type S = sig - type tree - - (** [compute_step] forwards the VM by one compute tick. If the VM is expecting - input, it gets stuck. If the VM is already stuck, this function may - raise an exception. *) - val compute_step : tree -> tree Lwt.t - - (** [set_input_step] forwards the VM by one input tick. If the VM is not - expecting input, it gets stuck. If the VM is already stuck, this function - may raise an exception. *) - val set_input_step : input -> string -> tree -> tree Lwt.t - - (** [get_output output state] returns the payload associated with the given - output. The result is meant to be deserialized using - [Sc_rollup_PVM_sem.output_encoding]. If the output is missing, this - function may raise an exception. *) - val get_output : output -> tree -> string Lwt.t - - (** [get_info] provides a typed view of the current machine state. Should not - raise. *) - val get_info : tree -> info Lwt.t -end +include module type of Wasm_pvm (** Builds a WASM VM given a concrete implementation of {!Tree.S}. *) -module Make (T : Tree.S) : S with type tree = T.tree +module Make (T : Tree.S) : Wasm_pvm.S with type tree = T.tree exception Bad_input -(** [aux_write_memory ~input_buffer ~module_inst ~rtype_offset ~level_offset +(** [aux_write_memory ~input_buffer ~module_inst ~rtype_offset ~level_offset ~id_offset ~dst ~max_bytes] - reads `input_buffer` and writes its components to the memory of - `module_inst` based on the memory addreses offsets described. It also - checks that the input payload is no larger than `max_input` and crashes + reads `input_buffer` and writes its components to the memory of + `module_inst` based on the memory addreses offsets described. It also + checks that the input payload is no larger than `max_input` and crashes with `input too large` otherwise. It returns the size of the payload.*) val aux_write_input_in_memory : input_buffer:Tezos_webassembly_interpreter.Input_buffer.t -> @@ -107,9 +55,9 @@ val aux_write_input_in_memory : int Lwt.t (** read_input is a HostFunction. It has to be invoked with a list of 5 values - representing rtype_offset, level_offset, id_offset, dst and max_bytes. When - invoked, it applies `aux_write_input_in_memory` with the corresponding - parameters and returns a singleton value list containing the size of the + representing rtype_offset, level_offset, id_offset, dst and max_bytes. When + invoked, it applies `aux_write_input_in_memory` with the corresponding + parameters and returns a singleton value list containing the size of the input_buffer payload. *) val read_input : ( Tezos_webassembly_interpreter.Input_buffer.t, diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml new file mode 100644 index 000000000000..3667e354aaef --- /dev/null +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type input_info = { + inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + message_counter : Z.t; +} + +type output_info = { + outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + message_index : Z.t; +} + +type input_request = No_input_required | Input_required + +type info = { + current_tick : Z.t; + last_input_read : input_info option; + input_request : input_request; (** The current VM input request. *) +} + +module type S = sig + type tree + + val compute_step : tree -> tree Lwt.t + + val set_input_step : input_info -> string -> tree -> tree Lwt.t + + val get_output : output_info -> tree -> string Lwt.t + + val get_info : tree -> info Lwt.t +end diff --git a/src/lib_scoru_wasm/wasm_pvm.mli b/src/lib_scoru_wasm/wasm_pvm.mli new file mode 100644 index 000000000000..d0107273d308 --- /dev/null +++ b/src/lib_scoru_wasm/wasm_pvm.mli @@ -0,0 +1,78 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Represents the location of an input message. *) +type input_info = { + inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + (** The inbox level at which the message exists.*) + message_counter : Z.t; (** The index of the message in the inbox. *) +} + +(** Represents the location of an output message. *) +type output_info = { + outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + (** The outbox level at which the message exists.*) + message_index : Z.t; (** The index of the message in the outbox. *) +} + +(** Represents the state of input requests. *) +type input_request = + | No_input_required (** The VM does not expect any input. *) + | Input_required (** The VM needs input in order to progress. *) + +(** Represents the state of the VM. *) +type info = { + current_tick : Z.t; + (** The number of ticks processed by the VM, zero for the initial state. + [current_tick] must be incremented for each call to [step] *) + last_input_read : input_info option; + (** The last message to be read by the VM, if any. *) + input_request : input_request; (** The current VM input request. *) +} + +(** This module type defines a WASM VM API used for smart-contract rollups. *) +module type S = sig + type tree + + (** [compute_step] forwards the VM by one compute tick. If the VM is expecting + input, it gets stuck. If the VM is already stuck, this function may + raise an exception. *) + val compute_step : tree -> tree Lwt.t + + (** [set_input_step] forwards the VM by one input tick. If the VM is not + expecting input, it gets stuck. If the VM is already stuck, this function + may raise an exception. *) + val set_input_step : input_info -> string -> tree -> tree Lwt.t + + (** [get_output output state] returns the payload associated with the given + output. The result is meant to be deserialized using + [Sc_rollup_PVM_sem.output_encoding]. If the output is missing, this + function may raise an exception. *) + val get_output : output_info -> tree -> string Lwt.t + + (** [get_info] provides a typed view of the current machine state. Should not + raise. *) + val get_info : tree -> info Lwt.t +end -- GitLab From 3dbf6d6c81fc41e8dcc97631f60c46c7fa6f6a79 Mon Sep 17 00:00:00 2001 From: Thomas Letan Date: Fri, 8 Jul 2022 16:58:46 +0200 Subject: [PATCH 3/7] =?UTF-8?q?Scoru=5Fwasm:=20Do=20not=20shadow=20the=20l?= =?UTF-8?q?ibrary=E2=80=99s=20modules?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../environment_V6.ml | 5 +- src/lib_scoru_wasm/gather_floppies.ml | 6 +- src/lib_scoru_wasm/gather_floppies.mli | 8 +- src/lib_scoru_wasm/host_funcs.ml | 79 ++++++++++ src/lib_scoru_wasm/host_funcs.mli | 35 +++++ src/lib_scoru_wasm/test/test_scoru_wasm.ml | 4 +- src/lib_scoru_wasm/tezos_scoru_wasm.ml | 137 ------------------ src/lib_scoru_wasm/tezos_scoru_wasm.mli | 65 --------- src/lib_scoru_wasm/wasm_pvm.ml | 47 +++--- src/lib_scoru_wasm/wasm_pvm.mli | 55 +------ src/lib_scoru_wasm/wasm_pvm_sig.ml | 78 ++++++++++ 11 files changed, 233 insertions(+), 286 deletions(-) delete mode 100644 src/lib_scoru_wasm/tezos_scoru_wasm.ml delete mode 100644 src/lib_scoru_wasm/tezos_scoru_wasm.mli create mode 100644 src/lib_scoru_wasm/wasm_pvm_sig.ml diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 2efa5705b769..6e55e2df035b 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1126,7 +1126,7 @@ struct module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct - module Wasm = Tezos_scoru_wasm.Make (Tree) + module Wasm = Tezos_scoru_wasm.Wasm_pvm.Make (Tree) (* TODO: https://gitlab.com/tezos/tezos/-/issues/3214 The rest of the module is pure boilerplate converting between @@ -1142,7 +1142,8 @@ struct let get_output {outbox_level; message_index} (tree : Tree.tree) = Wasm.get_output {outbox_level; message_index} tree - let convert_input : Tezos_scoru_wasm.input_info -> input = function + let convert_input : Tezos_scoru_wasm.Wasm_pvm_sig.input_info -> input = + function | {inbox_level; message_counter} -> {inbox_level; message_counter} let get_info (tree : Tree.tree) = diff --git a/src/lib_scoru_wasm/gather_floppies.ml b/src/lib_scoru_wasm/gather_floppies.ml index 801f879fc5f5..84d434cd358e 100644 --- a/src/lib_scoru_wasm/gather_floppies.ml +++ b/src/lib_scoru_wasm/gather_floppies.ml @@ -35,15 +35,15 @@ exception Encoding_error of Data_encoding.Binary.write_error exception Malformed_input_info_record -module Make (T : Tree.S) (Wasm : Wasm_pvm.S with type tree = T.tree) : - Wasm_pvm.S with type tree = T.tree = struct +module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : + Wasm_pvm_sig.S with type tree = T.tree = struct type tree = Wasm.tree type 'a value = 'a Thunk.value module Thunk = Thunk.Make (T) module Decoding = Tree_decoding.Make (T) - include Wasm_pvm + open Wasm_pvm_sig (* TYPES *) diff --git a/src/lib_scoru_wasm/gather_floppies.mli b/src/lib_scoru_wasm/gather_floppies.mli index d02e282caee9..96813569af1a 100644 --- a/src/lib_scoru_wasm/gather_floppies.mli +++ b/src/lib_scoru_wasm/gather_floppies.mli @@ -27,11 +27,11 @@ incomplete kernel message. *) exception Malformed_origination_message of Data_encoding.Binary.read_error -(** Raised when a message containing a kernel image chunk was expected, but +(** Raised when a message containing a kernel image chunk was expected, but the message in the inbox contained something else. *) exception Malformed_inbox_message of Data_encoding.Binary.read_error -(** Raised when [compute_step] was called when the floppy gathering module +(** Raised when [compute_step] was called when the floppy gathering module expected input. *) exception Compute_step_expected_input @@ -51,5 +51,5 @@ exception Malformed_input_info_record image as either a complete kernel in the origination message or a kernel image divided into chunks and provided via both origination- and inbox- messages. *) -module Make (T : Tree.S) (Wasm : Wasm_pvm.S with type tree = T.tree) : - Wasm_pvm.S with type tree = T.tree +module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : + Wasm_pvm_sig.S with type tree = T.tree diff --git a/src/lib_scoru_wasm/host_funcs.ml b/src/lib_scoru_wasm/host_funcs.ml index 569ddad0d70f..556d24dbed65 100644 --- a/src/lib_scoru_wasm/host_funcs.ml +++ b/src/lib_scoru_wasm/host_funcs.ml @@ -23,5 +23,84 @@ (* *) (*****************************************************************************) +open Tezos_webassembly_interpreter +open Instance + let lookup name = Stdlib.failwith (Printf.sprintf "Unknown host function %s" name) + +exception Bad_input + +let aux_write_input_in_memory ~input_buffer ~module_inst ~rtype_offset + ~level_offset ~id_offset ~dst ~max_bytes = + let open Lwt.Syntax in + let memories = !module_inst.memories in + let* {rtype; raw_level; message_counter; payload} = + Input_buffer.dequeue input_buffer + in + let input_size = Bytes.length payload in + if Int64.of_int input_size > 4096L then + raise (Eval.Crash (Source.no_region, "input too large")) + else + let payload = + Bytes.sub payload 0 @@ min input_size (Int64.to_int max_bytes) + in + let* memory = + match Vector.num_elements memories with + | 1l -> Vector.get 0l memories + | _ -> + raise + (Eval.Crash + (Source.no_region, "the memories is supposed to be a singleton")) + in + + let _ = Memory.store_bytes memory dst (Bytes.to_string payload) in + let _ = Memory.store_num memory rtype_offset 0l (I32 rtype) in + let _ = Memory.store_num memory level_offset 0l (I32 raw_level) in + let _ = + Memory.store_num memory id_offset 0l (I64 (Z.to_int64 message_counter)) + in + Lwt.return input_size + +let read_input = + let open Lwt.Syntax in + let input_types = + Types. + [ + NumType I64Type; + NumType I64Type; + NumType I64Type; + NumType I64Type; + NumType I64Type; + ] + |> Vector.of_list + in + let output_types = Types.[NumType I32Type] |> Vector.of_list in + let fun_type = Types.FuncType (input_types, output_types) in + let f input_buffer module_inst inputs = + match inputs with + | [ + Values.(Num (I64 rtype_offset)); + Values.(Num (I64 level_offset)); + Values.(Num (I64 id_offset)); + Values.(Num (I64 dst)); + Values.(Num (I64 max_bytes)); + ] -> + let* x = + aux_write_input_in_memory + ~input_buffer + ~module_inst + ~rtype_offset + ~level_offset + ~id_offset + ~dst + ~max_bytes + in + Lwt.return [Values.(Num (I32 (I32.of_int_s x)))] + | _ -> raise Bad_input + in + Func.HostFunc (fun_type, f) + +module Internal_for_tests = struct + let aux_write_input_in_memory = aux_write_input_in_memory +end diff --git a/src/lib_scoru_wasm/host_funcs.mli b/src/lib_scoru_wasm/host_funcs.mli index 099b34fb1bfa..9f89d0f001fd 100644 --- a/src/lib_scoru_wasm/host_funcs.mli +++ b/src/lib_scoru_wasm/host_funcs.mli @@ -26,3 +26,38 @@ (** [lookup name] retrieves or instantiates a host function by the given [name]. *) val lookup : string -> ('input, 'inst) Tezos_webassembly_interpreter.Func.t + +exception Bad_input + +(** [read_input] is a host function. It has to be invoked with a list + of 5 values representing rtype_offset, level_offset, id_offset, + dst and max_bytes, otherwise it raises the [Bad_input] exception. + + When invoked, it write the content of an input message into the + memory of a [module_inst]. It also checks that the input payload + is no larger than the input is not too large. Finally, it returns + returns a singleton value list containing the size of the + input_buffer payload. *) +val read_input : + ( Tezos_webassembly_interpreter.Input_buffer.t, + Tezos_webassembly_interpreter.Instance.module_inst ref ) + Tezos_webassembly_interpreter.Func.func + +module Internal_for_tests : sig + (** [aux_write_memory ~input_buffer ~module_inst ~rtype_offset + ~level_offset ~id_offset ~dst ~max_bytes] reads `input_buffer` + and writes its components to the memory of `module_inst` based + on the memory addreses offsets described. It also checks that + the input payload is no larger than `max_input` and crashes + with `input too large` otherwise. It returns the size of the + payload.*) + val aux_write_input_in_memory : + input_buffer:Tezos_webassembly_interpreter.Input_buffer.t -> + module_inst:Tezos_webassembly_interpreter.Instance.module_inst ref -> + rtype_offset:int64 -> + level_offset:int64 -> + id_offset:int64 -> + dst:int64 -> + max_bytes:int64 -> + int Lwt.t +end diff --git a/src/lib_scoru_wasm/test/test_scoru_wasm.ml b/src/lib_scoru_wasm/test/test_scoru_wasm.ml index cd315027af29..48987a58a0e3 100644 --- a/src/lib_scoru_wasm/test/test_scoru_wasm.ml +++ b/src/lib_scoru_wasm/test/test_scoru_wasm.ml @@ -70,7 +70,7 @@ let read_input () = in module_inst := {!module_inst with memories} ; let* result = - aux_write_input_in_memory + Host_funcs.Internal_for_tests.aux_write_input_in_memory ~input_buffer ~module_inst ~rtype_offset:0L @@ -121,7 +121,7 @@ let test_host_fun () = ] in let* module_inst, result = - Eval.invoke ~module_inst ~input Tezos_scoru_wasm.read_input values + Eval.invoke ~module_inst ~input Host_funcs.read_input values in let* memory = Tezos_webassembly_interpreter.Lazy_vector.LwtInt32Vector.get diff --git a/src/lib_scoru_wasm/tezos_scoru_wasm.ml b/src/lib_scoru_wasm/tezos_scoru_wasm.ml deleted file mode 100644 index e552afb80bc7..000000000000 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.ml +++ /dev/null @@ -1,137 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 TriliTech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Tezos_webassembly_interpreter -open Instance - -(* - - This library acts as a dependency to the protocol environment. Everything that - must be exposed to the protocol via the environment shall be added here. - -*) - -include Wasm_pvm - -module Make (T : Tree.S) : S with type tree = T.tree = struct - type tree = T.tree - - module Decodings = Wasm_decodings.Make (T) - - let compute_step = Lwt.return - - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3092 - Implement handling of input logic. - *) - let set_input_step _ _ = Lwt.return - - let get_output _ _ = Lwt.return "" - - let get_info _ = - Lwt.return - { - current_tick = Z.of_int 0; - last_input_read = None; - input_request = No_input_required; - } - - let _module_instance_of_tree modules = - Decodings.run (Decodings.module_instance_decoding modules) - - let _module_instances_of_tree = - Decodings.run Decodings.module_instances_decoding -end - -exception Bad_input - -let aux_write_input_in_memory ~input_buffer ~module_inst ~rtype_offset - ~level_offset ~id_offset ~dst ~max_bytes = - let open Lwt.Syntax in - let memories = !module_inst.memories in - let* {rtype; raw_level; message_counter; payload} = - Input_buffer.dequeue input_buffer - in - let input_size = Bytes.length payload in - if Int64.of_int input_size > 4096L then - raise (Eval.Crash (Source.no_region, "input too large")) - else - let payload = - Bytes.sub payload 0 @@ min input_size (Int64.to_int max_bytes) - in - let* memory = - match Vector.num_elements memories with - | 1l -> Vector.get 0l memories - | _ -> - raise - (Eval.Crash - (Source.no_region, "the memories is supposed to be a singleton")) - in - - let _ = Memory.store_bytes memory dst (Bytes.to_string payload) in - let _ = Memory.store_num memory rtype_offset 0l (I32 rtype) in - let _ = Memory.store_num memory level_offset 0l (I32 raw_level) in - let _ = - Memory.store_num memory id_offset 0l (I64 (Z.to_int64 message_counter)) - in - Lwt.return input_size - -let read_input = - let open Lwt.Syntax in - let input_types = - Types. - [ - NumType I64Type; - NumType I64Type; - NumType I64Type; - NumType I64Type; - NumType I64Type; - ] - |> Vector.of_list - in - let output_types = Types.[NumType I32Type] |> Vector.of_list in - let fun_type = Types.FuncType (input_types, output_types) in - let f input_buffer module_inst inputs = - match inputs with - | [ - Values.(Num (I64 rtype_offset)); - Values.(Num (I64 level_offset)); - Values.(Num (I64 id_offset)); - Values.(Num (I64 dst)); - Values.(Num (I64 max_bytes)); - ] -> - let* x = - aux_write_input_in_memory - ~input_buffer - ~module_inst - ~rtype_offset - ~level_offset - ~id_offset - ~dst - ~max_bytes - in - Lwt.return [Values.(Num (I32 (I32.of_int_s x)))] - | _ -> raise Bad_input - in - Func.HostFunc (fun_type, f) diff --git a/src/lib_scoru_wasm/tezos_scoru_wasm.mli b/src/lib_scoru_wasm/tezos_scoru_wasm.mli deleted file mode 100644 index b1c6fcd1f76d..000000000000 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.mli +++ /dev/null @@ -1,65 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 TriliTech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** This module exposes a module type {!S} defining a WASM VM API. - It also exposes a functor {!Make} for constructing a concrete implementation - of this module type, given an implementation of a {!Tree.S} module. - - This library acts as a dependency to the protocol environment. Everything - WASM VM related that must be exposed to the protocol via the environment - shall be added here. *) - -include module type of Wasm_pvm - -(** Builds a WASM VM given a concrete implementation of {!Tree.S}. *) -module Make (T : Tree.S) : Wasm_pvm.S with type tree = T.tree - -exception Bad_input - -(** [aux_write_memory ~input_buffer ~module_inst ~rtype_offset ~level_offset - ~id_offset ~dst ~max_bytes] - reads `input_buffer` and writes its components to the memory of - `module_inst` based on the memory addreses offsets described. It also - checks that the input payload is no larger than `max_input` and crashes - with `input too large` otherwise. It returns the size of the payload.*) -val aux_write_input_in_memory : - input_buffer:Tezos_webassembly_interpreter.Input_buffer.t -> - module_inst:Tezos_webassembly_interpreter.Instance.module_inst ref -> - rtype_offset:int64 -> - level_offset:int64 -> - id_offset:int64 -> - dst:int64 -> - max_bytes:int64 -> - int Lwt.t - -(** read_input is a HostFunction. It has to be invoked with a list of 5 values - representing rtype_offset, level_offset, id_offset, dst and max_bytes. When - invoked, it applies `aux_write_input_in_memory` with the corresponding - parameters and returns a singleton value list containing the size of the - input_buffer payload. *) -val read_input : - ( Tezos_webassembly_interpreter.Input_buffer.t, - Tezos_webassembly_interpreter.Instance.module_inst ref ) - Tezos_webassembly_interpreter.Func.func diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml index 3667e354aaef..29a797ff3c8f 100644 --- a/src/lib_scoru_wasm/wasm_pvm.ml +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -23,32 +23,39 @@ (* *) (*****************************************************************************) -type input_info = { - inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - message_counter : Z.t; -} +(* -type output_info = { - outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - message_index : Z.t; -} + This library acts as a dependency to the protocol environment. Everything that + must be exposed to the protocol via the environment shall be added here. -type input_request = No_input_required | Input_required +*) -type info = { - current_tick : Z.t; - last_input_read : input_info option; - input_request : input_request; (** The current VM input request. *) -} +module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree = struct + type tree = T.tree -module type S = sig - type tree + module Decodings = Wasm_decodings.Make (T) - val compute_step : tree -> tree Lwt.t + let compute_step = Lwt.return - val set_input_step : input_info -> string -> tree -> tree Lwt.t + (* TODO: https://gitlab.com/tezos/tezos/-/issues/3092 + Implement handling of input logic. + *) + let set_input_step _ _ = Lwt.return - val get_output : output_info -> tree -> string Lwt.t + let get_output _ _ = Lwt.return "" - val get_info : tree -> info Lwt.t + let get_info _ = + Lwt.return + Wasm_pvm_sig. + { + current_tick = Z.of_int 0; + last_input_read = None; + input_request = No_input_required; + } + + let _module_instance_of_tree modules = + Decodings.run (Decodings.module_instance_decoding modules) + + let _module_instances_of_tree = + Decodings.run Decodings.module_instances_decoding end diff --git a/src/lib_scoru_wasm/wasm_pvm.mli b/src/lib_scoru_wasm/wasm_pvm.mli index d0107273d308..879d1de5ffdc 100644 --- a/src/lib_scoru_wasm/wasm_pvm.mli +++ b/src/lib_scoru_wasm/wasm_pvm.mli @@ -23,56 +23,5 @@ (* *) (*****************************************************************************) -(** Represents the location of an input message. *) -type input_info = { - inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - (** The inbox level at which the message exists.*) - message_counter : Z.t; (** The index of the message in the inbox. *) -} - -(** Represents the location of an output message. *) -type output_info = { - outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; - (** The outbox level at which the message exists.*) - message_index : Z.t; (** The index of the message in the outbox. *) -} - -(** Represents the state of input requests. *) -type input_request = - | No_input_required (** The VM does not expect any input. *) - | Input_required (** The VM needs input in order to progress. *) - -(** Represents the state of the VM. *) -type info = { - current_tick : Z.t; - (** The number of ticks processed by the VM, zero for the initial state. - [current_tick] must be incremented for each call to [step] *) - last_input_read : input_info option; - (** The last message to be read by the VM, if any. *) - input_request : input_request; (** The current VM input request. *) -} - -(** This module type defines a WASM VM API used for smart-contract rollups. *) -module type S = sig - type tree - - (** [compute_step] forwards the VM by one compute tick. If the VM is expecting - input, it gets stuck. If the VM is already stuck, this function may - raise an exception. *) - val compute_step : tree -> tree Lwt.t - - (** [set_input_step] forwards the VM by one input tick. If the VM is not - expecting input, it gets stuck. If the VM is already stuck, this function - may raise an exception. *) - val set_input_step : input_info -> string -> tree -> tree Lwt.t - - (** [get_output output state] returns the payload associated with the given - output. The result is meant to be deserialized using - [Sc_rollup_PVM_sem.output_encoding]. If the output is missing, this - function may raise an exception. *) - val get_output : output_info -> tree -> string Lwt.t - - (** [get_info] provides a typed view of the current machine state. Should not - raise. *) - val get_info : tree -> info Lwt.t -end +(** Builds a WASM VM given a concrete implementation of {!Tree.S}. *) +module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree diff --git a/src/lib_scoru_wasm/wasm_pvm_sig.ml b/src/lib_scoru_wasm/wasm_pvm_sig.ml new file mode 100644 index 000000000000..d0107273d308 --- /dev/null +++ b/src/lib_scoru_wasm/wasm_pvm_sig.ml @@ -0,0 +1,78 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Represents the location of an input message. *) +type input_info = { + inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + (** The inbox level at which the message exists.*) + message_counter : Z.t; (** The index of the message in the inbox. *) +} + +(** Represents the location of an output message. *) +type output_info = { + outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + (** The outbox level at which the message exists.*) + message_index : Z.t; (** The index of the message in the outbox. *) +} + +(** Represents the state of input requests. *) +type input_request = + | No_input_required (** The VM does not expect any input. *) + | Input_required (** The VM needs input in order to progress. *) + +(** Represents the state of the VM. *) +type info = { + current_tick : Z.t; + (** The number of ticks processed by the VM, zero for the initial state. + [current_tick] must be incremented for each call to [step] *) + last_input_read : input_info option; + (** The last message to be read by the VM, if any. *) + input_request : input_request; (** The current VM input request. *) +} + +(** This module type defines a WASM VM API used for smart-contract rollups. *) +module type S = sig + type tree + + (** [compute_step] forwards the VM by one compute tick. If the VM is expecting + input, it gets stuck. If the VM is already stuck, this function may + raise an exception. *) + val compute_step : tree -> tree Lwt.t + + (** [set_input_step] forwards the VM by one input tick. If the VM is not + expecting input, it gets stuck. If the VM is already stuck, this function + may raise an exception. *) + val set_input_step : input_info -> string -> tree -> tree Lwt.t + + (** [get_output output state] returns the payload associated with the given + output. The result is meant to be deserialized using + [Sc_rollup_PVM_sem.output_encoding]. If the output is missing, this + function may raise an exception. *) + val get_output : output_info -> tree -> string Lwt.t + + (** [get_info] provides a typed view of the current machine state. Should not + raise. *) + val get_info : tree -> info Lwt.t +end -- GitLab From e993a5cc9764198873afa23129b4b9e942b54c59 Mon Sep 17 00:00:00 2001 From: Thomas Letan Date: Sat, 2 Jul 2022 16:30:24 +0200 Subject: [PATCH 4/7] Scoru_wasm: Instrument the WASM PVM to gather floppies --- src/lib_scoru_wasm/wasm_pvm.ml | 45 ++++++++++--------- .../lib_protocol/sc_rollup_wasm.ml | 5 ++- 2 files changed, 29 insertions(+), 21 deletions(-) diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml index 29a797ff3c8f..f0ef2ead0084 100644 --- a/src/lib_scoru_wasm/wasm_pvm.ml +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -31,31 +31,36 @@ *) module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree = struct - type tree = T.tree + include + Gather_floppies.Make + (T) + (struct + type tree = T.tree - module Decodings = Wasm_decodings.Make (T) + module Decodings = Wasm_decodings.Make (T) - let compute_step = Lwt.return + let compute_step = Lwt.return - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3092 - Implement handling of input logic. - *) - let set_input_step _ _ = Lwt.return + (* TODO: https://gitlab.com/tezos/tezos/-/issues/3092 + Implement handling of input logic. + *) + let set_input_step _ _ = Lwt.return - let get_output _ _ = Lwt.return "" + let get_output _ _ = Lwt.return "" - let get_info _ = - Lwt.return - Wasm_pvm_sig. - { - current_tick = Z.of_int 0; - last_input_read = None; - input_request = No_input_required; - } + let get_info _ = + Lwt.return + Wasm_pvm_sig. + { + current_tick = Z.of_int 0; + last_input_read = None; + input_request = No_input_required; + } - let _module_instance_of_tree modules = - Decodings.run (Decodings.module_instance_decoding modules) + let _module_instance_of_tree modules = + Decodings.run (Decodings.module_instance_decoding modules) - let _module_instances_of_tree = - Decodings.run Decodings.module_instances_decoding + let _module_instances_of_tree = + Decodings.run Decodings.module_instances_decoding + end) end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index bbdf77cc7ce5..52f64e3834fc 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -211,7 +211,10 @@ module V2_0_0 = struct Lwt.return state let install_boot_sector state boot_sector = - Tree.add state ["boot-sector"] (Bytes.of_string boot_sector) + Tree.add + state + ["boot-sector"] + Data_encoding.(Binary.to_bytes_exn string boot_sector) let state_hash state = let context_hash = Tree.hash state in -- GitLab From 1c409f2b19f6916adc70b43115211e19c2165c25 Mon Sep 17 00:00:00 2001 From: Thomas Letan Date: Mon, 11 Jul 2022 11:12:10 +0200 Subject: [PATCH 5/7] Scoru_wasm,tests: Test the gathering floppies instrumentation --- src/lib_scoru_wasm/gather_floppies.ml | 150 +++++------ src/lib_scoru_wasm/gather_floppies.mli | 23 ++ src/lib_scoru_wasm/wasm_pvm_sig.ml | 11 + .../test/integration/test_sc_rollup_wasm.ml | 246 +++++++++++++++++- .../test/unit/test_sc_rollup_wasm.ml | 25 ++ 5 files changed, 371 insertions(+), 84 deletions(-) diff --git a/src/lib_scoru_wasm/gather_floppies.ml b/src/lib_scoru_wasm/gather_floppies.ml index 84d434cd358e..63309048ab97 100644 --- a/src/lib_scoru_wasm/gather_floppies.ml +++ b/src/lib_scoru_wasm/gather_floppies.ml @@ -23,6 +23,10 @@ (* *) (*****************************************************************************) +open Wasm_pvm_sig + +let chunk_size = 4_000 + exception Malformed_origination_message of Data_encoding.Binary.read_error exception Malformed_inbox_message of Data_encoding.Binary.read_error @@ -35,81 +39,68 @@ exception Encoding_error of Data_encoding.Binary.write_error exception Malformed_input_info_record -module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : - Wasm_pvm_sig.S with type tree = T.tree = struct - type tree = Wasm.tree +type internal_status = Gathering_floppies | Not_gathering_floppies - type 'a value = 'a Thunk.value +let internal_status_encoding = + Data_encoding.string_enum + [ + ("GatheringFloppies", Gathering_floppies); + ("NotGatheringFloppies", Not_gathering_floppies); + ] - module Thunk = Thunk.Make (T) - module Decoding = Tree_decoding.Make (T) - open Wasm_pvm_sig +(* An at most 4,096-byte fragment of a kernel. *) +type chunk = bytes - (* TYPES *) +let chunk_encoding = Data_encoding.Bounded.bytes chunk_size - type internal_status = Gathering_floppies | Not_gathering_floppies +type floppy = {chunk : chunk; signature : Tezos_crypto.Signature.t} - let internal_status_encoding = - Data_encoding.string_enum - [ - ("GatheringFloppies", Gathering_floppies); - ("NotGatheringFloppies", Not_gathering_floppies); - ] +let floppy_encoding = + Data_encoding.( + conv + (fun {chunk; signature} -> (chunk, signature)) + (fun (chunk, signature) -> {chunk; signature}) + (obj2 + (req "chunk" chunk_encoding) + (req "signature" Tezos_crypto.Signature.encoding))) + +(* Encoding for message in "boot sector" *) +type origination_message = + | Complete_kernel of bytes + | Incomplete_kernel of chunk * Tezos_crypto.Signature.Public_key.t + +let origination_message_encoding = + let open Data_encoding in + union + [ + case + ~title:"complete" + (Tag 0) + (obj1 @@ req "complete_kernel" bytes) + (function Complete_kernel s -> Some s | _ -> None) + (fun s -> Complete_kernel s); + case + ~title:"incomplete" + (Tag 1) + (obj2 + (req "first_chunk" chunk_encoding) + (req "public_key" Tezos_crypto.Signature.Public_key.encoding)) + (function Incomplete_kernel (s, pk) -> Some (s, pk) | _ -> None) + (fun (s, pk) -> Incomplete_kernel (s, pk)); + ] - (* An at most 4,096-byte fragment of a kernel. *) - type chunk = bytes +(* STORAGE KEYS *) - let chunk_encoding = Data_encoding.Bounded.bytes 4_096 +module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : + Wasm_pvm_sig.S with type tree = T.tree = struct + type tree = Wasm.tree - type floppy = {chunk : chunk; signature : Tezos_crypto.Signature.t} + type 'a value = 'a Thunk.value - let floppy_encoding = - Data_encoding.( - conv - (fun {chunk; signature} -> (chunk, signature)) - (fun (chunk, signature) -> {chunk; signature}) - (obj2 - (req "chunk" chunk_encoding) - (req "signature" Tezos_crypto.Signature.encoding))) - - (* Encoding for message in "boot sector" *) - type origination_message = - | Complete_kernel of bytes - | Incomplete_kernel of chunk * Tezos_crypto.Signature.Public_key.t - - let boot_sector_encoding = - let open Data_encoding in - union - [ - case - ~title:"complete" - (Tag 0) - (obj1 @@ req "complete_kernel" chunk_encoding) - (function Complete_kernel s -> Some s | _ -> None) - (fun s -> Complete_kernel s); - case - ~title:"incomplete" - (Tag 1) - (obj2 - (req "first_chunk" chunk_encoding) - (req "public_key" Tezos_crypto.Signature.Public_key.encoding)) - (function Incomplete_kernel (s, pk) -> Some (s, pk) | _ -> None) - (fun (s, pk) -> Incomplete_kernel (s, pk)); - ] - - let input_encoding = - let open Data_encoding in - conv - (fun {inbox_level; message_counter} -> - ( Tezos_base.Bounded.Int32.NonNegative.to_int32 inbox_level, - message_counter )) - (fun (inbox_level, message_counter) -> - match Tezos_base.Bounded.Int32.NonNegative.of_int32 inbox_level with - | Some v -> {inbox_level = v; message_counter} - | None -> raise Malformed_input_info_record) - (tup2 int32 z) + module Thunk = Thunk.Make (T) + module Decoding = Tree_decoding.Make (T) - (* STORAGE KEYS *) + (* TYPES *) type state = (internal_status value * Tezos_crypto.Signature.Public_key.t value) @@ -131,7 +122,7 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : (req "public-key" @@ encoding Tezos_crypto.Signature.Public_key.encoding))) (req "boot-sector" @@ encoding Data_encoding.string) - (req "last-input-info" @@ encoding input_encoding) + (req "last-input-info" @@ encoding input_info_encoding) (req "internal-loading-kernel-tick" @@ encoding Data_encoding.n) (req "durable" @@ folders ["kernel"; "boot.wasm"] @@ -175,12 +166,12 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : let len = Bytes.length bytes in let* chunks = state ^-> chunks_l in if len = 0 then return () - else if len < 4_096 then + else if len < chunk_size then let* _ = Thunk.Lazy_list.cons chunks bytes in return () else - let chunk = Bytes.sub bytes 0 4_096 in - let rst = Bytes.sub bytes 4_096 (len - 4_096) in + let chunk = Bytes.sub bytes 0 chunk_size in + let rst = Bytes.sub bytes chunk_size (len - chunk_size) in let* _ = Thunk.Lazy_list.cons chunks chunk in aux rst in @@ -209,14 +200,16 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : let* () = increment_ticks state in let*^ boot_sector = state ^-> boot_sector_l in let boot_sector = - Data_encoding.Binary.of_string_opt boot_sector_encoding boot_sector + Data_encoding.Binary.of_string_opt + origination_message_encoding + boot_sector in match boot_sector with | Some (Complete_kernel kernel) -> let* () = store_bytes state kernel in (state ^-> status_l) ^:= Not_gathering_floppies - | Some (Incomplete_kernel (chunk, _boot_pk)) when Bytes.length chunk = 4_096 - -> + | Some (Incomplete_kernel (chunk, _boot_pk)) + when Bytes.length chunk < chunk_size -> (* Despite claiming the boot sector is not a complete kernel, it is not large enough to fill a chunk. *) let* () = store_chunk state chunk in @@ -237,16 +230,23 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : let open Thunk.Syntax in let* () = (state ^-> last_input_info_l) ^:= input in let* () = increment_ticks state in - match Data_encoding.Binary.of_string floppy_encoding message with + (* TODO: check that the first byte of [message] is 0x01 (External). *) + match + Data_encoding.Binary.read + floppy_encoding + message + 1 + (String.length message - 1) + with | Error error -> raise (Malformed_inbox_message error) - | Ok {chunk; signature} -> + | Ok (_, {chunk; signature}) -> let* check = check_signature chunk signature state in if check then let* () = if 0 < Bytes.length chunk then store_chunk state chunk else return () in - if Bytes.length chunk < 4_096 then + if Bytes.length chunk < chunk_size then (state ^-> status_l) ^:= Not_gathering_floppies else return () else return () diff --git a/src/lib_scoru_wasm/gather_floppies.mli b/src/lib_scoru_wasm/gather_floppies.mli index 96813569af1a..5af9e72ba01d 100644 --- a/src/lib_scoru_wasm/gather_floppies.mli +++ b/src/lib_scoru_wasm/gather_floppies.mli @@ -47,6 +47,29 @@ exception Encoding_error of Data_encoding.Binary.write_error gets overwritten with something malformed. *) exception Malformed_input_info_record +(** The instrumented PVM is either in a pre-boot state + ([Gathering_floppies]), or in its regular functioning state + ([Not_gathering_floppies]). *) +type internal_status = Gathering_floppies | Not_gathering_floppies + +val internal_status_encoding : internal_status Data_encoding.t + +type chunk = bytes + +val chunk_size : int + +val chunk_encoding : chunk Data_encoding.t + +type floppy = {chunk : chunk; signature : Tezos_crypto.Signature.t} + +val floppy_encoding : floppy Data_encoding.t + +type origination_message = + | Complete_kernel of chunk + | Incomplete_kernel of chunk * Tezos_crypto.Signature.Public_key.t + +val origination_message_encoding : origination_message Data_encoding.t + (** [Make] encapsulates a WASM PVM to give it the ability to load a kernel image as either a complete kernel in the origination message or a kernel image divided into chunks and provided via both origination- and inbox- diff --git a/src/lib_scoru_wasm/wasm_pvm_sig.ml b/src/lib_scoru_wasm/wasm_pvm_sig.ml index d0107273d308..1d96e3c91c53 100644 --- a/src/lib_scoru_wasm/wasm_pvm_sig.ml +++ b/src/lib_scoru_wasm/wasm_pvm_sig.ml @@ -76,3 +76,14 @@ module type S = sig raise. *) val get_info : tree -> info Lwt.t end + +(* Encodings *) + +let input_info_encoding = + let open Data_encoding in + conv + (fun {inbox_level; message_counter} -> (inbox_level, message_counter)) + (fun (inbox_level, message_counter) -> {inbox_level; message_counter}) + (obj2 + (req "inbox_level" Tezos_base.Bounded.Int32.NonNegative.encoding) + (req "message_counter" n)) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml index 4c250a82041c..fb2f2f21ee66 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml @@ -108,20 +108,248 @@ end module Verifier = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.ProtocolImplementation module Prover = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.Make (WASM_P) +(* Helpers *) -let should_boot () = +let complete_boot_sector sector : + Tezos_scoru_wasm.Gather_floppies.origination_message = + Complete_kernel (Bytes.of_string sector) + +let incomplete_boot_sector sector Account.{pk; _} : + Tezos_scoru_wasm.Gather_floppies.origination_message = + Incomplete_kernel (Bytes.of_string sector, pk) + +let find tree key encoding = + let open Lwt.Syntax in + let+ value = Context_binary.Tree.find tree key in + match value with + | Some bytes -> Some (Data_encoding.Binary.of_bytes_exn encoding bytes) + | None -> None + +let find_status tree = + find + tree + ["pvm"; "status"] + Tezos_scoru_wasm.Gather_floppies.internal_status_encoding + +let get_chunks_count tree = + let open Lwt.Syntax in + let+ len = + find tree ["durable"; "kernel"; "boot.wasm"; "len"] Data_encoding.int32 + in + Option.value ~default:0l len + +let check_status tree expected = + let open Lwt.Syntax in + let* status = find_status tree in + match (status, expected) with + | Some status, Some expected -> + assert (status = expected) ; + Lwt.return () + | None, None -> Lwt.return () + | _, _ -> assert false + +let check_chunks_count tree expected = + let open Lwt.Syntax in + let* count = get_chunks_count tree in + if count = expected then Lwt_result.return () + else + failwith + "wrong chunks counter, expected %d, got %d" + (Int32.to_int expected) + (Int32.to_int count) + +let operator () = + match Account.generate_accounts 1 with + | [(account, _, _)] -> account + | _ -> assert false + +let should_boot_complete_boot_sector boot_sector () = + let open Tezos_scoru_wasm.Gather_floppies in let open Lwt_result_syntax in let*! index = Context_binary.init "/tmp" in let context = Context_binary.empty index in + (* The number of chunks necessary to store the kernel. *) + let nb_chunk_i32 = + match boot_sector with + | Complete_kernel bytes | Incomplete_kernel (bytes, _) -> + let len = Bytes.length bytes |> Int32.of_int in + let empty = if 0l < Int32.rem len 4_000l then 1l else 0l in + Int32.(add (div len 4_000l) empty) + in + let boot_sector = + Data_encoding.Binary.to_string_exn origination_message_encoding boot_sector + in + (* We create a new PVM, and install the boot sector. *) let*! s = Prover.initial_state context in - let*! s = Prover.install_boot_sector s "" in + let*! s = Prover.install_boot_sector s boot_sector in + (* After this first step, the PVM has just loaded the boot sector in + "/boot-sector", and nothing more. As a consequence, most of the + step of the [Gather_floppies] instrumentation is not set. *) + let*! () = check_status s None in + let* () = check_chunks_count s 0l in + (* At this step, the [eval] function of the PVM will interpret the + origination message encoded in [boot_sector]. *) let*! s = Prover.eval s in - let*! p_res = Prover.produce_proof context None s in - match p_res with - | Ok proof -> - let*! is_correct = Verifier.verify_proof proof in - if is_correct then return_unit else Stdlib.failwith "incorrect proof" + (* We expect that the WASM does not expect more floppies, and that + the kernel as been correctly splitted into several chunks. *) + let*! () = check_status s (Some Not_gathering_floppies) in + let* () = check_chunks_count s nb_chunk_i32 in + return_unit + +let floppy_input i operator chunk = + let open Lwt_result_syntax in + let signature = Signature.sign operator.Account.sk chunk in + let floppy = Tezos_scoru_wasm.Gather_floppies.{chunk; signature} in + match + Sc_rollup.Inbox.Message.serialize + (External + (Data_encoding.Binary.to_string_exn + Tezos_scoru_wasm.Gather_floppies.floppy_encoding + floppy)) + with + | Ok payload -> + return + Sc_rollup. + { + inbox_level = Raw_level.of_int32_exn 0l; + message_counter = Z.of_int i; + payload; + } | Error err -> - failwith "Could not produce a proof %a" Environment.Error_monad.pp err + Format.printf "%a@," Environment.Error_monad.pp_trace err ; + assert false + +let should_interpret_empty_chunk () = + let open Lwt_result_syntax in + let op = operator () in + let chunk_size = Tezos_scoru_wasm.Gather_floppies.chunk_size in + let origination_message = + Data_encoding.Binary.to_string_exn + Tezos_scoru_wasm__Gather_floppies.origination_message_encoding + @@ incomplete_boot_sector (String.make chunk_size 'a') op + in + let chunk = Bytes.empty in + let* correct_input = floppy_input 0 op chunk in + + (* Init the PVM *) + let*! index = Context_binary.init "/tmp" in + let context = Context_binary.empty index in + let*! s = Prover.initial_state context in + let*! s = Prover.install_boot_sector s origination_message in + (* Intererptation of the origination message *) + let*! s = Prover.eval s in + let*! () = check_status s (Some Gathering_floppies) in + let* () = check_chunks_count s 1l in + (* Try to interpret the empty input (correctly signed) *) + let*! s = Prover.set_input correct_input s in + let*! () = check_status s (Some Not_gathering_floppies) in + (* We still have 1 chunk. *) + let* () = check_chunks_count s 1l in + return_unit + +let should_refuse_chunks_with_incorrect_signature () = + let open Lwt_result_syntax in + let good_op = operator () in + let bad_op = operator () in + let chunk_size = Tezos_scoru_wasm.Gather_floppies.chunk_size in + let origination_message = + Data_encoding.Binary.to_string_exn + Tezos_scoru_wasm__Gather_floppies.origination_message_encoding + @@ incomplete_boot_sector (String.make chunk_size 'a') good_op + in + let chunk = Bytes.make chunk_size 'b' in + let* incorrect_input = floppy_input 0 bad_op chunk in + let* correct_input = floppy_input 0 good_op chunk in + + (* Init the PVM *) + let*! index = Context_binary.init "/tmp" in + let context = Context_binary.empty index in + let*! s = Prover.initial_state context in + let*! s = Prover.install_boot_sector s origination_message in + (* Intererptation of the origination message *) + let*! s = Prover.eval s in + let*! () = check_status s (Some Gathering_floppies) in + let* () = check_chunks_count s 1l in + (* Try to interpret the incorrect input (badly signed) *) + let*! s = Prover.set_input incorrect_input s in + let*! () = check_status s (Some Gathering_floppies) in + (* We still have 1 chunk. *) + let* () = check_chunks_count s 1l in + (* Try to interpret the correct input (correctly signed) *) + let*! s = Prover.set_input correct_input s in + let*! () = check_status s (Some Gathering_floppies) in + (* We now have 2 chunks. *) + let* () = check_chunks_count s 2l in + return_unit + +let should_boot_incomplete_boot_sector () = + let open Lwt_result_syntax in + let operator = operator () in + let chunk_size = Tezos_scoru_wasm.Gather_floppies.chunk_size in + let initial_chunk = + Data_encoding.Binary.to_string_exn + Tezos_scoru_wasm__Gather_floppies.origination_message_encoding + @@ incomplete_boot_sector (String.make chunk_size 'a') operator + in + let chunks = [Bytes.make chunk_size 'b'; Bytes.make chunk_size 'c'] in + let final_chunk = Bytes.make 2 'd' in + + let*! index = Context_binary.init "/tmp" in + let context = Context_binary.empty index in + let*! s = Prover.initial_state context in + let*! s = Prover.install_boot_sector s initial_chunk in + let*! () = check_status s None in + let* () = check_chunks_count s 0l in + (* First tick, to interpret the boot sector. One chunk have been + provided, and the PVM expects more chunk to come. *) + let*! s = Prover.eval s in + let*! () = check_status s (Some Gathering_floppies) in + let* () = check_chunks_count s 1l in + (* Then, installing the additional chunks. *) + let* s = + List.fold_left_i_es + (fun i s chunk -> + (* We are installing the [i+2]th chunk ([i] starts at 0, and + the first chunk is not part of the list). *) + let* input = floppy_input i operator chunk in + let*! s = Prover.set_input input s in + (* We are still gathering floppies. *) + let*! () = check_status s (Some Gathering_floppies) in + (* We have [i+2] chunks. *) + let* () = check_chunks_count s Int32.(of_int @@ (i + 2)) in + return s) + s + chunks + in + (* Up until the very last one, where the status of the PVM change. *) + let len = List.length chunks in + let* input = floppy_input len operator final_chunk in + let*! s = Prover.set_input input s in + let*! () = check_status s (Some Not_gathering_floppies) in + let* () = check_chunks_count s Int32.(of_int @@ (len + 2)) in + return_unit -let tests = [Tztest.tztest "should boot" `Quick should_boot] +let tests = + [ + Tztest.tztest "should boot a complete boot sector" `Quick + @@ should_boot_complete_boot_sector + (complete_boot_sector @@ String.make 10_000 'a'); + ( Tztest.tztest "should boot an incomplete but too small boot sector" `Quick + @@ fun () -> + let operator = operator () in + should_boot_complete_boot_sector + (incomplete_boot_sector "a nice boot sector" operator) + () ); + Tztest.tztest + "should boot an incomplete boot sector with floppies" + `Quick + should_boot_incomplete_boot_sector; + Tztest.tztest + "should interpret an empty chunk as EOF" + `Quick + should_interpret_empty_chunk; + Tztest.tztest + "should refuse chunks with an incorrect signature" + `Quick + should_refuse_chunks_with_incorrect_signature; + ] diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_wasm.ml index 07cd4db6d0f9..0630ecc37e0d 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_wasm.ml @@ -51,10 +51,35 @@ let test_initial_state_hash_wasm_pvm () = Sc_rollup.State_hash.pp hash +let test_incomplete_kernel_chunk_limit () = + let open Lwt_result_syntax in + let operator = + match Account.generate_accounts 1 with + | [(account, _, _)] -> account + | _ -> assert false + in + let chunk_size = Tezos_scoru_wasm.Gather_floppies.chunk_size in + let chunk_too_big = Bytes.make (chunk_size + 10) 'a' in + let signature = Signature.sign operator.Account.sk chunk_too_big in + let floppy = + Tezos_scoru_wasm.Gather_floppies.{chunk = chunk_too_big; signature} + in + match + Data_encoding.Binary.to_string_opt + Tezos_scoru_wasm.Gather_floppies.floppy_encoding + floppy + with + | None -> return_unit + | Some _ -> failwith "encoding of a floppy with a chunk too large should fail" + let tests = [ Tztest.tztest "initial state hash for Wasm" `Quick test_initial_state_hash_wasm_pvm; + Tztest.tztest + "encoding of a floppy with a chunk too large should fail" + `Quick + test_incomplete_kernel_chunk_limit; ] -- GitLab From b369c19ed1134ededfed4407aa26a60d3a77001d Mon Sep 17 00:00:00 2001 From: Thomas Letan Date: Sat, 2 Jul 2022 22:22:32 +0200 Subject: [PATCH 6/7] Proto,wasm: Unplug WASM tests in K We are making breaking changes in the WASM PVM compared to what has been frozen in K. This is OKay, because the WASM PVM is not in production yet. The simplest course of action is to remove the faulty tests, rather to needlessly pollute the code to remain backward compatible with something that was never intended to be used. --- .../lib_protocol/test/integration/main.ml | 1 - .../test/integration/test_sc_rollup_wasm.ml | 126 ------------------ 2 files changed, 127 deletions(-) delete mode 100644 src/proto_014_PtKathma/lib_protocol/test/integration/test_sc_rollup_wasm.ml diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/main.ml index cc4b5cd0f515..e8dc7b74eb26 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/main.ml @@ -40,6 +40,5 @@ let () = ("storage tests", Test_storage_functions.tests); ("token movements", Test_token.tests); ("frozen bonds", Test_frozen_bonds.tests); - ("sc rollup wasm", Test_sc_rollup_wasm.tests); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/test_sc_rollup_wasm.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/test_sc_rollup_wasm.ml deleted file mode 100644 index 0a31ad4390d6..000000000000 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/test_sc_rollup_wasm.ml +++ /dev/null @@ -1,126 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: sc rollup wasm - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/main.exe \ - -- test "^sc rollup wasm$" - Subject: Test the WASM 2.0 PVM. -*) - -open Protocol -open Alpha_context -module Context_binary = Tezos_context_memory.Context_binary - -module Tree : - Environment.Context.TREE - with type t = Context_binary.t - and type tree = Context_binary.tree - and type key = string list - and type value = bytes = struct - type t = Context_binary.t - - type tree = Context_binary.tree - - type key = Context_binary.key - - type value = Context_binary.value - - include Context_binary.Tree -end - -module WASM_P : - Protocol.Alpha_context.Sc_rollup.Wasm_2_0_0PVM.P - with type Tree.t = Context_binary.t - and type Tree.tree = Context_binary.tree - and type Tree.key = string list - and type Tree.value = bytes - and type proof = Context_binary.Proof.tree Context_binary.Proof.t = struct - module Tree = Tree - - type tree = Tree.tree - - type proof = Context_binary.Proof.tree Context_binary.Proof.t - - let proof_encoding = - Tezos_context_helpers.Merkle_proof_encoding.V2.Tree2.tree_proof_encoding - - let kinded_hash_to_state_hash : - Context_binary.Proof.kinded_hash -> Sc_rollup.State_hash.t = function - | `Value hash | `Node hash -> - Sc_rollup.State_hash.hash_bytes [Context_hash.to_bytes hash] - - let proof_before proof = - kinded_hash_to_state_hash proof.Context_binary.Proof.before - - let proof_after proof = - kinded_hash_to_state_hash proof.Context_binary.Proof.after - - let produce_proof context tree step = - let open Lwt_syntax in - let* context = Context_binary.add_tree context [] tree in - let _hash = Context_binary.commit ~time:Time.Protocol.epoch context in - let index = Context_binary.index context in - match Context_binary.Tree.kinded_key tree with - | Some k -> - let* p = Context_binary.produce_tree_proof index k step in - return (Some p) - | None -> - Stdlib.failwith - "produce_proof: internal error, [kinded_key] returned [None]" - - let verify_proof proof step = - let open Lwt_syntax in - let* result = Context_binary.verify_tree_proof proof step in - match result with - | Ok v -> return (Some v) - | Error _ -> - (* We skip the error analysis here since proof verification is not a - job for the rollup node. *) - return None -end - -module Verifier = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.ProtocolImplementation - -module Prover = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.Make (WASM_P) - -let should_boot () = - let open Lwt_result_syntax in - let*! index = Context_binary.init "/tmp" in - let context = Context_binary.empty index in - let*! s = Prover.initial_state context "" in - let*! s = Prover.eval s in - let*! p_res = Prover.produce_proof context None s in - match p_res with - | Ok proof -> - let*! is_correct = Verifier.verify_proof proof in - if is_correct then return_unit else Stdlib.failwith "incorrect proof" - | Error err -> - failwith "Could not produce a proof %a" Environment.Error_monad.pp err - -let tests = [Tztest.tztest "should boot" `Quick should_boot] -- GitLab From 4e5bbff574953a3219b7a2a7fe19a8464567b50a Mon Sep 17 00:00:00 2001 From: Thomas Letan Date: Mon, 11 Jul 2022 14:16:43 +0200 Subject: [PATCH 7/7] Doc,Scoru_wasm: Improve the documentation of the Gather_floppies module --- src/lib_scoru_wasm/gather_floppies.ml | 147 ++++++++++++++++++++------ 1 file changed, 117 insertions(+), 30 deletions(-) diff --git a/src/lib_scoru_wasm/gather_floppies.ml b/src/lib_scoru_wasm/gather_floppies.ml index 63309048ab97..b5a9bf9ebd3b 100644 --- a/src/lib_scoru_wasm/gather_floppies.ml +++ b/src/lib_scoru_wasm/gather_floppies.ml @@ -25,6 +25,8 @@ open Wasm_pvm_sig +(** FIXME: https://gitlab.com/tezos/tezos/-/issues/3361 + Increase the SCORU message size limit, and bump value to be 4,096. *) let chunk_size = 4_000 exception Malformed_origination_message of Data_encoding.Binary.read_error @@ -48,7 +50,6 @@ let internal_status_encoding = ("NotGatheringFloppies", Not_gathering_floppies); ] -(* An at most 4,096-byte fragment of a kernel. *) type chunk = bytes let chunk_encoding = Data_encoding.Bounded.bytes chunk_size @@ -100,8 +101,10 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : module Thunk = Thunk.Make (T) module Decoding = Tree_decoding.Make (T) - (* TYPES *) - + (** The [state] type is a phantom type that is used to describe the + data model of our PVM instrumentation. That is, values of type + [state] are never constructed. On the contrary, we manipulate + values of type [state Thunk.t]. *) type state = (internal_status value * Tezos_crypto.Signature.Public_key.t value) * string value @@ -112,6 +115,7 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : better with the [lib_webassembly]. *) * bytes value Thunk.Lazy_list.t + (** This [schema] decides how our data-model are encoded in a tree. *) let state_schema : state Thunk.schema = let open Thunk.Schema in obj5 @@ -128,30 +132,57 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : @@ folders ["kernel"; "boot.wasm"] @@ Thunk.Lazy_list.schema (encoding chunk_encoding)) + (** [status_l] is a lens to access the current [internal_status] of + the instrumented PVM. The instrumented PVM is either in the + process of gathering floppies, or is done with this pre-boot + step. *) let status_l : (state, internal_status value) Thunk.lens = Thunk.(tup5_0 ^. tup2_0) + (** [public_key_l] is a lens to access the public key incoming + chunks of kernel are expected to be signed with. The public key + is submitted in the [origination_message], and used as long as + the instrumented PVM is in the [Gather_floppies] state. *) let public_key_l : (state, Tezos_crypto.Signature.Public_key.t value) Thunk.lens = Thunk.(tup5_0 ^. tup2_1) + (** [boot_sector_l] is a lens to access the [origination_message] + provided at the origination of the rollup. This message is + either a complete kernel, or a chunk of a kernel with a public + key. *) let boot_sector_l : (state, string value) Thunk.lens = Thunk.tup5_1 + (** [last_input_info_l] is a lens to access the input that was last + provided to the PVM, along with some metadata. It is updated + after each chunk of kernel is received. *) let last_input_info_l : (state, input_info value) Thunk.lens = Thunk.tup5_2 + (** [interal_tick_l] is a lens to access the number of ticks + performed by the “gather floppies” instrumentation, before the + PVM starts its real execution. *) let internal_tick_l : (state, Z.t value) Thunk.lens = Thunk.tup5_3 + (** [chunks_l] is a lens to access the collection of chunks (saved + as a so-called [Thunk.Lazy_map.t]) already received by the + instrumented PVM. *) let chunks_l : (state, bytes value Thunk.Lazy_list.t) Thunk.lens = Thunk.tup5_4 - (* STORAGE/TREE INTERACTION *) - + (** [check_signature payload signature state] returns [true] iff + [signature] is a correct signature for [payload], that is, it + has been computed with the companion secret key of the public + key submitted in the [origination_message], and stored in + [state] (see {!public_key_l}). *) let check_signature payload signature state = let open Lwt_syntax in let open Thunk.Syntax in let*^ pk = state ^-> public_key_l in return @@ Tezos_crypto.Signature.check pk signature payload + (** [store_chunk state chunk] adds [chunk] in the collection of + chunks already collected by the instrumented PVM and stored in + [state] (see {!chunks_l}). *) let store_chunk state chunk = let open Lwt_syntax in let open Thunk.Syntax in @@ -159,6 +190,9 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : let* _ = Thunk.Lazy_list.cons chunks chunk in return () + (** [store_bytes state bytes] slices [bytes] into individual chunks, + and adds them in the collection of chunks stored in [state] (see + {!store_chunk}). *) let store_bytes state : bytes -> unit Lwt.t = let rec aux bytes = let open Lwt_syntax in @@ -177,12 +211,18 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : in aux + (** [get_internal_ticks state] returns the number of ticks as stored + in [state], or [0] if the values has not been initialized + yet. *) let get_internal_ticks state = let open Lwt_syntax in let open Thunk.Syntax in let*^? tick = state ^-> internal_tick_l in return @@ Option.value ~default:Z.zero tick + (** [increment_ticks state] increments the number of ticks as stored + in [state], or set it to [1] in case it has not been initialized + yet. *) let increment_ticks state = let open Lwt_syntax in let open Thunk.Syntax in @@ -191,9 +231,12 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : (* PROCESS MESSAGES *) - (* Process and store the kernel image in the origination message - This message contains either the entire (small) kernel image or - the first chunk of it. *) + (** [origination_kernel_loading_step state] processes and stores the + (potentially incomplete) kernel image contained in the + origination message. + + This message contains either the entire (small) kernel image or + the first chunk of it (see {!origination_message}). *) let origination_kernel_loading_step state = let open Lwt_syntax in let open Thunk.Syntax in @@ -222,37 +265,65 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : (* TODO: Add a proper [status] constructor *) return () - (* Process one sub-sequent kernel image chunks. If the chunk has - zero length it * means we're done and we have the entire kernel - image. *) + (** [kernel_loading_step input_info message state] processes the + sub-sequent kernel image chunk encoded in [message], as part of + an input tick described by [input_info]. + + If the chunk is not strictly equal to [chunk_size], then it is + considered as the very last chunk of the kernel, meaning the + instrumented PVM will update its status to start the regular + execution of the PVM. An empty chunk is also allowed. *) let kernel_loading_step input message state = let open Lwt_syntax in let open Thunk.Syntax in let* () = (state ^-> last_input_info_l) ^:= input in let* () = increment_ticks state in - (* TODO: check that the first byte of [message] is 0x01 (External). *) - match - Data_encoding.Binary.read - floppy_encoding - message - 1 - (String.length message - 1) - with - | Error error -> raise (Malformed_inbox_message error) - | Ok (_, {chunk; signature}) -> - let* check = check_signature chunk signature state in - if check then - let* () = - if 0 < Bytes.length chunk then store_chunk state chunk + if 0 < String.length message then + (* It is safe to read the very first character stored in + [message], that is [String.get] will not raise an exception. *) + match + ( String.get message 0, + Data_encoding.Binary.read + floppy_encoding + message + 1 + (String.length message - 1) ) + with + | '\001', Ok (_, {chunk; signature}) -> + let* check = check_signature chunk signature state in + if check then + let* () = + if 0 < Bytes.length chunk then store_chunk state chunk + else return () + in + if Bytes.length chunk < chunk_size then + (state ^-> status_l) ^:= Not_gathering_floppies else return () - in - if Bytes.length chunk < chunk_size then - (state ^-> status_l) ^:= Not_gathering_floppies else return () - else return () + | '\001', Error error -> raise (Malformed_inbox_message error) + | _, _ -> + (* [message] is not an external message (its tag is not + [0x01]), that is it is not a valid input. *) + return () + else (* [message] is empty, that is it is not a valid input. *) + return () (* Encapsulated WASM *) + (** [compute_step tree] instruments [Wasm.compute_step] to check the + current status of the PVM. + + {ul + {li If the status has not yet been initialized, it means it is + the very first step of the rollup, and we interpret the + [origination_message] that was provided at origination + time.} + {li If the status is [Gathering_floppies], then the PVM is + expected to receive the next kernel chunk, and + [compute_step] raises an exception.} + {li If the status is [Not_gathering_floppies], then the PVM + pre-boot has ended, the kernel has been provided, and + [Wasm.compute_step] is called.}} *) let compute_step tree = let open Lwt_syntax in let open Thunk.Syntax in @@ -265,6 +336,15 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : let* () = origination_kernel_loading_step state in Thunk.encode tree state + (** [set_input_step input message tree] instruments + [Wasm.set_input_step] to interpret incoming input messages as + floppies (that is, a kernel chunk and a signature) when the PVM + status is [Gathering_floppies]. + + When the status is [Not_gathering_floppies] the pre-boot phase + has ended and [Wasm.set_input_step] is called. If the status has + not yet been initialized, this function raises an exception, as + the origination message has yet to be interpreted. *) let set_input_step input message tree = let open Lwt_syntax in let open Thunk.Syntax in @@ -299,7 +379,14 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : return { inner_info with - current_tick = Z.(add inner_info.current_tick ticks); + current_tick = + (* We consider [Wasm] as a black box. In particular, we + don’t know where [Wasm] is storing the number of + internal ticks it has interpreted, hence the need to + add both tick counters (the one introduced by our + instrumentation, and the one maintained by + [Wasm]). *) + Z.(add inner_info.current_tick ticks); last_input_read = Option.fold ~none:last_boot_read -- GitLab