Main.hs (17290B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 4 module Main where 5 6 import Control.DeepSeq (NFData(..)) 7 import Criterion.Main 8 import Data.Word (Word64) 9 import qualified Data.ByteString as BS 10 import Lightning.Protocol.BOLT3 11 12 -- NFData instances for benchmarking 13 14 -- Existing instances 15 instance NFData Satoshi where 16 rnf (Satoshi x) = rnf x 17 18 instance NFData MilliSatoshi where 19 rnf (MilliSatoshi x) = rnf x 20 21 instance NFData Pubkey where 22 rnf (Pubkey x) = rnf x 23 24 instance NFData Point where 25 rnf (Point x) = rnf x 26 27 instance NFData PerCommitmentPoint where 28 rnf (PerCommitmentPoint x) = rnf x 29 30 instance NFData RevocationPubkey where 31 rnf (RevocationPubkey x) = rnf x 32 33 instance NFData RevocationBasepoint where 34 rnf (RevocationBasepoint x) = rnf x 35 36 instance NFData ChannelFeatures where 37 rnf (ChannelFeatures x) = rnf x 38 39 instance NFData FeeratePerKw where 40 rnf (FeeratePerKw x) = rnf x 41 42 instance NFData DustLimit where 43 rnf (DustLimit x) = rnf x 44 45 instance NFData PaymentHash where 46 rnf (PaymentHash x) = rnf x 47 48 instance NFData CltvExpiry where 49 rnf (CltvExpiry x) = rnf x 50 51 instance NFData HTLCDirection where 52 rnf HTLCOffered = () 53 rnf HTLCReceived = () 54 55 instance NFData HTLC where 56 rnf (HTLC d a h c) = rnf d `seq` rnf a `seq` rnf h `seq` rnf c 57 58 -- Transaction types 59 instance NFData CommitmentTx where 60 rnf (CommitmentTx v l i s o f) = 61 rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f 62 63 instance NFData HTLCTx where 64 rnf (HTLCTx v l i s ov os) = 65 rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os 66 67 instance NFData ClosingTx where 68 rnf (ClosingTx v l i s o f) = 69 rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f 70 71 -- Output types 72 instance NFData TxOutput where 73 rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t 74 75 instance NFData OutputType where 76 rnf OutputToLocal = () 77 rnf OutputToRemote = () 78 rnf OutputLocalAnchor = () 79 rnf OutputRemoteAnchor = () 80 rnf (OutputOfferedHTLC e) = rnf e 81 rnf (OutputReceivedHTLC e) = rnf e 82 83 -- Primitives 84 instance NFData Script where 85 rnf (Script bs) = rnf bs 86 87 88 instance NFData Sequence where 89 rnf (Sequence x) = rnf x 90 91 instance NFData Locktime where 92 rnf (Locktime x) = rnf x 93 94 instance NFData ToSelfDelay where 95 rnf (ToSelfDelay x) = rnf x 96 97 instance NFData CommitmentNumber where 98 rnf (CommitmentNumber x) = rnf x 99 100 -- Context types 101 instance NFData CommitmentContext where 102 rnf ctx = rnf (cc_funding_outpoint ctx) `seq` 103 rnf (cc_commitment_number ctx) `seq` 104 rnf (cc_htlcs ctx) `seq` 105 rnf (cc_keys ctx) 106 107 instance NFData CommitmentKeys where 108 rnf keys = rnf (ck_revocation_pubkey keys) `seq` 109 rnf (ck_local_delayed keys) `seq` 110 rnf (ck_local_htlc keys) `seq` 111 rnf (ck_remote_htlc keys) 112 113 instance NFData HTLCContext where 114 rnf ctx = rnf (hc_commitment_txid ctx) `seq` 115 rnf (hc_htlc ctx) 116 117 instance NFData ClosingContext where 118 rnf ctx = rnf (clc_funding_outpoint ctx) `seq` 119 rnf (clc_local_amount ctx) `seq` 120 rnf (clc_remote_amount ctx) 121 122 -- Key types 123 instance NFData LocalDelayedPubkey where 124 rnf (LocalDelayedPubkey p) = rnf p 125 126 instance NFData RemoteDelayedPubkey where 127 rnf (RemoteDelayedPubkey p) = rnf p 128 129 instance NFData LocalHtlcPubkey where 130 rnf (LocalHtlcPubkey p) = rnf p 131 132 instance NFData RemoteHtlcPubkey where 133 rnf (RemoteHtlcPubkey p) = rnf p 134 135 instance NFData LocalPubkey where 136 rnf (LocalPubkey p) = rnf p 137 138 instance NFData RemotePubkey where 139 rnf (RemotePubkey p) = rnf p 140 141 instance NFData PaymentBasepoint where 142 rnf (PaymentBasepoint p) = rnf p 143 144 instance NFData DelayedPaymentBasepoint where 145 rnf (DelayedPaymentBasepoint p) = rnf p 146 147 instance NFData HtlcBasepoint where 148 rnf (HtlcBasepoint p) = rnf p 149 150 instance NFData FundingPubkey where 151 rnf (FundingPubkey p) = rnf p 152 153 instance NFData PerCommitmentSecret where 154 rnf (PerCommitmentSecret bs) = rnf bs 155 156 -- Secret storage (SecretStore is a newtype over list) 157 instance NFData SecretStore where 158 rnf store = rnf (derive_old_secret 0 store) 159 160 -- Validation errors 161 instance NFData ValidationError where 162 rnf (InvalidVersion a b) = rnf a `seq` rnf b 163 rnf (InvalidLocktime a) = rnf a 164 rnf (InvalidSequence a) = rnf a 165 rnf InvalidOutputOrdering = () 166 rnf (DustLimitViolation a b c) = rnf a `seq` rnf b `seq` rnf c 167 rnf MissingAnchorOutput = () 168 rnf (InvalidAnchorValue a) = rnf a 169 rnf (InvalidFee a b) = rnf a `seq` rnf b 170 rnf (InvalidHTLCLocktime a b) = rnf a `seq` rnf b 171 rnf (InvalidHTLCSequence a b) = rnf a `seq` rnf b 172 rnf NoOutputs = () 173 rnf (TooManyOutputs a) = rnf a 174 175 main :: IO () 176 main = defaultMain [ 177 bgroup "key derivation" [ 178 bench "derive_pubkey" $ 179 whnf (derive_pubkey basepoint) perCommitmentPoint 180 , bench "derive_revocationpubkey" $ 181 whnf (derive_revocationpubkey revocationBasepoint) perCommitmentPoint 182 ] 183 , bgroup "secret generation" [ 184 bench "generate_from_seed (final node)" $ 185 whnf (generate_from_seed seed) 281474976710655 186 , bench "generate_from_seed (first node)" $ 187 whnf (generate_from_seed seed) 0 188 ] 189 , bgroup "fee calculation" [ 190 bench "commitment_fee (no anchors, 0 htlcs)" $ 191 whnf (commitment_fee feerate noAnchors) 0 192 , bench "commitment_fee (no anchors, 10 htlcs)" $ 193 whnf (commitment_fee feerate noAnchors) 10 194 , bench "commitment_fee (anchors, 10 htlcs)" $ 195 whnf (commitment_fee feerate withAnchors) 10 196 , bench "htlc_timeout_fee" $ 197 whnf (htlc_timeout_fee feerate) noAnchors 198 , bench "htlc_success_fee" $ 199 whnf (htlc_success_fee feerate) noAnchors 200 ] 201 , bgroup "trimming" [ 202 bench "is_trimmed (offered, not trimmed)" $ 203 whnf (is_trimmed dust feerate noAnchors) htlcNotTrimmed 204 , bench "is_trimmed (offered, trimmed)" $ 205 whnf (is_trimmed dust feerate noAnchors) htlcTrimmed 206 , bench "htlc_trim_threshold (offered)" $ 207 whnf (htlc_trim_threshold dust feerate noAnchors) HTLCOffered 208 ] 209 , bgroup "tx building" [ 210 bench "build_commitment_tx (0 htlcs, no anchors)" $ 211 whnf build_commitment_tx (mkCommitmentContext htlcs0 noAnchors) 212 , bench "build_commitment_tx (10 htlcs, no anchors)" $ 213 whnf build_commitment_tx (mkCommitmentContext htlcs10 noAnchors) 214 , bench "build_commitment_tx (100 htlcs, no anchors)" $ 215 whnf build_commitment_tx (mkCommitmentContext htlcs100 noAnchors) 216 , bench "build_commitment_tx (10 htlcs, anchors)" $ 217 whnf build_commitment_tx (mkCommitmentContext htlcs10 withAnchors) 218 , bench "build_htlc_timeout_tx" $ 219 whnf build_htlc_timeout_tx sampleHtlcContext 220 , bench "build_htlc_success_tx" $ 221 whnf build_htlc_success_tx sampleHtlcContext 222 , bench "build_closing_tx" $ 223 whnf build_closing_tx sampleClosingContext 224 ] 225 , bgroup "script generation" [ 226 bench "funding_script" $ 227 whnf (funding_script (FundingPubkey samplePubkey1)) 228 (FundingPubkey samplePubkey2) 229 , bench "to_local_script" $ 230 whnf (to_local_script (RevocationPubkey samplePubkey1) 231 (ToSelfDelay 144)) 232 (LocalDelayedPubkey samplePubkey2) 233 , bench "to_remote_script (no anchors)" $ 234 whnf (to_remote_script (RemotePubkey samplePubkey1)) noAnchors 235 , bench "to_remote_script (anchors)" $ 236 whnf (to_remote_script (RemotePubkey samplePubkey1)) withAnchors 237 , bench "anchor_script" $ 238 whnf anchor_script (FundingPubkey samplePubkey1) 239 , bench "offered_htlc_script" $ 240 whnf (offered_htlc_script (RevocationPubkey samplePubkey1) 241 (RemoteHtlcPubkey samplePubkey2) 242 (LocalHtlcPubkey samplePubkey3) 243 (PaymentHash $ BS.replicate 32 0)) 244 noAnchors 245 , bench "received_htlc_script" $ 246 whnf (received_htlc_script (RevocationPubkey samplePubkey1) 247 (RemoteHtlcPubkey samplePubkey2) 248 (LocalHtlcPubkey samplePubkey3) 249 (PaymentHash $ BS.replicate 32 0) 250 (CltvExpiry 500000)) 251 noAnchors 252 ] 253 , bgroup "serialization" [ 254 env (pure $ build_commitment_tx $ mkCommitmentContext htlcs0 noAnchors) 255 $ \tx -> bench "encode_tx (0 htlcs)" $ whnf encode_tx tx 256 , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors) 257 $ \tx -> bench "encode_tx (10 htlcs)" $ whnf encode_tx tx 258 , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs100 noAnchors) 259 $ \tx -> bench "encode_tx (100 htlcs)" $ whnf encode_tx tx 260 , bench "encode_htlc_tx" $ 261 whnf encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext) 262 , bench "encode_closing_tx" $ 263 whnf encode_closing_tx (build_closing_tx sampleClosingContext) 264 ] 265 , bgroup "parsing" [ 266 env (pure $ encodeTx0 htlcs0 noAnchors) 267 $ \bs -> bench "decode_tx (0 htlcs)" $ whnf decode_tx bs 268 , env (pure $ encodeTx0 htlcs10 noAnchors) 269 $ \bs -> bench "decode_tx (10 htlcs)" $ whnf decode_tx bs 270 , env (pure $ encodeTx0 htlcs100 noAnchors) 271 $ \bs -> bench "decode_tx (100 htlcs)" $ whnf decode_tx bs 272 ] 273 , bgroup "validation" [ 274 env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors) 275 $ \tx -> bench "validate_commitment_tx (valid)" $ 276 whnf (validate_commitment_tx dust noAnchors) tx 277 , env (pure $ build_htlc_timeout_tx sampleHtlcContext) 278 $ \tx -> bench "validate_htlc_tx" $ 279 whnf validate_htlc_tx tx 280 , env (pure $ build_closing_tx sampleClosingContext) 281 $ \tx -> bench "validate_closing_tx" $ 282 whnf validate_closing_tx tx 283 , env (pure $ ctx_outputs $ build_commitment_tx $ 284 mkCommitmentContext htlcs10 noAnchors) 285 $ \outs -> bench "validate_output_ordering" $ 286 whnf validate_output_ordering outs 287 ] 288 , bgroup "secret storage" [ 289 bench "insert_secret (first)" $ 290 whnf (insert_secret (BS.replicate 32 0xFF) 281474976710655) 291 empty_store 292 , env setupFilledStore $ \store -> 293 bench "derive_old_secret (recent)" $ 294 whnf (derive_old_secret 281474976710654) store 295 , env setupFilledStore $ \store -> 296 bench "derive_old_secret (old)" $ 297 whnf (derive_old_secret 281474976710600) store 298 ] 299 , bgroup "output sorting" [ 300 env (pure $ ctx_outputs $ build_commitment_tx $ 301 mkCommitmentContext htlcs10 noAnchors) 302 $ \outs -> bench "sort_outputs (10)" $ nf sort_outputs outs 303 , env (pure $ ctx_outputs $ build_commitment_tx $ 304 mkCommitmentContext htlcs100 noAnchors) 305 $ \outs -> bench "sort_outputs (100)" $ nf sort_outputs outs 306 ] 307 ] 308 where 309 -- Key derivation test data 310 basepoint = Point $ BS.pack 311 [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7, 312 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa, 313 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2] 314 315 perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack 316 [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d, 317 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2, 318 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86] 319 320 revocationBasepoint = RevocationBasepoint $ Point $ BS.pack 321 [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7, 322 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa, 323 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2] 324 325 -- Secret generation test data 326 seed = BS.replicate 32 0xFF 327 328 -- Fee calculation test data 329 feerate = FeeratePerKw 5000 330 noAnchors = ChannelFeatures { cf_option_anchors = False } 331 withAnchors = ChannelFeatures { cf_option_anchors = True } 332 333 -- Trimming test data 334 dust = DustLimit (Satoshi 546) 335 336 htlcNotTrimmed = HTLC 337 { htlc_direction = HTLCOffered 338 , htlc_amount_msat = MilliSatoshi 5000000 339 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 340 , htlc_cltv_expiry = CltvExpiry 500000 341 } 342 343 htlcTrimmed = HTLC 344 { htlc_direction = HTLCOffered 345 , htlc_amount_msat = MilliSatoshi 1000000 346 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 347 , htlc_cltv_expiry = CltvExpiry 500000 348 } 349 350 -- Sample pubkeys 351 samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey 352 samplePubkey1 = Pubkey $ BS.pack 353 [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7, 354 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa, 355 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2] 356 samplePubkey2 = Pubkey $ BS.pack 357 [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d, 358 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2, 359 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86] 360 samplePubkey3 = samplePubkey1 361 362 -- Helper to encode a commitment tx for decode benchmarks 363 encodeTx0 :: [HTLC] -> ChannelFeatures -> BS.ByteString 364 encodeTx0 htlcs features = 365 case encode_tx (build_commitment_tx 366 (mkCommitmentContext htlcs features)) of 367 Nothing -> BS.empty 368 Just bs -> bs 369 370 -- Funding outpoint 371 sampleFundingOutpoint :: OutPoint 372 sampleFundingOutpoint = OutPoint (TxId $ BS.replicate 32 0x01) 0 373 374 -- HTLC lists 375 mkHtlc :: HTLCDirection -> Word64 -> Word64 -> HTLC 376 mkHtlc dir amtMsat expiry = HTLC 377 { htlc_direction = dir 378 , htlc_amount_msat = MilliSatoshi amtMsat 379 , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00) 380 , htlc_cltv_expiry = CltvExpiry (fromIntegral expiry) 381 } 382 383 htlcs0, htlcs10, htlcs100 :: [HTLC] 384 htlcs0 = [] 385 htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived) 386 (5000000 + i * 100000) (500000 + i) 387 | i <- [0..9]] 388 htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived) 389 (5000000 + i * 10000) (500000 + i) 390 | i <- [0..99]] 391 392 -- CommitmentKeys fixture 393 sampleCommitmentKeys :: CommitmentKeys 394 sampleCommitmentKeys = CommitmentKeys 395 { ck_revocation_pubkey = RevocationPubkey samplePubkey1 396 , ck_local_delayed = LocalDelayedPubkey samplePubkey1 397 , ck_local_htlc = LocalHtlcPubkey samplePubkey1 398 , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2 399 , ck_local_payment = LocalPubkey samplePubkey1 400 , ck_remote_payment = RemotePubkey samplePubkey2 401 , ck_local_funding = FundingPubkey samplePubkey1 402 , ck_remote_funding = FundingPubkey samplePubkey2 403 } 404 405 -- CommitmentContext builder 406 mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext 407 mkCommitmentContext htlcs features = CommitmentContext 408 { cc_funding_outpoint = sampleFundingOutpoint 409 , cc_commitment_number = CommitmentNumber 42 410 , cc_local_payment_bp = 411 PaymentBasepoint $ Point $ unPubkey samplePubkey1 412 , cc_remote_payment_bp = 413 PaymentBasepoint $ Point $ unPubkey samplePubkey2 414 , cc_to_self_delay = ToSelfDelay 144 415 , cc_dust_limit = DustLimit (Satoshi 546) 416 , cc_feerate = FeeratePerKw 5000 417 , cc_features = features 418 , cc_is_funder = True 419 , cc_to_local_msat = MilliSatoshi 500000000 420 , cc_to_remote_msat = MilliSatoshi 500000000 421 , cc_htlcs = htlcs 422 , cc_keys = sampleCommitmentKeys 423 } 424 425 -- HTLC context 426 sampleHtlcContext :: HTLCContext 427 sampleHtlcContext = HTLCContext 428 { hc_commitment_txid = TxId $ BS.replicate 32 0x01 429 , hc_output_index = 0 430 , hc_htlc = mkHtlc HTLCOffered 5000000 500000 431 , hc_to_self_delay = ToSelfDelay 144 432 , hc_feerate = FeeratePerKw 5000 433 , hc_features = noAnchors 434 , hc_revocation_pubkey = RevocationPubkey samplePubkey1 435 , hc_local_delayed = LocalDelayedPubkey samplePubkey1 436 } 437 438 -- Closing context 439 sampleClosingContext :: ClosingContext 440 sampleClosingContext = ClosingContext 441 { clc_funding_outpoint = sampleFundingOutpoint 442 , clc_local_amount = Satoshi 500000 443 , clc_remote_amount = Satoshi 500000 444 , clc_local_script = 445 Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x01 446 , clc_remote_script = 447 Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x02 448 , clc_local_dust_limit = DustLimit (Satoshi 546) 449 , clc_remote_dust_limit = DustLimit (Satoshi 546) 450 , clc_fee = Satoshi 1000 451 , clc_is_funder = True 452 , clc_locktime = Locktime 0 453 , clc_funding_script = funding_script (FundingPubkey samplePubkey1) 454 (FundingPubkey samplePubkey2) 455 } 456 457 -- Setup for secret storage benchmarks 458 setupFilledStore :: IO SecretStore 459 setupFilledStore = do 460 let secrets = [(generate_from_seed seed i, i) 461 | i <- [281474976710655, 281474976710654 .. 281474976710600]] 462 pure $! foldl insertOrFail empty_store secrets 463 where 464 insertOrFail store (sec, idx) = 465 case insert_secret sec idx store of 466 Just s -> s 467 Nothing -> store