{-# 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
    -- FIXME(AB): This property exists solely because our current multisignature implementation
    -- is just the aggregates of individual (mock) signatures and there is no point in doing some
    -- complicated shuffle logic to verify signatures given we'll end up verifying a single Ed25519
    -- signatures.
    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

--
-- Properties
--

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 =
  -- NOTE: We only generate shelley addressed txouts because they are left out
  -- of the plutus script context in 'txInfoOut'.
  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