{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Cardano.Ledger.Shelley.Imp.UtxowSpec (spec) where
import qualified Cardano.Chain.Common as Byron
import Cardano.Ledger.Address (Addr (..), BootstrapAddress (..))
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Keys (asWitness, witVKeyHash)
import Cardano.Ledger.Keys.Bootstrap
import Cardano.Ledger.SafeHash (extractHash, hashAnnotated)
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
import Cardano.Ledger.Shelley.Scripts (
pattern RequireSignature,
)
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest
spec ::
forall era.
( ShelleyEraImp era
, Arbitrary (TxAuxData era)
, InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
) =>
SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ShelleyEraImp era, Arbitrary (TxAuxData era),
InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXOW" forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Bootstrap Witness" forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Valid Witnesses" forall a b. (a -> b) -> a -> b
$ do
BootstrapAddress (EraCrypto era)
aliceBootAddr <- forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (BootstrapAddress c)
freshBootstapAddress
TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo (forall c. BootstrapAddress c -> Addr c
AddrBootstrap BootstrapAddress (EraCrypto era)
aliceBootAddr) forall a. Monoid a => a
mempty
let txBody :: TxBody era
txBody = 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 era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"InvalidWitnessesUTXOW" forall a b. (a -> b) -> a -> b
$ do
aliceBootAddr :: BootstrapAddress (EraCrypto era)
aliceBootAddr@(BootstrapAddress Address
aliceByronAddr) <- forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (BootstrapAddress c)
freshBootstapAddress
ByronKeyPair
aliceByronKeyPair <- forall s c (m :: * -> *).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
BootstrapAddress c -> m ByronKeyPair
lookupByronKeyPair BootstrapAddress (EraCrypto era)
aliceBootAddr
TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo (forall c. BootstrapAddress c -> Addr c
AddrBootstrap BootstrapAddress (EraCrypto era)
aliceBootAddr) forall a. Monoid a => a
mempty
let (VKey 'Witness (EraCrypto era)
aliceVKey, ChainCode
_) = forall c.
(DSIGN c ~ Ed25519DSIGN) =>
VerificationKey -> (VKey 'Witness c, ChainCode)
unpackByronVKey (ByronKeyPair -> VerificationKey
bkpVerificationKey ByronKeyPair
aliceByronKeyPair)
txBody :: TxBody era
txBody = 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]
aliceBadWitness :: BootstrapWitness (EraCrypto era)
aliceBadWitness =
forall c.
(DSIGN c ~ Ed25519DSIGN, Crypto c) =>
Hash c EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness c
makeBootstrapWitness
(forall c i. SafeHash c i -> Hash (HASH c) i
extractHash (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody))
(ByronKeyPair -> SigningKey
bkpSigningKey ByronKeyPair
aliceByronKeyPair)
(Address -> Attributes AddrAttributes
Byron.addrAttributes Address
aliceByronAddr)
txBad :: Tx era
txBad =
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody
forall a b. a -> (a -> b) -> b
& (forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (BootstrapWitness (EraCrypto era)))
bootAddrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [BootstrapWitness (EraCrypto era)
aliceBadWitness]))
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
txBad [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
[VKey 'Witness (EraCrypto era)] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW [VKey 'Witness (EraCrypto era)
aliceVKey]]
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingVKeyWitnessesUTXOW" forall a b. (a -> b) -> a -> b
$ do
KeyHash 'Payment (EraCrypto era)
aliceKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo (forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Payment (EraCrypto era)
aliceKh) forall c. StakeReference c
StakeRefNull) forall a. Monoid a => a
mempty
let tx :: Tx era
tx = 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 a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
txIn]
let isAliceWitness :: WitVKey kr (EraCrypto era) -> Bool
isAliceWitness WitVKey kr (EraCrypto era)
wit = forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
witVKeyHash WitVKey kr (EraCrypto era)
wit forall a. Eq a => a -> a -> Bool
== forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'Payment (EraCrypto era)
aliceKh
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {kr :: KeyRole}. WitVKey kr (EraCrypto era) -> Bool
isAliceWitness))) forall a b. (a -> b) -> a -> b
$
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
tx
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
forall era.
Set (KeyHash 'Witness (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'Payment (EraCrypto era)
aliceKh]
]
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingScriptWitnessesUTXOW" forall a b. (a -> b) -> a -> b
$ do
KeyHash 'Witness (EraCrypto era)
requiredKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
let scriptHash :: ScriptHash (EraCrypto era)
scriptHash = forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature KeyHash 'Witness (EraCrypto era)
requiredKh
TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
scriptHash
let tx :: Tx era
tx = 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 a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
txIn]
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
tx
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW [ScriptHash (EraCrypto era)
scriptHash]
]
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingTxBodyMetadataHash" forall a b. (a -> b) -> a -> b
$ do
forall t. Int -> ImpM t ()
impSetSeed Int
12345
TxAuxData era
auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
let auxDataHash :: AuxiliaryDataHash (EraCrypto era)
auxDataHash = forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
auxData
tx :: Tx era
tx = 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) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
166249
addAuxData :: Tx era -> f (Tx era)
addAuxData Tx era
fixedTx = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era
fixedTx forall a b. a -> (a -> b) -> b
& forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust TxAuxData era
auxData)
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup forall {f :: * -> *}. Applicative f => Tx era -> f (Tx era)
addAuxData forall a b. (a -> b) -> a -> b
$
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
tx
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
forall era.
AuxiliaryDataHash (EraCrypto era) -> ShelleyUtxowPredFailure era
MissingTxBodyMetadataHash AuxiliaryDataHash (EraCrypto era)
auxDataHash
]
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingTxMetadata" forall a b. (a -> b) -> a -> b
$ do
TxAuxData era
auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
let auxDataHash :: AuxiliaryDataHash (EraCrypto era)
auxDataHash = forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
auxData
let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens'
(TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
auxDataHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust AuxiliaryDataHash (EraCrypto era)
auxDataHash
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
tx
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
forall era.
AuxiliaryDataHash (EraCrypto era) -> ShelleyUtxowPredFailure era
MissingTxMetadata AuxiliaryDataHash (EraCrypto era)
auxDataHash
]
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ConflictingMetadataHash" forall a b. (a -> b) -> a -> b
$ do
TxAuxData era
auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
let auxDataHash :: AuxiliaryDataHash (EraCrypto era)
auxDataHash = forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
auxData
AuxiliaryDataHash (EraCrypto era)
wrongAuxDataHash <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(AuxiliaryDataHash (EraCrypto era))
let tx :: Tx era
tx =
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens'
(TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
auxDataHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust AuxiliaryDataHash (EraCrypto era)
wrongAuxDataHash
forall a b. a -> (a -> b) -> b
& forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust TxAuxData era
auxData
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
tx
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
forall era.
Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
-> ShelleyUtxowPredFailure era
ConflictingMetadataHash forall a b. (a -> b) -> a -> b
$
Mismatch {mismatchSupplied :: AuxiliaryDataHash (EraCrypto era)
mismatchSupplied = AuxiliaryDataHash (EraCrypto era)
wrongAuxDataHash, mismatchExpected :: AuxiliaryDataHash (EraCrypto era)
mismatchExpected = AuxiliaryDataHash (EraCrypto era)
auxDataHash}
]
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ExtraneousScriptWitnessesUTXOW" forall a b. (a -> b) -> a -> b
$ do
KeyHash Any (EraCrypto era)
requiredKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
let script :: Script era
script = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash Any (EraCrypto era)
requiredKh)
let scriptHash :: ScriptHash (EraCrypto era)
scriptHash = forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
script
let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map (ScriptHash (EraCrypto era)) (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(ScriptHash (EraCrypto era)
scriptHash, Script era
script)]
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx forall a b. (a -> b) -> a -> b
$
if forall era. Era era => Version
eraProtVerLow @era forall a. Ord a => a -> a -> Bool
>= forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @6
then
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ExtraneousScriptWitnessesUTXOW [ScriptHash (EraCrypto era)
scriptHash]
]
else
[ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash (EraCrypto era)
scriptHash]
, forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ExtraneousScriptWitnessesUTXOW [ScriptHash (EraCrypto era)
scriptHash]
]