Check length plutus bytestring data, and double check some tests.

In order to validate data in both AuxiliaryData and in the WitnessSet, deserializing
a Plutus Data, with a ByteString type, whose length is greater than 64 now raises
a deserialisation error. Added a new combinator (<?) to Data.Coders that lets any
'constructor' raise an error. Also added roundtrip tests to be sure we actually
catch these cases.

Before running plutus scripts, we collect their input data using their hashes and the Witnesses.
Previous PredicateFailure tests should ensure we find Data for every script, BUT
the consequences of not finding Data means scripts can get dropped, so things
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.

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

@@ -56,9 +56,9 @@ import Cardano.Ledger.Shelley.Constraints
   )
 import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock)
 import qualified Data.Set as Set
-import qualified Plutus.V1.Ledger.Api as Plutus (validateScript)
 import qualified Shelley.Spec.Ledger.API as API
 import qualified Shelley.Spec.Ledger.BaseTypes as Shelley
+import Shelley.Spec.Ledger.CompactAddr (CompactAddr)
 import Shelley.Spec.Ledger.Metadata (validMetadatum)
 import qualified Shelley.Spec.Ledger.STS.Epoch as Shelley
 import qualified Shelley.Spec.Ledger.STS.Mir as Shelley
@@ -90,7 +90,7 @@ instance
 
 -- instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c)
 
-instance API.PraosCrypto c => API.GetLedgerView (AlonzoEra c)
+instance (Show (CompactAddr c), API.PraosCrypto c) => API.GetLedgerView (AlonzoEra c)
 
 instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where
   isNativeScript x = not (isPlutusScript x)
@@ -105,8 +105,10 @@ instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where
       timelock
     where
       vhks = Set.map witKeyHash (txwitsVKey' (wits' tx))
-  validateScript (PlutusScript scr) _tx = Plutus.validateScript scr
+  validateScript (PlutusScript _) _tx = False
 
+-- To run a PlutusScript use Cardano.Ledger.Alonzo.TxInfo(runPLCScript)
+-- To run any Alonzo Script use Cardano.Ledger.Alonzo.PlutusScriptApi(evalScripts)
 -- hashScript x = ...  We use the default method for hashScript
 
 instance
@@ -118,8 +120,7 @@ instance
   -- initialState :: ShelleyGenesis era -> AdditionalGenesisConfig era -> NewEpochState era
   initialState _ _ = error "TODO: implement initialState"
 
-instance CC.Crypto c => UsesTxOut (AlonzoEra c) where
-  -- makeTxOut :: Proxy era -> Addr (Crypto era) -> Value era -> TxOut era
+instance (CC.Crypto c) => UsesTxOut (AlonzoEra c) where
   makeTxOut _proxy addr val = TxOut addr val Shelley.SNothing
 
 type instance Core.TxOut (AlonzoEra c) = TxOut (AlonzoEra c)

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

@@ -35,7 +35,7 @@ module Cardano.Ledger.Alonzo.Data
   )
 where
 
-import Cardano.Binary (FromCBOR (..), ToCBOR (..), TokenType (..), peekTokenType)
+import Cardano.Binary (FromCBOR (..), ToCBOR (..), TokenType (..), peekTokenType, withSlice)
 import Cardano.Ledger.Alonzo.Scripts
   ( Script (..),
     isPlutusScript,
@@ -69,6 +69,9 @@ import Cardano.Ledger.SafeHash
     hashAnnotated,
   )
 import Cardano.Prelude (HeapWords (..), heapWords0, heapWords1)
+import qualified Data.ByteString as BS (ByteString, length)
+import Data.ByteString.Lazy (toStrict)
+import Data.ByteString.Short (toShort)
 import Data.Coders
 import qualified Data.Foldable as Foldable
 import qualified Data.List as List
@@ -103,9 +106,15 @@ instance FromCBOR (Annotator Plutus.Data) where
           <*! (D $ decodeMapContentsTraverse fromCBOR fromCBOR)
       decPlutus 2 = Ann (SumD Plutus.List) <*! listDecodeA From
       decPlutus 3 = Ann (SumD Plutus.I <! From)
-      decPlutus 4 = Ann (SumD Plutus.B <! From)
+      decPlutus 4 = Ann (SumD checkPlutusByteString <? From)
       decPlutus n = Invalid n
 
+checkPlutusByteString :: BS.ByteString -> Either String Plutus.Data
+checkPlutusByteString s =
+  if BS.length s <= 64
+    then Right (Plutus.B s)
+    else Left ("Plutus Bytestring in Plutus Data has length greater than 64: " ++ show (BS.length s) ++ "\n  " ++ show s)
+
 instance ToCBOR Plutus.Data where
   toCBOR x = encode (encPlutus x)
     where
@@ -127,11 +136,10 @@ newtype Data era = DataConstr (MemoBytes Plutus.Data)
   deriving (Eq, Ord, Generic, Show)
   deriving newtype (SafeToHash, ToCBOR)
 
-deriving via
-  (Mem Plutus.Data)
-  instance
-    (Era era) =>
-    FromCBOR (Annotator (Data era))
+instance Typeable era => FromCBOR (Annotator (Data era)) where
+  fromCBOR = do
+    (Annotator getT, Annotator getBytes) <- withSlice fromCBOR
+    pure (Annotator (\fullbytes -> DataConstr (Memo (getT fullbytes) (toShort (toStrict (getBytes fullbytes))))))
 
 instance (Crypto era ~ c) => HashAnnotated (Data era) EraIndependentData c
 

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

@@ -340,14 +340,6 @@ instance NoThunks (PParamsUpdate era)
 -- writing only those fields where the field is (SJust x), that is the role of
 -- the local function (omitStrictMaybe key x)
 
-fromSJust :: StrictMaybe a -> a
-fromSJust (SJust x) = x
-fromSJust SNothing = error "SNothing in fromSJust"
-
-isSNothing :: StrictMaybe a -> Bool
-isSNothing SNothing = True
-isSNothing (SJust _) = False
-
 encodePParamsUpdate ::
   PParamsUpdate era ->
   Encode ('Closed 'Sparse) (PParamsUpdate era)
@@ -380,6 +372,14 @@ encodePParamsUpdate ppup =
       Word -> StrictMaybe a -> (a -> Encoding) -> Encode ('Closed 'Sparse) (StrictMaybe a)
     omitStrictMaybe key x enc = Omit isSNothing (Key key (E (enc . fromSJust) x))
 
+    fromSJust :: StrictMaybe a -> a
+    fromSJust (SJust x) = x
+    fromSJust SNothing = error "SNothing in fromSJust. This should never happen, it is guarded by isSNothing."
+
+    isSNothing :: StrictMaybe a -> Bool
+    isSNothing SNothing = True
+    isSNothing (SJust _) = False
+
 instance (Era era) => ToCBOR (PParamsUpdate era) where
   toCBOR ppup = encode (encodePParamsUpdate ppup)
 

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

@@ -124,7 +124,7 @@ utxosTransition =
 
 scriptsValidateTransition ::
   forall era.
-  ( Show (Core.Value era), -- Arises because of the use of (∪) from SetAlgebra, needs Show to report errors.
+  ( Show (Core.Value era), -- Arises because of the use of (∪) from SetAlgebra, needs Show to report problems.
     Era era,
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,

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

@@ -94,18 +94,21 @@ data AlonzoPredFail era
 
 deriving instance
   ( Era era,
-    Show (PredicateFailure (Core.EraRule "UTXO" era)) -- The Shelley UtxowPredicateFailure needs this to Show
+    Show (PredicateFailure (Core.EraRule "UTXO" era)), -- The Shelley UtxowPredicateFailure needs this to Show
+    Show (Core.Script era)
   ) =>
   Show (AlonzoPredFail era)
 
 deriving instance
   ( Era era,
-    Eq (PredicateFailure (Core.EraRule "UTXO" era)) -- The Shelley UtxowPredicateFailure needs this to Eq
+    Eq (PredicateFailure (Core.EraRule "UTXO" era)), -- The Shelley UtxowPredicateFailure needs this to Eq
+    Eq (Core.Script era)
   ) =>
   Eq (AlonzoPredFail era)
 
 instance
   ( Era era,
+    NoThunks (Core.Script era),
     NoThunks (PredicateFailure (Core.EraRule "UTXO" era))
   ) =>
   NoThunks (AlonzoPredFail era)
@@ -114,7 +117,8 @@ instance
   ( Era era,
     ToCBOR (PredicateFailure (Core.EraRule "UTXO" era)),
     Typeable (Core.AuxiliaryData era),
-    Typeable (Core.Script era)
+    Typeable (Core.Script era),
+    ToCBOR (Core.Script era)
   ) =>
   ToCBOR (AlonzoPredFail era)
   where
@@ -142,7 +146,8 @@ instance
     FromCBOR (PredicateFailure (Core.EraRule "UTXO" era)),
     FromCBOR (Script era),
     Typeable (Core.Script era),
-    Typeable (Core.AuxiliaryData era)
+    Typeable (Core.AuxiliaryData era),
+    FromCBOR (Core.Script era)
   ) =>
   FromCBOR (AlonzoPredFail era)
   where

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

@@ -496,24 +496,22 @@ instance (Typeable c, CC.Crypto c) => FromCBOR (ScriptPurpose c) where
 -- =======================================
 
 class Indexable elem container where
-  indexOf :: elem -> container -> Word64
-  atIndex :: Word64 -> container -> elem
+  indexOf :: elem -> container -> StrictMaybe Word64
 
 instance Ord k => Indexable k (Set k) where
-  indexOf n set = fromIntegral $ Set.findIndex n set
-  atIndex i set = Set.elemAt (fromIntegral i) set
+  indexOf n set = case Set.lookupIndex n set of
+    Just x -> SJust (fromIntegral x)
+    Nothing -> SNothing
 
 instance Eq k => Indexable k (StrictSeq k) where
   indexOf n seqx = case StrictSeq.findIndexL (== n) seqx of
-    Just m -> fromIntegral m
-    Nothing -> error "Not found in StrictSeq"
-  atIndex i seqx = case StrictSeq.lookup (fromIntegral i) seqx of
-    Just element -> element
-    Nothing -> error ("No elem at index " ++ show i)
+    Just m -> SJust (fromIntegral m)
+    Nothing -> SNothing
 
 instance Ord k => Indexable k (Map.Map k v) where
-  indexOf n mp = fromIntegral $ Map.findIndex n mp
-  atIndex i mp = fst (Map.elemAt (fromIntegral i) mp) -- If one needs the value, on can use Map.Lookup
+  indexOf n mp = case Map.lookupIndex n mp of
+    Just x -> SJust (fromIntegral x)
+    Nothing -> SNothing
 
 rdptr ::
   forall era.
@@ -524,11 +522,11 @@ rdptr ::
   ) =>
   Core.TxBody era ->
   ScriptPurpose (Crypto era) ->
-  RdmrPtr
-rdptr txb (Minting (PolicyID hash)) = RdmrPtr Mint (indexOf hash ((getField @"minted" txb) :: Set (ScriptHash (Crypto era))))
-rdptr txb (Spending txin) = RdmrPtr Spend (indexOf txin (getField @"inputs" txb))
-rdptr txb (Rewarding racnt) = RdmrPtr Rewrd (indexOf racnt (unWdrl (getField @"wdrls" txb)))
-rdptr txb (Certifying d) = RdmrPtr Cert (indexOf d (getField @"certs" txb))
+  StrictMaybe RdmrPtr
+rdptr txb (Minting (PolicyID hash)) = RdmrPtr Mint <$> (indexOf hash ((getField @"minted" txb) :: Set (ScriptHash (Crypto era))))
+rdptr txb (Spending txin) = RdmrPtr Spend <$> (indexOf txin (getField @"inputs" txb))
+rdptr txb (Rewarding racnt) = RdmrPtr Rewrd <$> (indexOf racnt (unWdrl (getField @"wdrls" txb)))
+rdptr txb (Certifying d) = RdmrPtr Cert <$> (indexOf d (getField @"certs" txb))
 
 getMapFromValue :: Value crypto -> Map.Map (PolicyID crypto) (Map.Map AssetName Integer)
 getMapFromValue (Value _ m) = m
@@ -544,10 +542,11 @@ indexedRdmrs ::
   ValidatedTx era ->
   ScriptPurpose (Crypto era) ->
   Maybe (Data era, ExUnits)
-indexedRdmrs tx sp = Map.lookup rdptr' rdmrs
-  where
-    rdmrs = unRedeemers $ txrdmrs' . getField @"wits" $ tx
-    rdptr' = rdptr @era (getField @"body" tx) sp
+indexedRdmrs tx sp = case rdptr @era (getField @"body" tx) sp of
+  SNothing -> Nothing
+  SJust policyid -> Map.lookup policyid rdmrs
+    where
+      rdmrs = unRedeemers $ txrdmrs' . getField @"wits" $ tx
 
 -- =======================================================
 

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

@@ -141,12 +141,24 @@ deriving stock instance
   ) =>
   Eq (TxOut era)
 
+viewCompactTxOut ::
+  forall era.
+  (Era era) =>
+  TxOut era ->
+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))
+viewCompactTxOut (TxOutCompact bs c dh) = (addr, val, dh)
+  where
+    addr = decompactAddr bs
+    val = fromCompact c
+
 instance
-  ( Show (Core.Value era)
+  ( Era era,
+    Show (Core.Value era),
+    Show (CompactForm (Core.Value era))
   ) =>
   Show (TxOut era)
   where
-  show = error "Not yet implemented"
+  show = show . viewCompactTxOut
 
 deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)
 
@@ -210,7 +222,11 @@ instance
   NoThunks (TxBodyRaw era)
 
 deriving instance
-  (Era era, Show (Core.Value era), Show (PParamsDelta era)) =>
+  ( Era era,
+    Show (Core.Value era),
+    Show (PParamsDelta era),
+    Show (CompactAddr (Crypto era))
+  ) =>
   Show (TxBodyRaw era)
 
 newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))
@@ -236,7 +252,8 @@ deriving instance
   ( Era era,
     Compactible (Core.Value era),
     Show (Core.Value era),
-    Show (PParamsDelta era)
+    Show (PParamsDelta era),
+    Show (CompactAddr (Crypto era))
   ) =>
   Show (TxBody era)
 
@@ -483,7 +500,7 @@ encodeTxBodyRaw
 
       fromSJust :: StrictMaybe a -> a
       fromSJust (SJust x) = x
-      fromSJust SNothing = error "SNothing in fromSJust"
+      fromSJust SNothing = error "SNothing in fromSJust. This should never happen, it is guarded by isSNothing"
 
 instance
   forall era.

alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Ledger.Alonzo.Serialisation.Tripping where
 
 import Cardano.Binary
 import Cardano.Ledger.Alonzo (AlonzoEra)
-import Cardano.Ledger.Alonzo.Data (AuxiliaryData, Data)
+import Cardano.Ledger.Alonzo.Data (AuxiliaryData, Data (..))
 import Cardano.Ledger.Alonzo.PParams (PParams, PParamsUpdate)
 import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure)
 import Cardano.Ledger.Alonzo.Rules.Utxos (UtxosPredicateFailure)
@@ -16,8 +17,10 @@ import Cardano.Ledger.Alonzo.Scripts (Script)
 import Cardano.Ledger.Alonzo.Tx (CostModel, WitnessPPData)
 import Cardano.Ledger.Alonzo.TxBody (TxBody)
 import Cardano.Ledger.Alonzo.TxWitness
+import qualified Data.ByteString as BS (ByteString)
 import qualified Data.ByteString.Base16.Lazy as Base16
 import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Language.PlutusTx as Plutus
 import Shelley.Spec.Ledger.Metadata (Metadata)
 import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
 import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders (roundTrip, roundTripAnn)
@@ -64,6 +67,15 @@ trippingAnn x = trippingF roundTripAnn x
 tripping :: (Eq src, Show src, ToCBOR src, FromCBOR src) => src -> Property
 tripping x = trippingF roundTrip x
 
+-- ==========================
+-- Catch violations ofbytestrings that are toolong.
+
+toolong :: BS.ByteString
+toolong = "1234567890-=`~@#$%^&*()_+qwertyuiopQWERTYUIOPasdfghjklASDFGHJKLzxcvbnmZXCVBNM"
+
+badData :: Data (AlonzoEra C_Crypto)
+badData = Data $ Plutus.List [Plutus.I 34, Plutus.B toolong]
+
 tests :: TestTree
 tests =
   testGroup
@@ -72,6 +84,7 @@ tests =
         trippingAnn @(Script (AlonzoEra C_Crypto)),
       testProperty "alonzo/Data" $
         trippingAnn @(Data (AlonzoEra C_Crypto)),
+      testProperty "alonzo/Data/CatchToolong" (expectFailure (trippingAnn badData)),
       testProperty "alonzo/Metadata" $
         trippingAnn @(Metadata (AlonzoEra C_Crypto)),
       testProperty "alonzo/TxWitness" $

cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs

@@ -5,14 +5,15 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Benchmarks for transaction application
 module Bench.Cardano.Ledger.ApplyTx (applyTxBenchmarks) where
 
 import Cardano.Binary
 import Cardano.Ledger.Allegra (AllegraEra)
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Era (Era)
+import Cardano.Ledger.Era (Era, ValidateScript)
 import Cardano.Ledger.Mary (MaryEra)
 import Cardano.Ledger.Shelley (ShelleyEra)
 import Control.DeepSeq (NFData (..))
@@ -34,7 +35,6 @@ import Shelley.Spec.Ledger.API
     Tx,
     applyTxsTransition,
   )
-import Shelley.Spec.Ledger.PParams (PParams' (..))
 import Shelley.Spec.Ledger.Slot (SlotNo (SlotNo))
 import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C_Crypto)
 import Test.Shelley.Spec.Ledger.Utils (testGlobals)
@@ -140,7 +140,10 @@ applyTxGroup =
 deserialiseTxEra ::
   forall era.
   ( Era era,
-    ApplyTx era
+    ValidateScript era,
+    FromCBOR (Annotator (Core.TxBody era)),
+    FromCBOR (Annotator (Core.AuxiliaryData era)),
+    FromCBOR (Annotator (Core.Witnesses era))
   ) =>
   Proxy era ->
   Benchmark