BBODY examples

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

@@ -11,7 +11,6 @@
 module Cardano.Ledger.Alonzo.PlutusScriptApi
   ( -- Figure 8
     getData,
-    collectNNScriptInputs,
     evalScripts,
     -- Figure 12
     scriptsNeeded,
@@ -48,7 +47,7 @@ import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock)
 import Data.Coders
 import Data.List (foldl')
 import qualified Data.Map as Map
-import Data.Maybe (isJust, maybeToList)
+import Data.Maybe (isJust)
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -101,32 +100,6 @@ getData tx (UTxO m) sp = case sp of
               Nothing -> []
               Just d -> [d]
 
--- | Collect the inputs (Data, execution budget, costModel) for all twoPhase scripts.
-collectNNScriptInputs ::
-  ( Era era,
-    Core.Script era ~ AlonzoScript.Script era,
-    Core.TxOut era ~ Alonzo.TxOut era,
-    Core.TxBody era ~ Alonzo.TxBody era,
-    Core.Value era ~ Mary.Value (Crypto era),
-    HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
-    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)))
-  ) =>
-  Core.PParams era ->
-  ValidatedTx era ->
-  UTxO era ->
-  [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)]
-collectNNScriptInputs pp tx utxo =
-  let txinfo = transTx utxo tx
-   in [ (script, d : (valContext txinfo sp : getData tx utxo sp), eu, cost)
-        | (sp, scripthash) <- scriptsNeeded utxo tx, -- TODO, IN specification ORDER IS WRONG
-          (d, eu) <- maybeToList (indexedRdmrs tx sp),
-          script <- maybeToList (Map.lookup scripthash (txscripts' (getField @"wits" tx))),
-          cost <- maybeToList (Map.lookup PlutusV1 (getField @"_costmdls" pp))
-      ]
-
 -- ========================================================================
 
 -- | When collecting inputs for twophase scripts, 3 things can go wrong.
@@ -189,7 +162,8 @@ collectTwoPhaseScriptInputs pp tx utxo =
       case Map.lookup hash (txscripts' (getField @"wits" tx)) of
         Just script -> Right script
         Nothing -> Left (NoWitness hash)
-    apply cost (sp, d, eu) script = (script, d : (valContext txinfo sp) : (getData tx utxo sp), eu, cost)
+    apply cost (sp, d, eu) script =
+      (script, getData tx utxo sp ++ (d : [valContext txinfo sp]), eu, cost)
 
 -- | Merge two lists (either of which may have failures, i.e. (Left _)), collect all the failures
 --   but if there are none, use 'f' to construct a success.

alonzo/test/cardano-ledger-alonzo-test.cabal

@@ -61,13 +61,15 @@ test-suite cardano-ledger-alonzo-test
   other-modules:
     Test.Cardano.Ledger.Alonzo.Golden
     Test.Cardano.Ledger.Alonzo.Serialisation.Tripping
+    Test.Cardano.Ledger.Alonzo.Examples.Bbody
     Test.Cardano.Ledger.Alonzo.Examples.Utxow
     Test.Cardano.Ledger.Alonzo.Translation
     Test.Cardano.Ledger.Alonzo.Serialisation.CDDL
   build-depends:
     base16-bytestring,
     bytestring,
     cardano-binary,
+    cardano-crypto-class,
     cardano-ledger-alonzo,
     cardano-ledger-alonzo-test,
     cardano-ledger-shelley-ma,

alonzo/test/test/Test/Cardano/Ledger/Alonzo/Examples/Bbody.hs

@@ -0,0 +1,177 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Ledger.Alonzo.Examples.Bbody
+  ( bbodyExamples,
+  )
+where
+
+import Cardano.Crypto.VRF (evalCertified)
+import Cardano.Ledger.Alonzo (AlonzoEra)
+import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..))
+import Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBBODY)
+import Cardano.Ledger.Alonzo.Scripts (CostModel (..), ExUnits (..))
+import Cardano.Ledger.Alonzo.Tx (ValidatedTx)
+import Cardano.Ledger.Alonzo.TxSeq (TxSeq (..), hashTxSeq)
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Crypto (Crypto (..))
+import Control.State.Transition.Extended hiding (Assertion)
+import Control.State.Transition.Trace (checkTrace, (.-), (.->))
+import Data.Coerce (coerce)
+import Data.Default.Class (def)
+import qualified Data.Map.Strict as Map
+import qualified Data.Sequence.Strict as StrictSeq
+import Shelley.Spec.Ledger.API
+  ( BHBody (..),
+    BHeader (..),
+    Block (..),
+    DPState (..),
+    DState (..),
+    KESPeriod (..),
+    LedgerState (..),
+    Nonce (NeutralNonce),
+    OCert (..),
+    PrevHash (GenesisHash),
+    ProtVer (..),
+    UTxO (..),
+  )
+import Shelley.Spec.Ledger.BlockChain (bBodySize, mkSeed, seedEta, seedL)
+import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..))
+import Shelley.Spec.Ledger.Keys (KeyPair (..), KeyRole (..), coerceKeyRole, hashKey, signedDSIGN, signedKES)
+import Shelley.Spec.Ledger.LedgerState (UTxOState (..))
+import Shelley.Spec.Ledger.OCert (OCertSignable (..))
+import Shelley.Spec.Ledger.STS.Bbody (BbodyEnv (..), BbodyState (..))
+import Shelley.Spec.Ledger.Slot (BlockNo (..), SlotNo (..))
+import Shelley.Spec.Ledger.TxBody (TxIn (..))
+import Shelley.Spec.Ledger.UTxO (txid)
+import qualified Test.Cardano.Ledger.Alonzo.Examples.Utxow as UTXOW
+import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C_Crypto)
+import Test.Shelley.Spec.Ledger.Generator.EraGen (genesisId)
+import Test.Shelley.Spec.Ledger.Utils
+  ( applySTSTest,
+    mkKESKeyPair,
+    mkKeyPair,
+    mkVRFKeyPair,
+    runShelleyBase,
+  )
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, testCase, (@?=))
+
+type A = AlonzoEra C_Crypto
+
+-- =======================
+-- Setup the initial state
+-- =======================
+
+pp :: PParams A
+pp =
+  def
+    { _costmdls = Map.singleton PlutusV1 (CostModel mempty),
+      _maxValSize = 1000000000,
+      _maxTxExUnits = ExUnits 1000000 1000000,
+      _maxBlockExUnits = ExUnits 1000000 1000000
+    }
+
+bbodyEnv :: BbodyEnv A
+bbodyEnv = BbodyEnv pp def
+
+-- =======
+--  Tests
+-- =======
+
+dpstate :: DPState C_Crypto
+dpstate = def {_dstate = def {_rewards = Map.singleton UTXOW.scriptStakeCredSuceed (Coin 1000)}}
+
+initialBBodyState :: BbodyState A
+initialBBodyState = BbodyState (LedgerState UTXOW.initialUtxoSt dpstate) (BlocksMade mempty)
+
+coldKeys :: KeyPair 'BlockIssuer C_Crypto
+coldKeys = KeyPair skCold vkCold
+  where
+    (vkCold, skCold) = mkKeyPair @C_Crypto (0, 0, 0, 0, 1)
+
+makeNaiveBlock :: [ValidatedTx A] -> Block A
+makeNaiveBlock txs = Block (BHeader bhb sig) txs'
+  where
+    bhb =
+      BHBody
+        { bheaderBlockNo = BlockNo 0,
+          bheaderSlotNo = SlotNo 0,
+          bheaderPrev = GenesisHash,
+          bheaderVk = vKey coldKeys,
+          bheaderVrfVk = vvrf,
+          bheaderEta = coerce $ evalCertified () nonceNonce svrf,
+          bheaderL = coerce $ evalCertified () leaderNonce svrf,
+          bsize = fromIntegral $ bBodySize txs',
+          bhash = hashTxSeq txs',
+          bheaderOCert =
+            OCert
+              vkes
+              0
+              (KESPeriod 0)
+              (signedDSIGN @C_Crypto (sKey coldKeys) (OCertSignable vkes 0 (KESPeriod 0))),
+          bprotver = ProtVer 5 0
+        }
+    sig = signedKES () 0 bhb skes
+    nonceNonce = mkSeed seedEta (SlotNo 0) NeutralNonce
+    leaderNonce = mkSeed seedL (SlotNo 0) NeutralNonce
+    txs' = TxSeq . StrictSeq.fromList $ txs
+    (svrf, vvrf) = mkVRFKeyPair @(VRF C_Crypto) (0, 0, 0, 0, 2)
+    (skes, vkes) = mkKESKeyPair @(KES C_Crypto) (0, 0, 0, 0, 3)
+
+testBlock :: Block A
+testBlock =
+  makeNaiveBlock
+    [ UTXOW.validatingTx,
+      UTXOW.notValidatingTx,
+      UTXOW.validatingTxWithWithdrawal,
+      UTXOW.notValidatingTxWithWithdrawal,
+      UTXOW.validatingTxWithCert,
+      UTXOW.notValidatingTxWithCert,
+      UTXOW.validatingTxWithMint,
+      UTXOW.notValidatingTxWithMint
+    ]
+
+example1UTxO :: UTxO A
+example1UTxO =
+  UTxO $
+    Map.fromList
+      [ (TxIn genesisId 9, UTXOW.alwaysFailsOutput),
+        (TxIn (txid @A UTXOW.validatingBody) 0, UTXOW.outEx1),
+        (TxIn (txid @A UTXOW.validatingBodyWithCert) 0, UTXOW.outEx3),
+        (TxIn (txid @A UTXOW.validatingBodyWithWithdrawal) 0, UTXOW.outEx5),
+        (TxIn (txid @A UTXOW.validatingBodyWithMint) 0, UTXOW.outEx7)
+      ]
+
+example1UtxoSt :: UTxOState A
+example1UtxoSt = UTxOState example1UTxO (Coin 0) (Coin 4020) def
+
+example1BBodyState :: BbodyState A
+example1BBodyState =
+  BbodyState (LedgerState example1UtxoSt def) (BlocksMade $ Map.singleton poolID 1)
+  where
+    poolID = hashKey . vKey . coerceKeyRole $ coldKeys
+
+testBBODY ::
+  BbodyState A ->
+  Block A ->
+  Either [[PredicateFailure (AlonzoBBODY A)]] (BbodyState A) ->
+  Assertion
+testBBODY initialSt block (Right expectedSt) =
+  checkTrace @(AlonzoBBODY A) runShelleyBase bbodyEnv $
+    pure initialSt .- block .-> expectedSt
+testBBODY initialSt block predicateFailure@(Left _) = do
+  let st = runShelleyBase $ applySTSTest @(AlonzoBBODY A) (TRC (bbodyEnv, initialSt, block))
+  st @?= predicateFailure
+
+bbodyExamples :: TestTree
+bbodyExamples =
+  testGroup
+    "bbody examples"
+    [ testCase "eight plutus scripts cases" $
+        testBBODY initialBBodyState testBlock (Right example1BBodyState)
+    ]