Main.hs (37989B)
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 pp -> 244 unPaymentPreimage pp @?= 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 pp -> 267 unPaymentPreimage pp @?= 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 _ (B5.HTLCOfferedOutput _) -> 419 pure () 420 other -> assertFailure $ 421 "expected RevokeHTLC offered, got " 422 <> show other 423 case B5.uo_type o4 of 424 B5.RevokeHTLC _ (B5.HTLCReceivedOutput _) -> 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 ro1 = B5.RevokedOutput op1 (Satoshi 50000) 604 B5.RevokedToLocal 605 ro2 = B5.RevokedOutput op2 (Satoshi 30000) 606 B5.RevokedToLocal 607 pctx = B5.PenaltyContext 608 { B5.pc_outputs = ro1 :| [ro2] 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 ro = B5.RevokedOutput 627 dummyOutPoint (Satoshi 50000) 628 B5.RevokedToLocal 629 pctx = B5.PenaltyContext 630 { B5.pc_outputs = ro :| [] 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 ro1 = B5.RevokedOutput op1 647 (Satoshi 50000) 648 B5.RevokedToLocal 649 ro2 = B5.RevokedOutput op2 650 (Satoshi 10000) 651 (B5.RevokedHTLC 652 (B5.HTLCOfferedOutput 653 (CltvExpiry 500000))) 654 ro3 = B5.RevokedOutput op3 655 (Satoshi 10000) 656 (B5.RevokedHTLC 657 (B5.HTLCReceivedOutput 658 (CltvExpiry 500000))) 659 pctx = B5.PenaltyContext 660 { B5.pc_outputs = ro1 :| [ro2, ro3] 661 , B5.pc_revocation_key = 662 dummyRevocationPubkey 663 , B5.pc_destination = dummyDestScript 664 , B5.pc_feerate = dummyFeerate 665 } 666 stx <- assertJust "spend_revoked_batch" $ 667 B5.spend_revoked_batch pctx 668 let tx = B5.stx_tx stx 669 length (tx_inputs tx) @?= 3 670 671 , testCase "spend_to_local fee underflow" $ do 672 B5.spend_to_local 673 dummyOutPoint (Satoshi 1) 674 dummyRevocationPubkey dummyDelay 675 dummyLocalDelayedPubkey 676 dummyDestScript dummyFeerate 677 @?= Nothing 678 679 , testCase "spend_revoked_batch fee underflow" $ do 680 let ro = B5.RevokedOutput 681 dummyOutPoint (Satoshi 1) 682 B5.RevokedToLocal 683 pctx = B5.PenaltyContext 684 { B5.pc_outputs = ro :| [] 685 , B5.pc_revocation_key = 686 dummyRevocationPubkey 687 , B5.pc_destination = dummyDestScript 688 , B5.pc_feerate = dummyFeerate 689 } 690 B5.spend_revoked_batch pctx @?= Nothing 691 ] 692 693 -- htlc spend tests --------------------------------------------------- 694 695 htlc_spend_tests :: TestTree 696 htlc_spend_tests = testGroup "HTLC Spend" [ 697 testCase "spend_htlc_timeout produces valid tx" $ do 698 let stx = B5.spend_htlc_timeout 699 dummyHTLCContext dummyKeys 700 tx = B5.stx_tx stx 701 tx_version tx @?= 2 702 length (tx_inputs tx) @?= 1 703 length (tx_outputs tx) @?= 1 704 B5.stx_sighash_type stx @?= SIGHASH_ALL 705 B5.stx_input_value stx 706 @?= msatToSat (MilliSatoshi 1000000) 707 708 , testCase "spend_htlc_success produces valid tx" $ do 709 let ctx = dummyHTLCContext 710 { hc_htlc = dummyReceivedHTLC } 711 stx = B5.spend_htlc_success ctx dummyKeys 712 tx = B5.stx_tx stx 713 tx_version tx @?= 2 714 length (tx_inputs tx) @?= 1 715 B5.stx_sighash_type stx @?= SIGHASH_ALL 716 717 , testCase "spend_htlc_timeout anchors sighash" $ do 718 let ctx = dummyHTLCContext 719 { hc_features = dummyFeaturesAnchors } 720 stx = B5.spend_htlc_timeout ctx dummyKeys 721 B5.stx_sighash_type stx 722 @?= SIGHASH_SINGLE_ANYONECANPAY 723 724 , testCase "spend_htlc_success anchors sighash" $ do 725 let ctx = dummyHTLCContext 726 { hc_htlc = dummyReceivedHTLC 727 , hc_features = dummyFeaturesAnchors 728 } 729 stx = B5.spend_htlc_success ctx dummyKeys 730 B5.stx_sighash_type stx 731 @?= SIGHASH_SINGLE_ANYONECANPAY 732 ] 733 734 -- remote spend tests ------------------------------------------------- 735 736 remote_spend_tests :: TestTree 737 remote_spend_tests = testGroup "Remote Spend" [ 738 testCase "spend_remote_htlc_timeout structure" $ do 739 stx <- assertJust "spend_remote_htlc_timeout" $ 740 B5.spend_remote_htlc_timeout 741 dummyOutPoint (Satoshi 50000) 742 dummyHTLC dummyKeys dummyFeatures 743 dummyDestScript dummyFeerate 744 let tx = B5.stx_tx stx 745 tx_version tx @?= 2 746 length (tx_inputs tx) @?= 1 747 B5.stx_sighash_type stx @?= SIGHASH_ALL 748 B5.stx_input_value stx @?= Satoshi 50000 749 -- locktime should be HTLC CLTV expiry 750 tx_locktime tx @?= 500000 751 752 , testCase "spend_remote_htlc_timeout fee deduction" $ do 753 let value = Satoshi 50000 754 stx <- assertJust "spend_remote_htlc_timeout" $ 755 B5.spend_remote_htlc_timeout 756 dummyOutPoint value dummyHTLC 757 dummyKeys dummyFeatures 758 dummyDestScript dummyFeerate 759 let tx = B5.stx_tx stx 760 outVal = txout_value (head' (tx_outputs tx)) 761 assertBool "output < input" (outVal < 50000) 762 763 , testCase "spend_remote_htlc_preimage structure" $ do 764 stx <- assertJust "spend_remote_htlc_preimage" $ 765 B5.spend_remote_htlc_preimage 766 dummyOutPoint (Satoshi 50000) 767 dummyReceivedHTLC dummyKeys 768 dummyFeatures dummyDestScript dummyFeerate 769 let tx = B5.stx_tx stx 770 tx_version tx @?= 2 771 B5.stx_sighash_type stx @?= SIGHASH_ALL 772 -- locktime should be 0 for preimage claims 773 tx_locktime tx @?= 0 774 775 , testCase "spend_remote_htlc_timeout anchors seq" $ 776 do 777 stx <- assertJust "spend_remote_htlc_timeout" $ 778 B5.spend_remote_htlc_timeout 779 dummyOutPoint (Satoshi 50000) 780 dummyHTLC dummyKeys dummyFeaturesAnchors 781 dummyDestScript dummyFeerate 782 let tx = B5.stx_tx stx 783 inp = head' (tx_inputs tx) 784 txin_sequence inp @?= 1 785 786 , testCase "spend_remote_htlc_timeout no-anchor seq" $ 787 do 788 stx <- assertJust "spend_remote_htlc_timeout" $ 789 B5.spend_remote_htlc_timeout 790 dummyOutPoint (Satoshi 50000) 791 dummyHTLC dummyKeys dummyFeatures 792 dummyDestScript dummyFeerate 793 let tx = B5.stx_tx stx 794 inp = head' (tx_inputs tx) 795 txin_sequence inp @?= 0 796 797 , testCase "spend_remote_htlc_preimage nSequence" $ do 798 stx <- assertJust "spend_remote_htlc_preimage" $ 799 B5.spend_remote_htlc_preimage 800 dummyOutPoint (Satoshi 50000) 801 dummyReceivedHTLC dummyKeys 802 dummyFeatures dummyDestScript dummyFeerate 803 let tx = B5.stx_tx stx 804 inp = head' (tx_inputs tx) 805 txin_sequence inp @?= 0 806 ] 807 808 -- revoked htlc spend tests ------------------------------------------ 809 810 revoked_htlc_spend_tests :: TestTree 811 revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [ 812 testCase "spend_revoked_htlc - offered" $ do 813 case B5.spend_revoked_htlc 814 dummyOutPoint (Satoshi 50000) 815 (B5.HTLCOfferedOutput (CltvExpiry 500000)) 816 dummyRevocationPubkey dummyKeys 817 dummyFeatures dummyPaymentHash 818 dummyDestScript dummyFeerate of 819 Nothing -> assertFailure "expected Just" 820 Just stx -> do 821 let tx = B5.stx_tx stx 822 tx_version tx @?= 2 823 B5.stx_sighash_type stx @?= SIGHASH_ALL 824 let inp = head' (tx_inputs tx) 825 txin_sequence inp @?= 0xFFFFFFFF 826 827 , testCase "spend_revoked_htlc - received" $ do 828 case B5.spend_revoked_htlc 829 dummyOutPoint (Satoshi 50000) 830 (B5.HTLCReceivedOutput 831 (CltvExpiry 500000)) 832 dummyRevocationPubkey dummyKeys 833 dummyFeatures dummyPaymentHash 834 dummyDestScript dummyFeerate of 835 Nothing -> assertFailure "expected Just" 836 Just stx -> do 837 B5.stx_sighash_type stx @?= SIGHASH_ALL 838 let tx = B5.stx_tx stx 839 outVal = txout_value 840 (head' (tx_outputs tx)) 841 assertBool "output < input" 842 (outVal < 50000) 843 844 , testCase "htlcOutputType - valid HTLC types" $ do 845 B5.htlcOutputType 846 (OutputOfferedHTLC (CltvExpiry 500)) 847 @?= Just (B5.HTLCOfferedOutput (CltvExpiry 500)) 848 B5.htlcOutputType 849 (OutputReceivedHTLC (CltvExpiry 600)) 850 @?= Just (B5.HTLCReceivedOutput 851 (CltvExpiry 600)) 852 853 , testCase "htlcOutputType - non-HTLC types" $ do 854 B5.htlcOutputType OutputToLocal @?= Nothing 855 B5.htlcOutputType OutputToRemote @?= Nothing 856 B5.htlcOutputType OutputLocalAnchor @?= Nothing 857 B5.htlcOutputType OutputRemoteAnchor @?= Nothing 858 859 , testCase "spend_revoked_htlc_output structure" $ do 860 stx <- assertJust "spend_revoked_htlc_output" $ 861 B5.spend_revoked_htlc_output 862 dummyOutPoint (Satoshi 50000) 863 dummyRevocationPubkey dummyDelay 864 dummyLocalDelayedPubkey 865 dummyDestScript dummyFeerate 866 let tx = B5.stx_tx stx 867 tx_version tx @?= 2 868 B5.stx_sighash_type stx @?= SIGHASH_ALL 869 let inp = head' (tx_inputs tx) 870 txin_sequence inp @?= 0xFFFFFFFF 871 ] 872 873 -- weight tests ------------------------------------------------------- 874 875 weight_tests :: TestTree 876 weight_tests = testGroup "Weight" [ 877 testCase "penalty input = base + witness" $ do 878 -- to_local: 164 (txinput) + 160 (witness) = 324 879 B5.to_local_penalty_input_weight @?= 880 (164 + B5.to_local_penalty_witness_weight) 881 -- offered: 164 + 243 = 407 882 B5.offered_htlc_penalty_input_weight @?= 883 (164 + B5.offered_htlc_penalty_witness_weight) 884 -- accepted: 164 + 249 = 413 885 B5.accepted_htlc_penalty_input_weight @?= 886 (164 + B5.accepted_htlc_penalty_witness_weight) 887 888 , testCase "max HTLCs in single penalty tx" $ do 889 -- Per spec: (400000 - 324 - 272 - 212 - 2) / 413 890 -- = 399190 / 413 = 966 891 let maxHtlcs = (B5.max_standard_weight 892 - B5.to_local_penalty_input_weight 893 - B5.to_remote_input_weight 894 - B5.penalty_tx_base_weight 895 - 2) `div` 896 B5.accepted_htlc_penalty_input_weight 897 assertBool "can sweep 483 bidirectional HTLCs" 898 (maxHtlcs >= 966) 899 ] 900 901 -- property tests ----------------------------------------------------- 902 903 property_tests :: TestTree 904 property_tests = testGroup "Properties" [ 905 testProperty "spending_fee always non-negative" $ 906 \(NonNegative rate) (NonNegative weight) -> 907 let fee = B5.spending_fee 908 (FeeratePerKw (fromIntegral (rate :: Int))) 909 (fromIntegral (weight :: Int)) 910 in unSatoshi fee >= 0 911 912 , testProperty "spend_to_local fee deduction correct" $ 913 \(Positive val) -> 914 let value = Satoshi 915 (fromIntegral (val :: Int) + 100000) 916 expectedFee = B5.spending_fee 917 (FeeratePerKw 253) 918 (B5.to_local_penalty_input_weight 919 + B5.penalty_tx_base_weight) 920 in case B5.spend_to_local 921 dummyOutPoint value 922 dummyRevocationPubkey dummyDelay 923 dummyLocalDelayedPubkey 924 dummyDestScript (FeeratePerKw 253) of 925 Nothing -> False 926 Just stx -> 927 let tx = B5.stx_tx stx 928 outVal = txout_value 929 (head' (tx_outputs tx)) 930 in Satoshi outVal == 931 Satoshi (unSatoshi value 932 - unSatoshi expectedFee) 933 934 , testProperty "htlc_timed_out monotonic" $ 935 \(NonNegative h1) (NonNegative h2) -> 936 let height1 = fromIntegral (h1 :: Int) 937 height2 = fromIntegral (h2 :: Int) 938 htlc = dummyHTLC 939 { htlc_cltv_expiry = CltvExpiry 1000 } 940 in if height1 <= height2 941 then not (B5.htlc_timed_out height1 htlc) 942 || B5.htlc_timed_out height2 htlc 943 else True 944 945 , testProperty "output + fee = input (spend_to_local)" $ 946 \(Positive val) -> 947 let value = Satoshi 948 (fromIntegral (val :: Int) + 100000) 949 fee = B5.spending_fee (FeeratePerKw 253) 950 (B5.to_local_penalty_input_weight 951 + B5.penalty_tx_base_weight) 952 in case B5.spend_to_local 953 dummyOutPoint value 954 dummyRevocationPubkey dummyDelay 955 dummyLocalDelayedPubkey 956 dummyDestScript (FeeratePerKw 253) of 957 Nothing -> False 958 Just stx -> 959 let tx = B5.stx_tx stx 960 outVal = txout_value 961 (head' (tx_outputs tx)) 962 in outVal + unSatoshi fee == 963 unSatoshi value 964 965 , testProperty "fee monotonic in feerate" $ 966 \(Positive r1) (Positive r2) -> 967 let rate1 = fromIntegral (r1 :: Int) 968 rate2 = fromIntegral (r2 :: Int) 969 w = B5.to_local_penalty_input_weight 970 + B5.penalty_tx_base_weight 971 fee1 = B5.spending_fee 972 (FeeratePerKw rate1) w 973 fee2 = B5.spending_fee 974 (FeeratePerKw rate2) w 975 in if rate1 <= rate2 976 then unSatoshi fee1 <= unSatoshi fee2 977 else unSatoshi fee1 >= unSatoshi fee2 978 979 , testProperty "classify preserves output count" $ 980 \(NonNegative n') -> 981 let n = min (n' :: Int) 10 982 outputs = 983 [ TxOutput (Satoshi 50000) toLocalScript 984 OutputToLocal 985 | _ <- [1..n] ] 986 commitTx = CommitmentTx 987 { ctx_version = 2 988 , ctx_locktime = Locktime 0 989 , ctx_input_outpoint = dummyOutPoint 990 , ctx_input_sequence = Sequence 0 991 , ctx_outputs = outputs 992 , ctx_funding_script = dummyDestScript 993 } 994 outs = B5.classify_local_commit_outputs 995 commitTx dummyKeys dummyDelay 996 dummyFeatures [] 997 in length outs == n 998 999 , testProperty "spend_to_local always version 2" $ 1000 \(Positive val) -> 1001 let value = Satoshi 1002 (fromIntegral (val :: Int) + 100000) 1003 in case B5.spend_to_local 1004 dummyOutPoint value 1005 dummyRevocationPubkey dummyDelay 1006 dummyLocalDelayedPubkey 1007 dummyDestScript (FeeratePerKw 253) of 1008 Nothing -> False 1009 Just stx -> 1010 tx_version (B5.stx_tx stx) == 2 1011 1012 , testProperty "revoked nSequence is 0xFFFFFFFF" $ 1013 \(Positive val) -> 1014 let value = Satoshi 1015 (fromIntegral (val :: Int) + 100000) 1016 in case B5.spend_revoked_to_local 1017 dummyOutPoint value 1018 dummyRevocationPubkey dummyDelay 1019 dummyLocalDelayedPubkey 1020 dummyDestScript (FeeratePerKw 253) of 1021 Nothing -> False 1022 Just stx -> 1023 let inp = head' 1024 (tx_inputs (B5.stx_tx stx)) 1025 in txin_sequence inp == 0xFFFFFFFF 1026 1027 , testProperty "htlcOutputType preserves expiry" $ 1028 \expiry -> 1029 let ce = CltvExpiry expiry 1030 in B5.htlcOutputType (OutputOfferedHTLC ce) 1031 == Just (B5.HTLCOfferedOutput ce) 1032 && 1033 B5.htlcOutputType (OutputReceivedHTLC ce) 1034 == Just (B5.HTLCReceivedOutput ce) 1035 1036 , testProperty "htlcOutputType rejects non-HTLC" $ 1037 property $ 1038 B5.htlcOutputType OutputToLocal == Nothing 1039 && B5.htlcOutputType OutputToRemote == Nothing 1040 && B5.htlcOutputType OutputLocalAnchor == Nothing 1041 && B5.htlcOutputType OutputRemoteAnchor 1042 == Nothing 1043 1044 , testProperty "revoked_output_weight by type" $ 1045 \expiry -> 1046 let ce = CltvExpiry expiry 1047 roLocal = B5.RevokedOutput 1048 dummyOutPoint (Satoshi 1000) 1049 B5.RevokedToLocal 1050 roOffered = B5.RevokedOutput 1051 dummyOutPoint (Satoshi 1000) 1052 (B5.RevokedHTLC 1053 (B5.HTLCOfferedOutput ce)) 1054 roReceived = B5.RevokedOutput 1055 dummyOutPoint (Satoshi 1000) 1056 (B5.RevokedHTLC 1057 (B5.HTLCReceivedOutput ce)) 1058 in B5.revoked_output_weight roLocal 1059 == B5.to_local_penalty_input_weight 1060 && 1061 B5.revoked_output_weight roOffered 1062 == B5.offered_htlc_penalty_input_weight 1063 && 1064 B5.revoked_output_weight roReceived 1065 == B5.accepted_htlc_penalty_input_weight 1066 1067 , testProperty "spend_revoked_batch input count" $ 1068 \(Positive n') -> 1069 let n = min (n' :: Int) 5 1070 ros = [ B5.RevokedOutput 1071 (OutPoint dummyTxId 1072 (fromIntegral i)) 1073 (Satoshi 1000000) 1074 B5.RevokedToLocal 1075 | i <- [0..n-1] ] 1076 in case ros of 1077 [] -> True -- impossible with Positive 1078 (r:rs) -> 1079 let pctx = B5.PenaltyContext 1080 { B5.pc_outputs = r :| rs 1081 , B5.pc_revocation_key = 1082 dummyRevocationPubkey 1083 , B5.pc_destination = 1084 dummyDestScript 1085 , B5.pc_feerate = FeeratePerKw 253 1086 } 1087 in case B5.spend_revoked_batch pctx of 1088 Nothing -> False 1089 Just stx -> 1090 length (tx_inputs (B5.stx_tx stx)) 1091 == n 1092 ] 1093 1094 -- helpers ------------------------------------------------------------ 1095 1096 -- | Total head for NonEmpty. 1097 head' :: NonEmpty a -> a 1098 head' (x :| _) = x 1099 1100 -- | Assert a Maybe is Just, failing with a message otherwise. 1101 assertJust :: String -> Maybe a -> IO a 1102 assertJust msg = maybe (assertFailure msg) pure