Source file token.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2020-2021 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type container =
  [ `Contract of Contract_repr.t
  | `Collected_commitments of Blinded_public_key_hash.t
  | `Delegate_balance of Signature.Public_key_hash.t
  | `Frozen_deposits of Signature.Public_key_hash.t
  | `Block_fees
  | `Legacy_deposits of Signature.Public_key_hash.t * Cycle_repr.t
  | `Legacy_fees of Signature.Public_key_hash.t * Cycle_repr.t
  | `Legacy_rewards of Signature.Public_key_hash.t * Cycle_repr.t ]

type source =
  [ `Invoice
  | `Bootstrap
  | `Initial_commitments
  | `Revelation_rewards
  | `Double_signing_evidence_rewards
  | `Endorsing_rewards
  | `Baking_rewards
  | `Baking_bonuses
  | `Minted
  | `Liquidity_baking_subsidies
  | container ]

type sink =
  [ `Storage_fees
  | `Double_signing_punishments
  | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
  | `Burned
  | container ]

let allocated ctxt stored =
  match stored with
  | `Contract contract -> Contract_storage.allocated ctxt contract
  | `Collected_commitments bpkh -> Commitment_storage.exists ctxt bpkh >|= ok
  | `Delegate_balance delegate ->
      let contract = Contract_repr.implicit_contract delegate in
      Contract_storage.allocated ctxt contract
  | `Frozen_deposits delegate ->
      let contract = Contract_repr.implicit_contract delegate in
      Frozen_deposits_storage.allocated ctxt contract >|= ok
  | `Block_fees -> return_true
  (* TODO: remove in J *)
  | `Legacy_deposits (delegate, cycle) ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Legacy_frozen_deposits.mem (ctxt, contract) cycle >|= ok
  | `Legacy_fees (delegate, cycle) ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Legacy_frozen_fees.mem (ctxt, contract) cycle >|= ok
  | `Legacy_rewards (delegate, cycle) ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Legacy_frozen_rewards.mem (ctxt, contract) cycle >|= ok

let balance ctxt stored =
  match stored with
  | `Contract contract -> Contract_storage.get_balance ctxt contract
  | `Collected_commitments bpkh -> Commitment_storage.committed_amount ctxt bpkh
  | `Delegate_balance delegate ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Balance.get ctxt contract
  | `Frozen_deposits delegate -> (
      let contract = Contract_repr.implicit_contract delegate in
      Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits ->
      match frozen_deposits with
      | None -> Tez_repr.zero
      | Some frozen_deposits -> frozen_deposits.current_amount)
  | `Block_fees -> return (Raw_context.get_collected_fees ctxt)
  (* TODO: remove in J *)
  | `Legacy_deposits (delegate, cycle) ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Legacy_frozen_deposits.find (ctxt, contract) cycle
      >|=? Option.value ~default:Tez_repr.zero
  | `Legacy_fees (delegate, cycle) ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Legacy_frozen_fees.find (ctxt, contract) cycle
      >|=? Option.value ~default:Tez_repr.zero
  | `Legacy_rewards (delegate, cycle) ->
      let contract = Contract_repr.implicit_contract delegate in
      Storage.Contract.Legacy_frozen_rewards.find (ctxt, contract) cycle
      >|=? Option.value ~default:Tez_repr.zero

let credit ctxt dest amount origin =
  let open Receipt_repr in
  (match dest with
  | `Storage_fees -> return (ctxt, Storage_fees)
  | `Double_signing_punishments -> return (ctxt, Double_signing_punishments)
  | `Lost_endorsing_rewards (d, p, r) ->
      return (ctxt, Lost_endorsing_rewards (d, p, r))
  | `Burned -> return (ctxt, Burned)
  | `Contract dest ->
      Contract_storage.credit_only_call_from_token ctxt dest amount
      >|=? fun ctxt -> (ctxt, Contract dest)
  | `Collected_commitments bpkh ->
      Commitment_storage.increase_commitment_only_call_from_token
        ctxt
        bpkh
        amount
      >|=? fun ctxt -> (ctxt, Commitments bpkh)
  | `Delegate_balance delegate ->
      let contract = Contract_repr.implicit_contract delegate in
      Contract_storage.increase_balance_only_call_from_token
        ctxt
        contract
        amount
      >|=? fun ctxt -> (ctxt, Contract contract)
  | `Frozen_deposits delegate as dest ->
      allocated ctxt dest >>=? fun allocated ->
      (if not allocated then Frozen_deposits_storage.init ctxt delegate
      else return ctxt)
      >>=? fun ctxt ->
      Frozen_deposits_storage.credit_only_call_from_token ctxt delegate amount
      >|=? fun ctxt -> (ctxt, Deposits delegate)
  | `Block_fees ->
      Raw_context.credit_collected_fees_only_call_from_token ctxt amount
      >>?= fun ctxt -> return (ctxt, Block_fees)
  (* TODO: remove in J *)
  | `Legacy_deposits (delegate, cycle) as dest ->
      let contract = Contract_repr.implicit_contract delegate in
      balance ctxt dest >>=? fun old_amount ->
      Tez_repr.(old_amount +? amount) >>?= fun new_amount ->
      Storage.Contract.Legacy_frozen_deposits.add
        (ctxt, contract)
        cycle
        new_amount
      >>= fun ctxt -> return (ctxt, Legacy_deposits (delegate, cycle))
  | `Legacy_fees (delegate, cycle) as dest ->
      let contract = Contract_repr.implicit_contract delegate in
      balance ctxt dest >>=? fun old_amount ->
      Tez_repr.(old_amount +? amount) >>?= fun new_amount ->
      Storage.Contract.Legacy_frozen_fees.add (ctxt, contract) cycle new_amount
      >>= fun ctxt -> return (ctxt, Legacy_fees (delegate, cycle))
  | `Legacy_rewards (delegate, cycle) as dest ->
      let contract = Contract_repr.implicit_contract delegate in
      balance ctxt dest >>=? fun old_amount ->
      Tez_repr.(old_amount +? amount) >>?= fun new_amount ->
      Storage.Contract.Legacy_frozen_rewards.add
        (ctxt, contract)
        cycle
        new_amount
      >>= fun ctxt -> return (ctxt, Legacy_rewards (delegate, cycle)))
  >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin))

let spend ctxt src amount origin =
  let open Receipt_repr in
  (match src with
  | `Bootstrap -> return (ctxt, Bootstrap)
  | `Invoice -> return (ctxt, Invoice)
  | `Initial_commitments -> return (ctxt, Initial_commitments)
  | `Minted -> return (ctxt, Minted)
  | `Liquidity_baking_subsidies -> return (ctxt, Liquidity_baking_subsidies)
  | `Revelation_rewards -> return (ctxt, Nonce_revelation_rewards)
  | `Double_signing_evidence_rewards ->
      return (ctxt, Double_signing_evidence_rewards)
  | `Endorsing_rewards -> return (ctxt, Endorsing_rewards)
  | `Baking_rewards -> return (ctxt, Baking_rewards)
  | `Baking_bonuses -> return (ctxt, Baking_bonuses)
  | `Contract src ->
      Contract_storage.spend_only_call_from_token ctxt src amount
      >|=? fun ctxt -> (ctxt, Contract src)
  | `Collected_commitments bpkh ->
      Commitment_storage.decrease_commitment_only_call_from_token
        ctxt
        bpkh
        amount
      >>=? fun ctxt -> return (ctxt, Commitments bpkh)
  | `Delegate_balance delegate ->
      let contract = Contract_repr.implicit_contract delegate in
      Contract_storage.decrease_balance_only_call_from_token
        ctxt
        contract
        amount
      >|=? fun ctxt -> (ctxt, Contract contract)
  | `Frozen_deposits delegate ->
      (if Tez_repr.(amount = zero) then return ctxt
      else
        Frozen_deposits_storage.spend_only_call_from_token ctxt delegate amount)
      >>=? fun ctxt -> return (ctxt, Deposits delegate)
  | `Block_fees ->
      Raw_context.spend_collected_fees_only_call_from_token ctxt amount
      >>?= fun ctxt -> return (ctxt, Block_fees)
  (* TODO: remove in J *)
  | `Legacy_deposits (delegate, cycle) as src ->
      balance ctxt src >>=? fun old_amount ->
      Tez_repr.(old_amount -? amount) >>?= fun new_amount ->
      let contract = Contract_repr.implicit_contract delegate in
      (if Tez_repr.(new_amount = zero) then
       Storage.Contract.Legacy_frozen_deposits.remove (ctxt, contract) cycle
      else
        Storage.Contract.Legacy_frozen_deposits.add
          (ctxt, contract)
          cycle
          new_amount)
      >>= fun ctxt -> return (ctxt, Legacy_deposits (delegate, cycle))
  | `Legacy_fees (delegate, cycle) as src ->
      balance ctxt src >>=? fun old_amount ->
      Tez_repr.(old_amount -? amount) >>?= fun new_amount ->
      let contract = Contract_repr.implicit_contract delegate in
      (if Tez_repr.(new_amount = zero) then
       Storage.Contract.Legacy_frozen_fees.remove (ctxt, contract) cycle
      else
        Storage.Contract.Legacy_frozen_fees.add
          (ctxt, contract)
          cycle
          new_amount)
      >>= fun ctxt -> return (ctxt, Legacy_fees (delegate, cycle))
  | `Legacy_rewards (delegate, cycle) as src ->
      balance ctxt src >>=? fun old_amount ->
      Tez_repr.(old_amount -? amount) >>?= fun new_amount ->
      let contract = Contract_repr.implicit_contract delegate in
      (if Tez_repr.(new_amount = zero) then
       Storage.Contract.Legacy_frozen_rewards.remove (ctxt, contract) cycle
      else
        Storage.Contract.Legacy_frozen_rewards.add
          (ctxt, contract)
          cycle
          new_amount)
      >>= fun ctxt -> return (ctxt, Legacy_rewards (delegate, cycle)))
  >|=? fun (ctxt, balance) -> (ctxt, (balance, Debited amount, origin))

let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest =
  let sources = List.filter (fun (_, am) -> Tez_repr.(am <> zero)) src in
  match sources with
  | [] ->
      (* Avoid accessing context data when there is nothing to transfer. *)
      return (ctxt, [])
  | _ :: _ ->
      List.fold_left_es
        (fun (ctxt, total, debit_logs) (source, amount) ->
          spend ctxt source amount origin >>=? fun (ctxt, debit_log) ->
          Tez_repr.(amount +? total) >>?= fun total ->
          return (ctxt, total, debit_log :: debit_logs))
        (ctxt, Tez_repr.zero, [])
        sources
      >>=? fun (ctxt, amount, debit_logs) ->
      credit ctxt dest amount origin >|=? fun (ctxt, credit_log) ->
      (* Make sure the order of balance updates is : debit logs in the order of
         of the parameter [src], and then the credit log. *)
      let balance_updates = List.rev (credit_log :: debit_logs) in
      (ctxt, balance_updates)

let transfer ?(origin = Receipt_repr.Block_application) ctxt src dest amount =
  transfer_n ~origin ctxt [(src, amount)] dest