Tx.hs (23091B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DeriveGeneric #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT3.Tx 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Transaction assembly for BOLT #3. 12 -- 13 -- Constructs: 14 -- 15 -- * Commitment transactions 16 -- * HTLC-timeout transactions 17 -- * HTLC-success transactions 18 -- * Closing transactions 19 20 module Lightning.Protocol.BOLT3.Tx ( 21 -- * Commitment transaction 22 CommitmentTx(..) 23 , CommitmentContext(..) 24 , CommitmentKeys(..) 25 , build_commitment_tx 26 27 -- * HTLC transactions 28 , HTLCTx(..) 29 , HTLCContext(..) 30 , build_htlc_timeout_tx 31 , build_htlc_success_tx 32 33 -- * Closing transaction 34 , ClosingTx(..) 35 , ClosingContext(..) 36 , build_closing_tx 37 , build_legacy_closing_tx 38 39 -- * Conversion to ppad-tx 40 , commitment_to_tx 41 , htlc_to_tx 42 , closing_to_tx 43 44 -- * Transaction outputs 45 , TxOutput(..) 46 , OutputType(..) 47 48 -- * Fee calculation 49 , commitment_fee 50 , htlc_timeout_fee 51 , htlc_success_fee 52 , commitment_weight 53 54 -- * Trimming 55 , is_trimmed 56 , trimmed_htlcs 57 , untrimmed_htlcs 58 , htlc_trim_threshold 59 60 -- * Output ordering 61 , sort_outputs 62 ) where 63 64 import qualified Bitcoin.Prim.Tx as BT 65 import Data.Bits ((.&.), (.|.), shiftL, shiftR) 66 import qualified Data.ByteString as BS 67 import Data.List (sortBy) 68 import Data.List.NonEmpty (NonEmpty(..), nonEmpty) 69 import Data.Word (Word32, Word64) 70 import GHC.Generics (Generic) 71 import Lightning.Protocol.BOLT3.Keys 72 import Lightning.Protocol.BOLT3.Scripts 73 import Lightning.Protocol.BOLT3.Types 74 75 -- transaction outputs --------------------------------------------------------- 76 77 -- | Type of output in a commitment transaction. 78 data OutputType 79 = OutputToLocal 80 | OutputToRemote 81 | OutputLocalAnchor 82 | OutputRemoteAnchor 83 | OutputOfferedHTLC {-# UNPACK #-} !CltvExpiry 84 | OutputReceivedHTLC {-# UNPACK #-} !CltvExpiry 85 deriving (Eq, Show, Generic) 86 87 -- | A transaction output with value, script, and type information. 88 data TxOutput = TxOutput 89 { txout_value :: {-# UNPACK #-} !Satoshi 90 , txout_script :: !Script 91 , txout_type :: !OutputType 92 } deriving (Eq, Show, Generic) 93 94 -- commitment transaction ------------------------------------------------------ 95 96 -- | Derived keys needed for commitment transaction outputs. 97 data CommitmentKeys = CommitmentKeys 98 { ck_revocation_pubkey :: !RevocationPubkey 99 , ck_local_delayed :: !LocalDelayedPubkey 100 , ck_local_htlc :: !LocalHtlcPubkey 101 , ck_remote_htlc :: !RemoteHtlcPubkey 102 , ck_local_payment :: !LocalPubkey 103 , ck_remote_payment :: !RemotePubkey 104 , ck_local_funding :: !FundingPubkey 105 , ck_remote_funding :: !FundingPubkey 106 } deriving (Eq, Show, Generic) 107 108 -- | Context for building a commitment transaction. 109 data CommitmentContext = CommitmentContext 110 { cc_funding_outpoint :: !OutPoint 111 , cc_commitment_number :: !CommitmentNumber 112 , cc_local_payment_bp :: !PaymentBasepoint 113 , cc_remote_payment_bp :: !PaymentBasepoint 114 , cc_to_self_delay :: !ToSelfDelay 115 , cc_dust_limit :: !DustLimit 116 , cc_feerate :: !FeeratePerKw 117 , cc_features :: !ChannelFeatures 118 , cc_is_funder :: !Bool 119 , cc_to_local_msat :: !MilliSatoshi 120 , cc_to_remote_msat :: !MilliSatoshi 121 , cc_htlcs :: ![HTLC] 122 , cc_keys :: !CommitmentKeys 123 } deriving (Eq, Show, Generic) 124 125 -- | A commitment transaction. 126 data CommitmentTx = CommitmentTx 127 { ctx_version :: {-# UNPACK #-} !Word32 128 , ctx_locktime :: !Locktime 129 , ctx_input_outpoint :: !OutPoint 130 , ctx_input_sequence :: !Sequence 131 , ctx_outputs :: ![TxOutput] 132 , ctx_funding_script :: !Script 133 } deriving (Eq, Show, Generic) 134 135 -- | Build a commitment transaction. 136 -- 137 -- Follows the algorithm from BOLT #3: 138 -- 139 -- 1. Initialize input and locktime with obscured commitment number 140 -- 2. Calculate which HTLCs are trimmed 141 -- 3. Calculate base fee and subtract from funder 142 -- 4. Add untrimmed HTLC outputs 143 -- 5. Add to_local output if above dust 144 -- 6. Add to_remote output if above dust 145 -- 7. Add anchor outputs if option_anchors 146 -- 8. Sort outputs per BIP69+CLTV 147 build_commitment_tx :: CommitmentContext -> CommitmentTx 148 build_commitment_tx ctx = 149 let !obscured = obscured_commitment_number 150 (cc_local_payment_bp ctx) 151 (cc_remote_payment_bp ctx) 152 (cc_commitment_number ctx) 153 154 -- Locktime: upper 8 bits are 0x20, lower 24 bits are lower 24 of obscured 155 !locktime = Locktime $ 156 (0x20 `shiftL` 24) .|. (fromIntegral obscured .&. 0x00FFFFFF) 157 158 -- Sequence: upper 8 bits are 0x80, lower 24 bits are upper 24 of obscured 159 !inputSeq = Sequence $ 160 (0x80 `shiftL` 24) .|. 161 (fromIntegral (obscured `shiftR` 24) .&. 0x00FFFFFF) 162 163 -- Funding script for witness 164 !fundingScript = funding_script 165 (ck_local_funding $ cc_keys ctx) 166 (ck_remote_funding $ cc_keys ctx) 167 168 -- Calculate untrimmed HTLCs 169 !untrimmedHtlcs = untrimmed_htlcs 170 (cc_dust_limit ctx) 171 (cc_feerate ctx) 172 (cc_features ctx) 173 (cc_htlcs ctx) 174 175 -- Calculate base fee 176 !baseFee = commitment_fee 177 (cc_feerate ctx) 178 (cc_features ctx) 179 (fromIntegral $ length untrimmedHtlcs) 180 181 -- Anchor cost if applicable 182 !anchorCost = if has_anchors (cc_features ctx) 183 then 2 * anchor_output_value 184 else Satoshi 0 185 186 -- Subtract fees and anchors from funder 187 !totalDeduction = baseFee + anchorCost 188 !(toLocalSat, toRemoteSat) = if cc_is_funder ctx 189 then 190 let !local = msat_to_sat (cc_to_local_msat ctx) 191 !deducted = if unSatoshi local >= unSatoshi totalDeduction 192 then Satoshi (unSatoshi local - unSatoshi totalDeduction) 193 else Satoshi 0 194 in (deducted, msat_to_sat (cc_to_remote_msat ctx)) 195 else 196 let !remote = msat_to_sat (cc_to_remote_msat ctx) 197 !deducted = if unSatoshi remote >= unSatoshi totalDeduction 198 then Satoshi (unSatoshi remote - unSatoshi totalDeduction) 199 else Satoshi 0 200 in (msat_to_sat (cc_to_local_msat ctx), deducted) 201 202 !dustLimit = unDustLimit (cc_dust_limit ctx) 203 204 -- Build HTLC outputs 205 !htlcOutputs = map (htlcOutput ctx) untrimmedHtlcs 206 207 -- Build to_local output if above dust 208 !toLocalOutput = 209 if unSatoshi toLocalSat >= unSatoshi dustLimit 210 then 211 let !script = to_p2wsh $ to_local_script 212 (ck_revocation_pubkey $ cc_keys ctx) 213 (cc_to_self_delay ctx) 214 (ck_local_delayed $ cc_keys ctx) 215 in [TxOutput toLocalSat script OutputToLocal] 216 else [] 217 218 -- Build to_remote output if above dust 219 !toRemoteOutput = 220 if unSatoshi toRemoteSat >= unSatoshi dustLimit 221 then 222 let !script = if has_anchors (cc_features ctx) 223 then to_p2wsh $ to_remote_script 224 (ck_remote_payment $ cc_keys ctx) 225 (cc_features ctx) 226 else to_remote_script 227 (ck_remote_payment $ cc_keys ctx) 228 (cc_features ctx) 229 in [TxOutput toRemoteSat script OutputToRemote] 230 else [] 231 232 -- Build anchor outputs if option_anchors 233 !hasUntrimmedHtlcs = not (null untrimmedHtlcs) 234 !toLocalExists = not (null toLocalOutput) 235 !toRemoteExists = not (null toRemoteOutput) 236 237 !localAnchorOutput = 238 if has_anchors (cc_features ctx) && 239 (toLocalExists || hasUntrimmedHtlcs) 240 then 241 let !script = to_p2wsh $ anchor_script 242 (ck_local_funding $ cc_keys ctx) 243 in [TxOutput anchor_output_value script OutputLocalAnchor] 244 else [] 245 246 !remoteAnchorOutput = 247 if has_anchors (cc_features ctx) && 248 (toRemoteExists || hasUntrimmedHtlcs) 249 then 250 let !script = to_p2wsh $ anchor_script 251 (ck_remote_funding $ cc_keys ctx) 252 in [TxOutput anchor_output_value script OutputRemoteAnchor] 253 else [] 254 255 -- Combine and sort all outputs 256 !allOutputs = toLocalOutput ++ toRemoteOutput ++ 257 localAnchorOutput ++ remoteAnchorOutput ++ 258 htlcOutputs 259 !sortedOutputs = sort_outputs allOutputs 260 261 in CommitmentTx 262 { ctx_version = 2 263 , ctx_locktime = locktime 264 , ctx_input_outpoint = cc_funding_outpoint ctx 265 , ctx_input_sequence = inputSeq 266 , ctx_outputs = sortedOutputs 267 , ctx_funding_script = fundingScript 268 } 269 {-# INLINE build_commitment_tx #-} 270 271 -- | Build an HTLC output for commitment transaction. 272 htlcOutput :: CommitmentContext -> HTLC -> TxOutput 273 htlcOutput ctx htlc = 274 let !amountSat = msat_to_sat (htlc_amount_msat htlc) 275 !keys = cc_keys ctx 276 !features = cc_features ctx 277 !expiry = htlc_cltv_expiry htlc 278 in case htlc_direction htlc of 279 HTLCOffered -> 280 let !script = to_p2wsh $ offered_htlc_script 281 (ck_revocation_pubkey keys) 282 (ck_remote_htlc keys) 283 (ck_local_htlc keys) 284 (htlc_payment_hash htlc) 285 features 286 in TxOutput amountSat script (OutputOfferedHTLC expiry) 287 HTLCReceived -> 288 let !script = to_p2wsh $ received_htlc_script 289 (ck_revocation_pubkey keys) 290 (ck_remote_htlc keys) 291 (ck_local_htlc keys) 292 (htlc_payment_hash htlc) 293 expiry 294 features 295 in TxOutput amountSat script (OutputReceivedHTLC expiry) 296 {-# INLINE htlcOutput #-} 297 298 -- HTLC transactions ----------------------------------------------------------- 299 300 -- | Context for building HTLC transactions. 301 data HTLCContext = HTLCContext 302 { hc_commitment_txid :: !TxId 303 , hc_output_index :: {-# UNPACK #-} !Word32 304 , hc_htlc :: !HTLC 305 , hc_to_self_delay :: !ToSelfDelay 306 , hc_feerate :: !FeeratePerKw 307 , hc_features :: !ChannelFeatures 308 , hc_revocation_pubkey :: !RevocationPubkey 309 , hc_local_delayed :: !LocalDelayedPubkey 310 } deriving (Eq, Show, Generic) 311 312 -- | An HTLC transaction (timeout or success). 313 data HTLCTx = HTLCTx 314 { htx_version :: {-# UNPACK #-} !Word32 315 , htx_locktime :: !Locktime 316 , htx_input_outpoint :: !OutPoint 317 , htx_input_sequence :: !Sequence 318 , htx_output_value :: !Satoshi 319 , htx_output_script :: !Script 320 } deriving (Eq, Show, Generic) 321 322 -- | Internal helper for HTLC transaction construction. 323 -- 324 -- Both HTLC-timeout and HTLC-success transactions share the same 325 -- structure, differing only in locktime and fee calculation. 326 build_htlc_tx_common 327 :: HTLCContext 328 -> Locktime -- ^ Transaction locktime 329 -> Satoshi -- ^ Fee to subtract from output 330 -> HTLCTx 331 build_htlc_tx_common ctx locktime fee = 332 let !amountSat = msat_to_sat (htlc_amount_msat $ hc_htlc ctx) 333 !outputValue = if unSatoshi amountSat >= unSatoshi fee 334 then Satoshi (unSatoshi amountSat - unSatoshi fee) 335 else Satoshi 0 336 !inputSeq = if has_anchors (hc_features ctx) 337 then Sequence 1 338 else Sequence 0 339 !outpoint = OutPoint (hc_commitment_txid ctx) (hc_output_index ctx) 340 !outputScript = to_p2wsh $ htlc_output_script 341 (hc_revocation_pubkey ctx) 342 (hc_to_self_delay ctx) 343 (hc_local_delayed ctx) 344 in HTLCTx 345 { htx_version = 2 346 , htx_locktime = locktime 347 , htx_input_outpoint = outpoint 348 , htx_input_sequence = inputSeq 349 , htx_output_value = outputValue 350 , htx_output_script = outputScript 351 } 352 {-# INLINE build_htlc_tx_common #-} 353 354 -- | Build an HTLC-timeout transaction. 355 -- 356 -- * locktime: cltv_expiry 357 -- * sequence: 0 (or 1 with option_anchors) 358 -- * output: to_local style script with revocation and delayed paths 359 build_htlc_timeout_tx :: HTLCContext -> HTLCTx 360 build_htlc_timeout_tx ctx = 361 let !fee = htlc_timeout_fee (hc_feerate ctx) (hc_features ctx) 362 !locktime = Locktime (unCltvExpiry $ htlc_cltv_expiry $ hc_htlc ctx) 363 in build_htlc_tx_common ctx locktime fee 364 {-# INLINE build_htlc_timeout_tx #-} 365 366 -- | Build an HTLC-success transaction. 367 -- 368 -- * locktime: 0 369 -- * sequence: 0 (or 1 with option_anchors) 370 -- * output: to_local style script with revocation and delayed paths 371 build_htlc_success_tx :: HTLCContext -> HTLCTx 372 build_htlc_success_tx ctx = 373 let !fee = htlc_success_fee (hc_feerate ctx) (hc_features ctx) 374 in build_htlc_tx_common ctx (Locktime 0) fee 375 {-# INLINE build_htlc_success_tx #-} 376 377 -- closing transaction --------------------------------------------------------- 378 379 -- | Context for building closing transactions. 380 data ClosingContext = ClosingContext 381 { clc_funding_outpoint :: !OutPoint 382 , clc_local_amount :: !Satoshi 383 , clc_remote_amount :: !Satoshi 384 , clc_local_script :: !Script 385 , clc_remote_script :: !Script 386 , clc_local_dust_limit :: !DustLimit 387 , clc_remote_dust_limit :: !DustLimit 388 , clc_fee :: !Satoshi 389 , clc_is_funder :: !Bool 390 , clc_locktime :: !Locktime 391 , clc_funding_script :: !Script 392 } deriving (Eq, Show, Generic) 393 394 -- | A closing transaction. 395 data ClosingTx = ClosingTx 396 { cltx_version :: {-# UNPACK #-} !Word32 397 , cltx_locktime :: !Locktime 398 , cltx_input_outpoint :: !OutPoint 399 , cltx_input_sequence :: !Sequence 400 , cltx_outputs :: ![TxOutput] 401 , cltx_funding_script :: !Script 402 } deriving (Eq, Show, Generic) 403 404 -- | Build a closing transaction (option_simple_close). 405 -- 406 -- * locktime: from closing_complete message 407 -- * sequence: 0xFFFFFFFD 408 -- * outputs: sorted per BIP69 409 build_closing_tx :: ClosingContext -> ClosingTx 410 build_closing_tx ctx = 411 let -- Subtract fee from closer 412 !(localAmt, remoteAmt) = if clc_is_funder ctx 413 then 414 let !deducted = if unSatoshi (clc_local_amount ctx) >= 415 unSatoshi (clc_fee ctx) 416 then Satoshi (unSatoshi (clc_local_amount ctx) - 417 unSatoshi (clc_fee ctx)) 418 else Satoshi 0 419 in (deducted, clc_remote_amount ctx) 420 else 421 let !deducted = if unSatoshi (clc_remote_amount ctx) >= 422 unSatoshi (clc_fee ctx) 423 then Satoshi (unSatoshi (clc_remote_amount ctx) - 424 unSatoshi (clc_fee ctx)) 425 else Satoshi 0 426 in (clc_local_amount ctx, deducted) 427 428 -- Build outputs, omitting dust 429 !localOutput = 430 if unSatoshi localAmt >= unSatoshi (unDustLimit $ clc_local_dust_limit ctx) 431 then [TxOutput localAmt (clc_local_script ctx) OutputToLocal] 432 else [] 433 434 !remoteOutput = 435 if unSatoshi remoteAmt >= unSatoshi (unDustLimit $ clc_remote_dust_limit ctx) 436 then [TxOutput remoteAmt (clc_remote_script ctx) OutputToRemote] 437 else [] 438 439 !allOutputs = localOutput ++ remoteOutput 440 !sortedOutputs = sort_outputs allOutputs 441 442 in ClosingTx 443 { cltx_version = 2 444 , cltx_locktime = clc_locktime ctx 445 , cltx_input_outpoint = clc_funding_outpoint ctx 446 , cltx_input_sequence = Sequence 0xFFFFFFFD 447 , cltx_outputs = sortedOutputs 448 , cltx_funding_script = clc_funding_script ctx 449 } 450 {-# INLINE build_closing_tx #-} 451 452 -- | Build a legacy closing transaction (closing_signed). 453 -- 454 -- * locktime: 0 455 -- * sequence: 0xFFFFFFFF 456 -- * outputs: sorted per BIP69 457 build_legacy_closing_tx :: ClosingContext -> ClosingTx 458 build_legacy_closing_tx ctx = 459 let !result = build_closing_tx ctx 460 { clc_locktime = Locktime 0 } 461 in result { cltx_input_sequence = Sequence 0xFFFFFFFF } 462 {-# INLINE build_legacy_closing_tx #-} 463 464 -- fee calculation ------------------------------------------------------------- 465 466 -- | Calculate the base commitment transaction fee. 467 -- 468 -- @fee = feerate_per_kw * weight / 1000@ 469 -- 470 -- where @weight = base_weight + 172 * num_htlcs@ 471 commitment_fee :: FeeratePerKw -> ChannelFeatures -> Word64 -> Satoshi 472 commitment_fee feerate features numHtlcs = 473 let !weight = commitment_weight features numHtlcs 474 !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000 475 in Satoshi fee 476 {-# INLINE commitment_fee #-} 477 478 -- | Calculate commitment transaction weight. 479 -- 480 -- @weight = base + 172 * num_htlcs@ 481 commitment_weight :: ChannelFeatures -> Word64 -> Word64 482 commitment_weight features numHtlcs = 483 let !base = if has_anchors features 484 then commitment_weight_anchors 485 else commitment_weight_no_anchors 486 in base + htlc_output_weight * numHtlcs 487 {-# INLINE commitment_weight #-} 488 489 -- | Calculate HTLC-timeout transaction fee. 490 -- 491 -- With option_anchors, fee is 0 (CPFP). 492 -- Otherwise, @fee = feerate_per_kw * 663 / 1000@ 493 htlc_timeout_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi 494 htlc_timeout_fee feerate features 495 | has_anchors features = Satoshi 0 496 | otherwise = 497 let !weight = htlc_timeout_weight_no_anchors 498 !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000 499 in Satoshi fee 500 {-# INLINE htlc_timeout_fee #-} 501 502 -- | Calculate HTLC-success transaction fee. 503 -- 504 -- With option_anchors, fee is 0 (CPFP). 505 -- Otherwise, @fee = feerate_per_kw * 703 / 1000@ 506 htlc_success_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi 507 htlc_success_fee feerate features 508 | has_anchors features = Satoshi 0 509 | otherwise = 510 let !weight = htlc_success_weight_no_anchors 511 !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000 512 in Satoshi fee 513 {-# INLINE htlc_success_fee #-} 514 515 -- trimming -------------------------------------------------------------------- 516 517 -- | Calculate the trim threshold for an HTLC. 518 -- 519 -- An HTLC is trimmed if: 520 -- @amount < dust_limit + htlc_tx_fee@ 521 htlc_trim_threshold 522 :: DustLimit 523 -> FeeratePerKw 524 -> ChannelFeatures 525 -> HTLCDirection 526 -> Satoshi 527 htlc_trim_threshold dust feerate features direction = 528 let !dustVal = unDustLimit dust 529 !htlcFee = case direction of 530 HTLCOffered -> htlc_timeout_fee feerate features 531 HTLCReceived -> htlc_success_fee feerate features 532 in Satoshi (unSatoshi dustVal + unSatoshi htlcFee) 533 {-# INLINE htlc_trim_threshold #-} 534 535 -- | Check if an HTLC should be trimmed. 536 -- 537 -- An HTLC is trimmed if its amount minus the HTLC tx fee is below 538 -- the dust limit. 539 is_trimmed :: DustLimit -> FeeratePerKw -> ChannelFeatures -> HTLC -> Bool 540 is_trimmed dust feerate features htlc = 541 let !threshold = htlc_trim_threshold dust feerate features 542 (htlc_direction htlc) 543 !amountSat = msat_to_sat (htlc_amount_msat htlc) 544 in unSatoshi amountSat < unSatoshi threshold 545 {-# INLINE is_trimmed #-} 546 547 -- | Filter HTLCs that are trimmed. 548 trimmed_htlcs 549 :: DustLimit 550 -> FeeratePerKw 551 -> ChannelFeatures 552 -> [HTLC] 553 -> [HTLC] 554 trimmed_htlcs dust feerate features = 555 filter (is_trimmed dust feerate features) 556 {-# INLINE trimmed_htlcs #-} 557 558 -- | Filter HTLCs that are not trimmed. 559 untrimmed_htlcs 560 :: DustLimit 561 -> FeeratePerKw 562 -> ChannelFeatures 563 -> [HTLC] 564 -> [HTLC] 565 untrimmed_htlcs dust feerate features = 566 filter (not . is_trimmed dust feerate features) 567 {-# INLINE untrimmed_htlcs #-} 568 569 -- conversion to ppad-tx ------------------------------------------------------- 570 571 -- | Convert a 'TxOutput' to a ppad-tx 'BT.TxOut'. 572 toTxOut :: TxOutput -> BT.TxOut 573 toTxOut o = BT.TxOut 574 { BT.txout_value = 575 unSatoshi (txout_value o) 576 , BT.txout_script_pubkey = 577 unScript (txout_script o) 578 } 579 {-# INLINE toTxOut #-} 580 581 -- | Convert a commitment transaction to a ppad-tx 'BT.Tx'. 582 -- 583 -- Returns 'Nothing' if the transaction has no outputs. 584 commitment_to_tx :: CommitmentTx -> Maybe BT.Tx 585 commitment_to_tx ctx = do 586 outs <- nonEmpty (map toTxOut (ctx_outputs ctx)) 587 let !input = BT.TxIn 588 { BT.txin_prevout = ctx_input_outpoint ctx 589 , BT.txin_script_sig = BS.empty 590 , BT.txin_sequence = 591 unSequence (ctx_input_sequence ctx) 592 } 593 pure $! BT.Tx 594 { BT.tx_version = ctx_version ctx 595 , BT.tx_inputs = input :| [] 596 , BT.tx_outputs = outs 597 , BT.tx_witnesses = [] 598 , BT.tx_locktime = unLocktime (ctx_locktime ctx) 599 } 600 601 -- | Convert an HTLC transaction to a ppad-tx 'BT.Tx'. 602 htlc_to_tx :: HTLCTx -> BT.Tx 603 htlc_to_tx htx = 604 let !input = BT.TxIn 605 { BT.txin_prevout = htx_input_outpoint htx 606 , BT.txin_script_sig = BS.empty 607 , BT.txin_sequence = 608 unSequence (htx_input_sequence htx) 609 } 610 !output = BT.TxOut 611 { BT.txout_value = 612 unSatoshi (htx_output_value htx) 613 , BT.txout_script_pubkey = 614 unScript (htx_output_script htx) 615 } 616 in BT.Tx 617 { BT.tx_version = htx_version htx 618 , BT.tx_inputs = input :| [] 619 , BT.tx_outputs = output :| [] 620 , BT.tx_witnesses = [] 621 , BT.tx_locktime = unLocktime (htx_locktime htx) 622 } 623 624 -- | Convert a closing transaction to a ppad-tx 'BT.Tx'. 625 -- 626 -- Returns 'Nothing' if the transaction has no outputs. 627 closing_to_tx :: ClosingTx -> Maybe BT.Tx 628 closing_to_tx ctx = do 629 outs <- nonEmpty (map toTxOut (cltx_outputs ctx)) 630 let !input = BT.TxIn 631 { BT.txin_prevout = cltx_input_outpoint ctx 632 , BT.txin_script_sig = BS.empty 633 , BT.txin_sequence = 634 unSequence (cltx_input_sequence ctx) 635 } 636 pure $! BT.Tx 637 { BT.tx_version = cltx_version ctx 638 , BT.tx_inputs = input :| [] 639 , BT.tx_outputs = outs 640 , BT.tx_witnesses = [] 641 , BT.tx_locktime = unLocktime (cltx_locktime ctx) 642 } 643 644 -- output ordering ------------------------------------------------------------- 645 646 -- | Sort outputs per BOLT #3 ordering. 647 -- 648 -- Outputs are sorted by: 649 -- 1. Value (smallest first) 650 -- 2. ScriptPubKey (lexicographic) 651 -- 3. CLTV expiry (for HTLCs) 652 sort_outputs :: [TxOutput] -> [TxOutput] 653 sort_outputs = sortBy compareOutputs 654 {-# INLINE sort_outputs #-} 655 656 -- | Compare two outputs for ordering. 657 compareOutputs :: TxOutput -> TxOutput -> Ordering 658 compareOutputs o1 o2 = 659 case compare (txout_value o1) (txout_value o2) of 660 EQ -> case compare (unScript $ txout_script o1) 661 (unScript $ txout_script o2) of 662 EQ -> compareCltvExpiry (txout_type o1) (txout_type o2) 663 other -> other 664 other -> other 665 {-# INLINE compareOutputs #-} 666 667 -- | Compare CLTV expiry for HTLC outputs. 668 compareCltvExpiry :: OutputType -> OutputType -> Ordering 669 compareCltvExpiry (OutputOfferedHTLC e1) (OutputOfferedHTLC e2) = compare e1 e2 670 compareCltvExpiry (OutputReceivedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2 671 compareCltvExpiry (OutputOfferedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2 672 compareCltvExpiry (OutputReceivedHTLC e1) (OutputOfferedHTLC e2) = compare e1 e2 673 compareCltvExpiry _ _ = EQ 674 {-# INLINE compareCltvExpiry #-}