1188 lines
41 KiB
OCaml
1188 lines
41 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* Open Source License *)
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.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 Alpha_context
|
|
open Data_encoding
|
|
|
|
let error_encoding =
|
|
def
|
|
"error"
|
|
~description:
|
|
"The full list of RPC errors would be too long to include.\n\
|
|
It is available at RPC `/errors` (GET).\n\
|
|
Errors specific to protocol Alpha have an id that starts with \
|
|
`proto.alpha`."
|
|
@@ splitted
|
|
~json:
|
|
(conv
|
|
(fun err ->
|
|
Data_encoding.Json.construct Error_monad.error_encoding err)
|
|
(fun json ->
|
|
Data_encoding.Json.destruct Error_monad.error_encoding json)
|
|
json)
|
|
~binary:Error_monad.error_encoding
|
|
|
|
type _ successful_manager_operation_result =
|
|
| Reveal_result : {
|
|
consumed_gas : Z.t;
|
|
}
|
|
-> Kind.reveal successful_manager_operation_result
|
|
| Transaction_result : {
|
|
storage : Script.expr option;
|
|
big_map_diff : Contract.big_map_diff option;
|
|
balance_updates : Delegate.balance_updates;
|
|
originated_contracts : Contract.t list;
|
|
consumed_gas : Z.t;
|
|
storage_size : Z.t;
|
|
paid_storage_size_diff : Z.t;
|
|
allocated_destination_contract : bool;
|
|
}
|
|
-> Kind.transaction successful_manager_operation_result
|
|
| Origination_result : {
|
|
big_map_diff : Contract.big_map_diff option;
|
|
balance_updates : Delegate.balance_updates;
|
|
originated_contracts : Contract.t list;
|
|
consumed_gas : Z.t;
|
|
storage_size : Z.t;
|
|
paid_storage_size_diff : Z.t;
|
|
}
|
|
-> Kind.origination successful_manager_operation_result
|
|
| Delegation_result : {
|
|
consumed_gas : Z.t;
|
|
}
|
|
-> Kind.delegation successful_manager_operation_result
|
|
|
|
type packed_successful_manager_operation_result =
|
|
| Successful_manager_result :
|
|
'kind successful_manager_operation_result
|
|
-> packed_successful_manager_operation_result
|
|
|
|
type 'kind manager_operation_result =
|
|
| Applied of 'kind successful_manager_operation_result
|
|
| Backtracked of
|
|
'kind successful_manager_operation_result * error list option
|
|
| Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
|
|
| Skipped : 'kind Kind.manager -> 'kind manager_operation_result
|
|
|
|
type packed_internal_operation_result =
|
|
| Internal_operation_result :
|
|
'kind internal_operation * 'kind manager_operation_result
|
|
-> packed_internal_operation_result
|
|
|
|
module Manager_result = struct
|
|
type 'kind case =
|
|
| MCase : {
|
|
op_case : 'kind Operation.Encoding.Manager_operations.case;
|
|
encoding : 'a Data_encoding.t;
|
|
kind : 'kind Kind.manager;
|
|
iselect :
|
|
packed_internal_operation_result ->
|
|
('kind internal_operation * 'kind manager_operation_result) option;
|
|
select :
|
|
packed_successful_manager_operation_result ->
|
|
'kind successful_manager_operation_result option;
|
|
proj : 'kind successful_manager_operation_result -> 'a;
|
|
inj : 'a -> 'kind successful_manager_operation_result;
|
|
t : 'kind manager_operation_result Data_encoding.t;
|
|
}
|
|
-> 'kind case
|
|
|
|
let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
|
|
let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in
|
|
let t =
|
|
def (Format.asprintf "operation.alpha.operation_result.%s" name)
|
|
@@ union
|
|
~tag_size:`Uint8
|
|
[ case
|
|
(Tag 0)
|
|
~title:"Applied"
|
|
(merge_objs (obj1 (req "status" (constant "applied"))) encoding)
|
|
(fun o ->
|
|
match o with
|
|
| Skipped _ | Failed _ | Backtracked _ ->
|
|
None
|
|
| Applied o -> (
|
|
match select (Successful_manager_result o) with
|
|
| None ->
|
|
None
|
|
| Some o ->
|
|
Some ((), proj o) ))
|
|
(fun ((), x) -> Applied (inj x));
|
|
case
|
|
(Tag 1)
|
|
~title:"Failed"
|
|
(obj2
|
|
(req "status" (constant "failed"))
|
|
(req "errors" (list error_encoding)))
|
|
(function Failed (_, errs) -> Some ((), errs) | _ -> None)
|
|
(fun ((), errs) -> Failed (kind, errs));
|
|
case
|
|
(Tag 2)
|
|
~title:"Skipped"
|
|
(obj1 (req "status" (constant "skipped")))
|
|
(function Skipped _ -> Some () | _ -> None)
|
|
(fun () -> Skipped kind);
|
|
case
|
|
(Tag 3)
|
|
~title:"Backtracked"
|
|
(merge_objs
|
|
(obj2
|
|
(req "status" (constant "backtracked"))
|
|
(opt "errors" (list error_encoding)))
|
|
encoding)
|
|
(fun o ->
|
|
match o with
|
|
| Skipped _ | Failed _ | Applied _ ->
|
|
None
|
|
| Backtracked (o, errs) -> (
|
|
match select (Successful_manager_result o) with
|
|
| None ->
|
|
None
|
|
| Some o ->
|
|
Some (((), errs), proj o) ))
|
|
(fun (((), errs), x) -> Backtracked (inj x, errs)) ]
|
|
in
|
|
MCase {op_case; encoding; kind; iselect; select; proj; inj; t}
|
|
|
|
let reveal_case =
|
|
make
|
|
~op_case:Operation.Encoding.Manager_operations.reveal_case
|
|
~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
|
|
~iselect:(function
|
|
| Internal_operation_result (({operation = Reveal _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
~select:(function
|
|
| Successful_manager_result (Reveal_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None)
|
|
~kind:Kind.Reveal_manager_kind
|
|
~proj:(function Reveal_result {consumed_gas} -> consumed_gas)
|
|
~inj:(fun consumed_gas -> Reveal_result {consumed_gas})
|
|
|
|
let transaction_case =
|
|
make
|
|
~op_case:Operation.Encoding.Manager_operations.transaction_case
|
|
~encoding:
|
|
(obj8
|
|
(opt "storage" Script.expr_encoding)
|
|
(opt "big_map_diff" Contract.big_map_diff_encoding)
|
|
(dft "balance_updates" Delegate.balance_updates_encoding [])
|
|
(dft "originated_contracts" (list Contract.encoding) [])
|
|
(dft "consumed_gas" z Z.zero)
|
|
(dft "storage_size" z Z.zero)
|
|
(dft "paid_storage_size_diff" z Z.zero)
|
|
(dft "allocated_destination_contract" bool false))
|
|
~iselect:(function
|
|
| Internal_operation_result
|
|
(({operation = Transaction _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
~select:(function
|
|
| Successful_manager_result (Transaction_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None)
|
|
~kind:Kind.Transaction_manager_kind
|
|
~proj:(function
|
|
| Transaction_result
|
|
{ storage;
|
|
big_map_diff;
|
|
balance_updates;
|
|
originated_contracts;
|
|
consumed_gas;
|
|
storage_size;
|
|
paid_storage_size_diff;
|
|
allocated_destination_contract } ->
|
|
( storage,
|
|
big_map_diff,
|
|
balance_updates,
|
|
originated_contracts,
|
|
consumed_gas,
|
|
storage_size,
|
|
paid_storage_size_diff,
|
|
allocated_destination_contract ))
|
|
~inj:
|
|
(fun ( storage,
|
|
big_map_diff,
|
|
balance_updates,
|
|
originated_contracts,
|
|
consumed_gas,
|
|
storage_size,
|
|
paid_storage_size_diff,
|
|
allocated_destination_contract ) ->
|
|
Transaction_result
|
|
{
|
|
storage;
|
|
big_map_diff;
|
|
balance_updates;
|
|
originated_contracts;
|
|
consumed_gas;
|
|
storage_size;
|
|
paid_storage_size_diff;
|
|
allocated_destination_contract;
|
|
})
|
|
|
|
let origination_case =
|
|
make
|
|
~op_case:Operation.Encoding.Manager_operations.origination_case
|
|
~encoding:
|
|
(obj6
|
|
(opt "big_map_diff" Contract.big_map_diff_encoding)
|
|
(dft "balance_updates" Delegate.balance_updates_encoding [])
|
|
(dft "originated_contracts" (list Contract.encoding) [])
|
|
(dft "consumed_gas" z Z.zero)
|
|
(dft "storage_size" z Z.zero)
|
|
(dft "paid_storage_size_diff" z Z.zero))
|
|
~iselect:(function
|
|
| Internal_operation_result
|
|
(({operation = Origination _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
~select:(function
|
|
| Successful_manager_result (Origination_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None)
|
|
~proj:(function
|
|
| Origination_result
|
|
{ big_map_diff;
|
|
balance_updates;
|
|
originated_contracts;
|
|
consumed_gas;
|
|
storage_size;
|
|
paid_storage_size_diff } ->
|
|
( big_map_diff,
|
|
balance_updates,
|
|
originated_contracts,
|
|
consumed_gas,
|
|
storage_size,
|
|
paid_storage_size_diff ))
|
|
~kind:Kind.Origination_manager_kind
|
|
~inj:
|
|
(fun ( big_map_diff,
|
|
balance_updates,
|
|
originated_contracts,
|
|
consumed_gas,
|
|
storage_size,
|
|
paid_storage_size_diff ) ->
|
|
Origination_result
|
|
{
|
|
big_map_diff;
|
|
balance_updates;
|
|
originated_contracts;
|
|
consumed_gas;
|
|
storage_size;
|
|
paid_storage_size_diff;
|
|
})
|
|
|
|
let delegation_case =
|
|
make
|
|
~op_case:Operation.Encoding.Manager_operations.delegation_case
|
|
~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
|
|
~iselect:(function
|
|
| Internal_operation_result (({operation = Delegation _; _} as op), res)
|
|
->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
~select:(function
|
|
| Successful_manager_result (Delegation_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None)
|
|
~kind:Kind.Delegation_manager_kind
|
|
~proj:(function Delegation_result {consumed_gas} -> consumed_gas)
|
|
~inj:(fun consumed_gas -> Delegation_result {consumed_gas})
|
|
end
|
|
|
|
let internal_operation_result_encoding :
|
|
packed_internal_operation_result Data_encoding.t =
|
|
let make (type kind)
|
|
(Manager_result.MCase res_case : kind Manager_result.case) =
|
|
let (Operation.Encoding.Manager_operations.MCase op_case) =
|
|
res_case.op_case
|
|
in
|
|
case
|
|
(Tag op_case.tag)
|
|
~title:op_case.name
|
|
(merge_objs
|
|
(obj3
|
|
(req "kind" (constant op_case.name))
|
|
(req "source" Contract.encoding)
|
|
(req "nonce" uint16))
|
|
(merge_objs op_case.encoding (obj1 (req "result" res_case.t))))
|
|
(fun op ->
|
|
match res_case.iselect op with
|
|
| Some (op, res) ->
|
|
Some (((), op.source, op.nonce), (op_case.proj op.operation, res))
|
|
| None ->
|
|
None)
|
|
(fun (((), source, nonce), (op, res)) ->
|
|
let op = {source; operation = op_case.inj op; nonce} in
|
|
Internal_operation_result (op, res))
|
|
in
|
|
def "operation.alpha.internal_operation_result"
|
|
@@ union
|
|
[ make Manager_result.reveal_case;
|
|
make Manager_result.transaction_case;
|
|
make Manager_result.origination_case;
|
|
make Manager_result.delegation_case ]
|
|
|
|
type 'kind contents_result =
|
|
| Endorsement_result : {
|
|
balance_updates : Delegate.balance_updates;
|
|
delegate : Signature.Public_key_hash.t;
|
|
slots : int list;
|
|
}
|
|
-> Kind.endorsement contents_result
|
|
| Seed_nonce_revelation_result :
|
|
Delegate.balance_updates
|
|
-> Kind.seed_nonce_revelation contents_result
|
|
| Double_endorsement_evidence_result :
|
|
Delegate.balance_updates
|
|
-> Kind.double_endorsement_evidence contents_result
|
|
| Double_baking_evidence_result :
|
|
Delegate.balance_updates
|
|
-> Kind.double_baking_evidence contents_result
|
|
| Activate_account_result :
|
|
Delegate.balance_updates
|
|
-> Kind.activate_account contents_result
|
|
| Proposals_result : Kind.proposals contents_result
|
|
| Ballot_result : Kind.ballot contents_result
|
|
| Manager_operation_result : {
|
|
balance_updates : Delegate.balance_updates;
|
|
operation_result : 'kind manager_operation_result;
|
|
internal_operation_results : packed_internal_operation_result list;
|
|
}
|
|
-> 'kind Kind.manager contents_result
|
|
|
|
type packed_contents_result =
|
|
| Contents_result : 'kind contents_result -> packed_contents_result
|
|
|
|
type packed_contents_and_result =
|
|
| Contents_and_result :
|
|
'kind Operation.contents * 'kind contents_result
|
|
-> packed_contents_and_result
|
|
|
|
type ('a, 'b) eq = Eq : ('a, 'a) eq
|
|
|
|
let equal_manager_kind :
|
|
type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =
|
|
fun ka kb ->
|
|
match (ka, kb) with
|
|
| (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) ->
|
|
Some Eq
|
|
| (Kind.Reveal_manager_kind, _) ->
|
|
None
|
|
| (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) ->
|
|
Some Eq
|
|
| (Kind.Transaction_manager_kind, _) ->
|
|
None
|
|
| (Kind.Origination_manager_kind, Kind.Origination_manager_kind) ->
|
|
Some Eq
|
|
| (Kind.Origination_manager_kind, _) ->
|
|
None
|
|
| (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) ->
|
|
Some Eq
|
|
| (Kind.Delegation_manager_kind, _) ->
|
|
None
|
|
|
|
module Encoding = struct
|
|
type 'kind case =
|
|
| Case : {
|
|
op_case : 'kind Operation.Encoding.case;
|
|
encoding : 'a Data_encoding.t;
|
|
select : packed_contents_result -> 'kind contents_result option;
|
|
mselect :
|
|
packed_contents_and_result ->
|
|
('kind contents * 'kind contents_result) option;
|
|
proj : 'kind contents_result -> 'a;
|
|
inj : 'a -> 'kind contents_result;
|
|
}
|
|
-> 'kind case
|
|
|
|
let tagged_case tag name args proj inj =
|
|
let open Data_encoding in
|
|
case
|
|
tag
|
|
~title:(String.capitalize_ascii name)
|
|
(merge_objs (obj1 (req "kind" (constant name))) args)
|
|
(fun x -> match proj x with None -> None | Some x -> Some ((), x))
|
|
(fun ((), x) -> inj x)
|
|
|
|
let endorsement_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.endorsement_case;
|
|
encoding =
|
|
obj3
|
|
(req "balance_updates" Delegate.balance_updates_encoding)
|
|
(req "delegate" Signature.Public_key_hash.encoding)
|
|
(req "slots" (list uint8));
|
|
select =
|
|
(function
|
|
| Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Endorsement _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj =
|
|
(function
|
|
| Endorsement_result {balance_updates; delegate; slots} ->
|
|
(balance_updates, delegate, slots));
|
|
inj =
|
|
(fun (balance_updates, delegate, slots) ->
|
|
Endorsement_result {balance_updates; delegate; slots});
|
|
}
|
|
|
|
let seed_nonce_revelation_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.seed_nonce_revelation_case;
|
|
encoding =
|
|
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
|
|
select =
|
|
(function
|
|
| Contents_result (Seed_nonce_revelation_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj = (fun (Seed_nonce_revelation_result bus) -> bus);
|
|
inj = (fun bus -> Seed_nonce_revelation_result bus);
|
|
}
|
|
|
|
let double_endorsement_evidence_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.double_endorsement_evidence_case;
|
|
encoding =
|
|
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
|
|
select =
|
|
(function
|
|
| Contents_result (Double_endorsement_evidence_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj = (fun (Double_endorsement_evidence_result bus) -> bus);
|
|
inj = (fun bus -> Double_endorsement_evidence_result bus);
|
|
}
|
|
|
|
let double_baking_evidence_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.double_baking_evidence_case;
|
|
encoding =
|
|
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
|
|
select =
|
|
(function
|
|
| Contents_result (Double_baking_evidence_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Double_baking_evidence _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj = (fun (Double_baking_evidence_result bus) -> bus);
|
|
inj = (fun bus -> Double_baking_evidence_result bus);
|
|
}
|
|
|
|
let activate_account_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.activate_account_case;
|
|
encoding =
|
|
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
|
|
select =
|
|
(function
|
|
| Contents_result (Activate_account_result _ as op) ->
|
|
Some op
|
|
| _ ->
|
|
None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Activate_account _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj = (fun (Activate_account_result bus) -> bus);
|
|
inj = (fun bus -> Activate_account_result bus);
|
|
}
|
|
|
|
let proposals_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.proposals_case;
|
|
encoding = Data_encoding.empty;
|
|
select =
|
|
(function
|
|
| Contents_result (Proposals_result as op) -> Some op | _ -> None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Proposals _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj = (fun Proposals_result -> ());
|
|
inj = (fun () -> Proposals_result);
|
|
}
|
|
|
|
let ballot_case =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.ballot_case;
|
|
encoding = Data_encoding.empty;
|
|
select =
|
|
(function
|
|
| Contents_result (Ballot_result as op) -> Some op | _ -> None);
|
|
mselect =
|
|
(function
|
|
| Contents_and_result ((Ballot _ as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None);
|
|
proj = (fun Ballot_result -> ());
|
|
inj = (fun () -> Ballot_result);
|
|
}
|
|
|
|
let make_manager_case (type kind)
|
|
(Operation.Encoding.Case op_case :
|
|
kind Kind.manager Operation.Encoding.case)
|
|
(Manager_result.MCase res_case : kind Manager_result.case) mselect =
|
|
Case
|
|
{
|
|
op_case = Operation.Encoding.Case op_case;
|
|
encoding =
|
|
obj3
|
|
(req "balance_updates" Delegate.balance_updates_encoding)
|
|
(req "operation_result" res_case.t)
|
|
(dft
|
|
"internal_operation_results"
|
|
(list internal_operation_result_encoding)
|
|
[]);
|
|
select =
|
|
(function
|
|
| Contents_result
|
|
(Manager_operation_result
|
|
({operation_result = Applied res; _} as op)) -> (
|
|
match res_case.select (Successful_manager_result res) with
|
|
| Some res ->
|
|
Some
|
|
(Manager_operation_result
|
|
{op with operation_result = Applied res})
|
|
| None ->
|
|
None )
|
|
| Contents_result
|
|
(Manager_operation_result
|
|
({operation_result = Backtracked (res, errs); _} as op)) -> (
|
|
match res_case.select (Successful_manager_result res) with
|
|
| Some res ->
|
|
Some
|
|
(Manager_operation_result
|
|
{op with operation_result = Backtracked (res, errs)})
|
|
| None ->
|
|
None )
|
|
| Contents_result
|
|
(Manager_operation_result
|
|
({operation_result = Skipped kind; _} as op)) -> (
|
|
match equal_manager_kind kind res_case.kind with
|
|
| None ->
|
|
None
|
|
| Some Eq ->
|
|
Some
|
|
(Manager_operation_result
|
|
{op with operation_result = Skipped kind}) )
|
|
| Contents_result
|
|
(Manager_operation_result
|
|
({operation_result = Failed (kind, errs); _} as op)) -> (
|
|
match equal_manager_kind kind res_case.kind with
|
|
| None ->
|
|
None
|
|
| Some Eq ->
|
|
Some
|
|
(Manager_operation_result
|
|
{op with operation_result = Failed (kind, errs)}) )
|
|
| Contents_result Ballot_result ->
|
|
None
|
|
| Contents_result (Endorsement_result _) ->
|
|
None
|
|
| Contents_result (Seed_nonce_revelation_result _) ->
|
|
None
|
|
| Contents_result (Double_endorsement_evidence_result _) ->
|
|
None
|
|
| Contents_result (Double_baking_evidence_result _) ->
|
|
None
|
|
| Contents_result (Activate_account_result _) ->
|
|
None
|
|
| Contents_result Proposals_result ->
|
|
None);
|
|
mselect;
|
|
proj =
|
|
(fun (Manager_operation_result
|
|
{ balance_updates = bus;
|
|
operation_result = r;
|
|
internal_operation_results = rs }) ->
|
|
(bus, r, rs));
|
|
inj =
|
|
(fun (bus, r, rs) ->
|
|
Manager_operation_result
|
|
{
|
|
balance_updates = bus;
|
|
operation_result = r;
|
|
internal_operation_results = rs;
|
|
});
|
|
}
|
|
|
|
let reveal_case =
|
|
make_manager_case
|
|
Operation.Encoding.reveal_case
|
|
Manager_result.reveal_case
|
|
(function
|
|
| Contents_and_result
|
|
((Manager_operation {operation = Reveal _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
|
|
let transaction_case =
|
|
make_manager_case
|
|
Operation.Encoding.transaction_case
|
|
Manager_result.transaction_case
|
|
(function
|
|
| Contents_and_result
|
|
((Manager_operation {operation = Transaction _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
|
|
let origination_case =
|
|
make_manager_case
|
|
Operation.Encoding.origination_case
|
|
Manager_result.origination_case
|
|
(function
|
|
| Contents_and_result
|
|
((Manager_operation {operation = Origination _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
|
|
let delegation_case =
|
|
make_manager_case
|
|
Operation.Encoding.delegation_case
|
|
Manager_result.delegation_case
|
|
(function
|
|
| Contents_and_result
|
|
((Manager_operation {operation = Delegation _; _} as op), res) ->
|
|
Some (op, res)
|
|
| _ ->
|
|
None)
|
|
end
|
|
|
|
let contents_result_encoding =
|
|
let open Encoding in
|
|
let make
|
|
(Case
|
|
{ op_case = Operation.Encoding.Case {tag; name; _};
|
|
encoding;
|
|
mselect = _;
|
|
select;
|
|
proj;
|
|
inj }) =
|
|
let proj x =
|
|
match select x with None -> None | Some x -> Some (proj x)
|
|
in
|
|
let inj x = Contents_result (inj x) in
|
|
tagged_case (Tag tag) name encoding proj inj
|
|
in
|
|
def "operation.alpha.contents_result"
|
|
@@ union
|
|
[ make endorsement_case;
|
|
make seed_nonce_revelation_case;
|
|
make double_endorsement_evidence_case;
|
|
make double_baking_evidence_case;
|
|
make activate_account_case;
|
|
make proposals_case;
|
|
make ballot_case;
|
|
make reveal_case;
|
|
make transaction_case;
|
|
make origination_case;
|
|
make delegation_case ]
|
|
|
|
let contents_and_result_encoding =
|
|
let open Encoding in
|
|
let make
|
|
(Case
|
|
{ op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
|
|
mselect;
|
|
encoding = meta_encoding;
|
|
proj = meta_proj;
|
|
inj = meta_inj;
|
|
_ }) =
|
|
let proj c =
|
|
match mselect c with
|
|
| Some (op, res) ->
|
|
Some (proj op, meta_proj res)
|
|
| _ ->
|
|
None
|
|
in
|
|
let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
|
|
let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
|
|
tagged_case (Tag tag) name encoding proj inj
|
|
in
|
|
def "operation.alpha.operation_contents_and_result"
|
|
@@ union
|
|
[ make endorsement_case;
|
|
make seed_nonce_revelation_case;
|
|
make double_endorsement_evidence_case;
|
|
make double_baking_evidence_case;
|
|
make activate_account_case;
|
|
make proposals_case;
|
|
make ballot_case;
|
|
make reveal_case;
|
|
make transaction_case;
|
|
make origination_case;
|
|
make delegation_case ]
|
|
|
|
type 'kind contents_result_list =
|
|
| Single_result : 'kind contents_result -> 'kind contents_result_list
|
|
| Cons_result :
|
|
'kind Kind.manager contents_result
|
|
* 'rest Kind.manager contents_result_list
|
|
-> ('kind * 'rest) Kind.manager contents_result_list
|
|
|
|
type packed_contents_result_list =
|
|
| Contents_result_list :
|
|
'kind contents_result_list
|
|
-> packed_contents_result_list
|
|
|
|
let contents_result_list_encoding =
|
|
let rec to_list = function
|
|
| Contents_result_list (Single_result o) ->
|
|
[Contents_result o]
|
|
| Contents_result_list (Cons_result (o, os)) ->
|
|
Contents_result o :: to_list (Contents_result_list os)
|
|
in
|
|
let rec of_list = function
|
|
| [] ->
|
|
Pervasives.failwith "cannot decode empty operation result"
|
|
| [Contents_result o] ->
|
|
Contents_result_list (Single_result o)
|
|
| Contents_result o :: os -> (
|
|
let (Contents_result_list os) = of_list os in
|
|
match (o, os) with
|
|
| ( Manager_operation_result _,
|
|
Single_result (Manager_operation_result _) ) ->
|
|
Contents_result_list (Cons_result (o, os))
|
|
| (Manager_operation_result _, Cons_result _) ->
|
|
Contents_result_list (Cons_result (o, os))
|
|
| _ ->
|
|
Pervasives.failwith "cannot decode ill-formed operation result" )
|
|
in
|
|
def "operation.alpha.contents_list_result"
|
|
@@ conv to_list of_list (list contents_result_encoding)
|
|
|
|
type 'kind contents_and_result_list =
|
|
| Single_and_result :
|
|
'kind Alpha_context.contents * 'kind contents_result
|
|
-> 'kind contents_and_result_list
|
|
| Cons_and_result :
|
|
'kind Kind.manager Alpha_context.contents
|
|
* 'kind Kind.manager contents_result
|
|
* 'rest Kind.manager contents_and_result_list
|
|
-> ('kind * 'rest) Kind.manager contents_and_result_list
|
|
|
|
type packed_contents_and_result_list =
|
|
| Contents_and_result_list :
|
|
'kind contents_and_result_list
|
|
-> packed_contents_and_result_list
|
|
|
|
let contents_and_result_list_encoding =
|
|
let rec to_list = function
|
|
| Contents_and_result_list (Single_and_result (op, res)) ->
|
|
[Contents_and_result (op, res)]
|
|
| Contents_and_result_list (Cons_and_result (op, res, rest)) ->
|
|
Contents_and_result (op, res)
|
|
:: to_list (Contents_and_result_list rest)
|
|
in
|
|
let rec of_list = function
|
|
| [] ->
|
|
Pervasives.failwith "cannot decode empty combined operation result"
|
|
| [Contents_and_result (op, res)] ->
|
|
Contents_and_result_list (Single_and_result (op, res))
|
|
| Contents_and_result (op, res) :: rest -> (
|
|
let (Contents_and_result_list rest) = of_list rest in
|
|
match (op, rest) with
|
|
| (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
|
|
Contents_and_result_list (Cons_and_result (op, res, rest))
|
|
| (Manager_operation _, Cons_and_result (_, _, _)) ->
|
|
Contents_and_result_list (Cons_and_result (op, res, rest))
|
|
| _ ->
|
|
Pervasives.failwith
|
|
"cannot decode ill-formed combined operation result" )
|
|
in
|
|
conv to_list of_list (Variable.list contents_and_result_encoding)
|
|
|
|
type 'kind operation_metadata = {contents : 'kind contents_result_list}
|
|
|
|
type packed_operation_metadata =
|
|
| Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
|
|
| No_operation_metadata : packed_operation_metadata
|
|
|
|
let operation_metadata_encoding =
|
|
def "operation.alpha.result"
|
|
@@ union
|
|
[ case
|
|
(Tag 0)
|
|
~title:"Operation_metadata"
|
|
contents_result_list_encoding
|
|
(function
|
|
| Operation_metadata {contents} ->
|
|
Some (Contents_result_list contents)
|
|
| _ ->
|
|
None)
|
|
(fun (Contents_result_list contents) ->
|
|
Operation_metadata {contents});
|
|
case
|
|
(Tag 1)
|
|
~title:"No_operation_metadata"
|
|
empty
|
|
(function No_operation_metadata -> Some () | _ -> None)
|
|
(fun () -> No_operation_metadata) ]
|
|
|
|
let kind_equal :
|
|
type kind kind2.
|
|
kind contents -> kind2 contents_result -> (kind, kind2) eq option =
|
|
fun op res ->
|
|
match (op, res) with
|
|
| (Endorsement _, Endorsement_result _) ->
|
|
Some Eq
|
|
| (Endorsement _, _) ->
|
|
None
|
|
| (Seed_nonce_revelation _, Seed_nonce_revelation_result _) ->
|
|
Some Eq
|
|
| (Seed_nonce_revelation _, _) ->
|
|
None
|
|
| (Double_endorsement_evidence _, Double_endorsement_evidence_result _) ->
|
|
Some Eq
|
|
| (Double_endorsement_evidence _, _) ->
|
|
None
|
|
| (Double_baking_evidence _, Double_baking_evidence_result _) ->
|
|
Some Eq
|
|
| (Double_baking_evidence _, _) ->
|
|
None
|
|
| (Activate_account _, Activate_account_result _) ->
|
|
Some Eq
|
|
| (Activate_account _, _) ->
|
|
None
|
|
| (Proposals _, Proposals_result) ->
|
|
Some Eq
|
|
| (Proposals _, _) ->
|
|
None
|
|
| (Ballot _, Ballot_result) ->
|
|
Some Eq
|
|
| (Ballot _, _) ->
|
|
None
|
|
| ( Manager_operation {operation = Reveal _; _},
|
|
Manager_operation_result {operation_result = Applied (Reveal_result _); _}
|
|
) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Reveal _; _},
|
|
Manager_operation_result
|
|
{operation_result = Backtracked (Reveal_result _, _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Reveal _; _},
|
|
Manager_operation_result
|
|
{ operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);
|
|
_ } ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Reveal _; _},
|
|
Manager_operation_result
|
|
{operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _}
|
|
) ->
|
|
Some Eq
|
|
| (Manager_operation {operation = Reveal _; _}, _) ->
|
|
None
|
|
| ( Manager_operation {operation = Transaction _; _},
|
|
Manager_operation_result
|
|
{operation_result = Applied (Transaction_result _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Transaction _; _},
|
|
Manager_operation_result
|
|
{operation_result = Backtracked (Transaction_result _, _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Transaction _; _},
|
|
Manager_operation_result
|
|
{ operation_result =
|
|
Failed (Alpha_context.Kind.Transaction_manager_kind, _);
|
|
_ } ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Transaction _; _},
|
|
Manager_operation_result
|
|
{ operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;
|
|
_ } ) ->
|
|
Some Eq
|
|
| (Manager_operation {operation = Transaction _; _}, _) ->
|
|
None
|
|
| ( Manager_operation {operation = Origination _; _},
|
|
Manager_operation_result
|
|
{operation_result = Applied (Origination_result _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Origination _; _},
|
|
Manager_operation_result
|
|
{operation_result = Backtracked (Origination_result _, _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Origination _; _},
|
|
Manager_operation_result
|
|
{ operation_result =
|
|
Failed (Alpha_context.Kind.Origination_manager_kind, _);
|
|
_ } ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Origination _; _},
|
|
Manager_operation_result
|
|
{ operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;
|
|
_ } ) ->
|
|
Some Eq
|
|
| (Manager_operation {operation = Origination _; _}, _) ->
|
|
None
|
|
| ( Manager_operation {operation = Delegation _; _},
|
|
Manager_operation_result
|
|
{operation_result = Applied (Delegation_result _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Delegation _; _},
|
|
Manager_operation_result
|
|
{operation_result = Backtracked (Delegation_result _, _); _} ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Delegation _; _},
|
|
Manager_operation_result
|
|
{ operation_result =
|
|
Failed (Alpha_context.Kind.Delegation_manager_kind, _);
|
|
_ } ) ->
|
|
Some Eq
|
|
| ( Manager_operation {operation = Delegation _; _},
|
|
Manager_operation_result
|
|
{ operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;
|
|
_ } ) ->
|
|
Some Eq
|
|
| (Manager_operation {operation = Delegation _; _}, _) ->
|
|
None
|
|
|
|
let rec kind_equal_list :
|
|
type kind kind2.
|
|
kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option
|
|
=
|
|
fun contents res ->
|
|
match (contents, res) with
|
|
| (Single op, Single_result res) -> (
|
|
match kind_equal op res with None -> None | Some Eq -> Some Eq )
|
|
| (Cons (op, ops), Cons_result (res, ress)) -> (
|
|
match kind_equal op res with
|
|
| None ->
|
|
None
|
|
| Some Eq -> (
|
|
match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) )
|
|
| _ ->
|
|
None
|
|
|
|
let rec pack_contents_list :
|
|
type kind.
|
|
kind contents_list ->
|
|
kind contents_result_list ->
|
|
kind contents_and_result_list =
|
|
fun contents res ->
|
|
match (contents, res) with
|
|
| (Single op, Single_result res) ->
|
|
Single_and_result (op, res)
|
|
| (Cons (op, ops), Cons_result (res, ress)) ->
|
|
Cons_and_result (op, res, pack_contents_list ops ress)
|
|
| ( Single (Manager_operation _),
|
|
Cons_result (Manager_operation_result _, Single_result _) ) ->
|
|
.
|
|
| ( Cons (_, _),
|
|
Single_result (Manager_operation_result {operation_result = Failed _; _})
|
|
) ->
|
|
.
|
|
| ( Cons (_, _),
|
|
Single_result
|
|
(Manager_operation_result {operation_result = Skipped _; _}) ) ->
|
|
.
|
|
| ( Cons (_, _),
|
|
Single_result
|
|
(Manager_operation_result {operation_result = Applied _; _}) ) ->
|
|
.
|
|
| ( Cons (_, _),
|
|
Single_result
|
|
(Manager_operation_result {operation_result = Backtracked _; _}) ) ->
|
|
.
|
|
| (Single _, Cons_result _) ->
|
|
.
|
|
|
|
let rec unpack_contents_list :
|
|
type kind.
|
|
kind contents_and_result_list ->
|
|
kind contents_list * kind contents_result_list = function
|
|
| Single_and_result (op, res) ->
|
|
(Single op, Single_result res)
|
|
| Cons_and_result (op, res, rest) ->
|
|
let (ops, ress) = unpack_contents_list rest in
|
|
(Cons (op, ops), Cons_result (res, ress))
|
|
|
|
let rec to_list = function
|
|
| Contents_result_list (Single_result o) ->
|
|
[Contents_result o]
|
|
| Contents_result_list (Cons_result (o, os)) ->
|
|
Contents_result o :: to_list (Contents_result_list os)
|
|
|
|
let rec of_list = function
|
|
| [] ->
|
|
assert false
|
|
| [Contents_result o] ->
|
|
Contents_result_list (Single_result o)
|
|
| Contents_result o :: os -> (
|
|
let (Contents_result_list os) = of_list os in
|
|
match (o, os) with
|
|
| (Manager_operation_result _, Single_result (Manager_operation_result _))
|
|
->
|
|
Contents_result_list (Cons_result (o, os))
|
|
| (Manager_operation_result _, Cons_result _) ->
|
|
Contents_result_list (Cons_result (o, os))
|
|
| _ ->
|
|
Pervasives.failwith
|
|
"Operation result list of length > 1 should only contains manager \
|
|
operations result." )
|
|
|
|
let operation_data_and_metadata_encoding =
|
|
def "operation.alpha.operation_with_metadata"
|
|
@@ union
|
|
[ case
|
|
(Tag 0)
|
|
~title:"Operation_with_metadata"
|
|
(obj2
|
|
(req "contents" (dynamic_size contents_and_result_list_encoding))
|
|
(opt "signature" Signature.encoding))
|
|
(function
|
|
| (Operation_data _, No_operation_metadata) ->
|
|
None
|
|
| (Operation_data op, Operation_metadata res) -> (
|
|
match kind_equal_list op.contents res.contents with
|
|
| None ->
|
|
Pervasives.failwith
|
|
"cannot decode inconsistent combined operation result"
|
|
| Some Eq ->
|
|
Some
|
|
( Contents_and_result_list
|
|
(pack_contents_list op.contents res.contents),
|
|
op.signature ) ))
|
|
(fun (Contents_and_result_list contents, signature) ->
|
|
let (op_contents, res_contents) = unpack_contents_list contents in
|
|
( Operation_data {contents = op_contents; signature},
|
|
Operation_metadata {contents = res_contents} ));
|
|
case
|
|
(Tag 1)
|
|
~title:"Operation_without_metadata"
|
|
(obj2
|
|
(req "contents" (dynamic_size Operation.contents_list_encoding))
|
|
(opt "signature" Signature.encoding))
|
|
(function
|
|
| (Operation_data op, No_operation_metadata) ->
|
|
Some (Contents_list op.contents, op.signature)
|
|
| (Operation_data _, Operation_metadata _) ->
|
|
None)
|
|
(fun (Contents_list contents, signature) ->
|
|
(Operation_data {contents; signature}, No_operation_metadata)) ]
|
|
|
|
type block_metadata = {
|
|
baker : Signature.Public_key_hash.t;
|
|
level : Level.t;
|
|
voting_period_kind : Voting_period.kind;
|
|
nonce_hash : Nonce_hash.t option;
|
|
consumed_gas : Z.t;
|
|
deactivated : Signature.Public_key_hash.t list;
|
|
balance_updates : Delegate.balance_updates;
|
|
}
|
|
|
|
let block_metadata_encoding =
|
|
let open Data_encoding in
|
|
def "block_header.alpha.metadata"
|
|
@@ conv
|
|
(fun { baker;
|
|
level;
|
|
voting_period_kind;
|
|
nonce_hash;
|
|
consumed_gas;
|
|
deactivated;
|
|
balance_updates } ->
|
|
( baker,
|
|
level,
|
|
voting_period_kind,
|
|
nonce_hash,
|
|
consumed_gas,
|
|
deactivated,
|
|
balance_updates ))
|
|
(fun ( baker,
|
|
level,
|
|
voting_period_kind,
|
|
nonce_hash,
|
|
consumed_gas,
|
|
deactivated,
|
|
balance_updates ) ->
|
|
{
|
|
baker;
|
|
level;
|
|
voting_period_kind;
|
|
nonce_hash;
|
|
consumed_gas;
|
|
deactivated;
|
|
balance_updates;
|
|
})
|
|
(obj7
|
|
(req "baker" Signature.Public_key_hash.encoding)
|
|
(req "level" Level.encoding)
|
|
(req "voting_period_kind" Voting_period.kind_encoding)
|
|
(req "nonce_hash" (option Nonce_hash.encoding))
|
|
(req "consumed_gas" (check_size 10 n))
|
|
(req "deactivated" (list Signature.Public_key_hash.encoding))
|
|
(req "balance_updates" Delegate.balance_updates_encoding))
|