{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Shelley.UnitTests (unitTests) where

import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Address (Addr (..), raCredential, pattern RewardAccount)
import Cardano.Ledger.BaseTypes hiding ((==>))
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.PoolParams (
  PoolMetadata (..),
  PoolParams (..),
  pmHash,
  pmUrl,
  ppCost,
  ppId,
  ppMargin,
  ppMetadata,
  ppOwners,
  ppPledge,
  ppRelays,
  ppRewardAccount,
  ppVrf,
 )
import Cardano.Ledger.Shelley.API (
  LedgerEnv (..),
  ShelleyLEDGER,
 )
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  CertState (..),
  IncrementalStake (..),
  LedgerState (..),
  UTxOState (..),
  certDState,
  dsUnified,
  rewards,
 )
import Cardano.Ledger.Shelley.Rules (
  ShelleyDelegsPredFailure (..),
  ShelleyDelplPredFailure (..),
  ShelleyLedgerPredFailure (..),
  ShelleyPoolPredFailure (..),
  ShelleyUtxoPredFailure (..),
  ShelleyUtxowPredFailure (..),
 )
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxBody (ShelleyTxBody (..))
import Cardano.Ledger.Shelley.TxCert (ShelleyTxCert (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits, addrWits)
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val ((<+>), (<->))
import Cardano.Protocol.Crypto (StandardCrypto, VRF, hashVerKeyVRF)
import Cardano.Protocol.TPraos.BHeader (checkLeaderValue)
import Control.DeepSeq (rnf)
import Control.State.Transition.Extended (PredicateFailure, TRC (..))
import qualified Data.ByteString.Char8 as BS (pack)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.Proxy (Proxy (..))
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Word (Word64)
import GHC.Stack
import Lens.Micro
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Core.KeyPair (
  KeyPair (..),
  mkVKeyRewardAccount,
  mkWitnessVKey,
  mkWitnessesVKey,
  vKey,
 )
import Test.Cardano.Ledger.Shelley.Arbitrary (
  ASC (ASC),
  StakeProportion (StakeProportion),
 )
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C, MockCrypto)
import Test.Cardano.Ledger.Shelley.Fees (sizeTests)
import Test.Cardano.Ledger.Shelley.Generator.Core (VRFKeyPair (..), genesisCoins)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Utils
import Test.Cardano.Protocol.TPraos.Arbitrary (VRFNatVal (VRFNatVal))
import Test.Control.State.Transition.Trace (checkTrace, (.-), (.->>))
import qualified Test.QuickCheck.Gen as QC
import qualified Test.QuickCheck.Random as QC
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck

-- ========================================================================================

alicePay :: KeyPair 'Payment
alicePay :: KeyPair 'Payment
alicePay = forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
1 Word64
1 Word64
1 Word64
1

aliceStake :: KeyPair 'Staking
aliceStake :: KeyPair 'Staking
aliceStake = forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
2 Word64
2 Word64
2 Word64
2 Word64
2

aliceAddr :: Addr
aliceAddr :: Addr
aliceAddr =
  Network -> PaymentCredential -> StakeReference -> Addr
Addr
    Network
Testnet
    (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
alicePay)
    (Credential 'Staking -> StakeReference
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Staking
aliceStake)

bobPay :: KeyPair 'Payment
bobPay :: KeyPair 'Payment
bobPay = forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
3 Word64
3 Word64
3 Word64
3 Word64
3

bobStake :: KeyPair 'Staking
bobStake :: KeyPair 'Staking
bobStake = forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
4 Word64
4 Word64
4 Word64
4 Word64
4

bobAddr :: Addr
bobAddr :: Addr
bobAddr =
  Network -> PaymentCredential -> StakeReference -> Addr
Addr
    Network
Testnet
    (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
bobPay)
    (Credential 'Staking -> StakeReference
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Staking
bobStake)

mkGenesisTxIn :: HasCallStack => Integer -> TxIn
mkGenesisTxIn :: HasCallStack => Integer -> TxIn
mkGenesisTxIn = TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Integer -> TxIx
mkTxIxPartial

pp :: forall era. (EraPParams era, ProtVerAtMost era 4) => PParams era
pp :: forall era. (EraPParams era, ProtVerAtMost era 4) => PParams era
pp =
  forall era. EraPParams era => PParams era
emptyPParams
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeBL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
100
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
250
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxTxSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
1024
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
10
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
100
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
10

testVRFCheckWithActiveSlotCoeffOne :: Assertion
testVRFCheckWithActiveSlotCoeffOne :: Assertion
testVRFCheckWithActiveSlotCoeffOne =
  forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue
    (forall v. VRFAlgorithm v => Natural -> OutputVRF v
VRF.mkTestOutputVRF Natural
0 :: VRF.OutputVRF (VRF MockCrypto))
    (Integer
1 forall a. Integral a => a -> a -> Ratio a
% Integer
2)
    (PositiveUnitInterval -> ActiveSlotCoeff
mkActiveSlotCoeff forall a b. (a -> b) -> a -> b
$ forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
1)
    forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True

testsPParams :: TestTree
testsPParams :: TestTree
testsPParams =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Test the protocol parameters."
    [ TestName -> Assertion -> TestTree
testCase TestName
"VRF checks when the activeSlotCoeff is one" Assertion
testVRFCheckWithActiveSlotCoeffOne
    ]

-- | Test @checkLeaderVal@ in 'Cardano.Ledger.Shelley.BlockChain'
testCheckLeaderVal ::
  forall v.
  v ~ VRF StandardCrypto =>
  TestTree
testCheckLeaderVal :: forall v. (v ~ VRF StandardCrypto) => TestTree
testCheckLeaderVal =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Test checkLeaderVal calculation"
    [ forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"With a stake of 0, cannot lead" forall a b. (a -> b) -> a -> b
$
        \(VRFNatVal Natural
n) (ASC ActiveSlotCoeff
f) ->
          forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue @v (forall v. VRFAlgorithm v => Natural -> OutputVRF v
VRF.mkTestOutputVRF Natural
n) Rational
0 ActiveSlotCoeff
f forall a. Eq a => a -> a -> Bool
== Bool
False
    , forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"With a maximal VRF, cannot lead" forall a b. (a -> b) -> a -> b
$
        \(ASC ActiveSlotCoeff
f) (StakeProportion Rational
r) ->
          forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue @v
            (forall v. VRFAlgorithm v => Natural -> OutputVRF v
VRF.mkTestOutputVRF Natural
maxVRFVal)
            Rational
r
            ActiveSlotCoeff
f
            forall a. Eq a => a -> a -> Bool
== Bool
False
    , forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"checkLeaderVal succeeds iff l < 1 - (1-f)^r" forall a b. (a -> b) -> a -> b
$
        \(VRFNatVal Natural
n) (ASC ActiveSlotCoeff
f) (StakeProportion Rational
r) ->
          Rational
r forall a. Ord a => a -> a -> Bool
> Rational
0 forall prop. Testable prop => Bool -> prop -> Property
==>
            let ascVal :: Double
                ascVal :: Double
ascVal = forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. BoundedRational r => r -> Rational
unboundRational forall a b. (a -> b) -> a -> b
$ ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal ActiveSlotCoeff
f
             in forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue @v
                  (forall v. VRFAlgorithm v => Natural -> OutputVRF v
VRF.mkTestOutputVRF Natural
n)
                  Rational
r
                  ActiveSlotCoeff
f
                  forall a. (Eq a, Show a) => a -> a -> Property
=== ( (forall a b. (Real a, Fractional b) => a -> b
realToFrac Natural
n forall a. Fractional a => a -> a -> a
/ forall a b. (Real a, Fractional b) => a -> b
realToFrac (Natural
maxVRFVal forall a. Num a => a -> a -> a
+ Natural
1))
                          forall a. Ord a => a -> a -> Bool
< (Double
1 forall a. Num a => a -> a -> a
- (Double
1 forall a. Num a => a -> a -> a
- Double
ascVal) forall a. Floating a => a -> a -> a
** forall a. Fractional a => Rational -> a
fromRational Rational
r)
                      )
    , -- Suppose that our VRF value V is drawn uniformly from [0, maxVRFVal).
      -- The leader check verifies that fromNat V < 1 - (1-f)^r, where fromNat
      -- is an appropriate mapping into the unit interval giving fromNat V ~
      -- U(0,1). Then the probability X of being selected leader, given that VRF
      -- value, is given by p = 1 - (1 - f)^r. So assuming n independent draws
      -- of V, the number of slots in which we lead is given by S ~ Bin(n, p)
      -- and has an expected value of np.
      --
      -- The probability that S sits outside a δ-window around the mean (i.e.
      -- that this test fails under the hypothesis that our leader check is
      -- correct) is given by P(np - δ <= S <= np + δ).
      --
      -- Previously, we chose δ such that this value is quite low (eg, <1/1000).
      -- However, this means the test *will* fail sometimes. If the probability
      -- is 0.0004 and we run the test 100 times for each run of the test
      -- suite, we would expect it to fail approximately once in every 25 test
      -- runs.
      --
      -- We therefore now use a fixed seed so that this is effectively a unit test
      -- and not a property test.
      --
      forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"We are elected as leader proportional to our stake" forall a b. (a -> b) -> a -> b
$
        -- 6297 is a seed value that fails
        -- --quickcheck-replay=618 fails when withSeed isn't used
        forall prop. Testable prop => prop -> Property
once forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Int -> Gen a -> Gen a
withSeed Int
12345 forall a b. (a -> b) -> a -> b
$ do
          let numTrials :: Int
numTrials = Int
2000
          ASC ActiveSlotCoeff
f <- forall a. Arbitrary a => Gen a
arbitrary
          StakeProportion Rational
r <- forall a. Arbitrary a => Gen a
arbitrary
          [Integer]
vrfVals <- forall a. Int -> Gen a -> Gen [a]
QC.vectorOf Int
numTrials (forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
maxVRFVal :: Integer))
          let ascVal :: Double
              ascVal :: Double
ascVal = forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. BoundedRational r => r -> Rational
unboundRational forall a b. (a -> b) -> a -> b
$ ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal ActiveSlotCoeff
f
              -- 4 standard deviations
              δ :: Double
δ = Double
4 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt (forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
numTrials forall a. Num a => a -> a -> a
* Double
p forall a. Num a => a -> a -> a
* (Double
1 forall a. Num a => a -> a -> a
- Double
p))
              p :: Double
p = Double
1 forall a. Num a => a -> a -> a
- (Double
1 forall a. Num a => a -> a -> a
- Double
ascVal) forall a. Floating a => a -> a -> a
** forall a. Fractional a => Rational -> a
fromRational Rational
r
              mean :: Double
mean = forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
numTrials forall a. Num a => a -> a -> a
* Double
p
              lb :: Int
lb = forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
mean forall a. Num a => a -> a -> a
- Double
δ)
              ub :: Int
ub = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double
mean forall a. Num a => a -> a -> a
+ Double
δ)
              check :: Integer -> Bool
check Integer
vrf = forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue @v (forall v. VRFAlgorithm v => Natural -> OutputVRF v
VRF.mkTestOutputVRF forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
vrf) Rational
r ActiveSlotCoeff
f
              s :: Int
s = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Integer -> Bool
check forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Integer]
vrfVals
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            Rational
r forall a. Ord a => a -> a -> Bool
> Rational
0 forall prop. Testable prop => Bool -> prop -> Property
==>
              forall prop. Testable prop => TestName -> prop -> Property
counterexample
                (forall a. Show a => a -> TestName
show Int
lb forall a. Semigroup a => a -> a -> a
<> TestName
" /< " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> TestName
show Int
s forall a. Semigroup a => a -> a -> a
<> TestName
" /< " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> TestName
show Int
ub forall a. Semigroup a => a -> a -> a
<> TestName
" (p=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> TestName
show Double
p forall a. Semigroup a => a -> a -> a
<> TestName
")")
                (Int
lb forall a. Ord a => a -> a -> Bool
< Int
s Bool -> Bool -> Bool
&& Int
s forall a. Ord a => a -> a -> Bool
< Int
ub)
    ]
  where
    maxVRFVal :: Natural
    maxVRFVal :: Natural
maxVRFVal = (Natural
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Word
8 forall a. Num a => a -> a -> a
* forall v (proxy :: * -> *). VRFAlgorithm v => proxy v -> Word
VRF.sizeOutputVRF (forall {k} (t :: k). Proxy t
Proxy @v))) forall a. Num a => a -> a -> a
- Natural
1
    withSeed :: Int -> Gen a -> Gen a
withSeed Int
i (QC.MkGen QCGen -> Int -> a
f) = forall a. (QCGen -> Int -> a) -> Gen a
QC.MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
_r Int
n -> QCGen -> Int -> a
f (Int -> QCGen
QC.mkQCGen Int
i) Int
n

testLEDGER ::
  HasCallStack =>
  LedgerState C ->
  ShelleyTx C ->
  LedgerEnv C ->
  Either (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C) ->
  Assertion
testLEDGER :: HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER LedgerState C
initSt ShelleyTx C
tx LedgerEnv C
env (Right LedgerState C
expectedSt) = do
  forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @(ShelleyLEDGER C) forall a. ShelleyBase a -> a
runShelleyBase LedgerEnv C
env forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerState C
initSt forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- ShelleyTx C
tx forall (m :: * -> *) st.
(MonadIO m, Eq st, ToExpr st, HasCallStack) =>
m st -> st -> m st
.->> LedgerState C
expectedSt
testLEDGER LedgerState C
initSt ShelleyTx C
tx LedgerEnv C
env predicateFailure :: Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
predicateFailure@(Left NonEmpty (PredicateFailure (ShelleyLEDGER C))
_) = do
  let st :: Either (NonEmpty (ShelleyLedgerPredFailure C)) (LedgerState C)
st = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyLEDGER C) (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv C
env, LedgerState C
initSt, ShelleyTx C
tx))
  Either (NonEmpty (ShelleyLedgerPredFailure C)) (LedgerState C)
st forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
predicateFailure

aliceInitCoin :: Coin
aliceInitCoin :: Coin
aliceInitCoin = Integer -> Coin
Coin Integer
10000

data AliceToBob = AliceToBob
  { AliceToBob -> TxIn
input :: TxIn
  , AliceToBob -> Coin
toBob :: Coin
  , AliceToBob -> Coin
fee :: Coin
  , AliceToBob -> Coin
deposits :: Coin
  , AliceToBob -> Coin
refunds :: Coin
  , AliceToBob -> [TxCert C]
certs :: [TxCert C]
  , AliceToBob -> SlotNo
ttl :: SlotNo
  , AliceToBob -> [KeyPair 'Witness]
signers :: [KeyPair 'Witness]
  }

aliceGivesBobLovelace :: AliceToBob -> ShelleyTx C
aliceGivesBobLovelace :: AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
  AliceToBob
    { TxIn
input :: TxIn
$sel:input:AliceToBob :: AliceToBob -> TxIn
input
    , Coin
toBob :: Coin
$sel:toBob:AliceToBob :: AliceToBob -> Coin
toBob
    , Coin
fee :: Coin
$sel:fee:AliceToBob :: AliceToBob -> Coin
fee
    , Coin
deposits :: Coin
$sel:deposits:AliceToBob :: AliceToBob -> Coin
deposits
    , Coin
refunds :: Coin
$sel:refunds:AliceToBob :: AliceToBob -> Coin
refunds
    , [TxCert C]
certs :: [TxCert C]
$sel:certs:AliceToBob :: AliceToBob -> [TxCert C]
certs
    , SlotNo
ttl :: SlotNo
$sel:ttl:AliceToBob :: AliceToBob -> SlotNo
ttl
    , [KeyPair 'Witness]
signers :: [KeyPair 'Witness]
$sel:signers:AliceToBob :: AliceToBob -> [KeyPair 'Witness]
signers
    } = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx ShelleyTxBody C
txbody forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = Set (WitVKey 'Witness)
awits} forall a. StrictMaybe a
SNothing
    where
      aliceCoin :: Coin
aliceCoin = Coin
aliceInitCoin forall t. Val t => t -> t -> t
<+> Coin
refunds forall t. Val t => t -> t -> t
<-> (Coin
toBob forall t. Val t => t -> t -> t
<+> Coin
fee forall t. Val t => t -> t -> t
<+> Coin
deposits)
      txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
          (forall a. a -> Set a
Set.singleton TxIn
input)
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr Coin
aliceCoin
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr Coin
toBob
              ]
          )
          (forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxCert C]
certs)
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          Coin
fee
          SlotNo
ttl
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      awits :: Set (WitVKey 'Witness)
awits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txbody) [KeyPair 'Witness]
signers

utxoState :: UTxOState C
utxoState :: UTxOState C
utxoState =
  forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> IncrementalStake
-> Coin
-> UTxOState era
UTxOState
    ( forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins
        TxId
genesisId
        [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr Coin
aliceInitCoin
        , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
1000)
        ]
    )
    (Integer -> Coin
Coin Integer
0)
    (Integer -> Coin
Coin Integer
0)
    forall a. Default a => a
def
    (Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake
IStake forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)
    forall a. Monoid a => a
mempty

dpState :: CertState C
dpState :: CertState C
dpState = forall era. VState era -> PState era -> DState era -> CertState era
CertState forall a. Default a => a
def forall a. Default a => a
def forall a. Default a => a
def

ledgerState :: LedgerState C
ledgerState :: LedgerState C
ledgerState = forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState C
utxoState CertState C
dpState

addReward :: CertState C -> Credential 'Staking -> Coin -> CertState C
addReward :: CertState C -> Credential 'Staking -> Coin -> CertState C
addReward CertState C
dp Credential 'Staking
ra Coin
c = CertState C
dp {certDState :: DState C
certDState = DState C
ds {dsUnified :: UMap
dsUnified = UMap
rewards'}}
  where
    ds :: DState C
ds = forall era. CertState era -> DState era
certDState CertState C
dp
    rewards' :: UMap
rewards' = forall k v. k -> v -> UView k v -> UMap
UM.insert Credential 'Staking
ra (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Coin
c) (Word64 -> CompactForm Coin
UM.CompactCoin Word64
2)) (forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState C
ds)

-- Any key deposit works in this test ^
ledgerEnv :: LedgerEnv C
ledgerEnv :: LedgerEnv C
ledgerEnv = forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> AccountState
-> Bool
-> LedgerEnv era
LedgerEnv (Word64 -> SlotNo
SlotNo Word64
0) forall a. Maybe a
Nothing forall a. Bounded a => a
minBound forall era. (EraPParams era, ProtVerAtMost era 4) => PParams era
pp (Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)) Bool
False

testInvalidTx ::
  NonEmpty (PredicateFailure (ShelleyLEDGER C)) ->
  ShelleyTx C ->
  Assertion
testInvalidTx :: NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx NonEmpty (PredicateFailure (ShelleyLEDGER C))
errs ShelleyTx C
tx =
  HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER LedgerState C
ledgerState ShelleyTx C
tx LedgerEnv C
ledgerEnv (forall a b. a -> Either a b
Left NonEmpty (PredicateFailure (ShelleyLEDGER C))
errs)

testSpendNonexistentInput :: Assertion
testSpendNonexistentInput :: Assertion
testSpendNonexistentInput =
  NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
    [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure (forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure (forall era.
Mismatch 'RelEQ (Value era) -> ShelleyUtxoPredFailure era
ValueNotConservedUTxO forall a b. (a -> b) -> a -> b
$ forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
10000)))
    , forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure (forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure forall a b. (a -> b) -> a -> b
$ forall era. Set TxIn -> ShelleyUtxoPredFailure era
BadInputsUTxO (forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
42))
    ]
    forall a b. (a -> b) -> a -> b
$ AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
    forall a b. (a -> b) -> a -> b
$ AliceToBob
      { $sel:input:AliceToBob :: TxIn
input = HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
42 -- Non Existent
      , $sel:toBob:AliceToBob :: Coin
toBob = Integer -> Coin
Coin Integer
3000
      , $sel:fee:AliceToBob :: Coin
fee = Integer -> Coin
Coin Integer
1500
      , $sel:deposits:AliceToBob :: Coin
deposits = Integer -> Coin
Coin Integer
0
      , $sel:refunds:AliceToBob :: Coin
refunds = Integer -> Coin
Coin Integer
0
      , $sel:certs:AliceToBob :: [TxCert C]
certs = []
      , $sel:ttl:AliceToBob :: SlotNo
ttl = Word64 -> SlotNo
SlotNo Word64
100
      , $sel:signers:AliceToBob :: [KeyPair 'Witness]
signers = [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay]
      }

testWitnessNotIncluded :: Assertion
testWitnessNotIncluded :: Assertion
testWitnessNotIncluded =
  let txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
6404)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
3000)
              ]
          )
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          (Integer -> Coin
Coin Integer
596)
          (Word64 -> SlotNo
SlotNo Word64
100)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txbody forall a. Monoid a => a
mempty forall a. StrictMaybe a
SNothing
      txwits :: Set (KeyHash 'Witness)
txwits = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
alicePay)
   in NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
        [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$
            forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness)
txwits
        ]
        ShelleyTx C
tx

testSpendNotOwnedUTxO :: Assertion
testSpendNotOwnedUTxO :: Assertion
testSpendNotOwnedUTxO =
  let txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
1])
          (forall a. a -> StrictSeq a
StrictSeq.singleton forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
232))
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          (Integer -> Coin
Coin Integer
768)
          (Word64 -> SlotNo
SlotNo Word64
100)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      aliceWit :: WitVKey 'Witness
aliceWit = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txbody) KeyPair 'Payment
alicePay
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txbody forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness
aliceWit]} forall a. StrictMaybe a
SNothing
      txwits :: Set (KeyHash 'Witness)
txwits = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
bobPay)
   in NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
        [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$
            forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness)
txwits
        ]
        ShelleyTx C
tx

testWitnessWrongUTxO :: Assertion
testWitnessWrongUTxO :: Assertion
testWitnessWrongUTxO =
  let txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
1])
          (forall a. a -> StrictSeq a
StrictSeq.singleton forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
230))
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          (Integer -> Coin
Coin Integer
770)
          (Word64 -> SlotNo
SlotNo Word64
100)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      tx2body :: ShelleyTxBody C
tx2body =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
1])
          (forall a. a -> StrictSeq a
StrictSeq.singleton forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
230))
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          (Integer -> Coin
Coin Integer
770)
          (Word64 -> SlotNo
SlotNo Word64
101)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      aliceWit :: WitVKey 'Witness
aliceWit = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
tx2body) KeyPair 'Payment
alicePay
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txbody forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness
aliceWit]} forall a. StrictMaybe a
SNothing
      txwits :: Set (KeyHash 'Witness)
txwits = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
bobPay)
   in NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
        [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$
            forall era. [VKey 'Witness] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW
              [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
alicePay]
        , forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$
            forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness)
txwits
        ]
        ShelleyTx C
tx

testEmptyInputSet :: Assertion
testEmptyInputSet :: Assertion
testEmptyInputSet =
  let aliceWithdrawal :: Map RewardAccount Coin
aliceWithdrawal = forall k a. k -> a -> Map k a
Map.singleton (Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
Testnet KeyPair 'Staking
aliceStake) (Integer -> Coin
Coin Integer
2000)
      txb :: ShelleyTxBody C
txb =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
          forall a. Set a
Set.empty
          (forall a. a -> StrictSeq a
StrictSeq.singleton forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
1000))
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals Map RewardAccount Coin
aliceWithdrawal)
          (Integer -> Coin
Coin Integer
1000)
          (Word64 -> SlotNo
SlotNo Word64
0)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      txwits :: ShelleyTxWits C
txwits = forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txb) [KeyPair 'Staking
aliceStake]}
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx ShelleyTxBody C
txb ShelleyTxWits C
txwits forall a. StrictMaybe a
SNothing
      dpState' :: CertState C
dpState' = CertState C -> Credential 'Staking -> Coin -> CertState C
addReward CertState C
dpState (RewardAccount -> Credential 'Staking
raCredential forall a b. (a -> b) -> a -> b
$ Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
Testnet KeyPair 'Staking
aliceStake) (Integer -> Coin
Coin Integer
2000)
   in HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER
        (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState C
utxoState CertState C
dpState')
        ShelleyTx C
tx
        LedgerEnv C
ledgerEnv
        (forall a b. a -> Either a b
Left [forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure (forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure forall era. ShelleyUtxoPredFailure era
InputSetEmptyUTxO)])

testFeeTooSmall :: Assertion
testFeeTooSmall :: Assertion
testFeeTooSmall =
  NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
    [forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure (forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure (forall era. Mismatch 'RelGTEQ Coin -> ShelleyUtxoPredFailure era
FeeTooSmallUTxO forall a b. (a -> b) -> a -> b
$ forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch (Integer -> Coin
Coin Integer
1) (Integer -> Coin
Coin Integer
279)))]
    forall a b. (a -> b) -> a -> b
$ AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
      AliceToBob
        { $sel:input:AliceToBob :: TxIn
input = TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound
        , $sel:toBob:AliceToBob :: Coin
toBob = Integer -> Coin
Coin Integer
3000
        , $sel:fee:AliceToBob :: Coin
fee = Integer -> Coin
Coin Integer
1
        , $sel:deposits:AliceToBob :: Coin
deposits = Integer -> Coin
Coin Integer
0
        , $sel:refunds:AliceToBob :: Coin
refunds = Integer -> Coin
Coin Integer
0
        , $sel:certs:AliceToBob :: [TxCert C]
certs = []
        , $sel:ttl:AliceToBob :: SlotNo
ttl = Word64 -> SlotNo
SlotNo Word64
100
        , $sel:signers:AliceToBob :: [KeyPair 'Witness]
signers = [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay]
        }

testExpiredTx :: Assertion
testExpiredTx :: Assertion
testExpiredTx =
  let errs :: NonEmpty (ShelleyLedgerPredFailure C)
errs =
        [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure (forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure (forall era. Mismatch 'RelLTEQ SlotNo -> ShelleyUtxoPredFailure era
ExpiredUTxO forall a b. (a -> b) -> a -> b
$ forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch (SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}) (SlotNo {unSlotNo :: Word64
unSlotNo = Word64
1})))
        ]
      tx :: ShelleyTx C
tx =
        AliceToBob -> ShelleyTx C
aliceGivesBobLovelace forall a b. (a -> b) -> a -> b
$
          AliceToBob
            { $sel:input:AliceToBob :: TxIn
input = TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound
            , $sel:toBob:AliceToBob :: Coin
toBob = Integer -> Coin
Coin Integer
3000
            , $sel:fee:AliceToBob :: Coin
fee = Integer -> Coin
Coin Integer
600
            , $sel:deposits:AliceToBob :: Coin
deposits = Integer -> Coin
Coin Integer
0
            , $sel:refunds:AliceToBob :: Coin
refunds = Integer -> Coin
Coin Integer
0
            , $sel:certs:AliceToBob :: [TxCert C]
certs = []
            , $sel:ttl:AliceToBob :: SlotNo
ttl = Word64 -> SlotNo
SlotNo Word64
0
            , $sel:signers:AliceToBob :: [KeyPair 'Witness]
signers = [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay]
            }
      ledgerEnv' :: LedgerEnv C
ledgerEnv' = forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> AccountState
-> Bool
-> LedgerEnv era
LedgerEnv (Word64 -> SlotNo
SlotNo Word64
1) forall a. Maybe a
Nothing forall a. Bounded a => a
minBound forall era. (EraPParams era, ProtVerAtMost era 4) => PParams era
pp (Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)) Bool
False
   in HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER LedgerState C
ledgerState ShelleyTx C
tx LedgerEnv C
ledgerEnv' (forall a b. a -> Either a b
Left NonEmpty (ShelleyLedgerPredFailure C)
errs)

testInvalidWintess :: Assertion
testInvalidWintess :: Assertion
testInvalidWintess =
  let txb :: ShelleyTxBody C
txb =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
6000)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
3000)
              ]
          )
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          (Integer -> Coin
Coin Integer
1000)
          (Word64 -> SlotNo
SlotNo Word64
1)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      txb' :: ShelleyTxBody C
txb' = ShelleyTxBody C
txb {stbTTL :: SlotNo
stbTTL = Word64 -> SlotNo
SlotNo Word64
2}
      txwits :: Cardano.Ledger.Shelley.TxWits.ShelleyTxWits C
      txwits :: ShelleyTxWits C
txwits = forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txb') [KeyPair 'Payment
alicePay]}
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txb ShelleyTxWits C
txwits forall a. StrictMaybe a
SNothing
      errs :: NonEmpty (ShelleyLedgerPredFailure C)
errs =
        [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$
            forall era. [VKey 'Witness] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW
              [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Payment
alicePay]
        ]
   in HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER LedgerState C
ledgerState ShelleyTx C
tx LedgerEnv C
ledgerEnv (forall a b. a -> Either a b
Left NonEmpty (ShelleyLedgerPredFailure C)
errs)

testWithdrawalNoWit :: Assertion
testWithdrawalNoWit :: Assertion
testWithdrawalNoWit =
  let txb :: ShelleyTxBody C
txb =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
6000)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
3010)
              ]
          )
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
Testnet KeyPair 'Staking
bobStake) (Integer -> Coin
Coin Integer
10))
          (Integer -> Coin
Coin Integer
1000)
          (Word64 -> SlotNo
SlotNo Word64
0)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      txwits :: ShelleyTxWits C
      txwits :: ShelleyTxWits C
txwits = forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txb) KeyPair 'Payment
alicePay}
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txb ShelleyTxWits C
txwits forall a. StrictMaybe a
SNothing
      missing :: Set (KeyHash 'Witness)
missing = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Staking
bobStake)
      errs :: NonEmpty (ShelleyLedgerPredFailure C)
errs =
        [ forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$ forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness)
missing
        ]
      dpState' :: CertState C
dpState' = CertState C -> Credential 'Staking -> Coin -> CertState C
addReward CertState C
dpState (RewardAccount -> Credential 'Staking
raCredential forall a b. (a -> b) -> a -> b
$ Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
Testnet KeyPair 'Staking
bobStake) (Integer -> Coin
Coin Integer
10)
   in HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState C
utxoState CertState C
dpState') ShelleyTx C
tx LedgerEnv C
ledgerEnv (forall a b. a -> Either a b
Left NonEmpty (ShelleyLedgerPredFailure C)
errs)

testWithdrawalWrongAmt :: Assertion
testWithdrawalWrongAmt :: Assertion
testWithdrawalWrongAmt =
  let txb :: ShelleyTxBody C
txb =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (Integer -> Coin
Coin Integer
6000)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
3011)
              ]
          )
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
Testnet KeyPair 'Staking
bobStake) (Integer -> Coin
Coin Integer
11))
          (Integer -> Coin
Coin Integer
1000)
          (Word64 -> SlotNo
SlotNo Word64
0)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      txwits :: ShelleyTxWits C
txwits =
        forall a. Monoid a => a
mempty
          { addrWits :: Set (WitVKey 'Witness)
addrWits =
              forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey
                (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txb)
                [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay, forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
bobStake]
          }
      rAccount :: RewardAccount
rAccount = Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
Testnet KeyPair 'Staking
bobStake
      dpState' :: CertState C
dpState' = CertState C -> Credential 'Staking -> Coin -> CertState C
addReward CertState C
dpState (RewardAccount -> Credential 'Staking
raCredential RewardAccount
rAccount) (Integer -> Coin
Coin Integer
10)
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txb ShelleyTxWits C
txwits forall a. StrictMaybe a
SNothing
      errs :: NonEmpty (ShelleyLedgerPredFailure C)
errs = [forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure (forall era. Map RewardAccount Coin -> ShelleyDelegsPredFailure era
WithdrawalsNotInRewardsDELEGS (forall k a. k -> a -> Map k a
Map.singleton RewardAccount
rAccount (Integer -> Coin
Coin Integer
11)))]
   in HasCallStack =>
LedgerState C
-> ShelleyTx C
-> LedgerEnv C
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER C))) (LedgerState C)
-> Assertion
testLEDGER (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState C
utxoState CertState C
dpState') ShelleyTx C
tx LedgerEnv C
ledgerEnv (forall a b. a -> Either a b
Left NonEmpty (ShelleyLedgerPredFailure C)
errs)

testOutputTooSmall :: Assertion
testOutputTooSmall :: Assertion
testOutputTooSmall =
  NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
    [forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure (forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure forall a b. (a -> b) -> a -> b
$ forall era. [TxOut era] -> ShelleyUtxoPredFailure era
OutputTooSmallUTxO [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
1)])]
    forall a b. (a -> b) -> a -> b
$ AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
    forall a b. (a -> b) -> a -> b
$ AliceToBob
      { $sel:input:AliceToBob :: TxIn
input = TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound
      , $sel:toBob:AliceToBob :: Coin
toBob = Integer -> Coin
Coin Integer
1 -- Too Small
      , $sel:fee:AliceToBob :: Coin
fee = Integer -> Coin
Coin Integer
997
      , $sel:deposits:AliceToBob :: Coin
deposits = Integer -> Coin
Coin Integer
0
      , $sel:refunds:AliceToBob :: Coin
refunds = Integer -> Coin
Coin Integer
0
      , $sel:certs:AliceToBob :: [TxCert C]
certs = []
      , $sel:ttl:AliceToBob :: SlotNo
ttl = Word64 -> SlotNo
SlotNo Word64
0
      , $sel:signers:AliceToBob :: [KeyPair 'Witness]
signers = [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay]
      }

alicePoolColdKeys :: KeyPair 'StakePool
alicePoolColdKeys :: KeyPair 'StakePool
alicePoolColdKeys = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall {kd :: KeyRole}. VKey kd
vk SignKeyDSIGN DSIGN
sk
  where
    (SignKeyDSIGN DSIGN
sk, VKey kd
vk) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
1)

alicePoolParamsSmallCost :: PoolParams
alicePoolParamsSmallCost :: PoolParams
alicePoolParamsSmallCost =
  PoolParams
    { ppId :: KeyHash 'StakePool
ppId = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'StakePool
alicePoolColdKeys
    , ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @MockCrypto VerKeyVRF FakeVRF
vkVrf
    , ppPledge :: Coin
ppPledge = Integer -> Coin
Coin Integer
1
    , ppCost :: Coin
ppCost = Integer -> Coin
Coin Integer
5 -- Too Small!
    , ppMargin :: UnitInterval
ppMargin = forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.1
    , ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ KeyPair 'Staking
aliceStake)
    , ppOwners :: Set (KeyHash 'Staking)
ppOwners = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey) KeyPair 'Staking
aliceStake
    , ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. StrictSeq a
StrictSeq.empty
    , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata =
        forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$
          PoolMetadata
            { pmUrl :: Url
pmUrl = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
64 Text
"alice.pool"
            , pmHash :: ByteString
pmHash = TestName -> ByteString
BS.pack TestName
"{}"
            }
    }
  where
    vkVrf :: VerKeyVRF (VRF MockCrypto)
vkVrf = forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair @MockCrypto (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
2)

testPoolCostTooSmall :: Assertion
testPoolCostTooSmall :: Assertion
testPoolCostTooSmall =
  NonEmpty (PredicateFailure (ShelleyLEDGER C))
-> ShelleyTx C -> Assertion
testInvalidTx
    [ forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure forall a b. (a -> b) -> a -> b
$
        forall era.
PredicateFailure (EraRule "DELPL" era)
-> ShelleyDelegsPredFailure era
DelplFailure forall a b. (a -> b) -> a -> b
$
          forall era.
PredicateFailure (EraRule "POOL" era)
-> ShelleyDelplPredFailure era
PoolFailure forall a b. (a -> b) -> a -> b
$
            forall era. Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
StakePoolCostTooLowPOOL forall a b. (a -> b) -> a -> b
$
              forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch (PoolParams -> Coin
ppCost PoolParams
alicePoolParamsSmallCost) (forall era. (EraPParams era, ProtVerAtMost era 4) => PParams era
pp @C forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL)
    ]
    forall a b. (a -> b) -> a -> b
$ AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
    forall a b. (a -> b) -> a -> b
$ AliceToBob
      { $sel:input:AliceToBob :: TxIn
input = TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound
      , $sel:toBob:AliceToBob :: Coin
toBob = Integer -> Coin
Coin Integer
100
      , $sel:fee:AliceToBob :: Coin
fee = Integer -> Coin
Coin Integer
997
      , $sel:deposits:AliceToBob :: Coin
deposits = Integer -> Coin
Coin Integer
250
      , $sel:refunds:AliceToBob :: Coin
refunds = Integer -> Coin
Coin Integer
0
      , $sel:certs:AliceToBob :: [TxCert C]
certs = [forall era. PoolCert -> ShelleyTxCert era
ShelleyTxCertPool forall a b. (a -> b) -> a -> b
$ PoolParams -> PoolCert
RegPool PoolParams
alicePoolParamsSmallCost]
      , $sel:ttl:AliceToBob :: SlotNo
ttl = Word64 -> SlotNo
SlotNo Word64
0
      , $sel:signers:AliceToBob :: [KeyPair 'Witness]
signers =
          ( [ forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay
            , forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
aliceStake
            , forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'StakePool
alicePoolColdKeys
            ]
          )
      }

testProducedOverMaxWord64 :: Assertion
testProducedOverMaxWord64 :: Assertion
testProducedOverMaxWord64 =
  let biggestCoin :: Integer
biggestCoin = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word64)
      txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
          (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
bobAddr (Integer -> Coin
Coin Integer
biggestCoin)])
          forall a. StrictSeq a
Empty
          (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
          (Integer -> Coin
Coin Integer
1) -- @produced@ will return biggestCoin + 1, which is > 2^64.
          (Word64 -> SlotNo
SlotNo Word64
100)
          forall a. StrictMaybe a
SNothing
          forall a. StrictMaybe a
SNothing
      txwits :: ShelleyTxWits C
txwits = forall a. Monoid a => a
mempty {addrWits :: Set (WitVKey 'Witness)
addrWits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody C
txbody) [KeyPair 'Payment
alicePay]}
      tx :: ShelleyTx C
tx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx @C ShelleyTxBody C
txbody ShelleyTxWits C
txwits forall a. StrictMaybe a
SNothing
      st :: Either (NonEmpty (ShelleyLedgerPredFailure C)) (LedgerState C)
st =
        forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyLEDGER C) (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv C
ledgerEnv, LedgerState C
ledgerState, ShelleyTx C
tx))
   in -- We test that the predicate failure does not return bottom
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. NFData a => a -> ()
rnf Either (NonEmpty (ShelleyLedgerPredFailure C)) (LedgerState C)
st

testsInvalidLedger :: TestTree
testsInvalidLedger :: TestTree
testsInvalidLedger =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Tests with invalid transactions in ledger"
    [ TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice tries to spend a nonexistent input" Assertion
testSpendNonexistentInput
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice does not include a witness" Assertion
testWitnessNotIncluded
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice tries to spend Bob's UTxO" Assertion
testSpendNotOwnedUTxO
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice provides witness of wrong UTxO" Assertion
testWitnessWrongUTxO
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice's transaction does not consume input" Assertion
testEmptyInputSet
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice's fee is too small" Assertion
testFeeTooSmall
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Alice's transaction has expired" Assertion
testExpiredTx
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Invalid witnesses" Assertion
testInvalidWintess
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - No withdrawal witness" Assertion
testWithdrawalNoWit
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - Incorrect withdrawal amount" Assertion
testWithdrawalWrongAmt
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - OutputTooSmall" Assertion
testOutputTooSmall
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - PoolCostTooSmall" Assertion
testPoolCostTooSmall
    , TestName -> Assertion -> TestTree
testCase TestName
"Invalid Ledger - ProducedOverMaxWord64" Assertion
testProducedOverMaxWord64
    ]

unitTests :: TestTree
unitTests :: TestTree
unitTests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Unit Tests"
    [ TestTree
testsInvalidLedger
    , TestTree
testsPParams
    , TestTree
sizeTests
    , forall v. (v ~ VRF StandardCrypto) => TestTree
testCheckLeaderVal
    ]