module Hydra.Ledger.Cardano (
  module Hydra.Ledger.Cardano,
  module Hydra.Ledger.Cardano.Builder,
  Ledger.ShelleyGenesis (..),
  Ledger.Globals,
  Ledger.LedgerEnv,
  Tx,
) where

import Hydra.Prelude

import Hydra.Cardano.Api hiding (getVerificationKey, initialLedgerState, utxoFromTx)
import Hydra.Ledger.Cardano.Builder
import Hydra.Tx.Crypto (getVerificationKey)
import Hydra.Tx.Secret (Secret, withSecret)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Address (AccountAddress (..), AccountId (..))
import Cardano.Ledger.Alonzo.Rules (
  FailureDescription (..),
  TagMismatchDescription (FailedUnexpectedly),
 )
import Cardano.Ledger.Api (bodyTxL, unWithdrawals, withdrawalsTxBodyL)
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin (CompactForm (CompactCoin))
import Cardano.Ledger.Conway (ApplyTxError (ConwayApplyTxError))
import Cardano.Ledger.Conway.Rules (
  ConwayLedgerPredFailure (ConwayUtxowFailure),
  ConwayUtxoPredFailure (UtxosFailure),
  ConwayUtxosPredFailure (ValidationTagMismatch),
  ConwayUtxowPredFailure (UtxoFailure),
 )
import Cardano.Ledger.Conway.State (ConwayAccountState (..))
import Cardano.Ledger.Plutus (debugPlutusUnbounded, defaultPlutusDebugOverrides, pdoExUnitsEnforced)
import Cardano.Ledger.Shelley.API.Mempool qualified as Ledger
import Cardano.Ledger.Shelley.Genesis qualified as Ledger
import Cardano.Ledger.Shelley.LedgerState qualified as Ledger
import Cardano.Ledger.Shelley.Rules qualified as Ledger
import Cardano.Ledger.State (ChainAccountState (..), accountsL, addAccountState)
import Control.Lens ((%~), (.~), (^.))
import Data.Default (def)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Ledger (Ledger (..), ValidationError (..))
import Hydra.Tx (IsTx (..))

-- * Ledger

-- | Use the cardano-ledger as an in-hydra 'Ledger'.
cardanoLedger :: Ledger.Globals -> Ledger.LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger :: Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
globals LedgerEnv LedgerEra
ledgerEnv =
  Ledger{ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
$sel:applyTransactions:Ledger :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions, ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
reapplyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
$sel:reapplyTransactions:Ledger :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
reapplyTransactions}
 where
  -- NOTE(SN): See full note on 'applyTx' why we only have a single transaction
  -- application here.
  applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions = (ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO)
-> ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
foldTxs ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
applyTx

  -- Re-apply transactions that were already accepted by 'applyTransactions'
  -- earlier. This skips the static checks (Plutus script evaluation and witness
  -- cryptography) which dominate the per-tx cost, while still running the
  -- state-dependent ledger checks so it fails exactly like 'applyTransactions'
  -- when a transaction no longer applies to the given UTxO.
  reapplyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
reapplyTransactions = (ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO)
-> ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
foldTxs ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
reapplyTx

  -- Left-fold a single-transaction step over a list, threading the UTxO forward
  -- and short-circuiting on the first validation failure.
  foldTxs ::
    (ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO) ->
    ChainSlot ->
    UTxO ->
    [Tx] ->
    Either (Tx, ValidationError) UTxO
  foldTxs :: (ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO)
-> ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
foldTxs ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
step ChainSlot
slot = UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
go
   where
    go :: UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
go UTxO
utxo = \case
      [] -> UTxO -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right UTxO
utxo
      (Tx
tx : [Tx]
txs) -> do
        UTxO
utxo' <- ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
step ChainSlot
slot UTxO
utxo Tx
tx
        UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
go UTxO
utxo' [Tx]
txs

  -- TODO(SN): Pre-validate transactions to get less confusing errors on
  -- transactions which are not expected to work on a layer-2
  -- NOTE(SN): This is will fail on any transaction requiring the 'DPState' to be
  -- in a certain state as we do throw away the resulting 'DPState' and only take
  -- the ledger's 'UTxO' forward.
  --
  -- We came to this signature of only applying a single transaction because we
  -- got confused why a sequence of transactions worked but sequentially applying
  -- single transactions didn't. This was because of this not-keeping the'DPState'
  -- as described above.
  applyTx :: ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
applyTx ChainSlot
slot UTxO
utxo Tx
tx =
    ChainSlot
-> UTxO
-> Tx
-> (LedgerEnv ConwayEra
    -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
-> Either (Tx, ValidationError) UTxO
withLedgerState ChainSlot
slot UTxO
utxo Tx
tx ((LedgerEnv ConwayEra
  -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
 -> Either (Tx, ValidationError) UTxO)
-> (LedgerEnv ConwayEra
    -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
-> Either (Tx, ValidationError) UTxO
forall a b. (a -> b) -> a -> b
$ \LedgerEnv ConwayEra
env' LedgerState ConwayEra
memPoolState ->
      case Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> Tx TopTx ConwayEra
-> Either
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, Validated (Tx TopTx ConwayEra))
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
Ledger.applyTx Globals
globals LedgerEnv ConwayEra
env' LedgerState ConwayEra
memPoolState (Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx) of
        Left ApplyTxError ConwayEra
err ->
          (Tx, ValidationError) -> Either (Tx, ValidationError) UTxO
forall a b. a -> Either a b
Left (Tx
tx, ApplyTxError LedgerEra -> ValidationError
toValidationError ApplyTxError ConwayEra
ApplyTxError LedgerEra
err)
        Right (Ledger.LedgerState{lsUTxOState :: forall era. LedgerState era -> UTxOState era
Ledger.lsUTxOState = UTxOState ConwayEra
us}, Validated (Tx TopTx ConwayEra)
_validatedTx) ->
          UTxO -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right (UTxO -> Either (Tx, ValidationError) UTxO)
-> (UTxO ConwayEra -> UTxO)
-> UTxO ConwayEra
-> Either (Tx, ValidationError) UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO -> UTxO
forceNewEntries UTxO
utxo (UTxO -> UTxO)
-> (UTxO ConwayEra -> UTxO) -> UTxO ConwayEra -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra Era -> UTxO LedgerEra -> UTxO
forall era.
ShelleyBasedEra era -> UTxO (ShelleyLedgerEra era) -> UTxO era
UTxO.fromShelleyUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (UTxO ConwayEra -> Either (Tx, ValidationError) UTxO)
-> UTxO ConwayEra -> Either (Tx, ValidationError) UTxO
forall a b. (a -> b) -> a -> b
$ UTxOState ConwayEra -> UTxO ConwayEra
forall era. UTxOState era -> UTxO era
Ledger.utxosUtxo UTxOState ConwayEra
us

  -- NOTE: 'unsafeMakeValidated' asserts that the transaction has previously
  -- passed full validation; this holds because callers only re-apply
  -- transactions already accepted by 'applyTx'. 'Ledger.reapplyTx' then runs
  -- every ledger check except the static ones.
  reapplyTx :: ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
reapplyTx ChainSlot
slot UTxO
utxo Tx
tx =
    ChainSlot
-> UTxO
-> Tx
-> (LedgerEnv ConwayEra
    -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
-> Either (Tx, ValidationError) UTxO
withLedgerState ChainSlot
slot UTxO
utxo Tx
tx ((LedgerEnv ConwayEra
  -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
 -> Either (Tx, ValidationError) UTxO)
-> (LedgerEnv ConwayEra
    -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
-> Either (Tx, ValidationError) UTxO
forall a b. (a -> b) -> a -> b
$ \LedgerEnv ConwayEra
env' LedgerState ConwayEra
memPoolState ->
      case Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> Validated (Tx TopTx ConwayEra)
-> Either (ApplyTxError ConwayEra) (LedgerState ConwayEra)
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx TopTx era)
-> Either (ApplyTxError era) (MempoolState era)
Ledger.reapplyTx Globals
globals LedgerEnv ConwayEra
env' LedgerState ConwayEra
memPoolState (Tx TopTx ConwayEra -> Validated (Tx TopTx ConwayEra)
forall tx. tx -> Validated tx
Ledger.unsafeMakeValidated (Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx)) of
        Left ApplyTxError ConwayEra
err ->
          (Tx, ValidationError) -> Either (Tx, ValidationError) UTxO
forall a b. a -> Either a b
Left (Tx
tx, ApplyTxError LedgerEra -> ValidationError
toValidationError ApplyTxError ConwayEra
ApplyTxError LedgerEra
err)
        Right Ledger.LedgerState{lsUTxOState :: forall era. LedgerState era -> UTxOState era
Ledger.lsUTxOState = UTxOState ConwayEra
us} ->
          UTxO -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right (UTxO -> Either (Tx, ValidationError) UTxO)
-> (UTxO ConwayEra -> UTxO)
-> UTxO ConwayEra
-> Either (Tx, ValidationError) UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO -> UTxO
forceNewEntries UTxO
utxo (UTxO -> UTxO)
-> (UTxO ConwayEra -> UTxO) -> UTxO ConwayEra -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra Era -> UTxO LedgerEra -> UTxO
forall era.
ShelleyBasedEra era -> UTxO (ShelleyLedgerEra era) -> UTxO era
UTxO.fromShelleyUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (UTxO ConwayEra -> Either (Tx, ValidationError) UTxO)
-> UTxO ConwayEra -> Either (Tx, ValidationError) UTxO
forall a b. (a -> b) -> a -> b
$ UTxOState ConwayEra -> UTxO ConwayEra
forall era. UTxOState era -> UTxO era
Ledger.utxosUtxo UTxOState ConwayEra
us

  -- Build the ledger env and mempool state for a single transaction and hand
  -- them to the given continuation. Shared by 'applyTx' and 'reapplyTx'.
  withLedgerState :: ChainSlot
-> UTxO
-> Tx
-> (LedgerEnv ConwayEra
    -> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO)
-> Either (Tx, ValidationError) UTxO
withLedgerState (ChainSlot Natural
slot) UTxO
utxo Tx
tx LedgerEnv ConwayEra
-> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO
cont = LedgerEnv ConwayEra
-> LedgerState ConwayEra -> Either (Tx, ValidationError) UTxO
cont LedgerEnv ConwayEra
env' LedgerState ConwayEra
memPoolState
   where
    env' :: LedgerEnv ConwayEra
env' = LedgerEnv LedgerEra
ledgerEnv{Ledger.ledgerSlotNo = fromIntegral slot}

    memPoolState :: LedgerState ConwayEra
memPoolState =
      LedgerState ConwayEra
forall a. Default a => a
def
        LedgerState ConwayEra
-> (LedgerState ConwayEra -> LedgerState ConwayEra)
-> LedgerState ConwayEra
forall a b. a -> (a -> b) -> b
& (UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
Ledger.lsUTxOStateL ((UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
    -> UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> LedgerState ConwayEra
-> Identity (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> UTxOState ConwayEra -> Identity (UTxOState ConwayEra)
forall era. Lens' (UTxOState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
Ledger.utxoL ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> UTxO ConwayEra -> LedgerState ConwayEra -> LedgerState ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShelleyBasedEra Era -> UTxO -> UTxO LedgerEra
forall era.
HasCallStack =>
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
UTxO.toShelleyUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra UTxO
utxo
        LedgerState ConwayEra
-> (LedgerState ConwayEra -> LedgerState ConwayEra)
-> LedgerState ConwayEra
forall a b. a -> (a -> b) -> b
& (CertState ConwayEra -> Identity (CertState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
(ConwayCertState ConwayEra -> Identity (ConwayCertState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
Ledger.lsCertStateL ((ConwayCertState ConwayEra
  -> Identity (ConwayCertState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> ((DState ConwayEra -> Identity (DState ConwayEra))
    -> ConwayCertState ConwayEra
    -> Identity (ConwayCertState ConwayEra))
-> (DState ConwayEra -> Identity (DState ConwayEra))
-> LedgerState ConwayEra
-> Identity (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState ConwayEra -> Identity (DState ConwayEra))
-> CertState ConwayEra -> Identity (CertState ConwayEra)
(DState ConwayEra -> Identity (DState ConwayEra))
-> ConwayCertState ConwayEra
-> Identity (ConwayCertState ConwayEra)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState ConwayEra) (DState ConwayEra)
Ledger.certDStateL ((DState ConwayEra -> Identity (DState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> (DState ConwayEra -> DState ConwayEra)
-> LedgerState ConwayEra
-> LedgerState ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DState ConwayEra -> DState ConwayEra
mockCertState

    -- NOTE: Mocked certificate state that simulates any reward accounts for any
    -- withdraw-zero scripts included in the transaction.
    mockCertState :: DState ConwayEra -> DState ConwayEra
mockCertState =
      (Accounts ConwayEra -> Identity (Accounts ConwayEra))
-> DState ConwayEra -> Identity (DState ConwayEra)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts ConwayEra -> Identity (Accounts ConwayEra))
 -> DState ConwayEra -> Identity (DState ConwayEra))
-> (Accounts ConwayEra -> Accounts ConwayEra)
-> DState ConwayEra
-> DState ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Accounts ConwayEra
accounts ->
        (Accounts ConwayEra -> Credential Staking -> Accounts ConwayEra)
-> Accounts ConwayEra
-> Set (Credential Staking)
-> Accounts ConwayEra
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
          (\Accounts ConwayEra
acc Credential Staking
cred -> Credential Staking
-> AccountState ConwayEra
-> Accounts ConwayEra
-> Accounts ConwayEra
forall era.
EraAccounts era =>
Credential Staking
-> AccountState era -> Accounts era -> Accounts era
addAccountState Credential Staking
cred ConwayAccountState{casBalance :: CompactForm Coin
casBalance = Word64 -> CompactForm Coin
CompactCoin Word64
0, casDeposit :: CompactForm Coin
casDeposit = Word64 -> CompactForm Coin
CompactCoin Word64
0, casStakePoolDelegation :: Maybe (KeyHash StakePool)
casStakePoolDelegation = Maybe (KeyHash StakePool)
forall a. Maybe a
Nothing, casDRepDelegation :: Maybe DRep
casDRepDelegation = Maybe DRep
forall a. Maybe a
Nothing} Accounts ConwayEra
acc)
          Accounts ConwayEra
accounts
          Set (Credential Staking)
withdrawZeroCredentials

    withdrawZeroCredentials :: Set (Credential Staking)
withdrawZeroCredentials =
      Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting Withdrawals (Tx TopTx ConwayEra) Withdrawals
-> Withdrawals
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const Withdrawals (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const Withdrawals (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const Withdrawals (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const Withdrawals (Tx TopTx ConwayEra))
-> ((Withdrawals -> Const Withdrawals Withdrawals)
    -> TxBody TopTx ConwayEra
    -> Const Withdrawals (TxBody TopTx ConwayEra))
-> Getting Withdrawals (Tx TopTx ConwayEra) Withdrawals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Const Withdrawals Withdrawals)
-> TxBody TopTx ConwayEra
-> Const Withdrawals (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) Withdrawals
withdrawalsTxBodyL
        Withdrawals
-> (Withdrawals -> Map AccountAddress Coin)
-> Map AccountAddress Coin
forall a b. a -> (a -> b) -> b
& Withdrawals -> Map AccountAddress Coin
unWithdrawals
        Map AccountAddress Coin
-> (Map AccountAddress Coin -> Map AccountAddress Coin)
-> Map AccountAddress Coin
forall a b. a -> (a -> b) -> b
& (Coin -> Bool)
-> Map AccountAddress Coin -> Map AccountAddress Coin
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Coin
Coin Integer
0)
        Map AccountAddress Coin
-> (Map AccountAddress Coin -> Set AccountAddress)
-> Set AccountAddress
forall a b. a -> (a -> b) -> b
& Map AccountAddress Coin -> Set AccountAddress
forall k a. Map k a -> Set k
Map.keysSet
        Set AccountAddress
-> (Set AccountAddress -> Set (Credential Staking))
-> Set (Credential Staking)
forall a b. a -> (a -> b) -> b
& (AccountAddress -> Credential Staking)
-> Set AccountAddress -> Set (Credential Staking)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (AccountId -> Credential Staking
unAccountId (AccountId -> Credential Staking)
-> (AccountAddress -> AccountId)
-> AccountAddress
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccountAddress -> AccountId
aaId)

  -- As we use applyTx we only expect one ledger rule to run and one tx to
  -- fail validation, hence using the heads of non empty lists is fine.
  toValidationError :: ApplyTxError LedgerEra -> ValidationError
  toValidationError :: ApplyTxError LedgerEra -> ValidationError
toValidationError (ConwayApplyTxError (ConwayLedgerPredFailure ConwayEra
e :| [ConwayLedgerPredFailure ConwayEra]
_)) = case ConwayLedgerPredFailure ConwayEra
e of
    (ConwayUtxowFailure (UtxoFailure (UtxosFailure (ValidationTagMismatch IsValid
_ (FailedUnexpectedly (PlutusFailure Text
msg ByteString
ctx :| [FailureDescription]
_)))))) ->
      Text -> ValidationError
ValidationError (Text -> ValidationError) -> Text -> ValidationError
forall a b. (a -> b) -> a -> b
$
        Text
"Plutus validation failed: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Debug info: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PlutusDebugInfo -> Text
forall b a. (Show a, IsString b) => a -> b
show (HasCallStack => String -> PlutusDebugOverrides -> PlutusDebugInfo
String -> PlutusDebugOverrides -> PlutusDebugInfo
debugPlutusUnbounded (ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
ctx) (PlutusDebugOverrides
defaultPlutusDebugOverrides{pdoExUnitsEnforced = True}))
    ConwayLedgerPredFailure ConwayEra
_ -> Text -> ValidationError
ValidationError (Text -> ValidationError) -> Text -> ValidationError
forall a b. (a -> b) -> a -> b
$ ConwayLedgerPredFailure ConwayEra -> Text
forall b a. (Show a, IsString b) => a -> b
show ConwayLedgerPredFailure ConwayEra
e

-- * LedgerEnv

-- | Create a new ledger env from given protocol parameters.
newLedgerEnv :: PParams LedgerEra -> Ledger.LedgerEnv LedgerEra
newLedgerEnv :: PParams LedgerEra -> LedgerEnv LedgerEra
newLedgerEnv PParams LedgerEra
protocolParams =
  Ledger.LedgerEnv
    { ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = Word64 -> SlotNo
SlotNo Word64
0
    , -- NOTE: This can probably stay at 0 forever. This is used internally by the
      -- node's mempool to keep track of transaction seen from peers. Transactions
      -- in Hydra do not go through the node's mempool and follow a different
      -- consensus path so this will remain unused.
      ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
    , -- NOTE: This keeps track of the ledger's treasury and reserve which are
      -- both unused in Hydra. There might be room for interesting features in the
      -- future with these two but for now, we'll consider them empty.
      ledgerAccount :: ChainAccountState
Ledger.ledgerAccount = Coin -> Coin -> ChainAccountState
ChainAccountState Coin
forall a. Monoid a => a
mempty Coin
forall a. Monoid a => a
mempty
    , ledgerPp :: PParams ConwayEra
Ledger.ledgerPp = PParams ConwayEra
PParams LedgerEra
protocolParams
    , ledgerEpochNo :: Maybe EpochNo
Ledger.ledgerEpochNo = Maybe EpochNo
forall a. Maybe a
Nothing
    }

-- * Conversions and utilities

-- | Simple conversion from a generic slot to a specific local one.
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot (ChainSlot Natural
s) = Natural -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
s

-- | Build a zero-fee transaction which spends the first output owned by given
-- signing key and transfers it in full to given verification key.
mkTransferTx ::
  MonadFail m =>
  NetworkId ->
  UTxO ->
  Secret (SigningKey PaymentKey) ->
  VerificationKey PaymentKey ->
  m Tx
mkTransferTx :: forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo Secret (SigningKey PaymentKey)
sender VerificationKey PaymentKey
recipient =
  case (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool
forall ctx era. VerificationKey PaymentKey -> TxOut ctx era -> Bool
isVkTxOut (VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool)
-> VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool
forall a b. (a -> b) -> a -> b
$ Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sender) UTxO
utxo of
    Maybe (TxIn, TxOut CtxUTxO Era)
Nothing -> String -> m Tx
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no utxo left to spend"
    Just (TxIn
txIn, TxOut CtxUTxO Era
txOut) ->
      case (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txIn, TxOut CtxUTxO Era
txOut) (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
recipient, TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
txOut) Secret (SigningKey PaymentKey)
sender of
        Left TxBodyError
err ->
          String -> m Tx
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Tx) -> String -> m Tx
forall a b. (a -> b) -> a -> b
$ String
"mkSimpleTx failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
err
        Right Tx
tx ->
          Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx

-- | Build a zero-fee payment transaction.
mkSimpleTx ::
  (TxIn, TxOut CtxUTxO) ->
  -- | Recipient address and amount.
  (AddressInEra, Value) ->
  -- | Sender's signing key.
  Secret (SigningKey PaymentKey) ->
  Either TxBodyError Tx
mkSimpleTx :: (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txin, TxOut AddressInEra
owner Value
valueIn TxOutDatum CtxUTxO
datum ReferenceScript
refScript) (AddressInEra
recipient, Value
valueOut) Secret (SigningKey PaymentKey)
sk = do
  TxBody
body <- TxBodyContent BuildTx -> Either TxBodyError TxBody
createAndValidateTransactionBody TxBodyContent BuildTx
bodyContent
  let witnesses :: [KeyWitness]
witnesses = Secret (SigningKey PaymentKey)
-> (SigningKey PaymentKey -> [KeyWitness]) -> [KeyWitness]
forall a r. Secret a -> (a -> r) -> r
withSecret Secret (SigningKey PaymentKey)
sk ((SigningKey PaymentKey -> [KeyWitness]) -> [KeyWitness])
-> (SigningKey PaymentKey -> [KeyWitness]) -> [KeyWitness]
forall a b. (a -> b) -> a -> b
$ \SigningKey PaymentKey
rawSk -> [TxBody -> ShelleyWitnessSigningKey -> KeyWitness
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
rawSk)]
  Tx -> Either TxBodyError Tx
forall a. a -> Either TxBodyError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either TxBodyError Tx) -> Tx -> Either TxBodyError Tx
forall a b. (a -> b) -> a -> b
$ [KeyWitness] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [KeyWitness]
witnesses TxBody
body
 where
  bodyContent :: TxBodyContent BuildTx
bodyContent =
    TxBodyContent BuildTx
defaultTxBodyContent
      { txIns = [(txin, BuildTxWith $ KeyWitness KeyWitnessForSpending)]
      , txOuts = outs
      , txFee = TxFeeExplicit fee
      }

  outs :: [TxOut CtxTx]
outs =
    forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut @CtxTx AddressInEra
recipient Value
valueOut TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
      TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [ TxOut CtxUTxO Era -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut (TxOut CtxUTxO Era -> TxOut CtxTx)
-> TxOut CtxUTxO Era -> TxOut CtxTx
forall a b. (a -> b) -> a -> b
$
          AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
            AddressInEra
owner
            (Value
valueIn Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
valueOut)
            TxOutDatum CtxUTxO
datum
            ReferenceScript
refScript
        | Value
valueOut Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
valueIn
        ]

  fee :: Coin
fee = Integer -> Coin
Coin Integer
0

-- | Utility function to "adjust" a `UTxO` set given a `Tx`
--
--  The inputs from the `Tx` are removed from the internal map of the `UTxO` and
--  the outputs added, correctly indexed by the `TxIn`. This function is useful
--  to manually maintain a `UTxO` set without caring too much about the `Ledger`
--  rules.
adjustUTxO :: Tx -> UTxO -> UTxO
adjustUTxO :: Tx -> UTxO -> UTxO
adjustUTxO Tx
tx UTxO
utxo =
  let txid :: TxIdType Tx
txid = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
Hydra.Tx.txId Tx
tx
      consumed :: [TxIn]
consumed = Tx -> [TxIn]
forall era. Tx era -> [TxIn]
txIns' Tx
tx
      produced :: UTxO
produced = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ((\(TxOut CtxTx
txout, Word
ix) -> (TxId -> TxIx -> TxIn
TxIn TxIdType Tx
TxId
txid (Word -> TxIx
TxIx Word
ix), TxOut CtxTx -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx
txout)) ((TxOut CtxTx, Word) -> (TxIn, TxOut CtxUTxO Era))
-> [(TxOut CtxTx, Word)] -> [(TxIn, TxOut CtxUTxO Era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx] -> [Word] -> [(TxOut CtxTx, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx) [Word
0 ..])
      utxo' :: UTxO
utxo' = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut CtxUTxO Era) -> Bool)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
txin, TxOut CtxUTxO Era
_) -> TxIn
txin TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [TxIn]
consumed) ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)])
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxo
   in UTxO
utxo' UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO -> UTxO
forceUTxO UTxO
produced