Merge pull request #2263 from input-output-hk/ts-EraGen-alonzo

Added EraGen instance for Alonzo

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

@@ -37,15 +37,11 @@ import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS, constructVa
 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
-  ( ValidatedTx (..),
-    body',
-    wits',
-  )
-import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut (..), vldt')
+import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
+import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut (..))
 import Cardano.Ledger.Alonzo.TxInfo (validPlutusdata, validScript)
 import qualified Cardano.Ledger.Alonzo.TxSeq as Alonzo (TxSeq (..), hashTxSeq)
-import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey'))
+import Cardano.Ledger.Alonzo.TxWitness (TxWitness)
 import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..), ValidateAuxiliaryData (..))
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CC
@@ -59,14 +55,13 @@ import Cardano.Ledger.Shelley.Constraints
     UsesTxOut (..),
     UsesValue,
   )
-import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock)
+import Cardano.Ledger.ShelleyMA.Timelocks (validateTimelock)
 import Cardano.Ledger.Tx (Tx (Tx))
 import Control.Arrow (left)
 import Control.Monad (join)
 import Control.Monad.Except (liftEither, runExcept)
 import Control.Monad.Reader (runReader)
 import Control.State.Transition.Extended (TRC (TRC))
-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
@@ -90,7 +85,6 @@ 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)
 
 -- =====================================================
 
@@ -147,14 +141,7 @@ instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where
     if isPlutusScript script
       then "\x01"
       else nativeMultiSigTag -- "\x00"
-  validateScript (TimelockScript timelock) tx =
-    evalTimelock
-      vhks
-      (vldt' (body' tx))
-      timelock
-    where
-      vhks = Set.map witKeyHash (txwitsVKey' (wits' tx))
-  -- TODO check if instead we should filter plutus scripts before calling
+  validateScript (TimelockScript script) tx = validateTimelock @(AlonzoEra c) script tx
   validateScript (PlutusScript _) _tx = True
 
 -- To run a PlutusScript use Cardano.Ledger.Alonzo.TxInfo(runPLCScript)
@@ -187,16 +174,11 @@ type instance Core.PParams (AlonzoEra c) = PParams (AlonzoEra c)
 
 type instance Core.Witnesses (AlonzoEra c) = TxWitness (AlonzoEra c)
 
-instance CC.Crypto c => UsesValue (AlonzoEra c)
+type instance Core.PParamsDelta (AlonzoEra c) = PParamsUpdate (AlonzoEra c)
 
-instance
-  (CC.Crypto c) =>
-  UsesPParams (AlonzoEra c)
-  where
-  type
-    PParamsDelta (AlonzoEra c) =
-      PParamsUpdate (AlonzoEra c)
+instance CC.Crypto c => UsesValue (AlonzoEra c)
 
+instance (CC.Crypto c) => UsesPParams (AlonzoEra c) where
   mergePPUpdates _ = updatePParams
 
 instance CC.Crypto c => ValidateAuxiliaryData (AlonzoEra c) c where
@@ -277,3 +259,5 @@ type instance Core.EraRule "UPEC" (AlonzoEra c) = Shelley.UPEC (AlonzoEra c)
 type Self c = AlonzoEra c
 
 type Value era = V.Value (EraModule.Crypto era)
+
+type PParamsDelta era = PParamsUpdate era

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

@@ -28,6 +28,10 @@ module Cardano.Ledger.Alonzo.PParams
     updatePParams,
     getLanguageView,
     LangDepView (..),
+    retractPP,
+    extendPP,
+    ppPParams,
+    ppPParamsUpdate,
   )
 where
 
@@ -37,15 +41,32 @@ import Cardano.Binary
     ToCBOR (..),
     encodePreEncoded,
   )
-import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.Language (Language (PlutusV1), ppLanguage)
 import Cardano.Ledger.Alonzo.Scripts
   ( CostModel,
     ExUnits (..),
     Prices (..),
+    ppCostModel,
+    ppExUnits,
+    ppPrices,
   )
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Era
 import Cardano.Ledger.Hashes (EraIndependentPParamView)
+import Cardano.Ledger.Pretty
+  ( PDoc,
+    PrettyA (prettyA),
+    ppCoin,
+    ppEpochNo,
+    ppMap,
+    ppNatural,
+    ppNonce,
+    ppProtVer,
+    ppRational,
+    ppRecord,
+    ppStrictMaybe,
+    ppUnitInterval,
+  )
 import Cardano.Ledger.SafeHash
   ( HashAnnotated (..),
     SafeToHash (..),
@@ -85,6 +106,7 @@ import Shelley.Spec.Ledger.BaseTypes
   )
 import Shelley.Spec.Ledger.Orphans ()
 import Shelley.Spec.Ledger.PParams (HKD, ProtVer (..))
+import qualified Shelley.Spec.Ledger.PParams as Shelley (PParams' (..))
 import Shelley.Spec.Ledger.Serialization
   ( FromCBORGroup (..),
     ToCBORGroup (..),
@@ -596,3 +618,107 @@ getLanguageView ::
   Language ->
   Maybe (LangDepView era)
 getLanguageView pp PlutusV1 = PlutusView <$> Map.lookup PlutusV1 (_costmdls pp)
+
+-- Usefull in tests and in translating from earlier Era to the Alonzo Era.
+
+-- | Turn an PParams' into a Shelley.Params'
+retractPP :: (HKD f Coin) -> PParams' f era2 -> Shelley.PParams' f era1
+retractPP
+  c
+  (PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv mnP _ _ _ _ _ _ _ _) =
+    (Shelley.PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv c mnP)
+
+-- | Given the missing pieces Turn a Shelley.PParams' into an Params'
+extendPP ::
+  Shelley.PParams' f era1 ->
+  (HKD f Coin) ->
+  (HKD f (Map Language CostModel)) ->
+  (HKD f Prices) ->
+  (HKD f ExUnits) ->
+  (HKD f ExUnits) ->
+  (HKD f Natural) ->
+  (HKD f Natural) ->
+  (HKD f Natural) ->
+  PParams' f era2
+extendPP
+  (Shelley.PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv _ mnP)
+  ada
+  cost
+  price
+  mxTx
+  mxBl
+  mxV
+  col
+  mxCol =
+    PParams ma mb mxBB mxT mxBH kd pd emx a n rho tau d eE pv mnP ada cost price mxTx mxBl mxV col mxCol
+
+-- ======================================================
+-- Pretty instances
+
+ppPParams :: PParams' Identity era -> PDoc
+ppPParams (PParams feeA feeB mbb mtx mbh kd pd em no a0 rho tau d ex pv mpool ada cost prices mxEx mxBEx mxV c mxC) =
+  ppRecord
+    "PParams"
+    [ ("minfeeA", ppNatural feeA),
+      ("minfeeB", ppNatural feeB),
+      ("maxBBSize", ppNatural mbb),
+      ("maxTxSize", ppNatural mtx),
+      ("maxBHSize", ppNatural mbh),
+      ("keyDeposit", ppCoin kd),
+      ("poolDeposit", ppCoin pd),
+      ("eMax", ppEpochNo em),
+      ("nOpt", ppNatural no),
+      ("a0", ppRational a0),
+      ("rho", ppUnitInterval rho),
+      ("tau", ppUnitInterval tau),
+      ("d", ppUnitInterval d),
+      ("extraEntropy", ppNonce ex),
+      ("protocolVersion", ppProtVer pv),
+      ("minPoolCost", ppCoin mpool),
+      ("adaPerWord", ppCoin ada),
+      ("costmdls", ppMap ppLanguage ppCostModel cost),
+      ("prices", ppPrices prices),
+      ("maxTxExUnits", ppExUnits mxEx),
+      ("maxBlockExUnits", ppExUnits mxBEx),
+      ("maxValSize", ppNatural mxV),
+      ("collateral%", ppNatural c),
+      ("maxCollateralInputs", ppNatural mxC)
+    ]
+
+instance PrettyA (PParams' Identity era) where
+  prettyA = ppPParams
+
+ppPParamsUpdate :: PParams' StrictMaybe era -> PDoc
+ppPParamsUpdate (PParams feeA feeB mbb mtx mbh kd pd em no a0 rho tau d ex pv mpool ada cost prices mxEx mxBEx mxV c mxC) =
+  ppRecord
+    "PParams"
+    [ ("minfeeA", lift ppNatural feeA),
+      ("minfeeB", lift ppNatural feeB),
+      ("maxBBSize", lift ppNatural mbb),
+      ("maxTxSize", lift ppNatural mtx),
+      ("maxBHSize", lift ppNatural mbh),
+      ("keyDeposit", lift ppCoin kd),
+      ("poolDeposit", lift ppCoin pd),
+      ("eMax", lift ppEpochNo em),
+      ("nOpt", lift ppNatural no),
+      ("a0", lift ppRational a0),
+      ("rho", lift ppUnitInterval rho),
+      ("tau", lift ppUnitInterval tau),
+      ("d", lift ppUnitInterval d),
+      ("extraEntropy", lift ppNonce ex),
+      ("protocolVersion", lift ppProtVer pv),
+      ("minPoolCost", lift ppCoin mpool),
+      ("adaPerWord", lift ppCoin ada),
+      ("costmdls", lift (ppMap ppLanguage ppCostModel) cost),
+      ("prices", lift ppPrices prices),
+      ("maxTxExUnits", lift ppExUnits mxEx),
+      ("maxBlockExUnits", lift ppExUnits mxBEx),
+      ("maxValSize", lift ppNatural mxV),
+      ("collateral%", lift ppNatural c),
+      ("maxCollateralInputs", lift ppNatural mxC)
+    ]
+  where
+    lift pp x = ppStrictMaybe pp x
+
+instance PrettyA (PParams' StrictMaybe era) where
+  prettyA = ppPParamsUpdate

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

@@ -26,7 +26,6 @@ import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx (..))
 import Cardano.Ledger.Coin (Coin)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Crypto, Era, TxInBlock)
-import Cardano.Ledger.Shelley.Constraints (PParamsDelta)
 import Control.State.Transition
   ( Assertion (..),
     AssertionViolation (..),
@@ -118,7 +117,7 @@ instance
     Show (Core.AuxiliaryData era),
     Show (Core.PParams era),
     Show (Core.Value era),
-    Show (PParamsDelta era),
+    Show (Core.PParamsDelta era),
     DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody),
     Era era,
     TxInBlock era ~ ValidatedTx era,

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

@@ -65,7 +65,7 @@ import Data.Coders
     (<!),
   )
 import Data.Coerce (coerce)
-import Data.Foldable (toList)
+import Data.Foldable (foldl', toList)
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -185,7 +185,7 @@ data UtxoPredicateFailure era
   | TriesToForgeADA
   | -- | list of supplied bad transaction outputs
     OutputTooBigUTxO
-      ![Core.TxOut era]
+      ![(Int, Int, Core.TxOut era)]
   | InsufficientCollateral
       !Coin
       -- ^ balance computed
@@ -370,13 +370,14 @@ utxoTransition = do
   -- use serialized length of Value because this Value size is being limited inside a serialized Tx
   let outputs = Map.elems $ unUTxO (txouts @era txb)
       maxValSize = getField @"_maxValSize" pp
-      outputsTooBig =
-        filter
-          ( \out ->
-              let v = getField @"value" out
-               in (fromIntegral . BSL.length . serialize) v > maxValSize
-          )
-          outputs
+      outputsTooBig = foldl' accum [] outputs
+        where
+          accum ans out =
+            let v = getField @"value" out
+                size = (fromIntegral . BSL.length . serialize) v
+             in if size > maxValSize
+                  then (fromIntegral size, fromIntegral maxValSize, out) : ans
+                  else ans
   null outputsTooBig ?! OutputTooBigUTxO outputsTooBig
 
   ni <- liftSTS $ asks networkId

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

@@ -35,7 +35,6 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Crypto, Era)
 import Cardano.Ledger.Mary.Value (Value)
 import Cardano.Ledger.Rules.ValidationMode ((?!#))
-import Cardano.Ledger.Shelley.Constraints (PParamsDelta)
 import qualified Cardano.Ledger.Val as Val
 import Control.Iterate.SetAlgebra (eval, (∪), (⋪), (◁))
 import Control.Monad.Except (MonadError (throwError))
@@ -76,8 +75,8 @@ instance
   ( Era era,
     Eq (Core.PParams era),
     Show (Core.PParams era),
-    Show (PParamsDelta era),
-    Eq (PParamsDelta era),
+    Show (Core.PParamsDelta era),
+    Eq (Core.PParamsDelta era),
     Embed (Core.EraRule "PPUP" era) (UTXOS era),
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,
@@ -111,8 +110,8 @@ utxosTransition ::
     Embed (Core.EraRule "PPUP" era) (UTXOS era),
     Eq (Core.PParams era),
     Show (Core.PParams era),
-    Show (PParamsDelta era),
-    Eq (PParamsDelta era),
+    Show (Core.PParamsDelta era),
+    Eq (Core.PParamsDelta era),
     Core.TxOut era ~ Alonzo.TxOut era,
     Core.Value era ~ Value (Crypto era),
     Core.TxBody era ~ Alonzo.TxBody era,
@@ -140,8 +139,8 @@ scriptsValidateTransition ::
     Embed (Core.EraRule "PPUP" era) (UTXOS era),
     Eq (Core.PParams era),
     Show (Core.PParams era),
-    Show (PParamsDelta era),
-    Eq (PParamsDelta era),
+    Show (Core.PParamsDelta era),
+    Eq (Core.PParamsDelta era),
     Core.Script era ~ Script era,
     Core.TxBody era ~ Alonzo.TxBody era,
     Core.TxOut era ~ Alonzo.TxOut era,
@@ -193,8 +192,8 @@ scriptsNotValidateTransition ::
   ( Era era,
     Eq (Core.PParams era),
     Show (Core.PParams era),
-    Show (PParamsDelta era),
-    Eq (PParamsDelta era),
+    Show (Core.PParamsDelta era),
+    Eq (Core.PParamsDelta era),
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,
     Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
@@ -301,8 +300,8 @@ constructValidated ::
     Era era,
     Eq (Core.PParams era),
     Show (Core.PParams era),
-    Show (PParamsDelta era),
-    Eq (PParamsDelta era),
+    Show (Core.PParamsDelta era),
+    Eq (Core.PParamsDelta era),
     ToCBOR (Core.AuxiliaryData era),
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,