{-# 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
alwaysSucceedsWithDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang :: ScriptHash
          alwaysSucceedsNoDatumHash :: ScriptHash
alwaysSucceedsNoDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
slang :: ScriptHash
          alwaysFailsWithDatumHash :: ScriptHash
alwaysFailsWithDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
slang :: ScriptHash
          alwaysFailsNoDatumHash :: ScriptHash
alwaysFailsNoDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
slang :: ScriptHash

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating SPEND script" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
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
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
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
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          let txCert :: TxCert era
txCert = forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
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
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          let txCert :: TxCert era
txCert = forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
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
account <- forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential @era forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
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
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
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
account <- forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential @era forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
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
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
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 -> ImpTestM era (Tx era)
mkTokenMintingTx forall a b. (a -> b) -> a -> b
$ ScriptHash
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 -> ImpTestM era (Tx era)
mkTokenMintingTx forall a b. (a -> b) -> a -> b
$ ScriptHash
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"