{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- Embed instances for (AlonzoEra TestCrypto)
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Test.Cardano.Ledger.Alonzo.ChainTrace (
  tests,
) where

import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  collectPlutusScriptsWithContext,
  evalPlutusScripts,
 )
import Cardano.Ledger.Alonzo.Rules (AlonzoBBODY, AlonzoLEDGER)
import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..), ExUnits (..), mkPlutusScript)
import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), totExUnits)
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus.Evaluate (PlutusWithContext (..), ScriptResult (..))
import Cardano.Ledger.Plutus.Language (plutusFromRunnable)
import Cardano.Ledger.Shelley.LedgerState hiding (circulation)
import Cardano.Ledger.Slot (EpochSize (..))
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import Control.State.Transition
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word64)
import Lens.Micro
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Alonzo.AlonzoEraGen (sumCollateral)
import Test.Cardano.Ledger.Alonzo.EraMapping ()
import Test.Cardano.Ledger.Alonzo.Trace ()
import Test.Cardano.Ledger.EraBuffet (TestCrypto)
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
import Test.Cardano.Ledger.Shelley.Rules.Chain (
  CHAIN,
  ChainEvent (..),
  ChainState (..),
  TestChainPredicateFailure (..),
 )
import Test.Cardano.Ledger.Shelley.Rules.TestChain (
  forAllChainTrace,
  ledgerTraceFromBlock,
 )
import Test.Control.State.Transition.Trace (SourceSignalTarget (..), sourceSignalTargets)
import Test.QuickCheck (
  Property,
  conjoin,
  counterexample,
  (.&&.),
  (===),
 )
import Test.Tasty
import qualified Test.Tasty.QuickCheck as TQC

type A = AlonzoEra TestCrypto

instance Embed (AlonzoBBODY A) (CHAIN A) where
  wrapFailed :: PredicateFailure (AlonzoBBODY (AlonzoEra TestCrypto))
-> PredicateFailure (CHAIN (AlonzoEra TestCrypto))
wrapFailed = forall era.
PredicateFailure (EraRule "BBODY" era)
-> TestChainPredicateFailure era
BbodyFailure
  wrapEvent :: Event (AlonzoBBODY (AlonzoEra TestCrypto))
-> Event (CHAIN (AlonzoEra TestCrypto))
wrapEvent = forall era. Event (EraRule "BBODY" era) -> ChainEvent era
BbodyEvent

traceLen :: Word64
traceLen :: Word64
traceLen = Word64
100

data HasPlutus = HasPlutus | NoPlutus
  deriving (Int -> HasPlutus -> ShowS
[HasPlutus] -> ShowS
HasPlutus -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HasPlutus] -> ShowS
$cshowList :: [HasPlutus] -> ShowS
show :: HasPlutus -> [Char]
$cshow :: HasPlutus -> [Char]
showsPrec :: Int -> HasPlutus -> ShowS
$cshowsPrec :: Int -> HasPlutus -> ShowS
Show)

tests :: TestTree
tests :: TestTree
tests =
  forall a. Testable a => [Char] -> a -> TestTree
TQC.testProperty [Char]
"alonzo specific" forall a b. (a -> b) -> a -> b
$
    forall era prop.
(Testable prop, EraGen era, HasTrace (CHAIN era) (GenEnv era),
 EraGov era) =>
Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forAllChainTrace @A Word64
traceLen Constants
defaultConstants forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN (AlonzoEra TestCrypto))
tr ->
      forall prop. Testable prop => [prop] -> Property
conjoin forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SourceSignalTarget (CHAIN (AlonzoEra TestCrypto)) -> Property
alonzoSpecificProps (forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN (AlonzoEra TestCrypto))
tr)

alonzoSpecificProps ::
  SourceSignalTarget (CHAIN A) ->
  Property
alonzoSpecificProps :: SourceSignalTarget (CHAIN (AlonzoEra TestCrypto)) -> Property
alonzoSpecificProps SourceSignalTarget {source :: forall a. SourceSignalTarget a -> State a
source = State (CHAIN (AlonzoEra TestCrypto))
chainSt, signal :: forall a. SourceSignalTarget a -> Signal a
signal = Signal (CHAIN (AlonzoEra TestCrypto))
block} =
  forall prop. Testable prop => [prop] -> Property
conjoin forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map SourceSignalTarget (AlonzoLEDGER (AlonzoEra TestCrypto))
-> Property
alonzoSpecificPropsLEDGER forall a b. (a -> b) -> a -> b
$
      forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (AlonzoLEDGER (AlonzoEra TestCrypto))
ledgerTr
  where
    (ChainState (AlonzoEra TestCrypto)
tickedChainSt, Trace (AlonzoLEDGER (AlonzoEra TestCrypto))
ledgerTr) = forall era ledger.
(ChainProperty era, EraSegWits era, TestingLedger era ledger) =>
ChainState era
-> Block (BHeader (EraCrypto era)) era
-> (ChainState era, Trace ledger)
ledgerTraceFromBlock State (CHAIN (AlonzoEra TestCrypto))
chainSt Signal (CHAIN (AlonzoEra TestCrypto))
block
    pp :: PParams (AlonzoEra TestCrypto)
pp = (forall a s. Getting a s a -> s -> a
view forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes) ChainState (AlonzoEra TestCrypto)
tickedChainSt
    alonzoSpecificPropsLEDGER :: SourceSignalTarget (AlonzoLEDGER A) -> Property
    alonzoSpecificPropsLEDGER :: SourceSignalTarget (AlonzoLEDGER (AlonzoEra TestCrypto))
-> Property
alonzoSpecificPropsLEDGER
      SourceSignalTarget
        { source :: forall a. SourceSignalTarget a -> State a
source = LedgerState UTxOState {utxosUtxo :: forall era. UTxOState era -> UTxO era
utxosUtxo = UTxO Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u, utxosDeposited :: forall era. UTxOState era -> Coin
utxosDeposited = Coin
dp, utxosFees :: forall era. UTxOState era -> Coin
utxosFees = Coin
f} CertState (AlonzoEra TestCrypto)
ds
        , signal :: forall a. SourceSignalTarget a -> Signal a
signal = Signal (AlonzoLEDGER (AlonzoEra TestCrypto))
tx
        , target :: forall a. SourceSignalTarget a -> State a
target = LedgerState UTxOState {utxosUtxo :: forall era. UTxOState era -> UTxO era
utxosUtxo = UTxO Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u', utxosDeposited :: forall era. UTxOState era -> Coin
utxosDeposited = Coin
dp', utxosFees :: forall era. UTxOState era -> Coin
utxosFees = Coin
f'} CertState (AlonzoEra TestCrypto)
ds'
        } =
        let isValid' :: IsValid
isValid' = Signal (AlonzoLEDGER (AlonzoEra TestCrypto))
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL
            noNewUTxO :: Bool
noNewUTxO = Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u' forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
`Map.isSubmapOf` Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u
            collateralInFees :: Bool
collateralInFees = Coin
f forall a. Semigroup a => a -> a -> a
<> forall era.
(EraTx era, AlonzoEraTxBody era) =>
Tx era -> UTxO era -> Coin
sumCollateral Signal (AlonzoLEDGER (AlonzoEra TestCrypto))
tx (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u) forall a. Eq a => a -> a -> Bool
== Coin
f'
            utxoConsumed :: Bool
utxoConsumed = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
`Map.isSubmapOf` Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u'
            allScripts :: Map
  (ScriptHash (EraCrypto (AlonzoEra TestCrypto)))
  (AlonzoScript (AlonzoEra TestCrypto))
allScripts = Signal (AlonzoLEDGER (AlonzoEra TestCrypto))
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map (ScriptHash (EraCrypto era)) (Script era))
scriptTxWitsL
            hasPlutus :: HasPlutus
hasPlutus = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall era. EraScript era => Script era -> Bool
isNativeScript @A) Map
  (ScriptHash (EraCrypto (AlonzoEra TestCrypto)))
  (AlonzoScript (AlonzoEra TestCrypto))
allScripts then HasPlutus
NoPlutus else HasPlutus
HasPlutus
            totEU :: ExUnits
totEU = forall era. (EraTx era, AlonzoEraTxWits era) => Tx era -> ExUnits
totExUnits Signal (AlonzoLEDGER (AlonzoEra TestCrypto))
tx
            nonTrivialExU :: Bool
nonTrivialExU = ExUnits -> Natural
exUnitsMem ExUnits
totEU forall a. Ord a => a -> a -> Bool
> Natural
0 Bool -> Bool -> Bool
&& ExUnits -> Natural
exUnitsSteps ExUnits
totEU forall a. Ord a => a -> a -> Bool
> Natural
0
            collected :: [PlutusWithContext TestCrypto]
collected =
              -- Note that none of our plutus scripts use validity intervals,
              -- so it is safe to use anything for the epech info and the system start.
              case forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectPlutusScriptsWithContext
                (forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo (Word64 -> EpochSize
EpochSize Word64
100) (NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
1)) -- arbitrary
                (UTCTime -> SystemStart
SystemStart forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
0) -- arbitrary
                PParams (AlonzoEra TestCrypto)
pp
                Signal (AlonzoLEDGER (AlonzoEra TestCrypto))
tx
                (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map
  (TxIn (EraCrypto (AlonzoEra TestCrypto)))
  (TxOut (AlonzoEra TestCrypto))
u) of
                Left [CollectError (AlonzoEra TestCrypto)]
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Plutus script collection error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [CollectError (AlonzoEra TestCrypto)]
e
                Right [PlutusWithContext (EraCrypto (AlonzoEra TestCrypto))]
c -> [PlutusWithContext (EraCrypto (AlonzoEra TestCrypto))]
c
            collectedScripts :: Set (PlutusScript (AlonzoEra TestCrypto))
collectedScripts =
              forall a. Ord a => [a] -> Set a
Set.fromList
                [ PlutusScript (AlonzoEra TestCrypto)
plutus
                | PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
pwcScript :: ()
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript} <- [PlutusWithContext TestCrypto]
collected
                , Just PlutusScript (AlonzoEra TestCrypto)
plutus <- [forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall (l :: Language). PlutusRunnable l -> Plutus l
plutusFromRunnable Either (Plutus l) (PlutusRunnable l)
pwcScript]
                ]
            suppliedPScrpts :: Set (PlutusScript (AlonzoEra TestCrypto))
suppliedPScrpts = forall a. Ord a => [a] -> Set a
Set.fromList [PlutusScript (AlonzoEra TestCrypto)
plutus | PlutusScript PlutusScript (AlonzoEra TestCrypto)
plutus <- forall k a. Map k a -> [a]
Map.elems Map
  (ScriptHash (EraCrypto (AlonzoEra TestCrypto)))
  (AlonzoScript (AlonzoEra TestCrypto))
allScripts]
            expectedPScripts :: Bool
expectedPScripts = Set (PlutusScript (AlonzoEra TestCrypto))
collectedScripts forall a. Eq a => a -> a -> Bool
== Set (PlutusScript (AlonzoEra TestCrypto))
suppliedPScrpts
            allPlutusTrue :: Bool
allPlutusTrue = case forall c. [PlutusWithContext c] -> ScriptResult c
evalPlutusScripts [PlutusWithContext TestCrypto]
collected of
              Fails [PlutusWithContext TestCrypto]
_ NonEmpty (ScriptFailure TestCrypto)
_ -> Bool
False
              Passes [PlutusWithContext TestCrypto]
_ -> Bool
True
         in forall prop. Testable prop => [Char] -> prop -> Property
counterexample
              ( forall a. Monoid a => [a] -> a
mconcat
                  [ [Char]
"\nHas plutus scripts: "
                  , forall a. Show a => a -> [Char]
show HasPlutus
hasPlutus
                  , [Char]
"\nIs valid: "
                  , forall a. Show a => a -> [Char]
show IsValid
isValid'
                  , [Char]
"\nAt least one UTxO is consumed: "
                  , forall a. Show a => a -> [Char]
show Bool
utxoConsumed
                  , [Char]
"\nNon trivial execution units: "
                  , forall a. Show a => a -> [Char]
show Bool
nonTrivialExU
                  , [Char]
"\nReceived the expected plutus scripts: "
                  , forall a. Show a => a -> [Char]
show Bool
expectedPScripts
                  , [Char]
"\nPlutus scripts all evaluate to true: "
                  , forall a. Show a => a -> [Char]
show Bool
allPlutusTrue
                  , [Char]
"\nNo new UTxO: "
                  , forall a. Show a => a -> [Char]
show Bool
noNewUTxO
                  , [Char]
"\nThe collateral amount was added to the fees: "
                  , forall a. Show a => a -> [Char]
show Bool
collateralInFees
                  , [Char]
"\nThe deposit pot is unchanged: "
                  , forall a. Show a => a -> [Char]
show (Coin
dp forall a. Eq a => a -> a -> Bool
== Coin
dp')
                  , [Char]
"\nThe delegation state is unchanged: "
                  , forall a. Show a => a -> [Char]
show (CertState (AlonzoEra TestCrypto)
ds forall a. Eq a => a -> a -> Bool
== CertState (AlonzoEra TestCrypto)
ds')
                  ]
              )
              ( forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"At least one UTxO is consumed" Bool
utxoConsumed
                  forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. ( case (HasPlutus
hasPlutus, IsValid
isValid') of
                          (HasPlutus
NoPlutus, IsValid Bool
True) -> ExUnits
totEU forall a. (Eq a, Show a) => a -> a -> Property
=== Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0
                          (HasPlutus
NoPlutus, IsValid Bool
False) -> forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"No Plutus scripts, but isValid == False" Bool
False
                          (HasPlutus
HasPlutus, IsValid Bool
True) ->
                            forall prop. Testable prop => [prop] -> Property
conjoin
                              [ forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Non trivial execution units" Bool
nonTrivialExU
                              , forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Received the expected plutus scripts" Bool
expectedPScripts
                              , forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Plutus scripts all evaluate to true" Bool
allPlutusTrue
                              ]
                          (HasPlutus
HasPlutus, IsValid Bool
False) ->
                            forall prop. Testable prop => [prop] -> Property
conjoin
                              [ forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"No new UTxO" Bool
noNewUTxO
                              , forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"The collateral amount was added to the fees" Bool
collateralInFees
                              , Coin
dp forall a. (Eq a, Show a) => a -> a -> Property
=== Coin
dp'
                              , CertState (AlonzoEra TestCrypto)
ds forall a. (Eq a, Show a) => a -> a -> Property
=== CertState (AlonzoEra TestCrypto)
ds'
                              , forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"No failing Plutus scripts" forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
allPlutusTrue
                              ]
                       )
              )