Added to FakePlutus

DCert, Wdrls, and others Worked out how to actually call plutus in eval_scripts.
IntersectMBO · Mar 25, 2021 · 730a9cb · 730a9cb
1 parent ed6f40e
commit 730a9cb
Show file tree

Hide file tree

Showing 4 changed files with 253 additions and 104 deletions.
diff --git a/alonzo/impl/cardano-ledger-alonzo.cabal b/alonzo/impl/cardano-ledger-alonzo.cabal
@@ -41,6 +41,7 @@ library
     Cardano.Ledger.Alonzo
     Cardano.Ledger.Alonzo.Data
     Cardano.Ledger.Alonzo.FakePlutus
+    Cardano.Ledger.Alonzo.RunPlutus
     Cardano.Ledger.Alonzo.Language
     Cardano.Ledger.Alonzo.PParams
     Cardano.Ledger.Alonzo.Rules.Utxo
@@ -66,6 +67,7 @@ library
     nothunks,
     plutus-ledger-api,
     plutus-tx,
+    plutus-core,
     serialise,
     shelley-spec-ledger,
     small-steps,

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/FakePlutus.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/FakePlutus.hs
@@ -5,8 +5,11 @@ module Cardano.Ledger.Alonzo.FakePlutus where
 -- import Plutus.V1.Ledger.Address(Address (..))
 
 import qualified Data.ByteString as BS (ByteString)
+import Data.Map (Map)
+import Data.Word (Word64)
 import Language.PlutusTx (Data (..))
 import Language.PlutusTx.IsData.Class (IsData (..))
+import Numeric.Natural (Natural)
 import Plutus.V1.Ledger.Ada (adaSymbol, adaToken)
 import Plutus.V1.Ledger.Contexts (TxOutInfo)
 import Plutus.V1.Ledger.Crypto (PubKeyHash (..))
@@ -25,22 +28,23 @@ import Plutus.V1.Ledger.Value (CurrencySymbol (..), TokenName (..), Value (..),
 -- ========================================================
 
 -- | Legal addresses may have Staking credential, used to assign rewards
-newtype StakingHash = StakingHash {getStakingHash :: BS.ByteString}
+data StakingCredential
+  = StakingHash BS.ByteString
+  | StakingPtr Word64 Natural Natural
+  deriving (Eq, Ord)
 
 -- | This is isomorphic to the old Plutus stype Address
 data Credential
   = PubKeyCredential !PubKeyHash
   | ScriptCredential !ValidatorHash
 
 -- | The new style Plutus Address has two kinds of credentials, normal and staking
-data Address = Address !Credential !(Maybe StakingHash)
+data Address = Address !Credential !(Maybe StakingCredential)
 
 -- | The TxInIfo 'resolves' the TxIn from the Tx, using the UTxO and the PtrMap
 data TxInInfo = TxInInfo
   { txInInfoOutRef :: !TxOutRef,
-    txInAddr :: !Address,
-    txInValue :: !Value,
-    txInDataHash :: !(Maybe DatumHash)
+    txInInfoResolved :: !TxOut
   }
 
 -- | Newstyle TxOut uses the new style Address
@@ -57,17 +61,104 @@ data TxInfo = TxInfo
     txInfoOutputs :: [TxOut],
     -- | The fee paid by this transaction.
     txInfoFee :: Value,
-    -- | The 'Value' forged by this transaction.
+    -- | The 'Value' forged by this transaction
     txInfoForge :: Value,
+    -- | Digests of Certificates included in this transaction
+    txInfoDCert :: [DCert],
+    -- | Withdrawals
+    txInfoWdrl :: (Map StakingCredential Integer),
     -- | The valid range for the transaction.
     txInfoValidRange :: SlotRange,
-    -- | Signatures provided with the transaction
+    -- | Signatures provided with the transaction, attested that they all signed the Tx
     txInfoSignatories :: [PubKeyHash],
     txInfoData :: [(DatumHash, Datum)],
     -- | Hash of the pending transaction (excluding witnesses)
     txInfoId :: TxId
   }
 
+-- | A representation of the Ledger DCert, Some information is digested, and not included
+data DCert
+  = DCertDelegRegKey StakingCredential
+  | DCertDelegDeRegKey StakingCredential
+  | DCertDelegDelegate
+      StakingCredential
+      -- ^ delegator
+      PubKeyHash
+      -- ^ delegatee
+  | -- | A digest of the PoolParams
+    DCertPoolRegister
+      PubKeyHash
+      -- ^ poolId
+      PubKeyHash
+      -- ^ pool VFR
+  | -- | The retiremant certificate and the Epoch N
+    DCertPoolRetire PubKeyHash Word64
+  | -- | A really terse Digest
+    DCertGenesis
+  | -- | Another really terse Digest
+    DCertMir
+
+{-
+transDCert (DCertDeleg (RegKey stkcred)) = P.DCertDelegRegKey  undefined
+transDCert (DCertDeleg (DeRegKey stkcred)) = P.DCertDelegRegDeKey  undefined
+transDCert (DCertDeleg (Delegate stkcred keyhash)) =  P.DCertDelegDelegate undefined undefined
+transDCert (DCertPool (RegPool pp)) = P.DCertPoolRegister undefined undefined
+transDCert (DCertPool (RetirePool keyhash epochni)) = P.DCertPoolRetire undefined undefined
+transDCert (DCertGenesis _) = P.DCertGenesis
+transDCert (DCertMir _) = P.DCertMir
+
+ Missing
+_certs :: !(StrictSeq (DCert (Crypto era))),
+    _wdrls :: !(Wdrl (Crypto era)),
+
+data DCert crypto
+  = DCertDeleg !(DelegCert crypto)
+  | DCertPool !(PoolCert crypto)
+  | DCertGenesis !(GenesisDelegCert crypto)
+  | DCertMir !(MIRCert crypto)
+
+data DelegCert crypto
+  = -- | A stake key registration certificate.
+    RegKey !(StakeCredential crypto)
+  | -- | A stake key deregistration certificate.
+    DeRegKey !(StakeCredential crypto)
+  | -- | A stake delegation certificate.
+    Delegate !(Delegation crypto)
+
+data PoolCert crypto
+  = -- | A stake pool registration certificate.
+    RegPool !(PoolParams crypto)
+  | -- | A stake pool retirement certificate.
+    RetirePool !(KeyHash 'StakePool crypto) !EpochNo
+  deriving (Show, Generic, Eq, NFData)
+
+data PoolParams crypto = PoolParams
+  { _poolId :: !(KeyHash 'StakePool crypto),
+    _poolVrf :: !(Hash crypto (VerKeyVRF crypto)),
+
+data MIRCert crypto = MIRCert
+  { mirPot :: MIRPot,
+    mirRewards :: MIRTarget crypto
+
+data MIRCert crypto = MIRCert
+  { mirPot :: MIRPot,
+    mirRewards :: MIRTarget crypto
+
+data MIRPot = ReservesMIR | TreasuryMIR
+  deriving (Show, Generic, Eq, NFData)
+
+-- | The delegation of one stake key to another.
+data Delegation crypto = Delegation
+  { _delegator :: !(StakeCredential crypto),
+    _delegatee :: !(KeyHash 'StakePool crypto)
+  }
+
+data RewardAcnt crypto = RewardAcnt
+  { getRwdNetwork :: !Network,
+    getRwdCred :: !(Credential 'Staking crypto)
+  }
+-}
+
 instance IsData TxInfo where
   toData _txinfo = undefined
   fromData _dat = Nothing
diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/RunPlutus.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/RunPlutus.hs
@@ -5,43 +5,38 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module RunPlutus where
+module Cardano.Ledger.Alonzo.RunPlutus where
 
-import Cardano.Ledger.Alonzo.Language (Language (..), nonNativeLanguages)
-import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), Prices, scriptfee)
-import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..), Tag (..))
+import Cardano.Ledger.Alonzo.Data (getPlutusData)
+import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..))
+import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..))
 import Cardano.Ledger.Alonzo.Tx
-  ( CostModel (..),
-    Data (..),
-    DataHash (..),
+  ( Data,
+    DataHash,
     IsValidating (..),
     ScriptPurpose (..),
     Tx (..),
     indexedRdmrs,
     scriptsNeeded,
     txdats',
-    txscripts',
   )
-import Cardano.Ledger.Alonzo.TxBody (TxBody (..))
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..))
-import Cardano.Ledger.Alonzo.TxInfo (valContext)
+import Cardano.Ledger.Alonzo.TxInfo (evalPlutusScript, valContext)
 import Cardano.Ledger.Core as Core hiding (Tx)
-import qualified Cardano.Ledger.Crypto as CC (Crypto)
-import Cardano.Ledger.Era (Crypto, Era)
+import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..))
 import qualified Cardano.Ledger.Mary.Value as Mary (Value (..))
-import Data.ByteString as BS (ByteString)
-import Data.ByteString.Short as SBS (fromShort)
-import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe (isJust, maybeToList)
+import Data.Maybe (maybeToList)
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
-import qualified Data.Set as Set
 import Data.Typeable (Typeable)
 import GHC.Records (HasField (..))
-import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..), maybeToStrictMaybe, strictMaybeToMaybe)
+import qualified Plutus.V1.Ledger.Scripts as Plutus (Script)
+import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..))
 import Shelley.Spec.Ledger.Delegation.Certificates (DCert (..))
-import Shelley.Spec.Ledger.TxBody (TxId (..), TxIn (..), Wdrl (..))
+import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
+import Shelley.Spec.Ledger.TxBody (TxIn (..), Wdrl (..))
 import Shelley.Spec.Ledger.UTxO (UTxO (..))
 
 -- ===============================================================
@@ -100,29 +95,35 @@ collectNNScriptInputs ::
   Core.PParams era ->
   Tx era ->
   UTxO era ->
-  [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)]
+  [(Plutus.Script, [Data era], ExUnits, CostModel)]
 collectNNScriptInputs pp tx utxo =
   [ (script, d : (valContext utxo tx 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 <- case language script of
-        Nothing -> []
-        Just lang -> maybeToList (Map.lookup lang (getField @"_costmdls" pp))
+      script <- onlytwoPhaseScripts tx scripthash, -- maybeToList (Map.lookup scripthash (txscripts' (getField @"wits" tx))),
+      cost <- maybeToList (Map.lookup PlutusV1 (getField @"_costmdls" pp))
   ]
 
-language :: Typeable (Crypto era) => AlonzoScript.Script era -> Maybe Language
-language (AlonzoScript.NativeScript _) = Nothing
-language (AlonzoScript.PlutusScript _) = Just PlutusV1
+-- | return only the scripts that use two-phase validation (Here that means Plutus scripts)
+onlytwoPhaseScripts ::
+  ( Era era,
+    Script era ~ AlonzoScript.Script era
+  ) =>
+  Tx era ->
+  ScriptHash (Crypto era) ->
+  [Plutus.Script]
+onlytwoPhaseScripts tx scripthash =
+  case Map.lookup scripthash (getField @"scriptWits" tx) of
+    Just (AlonzoScript.PlutusScript pscript) -> [pscript]
+    Just (AlonzoScript.NativeScript _) -> []
+    Nothing -> []
 
 evalScripts ::
   Typeable (Crypto era) =>
   [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] ->
   Bool
 evalScripts [] = True
-evalScripts ((AlonzoScript.NativeScript _timelock, _, _, _) : rest) =
-  evalScripts rest
-evalScripts ((AlonzoScript.PlutusScript s, ds, units, cost) : rest) =
-  b && evalScripts rest
-  where
-    (IsValidating b, _exunits) = runPLCScript cost (AlonzoScript.PlutusScript s) ds units
+-- We may safely skip over the Timelock scripts
+evalScripts ((AlonzoScript.NativeScript _, _, _, _) : rest) = evalScripts rest
+evalScripts ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) =
+  evalPlutusScript cost units pscript (map getPlutusData ds) && evalScripts rest