Main.hs (35325B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 4 module Main where 5 6 import Bitcoin.Prim.Tx (TxOut(..)) 7 import Bitcoin.Prim.Tx.Sighash (SighashType(..)) 8 import qualified Data.ByteString as BS 9 import Data.List.NonEmpty (NonEmpty(..)) 10 import Lightning.Protocol.BOLT3 hiding 11 (txout_value, txout_script) 12 import qualified Lightning.Protocol.BOLT5 as B5 13 import Test.Tasty 14 import Test.Tasty.HUnit 15 import Test.Tasty.QuickCheck 16 17 main :: IO () 18 main = defaultMain $ testGroup "ppad-bolt5" [ 19 types_tests 20 , detect_tests 21 , classify_tests 22 , spend_tests 23 , htlc_spend_tests 24 , remote_spend_tests 25 , revoked_htlc_spend_tests 26 , weight_tests 27 , property_tests 28 ] 29 30 -- test fixtures ------------------------------------------------------ 31 32 -- Dummy 33-byte pubkey 33 dummyPubkeyBytes :: BS.ByteString 34 dummyPubkeyBytes = BS.pack $ 35 0x02 : replicate 32 0x01 36 37 -- Dummy 32-byte hash 38 dummyHash32 :: BS.ByteString 39 dummyHash32 = BS.replicate 32 0xAA 40 41 -- Dummy 32-byte preimage 42 dummyPreimage :: BS.ByteString 43 dummyPreimage = BS.replicate 32 0xBB 44 45 dummyTxId :: TxId 46 dummyTxId = case mkTxId (BS.replicate 32 0x00) of 47 Just tid -> tid 48 Nothing -> error "impossible" 49 50 dummyOutPoint :: OutPoint 51 dummyOutPoint = OutPoint dummyTxId 0 52 53 dummyPubkey :: Pubkey 54 dummyPubkey = case pubkey dummyPubkeyBytes of 55 Just pk -> pk 56 Nothing -> error "impossible" 57 58 dummyRevocationPubkey :: RevocationPubkey 59 dummyRevocationPubkey = RevocationPubkey dummyPubkey 60 61 dummyLocalDelayedPubkey :: LocalDelayedPubkey 62 dummyLocalDelayedPubkey = LocalDelayedPubkey dummyPubkey 63 64 dummyLocalHtlcPubkey :: LocalHtlcPubkey 65 dummyLocalHtlcPubkey = LocalHtlcPubkey dummyPubkey 66 67 dummyRemoteHtlcPubkey :: RemoteHtlcPubkey 68 dummyRemoteHtlcPubkey = RemoteHtlcPubkey dummyPubkey 69 70 dummyFundingPubkey :: FundingPubkey 71 dummyFundingPubkey = FundingPubkey dummyPubkey 72 73 dummyPaymentHash :: PaymentHash 74 dummyPaymentHash = case paymentHash dummyHash32 of 75 Just ph -> ph 76 Nothing -> error "impossible" 77 78 dummyDelay :: ToSelfDelay 79 dummyDelay = ToSelfDelay 144 80 81 dummyFeerate :: FeeratePerKw 82 dummyFeerate = FeeratePerKw 253 83 84 dummyFeatures :: ChannelFeatures 85 dummyFeatures = ChannelFeatures False 86 87 dummyFeaturesAnchors :: ChannelFeatures 88 dummyFeaturesAnchors = ChannelFeatures True 89 90 dummyDestScript :: Script 91 dummyDestScript = Script $ BS.pack 92 [0x00, 0x14] <> BS.replicate 20 0xCC 93 94 dummyKeys :: CommitmentKeys 95 dummyKeys = CommitmentKeys 96 { ck_revocation_pubkey = dummyRevocationPubkey 97 , ck_local_delayed = dummyLocalDelayedPubkey 98 , ck_local_htlc = dummyLocalHtlcPubkey 99 , ck_remote_htlc = dummyRemoteHtlcPubkey 100 , ck_local_payment = LocalPubkey dummyPubkey 101 , ck_remote_payment = RemotePubkey dummyPubkey 102 , ck_local_funding = dummyFundingPubkey 103 , ck_remote_funding = dummyFundingPubkey 104 } 105 106 dummyHTLC :: HTLC 107 dummyHTLC = HTLC 108 { htlc_direction = HTLCOffered 109 , htlc_amount_msat = MilliSatoshi 1000000 110 , htlc_payment_hash = dummyPaymentHash 111 , htlc_cltv_expiry = CltvExpiry 500000 112 } 113 114 dummyReceivedHTLC :: HTLC 115 dummyReceivedHTLC = dummyHTLC 116 { htlc_direction = HTLCReceived } 117 118 dummyHTLCContext :: HTLCContext 119 dummyHTLCContext = HTLCContext 120 { hc_commitment_txid = dummyTxId 121 , hc_output_index = 0 122 , hc_htlc = dummyHTLC 123 , hc_to_self_delay = dummyDelay 124 , hc_feerate = dummyFeerate 125 , hc_features = dummyFeatures 126 , hc_revocation_pubkey = dummyRevocationPubkey 127 , hc_local_delayed = dummyLocalDelayedPubkey 128 } 129 130 -- Script that matches what findHTLC expects for offered 131 offeredScript :: Script 132 offeredScript = to_p2wsh $ offered_htlc_script 133 dummyRevocationPubkey 134 dummyRemoteHtlcPubkey 135 dummyLocalHtlcPubkey 136 dummyPaymentHash 137 dummyFeatures 138 139 -- Script that matches what findHTLC expects for received 140 receivedScript :: Script 141 receivedScript = to_p2wsh $ received_htlc_script 142 dummyRevocationPubkey 143 dummyRemoteHtlcPubkey 144 dummyLocalHtlcPubkey 145 dummyPaymentHash 146 (CltvExpiry 500000) 147 dummyFeatures 148 149 toLocalScript :: Script 150 toLocalScript = to_p2wsh $ to_local_script 151 dummyRevocationPubkey dummyDelay 152 dummyLocalDelayedPubkey 153 154 -- CommitmentTx with to_local + to_remote outputs 155 dummyLocalCommitTx :: CommitmentTx 156 dummyLocalCommitTx = CommitmentTx 157 { ctx_version = 2 158 , ctx_locktime = Locktime 0 159 , ctx_input_outpoint = dummyOutPoint 160 , ctx_input_sequence = Sequence 0 161 , ctx_outputs = 162 [ TxOutput (Satoshi 50000) toLocalScript 163 OutputToLocal 164 , TxOutput (Satoshi 30000) dummyDestScript 165 OutputToRemote 166 ] 167 , ctx_funding_script = dummyDestScript 168 } 169 170 -- CommitmentTx with HTLC outputs 171 dummyLocalCommitWithHTLCs :: CommitmentTx 172 dummyLocalCommitWithHTLCs = CommitmentTx 173 { ctx_version = 2 174 , ctx_locktime = Locktime 0 175 , ctx_input_outpoint = dummyOutPoint 176 , ctx_input_sequence = Sequence 0 177 , ctx_outputs = 178 [ TxOutput (Satoshi 50000) toLocalScript 179 OutputToLocal 180 , TxOutput (Satoshi 30000) dummyDestScript 181 OutputToRemote 182 , TxOutput (Satoshi 10000) offeredScript 183 (OutputOfferedHTLC (CltvExpiry 500000)) 184 , TxOutput (Satoshi 10000) receivedScript 185 (OutputReceivedHTLC (CltvExpiry 500000)) 186 ] 187 , ctx_funding_script = dummyDestScript 188 } 189 190 -- A distinct CommitmentTx (different locktime) 191 dummyRemoteCommitTx :: CommitmentTx 192 dummyRemoteCommitTx = CommitmentTx 193 { ctx_version = 2 194 , ctx_locktime = Locktime 1 195 , ctx_input_outpoint = dummyOutPoint 196 , ctx_input_sequence = Sequence 0 197 , ctx_outputs = 198 [ TxOutput (Satoshi 40000) toLocalScript 199 OutputToLocal 200 , TxOutput (Satoshi 20000) dummyDestScript 201 OutputToRemote 202 ] 203 , ctx_funding_script = dummyDestScript 204 } 205 206 -- types tests -------------------------------------------------------- 207 208 types_tests :: TestTree 209 types_tests = testGroup "Types" [ 210 testCase "CloseType constructors" $ do 211 B5.MutualClose @?= B5.MutualClose 212 B5.LocalCommitClose @?= B5.LocalCommitClose 213 B5.RemoteCommitClose @?= B5.RemoteCommitClose 214 B5.RevokedCommitClose @?= B5.RevokedCommitClose 215 216 , testCase "spending_fee calculation" $ do 217 let fee = B5.spending_fee (FeeratePerKw 1000) 500 218 fee @?= Satoshi 500 219 220 , testCase "spending_fee at low feerate" $ do 221 let fee = B5.spending_fee (FeeratePerKw 253) 324 222 -- 253 * 324 / 1000 = 81.972 -> 81 223 fee @?= Satoshi 81 224 225 , testCase "weight constants" $ do 226 B5.to_local_penalty_witness_weight @?= 160 227 B5.to_local_penalty_input_weight @?= 324 228 B5.offered_htlc_penalty_input_weight @?= 407 229 B5.accepted_htlc_penalty_input_weight @?= 413 230 B5.to_remote_input_weight @?= 272 231 B5.max_standard_weight @?= 400000 232 ] 233 234 -- detect tests ------------------------------------------------------- 235 236 detect_tests :: TestTree 237 detect_tests = testGroup "Detect" [ 238 testCase "extract_preimage_offered - valid" $ do 239 let sig = BS.replicate 72 0x30 240 preimage = dummyPreimage 241 wit = Witness [sig, preimage] 242 case B5.extract_preimage_offered wit of 243 Just (PaymentPreimage bs) -> 244 bs @?= preimage 245 Nothing -> 246 assertFailure "expected preimage" 247 248 , testCase "extract_preimage_offered - wrong length" $ do 249 let sig = BS.replicate 72 0x30 250 badPreimage = BS.replicate 31 0xBB 251 wit = Witness [sig, badPreimage] 252 B5.extract_preimage_offered wit @?= Nothing 253 254 , testCase "extract_preimage_offered - wrong count" $ do 255 let sig = BS.replicate 72 0x30 256 wit = Witness [sig] 257 B5.extract_preimage_offered wit @?= Nothing 258 259 , testCase "extract_preimage_htlc_success - valid" $ do 260 let zero = BS.empty 261 remoteSig = BS.replicate 72 0x30 262 localSig = BS.replicate 72 0x30 263 preimage = dummyPreimage 264 wit = Witness [zero, remoteSig, localSig, preimage] 265 case B5.extract_preimage_htlc_success wit of 266 Just (PaymentPreimage bs) -> 267 bs @?= preimage 268 Nothing -> 269 assertFailure "expected preimage" 270 271 , testCase "extract_preimage_htlc_success - wrong count" $ do 272 let wit = Witness [BS.empty, dummyPreimage] 273 B5.extract_preimage_htlc_success wit @?= Nothing 274 275 , testCase "extract_preimage_htlc_success - wrong length" $ 276 do 277 let zero = BS.empty 278 remoteSig = BS.replicate 72 0x30 279 localSig = BS.replicate 72 0x30 280 badPreimage = BS.replicate 31 0xBB 281 wit = Witness 282 [zero, remoteSig, localSig, badPreimage] 283 B5.extract_preimage_htlc_success wit @?= Nothing 284 285 , testCase "htlc_timed_out - at expiry" $ do 286 let htlc = dummyHTLC 287 { htlc_cltv_expiry = CltvExpiry 500000 } 288 B5.htlc_timed_out 500000 htlc @?= True 289 290 , testCase "htlc_timed_out - past expiry" $ do 291 let htlc = dummyHTLC 292 { htlc_cltv_expiry = CltvExpiry 500000 } 293 B5.htlc_timed_out 500001 htlc @?= True 294 295 , testCase "htlc_timed_out - before expiry" $ do 296 let htlc = dummyHTLC 297 { htlc_cltv_expiry = CltvExpiry 500000 } 298 B5.htlc_timed_out 499999 htlc @?= False 299 ] 300 301 -- classify tests ----------------------------------------------------- 302 303 classify_tests :: TestTree 304 classify_tests = testGroup "Classify" [ 305 testCase "identify_close - local commit" $ do 306 case encode_tx_for_signing dummyLocalCommitTx of 307 Nothing -> assertFailure "encode failed" 308 Just localBytes -> 309 B5.identify_close 310 dummyLocalCommitTx 311 dummyRemoteCommitTx 312 localBytes 313 @?= Just B5.LocalCommitClose 314 315 , testCase "identify_close - remote commit" $ do 316 case encode_tx_for_signing dummyRemoteCommitTx of 317 Nothing -> assertFailure "encode failed" 318 Just remoteBytes -> 319 B5.identify_close 320 dummyLocalCommitTx 321 dummyRemoteCommitTx 322 remoteBytes 323 @?= Just B5.RemoteCommitClose 324 325 , testCase "identify_close - no match" $ do 326 B5.identify_close 327 dummyLocalCommitTx 328 dummyRemoteCommitTx 329 "unknown bytes" 330 @?= Nothing 331 332 , testCase "classify_local - to_local and to_remote" $ do 333 let outs = B5.classify_local_commit_outputs 334 dummyLocalCommitTx dummyKeys 335 dummyDelay dummyFeatures [] 336 length outs @?= 2 337 case outs of 338 [o1, o2] -> do 339 case B5.uo_type o1 of 340 B5.SpendToLocal d rk dk -> do 341 d @?= dummyDelay 342 rk @?= dummyRevocationPubkey 343 dk @?= dummyLocalDelayedPubkey 344 other -> assertFailure $ 345 "expected SpendToLocal, got " <> show other 346 B5.uo_type o2 @?= B5.Resolved 347 _ -> assertFailure "expected 2 outputs" 348 349 , testCase "classify_local - HTLC outputs" $ do 350 let outs = B5.classify_local_commit_outputs 351 dummyLocalCommitWithHTLCs dummyKeys 352 dummyDelay dummyFeatures 353 [dummyHTLC, dummyReceivedHTLC] 354 length outs @?= 4 355 case outs of 356 [_, _, o3, o4] -> do 357 case B5.uo_type o3 of 358 B5.SpendHTLCTimeout _ _ _ -> pure () 359 other -> assertFailure $ 360 "expected SpendHTLCTimeout, got " 361 <> show other 362 case B5.uo_type o4 of 363 B5.SpendHTLCSuccess _ _ _ -> pure () 364 other -> assertFailure $ 365 "expected SpendHTLCSuccess, got " 366 <> show other 367 _ -> assertFailure "expected 4 outputs" 368 369 , testCase "classify_remote - HTLC outputs" $ do 370 let commitTx = CommitmentTx 371 { ctx_version = 2 372 , ctx_locktime = Locktime 0 373 , ctx_input_outpoint = dummyOutPoint 374 , ctx_input_sequence = Sequence 0 375 , ctx_outputs = 376 [ TxOutput (Satoshi 50000) toLocalScript 377 OutputToLocal 378 , TxOutput (Satoshi 10000) offeredScript 379 (OutputOfferedHTLC 380 (CltvExpiry 500000)) 381 , TxOutput (Satoshi 10000) receivedScript 382 (OutputReceivedHTLC 383 (CltvExpiry 500000)) 384 ] 385 , ctx_funding_script = dummyDestScript 386 } 387 outs = B5.classify_remote_commit_outputs 388 commitTx dummyKeys dummyFeatures 389 [dummyHTLC, dummyReceivedHTLC] 390 length outs @?= 3 391 case outs of 392 [o1, o2, o3] -> do 393 B5.uo_type o1 @?= B5.Resolved 394 case B5.uo_type o2 of 395 B5.SpendHTLCPreimageDirect _ -> pure () 396 other -> assertFailure $ 397 "expected SpendHTLCPreimageDirect, got " 398 <> show other 399 case B5.uo_type o3 of 400 B5.SpendHTLCTimeoutDirect _ -> pure () 401 other -> assertFailure $ 402 "expected SpendHTLCTimeoutDirect, got " 403 <> show other 404 _ -> assertFailure "expected 3 outputs" 405 406 , testCase "classify_revoked - to_local revoked" $ do 407 let outs = B5.classify_revoked_commit_outputs 408 dummyLocalCommitWithHTLCs dummyKeys 409 dummyRevocationPubkey dummyFeatures 410 [dummyHTLC, dummyReceivedHTLC] 411 length outs @?= 4 412 case outs of 413 [o1, o2, o3, o4] -> do 414 B5.uo_type o1 415 @?= B5.Revoke dummyRevocationPubkey 416 B5.uo_type o2 @?= B5.Resolved 417 case B5.uo_type o3 of 418 B5.RevokeHTLC _ (OutputOfferedHTLC _) -> 419 pure () 420 other -> assertFailure $ 421 "expected RevokeHTLC offered, got " 422 <> show other 423 case B5.uo_type o4 of 424 B5.RevokeHTLC _ (OutputReceivedHTLC _) -> 425 pure () 426 other -> assertFailure $ 427 "expected RevokeHTLC received, got " 428 <> show other 429 _ -> assertFailure "expected 4 outputs" 430 431 , testCase "classify_local - anchor outputs" $ do 432 let anchorScript = to_p2wsh $ 433 anchor_script dummyFundingPubkey 434 remoteFundPk = ck_remote_funding dummyKeys 435 remoteAnchorScript = to_p2wsh $ 436 anchor_script remoteFundPk 437 commitTx = CommitmentTx 438 { ctx_version = 2 439 , ctx_locktime = Locktime 0 440 , ctx_input_outpoint = dummyOutPoint 441 , ctx_input_sequence = Sequence 0 442 , ctx_outputs = 443 [ TxOutput (Satoshi 330) anchorScript 444 OutputLocalAnchor 445 , TxOutput (Satoshi 330) remoteAnchorScript 446 OutputRemoteAnchor 447 ] 448 , ctx_funding_script = dummyDestScript 449 } 450 outs = B5.classify_local_commit_outputs 451 commitTx dummyKeys dummyDelay 452 dummyFeaturesAnchors [] 453 length outs @?= 2 454 case outs of 455 [o1, o2] -> do 456 case B5.uo_type o1 of 457 B5.AnchorSpend _ -> pure () 458 other -> assertFailure $ 459 "expected AnchorSpend, got " 460 <> show other 461 B5.uo_type o2 @?= B5.Resolved 462 _ -> assertFailure "expected 2 outputs" 463 464 , testCase "classify_remote - non-HTLC outputs" $ do 465 let outs = B5.classify_remote_commit_outputs 466 dummyRemoteCommitTx dummyKeys 467 dummyFeatures [] 468 length outs @?= 2 469 case outs of 470 [o1, o2] -> do 471 B5.uo_type o1 @?= B5.Resolved 472 B5.uo_type o2 @?= B5.Resolved 473 _ -> assertFailure "expected 2 outputs" 474 475 , testCase "classify_local - unmatched HTLC" $ do 476 let outs = B5.classify_local_commit_outputs 477 dummyLocalCommitWithHTLCs dummyKeys 478 dummyDelay dummyFeatures [] 479 -- With no HTLCs passed, HTLC outputs -> Resolved 480 length outs @?= 4 481 case outs of 482 [_, _, o3, o4] -> do 483 B5.uo_type o3 @?= B5.Resolved 484 B5.uo_type o4 @?= B5.Resolved 485 _ -> assertFailure "expected 4 outputs" 486 487 , testCase "classify_local - empty commit" $ do 488 let emptyCommit = CommitmentTx 489 { ctx_version = 2 490 , ctx_locktime = Locktime 0 491 , ctx_input_outpoint = dummyOutPoint 492 , ctx_input_sequence = Sequence 0 493 , ctx_outputs = [] 494 , ctx_funding_script = dummyDestScript 495 } 496 B5.classify_local_commit_outputs 497 emptyCommit dummyKeys dummyDelay 498 dummyFeatures [] 499 @?= [] 500 ] 501 502 -- spend tests -------------------------------------------------------- 503 504 spend_tests :: TestTree 505 spend_tests = testGroup "Spend" [ 506 testCase "spend_to_local produces valid tx" $ do 507 stx <- assertJust "spend_to_local" $ 508 B5.spend_to_local 509 dummyOutPoint 510 (Satoshi 100000) 511 dummyRevocationPubkey 512 dummyDelay 513 dummyLocalDelayedPubkey 514 dummyDestScript 515 dummyFeerate 516 let tx = B5.stx_tx stx 517 -- Version should be 2 518 tx_version tx @?= 2 519 -- Single input 520 length (tx_inputs tx) @?= 1 521 -- Single output 522 length (tx_outputs tx) @?= 1 523 -- Output value should be less than input 524 let outVal = txout_value 525 (head' (tx_outputs tx)) 526 assertBool "output < input" 527 (outVal < 100000) 528 -- Sighash should be ALL 529 B5.stx_sighash_type stx @?= SIGHASH_ALL 530 -- Input value should match 531 B5.stx_input_value stx @?= Satoshi 100000 532 -- nSequence should encode delay 533 let inp = head' (tx_inputs tx) 534 txin_sequence inp @?= fromIntegral 535 (unToSelfDelay dummyDelay) 536 537 , testCase "spend_to_local fee deduction" $ do 538 let value = Satoshi 100000 539 stx <- assertJust "spend_to_local" $ 540 B5.spend_to_local 541 dummyOutPoint value 542 dummyRevocationPubkey dummyDelay 543 dummyLocalDelayedPubkey 544 dummyDestScript dummyFeerate 545 let tx = B5.stx_tx stx 546 outVal = txout_value 547 (head' (tx_outputs tx)) 548 expectedFee = B5.spending_fee dummyFeerate 549 (B5.to_local_penalty_input_weight 550 + B5.penalty_tx_base_weight) 551 Satoshi outVal @?= 552 Satoshi (unSatoshi value 553 - unSatoshi expectedFee) 554 555 , testCase "spend_revoked_to_local nSequence" $ do 556 stx <- assertJust "spend_revoked_to_local" $ 557 B5.spend_revoked_to_local 558 dummyOutPoint (Satoshi 100000) 559 dummyRevocationPubkey dummyDelay 560 dummyLocalDelayedPubkey 561 dummyDestScript dummyFeerate 562 let tx = B5.stx_tx stx 563 inp = head' (tx_inputs tx) 564 txin_sequence inp @?= 0xFFFFFFFF 565 566 , testCase "spend_anchor_owner tx structure" $ do 567 let stx = B5.spend_anchor_owner 568 dummyOutPoint (Satoshi 330) 569 dummyFundingPubkey dummyDestScript 570 tx = B5.stx_tx stx 571 tx_version tx @?= 2 572 tx_locktime tx @?= 0 573 B5.stx_sighash_type stx @?= SIGHASH_ALL 574 575 , testCase "spend_anchor_anyone nSequence" $ do 576 let stx = B5.spend_anchor_anyone 577 dummyOutPoint (Satoshi 330) 578 dummyFundingPubkey dummyDestScript 579 tx = B5.stx_tx stx 580 inp = head' (tx_inputs tx) 581 txin_sequence inp @?= 16 582 583 , testCase "spend_htlc_output is spend_to_local" $ do 584 stx1 <- assertJust "spend_to_local" $ 585 B5.spend_to_local 586 dummyOutPoint (Satoshi 50000) 587 dummyRevocationPubkey dummyDelay 588 dummyLocalDelayedPubkey 589 dummyDestScript dummyFeerate 590 stx2 <- assertJust "spend_htlc_output" $ 591 B5.spend_htlc_output 592 dummyOutPoint (Satoshi 50000) 593 dummyRevocationPubkey dummyDelay 594 dummyLocalDelayedPubkey 595 dummyDestScript dummyFeerate 596 B5.stx_tx stx1 @?= B5.stx_tx stx2 597 B5.stx_input_script stx1 @?= 598 B5.stx_input_script stx2 599 600 , testCase "spend_revoked_batch total value" $ do 601 let op1 = OutPoint dummyTxId 0 602 op2 = OutPoint dummyTxId 1 603 uo1 = B5.UnresolvedOutput op1 (Satoshi 50000) 604 (B5.Revoke dummyRevocationPubkey) 605 uo2 = B5.UnresolvedOutput op2 (Satoshi 30000) 606 (B5.Revoke dummyRevocationPubkey) 607 pctx = B5.PenaltyContext 608 { B5.pc_outputs = uo1 :| [uo2] 609 , B5.pc_revocation_key = 610 dummyRevocationPubkey 611 , B5.pc_destination = dummyDestScript 612 , B5.pc_feerate = dummyFeerate 613 } 614 stx <- assertJust "spend_revoked_batch" $ 615 B5.spend_revoked_batch pctx 616 let tx = B5.stx_tx stx 617 outVal = txout_value 618 (head' (tx_outputs tx)) 619 -- Output should be less than total input 620 assertBool "output < total input" 621 (outVal < 80000) 622 -- Should have 2 inputs 623 length (tx_inputs tx) @?= 2 624 625 , testCase "spend_revoked_batch single element" $ do 626 let uo = B5.UnresolvedOutput 627 dummyOutPoint (Satoshi 50000) 628 (B5.Revoke dummyRevocationPubkey) 629 pctx = B5.PenaltyContext 630 { B5.pc_outputs = uo :| [] 631 , B5.pc_revocation_key = 632 dummyRevocationPubkey 633 , B5.pc_destination = dummyDestScript 634 , B5.pc_feerate = dummyFeerate 635 } 636 stx <- assertJust "spend_revoked_batch" $ 637 B5.spend_revoked_batch pctx 638 let tx = B5.stx_tx stx 639 length (tx_inputs tx) @?= 1 640 length (tx_outputs tx) @?= 1 641 642 , testCase "spend_revoked_batch mixed types" $ do 643 let op1 = OutPoint dummyTxId 0 644 op2 = OutPoint dummyTxId 1 645 op3 = OutPoint dummyTxId 2 646 uo1 = B5.UnresolvedOutput op1 647 (Satoshi 50000) 648 (B5.Revoke dummyRevocationPubkey) 649 uo2 = B5.UnresolvedOutput op2 650 (Satoshi 10000) 651 (B5.RevokeHTLC dummyRevocationPubkey 652 (OutputOfferedHTLC (CltvExpiry 500000))) 653 uo3 = B5.UnresolvedOutput op3 654 (Satoshi 10000) 655 (B5.RevokeHTLC dummyRevocationPubkey 656 (OutputReceivedHTLC (CltvExpiry 500000))) 657 pctx = B5.PenaltyContext 658 { B5.pc_outputs = uo1 :| [uo2, uo3] 659 , B5.pc_revocation_key = 660 dummyRevocationPubkey 661 , B5.pc_destination = dummyDestScript 662 , B5.pc_feerate = dummyFeerate 663 } 664 stx <- assertJust "spend_revoked_batch" $ 665 B5.spend_revoked_batch pctx 666 let tx = B5.stx_tx stx 667 length (tx_inputs tx) @?= 3 668 669 , testCase "spend_to_local fee underflow" $ do 670 B5.spend_to_local 671 dummyOutPoint (Satoshi 1) 672 dummyRevocationPubkey dummyDelay 673 dummyLocalDelayedPubkey 674 dummyDestScript dummyFeerate 675 @?= Nothing 676 677 , testCase "spend_revoked_batch fee underflow" $ do 678 let uo = B5.UnresolvedOutput 679 dummyOutPoint (Satoshi 1) 680 (B5.Revoke dummyRevocationPubkey) 681 pctx = B5.PenaltyContext 682 { B5.pc_outputs = uo :| [] 683 , B5.pc_revocation_key = 684 dummyRevocationPubkey 685 , B5.pc_destination = dummyDestScript 686 , B5.pc_feerate = dummyFeerate 687 } 688 B5.spend_revoked_batch pctx @?= Nothing 689 ] 690 691 -- htlc spend tests --------------------------------------------------- 692 693 htlc_spend_tests :: TestTree 694 htlc_spend_tests = testGroup "HTLC Spend" [ 695 testCase "spend_htlc_timeout produces valid tx" $ do 696 let stx = B5.spend_htlc_timeout 697 dummyHTLCContext dummyKeys 698 tx = B5.stx_tx stx 699 tx_version tx @?= 2 700 length (tx_inputs tx) @?= 1 701 length (tx_outputs tx) @?= 1 702 B5.stx_sighash_type stx @?= SIGHASH_ALL 703 B5.stx_input_value stx 704 @?= msatToSat (MilliSatoshi 1000000) 705 706 , testCase "spend_htlc_success produces valid tx" $ do 707 let ctx = dummyHTLCContext 708 { hc_htlc = dummyReceivedHTLC } 709 stx = B5.spend_htlc_success ctx dummyKeys 710 tx = B5.stx_tx stx 711 tx_version tx @?= 2 712 length (tx_inputs tx) @?= 1 713 B5.stx_sighash_type stx @?= SIGHASH_ALL 714 715 , testCase "spend_htlc_timeout anchors sighash" $ do 716 let ctx = dummyHTLCContext 717 { hc_features = dummyFeaturesAnchors } 718 stx = B5.spend_htlc_timeout ctx dummyKeys 719 B5.stx_sighash_type stx 720 @?= SIGHASH_SINGLE_ANYONECANPAY 721 722 , testCase "spend_htlc_success anchors sighash" $ do 723 let ctx = dummyHTLCContext 724 { hc_htlc = dummyReceivedHTLC 725 , hc_features = dummyFeaturesAnchors 726 } 727 stx = B5.spend_htlc_success ctx dummyKeys 728 B5.stx_sighash_type stx 729 @?= SIGHASH_SINGLE_ANYONECANPAY 730 ] 731 732 -- remote spend tests ------------------------------------------------- 733 734 remote_spend_tests :: TestTree 735 remote_spend_tests = testGroup "Remote Spend" [ 736 testCase "spend_remote_htlc_timeout structure" $ do 737 stx <- assertJust "spend_remote_htlc_timeout" $ 738 B5.spend_remote_htlc_timeout 739 dummyOutPoint (Satoshi 50000) 740 dummyHTLC dummyKeys dummyFeatures 741 dummyDestScript dummyFeerate 742 let tx = B5.stx_tx stx 743 tx_version tx @?= 2 744 length (tx_inputs tx) @?= 1 745 B5.stx_sighash_type stx @?= SIGHASH_ALL 746 B5.stx_input_value stx @?= Satoshi 50000 747 -- locktime should be HTLC CLTV expiry 748 tx_locktime tx @?= 500000 749 750 , testCase "spend_remote_htlc_timeout fee deduction" $ do 751 let value = Satoshi 50000 752 stx <- assertJust "spend_remote_htlc_timeout" $ 753 B5.spend_remote_htlc_timeout 754 dummyOutPoint value dummyHTLC 755 dummyKeys dummyFeatures 756 dummyDestScript dummyFeerate 757 let tx = B5.stx_tx stx 758 outVal = txout_value (head' (tx_outputs tx)) 759 assertBool "output < input" (outVal < 50000) 760 761 , testCase "spend_remote_htlc_preimage structure" $ do 762 stx <- assertJust "spend_remote_htlc_preimage" $ 763 B5.spend_remote_htlc_preimage 764 dummyOutPoint (Satoshi 50000) 765 dummyReceivedHTLC dummyKeys 766 dummyFeatures dummyDestScript dummyFeerate 767 let tx = B5.stx_tx stx 768 tx_version tx @?= 2 769 B5.stx_sighash_type stx @?= SIGHASH_ALL 770 -- locktime should be 0 for preimage claims 771 tx_locktime tx @?= 0 772 773 , testCase "spend_remote_htlc_timeout anchors seq" $ 774 do 775 stx <- assertJust "spend_remote_htlc_timeout" $ 776 B5.spend_remote_htlc_timeout 777 dummyOutPoint (Satoshi 50000) 778 dummyHTLC dummyKeys dummyFeaturesAnchors 779 dummyDestScript dummyFeerate 780 let tx = B5.stx_tx stx 781 inp = head' (tx_inputs tx) 782 txin_sequence inp @?= 1 783 784 , testCase "spend_remote_htlc_timeout no-anchor seq" $ 785 do 786 stx <- assertJust "spend_remote_htlc_timeout" $ 787 B5.spend_remote_htlc_timeout 788 dummyOutPoint (Satoshi 50000) 789 dummyHTLC dummyKeys dummyFeatures 790 dummyDestScript dummyFeerate 791 let tx = B5.stx_tx stx 792 inp = head' (tx_inputs tx) 793 txin_sequence inp @?= 0 794 795 , testCase "spend_remote_htlc_preimage nSequence" $ do 796 stx <- assertJust "spend_remote_htlc_preimage" $ 797 B5.spend_remote_htlc_preimage 798 dummyOutPoint (Satoshi 50000) 799 dummyReceivedHTLC dummyKeys 800 dummyFeatures dummyDestScript dummyFeerate 801 let tx = B5.stx_tx stx 802 inp = head' (tx_inputs tx) 803 txin_sequence inp @?= 0 804 ] 805 806 -- revoked htlc spend tests ------------------------------------------ 807 808 revoked_htlc_spend_tests :: TestTree 809 revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [ 810 testCase "spend_revoked_htlc - offered" $ do 811 case B5.spend_revoked_htlc 812 dummyOutPoint (Satoshi 50000) 813 (OutputOfferedHTLC (CltvExpiry 500000)) 814 dummyRevocationPubkey dummyKeys 815 dummyFeatures dummyPaymentHash 816 dummyDestScript dummyFeerate of 817 Nothing -> assertFailure "expected Just" 818 Just stx -> do 819 let tx = B5.stx_tx stx 820 tx_version tx @?= 2 821 B5.stx_sighash_type stx @?= SIGHASH_ALL 822 let inp = head' (tx_inputs tx) 823 txin_sequence inp @?= 0xFFFFFFFF 824 825 , testCase "spend_revoked_htlc - received" $ do 826 case B5.spend_revoked_htlc 827 dummyOutPoint (Satoshi 50000) 828 (OutputReceivedHTLC (CltvExpiry 500000)) 829 dummyRevocationPubkey dummyKeys 830 dummyFeatures dummyPaymentHash 831 dummyDestScript dummyFeerate of 832 Nothing -> assertFailure "expected Just" 833 Just stx -> do 834 B5.stx_sighash_type stx @?= SIGHASH_ALL 835 let tx = B5.stx_tx stx 836 outVal = txout_value 837 (head' (tx_outputs tx)) 838 assertBool "output < input" 839 (outVal < 50000) 840 841 , testCase "spend_revoked_htlc - invalid type" $ do 842 B5.spend_revoked_htlc 843 dummyOutPoint (Satoshi 50000) 844 OutputToLocal 845 dummyRevocationPubkey dummyKeys 846 dummyFeatures dummyPaymentHash 847 dummyDestScript dummyFeerate 848 @?= Nothing 849 850 , testCase "spend_revoked_htlc_output structure" $ do 851 stx <- assertJust "spend_revoked_htlc_output" $ 852 B5.spend_revoked_htlc_output 853 dummyOutPoint (Satoshi 50000) 854 dummyRevocationPubkey dummyDelay 855 dummyLocalDelayedPubkey 856 dummyDestScript dummyFeerate 857 let tx = B5.stx_tx stx 858 tx_version tx @?= 2 859 B5.stx_sighash_type stx @?= SIGHASH_ALL 860 let inp = head' (tx_inputs tx) 861 txin_sequence inp @?= 0xFFFFFFFF 862 ] 863 864 -- weight tests ------------------------------------------------------- 865 866 weight_tests :: TestTree 867 weight_tests = testGroup "Weight" [ 868 testCase "penalty input = base + witness" $ do 869 -- to_local: 164 (txinput) + 160 (witness) = 324 870 B5.to_local_penalty_input_weight @?= 871 (164 + B5.to_local_penalty_witness_weight) 872 -- offered: 164 + 243 = 407 873 B5.offered_htlc_penalty_input_weight @?= 874 (164 + B5.offered_htlc_penalty_witness_weight) 875 -- accepted: 164 + 249 = 413 876 B5.accepted_htlc_penalty_input_weight @?= 877 (164 + B5.accepted_htlc_penalty_witness_weight) 878 879 , testCase "max HTLCs in single penalty tx" $ do 880 -- Per spec: (400000 - 324 - 272 - 212 - 2) / 413 881 -- = 399190 / 413 = 966 882 let maxHtlcs = (B5.max_standard_weight 883 - B5.to_local_penalty_input_weight 884 - B5.to_remote_input_weight 885 - B5.penalty_tx_base_weight 886 - 2) `div` 887 B5.accepted_htlc_penalty_input_weight 888 assertBool "can sweep 483 bidirectional HTLCs" 889 (maxHtlcs >= 966) 890 ] 891 892 -- property tests ----------------------------------------------------- 893 894 property_tests :: TestTree 895 property_tests = testGroup "Properties" [ 896 testProperty "spending_fee always non-negative" $ 897 \(NonNegative rate) (NonNegative weight) -> 898 let fee = B5.spending_fee 899 (FeeratePerKw (fromIntegral (rate :: Int))) 900 (fromIntegral (weight :: Int)) 901 in unSatoshi fee >= 0 902 903 , testProperty "spend_to_local fee deduction correct" $ 904 \(Positive val) -> 905 let value = Satoshi 906 (fromIntegral (val :: Int) + 100000) 907 expectedFee = B5.spending_fee 908 (FeeratePerKw 253) 909 (B5.to_local_penalty_input_weight 910 + B5.penalty_tx_base_weight) 911 in case B5.spend_to_local 912 dummyOutPoint value 913 dummyRevocationPubkey dummyDelay 914 dummyLocalDelayedPubkey 915 dummyDestScript (FeeratePerKw 253) of 916 Nothing -> False 917 Just stx -> 918 let tx = B5.stx_tx stx 919 outVal = txout_value 920 (head' (tx_outputs tx)) 921 in Satoshi outVal == 922 Satoshi (unSatoshi value 923 - unSatoshi expectedFee) 924 925 , testProperty "htlc_timed_out monotonic" $ 926 \(NonNegative h1) (NonNegative h2) -> 927 let height1 = fromIntegral (h1 :: Int) 928 height2 = fromIntegral (h2 :: Int) 929 htlc = dummyHTLC 930 { htlc_cltv_expiry = CltvExpiry 1000 } 931 in if height1 <= height2 932 then not (B5.htlc_timed_out height1 htlc) 933 || B5.htlc_timed_out height2 htlc 934 else True 935 936 , testProperty "output + fee = input (spend_to_local)" $ 937 \(Positive val) -> 938 let value = Satoshi 939 (fromIntegral (val :: Int) + 100000) 940 fee = B5.spending_fee (FeeratePerKw 253) 941 (B5.to_local_penalty_input_weight 942 + B5.penalty_tx_base_weight) 943 in case B5.spend_to_local 944 dummyOutPoint value 945 dummyRevocationPubkey dummyDelay 946 dummyLocalDelayedPubkey 947 dummyDestScript (FeeratePerKw 253) of 948 Nothing -> False 949 Just stx -> 950 let tx = B5.stx_tx stx 951 outVal = txout_value 952 (head' (tx_outputs tx)) 953 in outVal + unSatoshi fee == 954 unSatoshi value 955 956 , testProperty "fee monotonic in feerate" $ 957 \(Positive r1) (Positive r2) -> 958 let rate1 = fromIntegral (r1 :: Int) 959 rate2 = fromIntegral (r2 :: Int) 960 w = B5.to_local_penalty_input_weight 961 + B5.penalty_tx_base_weight 962 fee1 = B5.spending_fee 963 (FeeratePerKw rate1) w 964 fee2 = B5.spending_fee 965 (FeeratePerKw rate2) w 966 in if rate1 <= rate2 967 then unSatoshi fee1 <= unSatoshi fee2 968 else unSatoshi fee1 >= unSatoshi fee2 969 970 , testProperty "classify preserves output count" $ 971 \(NonNegative n') -> 972 let n = min (n' :: Int) 10 973 outputs = 974 [ TxOutput (Satoshi 50000) toLocalScript 975 OutputToLocal 976 | _ <- [1..n] ] 977 commitTx = CommitmentTx 978 { ctx_version = 2 979 , ctx_locktime = Locktime 0 980 , ctx_input_outpoint = dummyOutPoint 981 , ctx_input_sequence = Sequence 0 982 , ctx_outputs = outputs 983 , ctx_funding_script = dummyDestScript 984 } 985 outs = B5.classify_local_commit_outputs 986 commitTx dummyKeys dummyDelay 987 dummyFeatures [] 988 in length outs == n 989 990 , testProperty "spend_to_local always version 2" $ 991 \(Positive val) -> 992 let value = Satoshi 993 (fromIntegral (val :: Int) + 100000) 994 in case B5.spend_to_local 995 dummyOutPoint value 996 dummyRevocationPubkey dummyDelay 997 dummyLocalDelayedPubkey 998 dummyDestScript (FeeratePerKw 253) of 999 Nothing -> False 1000 Just stx -> 1001 tx_version (B5.stx_tx stx) == 2 1002 1003 , testProperty "revoked nSequence is 0xFFFFFFFF" $ 1004 \(Positive val) -> 1005 let value = Satoshi 1006 (fromIntegral (val :: Int) + 100000) 1007 in case B5.spend_revoked_to_local 1008 dummyOutPoint value 1009 dummyRevocationPubkey dummyDelay 1010 dummyLocalDelayedPubkey 1011 dummyDestScript (FeeratePerKw 253) of 1012 Nothing -> False 1013 Just stx -> 1014 let inp = head' 1015 (tx_inputs (B5.stx_tx stx)) 1016 in txin_sequence inp == 0xFFFFFFFF 1017 ] 1018 1019 -- helpers ------------------------------------------------------------ 1020 1021 -- | Total head for NonEmpty. 1022 head' :: NonEmpty a -> a 1023 head' (x :| _) = x 1024 1025 -- | Assert a Maybe is Just, failing with a message otherwise. 1026 assertJust :: String -> Maybe a -> IO a 1027 assertJust msg = maybe (assertFailure msg) pure