Merge pull request #2264 from input-output-hk/ts-new-mempool-onTopOf-…

…nick

Implement applyTx for Alonzo

alonzo/impl/src/Cardano/Ledger/Alonzo.hs

@@ -30,8 +30,10 @@ import Cardano.Ledger.Alonzo.PParams
   )
 import qualified Cardano.Ledger.Alonzo.Rules.Bbody as Alonzo (AlonzoBBODY)
 import qualified Cardano.Ledger.Alonzo.Rules.Ledger as Alonzo (AlonzoLEDGER)
+import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure (UtxosFailure))
 import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo (AlonzoUTXO)
-import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS)
+import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS, constructValidated)
+import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail (WrappedShelleyEraFailure))
 import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo (AlonzoUTXOW)
 import Cardano.Ledger.Alonzo.Scripts (Script (..), isPlutusScript)
 import Cardano.Ledger.Alonzo.Tx
@@ -57,11 +59,22 @@ import Cardano.Ledger.Shelley.Constraints
   )
 import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock)
 import Cardano.Ledger.Tx (Tx (Tx))
+import Control.Arrow (left)
+import Control.Monad.Except (liftEither, runExcept)
 import qualified Data.Set as Set
 import qualified Shelley.Spec.Ledger.API as API
 import qualified Shelley.Spec.Ledger.BaseTypes as Shelley
+import Shelley.Spec.Ledger.LedgerState
+  ( DPState (..),
+    DState (..),
+    PState (..),
+  )
 import Shelley.Spec.Ledger.Metadata (validMetadatum)
 import qualified Shelley.Spec.Ledger.STS.Epoch as Shelley
+import Shelley.Spec.Ledger.STS.Ledger
+  ( LedgerEnv (..),
+    LedgerPredicateFailure (UtxowFailure),
+  )
 import qualified Shelley.Spec.Ledger.STS.Mir as Shelley
 import qualified Shelley.Spec.Ledger.STS.Newpp as Shelley
 import qualified Shelley.Spec.Ledger.STS.Ocert as Shelley
@@ -70,9 +83,12 @@ import qualified Shelley.Spec.Ledger.STS.Rupd as Shelley
 import qualified Shelley.Spec.Ledger.STS.Snap as Shelley
 import qualified Shelley.Spec.Ledger.STS.Tick as Shelley
 import qualified Shelley.Spec.Ledger.STS.Upec as Shelley
+import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (UtxoFailure))
 import qualified Shelley.Spec.Ledger.Tx as Shelley
 import Shelley.Spec.Ledger.TxBody (witKeyHash)
 
+-- =====================================================
+
 -- | The Alonzo era
 data AlonzoEra c
 
@@ -84,15 +100,30 @@ instance
   where
   type Crypto (AlonzoEra c) = c
 
--- TODO we cannot have this instance until we rewrite the mempool API to reflect
--- the difference between Tx and TxInBlock
-
 instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where
-  applyTx = undefined
+  applyTx globals (LedgerEnv slot _ix pp _accnt) (utxostate, dpstate) tx =
+    do
+      (utxostate2, vtx) <-
+        liftEither
+          . left
+            ( API.ApplyTxError
+                . fmap
+                  ( UtxowFailure
+                      . WrappedShelleyEraFailure
+                      . UtxoFailure
+                      . UtxosFailure
+                  )
+            )
+          . runExcept
+          $ Alonzo.constructValidated globals utxoenv utxostate tx
+      pure ((utxostate2, dpstate), vtx)
+    where
+      delegs = (_genDelegs . _dstate) dpstate
+      stake = (_pParams . _pstate) dpstate
+      utxoenv = API.UtxoEnv slot pp stake delegs
+
   applyTxInBlock = undefined
 
-  -- TODO implement this without reserialisation by extracting the various
-  -- bytestring parts.
   extractTx ValidatedTx {body, wits, auxiliaryData} =
     Tx body wits auxiliaryData
 

alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs

@@ -32,11 +32,9 @@ import Cardano.Ledger.Alonzo.Tx
     DataHash,
     ScriptPurpose (..),
     ValidatedTx (..),
-    body',
     getValidatorHash,
     indexedRdmrs,
     txdats',
-    wits',
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..), vldt')
 import Cardano.Ledger.Alonzo.TxInfo (runPLCScript, transTx, valContext)
@@ -79,10 +77,11 @@ import Shelley.Spec.Ledger.UTxO (UTxO (..))
 -- | Get the Data associated with a ScriptPurpose. Only the Spending
 --   ScriptPurpose contains Data. The null list is returned for the other kinds.
 getData ::
-  forall era.
-  ( HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era)))
+  forall era tx.
+  ( HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
+    HasField "wits" tx (TxWitness era)
   ) =>
-  ValidatedTx era ->
+  tx ->
   UTxO era ->
   ScriptPurpose (Crypto era) ->
   [Data era]
@@ -157,6 +156,7 @@ instance (CC.Crypto crypto) => FromCBOR (CollectError crypto) where
 --     might validate that shouldn't. So we double check that every Script has its Data, and
 --     if that is not the case, a PredicateFailure is raised in the Utxos rule.
 collectTwoPhaseScriptInputs ::
+  forall era tx.
   ( Era era,
     Core.Script era ~ AlonzoScript.Script era,
     Core.TxOut era ~ Alonzo.TxOut era,
@@ -166,10 +166,12 @@ collectTwoPhaseScriptInputs ::
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
     HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
-    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    HasField "body" tx (Core.TxBody era),
+    HasField "wits" tx (TxWitness era)
   ) =>
   Core.PParams era ->
-  ValidatedTx era ->
+  tx ->
   UTxO era ->
   Either [CollectError (Crypto era)] [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)]
 collectTwoPhaseScriptInputs pp tx utxo =
@@ -215,18 +217,20 @@ language (AlonzoScript.TimelockScript _) = Nothing
 --   There are two kinds of scripts, evaluate each kind using the
 --   appropriate mechanism.
 evalScripts ::
-  forall era.
+  forall era tx.
   ( Era era,
-    Alonzo.TxBody era ~ Core.TxBody era
+    Alonzo.TxBody era ~ Core.TxBody era,
+    HasField "body" tx (Core.TxBody era),
+    HasField "wits" tx (TxWitness era)
   ) =>
-  ValidatedTx era ->
+  tx ->
   [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] ->
   Bool
 evalScripts _tx [] = True
 evalScripts tx ((AlonzoScript.TimelockScript timelock, _, _, _) : rest) =
-  evalTimelock vhks (Alonzo.vldt' (body' tx)) timelock && evalScripts tx rest
+  evalTimelock vhks (Alonzo.vldt' (getField @"body" tx)) timelock && evalScripts tx rest
   where
-    vhks = Set.map witKeyHash (txwitsVKey' (wits' tx))
+    vhks = Set.map witKeyHash (txwitsVKey' (getField @"wits" tx))
 evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) =
   runPLCScript cost pscript units (map getPlutusData ds) && evalScripts tx rest
 
@@ -261,19 +265,20 @@ checkScriptData tx {- utxo -} (sp, h) =
 
 -- Collect information (purpose and hash) about all the scripts in a Tx.
 scriptsNeeded ::
-  forall era.
+  forall era tx.
   ( Era era,
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
     HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
-    HasField "address" (Core.TxOut era) (Addr (Crypto era))
+    HasField "address" (Core.TxOut era) (Addr (Crypto era)),
+    HasField "body" tx (Core.TxBody era)
   ) =>
   UTxO era ->
-  ValidatedTx era ->
+  tx ->
   [(ScriptPurpose (Crypto era), ScriptHash (Crypto era))]
 scriptsNeeded (UTxO utxomap) tx = spend ++ reward ++ cert ++ minted
   where
-    txb = body' tx
+    txb = getField @"body" tx
     !spend = foldl' accum [] (getField @"inputs" txb)
       where
         accum !ans !i =

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -29,13 +30,16 @@ import Cardano.Ledger.Alonzo.Tx
     txouts,
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
+import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
 import Cardano.Ledger.Coin (Coin)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Crypto, Era)
 import Cardano.Ledger.Mary.Value (Value)
 import Cardano.Ledger.Shelley.Constraints (PParamsDelta)
 import qualified Cardano.Ledger.Val as Val
 import Control.Iterate.SetAlgebra (eval, (∪), (⋪), (◁))
+import Control.Monad.Except (MonadError (throwError))
+import Control.Monad.Trans.Reader (runReader)
 import Control.State.Transition.Extended
 import Data.Coders
 import Data.Foldable (toList)
@@ -45,8 +49,13 @@ import Data.Set (Set)
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
-import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), strictMaybeToMaybe)
-import Shelley.Spec.Ledger.LedgerState
+import Shelley.Spec.Ledger.BaseTypes
+  ( Globals,
+    ShelleyBase,
+    StrictMaybe (..),
+    strictMaybeToMaybe,
+  )
+import Shelley.Spec.Ledger.LedgerState (PPUPState (..), UTxOState (..), keyRefunds)
 import qualified Shelley.Spec.Ledger.LedgerState as Shelley
 import Shelley.Spec.Ledger.PParams (Update)
 import Shelley.Spec.Ledger.STS.Ppup (PPUP, PPUPEnv (..), PpupPredicateFailure)
@@ -251,3 +260,64 @@ instance
   Embed (PPUP era) (UTXOS era)
   where
   wrapFailed = UpdateFailure
+
+-- =================================================================
+
+constructValidated ::
+  forall era m.
+  ( MonadError [UtxosPredicateFailure era] m,
+    Era era,
+    Eq (Core.PParams era),
+    Show (Core.PParams era),
+    Show (PParamsDelta era),
+    Eq (PParamsDelta era),
+    ToCBOR (Core.AuxiliaryData era),
+    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
+    State (Core.EraRule "PPUP" era) ~ PPUPState era,
+    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
+    Embed (Core.EraRule "PPUP" era) (UTXOS era),
+    Core.Script era ~ Script era,
+    Core.TxOut era ~ Alonzo.TxOut era,
+    Core.Value era ~ Value (Crypto era),
+    Core.TxBody era ~ Alonzo.TxBody era,
+    Core.Witnesses era ~ Alonzo.TxWitness era,
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    HasField "update" (Core.TxBody era) (StrictMaybe (Update era)),
+    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
+    HasField "_keyDeposit" (Core.PParams era) Coin,
+    HasField "_poolDeposit" (Core.PParams era) Coin,
+    HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
+    HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
+    HasField "txinputs_fee" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era))
+  ) =>
+  Globals ->
+  UtxoEnv era ->
+  UTxOState era ->
+  Core.Tx era ->
+  m (UTxOState era, ValidatedTx era)
+constructValidated globals env@(UtxoEnv _ pp _ _) st tx =
+  case collectTwoPhaseScriptInputs pp tx utxo of
+    Left errs -> throwError [ShouldNeverHappenScriptInputsNotFound errs]
+    Right sLst ->
+      let scriptEvalResult = evalScripts @era tx sLst
+          vTx =
+            ValidatedTx
+              (getField @"body" tx)
+              (getField @"wits" tx)
+              (IsValidating scriptEvalResult)
+              (getField @"auxiliaryData" tx)
+          (newState, errs) =
+            flip runReader globals . runTransitionRule (TRC (env, st, vTx)) $
+              if scriptEvalResult
+                then scriptsValidateTransition
+                else scriptsNotValidateTransition
+       in case errs of
+            [] -> pure (newState, vTx)
+            _ -> throwError errs
+  where
+    runTransitionRule :: RuleInterpreter
+    runTransitionRule = applyRuleInternal ValidateAll runSTS
+    runSTS :: STSInterpreter
+    runSTS = applySTSInternal AssertionsOff runTransitionRule
+    utxo = _utxo st

alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs

@@ -532,13 +532,15 @@ getMapFromValue (Value _ m) = m
 
 -- | Find the Data and ExUnits assigned to a script.
 indexedRdmrs ::
-  forall era.
+  forall era tx.
   ( Era era,
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
     HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
-    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era)))
+    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
+    HasField "wits" tx (TxWitness era), -- Generalized over tx, so tx can be Tx or TxInBlock
+    HasField "body" tx (Core.TxBody era)
   ) =>
-  ValidatedTx era ->
+  tx ->
   ScriptPurpose (Crypto era) ->
   Maybe (Data era, ExUnits)
 indexedRdmrs tx sp = case rdptr @era (getField @"body" tx) sp of

alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs

@@ -25,6 +25,7 @@ import Cardano.Ledger.Alonzo.TxBody
     wdrls',
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..))
+import Cardano.Ledger.Alonzo.TxWitness (TxWitness)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core as Core (TxBody, TxOut, Value)
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
@@ -268,14 +269,16 @@ transScriptPurpose (Certifying dcert) = P.Certifying (transDCert dcert)
 -- | Compute a Digest of the current transaction to pass to the script
 --   This is the major component of the valContext function.
 transTx ::
-  forall era.
+  forall era tx.
   ( Era era,
     Core.TxOut era ~ Alonzo.TxOut era,
     Core.TxBody era ~ Alonzo.TxBody era,
-    Value era ~ Mary.Value (Crypto era)
+    Value era ~ Mary.Value (Crypto era),
+    HasField "body" tx (Core.TxBody era),
+    HasField "wits" tx (TxWitness era)
   ) =>
   UTxO era ->
-  ValidatedTx era ->
+  tx ->
   P.TxInfo
 transTx utxo tx =
   P.TxInfo
@@ -292,15 +295,13 @@ transTx utxo tx =
       P.txInfoId = (P.TxId (transSafeHash (hashAnnotated @(Crypto era) tbody)))
     }
   where
-    tbody = body' tx
-    _witnesses = wits' tx
-    _isval = isValidating' tx
-    _auxdat = auxiliaryData' tx
+    tbody = getField @"body" tx
+    _witnesses = getField @"wits" tx
     outs = outputs' tbody
     fee = txfee' tbody
     forge = mint' tbody
     interval = vldt' tbody
-    datpairs = Map.toList (txdats' (wits' tx))
+    datpairs = Map.toList (txdats' _witnesses)
 
 -- ===============================================================
 -- From the specification, Figure 7 "Script Validation, cont."