Removed calls to error.

Removed calls to error, because the method indexOf might fail. Also tracked down a few others. Also discovered that STS.ApplyTx hardcodes in Shelley Tx, rather than Core.Tx Relplace Tx with COre.Tx is its defintion in Shelley.Spec.Ledger.API.Mempool Still Having some trouble writing an ApplyTX for Alonzo.
IntersectMBO · Apr 9, 2021 · a9db549 · a9db549
1 parent a129af0
commit a9db549
Show file tree

Hide file tree

Showing 11 changed files with 101 additions and 68 deletions.
diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs
@@ -23,6 +23,7 @@ where
 
 import Cardano.Ledger.Alonzo.Data (AuxiliaryData (..), getPlutusData)
 import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..), PParamsUpdate, updatePParams)
+import Cardano.Ledger.Alonzo.Rules.Ledger (AlonzoLEDGER)
 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.Utxow as Alonzo (AlonzoUTXOW)
@@ -51,6 +52,7 @@ import Data.Typeable (Typeable)
 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.Bbody as STS
 import qualified Shelley.Spec.Ledger.STS.Bbody as Shelley
@@ -69,11 +71,16 @@ import Shelley.Spec.Ledger.TxBody (witKeyHash)
 -- | The Alonzo era
 data AlonzoEra c
 
-instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c)
+{-
+instance
+  ( Show (CompactAddr c),
+    API.PraosCrypto c
+  ) => API.ApplyTx (AlonzoEra c)
+-}
 
-instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c)
+instance (Show (CompactAddr c), 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)
@@ -97,8 +104,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 (Show (CompactAddr c), CC.Crypto c) => UsesTxOut (AlonzoEra c) where
   makeTxOut _proxy addr val = TxOut addr val Shelley.SNothing
 
 instance
@@ -149,8 +155,13 @@ instance CC.Crypto c => EraModule.BlockDecoding (AlonzoEra c) where
   seqIsValidating tx = case isValidating' tx of IsValidating b -> b
   seqHasValidating = True -- Tx in AlonzoEra has an IsValidating field
 
-instance API.PraosCrypto c => API.ShelleyBasedEra (AlonzoEra c)
-
+{-
+instance
+  ( Show (CompactAddr c),
+    API.PraosCrypto c,
+    Core.Witnesses c ~ TxWitness c
+  ) => API.ShelleyBasedEra (AlonzoEra c)
+-}
 -------------------------------------------------------------------------------
 -- Era Mapping
 -------------------------------------------------------------------------------
@@ -163,6 +174,7 @@ type instance Core.EraRule "UTXO" (AlonzoEra c) = Alonzo.AlonzoUTXO (AlonzoEra c
 
 type instance Core.EraRule "UTXOW" (AlonzoEra c) = Alonzo.AlonzoUTXOW (AlonzoEra c)
 
+{-
 type LEDGERSTUB c =
   STUB
     (API.LedgerEnv (AlonzoEra c))
@@ -173,8 +185,9 @@ type LEDGERSTUB c =
 
 instance Typeable c => STS.Embed (LEDGERSTUB c) (API.LEDGERS (AlonzoEra c)) where
   wrapFailed = error "TODO: implement LEDGER rule"
+-}
 
-type instance Core.EraRule "LEDGER" (AlonzoEra c) = LEDGERSTUB c
+type instance Core.EraRule "LEDGER" (AlonzoEra c) = AlonzoLEDGER c
 
 type instance
   Core.EraRule "BBODY" (AlonzoEra c) =

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs
@@ -122,18 +122,11 @@ 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
 

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/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)
 

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs
@@ -81,6 +81,7 @@ import Shelley.Spec.Ledger.BaseTypes
     StrictMaybe (..),
     networkId,
   )
+import Shelley.Spec.Ledger.CompactAddr (CompactAddr)
 import qualified Shelley.Spec.Ledger.LedgerState as Shelley
 import qualified Shelley.Spec.Ledger.STS.Utxo as Shelley
 import Shelley.Spec.Ledger.Tx (TxIn)
@@ -274,6 +275,7 @@ utxoTransition ::
   forall era.
   ( Era era,
     ValidateScript era,
+    Show (CompactAddr (Crypto era)),
     -- instructions for calling UTXOS from AlonzoUTXO
     Embed (Core.EraRule "UTXOS" era) (AlonzoUTXO era),
     Environment (Core.EraRule "UTXOS" era) ~ Shelley.UtxoEnv era,
@@ -392,6 +394,7 @@ utxoTransition = do
 instance
   forall era.
   ( ValidateScript era,
+    Show (CompactAddr (Crypto era)),
     -- Instructions needed to call the UTXOS transition from this one.
     Embed (Core.EraRule "UTXOS" era) (AlonzoUTXO era),
     Environment (Core.EraRule "UTXOS" era) ~ Shelley.UtxoEnv era,

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs
@@ -43,6 +43,7 @@ import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
 import Shelley.Spec.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), strictMaybeToMaybe)
+import Shelley.Spec.Ledger.CompactAddr (CompactAddr)
 import Shelley.Spec.Ledger.LedgerState
 import qualified Shelley.Spec.Ledger.LedgerState as Shelley
 import Shelley.Spec.Ledger.PParams (Update)
@@ -63,6 +64,7 @@ instance
     Eq (Core.PParams era),
     Show (Core.PParams era),
     Show (PParamsDelta era),
+    Show (CompactAddr (Crypto era)),
     Eq (PParamsDelta era),
     Embed (Core.EraRule "PPUP" era) (UTXOS era),
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
@@ -90,6 +92,7 @@ instance
 utxosTransition ::
   forall era.
   ( Era era,
+    Show (CompactAddr (Crypto era)),
     Core.Script era ~ Script era,
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,
@@ -119,7 +122,8 @@ 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.
+    Show (CompactAddr (Crypto era)),
     Era era,
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs
@@ -87,24 +87,28 @@ data AlonzoPredFail era
     WrongNetworkInTxBody
       !Network -- Actual Network ID
       !Network -- Network ID in transaction body
+  | ScriptsDidNotValidate [Core.Script 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,
     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
@@ -114,7 +118,8 @@ encodePredFail ::
   ( Era era,
     ToCBOR (PredicateFailure (Core.EraRule "UTXO" era)),
     Typeable (Core.Script era),
-    Typeable (Core.AuxiliaryData era)
+    Typeable (Core.AuxiliaryData era),
+    ToCBOR (Core.Script era)
   ) =>
   AlonzoPredFail era ->
   Encode 'Open (AlonzoPredFail era)
@@ -126,13 +131,15 @@ encodePredFail (PPViewHashesDontMatch x y) = Sum PPViewHashesDontMatch 4 !> To x
 encodePredFail (MissingRequiredSigners x) = Sum MissingRequiredSigners 5 !> To x
 encodePredFail (Phase1ScriptWitnessNotValidating x) = Sum Phase1ScriptWitnessNotValidating 6 !> To x
 encodePredFail (WrongNetworkInTxBody x y) = Sum WrongNetworkInTxBody 7 !> To x !> To y
+encodePredFail (ScriptsDidNotValidate x) = Sum ScriptsDidNotValidate 8 !> To x
 
 instance
   ( Era era,
     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
@@ -143,7 +150,8 @@ decodePredFail ::
     FromCBOR (PredicateFailure (Core.EraRule "UTXO" era)), -- TODO, we should be able to get rid of this constraint
     FromCBOR (Script era),
     Typeable (Core.Script era),
-    Typeable (Core.AuxiliaryData era)
+    Typeable (Core.AuxiliaryData era),
+    FromCBOR (Core.Script era)
   ) =>
   Word ->
   Decode 'Open (AlonzoPredFail era)
@@ -155,6 +163,7 @@ decodePredFail 4 = SumD PPViewHashesDontMatch <! From <! From
 decodePredFail 5 = SumD MissingRequiredSigners <! From
 decodePredFail 6 = SumD Phase1ScriptWitnessNotValidating <! From
 decodePredFail 7 = SumD WrongNetworkInTxBody <! From <! From
+decodePredFail 8 = SumD ScriptsDidNotValidate <! From
 decodePredFail n = Invalid n
 
 -- =============================================
@@ -222,6 +231,13 @@ alonzoStyleWitness = do
           accum (PlutusScript _) bad = bad
   null failedScripts ?! (Phase1ScriptWitnessNotValidating $ Set.fromList failedScripts)
 
+  -- ONE OF THESE MAY BE REDUNDANT. validateScript NOW WORKS ON PLUTUS SCRIPTS TOO.
+  let failedScripts2 = Map.foldr accum2 [] scriptWitMap
+        where
+          accum2 script bad = if validateScript @era script tx then bad else script : bad
+  null failedScripts2 ?! ScriptsDidNotValidate failedScripts2
+
+
   let utxo = _utxo u'
       sphs :: [(ScriptPurpose (Crypto era), ScriptHash (Crypto era))]
       sphs = scriptsNeeded utxo tx

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs
@@ -475,24 +475,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.
@@ -503,11 +501,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
@@ -523,10 +521,11 @@ indexedRdmrs ::
   Tx 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
 
 -- =======================================================
 

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs
@@ -136,12 +136,12 @@ deriving stock instance
   ) =>
   Eq (TxOut era)
 
-instance
-  ( Show (Core.Value era)
+deriving instance
+  ( Show (CompactAddr (Crypto era)),
+    Show (Core.Value era),
+    Show (CompactForm (Core.Value era))
   ) =>
   Show (TxOut era)
-  where
-  show = error "Not yet implemented"
 
 deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)
 
@@ -205,7 +205,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))
@@ -231,7 +235,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)
 
@@ -475,7 +480,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.