1
1
{-# LANGUAGE BangPatterns #-}
2
2
{-# LANGUAGE FlexibleContexts #-}
3
+ {-# LANGUAGE LambdaCase #-}
3
4
{-# LANGUAGE NamedFieldPuns #-}
4
5
{-# LANGUAGE OverloadedStrings #-}
5
6
{-# LANGUAGE TypeApplications #-}
@@ -11,6 +12,10 @@ import Cardano.Ledger.Api.Era
11
12
import Cardano.Ledger.Api.State.Query (queryStakePoolDelegsAndRewards )
12
13
import Cardano.Ledger.BaseTypes
13
14
import Cardano.Ledger.Binary
15
+ import Cardano.Ledger.Conway.Rules (
16
+ ConwayLedgerPredFailure (ConwayUtxowFailure ),
17
+ ConwayUtxowPredFailure (InvalidWitnessesUTXOW ),
18
+ )
14
19
import Cardano.Ledger.Core
15
20
import Cardano.Ledger.Shelley.API.Mempool
16
21
import Cardano.Ledger.Shelley.API.Wallet (getFilteredUTxO , getUTxO )
@@ -21,54 +26,77 @@ import Cardano.Ledger.Shelley.Genesis (
21
26
)
22
27
import Cardano.Ledger.Shelley.LedgerState
23
28
import Cardano.Ledger.State
24
- import Cardano.Ledger.State.UTxO (CurrentEra , readNewEpochState )
29
+ import Cardano.Ledger.State.UTxO (CurrentEra , readHexUTxO , readNewEpochState )
25
30
import Cardano.Ledger.UMap
26
31
import Cardano.Ledger.Val
27
32
import Cardano.Slotting.EpochInfo (fixedEpochInfo )
28
33
import Cardano.Slotting.Time (mkSlotLength )
29
34
import Control.DeepSeq
35
+ import Control.Monad (when )
30
36
import Criterion.Main
31
37
import Data.Aeson
32
- import Data.Bifunctor (first )
38
+ import Data.Bifunctor (bimap , first )
33
39
import Data.ByteString.Base16.Lazy as BSL16
34
40
import Data.ByteString.Lazy (ByteString )
35
41
import Data.Foldable as F
42
+ import Data.List.NonEmpty (NonEmpty ((:|) ))
36
43
import Data.Map.Strict (Map )
37
44
import qualified Data.Map.Strict as Map
38
45
import Data.MapExtras (extractKeys , extractKeysSmallSet )
39
46
import Data.Set (Set )
40
47
import qualified Data.Set as Set
41
- import Lens.Micro ((^.) )
48
+ import GHC.Stack (HasCallStack )
49
+ import Lens.Micro ((&) , (.~) , (^.) )
42
50
import System.Environment (getEnv )
51
+ import System.Exit (die )
43
52
import System.Random.Stateful
44
53
import Test.Cardano.Ledger.Api.State.Query (getFilteredDelegationsAndRewardAccounts )
45
54
import Test.Cardano.Ledger.Core.Arbitrary (uniformSubSet )
46
55
47
56
main :: IO ()
48
57
main = do
49
- let ledgerVarName = " BENCH_LEDGER_STATE_PATH "
50
- genesisVarName = " BENCH_GENESIS_PATH "
51
- ledgerStateFilePath <- getEnv ledgerVarName
58
+ let genesisVarName = " BENCH_GENESIS_PATH "
59
+ utxoVarName = " BENCH_UTXO_PATH "
60
+ ledgerStateVarName = " BENCH_LEDGER_STATE_PATH "
52
61
genesisFilePath <- getEnv genesisVarName
62
+ utxoFilePath <- getEnv utxoVarName
63
+ ledgerStateFilePath <- getEnv ledgerStateVarName
64
+
53
65
genesis <- either error id <$> eitherDecodeFileStrict' genesisFilePath
66
+ putStrLn $ " Importing UTxO from: " ++ show utxoFilePath
67
+ utxo <- readHexUTxO utxoFilePath
68
+ putStrLn " Done importing UTxO"
69
+ putStrLn $ " Importing NewEpochState from: " ++ show ledgerStateFilePath
70
+ es' <- readNewEpochState ledgerStateFilePath
71
+ putStrLn " Done importing NewEpochState"
72
+
73
+ let nesUTxOL = nesEsL . esLStateL . lsUTxOStateL . utxoL
74
+ es = es' & nesUTxOL .~ utxo
75
+ utxoMap = unUTxO utxo
76
+ utxoSize = Map. size utxoMap
77
+ largeKeysNum = 100000
78
+ stdGen = mkStdGen 2022
54
79
55
80
let toMempoolState :: NewEpochState CurrentEra -> MempoolState CurrentEra
56
81
toMempoolState NewEpochState {nesEs = EpochState {esLState}} = esLState
57
82
! globals = mkGlobals genesis
58
83
! slotNo = SlotNo 55733343
84
+ restrictError = \ case
85
+ ApplyTxError (ConwayUtxowFailure (InvalidWitnessesUTXOW [_]) :| [] ) -> ()
86
+ otherErr -> error . show $ otherErr
59
87
applyTx' mempoolEnv mempoolState =
60
- either (error . show ) seqTuple
88
+ -- TODO: revert this to `either (error . show) seqTuple` after tx's are fixed
89
+ bimap restrictError seqTuple
61
90
. applyTx globals mempoolEnv mempoolState
62
- reapplyTx' mempoolEnv mempoolState tx =
63
- case reapplyTx globals mempoolEnv mempoolState tx of
64
- Left err -> error (show err)
65
- Right st -> st
66
- putStrLn $ " Importing NewEpochState from: " ++ show ledgerStateFilePath
67
- es <- readNewEpochState ledgerStateFilePath
68
- putStrLn " Done importing NewEpochState"
69
- let largeKeysNum = 100000
70
- stdGen = mkStdGen 2022
71
- largeKeys <- selectRandomMapKeys 100000 stdGen (unUTxO (getUTxO es))
91
+ reapplyTx' mempoolEnv mempoolState =
92
+ either (error . show ) id
93
+ . reapplyTx globals mempoolEnv mempoolState
94
+
95
+ when (utxoSize < largeKeysNum) $
96
+ die $
97
+ " UTxO size is too small (" <> show utxoSize <> " < " <> show largeKeysNum <> " )"
98
+ largeKeys <- selectRandomMapKeys 100000 stdGen utxoMap
99
+
72
100
defaultMain
73
101
[ env (pure (mkMempoolEnv es slotNo, toMempoolState es)) $ \ ~ (mempoolEnv, mempoolState) ->
74
102
bgroup
@@ -92,22 +120,26 @@ main = do
92
120
bench " Tx2" . whnf (applyTx' mempoolEnv mempoolState)
93
121
, env (pure (extractTx validatedTx3)) $
94
122
bench " Tx3" . whnf (applyTx' mempoolEnv mempoolState)
123
+ , env
124
+ (pure [validatedTx1, validatedTx2, validatedTx3])
125
+ $ bench " Tx1+Tx2+Tx3"
126
+ -- TODO: revert this to `foldl'` without `fmap` after tx's are fixed
127
+ . whnf (F. foldlM (\ ms -> fmap fst . applyTx' mempoolEnv ms . extractTx) mempoolState)
95
128
]
96
- , env (pure (getUTxO es)) $ \ utxo ->
129
+ , env (pure utxo) $ \ utxo' ->
97
130
bgroup
98
131
" UTxO"
99
- [ bench " balance" $ nf balance utxo
100
- , bench " coinBalance" $ nf coinBalance utxo
132
+ [ bench " balance" $ nf balance utxo'
133
+ , bench " coinBalance" $ nf coinBalance utxo'
101
134
, -- We need to filter out all multi-assets to prevent `areAllAdaOnly`
102
135
-- from short circuiting and producing results that are way better
103
136
-- than the worst case
104
- env (pure $ Map. filter (\ txOut -> isAdaOnly (txOut ^. valueTxOutL)) $ unUTxO utxo) $
137
+ env (pure $ Map. filter (\ txOut -> isAdaOnly (txOut ^. valueTxOutL)) $ unUTxO utxo' ) $
105
138
bench " areAllAdaOnly" . nf areAllAdaOnly
106
139
]
107
140
, env (pure es) $ \ newEpochState ->
108
- let utxo = getUTxO es
109
- (_, minTxOut) = Map. findMin $ unUTxO utxo
110
- (_, maxTxOut) = Map. findMax $ unUTxO utxo
141
+ let (_, minTxOut) = Map. findMin utxoMap
142
+ (_, maxTxOut) = Map. findMax utxoMap
111
143
setAddr =
112
144
Set. fromList [minTxOut ^. addrTxOutL, maxTxOut ^. addrTxOutL]
113
145
in bgroup
@@ -137,10 +169,10 @@ main = do
137
169
]
138
170
, bgroup
139
171
" DeleteTxOuts"
140
- [ extractKeysBench (unUTxO (getUTxO es)) largeKeysNum largeKeys
141
- , extractKeysBench (unUTxO (getUTxO es)) 9 (Set. take 9 largeKeys)
142
- , extractKeysBench (unUTxO (getUTxO es)) 5 (Set. take 5 largeKeys)
143
- , extractKeysBench (unUTxO (getUTxO es)) 2 (Set. take 2 largeKeys)
172
+ [ extractKeysBench utxoMap largeKeysNum largeKeys
173
+ , extractKeysBench utxoMap 9 (Set. take 9 largeKeys)
174
+ , extractKeysBench utxoMap 5 (Set. take 5 largeKeys)
175
+ , extractKeysBench utxoMap 2 (Set. take 2 largeKeys)
144
176
]
145
177
]
146
178
@@ -176,10 +208,12 @@ selectRandomMapKeys n gen m = runStateGenT_ gen $ \g ->
176
208
extractKeysNaive :: Ord k => Map k a -> Set. Set k -> (Map k a , Map k a )
177
209
extractKeysNaive sm s = (Map. withoutKeys sm s, Map. restrictKeys sm s)
178
210
179
- decodeTx :: ByteString -> Tx CurrentEra
211
+ decodeTx :: HasCallStack => ByteString -> Tx CurrentEra
180
212
decodeTx hex = either error id $ do
181
213
bsl <- BSL16. decode hex
182
- first show $ decodeFull (eraProtVerHigh @ CurrentEra ) bsl
214
+ tx <- first show $ decodeFull (eraProtVerHigh @ BabbageEra ) bsl
215
+ -- TODO: remove this after the transactions below are updated
216
+ first show $ upgradeTx tx
183
217
184
218
-- | Most basic ada-only transaction:
185
219
--
@@ -235,8 +269,8 @@ validatedTx3 =
235
269
\424643546f6b656e1a006cc9f2021a0002afe90e81581c780648b89ea2f11fa9bbdd67\
236
270
\552db5dd020eda1c9a54142dd9f1b136a10081825820cf2477066091b565f87f044581\
237
271
\7c4df726900b29af3f05d229309afdbf94296d584088444a5845b198a2d255175770be\
238
- \7120c2d3482751b14f06dd41d7ff023eeae6e63933b097c023c1ed19df6a061173c45aa \
239
- \54cceb568ff1886e2716e84e6260df5f6 "
272
+ \7120c2d3482751b14f06dd41d7ff023eeae6e63933b097c023c1ed19df6a061173c45a \
273
+ \a54cceb568ff1886e2716e84e6260df5f6 "
240
274
241
275
mkGlobals :: ShelleyGenesis -> Globals
242
276
mkGlobals genesis =
0 commit comments