receipt_repr.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
module Token = struct
type 'token t =
| Tez : Tez_repr.t t
| Staking_pseudotoken : Staking_pseudotoken_repr.t t
let eq :
type token1 token2.
token1 t -> token2 t -> (token1, token2) Equality_witness.eq option =
fun t1 t2 ->
match (t1, t2) with
| Tez, Tez -> Some Refl
| Tez, _ | _, Tez -> None
| Staking_pseudotoken, Staking_pseudotoken -> Some Refl
let equal : type token. token t -> token -> token -> bool = function
| Tez -> Tez_repr.( = )
| Staking_pseudotoken -> Staking_pseudotoken_repr.( = )
let is_zero : type token. token t -> token -> bool =
fun token t ->
match token with
| Tez -> Tez_repr.(t = zero)
| Staking_pseudotoken -> Staking_pseudotoken_repr.(t = zero)
let le : type token. token t -> token -> token -> bool = function
| Tez -> Tez_repr.( <= )
| Staking_pseudotoken -> Staking_pseudotoken_repr.( <= )
let add : type token. token t -> token -> token -> token tzresult = function
| Tez -> Tez_repr.( +? )
| Staking_pseudotoken -> Staking_pseudotoken_repr.( +? )
let sub : type token. token t -> token -> token -> token tzresult = function
| Tez -> Tez_repr.( -? )
| Staking_pseudotoken -> Staking_pseudotoken_repr.( -? )
let pp_tez =
let tez_sym = "\xEA\x9C\xA9" in
fun ppf tez -> Format.fprintf ppf "%s%a" tez_sym Tez_repr.pp tez
let pp : type token. token t -> Format.formatter -> token -> unit = function
| Tez -> pp_tez
| Staking_pseudotoken -> Staking_pseudotoken_repr.pp
end
type 'token balance =
| Contract : Contract_repr.t -> Tez_repr.t balance
| Block_fees : Tez_repr.t balance
| Deposits : Frozen_staker_repr.t -> Tez_repr.t balance
| Unstaked_deposits :
Unstaked_frozen_staker_repr.t * Cycle_repr.t
-> Tez_repr.t balance
| Nonce_revelation_rewards : Tez_repr.t balance
| Attesting_rewards : Tez_repr.t balance
| Baking_rewards : Tez_repr.t balance
| Baking_bonuses : Tez_repr.t balance
| Storage_fees : Tez_repr.t balance
| Double_signing_punishments : Tez_repr.t balance
| Lost_attesting_rewards :
Signature.Public_key_hash.t * bool * bool
-> Tez_repr.t balance
| Liquidity_baking_subsidies : Tez_repr.t balance
| Burned : Tez_repr.t balance
| Commitments : Blinded_public_key_hash.t -> Tez_repr.t balance
| Bootstrap : Tez_repr.t balance
| Invoice : Tez_repr.t balance
| Initial_commitments : Tez_repr.t balance
| Minted : Tez_repr.t balance
| Frozen_bonds : Contract_repr.t * Bond_id_repr.t -> Tez_repr.t balance
| Sc_rollup_refutation_punishments : Tez_repr.t balance
| Sc_rollup_refutation_rewards : Tez_repr.t balance
| Staking_delegator_numerator : {
delegator : Contract_repr.t;
}
-> Staking_pseudotoken_repr.t balance
| Staking_delegate_denominator : {
delegate : Signature.public_key_hash;
}
-> Staking_pseudotoken_repr.t balance
let token_of_balance : type token. token balance -> token Token.t = function
| Contract _ -> Token.Tez
| Block_fees -> Token.Tez
| Deposits _ -> Token.Tez
| Unstaked_deposits _ -> Token.Tez
| Nonce_revelation_rewards -> Token.Tez
| Attesting_rewards -> Token.Tez
| Baking_rewards -> Token.Tez
| Baking_bonuses -> Token.Tez
| Storage_fees -> Token.Tez
| Double_signing_punishments -> Token.Tez
| Lost_attesting_rewards _ -> Token.Tez
| Liquidity_baking_subsidies -> Token.Tez
| Burned -> Token.Tez
| Commitments _ -> Token.Tez
| Bootstrap -> Token.Tez
| Invoice -> Token.Tez
| Initial_commitments -> Token.Tez
| Minted -> Token.Tez
| Frozen_bonds _ -> Token.Tez
| Sc_rollup_refutation_punishments -> Token.Tez
| Sc_rollup_refutation_rewards -> Token.Tez
| Staking_delegator_numerator _ -> Token.Staking_pseudotoken
| Staking_delegate_denominator _ -> Token.Staking_pseudotoken
let is_not_zero c = not (Compare.Int.equal c 0)
let compare_balance :
type token1 token2. token1 balance -> token2 balance -> int =
fun ba bb ->
match (ba, bb) with
| Contract ca, Contract cb -> Contract_repr.compare ca cb
| Deposits sa, Deposits sb -> Frozen_staker_repr.compare sa sb
| Unstaked_deposits (sa, ca), Unstaked_deposits (sb, cb) ->
Compare.or_else (Unstaked_frozen_staker_repr.compare sa sb) (fun () ->
Cycle_repr.compare ca cb)
| Lost_attesting_rewards (pkha, pa, ra), Lost_attesting_rewards (pkhb, pb, rb)
->
let c = Signature.Public_key_hash.compare pkha pkhb in
if is_not_zero c then c
else
let c = Compare.Bool.compare pa pb in
if is_not_zero c then c else Compare.Bool.compare ra rb
| Commitments bpkha, Commitments bpkhb ->
Blinded_public_key_hash.compare bpkha bpkhb
| Frozen_bonds (ca, ra), Frozen_bonds (cb, rb) ->
let c = Contract_repr.compare ca cb in
if is_not_zero c then c else Bond_id_repr.compare ra rb
| ( Staking_delegator_numerator {delegator = ca},
Staking_delegator_numerator {delegator = cb} ) ->
Contract_repr.compare ca cb
| ( Staking_delegate_denominator {delegate = pkha},
Staking_delegate_denominator {delegate = pkhb} ) ->
Signature.Public_key_hash.compare pkha pkhb
| _, _ ->
let index : type token. token balance -> int = function
| Contract _ -> 0
| Block_fees -> 1
| Deposits _ -> 2
| Unstaked_deposits _ -> 3
| Nonce_revelation_rewards -> 4
| Attesting_rewards -> 5
| Baking_rewards -> 6
| Baking_bonuses -> 7
| Storage_fees -> 8
| Double_signing_punishments -> 9
| Lost_attesting_rewards _ -> 10
| Liquidity_baking_subsidies -> 11
| Burned -> 12
| Commitments _ -> 13
| Bootstrap -> 14
| Invoice -> 15
| Initial_commitments -> 16
| Minted -> 17
| Frozen_bonds _ -> 18
| Sc_rollup_refutation_punishments -> 19
| Sc_rollup_refutation_rewards -> 20
| Staking_delegator_numerator _ -> 21
| Staking_delegate_denominator _ -> 22
(* don't forget to add parameterized cases in the first part of the function *)
in
Compare.Int.compare (index ba) (index bb)
type 'token balance_update = Debited of 'token | Credited of 'token
type balance_and_update =
| Ex_token : 'token balance * 'token balance_update -> balance_and_update
let is_zero_update : type token. token Token.t -> token balance_update -> bool =
fun token -> function Debited t | Credited t -> Token.is_zero token t
let conv_balance_update encoding =
Data_encoding.conv
(function Credited v -> `Credited v | Debited v -> `Debited v)
(function `Credited v -> Credited v | `Debited v -> Debited v)
encoding
let tez_balance_update_encoding =
let open Data_encoding in
def "operation_metadata.alpha.tez_balance_update"
@@ obj1 (req "change" (conv_balance_update Tez_repr.balance_update_encoding))
let staking_pseudotoken_balance_update_encoding =
let open Data_encoding in
def "operation_metadata.alpha.staking_abstract_quantity"
@@ obj1
(req
"change"
(conv_balance_update Staking_pseudotoken_repr.balance_update_encoding))
let balance_and_update_encoding ~use_legacy_attestation_name =
let open Data_encoding in
let case = function
| Tag tag ->
(* The tag was used by old variant. It have been removed in
protocol proposal O, it can be unblocked in the future. *)
let tx_rollup_reserved_tag = [22; 23] in
assert (
not @@ List.exists (Compare.Int.equal tag) tx_rollup_reserved_tag) ;
case (Tag tag)
| _ as c -> case c
in
let tez_case ~title tag enc (proj : Tez_repr.t balance -> _ option) inj =
case
~title
tag
(merge_objs enc tez_balance_update_encoding)
(fun (Ex_token (balance, update)) ->
match token_of_balance balance with
| Tez -> proj balance |> Option.map (fun x -> (x, update))
| _ -> None)
(fun (x, update) -> Ex_token (inj x, update))
in
let staking_pseudotoken_case ~title tag enc
(proj : Staking_pseudotoken_repr.t balance -> _ option) inj =
case
~title
tag
(merge_objs enc staking_pseudotoken_balance_update_encoding)
(fun (Ex_token (balance, update)) ->
match token_of_balance balance with
| Staking_pseudotoken ->
proj balance |> Option.map (fun x -> (x, update))
| _ -> None)
(fun (x, update) -> Ex_token (inj x, update))
in
def
(if use_legacy_attestation_name then
"operation_metadata_with_legacy_attestation_name.alpha.balance_and_update"
else "operation_metadata.alpha.balance_and_update")
@@ union
[
tez_case
(Tag 0)
~title:"Contract"
(obj2
(req "kind" (constant "contract"))
(req "contract" Contract_repr.encoding))
(function Contract c -> Some ((), c) | _ -> None)
(fun ((), c) -> Contract c);
tez_case
(Tag 2)
~title:"Block_fees"
(obj2
(req "kind" (constant "accumulator"))
(req "category" (constant "block fees")))
(function Block_fees -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Block_fees);
tez_case
(Tag 4)
~title:"Deposits"
(obj3
(req "kind" (constant "freezer"))
(req "category" (constant "deposits"))
(req "staker" Frozen_staker_repr.encoding))
(function Deposits staker -> Some ((), (), staker) | _ -> None)
(fun ((), (), staker) -> Deposits staker);
tez_case
(Tag 5)
~title:"Nonce_revelation_rewards"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "nonce revelation rewards")))
(function Nonce_revelation_rewards -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Nonce_revelation_rewards);
(* 6 was for Double_signing_evidence_rewards that has been removed.
https://gitlab.com/tezos/tezos/-/merge_requests/7758 *)
tez_case
(Tag 7)
~title:
(if use_legacy_attestation_name then "Endorsing_rewards"
else "Attesting_rewards")
(obj2
(req "kind" (constant "minted"))
(req
"category"
(constant
(if use_legacy_attestation_name then "endorsing rewards"
else "attesting rewards"))))
(function Attesting_rewards -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Attesting_rewards);
tez_case
(Tag 8)
~title:"Baking_rewards"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "baking rewards")))
(function Baking_rewards -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Baking_rewards);
tez_case
(Tag 9)
~title:"Baking_bonuses"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "baking bonuses")))
(function Baking_bonuses -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Baking_bonuses);
tez_case
(Tag 11)
~title:"Storage_fees"
(obj2
(req "kind" (constant "burned"))
(req "category" (constant "storage fees")))
(function Storage_fees -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Storage_fees);
tez_case
(Tag 12)
~title:"Double_signing_punishments"
(obj2
(req "kind" (constant "burned"))
(req "category" (constant "punishments")))
(function Double_signing_punishments -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Double_signing_punishments);
tez_case
(Tag 13)
~title:
(if use_legacy_attestation_name then "Lost_endorsing_rewards"
else "Lost_attesting_rewards")
(obj5
(req "kind" (constant "burned"))
(req
"category"
(constant
(if use_legacy_attestation_name then
"lost endorsing rewards"
else "lost attesting rewards")))
(req "delegate" Signature.Public_key_hash.encoding)
(req "participation" Data_encoding.bool)
(req "revelation" Data_encoding.bool))
(function
| Lost_attesting_rewards (d, p, r) -> Some ((), (), d, p, r)
| _ -> None)
(fun ((), (), d, p, r) -> Lost_attesting_rewards (d, p, r));
tez_case
(Tag 14)
~title:"Liquidity_baking_subsidies"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "subsidy")))
(function Liquidity_baking_subsidies -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Liquidity_baking_subsidies);
tez_case
(Tag 15)
~title:"Burned"
(obj2
(req "kind" (constant "burned"))
(req "category" (constant "burned")))
(function Burned -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Burned);
tez_case
(Tag 16)
~title:"Commitments"
(obj3
(req "kind" (constant "commitment"))
(req "category" (constant "commitment"))
(req "committer" Blinded_public_key_hash.encoding))
(function Commitments bpkh -> Some ((), (), bpkh) | _ -> None)
(fun ((), (), bpkh) -> Commitments bpkh);
tez_case
(Tag 17)
~title:"Bootstrap"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "bootstrap")))
(function Bootstrap -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Bootstrap);
tez_case
(Tag 18)
~title:"Invoice"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "invoice")))
(function Invoice -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Invoice);
tez_case
(Tag 19)
~title:"Initial_commitments"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "commitment")))
(function Initial_commitments -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Initial_commitments);
tez_case
(Tag 20)
~title:"Minted"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "minted")))
(function Minted -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Minted);
tez_case
(Tag 21)
~title:"Frozen_bonds"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "bonds"))
(req "contract" Contract_repr.encoding)
(req "bond_id" Bond_id_repr.encoding))
(function Frozen_bonds (c, r) -> Some ((), (), c, r) | _ -> None)
(fun ((), (), c, r) -> Frozen_bonds (c, r));
tez_case
(Tag 24)
~title:"Smart_rollup_refutation_punishments"
(obj2
(req "kind" (constant "burned"))
(req "category" (constant "smart_rollup_refutation_punishments")))
(function
| Sc_rollup_refutation_punishments -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Sc_rollup_refutation_punishments);
tez_case
(Tag 25)
~title:"Smart_rollup_refutation_rewards"
(obj2
(req "kind" (constant "minted"))
(req "category" (constant "smart_rollup_refutation_rewards")))
(function
| Sc_rollup_refutation_rewards -> Some ((), ()) | _ -> None)
(fun ((), ()) -> Sc_rollup_refutation_rewards);
tez_case
(Tag 26)
~title:"Unstaked_deposits"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "unstaked_deposits"))
(req "staker" Unstaked_frozen_staker_repr.encoding)
(req "cycle" Cycle_repr.encoding))
(function
| Unstaked_deposits (staker, cycle) -> Some ((), (), staker, cycle)
| _ -> None)
(fun ((), (), staker, cycle) -> Unstaked_deposits (staker, cycle));
staking_pseudotoken_case
(Tag 27)
~title:"Staking_delegator_numerator"
(obj3
(req "kind" (constant "staking"))
(req "category" (constant "delegator_numerator"))
(req "delegator" Contract_repr.encoding))
(function
| Staking_delegator_numerator {delegator} ->
Some ((), (), delegator)
| _ -> None)
(fun ((), (), delegator) -> Staking_delegator_numerator {delegator});
staking_pseudotoken_case
(Tag 28)
~title:"Staking_delegate_denominator"
(obj3
(req "kind" (constant "staking"))
(req "category" (constant "delegate_denominator"))
(req "delegate" Signature.Public_key_hash.encoding))
(function
| Staking_delegate_denominator {delegate} -> Some ((), (), delegate)
| _ -> None)
(fun ((), (), delegate) -> Staking_delegate_denominator {delegate});
]
let balance_and_update_encoding_with_legacy_attestation_name =
balance_and_update_encoding ~use_legacy_attestation_name:true
let balance_and_update_encoding =
balance_and_update_encoding ~use_legacy_attestation_name:false
type update_origin =
| Block_application
| Protocol_migration
| Subsidy
| Simulation
| Delayed_operation of {operation_hash : Operation_hash.t}
let compare_update_origin oa ob =
match (oa, ob) with
| ( Delayed_operation {operation_hash = oha},
Delayed_operation {operation_hash = ohb} ) ->
Operation_hash.compare oha ohb
| _, _ ->
let index o =
match o with
| Block_application -> 0
| Protocol_migration -> 1
| Subsidy -> 2
| Simulation -> 3
| Delayed_operation _ -> 4
(* don't forget to add parameterized cases in the first part of the function *)
in
Compare.Int.compare (index oa) (index ob)
let update_origin_encoding =
let open Data_encoding in
def "operation_metadata.alpha.update_origin"
@@ union
[
case
(Tag 0)
~title:"Block_application"
(obj1 (req "origin" (constant "block")))
(function Block_application -> Some () | _ -> None)
(fun () -> Block_application);
case
(Tag 1)
~title:"Protocol_migration"
(obj1 (req "origin" (constant "migration")))
(function Protocol_migration -> Some () | _ -> None)
(fun () -> Protocol_migration);
case
(Tag 2)
~title:"Subsidy"
(obj1 (req "origin" (constant "subsidy")))
(function Subsidy -> Some () | _ -> None)
(fun () -> Subsidy);
case
(Tag 3)
~title:"Simulation"
(obj1 (req "origin" (constant "simulation")))
(function Simulation -> Some () | _ -> None)
(fun () -> Simulation);
case
(Tag 4)
~title:"Delayed_operation"
(obj2
(req "origin" (constant "delayed_operation"))
(req "delayed_operation_hash" Operation_hash.encoding))
(function
| Delayed_operation {operation_hash} -> Some ((), operation_hash)
| _ -> None)
(fun ((), operation_hash) -> Delayed_operation {operation_hash});
]
type balance_update_item =
| Balance_update_item :
'token balance * 'token balance_update * update_origin
-> balance_update_item
let item balance balance_update update_origin =
Balance_update_item (balance, balance_update, update_origin)
let item_encoding_with_legacy_attestation_name =
let open Data_encoding in
conv
(function
| Balance_update_item (balance, balance_update, update_origin) ->
(Ex_token (balance, balance_update), update_origin))
(fun (Ex_token (balance, balance_update), update_origin) ->
Balance_update_item (balance, balance_update, update_origin))
(merge_objs
balance_and_update_encoding_with_legacy_attestation_name
update_origin_encoding)
let item_encoding =
let open Data_encoding in
conv
(function
| Balance_update_item (balance, balance_update, update_origin) ->
(Ex_token (balance, balance_update), update_origin))
(fun (Ex_token (balance, balance_update), update_origin) ->
Balance_update_item (balance, balance_update, update_origin))
(merge_objs balance_and_update_encoding update_origin_encoding)
type balance_updates = balance_update_item list
let balance_updates_encoding_with_legacy_attestation_name =
let open Data_encoding in
def "operation_metadata_with_legacy_attestation_name.alpha.balance_updates"
@@ list item_encoding_with_legacy_attestation_name
let balance_updates_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_updates" @@ list item_encoding
module MakeBalanceMap (T : sig
type token
end) =
struct
include Map.Make (struct
type t = T.token balance * update_origin
let compare (ba, ua) (bb, ub) =
let c = compare_balance ba bb in
if is_not_zero c then c else compare_update_origin ua ub
end)
let update_r key (f : 'a option -> 'b option tzresult) map =
let open Result_syntax in
let* v_opt = f (find key map) in
match v_opt with
| Some v -> return (add key v map)
| None -> return (remove key map)
end
module TezBalanceMap = MakeBalanceMap (struct
type token = Tez_repr.t
end)
module StakingPseudotokenMap = MakeBalanceMap (struct
type token = Staking_pseudotoken_repr.t
end)
type 'a balance_maps = {
tez : Tez_repr.t balance_update TezBalanceMap.t;
staking_pt : Staking_pseudotoken_repr.t balance_update StakingPseudotokenMap.t;
}
let group_balance_updates balance_updates =
let open Result_syntax in
let update_map token update_r key update map =
update_r
key
(function
| None -> return_some update
| Some balance -> (
match (balance, update) with
| Credited a, Debited b | Debited b, Credited a ->
(* Remove the binding since it just fell down to zero *)
if Token.equal token a b then return_none
else if Token.le token b a then
let* update = Token.sub token a b in
return_some (Credited update)
else
let* update = Token.sub token b a in
return_some (Debited update)
| Credited a, Credited b ->
let* update = Token.add token a b in
return_some (Credited update)
| Debited a, Debited b ->
let* update = Token.add token a b in
return_some (Debited update)))
map
in
let* {tez; staking_pt} =
List.fold_left_e
(fun acc (Balance_update_item (b, update, o)) ->
(* Do not do anything if the update is zero *)
let token = token_of_balance b in
if is_zero_update token update then return acc
else
match token with
| Tez ->
let+ tez =
update_map token TezBalanceMap.update_r (b, o) update acc.tez
in
{acc with tez}
| Staking_pseudotoken ->
let+ staking_pt =
update_map
token
StakingPseudotokenMap.update_r
(b, o)
update
acc.staking_pt
in
{acc with staking_pt})
{tez = TezBalanceMap.empty; staking_pt = StakingPseudotokenMap.empty}
balance_updates
in
return
(StakingPseudotokenMap.fold
(fun (b, o) u acc -> Balance_update_item (b, u, o) :: acc)
staking_pt
(TezBalanceMap.fold
(fun (b, o) u acc -> Balance_update_item (b, u, o) :: acc)
tez
[]))
