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

module Test.Cardano.Ledger.Dijkstra.Imp.UtxowSpec (spec) where

import Cardano.Ledger.Conway.Rules
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Scripts
import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts
import qualified Data.Set.NonEmpty as NES
import Lens.Micro
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Dijkstra.ImpTest

spec ::
  forall era.
  DijkstraEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RequireGuard native scripts" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Spending inputs locked by script requiring a keyhash guard" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      guardKeyHash <- KeyHash Guard -> Credential Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Guard -> Credential Guard)
-> ImpM (LedgerSpec era) (KeyHash Guard)
-> ImpM (LedgerSpec era) (Credential Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      scriptHash <- impAddNativeScript (RequireGuard guardKeyHash)
      txIn <- produceScript scriptHash
      let tx = TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn])
      submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW $ NES.singleton scriptHash]
      submitTx_ $ tx & bodyTxL . guardsTxBodyL .~ [guardKeyHash]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A native script required as guard needs to be witnessed " (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let guardScript :: NativeScript era
guardScript = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf []
      let guardScriptHash :: ScriptHash
guardScriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScript
      scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ Credential Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential Guard -> NativeScript era
RequireGuard (ScriptHash -> Credential Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash)
      tx <- mkTokenMintingTx scriptHash
      submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW $ NES.singleton scriptHash]

      let txWithGuards = Tx TopTx era
tx Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) (OSet (Credential Guard))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (Credential Guard))
guardsTxBodyL ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (Credential Guard) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ScriptHash -> Credential Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash]
      submitFailingTx
        txWithGuards
        [injectFailure $ MissingScriptWitnessesUTXOW $ NES.singleton guardScriptHash]
      submitTx_ $ txWithGuards & witsTxL . hashScriptTxWitsL .~ [fromNativeScript guardScript]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A failing native script required as guard results in a predicate failure" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let guardScriptFailing :: NativeScript era
guardScriptFailing = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf []
      let guardScriptHash :: ScriptHash
guardScriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScriptFailing
      scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ Credential Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential Guard -> NativeScript era
RequireGuard (ScriptHash -> Credential Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash)
      expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
      let tx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxCert era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert (ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) Coin
expectedDeposit]
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) (OSet (Credential Guard))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (Credential Guard))
guardsTxBodyL ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (Credential Guard) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ScriptHash -> Credential Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash]
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Map ScriptHash (Script era) -> Identity [Script era])
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era) -> Identity [Script era])
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era) -> Identity [Script era])
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
hashScriptTxWitsL ((Map ScriptHash (Script era) -> Identity [Script era])
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> [Script era] -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScriptFailing]
      submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW $ NES.singleton guardScriptHash]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A redundant guard is ignored" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      guardKeyHash <- KeyHash Guard -> Credential Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Guard -> Credential Guard)
-> ImpM (LedgerSpec era) (KeyHash Guard)
-> ImpM (LedgerSpec era) (Credential Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let tx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) (OSet (Credential Guard))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (Credential Guard))
guardsTxBodyL ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (Credential Guard) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (Credential Guard))
Credential Guard
guardKeyHash]
      submitTx_ tx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Nested RequiredGuard scripts" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      guardKeyHash <- KeyHash Guard -> Credential Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Guard -> Credential Guard)
-> ImpM (LedgerSpec era) (KeyHash Guard)
-> ImpM (LedgerSpec era) (Credential Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let guardScript = Credential Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential Guard -> NativeScript era
RequireGuard Credential Guard
guardKeyHash
      let guardScriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScript

      scriptHash <- impAddNativeScript $ RequireGuard (ScriptHashObj guardScriptHash)

      tx <- mkTokenMintingTx scriptHash
      submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW $ NES.singleton scriptHash]
      submitTx_ $
        tx
          & bodyTxL . guardsTxBodyL .~ [ScriptHashObj guardScriptHash, guardKeyHash]
          & witsTxL . hashScriptTxWitsL .~ [fromNativeScript guardScript]