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