{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Shelley.Imp.LedgerSpec (
  spec,
) where

import Cardano.Ledger.BaseTypes (inject)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.UTxO (UTxO (..))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ShelleyEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LEDGER" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Transactions update UTxO" forall a b. (a -> b) -> a -> b
$ do
    KeyPair 'Payment (EraCrypto era)
kpPayment1 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
    KeyPair 'Staking (EraCrypto era)
kpStaking1 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
    let coin1 :: Coin
coin1 = Integer -> Coin
Coin Integer
2000000
    Tx era
tx1 <-
      forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"First transaction" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton
              (forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut (forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (KeyPair 'Payment (EraCrypto era)
kpPayment1, KeyPair 'Staking (EraCrypto era)
kpStaking1)) forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject Coin
coin1)
    UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo1 <- forall era. ImpTestM era (UTxO era)
getUTxO
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
txInAt (Int
0 :: Int) Tx era
tx1) Map (TxIn (EraCrypto era)) (TxOut era)
utxo1 of
      Just TxOut era
out1 -> TxOut era
out1 forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
coin1
      Maybe (TxOut era)
Nothing -> forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure String
"Could not find the TxOut of the first transaction"
    KeyPair 'Payment (EraCrypto era)
kpPayment2 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
    KeyPair 'Staking (EraCrypto era)
kpStaking2 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
    let coin2 :: Coin
coin2 = Integer -> Coin
Coin Integer
3000000
    Tx era
tx2 <-
      forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Second transaction" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton
              (forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
txInAt (Int
0 :: Int) Tx era
tx1)
          forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton
              (forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut (forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (KeyPair 'Payment (EraCrypto era)
kpPayment2, KeyPair 'Staking (EraCrypto era)
kpStaking2)) forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject Coin
coin2)
    UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo2 <- forall era. ImpTestM era (UTxO era)
getUTxO
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
txInAt (Int
0 :: Int) Tx era
tx2) Map (TxIn (EraCrypto era)) (TxOut era)
utxo2 of
      Just TxOut era
out1 -> do
        TxOut era
out1 forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
coin2
      Maybe (TxOut era)
Nothing -> forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure String
"Could not find the TxOut of the second transaction"