{-# LANGUAGE AllowAmbiguousTypes #-}

module Hydra.Ledger.CardanoSpec where

import Cardano.Api.UTxO (fromApi, toApi)
import Hydra.Cardano.Api
import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Binary (decodeFull, serialize')
import Cardano.Ledger.Api (ensureMinCoinTxOut)
import Cardano.Ledger.Core (PParams ())
import Cardano.Ledger.Credential (Credential (..))
import Data.Aeson (eitherDecode, encode)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key)
import Data.ByteString.Base16 qualified as Base16
import Data.Text (unpack)
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Chain.Direct.Fixture (defaultGlobals, defaultLedgerEnv, defaultPParams)
import Hydra.JSONSchema (prop_validateJSONSchema)
import Hydra.Ledger (ChainSlot (ChainSlot), applyTransactions, txId)
import Hydra.Ledger.Cardano (
  cardanoLedger,
  genOneUTxOFor,
  genOutput,
  genSequenceOfSimplePaymentTransactions,
  genTxOut,
  genUTxOAdaOnlyOfSize,
  genUTxOAlonzo,
  genUTxOFor,
  genValue,
 )
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.QuickCheck (Property, checkCoverage, conjoin, counterexample, cover, forAll, forAllBlind, property, sized, vectorOf, withMaxSuccess, (.&&.), (===))
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)
    -- FIXME: Roundtrip instances for all JSON types we depend on

    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
      Proxy UTxO -> 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 @UTxO)

      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 -> (UTxO -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip to and from Api" UTxO -> Property
roundtripFromAndToApi

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ProtocolParameters" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
      String -> (PParams StandardBabbage -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip JSON encoding" PParams (ShelleyLedgerEra Era) -> Property
PParams StandardBabbage -> Property
roundtripProtocolParameters

    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
      Proxy (ReasonablySized Tx) -> 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 @(ReasonablySized Tx))

      String -> (Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Same TxId before/after JSON encoding" Tx -> Property
roundtripTxId

      String -> (Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Same TxId as TxBody after JSON decoding" Tx -> Property
roundtripTxId'

      String -> (Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip to and from Ledger" Tx -> Property
roundtripLedger

      String -> (Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip CBOR encoding" ((Tx -> Property) -> Spec) -> (Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Show a, ToCBOR a, FromCBOR a) => a -> Property
roundtripCBOR @Tx

      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
$
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
5 (Property -> Property) -> Property -> Property
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
"genUTxOAlonzo" Gen UTxO
genUTxOAlonzo
      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

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 ()

roundtripFromAndToApi :: UTxO -> Property
roundtripFromAndToApi :: UTxO -> Property
roundtripFromAndToApi UTxO
utxo =
  UTxO Era -> UTxO
forall era. UTxO era -> UTxO
fromApi (UTxO -> UTxO Era
toApi UTxO
utxo) UTxO -> UTxO -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== UTxO
utxo

-- | Test that the 'ProtocolParameters' To/FromJSON instances to roundtrip. Note
-- that we use the ledger 'PParams' type to generate values, but the cardano-api
-- type 'ProtocolParameters' is used for the serialization.
roundtripProtocolParameters :: PParams LedgerEra -> Property
roundtripProtocolParameters :: PParams (ShelleyLedgerEra Era) -> Property
roundtripProtocolParameters PParams (ShelleyLedgerEra Era)
pparams = do
  case LByteString -> Maybe ProtocolParameters
forall a. FromJSON a => LByteString -> Maybe a
Aeson.decode (ProtocolParameters -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode ProtocolParameters
expected) of
    Maybe ProtocolParameters
Nothing ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
    Just ProtocolParameters
actual ->
      (ProtocolParameters
expected ProtocolParameters -> ProtocolParameters -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ProtocolParameters
actual)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"ledger: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PParams StandardBabbage -> String
forall b a. (Show a, IsString b) => a -> b
show PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
pparams)
 where
  expected :: ProtocolParameters
expected = ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era) -> ProtocolParameters
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> ProtocolParameters
fromLedgerPParams ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra PParams (ShelleyLedgerEra Era)
pparams

roundtripTxId :: Tx -> Property
roundtripTxId :: Tx -> Property
roundtripTxId tx :: Tx
tx@(Tx TxBody
body [KeyWitness]
_) =
  case LByteString -> Maybe Tx
forall a. FromJSON a => LByteString -> Maybe a
Aeson.decode (Tx -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Tx
tx) of
    Maybe Tx
Nothing ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
    Just tx' :: Tx
tx'@(Tx TxBody
body' [KeyWitness]
_) ->
      (Tx
tx Tx -> Tx -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Tx
tx' Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TxBody -> TxId
forall era. TxBody era -> TxId
getTxId TxBody
body TxId -> TxId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxBody -> TxId
forall era. TxBody era -> TxId
getTxId TxBody
body')
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"after:  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' 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
"before: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' Tx
tx))

roundtripTxId' :: Tx -> Property
roundtripTxId' :: Tx -> Property
roundtripTxId' tx :: Tx
tx@(Tx TxBody
body [KeyWitness]
_) =
  case LByteString -> Maybe Tx
forall a. FromJSON a => LByteString -> Maybe a
Aeson.decode (Tx -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Tx
tx) of
    Maybe Tx
Nothing ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
    Just tx' :: Tx
tx'@(Tx TxBody
body' [KeyWitness]
_) ->
      (Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx TxId -> TxId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxBody -> TxId
forall era. TxBody era -> TxId
getTxId TxBody
body' Property -> Bool -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx' TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxBody -> TxId
forall era. TxBody era -> TxId
getTxId TxBody
body)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"after:  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' 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
"before: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' Tx
tx))

roundtripLedger :: Tx -> Property
roundtripLedger :: Tx -> Property
roundtripLedger Tx
tx =
  Tx (ShelleyLedgerEra Era) -> Tx
fromLedgerTx (Tx -> Tx (ShelleyLedgerEra Era)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx) Tx -> Tx -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Tx
tx

roundtripCBOR :: (Eq a, Show a, ToCBOR a, FromCBOR a) => a -> Property
roundtripCBOR :: forall a. (Eq a, Show a, ToCBOR a, FromCBOR a) => a -> Property
roundtripCBOR a
a =
  let encoded :: ByteString
encoded = a -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' a
a
      decoded :: Either DecoderError a
decoded = LByteString -> Either DecoderError a
forall a. FromCBOR a => LByteString -> Either DecoderError a
decodeFull (LByteString -> Either DecoderError a)
-> LByteString -> Either DecoderError a
forall a b. (a -> b) -> a -> b
$ ByteString -> LByteString
forall l s. LazyStrict l s => s -> l
fromStrict ByteString
encoded
   in Either DecoderError a
decoded Either DecoderError a -> Either DecoderError a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Either DecoderError a
forall a b. b -> Either a b
Right a
a
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"encoded: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
encoded String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". decode: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either DecoderError a -> String
forall b a. (Show a, IsString b) => a -> b
show Either DecoderError a
decoded)

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 (ShelleyLedgerEra Era) -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv (ShelleyLedgerEra Era)
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 (ShelleyLedgerEra Era) -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv (ShelleyLedgerEra Era)
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 -> [(AssetId, Quantity)]
valueToList 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 StandardBabbage
-> TxOut StandardBabbage -> TxOut StandardBabbage
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
defaultPParams (TxOut CtxUTxO -> TxOut (ShelleyLedgerEra Era)
toLedgerTxOut TxOut CtxUTxO
txOut) TxOut StandardBabbage -> TxOut StandardBabbage -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxOut CtxUTxO -> 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)]
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)]
assets

  assets :: [(AssetId, Quantity)]
assets = Value -> [(AssetId, Quantity)]
valueToList (Value -> [(AssetId, Quantity)]) -> Value -> [(AssetId, Quantity)]
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