IntersectMBO · nc6 · Apr 20, 2021 · Apr 1, 2021
@@ -56,7 +56,6 @@ 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.Metadata (validMetadatum)
@@ -90,7 +89,7 @@ instance
 
 -- instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c)
 
-instance API.PraosCrypto c => API.GetLedgerView (AlonzoEra c)
+instance (API.PraosCrypto c) => API.GetLedgerView (AlonzoEra c)
 
 instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where
   isNativeScript x = not (isPlutusScript x)
@@ -105,8 +104,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 +119,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)

@@ -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
 

@@ -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)
 

@@ -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,

@@ -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

@@ -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
 
 -- =======================================================
 

@@ -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,10 @@ 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 (TxBodyRaw era)
 
 newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))
@@ -483,7 +498,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.

@@ -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" $

@@ -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