(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* 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_protocol_alpha
open Protocol
open Alpha_context
(* Encoding reading string as Michelson data, of the form "Pair Unit...". It can
only be used for decoding however, not encoding. *)
let parsed_string_encoding =
Data_encoding.conv
(fun _ -> Stdlib.failwith "This value is not supposed to be encoded")
(fun s ->
let parsed, _ =
Tezos_client_alpha.Michelson_v1_parser.parse_expression s
in
parsed.Tezos_client_alpha.Michelson_v1_parser.expanded)
Data_encoding.string
(* [input_encoding default_sender default_source default_destination] is an
alternative encoding for {Sc_rollup_inbox_message_repr.t} that only encodes
`Internal Transfer` and `External`. In the case of `Internal Transfer`, only
the Micheline payload is mandatory, the other field are taken from the
default one if they are missing. *)
let input_encoding default_sender default_source default_destination =
let open Data_encoding in
union
[
case
(Tag 0)
~title:"Transfer"
(obj4
(req "payload" parsed_string_encoding)
(dft "sender" Contract_hash.encoding default_sender)
(dft
"source"
Tezos_crypto.Signature.Public_key_hash.encoding
default_source)
(dft
"destination"
Sc_rollup_repr.Address.encoding
default_destination))
(function
| Sc_rollup.Inbox_message.(
Internal (Transfer {payload; sender; source; destination})) ->
Some (payload, sender, source, destination)
| _ -> None)
(fun (payload, sender, source, destination) ->
Internal (Transfer {payload; sender; source; destination}));
case
(Tag 1)
~title:"External"
(obj1 (req "external" string))
(function
| Sc_rollup.Inbox_message.External msg ->
let (`Hex msg) = Hex.of_string msg in
Some msg
| Internal _ -> None)
(fun msg ->
External (Hex.to_string (`Hex msg) |> Option.value ~default:""));
]
(* Represent a set of inboxes, i.e. a set of set of inputs. The position of an
inbox in the list represents its level. *)
type inboxes = Sc_rollup.Inbox_message.t list list
let inboxes_encoding default_sender default_source default_destination =
Data_encoding.(
list
(list (input_encoding default_sender default_source default_destination)))
(* [parse_inboxes inputs config] parses an inbox from raw string. *)
let parse_inboxes inputs Config.{sender; source; destination; _} =
let open Lwt_result_syntax in
match Data_encoding.Json.from_string inputs with
| Ok json ->
let* full_inputs =
(fun () ->
Lwt.return
(Data_encoding.Json.destruct
(inboxes_encoding sender source destination)
json))
|> Repl_helpers.trap_exn
in
List.map_es
(fun inputs ->
List.map_es
(fun input ->
Protocol.Alpha_context.Sc_rollup.Inbox_message.(
serialize input
|> Result.map unsafe_to_string
|> Environment.wrap_tzresult |> Lwt.return))
inputs)
full_inputs
| Error e -> Error_monad.failwith "%s" e
(* [pp_input ppf bytes] is a pretty printer for Sc_rollup.Inbox messages that
also handles deserialization from raw bytes. If the message cannot be
decoded, it prints its hexadecimal representation. *)
let pp_input ppf bytes =
let pp ppf = function
| Sc_rollup.Inbox_message.(Internal (Transfer _) as msg) ->
let json =
Data_encoding.Json.construct Sc_rollup.Inbox_message.encoding msg
in
Data_encoding.Json.pp ppf json
| Internal Start_of_level -> Format.fprintf ppf "Start_of_level"
| Internal End_of_level -> Format.fprintf ppf "End_of_level"
| Internal (Protocol_migration proto) ->
Format.fprintf ppf "Protocol_migration %s" proto
| Internal (Info_per_level {predecessor_timestamp; predecessor}) ->
Format.fprintf
ppf
"Info_per_level {predecessor_timestamp = %a; predecessor = %a}"
Timestamp.pp
predecessor_timestamp
Block_hash.pp
predecessor
| External msg -> Format.fprintf ppf "%a" Hex.pp (Hex.of_string msg)
in
match
Sc_rollup.Inbox_message.(
deserialize (unsafe_of_string (Bytes.to_string bytes)))
with
| Error _ ->
Format.fprintf ppf "Unknown encoding: %a" Hex.pp (Hex.of_bytes bytes)
| Ok msg -> pp ppf msg
let compare_input_buffer_messages i1 i2 =
let cmp_lvl =
Int32.compare
i1.Tezos_webassembly_interpreter.Input_buffer.raw_level
i2.Tezos_webassembly_interpreter.Input_buffer.raw_level
in
if cmp_lvl = 0 then Z.compare i1.message_counter i2.message_counter
else cmp_lvl
(* [pp_output ppf bytes] is a pretty printer for Sc_rollup.Outbox messages that
also handles deserialization from raw bytes. If the message cannot be
decoded, it prints its hexadecimal representation. *)
let pp_output ppf bytes =
let pp_message_untyped ppf
({unparsed_parameters; destination; entrypoint} :
Sc_rollup.Outbox.Message.transaction) =
let json =
Data_encoding.Json.construct Script_repr.expr_encoding unparsed_parameters
in
Format.fprintf
ppf
"@[{ unparsed_parameters: %a@; destination: %a@; entrypoint: %a }@]"
Data_encoding.Json.pp
json
Contract_hash.pp
destination
Entrypoint.pp
entrypoint
in
let pp_message_typed ppf
({unparsed_parameters; unparsed_ty; destination; entrypoint} :
Sc_rollup.Outbox.Message.typed_transaction) =
let parameters_json =
Data_encoding.Json.construct Script_repr.expr_encoding unparsed_parameters
in
let ty_json =
Data_encoding.Json.construct Script_repr.expr_encoding unparsed_ty
in
Format.fprintf
ppf
"@[<v2>unparsed_parameters: %a@,\
unparsed_ty: %a@,\
destination: %a@,\
entrypoint: %a@]"
Data_encoding.Json.pp
parameters_json
Data_encoding.Json.pp
ty_json
Contract_hash.pp
destination
Entrypoint.pp
entrypoint
in
let pp_batch ppf = function
| Sc_rollup.Outbox.Message.(Atomic_transaction_batch {transactions}) ->
Format.pp_print_list pp_message_untyped ppf transactions
| Sc_rollup.Outbox.Message.(Atomic_transaction_batch_typed {transactions})
->
Format.pp_print_list pp_message_typed ppf transactions
in
match
Sc_rollup.Outbox.Message.(
deserialize (unsafe_of_string (Bytes.to_string bytes)))
with
| Error _ ->
Format.fprintf ppf "Unknown encoding: %a" Hex.pp (Hex.of_bytes bytes)
| Ok msgs -> pp_batch ppf msgs