diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 52cbeefd0f2bedfee7d71b257cbab42c46a8af38..6e55e2df035b0b7e38a4684e62c757d93419f5dd 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 -> 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 new file mode 100644 index 0000000000000000000000000000000000000000..b5a9bf9ebd3ba12c514a8feb1e988f6ab3df6844 --- /dev/null +++ b/src/lib_scoru_wasm/gather_floppies.ml @@ -0,0 +1,403 @@ +(*****************************************************************************) +(* *) +(* 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 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 + +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 + +type internal_status = Gathering_floppies | Not_gathering_floppies + +let internal_status_encoding = + Data_encoding.string_enum + [ + ("GatheringFloppies", Gathering_floppies); + ("NotGatheringFloppies", Not_gathering_floppies); + ] + +type chunk = bytes + +let chunk_encoding = Data_encoding.Bounded.bytes chunk_size + +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 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)); + ] + +(* STORAGE KEYS *) + +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) + + (** 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 + * 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 + + (** This [schema] decides how our data-model are encoded in a tree. *) + 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_info_encoding) + (req "internal-loading-kernel-tick" @@ encoding Data_encoding.n) + (req "durable" + @@ 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 + + (** [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 + let* chunks = state ^-> chunks_l in + 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 + 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 < chunk_size then + let* _ = Thunk.Lazy_list.cons chunks bytes in + return () + else + 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 + 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 + let* tick = get_internal_ticks state in + (state ^-> internal_tick_l) ^:= Z.succ tick + + (* PROCESS MESSAGES *) + + (** [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 + let* () = increment_ticks state in + let*^ boot_sector = state ^-> boot_sector_l in + let 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 < 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 + (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 () + + (** [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 + 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 () + 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 + 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 + + (** [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 + 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 = + (* 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 + ~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 0000000000000000000000000000000000000000..5af9e72ba01d763a422a7f6e618f6519259778d8 --- /dev/null +++ b/src/lib_scoru_wasm/gather_floppies.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. *) +(* *) +(*****************************************************************************) + +(** 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 + +(** 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- + messages. *) +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 569ddad0d70fb5a8e91c560364526d9a9ec760a9..556d24dbed658ed950ae8b987061bdff5c8c3cf6 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 099b34fb1bfac790e89cb7b27260ffc20ac02560..9f89d0f001fd4e56ad56831b533b142e4877a177 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 cd315027af29c99e870c3e41efddda74a9e667bf..48987a58a0e3951e4786bcf54dcc12c50dc95bd7 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 b44d6db3568c6fc0c2b9df4be73e633b8c6820f5..0000000000000000000000000000000000000000 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.ml +++ /dev/null @@ -1,164 +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 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 - -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/thunk.ml b/src/lib_scoru_wasm/thunk.ml new file mode 100644 index 0000000000000000000000000000000000000000..8abcf5cc7008ba57c665cf9590432470b5e69b14 --- /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 0000000000000000000000000000000000000000..f59b84326e63d9761dd66acb312a804683d125f1 --- /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 diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml new file mode 100644 index 0000000000000000000000000000000000000000..f0ef2ead0084be1ec38f031d99b6141c4a82732a --- /dev/null +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -0,0 +1,66 @@ +(*****************************************************************************) +(* *) +(* 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 library acts as a dependency to the protocol environment. Everything that + must be exposed to the protocol via the environment shall be added here. + +*) + +module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree = struct + include + Gather_floppies.Make + (T) + (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 + 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) +end diff --git a/src/lib_scoru_wasm/wasm_pvm.mli b/src/lib_scoru_wasm/wasm_pvm.mli new file mode 100644 index 0000000000000000000000000000000000000000..879d1de5ffdcddd80c8d6b3ece33fb6b9051067b --- /dev/null +++ b/src/lib_scoru_wasm/wasm_pvm.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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/tezos_scoru_wasm.mli b/src/lib_scoru_wasm/wasm_pvm_sig.ml similarity index 65% rename from src/lib_scoru_wasm/tezos_scoru_wasm.mli rename to src/lib_scoru_wasm/wasm_pvm_sig.ml index 36a2c9517fd4a46472bc3f6b1646d10a449b56c1..1d96e3c91c537e65a800a90e75842e8d24d95d70 100644 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.mli +++ b/src/lib_scoru_wasm/wasm_pvm_sig.ml @@ -23,23 +23,15 @@ (* *) (*****************************************************************************) -(** 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. *) - (** Represents the location of an input message. *) -type input = { +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 = { +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. *) @@ -54,8 +46,8 @@ type input_request = 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; + [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. *) } @@ -72,46 +64,26 @@ module type S = sig (** [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 + 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 -> tree -> string Lwt.t + 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) : 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 +(* Encodings *) -(** 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 +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_014_PtKathma/lib_protocol/test/integration/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/main.ml index cc4b5cd0f515dbef68da4d16e39b597b35ac4724..e8dc7b74eb260c497bdb9517c3ffc222bba1eebc 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 0a31ad4390d62d620a6884e2c9725e77a5eaf8fa..0000000000000000000000000000000000000000 --- 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] diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index bbdf77cc7ce5a3288f25d04ba3dffd2f75037449..52f64e3834fca0a4712c2d3ed0bf901e79b1025c 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 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 4c250a82041c46f33d69c042af005eaf28ef2c6d..fb2f2f21ee66d9614697b140bb6a7fefcecc3bb5 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 07cd4db6d0f90407497ce945e397c8a8fe26c4d4..0630ecc37e0d0992c82ef31d14909f6d6804d9ee 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; ]