/
TxSpec.hs
197 lines (176 loc) · 8.72 KB
/
TxSpec.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Unit tests for our "hand-rolled" transactions as they are used in the
-- "direct" chain component.
module Hydra.Chain.Direct.TxSpec where
import Hydra.Prelude
import Test.Hydra.Prelude
import Test.Cardano.Ledger.Generic.Updaters hiding (vkey)
import Test.Cardano.Ledger.Generic.Proof
import Cardano.Binary (serialize, serialize')
import Cardano.Ledger.Alonzo (TxOut)
import Cardano.Ledger.Alonzo.Data (Data (Data), hashData)
import Cardano.Ledger.Alonzo.Language (Language (PlutusV1))
import Cardano.Ledger.Alonzo.PParams (PParams, ProtVer (..))
import Cardano.Ledger.Alonzo.Scripts (ExUnits(..))
import Cardano.Ledger.Alonzo.Tools (ScriptFailure, evaluateTransactionExecutionUnits)
import Cardano.Ledger.Alonzo.Tx (ValidatedTx (ValidatedTx, body, wits))
import Cardano.Ledger.Alonzo.TxBody (TxOut (TxOut))
import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr, TxWitness (txdats), unTxDats)
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Era (hashScript)
import Cardano.Ledger.Mary.Value (AssetName, PolicyID, Value (Value))
import qualified Cardano.Ledger.SafeHash as SafeHash
import Cardano.Ledger.Slot (EpochSize (EpochSize))
import Cardano.Ledger.Val (inject)
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import Data.Array (array)
import Data.ByteArray (convert)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Hydra.Chain (HeadParameters (..), PostChainTx (..))
import Hydra.Chain.Direct.Tx (OnChainHeadState (..), abortTx, initTx, observeAbortTx, observeInitTx, plutusScript, scriptAddr, threadToken)
import Hydra.Chain.Direct.Util (Era)
import qualified Hydra.Contract.Commit as Commit
import qualified Hydra.Contract.Initial as Initial
import qualified Hydra.Contract.MockHead as Head
import Hydra.Data.ContestationPeriod (contestationPeriodFromDiffTime)
import Hydra.Data.Party (partyFromVerKey)
import Hydra.Party (vkey)
import Ledger.Value (currencyMPSHash, unAssetClass)
import Plutus.V1.Ledger.Api (PubKeyHash (PubKeyHash), toBuiltin, toBuiltinData, toData)
import qualified Plutus.V1.Ledger.Api as Plutus
import Shelley.Spec.Ledger.API (Coin (Coin), StrictMaybe (SJust), TxId (TxId), TxIn (TxIn), UTxO (UTxO))
import Test.Cardano.Ledger.Alonzo.PlutusScripts (defaultCostModel)
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.QuickCheck (Gen, NonEmptyList (NonEmpty), counterexample, listOf, oneof, (===))
import Test.QuickCheck.Instances ()
maxTxSize :: Int64
maxTxSize = 16384 -- 2 ^ 14, as per current Mainnet
spec :: Spec
spec =
parallel $ do
describe "initTx" $ do
-- NOTE(SN): We are relying in the inclusion of the datum in the "posting
-- tx" in order to 'observeTx'. This test is here to make this a bit more
-- explicit than the above general property.
prop "contains HeadParameters as datums" $ \txIn params ->
let ValidatedTx{wits} = initTx params txIn
dats = txdats wits
HeadParameters{contestationPeriod, parties} = params
onChainPeriod = contestationPeriodFromDiffTime contestationPeriod
onChainParties = map (partyFromVerKey . vkey) parties
datum = Head.Initial onChainPeriod onChainParties
in Map.elems (unTxDats dats) === [Data . toData $ toBuiltinData datum]
prop "updates on-chain state to 'Initial' given state is closed" $ \txIn params ->
let tx@ValidatedTx{body} = initTx params txIn
st = snd $ observeInitTx tx Closed
txin = TxIn (TxId $ SafeHash.hashAnnotated body) 0
in st === Initial{threadOutput = (txin, threadToken, params), initials = []}
describe "abortTx" $ do
-- NOTE(AB): This property fails if the list generated is arbitrarily long
prop "transaction size below limit" $ \txIn params initials ->
let tx = abortTx (txIn, threadToken, params) (take 10 initials)
cbor = serialize tx
len = LBS.length cbor
in counterexample ("Tx: " <> show tx) $
counterexample ("Tx serialized size: " <> show len) $
len < maxTxSize
prop "updates on-chain state to 'Final' given state is Initial" $ \txIn params (NonEmpty initials) ->
let tx = abortTx (txIn, threadToken, params) initials
st = snd $ observeAbortTx tx Initial{threadOutput = (txIn, threadToken, params), initials = initials}
in st === Final
-- TODO(SN): this requires the abortTx to include a redeemer, for a TxIn,
-- spending a Head-validated output
prop "validates against 'head' script in haskell (unlimited budget)" $ \txIn params@HeadParameters{contestationPeriod, parties} (NonEmpty initials) ->
let tx = abortTx (txIn, threadToken, params) initials
-- input governed by head script
-- datum : Initiafl + head parameters
-- redeemer : State
txOut = TxOut headAddress headValue (SJust headDatumHash)
(policyId, _) = first currencyMPSHash (unAssetClass threadToken)
headAddress = scriptAddr $ plutusScript $ Head.validatorScript policyId
headValue = inject (Coin 0)
headDatumHash =
hashData @Era . Data $
toData $
Head.Initial
(contestationPeriodFromDiffTime contestationPeriod)
(map (partyFromVerKey . vkey) parties)
utxo = UTxO $ Map.fromList $ (txIn, txOut) : map toTxOut initials
results = validateTxScriptsUnlimited tx utxo
in 1 + length initials == length (rights $ Map.elems results)
& counterexample ("Evaluation results: " <> show results)
& counterexample ("Tx: " <> show tx)
& counterexample ("Input utxo: " <> show utxo)
toTxOut :: (TxIn StandardCrypto, PubKeyHash) -> (TxIn StandardCrypto, TxOut Era)
toTxOut (txIn, pkh) =
(txIn, TxOut initialAddress initialValue (SJust initialDatumHash))
where
initialAddress = scriptAddr $ plutusScript Initial.validatorScript
initialValue = inject (Coin 0)
initialDatumHash =
hashData @Era $ Data $ toData $ Initial.datum (policyId, dependencies, pkh)
where
(policyId, _) = first currencyMPSHash (unAssetClass threadToken)
headScript = plutusScript (Head.validatorScript policyId)
commitScript = plutusScript Commit.validatorScript
dependencies =
Initial.Dependencies
{ Initial.headScript =
Plutus.ValidatorHash $ convert $ serialize' $ hashScript @Era headScript
, Initial.commitScript =
Plutus.ValidatorHash $ convert $ serialize' $ hashScript @Era commitScript
}
isImplemented :: PostChainTx tx -> OnChainHeadState -> Bool
isImplemented tx st =
case (tx, st) of
(InitTx{}, Closed) -> True
(AbortTx{}, Initial{}) -> True
_ -> False
-- | Evaluate all plutus scripts and return execution budgets of a given
-- transaction (any included budgets are ignored).
validateTxScriptsUnlimited ::
ValidatedTx Era ->
-- | Utxo set used to create context for any tx inputs.
UTxO Era ->
Map RdmrPtr (Either (ScriptFailure StandardCrypto) ExUnits)
validateTxScriptsUnlimited tx utxo =
runIdentity $ evaluateTransactionExecutionUnits pparams tx utxo epochInfo systemStart costmodels
where
-- REVIEW(SN): taken from 'testGlobals'
epochInfo = fixedEpochInfo (EpochSize 100) (mkSlotLength 1)
-- REVIEW(SN): taken from 'testGlobals'
systemStart = SystemStart $ posixSecondsToUTCTime 0
-- NOTE(SN): copied from Test.Cardano.Ledger.Alonzo.Tools as not exported
costmodels = array (PlutusV1, PlutusV1) [(PlutusV1, fromJust defaultCostModel)]
pparams :: PParams Era
pparams =
newPParams
(Alonzo Standard)
[ Costmdls $ Map.singleton PlutusV1 $ fromJust defaultCostModel,
MaxValSize 1000000000,
MaxTxExUnits $ ExUnits 100000000 100000000,
MaxBlockExUnits $ ExUnits 100000000 100000000,
ProtocolVersion $ ProtVer 5 0
]
-- | Extract NFT candidates. any single quantity assets not being ADA is a
-- candidate.
txOutNFT :: TxOut Era -> [(PolicyID StandardCrypto, AssetName)]
txOutNFT (TxOut _ value _) =
mapMaybe findUnitAssets $ Map.toList assets
where
(Value _ assets) = value
findUnitAssets (policy, as) = do
(name, _q) <- find unitQuantity $ Map.toList as
pure (policy, name)
unitQuantity (_name, q) = q == 1
instance Arbitrary OnChainHeadState where
arbitrary = oneof [pure Closed, Initial <$> ((,,) <$> arbitrary <*> pure threadToken <*> arbitrary) <*> listOf initialOutputs]
where
initialOutputs = (,) <$> arbitrary <*> arbitrary
instance Arbitrary PubKeyHash where
arbitrary = PubKeyHash . toBuiltin <$> (arbitrary :: Gen ByteString)