{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid (spec) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure,
 )
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Plutus (
  hashPlutusScript,
  withSLanguage,
 )
import Control.Monad ((<=<))
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Valid transactions" forall a b. (a -> b) -> a -> b
$ do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall a. Show a => a -> String
show Language
lang) forall a b. (a -> b) -> a -> b
$ do
        let
          alwaysSucceedsWithDatumHash :: ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang :: ScriptHash (EraCrypto era)
          alwaysSucceedsNoDatumHash :: ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
slang :: ScriptHash (EraCrypto era)
          alwaysFailsWithDatumHash :: ScriptHash (EraCrypto era)
alwaysFailsWithDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
slang :: ScriptHash (EraCrypto era)
          alwaysFailsNoDatumHash :: ScriptHash (EraCrypto era)
alwaysFailsNoDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
slang :: ScriptHash (EraCrypto era)

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating SPEND script" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$
            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
.~ [TxIn (EraCrypto era)
txIn]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating SPEND script" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
alwaysFailsWithDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid forall a b. (a -> b) -> a -> b
$
            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
.~ [TxIn (EraCrypto era)
txIn]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating CERT script" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash
          let txCert :: TxCert era
txCert = forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$
            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
.~ [TxIn (EraCrypto era)
txIn]
                forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era
txCert]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating CERT script" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
alwaysFailsWithDatumHash
          let txCert :: TxCert era
txCert = forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid forall a b. (a -> b) -> a -> b
$
            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
.~ [TxIn (EraCrypto era)
txIn]
                forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era
txCert]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating WITHDRAWAL script" forall a b. (a -> b) -> a -> b
$ do
          RewardAccount (EraCrypto era)
account <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential @era forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$
            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) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall c. Map (RewardAccount c) Coin -> Withdrawals c
Withdrawals [(RewardAccount (EraCrypto era)
account, forall a. Monoid a => a
mempty)]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating WITHDRAWAL script" forall a b. (a -> b) -> a -> b
$ do
          RewardAccount (EraCrypto era)
account <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential @era forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
alwaysFailsNoDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid forall a b. (a -> b) -> a -> b
$
            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) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall c. Map (RewardAccount c) Coin -> Withdrawals c
Withdrawals [(RewardAccount (EraCrypto era)
account, forall a. Monoid a => a
mempty)]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating MINT script" forall a b. (a -> b) -> a -> b
$ do
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
MaryEraImp era =>
ScriptHash (EraCrypto era) -> ImpTestM era (Tx era)
mkTokenMintingTx forall a b. (a -> b) -> a -> b
$ ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating MINT script" forall a b. (a -> b) -> a -> b
$ do
          forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall era.
MaryEraImp era =>
ScriptHash (EraCrypto era) -> ImpTestM era (Tx era)
mkTokenMintingTx forall a b. (a -> b) -> a -> b
$ ScriptHash (EraCrypto era)
alwaysFailsNoDatumHash

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating scripts everywhere" forall a b. (a -> b) -> a -> b
$ do
    forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Expectation
pendingWith String
"not implemented yet"
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Acceptable supplimentary datum" forall a b. (a -> b) -> a -> b
$ do
    forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Expectation
pendingWith String
"not implemented yet"
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Multiple identical certificates" forall a b. (a -> b) -> a -> b
$ do
    forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Expectation
pendingWith String
"not implemented yet"
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Non-script output with datum" forall a b. (a -> b) -> a -> b
$ do
    forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Expectation
pendingWith String
"not implemented yet"