{-# LANGUAGE AllowAmbiguousTypes #-}

module Hydra.Ledger.CardanoSpec where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (toList)
import Test.Hydra.Prelude

import Cardano.Ledger.Api (ensureMinCoinTxOut)
import Cardano.Ledger.Credential (Credential (..))
import Data.Aeson (eitherDecode, encode)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key)
import Data.Text (unpack)
import GHC.IsList (IsList (..))
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Chain.ChainState (ChainSlot (ChainSlot))
import Hydra.JSONSchema (prop_validateJSONSchema)
import Hydra.Ledger (applyTransactions)
import Hydra.Ledger.Cardano (cardanoLedger, genSequenceOfSimplePaymentTransactions)
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Hydra.Node.Fixture (defaultGlobals, defaultLedgerEnv, defaultPParams)
import Test.Hydra.Tx.Gen (genOneUTxOFor, genOutput, genTxOut, genUTxO, genUTxOAdaOnlyOfSize, genUTxOFor, genValue)
import Test.QuickCheck (
  Property,
  checkCoverage,
  conjoin,
  counterexample,
  cover,
  forAll,
  forAllBlind,
  property,
  sized,
  vectorOf,
  (===),
 )
import Test.Util (propCollisionResistant)

spec :: Spec
spec :: Spec
spec =
  Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Proxy AssetName -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AssetName)

    -- XXX: Move API conformance tests to API specs and add any missing ones
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTxO" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"JSON encoding of UTxO according to schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @UTxO String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
          Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"schemas" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"UTxO"

      -- TODO(SN): rather ensure we use bech32 for addresses as a test
      String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"parses a specific UTxO" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
        let bs :: LByteString
bs =
              LByteString
"{\"9fdc525c20bc00d9dfa9d14904b65e01910c0dfe3bb39865523c1e20eaeb0903#0\":\
              \  {\"address\":\"addr1vx35vu6aqmdw6uuc34gkpdymrpsd3lsuh6ffq6d9vja0s6spkenss\",\
              \   \"value\":{\"lovelace\":14}}}"
        forall a. (HasCallStack, FromJSON a) => LByteString -> Expectation
shouldParseJSONAs @UTxO LByteString
bs

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PParams" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
      String -> (PParams StandardConway -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip JSON encoding" PParams LedgerEra -> Property
PParams StandardConway -> Property
roundtripPParams

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Tx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"JSON encoding of Tx according to schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Tx String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
          Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"schemas" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Transaction"

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"applyTransactions" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"works with valid transaction" Property
appliesValidTransaction
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"works with valid transaction deserialised from JSON" Property
appliesValidTransactionFromJSON

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Generators" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Gen TxIn -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @TxIn" (forall a. Arbitrary a => Gen a
arbitrary @TxIn)
      String -> Gen TxId -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @TxId" (forall a. Arbitrary a => Gen a
arbitrary @TxId)
      String -> Gen (VerificationKey PaymentKey) -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @(VerificationKey PaymentKey)" (forall a. Arbitrary a => Gen a
arbitrary @(VerificationKey PaymentKey))
      String -> Gen (Hash PaymentKey) -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @(Hash PaymentKey)" (forall a. Arbitrary a => Gen a
arbitrary @(Hash PaymentKey))
      String -> Gen UTxO -> Spec
forall (t :: * -> *) a.
(Show (t a), Foldable t, Monoid (t a)) =>
String -> Gen (t a) -> Spec
propDoesNotCollapse String
"genUTxO" Gen UTxO
genUTxO
      String -> Gen UTxO -> Spec
forall (t :: * -> *) a.
(Show (t a), Foldable t, Monoid (t a)) =>
String -> Gen (t a) -> Spec
propDoesNotCollapse String
"genUTxOAdaOnlyOfSize" ((Int -> Gen UTxO) -> Gen UTxO
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen UTxO
genUTxOAdaOnlyOfSize)
      String -> Gen UTxO -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"genUTxOFor" (VerificationKey PaymentKey -> Gen UTxO
genUTxOFor (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
`generateWith` Int
42))
      String -> Gen UTxO -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"genOneUTxOFor" (VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
`generateWith` Int
42))

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genTxOut" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does generate good values" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$
          Gen (TxOut CtxUTxO) -> (TxOut CtxUTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut CtxUTxO)
forall ctx. Gen (TxOut ctx)
genTxOut TxOut CtxUTxO -> Property
propGeneratesGoodTxOut

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genOutput" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has enough lovelace to cover assets" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$
          Gen (TxOut CtxUTxO) -> (TxOut CtxUTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Gen (TxOut CtxUTxO))
-> Gen (TxOut CtxUTxO)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutput) TxOut CtxUTxO -> Property
propHasEnoughLovelace

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genValue" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"produces realistic values" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$
          Gen Value -> (Value -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Value
genValue Value -> Property
propRealisticValue

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genChainPoint" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"generates only some genesis points" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Gen ChainPoint -> (ChainPoint -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ChainPoint
genChainPoint ((ChainPoint -> Property) -> Property)
-> (ChainPoint -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainPoint
cp ->
              Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
80 (ChainPoint
cp ChainPoint -> ChainPoint -> Bool
forall a. Eq a => a -> a -> Bool
/= ChainPoint
ChainPointAtGenesis) String
"not at genesis" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

shouldParseJSONAs :: forall a. (HasCallStack, FromJSON a) => LByteString -> Expectation
shouldParseJSONAs :: forall a. (HasCallStack, FromJSON a) => LByteString -> Expectation
shouldParseJSONAs LByteString
bs =
  case LByteString -> Either String a
forall a. FromJSON a => LByteString -> Either String a
Aeson.eitherDecode LByteString
bs of
    Left String
err -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
err
    Right (a
_ :: a) -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Test that the 'PParams' To/FromJSON instances to roundtrip.
roundtripPParams :: PParams LedgerEra -> Property
roundtripPParams :: PParams LedgerEra -> Property
roundtripPParams PParams LedgerEra
pparams = do
  case LByteString -> Maybe (PParams StandardConway)
forall a. FromJSON a => LByteString -> Maybe a
Aeson.decode (PParams StandardConway -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode PParams LedgerEra
PParams StandardConway
pparams) of
    Maybe (PParams StandardConway)
Nothing ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
    Just PParams StandardConway
actual ->
      PParams LedgerEra
PParams StandardConway
pparams PParams StandardConway -> PParams StandardConway -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PParams StandardConway
actual

appliesValidTransaction :: Property
appliesValidTransaction :: Property
appliesValidTransaction =
  Gen (UTxO, [Tx]) -> ((UTxO, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO, [Tx]) -> Property) -> Property)
-> ((UTxO, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo, [Tx]
txs) ->
    let result :: Either (Tx, ValidationError) (UTxOType Tx)
result = Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions (Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv) (Natural -> ChainSlot
ChainSlot Natural
0) UTxO
UTxOType Tx
utxo [Tx]
txs
     in case Either (Tx, ValidationError) (UTxOType Tx)
result of
          Right UTxOType Tx
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          Left (Tx
tx, ValidationError
err) ->
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ValidationError -> String
forall b a. (Show a, IsString b) => a -> b
show ValidationError
err)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failing tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx Tx
tx)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All txs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [Tx] -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON [Tx]
txs))
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Initial UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ UTxO -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON UTxO
utxo))

appliesValidTransactionFromJSON :: Property
appliesValidTransactionFromJSON :: Property
appliesValidTransactionFromJSON =
  Gen (UTxO, [Tx]) -> ((UTxO, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO, [Tx]) -> Property) -> Property)
-> ((UTxO, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo, [Tx]
txs) ->
    let encoded :: LByteString
encoded = [Tx] -> LByteString
forall a. ToJSON a => a -> LByteString
encode [Tx]
txs
        result :: Either String UTxO
result = LByteString -> Either String [Tx]
forall a. FromJSON a => LByteString -> Either String a
eitherDecode LByteString
encoded Either String [Tx]
-> ([Tx] -> Either String UTxO) -> Either String UTxO
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Tx, ValidationError) -> String)
-> Either (Tx, ValidationError) UTxO -> Either String UTxO
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Tx, ValidationError) -> String
forall b a. (Show a, IsString b) => a -> b
show (Either (Tx, ValidationError) UTxO -> Either String UTxO)
-> ([Tx] -> Either (Tx, ValidationError) UTxO)
-> [Tx]
-> Either String UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions (Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv) (Natural -> ChainSlot
ChainSlot Natural
0) UTxO
UTxOType Tx
utxo
     in Either String UTxO -> Bool
forall a b. Either a b -> Bool
isRight Either String UTxO
result
          Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Result: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either String UTxO -> String
forall b a. (Show a, IsString b) => a -> b
show Either String UTxO
result)
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All txs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [Tx] -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON [Tx]
txs))
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Initial UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ UTxO -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON UTxO
utxo))

propDoesNotCollapse :: (Show (t a), Foldable t, Monoid (t a)) => String -> Gen (t a) -> Spec
propDoesNotCollapse :: forall (t :: * -> *) a.
(Show (t a), Foldable t, Monoid (t a)) =>
String -> Gen (t a) -> Spec
propDoesNotCollapse String
name Gen (t a)
gen =
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not generate collapsing values") (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    Gen [t a] -> ([t a] -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (t a) -> Gen [t a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
100 Gen (t a)
gen) (([t a] -> Property) -> Property)
-> ([t a] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[t a]
xs ->
      [Int] -> Int
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (t a -> Int) -> [t a] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t a]
xs) Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([t a] -> t a
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [t a]
xs)

-- | A transaction or transaction output can usually only contain a realistic
-- number of native asset entries. This property checks a realistic order of
-- magnitude (100).
propRealisticValue :: Value -> Property
propRealisticValue :: Value -> Property
propRealisticValue Value
value =
  Int
numberOfAssets Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100
    Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"too many individual assets: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
numberOfAssets)
 where
  numberOfAssets :: Int
numberOfAssets = [(AssetId, Quantity)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
value)

-- | Check that an output has enough lovelace to cover asset deposits.
propHasEnoughLovelace :: TxOut CtxUTxO -> Property
propHasEnoughLovelace :: TxOut CtxUTxO -> Property
propHasEnoughLovelace TxOut CtxUTxO
txOut =
  PParams StandardConway
-> TxOut StandardConway -> TxOut StandardConway
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams LedgerEra
PParams StandardConway
defaultPParams (TxOut CtxUTxO -> TxOut LedgerEra
forall era.
IsShelleyBasedEra era =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut TxOut CtxUTxO
txOut) TxOut StandardConway -> TxOut StandardConway -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxOut CtxUTxO -> TxOut LedgerEra
forall era.
IsShelleyBasedEra era =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut TxOut CtxUTxO
txOut
    Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"ensureMinCoinTxOut deemed not enough lovelace in txOut"

-- | Check that the given 'TxOut' fulfills several requirements and does not use
-- unsupported features. See 'genTxOut' for rationale.
propGeneratesGoodTxOut :: TxOut CtxUTxO -> Property
propGeneratesGoodTxOut :: TxOut CtxUTxO -> Property
propGeneratesGoodTxOut TxOut CtxUTxO
txOut =
  Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ Property
propNoReferenceScript
      , Property
propNoByronAddress
      , Value -> Property
propRealisticValue (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut)
      , TxOut CtxUTxO -> Property
propHasEnoughLovelace TxOut CtxUTxO
txOut
      ]
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 Bool
hasDatum String
"has datum"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 Bool
isVKOutput String
"is VK output"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 Bool
isScriptOutput String
"is Script output"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
hasOnlyADA String
"has only ADA"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
hasMultiAssets String
"has multiple assets "
 where
  propNoReferenceScript :: Property
propNoReferenceScript =
    TxOut CtxUTxO -> ReferenceScript
forall ctx. TxOut ctx -> ReferenceScript
txOutReferenceScript TxOut CtxUTxO
txOut
      ReferenceScript -> ReferenceScript -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ReferenceScript
ReferenceScriptNone
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"generated reference script"

  propNoByronAddress :: Property
propNoByronAddress = case TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
txOut of
    ByronAddressInEra ByronAddress{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"generated byron address"
    ShelleyAddressInEra ShelleyAddress{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

  hasDatum :: Bool
hasDatum = TxOut CtxUTxO -> TxOutDatum CtxUTxO
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxUTxO
txOut TxOutDatum CtxUTxO -> TxOutDatum CtxUTxO -> Bool
forall a. Eq a => a -> a -> Bool
/= TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
TxOutDatumNone

  hasOnlyADA :: Bool
hasOnlyADA = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(AssetId
an, Quantity
_) -> AssetId
an AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
== AssetId
AdaAssetId) [(AssetId, Quantity)]
[Item Value]
assets

  hasMultiAssets :: Bool
hasMultiAssets = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(AssetId
an, Quantity
_) -> AssetId
an AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetId
AdaAssetId) [(AssetId, Quantity)]
[Item Value]
assets

  assets :: [Item Value]
assets = Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut

  isVKOutput :: Bool
isVKOutput = case TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
txOut of
    ByronAddressInEra ByronAddress{} -> Bool
False
    ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cred StakeReference StandardCrypto
_) ->
      case PaymentCredential StandardCrypto
cred of
        KeyHashObj{} -> Bool
True
        ScriptHashObj{} -> Bool
False

  isScriptOutput :: Bool
isScriptOutput = case TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
txOut of
    ByronAddressInEra ByronAddress{} -> Bool
False
    ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cred StakeReference StandardCrypto
_) ->
      case PaymentCredential StandardCrypto
cred of
        KeyHashObj{} -> Bool
False
        ScriptHashObj{} -> Bool
True