Skip to content

Commit

Permalink
SCP-1514 Extract scripts (IntersectMBO#2499)
Browse files Browse the repository at this point in the history 
* SCP-1514: Extract applied scripts
* plutus-use-cases: Write out all scripts from plutus-use-cases
  • Loading branch information
@j-mueller
j-mueller authored Jan 12, 2021
1 parent 0809f57 commit 333f5b9
Show file tree
Hide file tree
Showing 27 changed files with 649 additions and 264 deletions.
55 changes: 55 additions & 0 deletions nix/stack.materialized/plutus-use-cases.nix
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

6 changes: 4 additions & 2 deletions playground-common/src/PSGenerator/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ import Ledger (Address, Datum, Datu
TxOut, TxOutRef, TxOutTx, TxOutType, UtxoIndex, Validator)
import Ledger.Ada (Ada)
import Ledger.Constraints.OffChain (MkTxError)
import Ledger.Index (ValidationError)
import Ledger.Index (ScriptType, ScriptValidationEvent, ValidationError)
import Ledger.Interval (Extended, Interval, LowerBound, UpperBound)
import Ledger.Scripts (ScriptError)
import Ledger.Slot (Slot)
Expand Down Expand Up @@ -250,7 +250,7 @@ ledgerTypes =
, (genericShow <*> (order <*> mkSumType)) (Proxy @TokenName)
, (genericShow <*> (order <*> mkSumType)) (Proxy @TxInType)
, (genericShow <*> (order <*> mkSumType)) (Proxy @Validator)
, (genericShow <*> mkSumType) (Proxy @ScriptError)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @ScriptError)
, (genericShow <*> mkSumType) (Proxy @ValidationError)
, (order <*> (genericShow <*> mkSumType)) (Proxy @Address)
, (order <*> (genericShow <*> mkSumType)) (Proxy @Datum)
Expand Down Expand Up @@ -282,6 +282,8 @@ ledgerTypes =
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Priority)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @StopReason)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @IterationID)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @ScriptValidationEvent)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @ScriptType)
]

walletTypes :: [SumType 'Haskell]
Expand Down
9 changes: 5 additions & 4 deletions plutus-contract/src/Language/Plutus/Contract/Test.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -101,7 +101,7 @@ import Ledger.Tx (Tx)
import Ledger.Address (Address)
import Ledger.Generators (GeneratorModel, Mockchain (..))
import qualified Ledger.Generators as Gen
import Ledger.Index (ValidationError)
import Ledger.Index (ScriptValidationEvent, ValidationError)
import Ledger.Slot (Slot)
import Ledger.Value (Value)
import Wallet.Emulator (EmulatorEvent, EmulatorTimeEvent)
Expand Down Expand Up @@ -509,21 +509,22 @@ assertChainEvents predicate =

-- | Assert that at least one transaction failed to validate, and that all
-- transactions that failed meet the predicate.
assertFailedTransaction :: (Tx -> ValidationError -> Bool) -> TracePredicate
assertFailedTransaction :: (Tx -> ValidationError -> [ScriptValidationEvent] -> Bool) -> TracePredicate
assertFailedTransaction predicate =
flip postMapM (L.generalize Folds.failedTransactions) $ \case
[] -> do
tell @(Doc Void) $ "No transactions failed to validate."
pure False
xs -> pure (all (\(_, t, e) -> predicate t e) xs)
xs -> pure (all (\(_, t, e, evts) -> predicate t e evts) xs)

-- | Assert that no transaction failed to validate.
assertNoFailedTransactions :: TracePredicate
assertNoFailedTransactions =
flip postMapM (L.generalize Folds.failedTransactions) $ \case
[] -> pure True
xs -> do
tell @(Doc Void) $ vsep ("Transactions failed to validate:" : fmap pretty xs)
let prettyTxFail (i, _, err, _) = pretty i <> colon <+> pretty err
tell @(Doc Void) $ vsep ("Transactions failed to validate:" : fmap prettyTxFail xs)
pure False

assertInstanceLog ::
Expand Down
3 changes: 3 additions & 0 deletions plutus-contract/src/Language/Plutus/Contract/Util.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -28,3 +28,6 @@ finally a b = do
a' <- a
_ <- b
return a'

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
67 changes: 35 additions & 32 deletions plutus-contract/src/Wallet/Emulator/Chain.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,39 +15,41 @@

module Wallet.Emulator.Chain where

import Codec.Serialise (Serialise)
import Control.DeepSeq (NFData)
import Control.Lens hiding (index)
import Codec.Serialise (Serialise)
import Control.DeepSeq (NFData)
import Control.Lens hiding (index)
import Control.Monad.Freer
import Control.Monad.Freer.Log (LogMsg, logDebug, logInfo)
import Control.Monad.Freer.Log (LogMsg, logDebug, logInfo)
import Control.Monad.Freer.State
import qualified Control.Monad.State as S
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (traverse_)
import Data.List (partition, (\\))
import Data.Maybe (isNothing)
import qualified Control.Monad.State as S
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (traverse_)
import Data.List (partition, (\\))
import Data.Maybe (isNothing)
import Data.Text.Prettyprint.Doc
import Data.Traversable (for)
import GHC.Generics (Generic)
import Ledger (Block, Blockchain, Slot (..), Tx (..), TxId, txId)
import qualified Ledger.Index as Index
import qualified Ledger.Interval as Interval
import Data.Traversable (for)
import GHC.Generics (Generic)
import Language.Plutus.Contract.Util (uncurry3)
import Ledger (Block, Blockchain, ScriptValidationEvent, Slot (..), Tx (..), TxId,
txId)
import qualified Ledger.Index as Index
import qualified Ledger.Interval as Interval

-- | Events produced by the blockchain emulator.
data ChainEvent =
TxnValidate TxId Tx
TxnValidate TxId Tx [ScriptValidationEvent]
-- ^ A transaction has been validated and added to the blockchain.
| TxnValidationFail TxId Tx Index.ValidationError
| TxnValidationFail TxId Tx Index.ValidationError [ScriptValidationEvent]
-- ^ A transaction failed to validate.
| SlotAdd Slot
deriving stock (Eq, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty ChainEvent where
pretty = \case
TxnValidate i _ -> "TxnValidate" <+> pretty i
TxnValidationFail i _ e -> "TxnValidationFail" <+> pretty i <> colon <+> pretty e
SlotAdd sl -> "SlotAdd" <+> pretty sl
TxnValidate i _ _ -> "TxnValidate" <+> pretty i
TxnValidationFail i _ e _ -> "TxnValidationFail" <+> pretty i <> colon <+> pretty e
SlotAdd sl -> "SlotAdd" <+> pretty sl

-- | A pool of transactions which have yet to be validated.
type TxPool = [Tx]
Expand Down Expand Up @@ -133,41 +135,41 @@ validateBlock slot@(Slot s) idx txns =

-- Validate eligible transactions, updating the UTXO index each time
processed =
flip S.evalState idx $ for eligibleTxns $ \t -> do
r <- validateEm slot t
pure (t, r)
flip S.evalState idx $ for eligibleTxns $ \tx -> do
(err, events_) <- validateEm slot tx
pure (tx, err, events_)

-- The new block contains all transaction that were validated
-- successfully
block = fst <$> filter (isNothing . snd) processed
block = view _1 <$> filter (isNothing . view _2) processed

-- Also return an `EmulatorEvent` for each transaction that was
-- processed
nextSlot = Slot (s + 1)
events = (uncurry mkValidationEvent <$> processed) ++ [SlotAdd nextSlot]
events = (uncurry3 mkValidationEvent <$> processed) ++ [SlotAdd nextSlot]

in ValidatedBlock block events rest

-- | Check whether the given transaction can be validated in the given slot.
canValidateNow :: Slot -> Tx -> Bool
canValidateNow slot tx = Interval.member slot (txValidRange tx)

mkValidationEvent :: Tx -> Maybe Index.ValidationError -> ChainEvent
mkValidationEvent t result =
mkValidationEvent :: Tx -> Maybe Index.ValidationError -> [ScriptValidationEvent] -> ChainEvent
mkValidationEvent t result events =
case result of
Nothing -> TxnValidate (txId t) t
Just err -> TxnValidationFail (txId t) t err
Nothing -> TxnValidate (txId t) t events
Just err -> TxnValidationFail (txId t) t err events

-- | Validate a transaction in the current emulator state.
validateEm :: S.MonadState Index.UtxoIndex m => Slot -> Tx -> m (Maybe Index.ValidationError)
validateEm :: S.MonadState Index.UtxoIndex m => Slot -> Tx -> m (Maybe Index.ValidationError, [ScriptValidationEvent])
validateEm h txn = do
idx <- S.get
let result = Index.runValidation (Index.validateTransaction h txn) idx
let (result, events) = Index.runValidation (Index.validateTransaction h txn) idx
case result of
Left e -> pure (Just e)
Left e -> pure (Just e, events)
Right idx' -> do
_ <- S.put idx'
pure Nothing
pure (Nothing, events)

-- | Adds a block to ChainState, without validation.
addBlock :: Block -> ChainState -> ChainState
Expand All @@ -183,3 +185,4 @@ addTxToPool :: Tx -> TxPool -> TxPool
addTxToPool = (:)

makePrisms ''ChainEvent

22 changes: 16 additions & 6 deletions plutus-contract/src/Wallet/Emulator/Folds.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,7 @@ module Wallet.Emulator.Folds (
, chainEvents
, failedTransactions
, validatedTransactions
, scriptEvents
, utxoAtAddress
, valueAtAddress
-- * Folds for individual wallets (emulated agents)
Expand Down Expand Up @@ -66,7 +67,7 @@ import Ledger (TxId)
import Ledger.AddressMap (UtxoMap)
import qualified Ledger.AddressMap as AM
import Ledger.Constraints.OffChain (UnbalancedTx)
import Ledger.Index (ValidationError)
import Ledger.Index (ScriptValidationEvent, ValidationError)
import Ledger.Tx (Address, Tx, TxOut (..), TxOutTx (..))
import Ledger.Value (Value)
import Plutus.Trace.Emulator.ContractInstance (ContractInstanceState, addEventInstanceState,
Expand All @@ -89,13 +90,22 @@ type EmulatorEventFold a = Fold EmulatorEvent a
type EmulatorEventFoldM effs a = FoldM (Eff effs) EmulatorEvent a

-- | Transactions that failed to validate
failedTransactions :: EmulatorEventFold [(TxId, Tx, ValidationError)]
failedTransactions :: EmulatorEventFold [(TxId, Tx, ValidationError, [ScriptValidationEvent])]
failedTransactions = preMapMaybe (preview (eteEvent . chainEvent . _TxnValidationFail)) L.list

-- | Transactions that were validated
validatedTransactions :: EmulatorEventFold [(TxId, Tx)]
validatedTransactions :: EmulatorEventFold [(TxId, Tx, [ScriptValidationEvent])]
validatedTransactions = preMapMaybe (preview (eteEvent . chainEvent . _TxnValidate)) L.list

-- | All scripts that are run during transaction validation
scriptEvents :: EmulatorEventFold [ScriptValidationEvent]
scriptEvents = preMapMaybe (preview (eteEvent . chainEvent) >=> getEvent) (concat <$> L.list) where
getEvent :: ChainEvent -> Maybe [ScriptValidationEvent]
getEvent = \case
TxnValidate _ _ es -> Just es
TxnValidationFail _ _ _ es -> Just es
SlotAdd _ -> Nothing

-- | The state of a contract instance, recovered from the emulator log.
instanceState ::
forall s e a effs.
Expand Down Expand Up @@ -226,9 +236,9 @@ chainEvents = preMapMaybe (preview (eteEvent . chainEvent)) L.list
blockchain :: EmulatorEventFold [[Tx]]
blockchain =
let step (currentBlock, otherBlocks) = \case
SlotAdd _ -> ([], currentBlock : otherBlocks)
TxnValidate _ txn -> (txn : currentBlock, otherBlocks)
TxnValidationFail _ _ _ -> (currentBlock, otherBlocks)
SlotAdd _ -> ([], currentBlock : otherBlocks)
TxnValidate _ txn _ -> (txn : currentBlock, otherBlocks)
TxnValidationFail{} -> (currentBlock, otherBlocks)
initial = ([], [])
extract (currentBlock, otherBlocks) =
reverse (currentBlock : otherBlocks)
Expand Down
2 changes: 1 addition & 1 deletion plutus-contract/src/Wallet/Rollup.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -105,7 +105,7 @@ getAnnotatedTransactions = groupBy (equating (slotIndex . sequenceId)) . reverse
handleChainEvent :: RollupState -> ChainEvent -> RollupState
handleChainEvent s = \case
SlotAdd _ -> s & over currentSequenceId (set txIndexL 0 . over slotIndexL succ)
TxnValidate _ tx ->
TxnValidate _ tx _ ->
let (tx', newState) = runState (annotateTransaction (s ^. currentSequenceId) tx) (s ^. rollup)
in s & over currentSequenceId (over txIndexL succ)
& over annotatedTransactions ((:) tx')
Expand Down
8 changes: 4 additions & 4 deletions plutus-contract/test/Spec/Emulator.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -145,8 +145,8 @@ txnUpdateUtxo = property $ do
pred = \case
[ Chain.TxnValidate{}
, Chain.SlotAdd _
, Chain.TxnValidate _ i1
, Chain.TxnValidationFail _ txi (Index.TxOutRefNotFound _)
, Chain.TxnValidate _ i1 _
, Chain.TxnValidationFail _ txi (Index.TxOutRefNotFound _) _
, Chain.SlotAdd _
] -> i1 == txn && txi == txn
_ -> False
Expand All @@ -168,7 +168,7 @@ invalidTrace = property $ do
pred = \case
[ Chain.TxnValidate{}
, Chain.SlotAdd _
, Chain.TxnValidationFail _ txn (Index.ValueNotPreserved _ _)
, Chain.TxnValidationFail _ txn (Index.ValueNotPreserved _ _) _
, Chain.SlotAdd _
] -> txn == invalidTxn
_ -> False
Expand Down Expand Up @@ -205,7 +205,7 @@ invalidScript = property $ do
, Chain.SlotAdd _
, Chain.TxnValidate{}
, Chain.SlotAdd _
, Chain.TxnValidationFail _ txn (ScriptFailure (EvaluationError ["I always fail everything"]))
, Chain.TxnValidationFail _ txn (ScriptFailure (EvaluationError ["I always fail everything"])) _
, Chain.SlotAdd _
] -> txn == invalidTxn
_ -> False
Expand Down
2 changes: 1 addition & 1 deletion plutus-ledger/src/Ledger/Generators.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -248,7 +248,7 @@ validateMockchain :: Mockchain -> Tx -> Maybe Index.ValidationError
validateMockchain (Mockchain blck _) tx = either Just (const Nothing) result where
h = 1
idx = Index.initialise [blck]
result = Index.runValidation (Index.validateTransaction h tx) idx
result = fst $ Index.runValidation (Index.validateTransaction h tx) idx

{- | Split a value into max. n positive-valued parts such that the sum of the
parts equals the original value.
Expand Down
Loading

0 comments on commit 333f5b9

Please sign in to comment.