{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Hydra.Chain.Direct.ContractSpec where
import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Crypto.Util (SignableRepresentation (getSignableRepresentation))
import Cardano.Ledger.Alonzo.Plutus.TxInfo (TxOutSource (TxOutFromOutput))
import Cardano.Ledger.Babbage.TxInfo (transTxOutV2)
import Cardano.Ledger.BaseTypes qualified as Ledger
import Data.ByteString.Base16 qualified as Base16
import Data.List qualified as List
import Hydra.Cardano.Api (
UTxO,
toLedgerTxOut,
toPlutusTxOut,
)
import Hydra.Cardano.Api.Network (networkIdToNetwork)
import Hydra.Chain.Direct.Contract.Abort (genAbortMutation, healthyAbortTx, propHasCommit, propHasInitial)
import Hydra.Chain.Direct.Contract.Close (genCloseInitialMutation, genCloseMutation, healthyCloseInitialTx, healthyCloseTx)
import Hydra.Chain.Direct.Contract.CollectCom (genCollectComMutation, healthyCollectComTx)
import Hydra.Chain.Direct.Contract.Commit (genCommitMutation, healthyCommitTx)
import Hydra.Chain.Direct.Contract.Contest (genContestMutation, healthyContestTx)
import Hydra.Chain.Direct.Contract.FanOut (genFanoutMutation, healthyFanoutTx)
import Hydra.Chain.Direct.Contract.Init (genInitMutation, healthyInitTx)
import Hydra.Chain.Direct.Contract.Mutation (propMutation, propTransactionEvaluates)
import Hydra.Chain.Direct.Fixture (testNetworkId)
import Hydra.Chain.Direct.Tx (headIdToCurrencySymbol)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head (
verifyPartySignature,
verifySnapshotSignature,
)
import Hydra.Contract.Head qualified as OnChain
import Hydra.Crypto (aggregate, generateSigningKey, sign, toPlutusSignatures)
import Hydra.Ledger (hashUTxO)
import Hydra.Ledger qualified as OffChain
import Hydra.Ledger.Cardano (
Tx,
genUTxOSized,
genUTxOWithSimplifiedAddresses,
shrinkUTxO,
)
import Hydra.Ledger.Simple (SimpleTx)
import Hydra.Party (deriveParty, partyToChain)
import Hydra.Plutus.Orphans ()
import Hydra.Snapshot (Snapshot (..))
import PlutusLedgerApi.V2 (fromBuiltin, toBuiltin)
import Test.QuickCheck (
Property,
conjoin,
counterexample,
forAll,
forAllBlind,
forAllShrink,
property,
shuffle,
(=/=),
(===),
(==>),
)
import Test.QuickCheck.Instances ()
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
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Signature validator" (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
"verifies single signature produced off-chain"
Property
prop_verifyOffChainSignatures
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop
String
"verifies snapshot multi-signature for list of parties and signatures"
Property
prop_verifySnapshotSignatures
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxOut hashing" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
(Int -> Int) -> Spec -> Spec
forall a. (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxSuccess (Int -> Int -> Int
forall a b. a -> b -> a
const Int
20) (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
"OffChain.hashUTxO == OnChain.hashTxOuts (on sorted tx outs)" Property
prop_consistentOnAndOffChainHashOfTxOuts
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"OnChain.hashPreSerializedCommits == OnChain.hashTxOuts (on sorted tx outs)" Property
prop_consistentHashPreSerializedCommits
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does care about ordering of TxOut" Property
prop_hashingCaresAboutOrderingOfTxOuts
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Serializing commits" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"deserializeCommit . serializeCommit === id" Property
prop_serializingCommitRoundtrip
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Init" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyInitTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyInitTx (Tx, UTxO) -> Gen SomeMutation
genInitMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Abort" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
[Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ (Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
HasCallStack => (Tx, UTxO)
healthyAbortTx
, (Tx, UTxO) -> Property
propHasCommit (Tx, UTxO)
HasCallStack => (Tx, UTxO)
healthyAbortTx
, (Tx, UTxO) -> Property
propHasInitial (Tx, UTxO)
HasCallStack => (Tx, UTxO)
healthyAbortTx
]
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
HasCallStack => (Tx, UTxO)
healthyAbortTx (Tx, UTxO) -> Gen SomeMutation
genAbortMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Commit" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyCommitTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyCommitTx (Tx, UTxO) -> Gen SomeMutation
genCommitMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CollectCom" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyCollectComTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyCollectComTx (Tx, UTxO) -> Gen SomeMutation
genCollectComMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Close" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyCloseTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyCloseTx (Tx, UTxO) -> Gen SomeMutation
genCloseMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CloseInitial" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyCloseInitialTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyCloseInitialTx (Tx, UTxO) -> Gen SomeMutation
genCloseInitialMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Contest" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyContestTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyContestTx (Tx, UTxO) -> Gen SomeMutation
genContestMutation
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Fanout" (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
"is healthy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> Property
propTransactionEvaluates (Tx, UTxO)
healthyFanoutTx
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not survive random adversarial mutations" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
(Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx, UTxO)
healthyFanoutTx (Tx, UTxO) -> Gen SomeMutation
genFanoutMutation
prop_serializingCommitRoundtrip :: Property
prop_serializingCommitRoundtrip :: Property
prop_serializingCommitRoundtrip =
Gen (TxIn, TxOut CtxUTxO Era)
-> ((TxIn, TxOut CtxUTxO Era) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> (UTxO -> [(TxIn, TxOut CtxUTxO Era)])
-> UTxO
-> (TxIn, TxOut CtxUTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs (UTxO -> (TxIn, TxOut CtxUTxO Era))
-> Gen UTxO -> Gen (TxIn, TxOut CtxUTxO Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen UTxO
genUTxOSized Int
1) (((TxIn, TxOut CtxUTxO Era) -> Property) -> Property)
-> ((TxIn, TxOut CtxUTxO Era) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TxIn, TxOut CtxUTxO Era)
singleUTxO ->
let serialized :: Maybe Commit
serialized = (TxIn, TxOut CtxUTxO Era) -> Maybe Commit
Commit.serializeCommit (TxIn, TxOut CtxUTxO Era)
singleUTxO
deserialized :: Maybe (TxIn, TxOut CtxUTxO Era)
deserialized = Maybe Commit
serialized Maybe Commit
-> (Commit -> Maybe (TxIn, TxOut CtxUTxO Era))
-> Maybe (TxIn, TxOut CtxUTxO Era)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO Era)
Commit.deserializeCommit (NetworkId -> Network
networkIdToNetwork NetworkId
testNetworkId)
in case Maybe (TxIn, TxOut CtxUTxO Era)
deserialized of
Just (TxIn, TxOut CtxUTxO Era)
actual -> (TxIn, TxOut CtxUTxO Era)
actual (TxIn, TxOut CtxUTxO Era) -> (TxIn, TxOut CtxUTxO Era) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (TxIn, TxOut CtxUTxO Era)
singleUTxO
Maybe (TxIn, TxOut CtxUTxO Era)
Nothing ->
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
"roundtrip returned Nothing"
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Serialized: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Commit -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe Commit
serialized)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Deserialized: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe (TxIn, TxOut CtxUTxO Era) -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe (TxIn, TxOut CtxUTxO Era)
deserialized)
prop_consistentOnAndOffChainHashOfTxOuts :: Property
prop_consistentOnAndOffChainHashOfTxOuts :: Property
prop_consistentOnAndOffChainHashOfTxOuts =
Gen UTxO -> (UTxO -> [UTxO]) -> (UTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen UTxO
genUTxOWithSimplifiedAddresses UTxO -> [UTxO]
shrinkUTxO ((UTxO -> Property) -> Property) -> (UTxO -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo :: UTxO) ->
let plutusTxOuts :: [TxOut]
plutusTxOuts =
[Either (ContextError (BabbageEra StandardCrypto)) TxOut]
-> [TxOut]
forall a b. [Either a b] -> [b]
rights ([Either (ContextError (BabbageEra StandardCrypto)) TxOut]
-> [TxOut])
-> [Either (ContextError (BabbageEra StandardCrypto)) TxOut]
-> [TxOut]
forall a b. (a -> b) -> a -> b
$
(Word64
-> TxOut CtxUTxO Era
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut)
-> [Word64]
-> [TxOut CtxUTxO Era]
-> [Either (ContextError (BabbageEra StandardCrypto)) TxOut]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\Word64
ix TxOut CtxUTxO Era
o -> TxOutSource (EraCrypto (BabbageEra StandardCrypto))
-> TxOut (BabbageEra StandardCrypto)
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut
forall era.
(Inject (BabbageContextError era) (ContextError era),
Value era ~ MaryValue (EraCrypto era), BabbageEraTxOut era) =>
TxOutSource (EraCrypto era)
-> TxOut era -> Either (ContextError era) TxOut
transTxOutV2 (TxIx -> TxOutSource (EraCrypto (BabbageEra StandardCrypto))
forall c. TxIx -> TxOutSource c
TxOutFromOutput (TxIx -> TxOutSource (EraCrypto (BabbageEra StandardCrypto)))
-> TxIx -> TxOutSource (EraCrypto (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ Word64 -> TxIx
Ledger.TxIx Word64
ix) (TxOut (BabbageEra StandardCrypto)
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut)
-> TxOut (BabbageEra StandardCrypto)
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO Era -> TxOut (ShelleyLedgerEra Era)
toLedgerTxOut TxOut CtxUTxO Era
o)
[Word64
0 ..]
[TxOut CtxUTxO Era]
txOuts
txOuts :: [TxOut CtxUTxO Era]
txOuts = ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxOut CtxUTxO Era]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd ([(TxIn, TxOut CtxUTxO Era)] -> [TxOut CtxUTxO Era])
-> ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)])
-> [(TxIn, TxOut CtxUTxO Era)]
-> [TxOut CtxUTxO Era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO Era) -> TxIn)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TxIn, TxOut CtxUTxO Era) -> TxIn
forall a b. (a, b) -> a
fst ([(TxIn, TxOut CtxUTxO Era)] -> [TxOut CtxUTxO Era])
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxOut CtxUTxO Era]
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
utxo
in (forall tx. IsTx tx => UTxOType tx -> ByteString
OffChain.hashUTxO @Tx UTxO
UTxOType Tx
utxo ByteString -> ByteString -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin ([TxOut] -> BuiltinByteString
OnChain.hashTxOuts [TxOut]
plutusTxOuts))
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Plutus: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TxOut] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut]
plutusTxOuts)
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
<> [TxOut CtxUTxO Era] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut CtxUTxO Era]
txOuts)
prop_consistentHashPreSerializedCommits :: Property
prop_consistentHashPreSerializedCommits :: Property
prop_consistentHashPreSerializedCommits =
Gen UTxO -> (UTxO -> [UTxO]) -> (UTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen UTxO
genUTxOWithSimplifiedAddresses UTxO -> [UTxO]
shrinkUTxO ((UTxO -> Property) -> Property) -> (UTxO -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo :: UTxO) ->
let unsortedUTxOPairs :: [(TxIn, TxOut CtxUTxO Era)]
unsortedUTxOPairs = UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
utxo
toFanoutTxOuts :: [TxOut]
toFanoutTxOuts = ((TxIn, TxOut CtxUTxO Era) -> Maybe TxOut)
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HasCallStack => TxOut CtxUTxO Era -> Maybe TxOut
TxOut CtxUTxO Era -> Maybe TxOut
toPlutusTxOut (TxOut CtxUTxO Era -> Maybe TxOut)
-> ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> (TxIn, TxOut CtxUTxO Era)
-> Maybe TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd) ([(TxIn, TxOut CtxUTxO Era)] -> [TxOut])
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxOut]
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut CtxUTxO Era) -> TxIn)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TxIn, TxOut CtxUTxO Era) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, TxOut CtxUTxO Era)]
unsortedUTxOPairs
serializedCommits :: [Commit]
serializedCommits = ((TxIn, TxOut CtxUTxO Era) -> Maybe Commit)
-> [(TxIn, TxOut CtxUTxO Era)] -> [Commit]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIn, TxOut CtxUTxO Era) -> Maybe Commit
Commit.serializeCommit [(TxIn, TxOut CtxUTxO Era)]
unsortedUTxOPairs
hashedCommits :: BuiltinByteString
hashedCommits = [Commit] -> BuiltinByteString
OnChain.hashPreSerializedCommits [Commit]
serializedCommits
hashedTxOuts :: BuiltinByteString
hashedTxOuts = [TxOut] -> BuiltinByteString
OnChain.hashTxOuts [TxOut]
toFanoutTxOuts
in BuiltinByteString
hashedCommits
BuiltinByteString -> BuiltinByteString -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== BuiltinByteString
hashedTxOuts
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Hashed commits: " 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
$ BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin BuiltinByteString
hashedCommits))
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Hashed txOuts: " 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
$ BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin BuiltinByteString
hashedTxOuts))
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Serialized commits: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Commit] -> String
forall b a. (Show a, IsString b) => a -> b
show [Commit]
serializedCommits)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"To fanout txOuts: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TxOut] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut]
toFanoutTxOuts)
prop_hashingCaresAboutOrderingOfTxOuts :: Property
prop_hashingCaresAboutOrderingOfTxOuts :: Property
prop_hashingCaresAboutOrderingOfTxOuts =
Gen UTxO -> (UTxO -> [UTxO]) -> (UTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen UTxO
genUTxOWithSimplifiedAddresses UTxO -> [UTxO]
shrinkUTxO ((UTxO -> Property) -> Property) -> (UTxO -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo :: UTxO) ->
(UTxO -> Int
forall a. UTxO' a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length UTxO
utxo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
let plutusTxOuts :: [TxOut]
plutusTxOuts =
[Either (ContextError (BabbageEra StandardCrypto)) TxOut]
-> [TxOut]
forall a b. [Either a b] -> [b]
rights ([Either (ContextError (BabbageEra StandardCrypto)) TxOut]
-> [TxOut])
-> [Either (ContextError (BabbageEra StandardCrypto)) TxOut]
-> [TxOut]
forall a b. (a -> b) -> a -> b
$
(Word64
-> TxOut CtxUTxO Era
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut)
-> [Word64]
-> [TxOut CtxUTxO Era]
-> [Either (ContextError (BabbageEra StandardCrypto)) TxOut]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\Word64
ix TxOut CtxUTxO Era
o -> TxOutSource (EraCrypto (BabbageEra StandardCrypto))
-> TxOut (BabbageEra StandardCrypto)
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut
forall era.
(Inject (BabbageContextError era) (ContextError era),
Value era ~ MaryValue (EraCrypto era), BabbageEraTxOut era) =>
TxOutSource (EraCrypto era)
-> TxOut era -> Either (ContextError era) TxOut
transTxOutV2 (TxIx -> TxOutSource (EraCrypto (BabbageEra StandardCrypto))
forall c. TxIx -> TxOutSource c
TxOutFromOutput (TxIx -> TxOutSource (EraCrypto (BabbageEra StandardCrypto)))
-> TxIx -> TxOutSource (EraCrypto (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ Word64 -> TxIx
Ledger.TxIx Word64
ix) (TxOut (BabbageEra StandardCrypto)
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut)
-> TxOut (BabbageEra StandardCrypto)
-> Either (ContextError (BabbageEra StandardCrypto)) TxOut
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO Era -> TxOut (ShelleyLedgerEra Era)
toLedgerTxOut TxOut CtxUTxO Era
o)
[Word64
0 ..]
[TxOut CtxUTxO Era]
txOuts
txOuts :: [TxOut CtxUTxO Era]
txOuts = (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxOut CtxUTxO Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
utxo
in Gen [TxOut] -> ([TxOut] -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ([TxOut] -> Gen [TxOut]
forall a. [a] -> Gen [a]
shuffle [TxOut]
plutusTxOuts) (([TxOut] -> Property) -> Property)
-> ([TxOut] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[TxOut]
shuffledTxOuts ->
([TxOut]
shuffledTxOuts [TxOut] -> [TxOut] -> Bool
forall a. Eq a => a -> a -> Bool
/= [TxOut]
plutusTxOuts) Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
let hashed :: BuiltinByteString
hashed = [TxOut] -> BuiltinByteString
OnChain.hashTxOuts [TxOut]
plutusTxOuts
hashShuffled :: BuiltinByteString
hashShuffled = [TxOut] -> BuiltinByteString
OnChain.hashTxOuts [TxOut]
shuffledTxOuts
in (BuiltinByteString
hashed BuiltinByteString -> BuiltinByteString -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=/= BuiltinByteString
hashShuffled)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Plutus: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TxOut] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut]
plutusTxOuts)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Shuffled: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TxOut] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut]
shuffledTxOuts)
prop_verifyOffChainSignatures :: Property
prop_verifyOffChainSignatures :: Property
prop_verifyOffChainSignatures =
Gen (Snapshot SimpleTx)
-> (Snapshot SimpleTx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Snapshot SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary ((Snapshot SimpleTx -> Property) -> Property)
-> (Snapshot SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(snapshot :: Snapshot SimpleTx
snapshot@Snapshot{HeadId
headId :: HeadId
$sel:headId:Snapshot :: forall tx. Snapshot tx -> HeadId
headId, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, UTxOType SimpleTx
utxo :: UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo} :: Snapshot SimpleTx) ->
Gen ByteString -> (ByteString -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary ((ByteString -> Property) -> Property)
-> (ByteString -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ByteString
seed ->
let sk :: SigningKey HydraKey
sk = ByteString -> SigningKey HydraKey
generateSigningKey ByteString
seed
offChainSig :: Signature (Snapshot SimpleTx)
offChainSig = SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot
onChainSig :: BuiltinByteString
onChainSig = [BuiltinByteString] -> BuiltinByteString
forall a. HasCallStack => [a] -> a
List.head ([BuiltinByteString] -> BuiltinByteString)
-> (MultiSignature (Snapshot SimpleTx) -> [BuiltinByteString])
-> MultiSignature (Snapshot SimpleTx)
-> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiSignature (Snapshot SimpleTx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures (MultiSignature (Snapshot SimpleTx) -> BuiltinByteString)
-> MultiSignature (Snapshot SimpleTx) -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall {k} (a :: k). [Signature a] -> MultiSignature a
aggregate [Signature (Snapshot SimpleTx)
offChainSig]
onChainParty :: Party
onChainParty = Party -> Party
partyToChain (Party -> Party) -> Party -> Party
forall a b. (a -> b) -> a -> b
$ SigningKey HydraKey -> Party
deriveParty SigningKey HydraKey
sk
snapshotNumber :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a. Integral a => a -> Integer
toInteger SnapshotNumber
number
utxoHash :: BuiltinByteString
utxoHash = ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> ByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @SimpleTx UTxOType SimpleTx
utxo
in CurrencySymbol
-> Integer
-> BuiltinByteString
-> Party
-> BuiltinByteString
-> Bool
verifyPartySignature (HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId) Integer
snapshotNumber BuiltinByteString
utxoHash Party
onChainParty BuiltinByteString
onChainSig
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"headId: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadId -> String
forall b a. (Show a, IsString b) => a -> b
show HeadId
headId)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"signed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BuiltinByteString -> String
forall b a. (Show a, IsString b) => a -> b
show BuiltinByteString
onChainSig)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"party: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Party -> String
forall b a. (Show a, IsString b) => a -> b
show Party
onChainParty)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show (Snapshot SimpleTx -> ByteString
forall a. SignableRepresentation a => a -> ByteString
getSignableRepresentation Snapshot SimpleTx
snapshot))
prop_verifySnapshotSignatures :: Property
prop_verifySnapshotSignatures :: Property
prop_verifySnapshotSignatures =
Gen (Snapshot SimpleTx)
-> (Snapshot SimpleTx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Snapshot SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary ((Snapshot SimpleTx -> Property) -> Property)
-> (Snapshot SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(snapshot :: Snapshot SimpleTx
snapshot@Snapshot{HeadId
$sel:headId:Snapshot :: forall tx. Snapshot tx -> HeadId
headId :: HeadId
headId, SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number :: SnapshotNumber
number, UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo} :: Snapshot SimpleTx) ->
Gen [SigningKey HydraKey]
-> ([SigningKey HydraKey] -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen [SigningKey HydraKey]
forall a. Arbitrary a => Gen a
arbitrary (([SigningKey HydraKey] -> Bool) -> Property)
-> ([SigningKey HydraKey] -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \[SigningKey HydraKey]
sks ->
let parties :: [Party]
parties = SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party) -> [SigningKey HydraKey] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SigningKey HydraKey]
sks
onChainParties :: [Party]
onChainParties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
signatures :: [BuiltinByteString]
signatures = MultiSignature (Snapshot SimpleTx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures (MultiSignature (Snapshot SimpleTx) -> [BuiltinByteString])
-> MultiSignature (Snapshot SimpleTx) -> [BuiltinByteString]
forall a b. (a -> b) -> a -> b
$ [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall {k} (a :: k). [Signature a] -> MultiSignature a
aggregate [SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot | SigningKey HydraKey
sk <- [SigningKey HydraKey]
sks]
snapshotNumber :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a. Integral a => a -> Integer
toInteger SnapshotNumber
number
utxoHash :: BuiltinByteString
utxoHash = ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> ByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @SimpleTx UTxOType SimpleTx
utxo
in [Party]
-> CurrencySymbol
-> Integer
-> BuiltinByteString
-> [BuiltinByteString]
-> Bool
verifySnapshotSignature [Party]
onChainParties (HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId) Integer
snapshotNumber BuiltinByteString
utxoHash [BuiltinByteString]
signatures