{-# 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 Cardano.Crypto.Hash.Class (HashAlgorithm)
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.Crypto (Crypto, HASH, StandardCrypto, VRF)
import Cardano.Ledger.Keys (
  KeyRole (..),
  asWitness,
  hashKey,
  hashVerKeyVRF,
 )
import Cardano.Ledger.PoolParams (
  PoolMetadata (..),
  PoolParams (..),
  pmHash,
  pmUrl,
  ppCost,
  ppId,
  ppMargin,
  ppMetadata,
  ppOwners,
  ppPledge,
  ppRelays,
  ppRewardAccount,
  ppVrf,
 )
import Cardano.Ledger.SafeHash (hashAnnotated)
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.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.Class (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),
  VRFNatVal (VRFNatVal),
 )
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C, C_Crypto)
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.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 :: Crypto c => KeyPair 'Payment c
alicePay :: forall c. Crypto c => KeyPair 'Payment c
alicePay = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
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 :: Crypto c => KeyPair 'Staking c
aliceStake :: forall c. Crypto c => KeyPair 'Staking c
aliceStake = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
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 :: Crypto c => Addr c
aliceAddr :: forall c. Crypto c => Addr c
aliceAddr =
  forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr
    Network
Testnet
    (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
alicePay)
    (forall c. StakeCredential c -> StakeReference c
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Staking c
aliceStake)

bobPay :: Crypto c => KeyPair 'Payment c
bobPay :: forall c. Crypto c => KeyPair 'Payment c
bobPay = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
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 :: Crypto c => KeyPair 'Staking c
bobStake :: forall c. Crypto c => KeyPair 'Staking c
bobStake = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
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 :: Crypto c => Addr c
bobAddr :: forall c. Crypto c => Addr c
bobAddr =
  forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr
    Network
Testnet
    (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
bobPay)
    (forall c. StakeCredential c -> StakeReference c
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Staking c
bobStake)

mkGenesisTxIn :: (HashAlgorithm (HASH c), HasCallStack) => Integer -> TxIn c
mkGenesisTxIn :: forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn = forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
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 C_Crypto))
    (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 C_Crypto
input :: TxIn C_Crypto
  , 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 C_Crypto]
signers :: [KeyPair 'Witness C_Crypto]
  }

aliceGivesBobLovelace :: AliceToBob -> ShelleyTx C
aliceGivesBobLovelace :: AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
  AliceToBob
    { TxIn C_Crypto
input :: TxIn C_Crypto
$sel:input:AliceToBob :: AliceToBob -> TxIn C_Crypto
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 C_Crypto]
signers :: [KeyPair 'Witness C_Crypto]
$sel:signers:AliceToBob :: AliceToBob -> [KeyPair 'Witness C_Crypto]
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 (EraCrypto C))
addrWits = Set (WitVKey 'Witness C_Crypto)
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 (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
          (forall a. a -> Set a
Set.singleton TxIn C_Crypto
input)
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr Coin
aliceCoin
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr Coin
toBob
              ]
          )
          (forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxCert C]
certs)
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 C_Crypto)
awits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txbody) [KeyPair 'Witness C_Crypto]
signers

utxoState :: UTxOState C
utxoState :: UTxOState C
utxoState =
  forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> IncrementalStake (EraCrypto era)
-> Coin
-> UTxOState era
UTxOState
    ( forall era. TxId (EraCrypto era) -> [TxOut era] -> UTxO era
genesisCoins
        forall c. HashAlgorithm (HASH c) => TxId c
genesisId
        [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr Coin
aliceInitCoin
        , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr (Integer -> Coin
Coin Integer
1000)
        ]
    )
    (Integer -> Coin
Coin Integer
0)
    (Integer -> Coin
Coin Integer
0)
    forall a. Default a => a
def
    (forall c.
Map (Credential 'Staking c) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake c
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 C_Crypto -> Coin -> CertState C
addReward :: CertState C -> Credential 'Staking C_Crypto -> Coin -> CertState C
addReward CertState C
dp Credential 'Staking C_Crypto
ra Coin
c = CertState C
dp {certDState :: DState C
certDState = DState C
ds {dsUnified :: UMap (EraCrypto C)
dsUnified = UMap C_Crypto
rewards'}}
  where
    ds :: DState C
ds = forall era. CertState era -> DState era
certDState CertState C
dp
    rewards' :: UMap C_Crypto
rewards' = forall k v c. k -> v -> UView c k v -> UMap c
UM.insert Credential 'Staking C_Crypto
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
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards DState C
ds)

-- Any key deposit works in this test ^
ledgerEnv :: LedgerEnv C
ledgerEnv :: LedgerEnv C
ledgerEnv = forall era.
SlotNo
-> TxIx -> PParams era -> AccountState -> Bool -> LedgerEnv era
LedgerEnv (Word64 -> SlotNo
SlotNo Word64
0) 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. Value era -> Value era -> ShelleyUtxoPredFailure era
ValueNotConservedUTxO (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 (EraCrypto era)) -> ShelleyUtxoPredFailure era
BadInputsUTxO (forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
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 C_Crypto
input = forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
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 C_Crypto]
signers = [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
alicePay]
      }

testWitnessNotIncluded :: Assertion
testWitnessNotIncluded :: Assertion
testWitnessNotIncluded =
  let txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
6404)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr (Integer -> Coin
Coin Integer
3000)
              ]
          )
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 C_Crypto)
txwits = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness C_Crypto)
txwits
        ]
        ShelleyTx C
tx

testSpendNotOwnedUTxO :: Assertion
testSpendNotOwnedUTxO :: Assertion
testSpendNotOwnedUTxO =
  let txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
232))
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 C_Crypto
aliceWit = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txbody) forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto C))
addrWits = forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness C_Crypto
aliceWit]} forall a. StrictMaybe a
SNothing
      txwits :: Set (KeyHash 'Witness C_Crypto)
txwits = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness C_Crypto)
txwits
        ]
        ShelleyTx C
tx

testWitnessWrongUTxO :: Assertion
testWitnessWrongUTxO :: Assertion
testWitnessWrongUTxO =
  let txbody :: ShelleyTxBody C
txbody =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
230))
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
230))
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 C_Crypto
aliceWit = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
tx2body) forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto C))
addrWits = forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness C_Crypto
aliceWit]} forall a. StrictMaybe a
SNothing
      txwits :: Set (KeyHash 'Witness C_Crypto)
txwits = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto era)] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW
              [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
alicePay]
        , forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall a b. (a -> b) -> a -> b
$
            forall era.
Set (KeyHash 'Witness (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness C_Crypto)
txwits
        ]
        ShelleyTx C
tx

testEmptyInputSet :: Assertion
testEmptyInputSet :: Assertion
testEmptyInputSet =
  let aliceWithdrawal :: Map (RewardAccount (EraCrypto C)) Coin
aliceWithdrawal = forall k a. k -> a -> Map k a
Map.singleton (forall c.
Crypto c =>
Network -> KeyPair 'Staking c -> RewardAccount c
mkVKeyRewardAccount Network
Testnet forall c. Crypto c => KeyPair 'Staking c
aliceStake) (Integer -> Coin
Coin Integer
2000)
      txb :: ShelleyTxBody C
txb =
        forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> 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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
1000))
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
Withdrawals Map (RewardAccount (EraCrypto C)) 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 (EraCrypto C))
addrWits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txb) [forall c. Crypto c => KeyPair 'Staking c
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 C_Crypto -> Coin -> CertState C
addReward CertState C
dpState (forall c. RewardAccount c -> Credential 'Staking c
raCredential forall a b. (a -> b) -> a -> b
$ forall c.
Crypto c =>
Network -> KeyPair 'Staking c -> RewardAccount c
mkVKeyRewardAccount Network
Testnet forall c. Crypto c => KeyPair 'Staking c
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
205)))]
    forall a b. (a -> b) -> a -> b
$ AliceToBob -> ShelleyTx C
aliceGivesBobLovelace
      AliceToBob
        { $sel:input:AliceToBob :: TxIn C_Crypto
input = forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
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 C_Crypto]
signers = [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
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. SlotNo -> SlotNo -> ShelleyUtxoPredFailure era
ExpiredUTxO (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 C_Crypto
input = forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
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 C_Crypto]
signers = [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
alicePay]
            }
      ledgerEnv' :: LedgerEnv C
ledgerEnv' = forall era.
SlotNo
-> TxIx -> PParams era -> AccountState -> Bool -> LedgerEnv era
LedgerEnv (Word64 -> SlotNo
SlotNo Word64
1) 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 (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
6000)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr (Integer -> Coin
Coin Integer
3000)
              ]
          )
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 (EraCrypto C))
addrWits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txb') [forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto era)] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW
              [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
6000)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr (Integer -> Coin
Coin Integer
3010)
              ]
          )
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
Withdrawals forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall c.
Crypto c =>
Network -> KeyPair 'Staking c -> RewardAccount c
mkVKeyRewardAccount Network
Testnet forall c. Crypto c => KeyPair 'Staking c
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 (EraCrypto C))
addrWits = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txb) forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto C))
missing = forall a. a -> Set a
Set.singleton (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall c. Crypto c => KeyPair 'Staking c
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 (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness (EraCrypto C))
missing
        ]
      dpState' :: CertState C
dpState' = CertState C -> Credential 'Staking C_Crypto -> Coin -> CertState C
addReward CertState C
dpState (forall c. RewardAccount c -> Credential 'Staking c
raCredential forall a b. (a -> b) -> a -> b
$ forall c.
Crypto c =>
Network -> KeyPair 'Staking c -> RewardAccount c
mkVKeyRewardAccount Network
Testnet forall c. Crypto c => KeyPair 'Staking c
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 (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
          ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
              [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
aliceAddr (Integer -> Coin
Coin Integer
6000)
              , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr (Integer -> Coin
Coin Integer
3011)
              ]
          )
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
Withdrawals forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall c.
Crypto c =>
Network -> KeyPair 'Staking c -> RewardAccount c
mkVKeyRewardAccount Network
Testnet forall c. Crypto c => KeyPair 'Staking c
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 (EraCrypto C))
addrWits =
              forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey @C_Crypto
                (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txb)
                [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
alicePay, forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Staking c
bobStake]
          }
      rAccount :: RewardAccount C_Crypto
rAccount = forall c.
Crypto c =>
Network -> KeyPair 'Staking c -> RewardAccount c
mkVKeyRewardAccount Network
Testnet forall c. Crypto c => KeyPair 'Staking c
bobStake
      dpState' :: CertState C
dpState' = CertState C -> Credential 'Staking C_Crypto -> Coin -> CertState C
addReward CertState C
dpState (forall c. RewardAccount c -> Credential 'Staking c
raCredential RewardAccount C_Crypto
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 (EraCrypto era)) Coin
-> ShelleyDelegsPredFailure era
WithdrawalsNotInRewardsDELEGS (forall k a. k -> a -> Map k a
Map.singleton RewardAccount C_Crypto
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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
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 C_Crypto
input = forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
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 C_Crypto]
signers = [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
alicePay]
      }

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

alicePoolParamsSmallCost :: PoolParams C_Crypto
alicePoolParamsSmallCost :: PoolParams C_Crypto
alicePoolParamsSmallCost =
  PoolParams
    { ppId :: KeyHash 'StakePool C_Crypto
ppId = forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ KeyPair 'StakePool C_Crypto
alicePoolColdKeys
    , ppVrf :: Hash C_Crypto (VerKeyVRF C_Crypto)
ppVrf = forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
hashVerKeyVRF 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 C_Crypto
ppRewardAccount = forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => KeyPair 'Staking c
aliceStake)
    , ppOwners :: Set (KeyHash 'Staking C_Crypto)
ppOwners = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ (forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey) forall c. Crypto c => KeyPair 'Staking c
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 C_Crypto
vkVrf = forall c. VRFKeyPair c -> VerKeyVRF c
vrfVerKey forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair @C_Crypto (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 (forall c. PoolParams c -> Coin
ppCost PoolParams C_Crypto
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 C_Crypto
input = forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
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 (EraCrypto era) -> ShelleyTxCert era
ShelleyTxCertPool forall a b. (a -> b) -> a -> b
$ forall c. PoolParams c -> PoolCert c
RegPool PoolParams C_Crypto
alicePoolParamsSmallCost]
      , $sel:ttl:AliceToBob :: SlotNo
ttl = Word64 -> SlotNo
SlotNo Word64
0
      , $sel:signers:AliceToBob :: [KeyPair 'Witness C_Crypto]
signers =
          ( [ forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
alicePay
            , forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Staking c
aliceStake
            , forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'StakePool C_Crypto
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 (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody @C
          (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
          (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
bobAddr (Integer -> Coin
Coin Integer
biggestCoin)])
          forall a. StrictSeq a
Empty
          (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
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 (EraCrypto C))
addrWits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey @C_Crypto (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody C
txbody) [forall c. Crypto c => KeyPair 'Payment c
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
    ]