ppad-bolt5 (empty) → 0.0.1
raw patch · 10 files changed
+2380/−0 lines, 10 filesdep +QuickCheckdep +basedep +bytestring
Dependencies added: QuickCheck, base, bytestring, criterion, deepseq, ppad-bolt3, ppad-bolt5, ppad-sha256, ppad-tx, tasty, tasty-hunit, tasty-quickcheck, weigh
Files
- CHANGELOG +4/−0
- LICENSE +20/−0
- bench/Main.hs +183/−0
- bench/Weight.hs +146/−0
- lib/Lightning/Protocol/BOLT5.hs +114/−0
- lib/Lightning/Protocol/BOLT5/Detect.hs +350/−0
- lib/Lightning/Protocol/BOLT5/Spend.hs +515/−0
- lib/Lightning/Protocol/BOLT5/Types.hs +192/−0
- ppad-bolt5.cabal +92/−0
- test/Main.hs +764/−0
+ CHANGELOG view
@@ -0,0 +1,4 @@+# Changelog++- 0.0.1 (UNRELEASED)+ * Initial release
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2025 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ bench/Main.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Bitcoin.Prim.Tx.Sighash (SighashType(..))+import Control.DeepSeq (NFData(..))+import Criterion.Main+import qualified Data.ByteString as BS+import qualified Data.List.NonEmpty as NE+import Lightning.Protocol.BOLT3 hiding+ (txout_value, txout_script)+import qualified Lightning.Protocol.BOLT5 as B5++-- NFData orphan instances for criterion -----------------------------++instance NFData Satoshi where+ rnf (Satoshi x) = rnf x++instance NFData MilliSatoshi where+ rnf (MilliSatoshi x) = rnf x++instance NFData Script where+ rnf (Script bs) = rnf bs++instance NFData Pubkey where+ rnf (Pubkey x) = rnf x++instance NFData Point where+ rnf (Point x) = rnf x++instance NFData RevocationPubkey where+ rnf (RevocationPubkey x) = rnf x++instance NFData LocalDelayedPubkey where+ rnf (LocalDelayedPubkey p) = rnf p++instance NFData FundingPubkey where+ rnf (FundingPubkey p) = rnf p++instance NFData FeeratePerKw where+ rnf (FeeratePerKw x) = rnf x++instance NFData ToSelfDelay where+ rnf (ToSelfDelay x) = rnf x++instance NFData PaymentHash where+ rnf (PaymentHash x) = rnf x++instance NFData CltvExpiry where+ rnf (CltvExpiry x) = rnf x++instance NFData HTLCDirection where+ rnf HTLCOffered = ()+ rnf HTLCReceived = ()++instance NFData HTLC where+ rnf (HTLC d a h c) =+ rnf d `seq` rnf a `seq` rnf h `seq` rnf c++instance NFData SighashType++instance NFData B5.OutputResolution where+ rnf B5.Resolved = ()+ rnf (B5.Revoke rk) = rnf rk+ rnf _ = ()++instance NFData B5.UnresolvedOutput where+ rnf (B5.UnresolvedOutput op v t) =+ rnf op `seq` rnf v `seq` rnf t++instance NFData B5.SpendingTx where+ rnf (B5.SpendingTx tx scr val sh) =+ rnf tx `seq` rnf scr `seq` rnf val `seq` rnf sh++instance NFData B5.PenaltyContext where+ rnf (B5.PenaltyContext os rk d f) =+ rnf os `seq` rnf rk `seq` rnf d `seq` rnf f++main :: IO ()+main = defaultMain [+ spend_benchmarks+ , classify_benchmarks+ ]++-- fixtures -----------------------------------------------------------++dummyPubkey :: Pubkey+dummyPubkey = case pubkey (BS.pack (0x02 : replicate 32 0x01)) of+ Just pk -> pk+ Nothing -> error "impossible"++dummyTxId :: TxId+dummyTxId = case mkTxId (BS.replicate 32 0x00) of+ Just tid -> tid+ Nothing -> error "impossible"++dummyOutPoint :: OutPoint+dummyOutPoint = OutPoint dummyTxId 0++dummyRevPk :: RevocationPubkey+dummyRevPk = RevocationPubkey dummyPubkey++dummyDelayedPk :: LocalDelayedPubkey+dummyDelayedPk = LocalDelayedPubkey dummyPubkey++dummyFundPk :: FundingPubkey+dummyFundPk = FundingPubkey dummyPubkey++dummyDest :: Script+dummyDest = Script $ BS.pack [0x00, 0x14] <>+ BS.replicate 20 0xCC++dummyFeerate :: FeeratePerKw+dummyFeerate = FeeratePerKw 253++dummyDelay :: ToSelfDelay+dummyDelay = ToSelfDelay 144++mkRevokedOutputs :: Int -> NE.NonEmpty B5.UnresolvedOutput+mkRevokedOutputs n =+ let uo i = B5.UnresolvedOutput+ (OutPoint dummyTxId (fromIntegral i))+ (Satoshi 10000)+ (B5.Revoke dummyRevPk)+ in uo 0 NE.:| [ uo i | i <- [1..n-1] ]++-- benchmarks ---------------------------------------------------------++spend_benchmarks :: Benchmark+spend_benchmarks = bgroup "spend" [+ bench "spend_to_local" $+ nf (\v -> B5.spend_to_local+ dummyOutPoint v dummyRevPk dummyDelay+ dummyDelayedPk dummyDest dummyFeerate)+ (Satoshi 100000)++ , bench "spend_revoked_to_local" $+ nf (\v -> B5.spend_revoked_to_local+ dummyOutPoint v dummyRevPk dummyDelay+ dummyDelayedPk dummyDest dummyFeerate)+ (Satoshi 100000)++ , bench "spend_anchor_owner" $+ nf (\v -> B5.spend_anchor_owner+ dummyOutPoint v dummyFundPk dummyDest)+ (Satoshi 330)++ , bench "spend_revoked_batch/10" $+ nf B5.spend_revoked_batch+ (B5.PenaltyContext+ (mkRevokedOutputs 10)+ dummyRevPk dummyDest dummyFeerate)++ , bench "spend_revoked_batch/100" $+ nf B5.spend_revoked_batch+ (B5.PenaltyContext+ (mkRevokedOutputs 100)+ dummyRevPk dummyDest dummyFeerate)++ , bench "spend_revoked_batch/483" $+ nf B5.spend_revoked_batch+ (B5.PenaltyContext+ (mkRevokedOutputs 483)+ dummyRevPk dummyDest dummyFeerate)+ ]++classify_benchmarks :: Benchmark+classify_benchmarks = bgroup "classify" [+ bench "spending_fee" $+ nf (B5.spending_fee dummyFeerate) 538++ , bench "htlc_timed_out" $+ nf (B5.htlc_timed_out 500001)+ (HTLC HTLCOffered (MilliSatoshi 1000000)+ dummyPaymentHash (CltvExpiry 500000))+ ]+ where+ dummyPaymentHash = case payment_hash+ (BS.replicate 32 0xAA) of+ Just ph -> ph+ Nothing -> error "impossible"
+ bench/Weight.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Bitcoin.Prim.Tx.Sighash (SighashType(..))+import Control.DeepSeq (NFData(..))+import qualified Data.ByteString as BS+import qualified Data.List.NonEmpty as NE+import Lightning.Protocol.BOLT3 hiding+ (txout_value, txout_script)+import qualified Lightning.Protocol.BOLT5 as B5+import Weigh++-- NFData orphan instances for weigh ---------------------------------++instance NFData Satoshi where+ rnf (Satoshi x) = rnf x++instance NFData Script where+ rnf (Script bs) = rnf bs++instance NFData Pubkey where+ rnf (Pubkey x) = rnf x++instance NFData Point where+ rnf (Point x) = rnf x++instance NFData RevocationPubkey where+ rnf (RevocationPubkey x) = rnf x++instance NFData LocalDelayedPubkey where+ rnf (LocalDelayedPubkey p) = rnf p++instance NFData FundingPubkey where+ rnf (FundingPubkey p) = rnf p++instance NFData FeeratePerKw where+ rnf (FeeratePerKw x) = rnf x++instance NFData ToSelfDelay where+ rnf (ToSelfDelay x) = rnf x++instance NFData SighashType++instance NFData B5.OutputResolution where+ rnf B5.Resolved = ()+ rnf (B5.Revoke rk) = rnf rk+ rnf _ = ()++instance NFData B5.UnresolvedOutput where+ rnf (B5.UnresolvedOutput op v t) =+ rnf op `seq` rnf v `seq` rnf t++instance NFData B5.SpendingTx where+ rnf (B5.SpendingTx tx scr val sh) =+ rnf tx `seq` rnf scr `seq` rnf val `seq` rnf sh++instance NFData B5.PenaltyContext where+ rnf (B5.PenaltyContext os rk d f) =+ rnf os `seq` rnf rk `seq` rnf d `seq` rnf f++-- note that 'weigh' doesn't work properly in a repl+main :: IO ()+main = mainWith $ do+ spend_weights+ batch_weights++-- fixtures -----------------------------------------------------------++dummyPubkey :: Pubkey+dummyPubkey = case pubkey (BS.pack (0x02 : replicate 32 0x01)) of+ Just pk -> pk+ Nothing -> error "impossible"++dummyTxId :: TxId+dummyTxId = case mkTxId (BS.replicate 32 0x00) of+ Just tid -> tid+ Nothing -> error "impossible"++dummyOutPoint :: OutPoint+dummyOutPoint = OutPoint dummyTxId 0++dummyRevPk :: RevocationPubkey+dummyRevPk = RevocationPubkey dummyPubkey++dummyDelayedPk :: LocalDelayedPubkey+dummyDelayedPk = LocalDelayedPubkey dummyPubkey++dummyFundPk :: FundingPubkey+dummyFundPk = FundingPubkey dummyPubkey++dummyDest :: Script+dummyDest = Script $ BS.pack [0x00, 0x14] <>+ BS.replicate 20 0xCC++dummyFeerate :: FeeratePerKw+dummyFeerate = FeeratePerKw 253++dummyDelay :: ToSelfDelay+dummyDelay = ToSelfDelay 144++mkRevokedOutputs :: Int -> NE.NonEmpty B5.UnresolvedOutput+mkRevokedOutputs n =+ let uo i = B5.UnresolvedOutput+ (OutPoint dummyTxId (fromIntegral i))+ (Satoshi 10000)+ (B5.Revoke dummyRevPk)+ in uo 0 NE.:| [ uo i | i <- [1..n-1] ]++-- weights ------------------------------------------------------------++spend_weights :: Weigh ()+spend_weights = wgroup "spend" $ do+ func "spend_to_local"+ (\v -> B5.spend_to_local+ dummyOutPoint v dummyRevPk dummyDelay+ dummyDelayedPk dummyDest dummyFeerate)+ (Satoshi 100000)++ func "spend_anchor_owner"+ (\v -> B5.spend_anchor_owner+ dummyOutPoint v dummyFundPk dummyDest)+ (Satoshi 330)++batch_weights :: Weigh ()+batch_weights = wgroup "batch" $ do+ func "spend_revoked_batch/10"+ B5.spend_revoked_batch+ (B5.PenaltyContext+ (mkRevokedOutputs 10)+ dummyRevPk dummyDest dummyFeerate)++ func "spend_revoked_batch/100"+ B5.spend_revoked_batch+ (B5.PenaltyContext+ (mkRevokedOutputs 100)+ dummyRevPk dummyDest dummyFeerate)++ func "spend_revoked_batch/483"+ B5.spend_revoked_batch+ (B5.PenaltyContext+ (mkRevokedOutputs 483)+ dummyRevPk dummyDest dummyFeerate)
+ lib/Lightning/Protocol/BOLT5.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Module: Lightning.Protocol.BOLT5+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- On-chain transaction handling for the Lightning Network, per+-- [BOLT #5](https://github.com/lightning/bolts/blob/master/05-onchain.md).+--+-- This module implements the logic for handling channel closures:+--+-- * Mutual close - cooperative closure agreed by both parties+-- * Unilateral close - one party publishes their commitment+-- transaction+-- * Revoked transaction close - penalty for publishing old state+--+-- = Design+--+-- This is a stateless toolkit of pure functions. The caller+-- manages channel state (which outputs are resolved, current+-- block height, etc.) and provides explicit inputs. Functions+-- produce unsigned 'SpendingTx' values; the caller signs and+-- assembles witnesses using bolt3 constructors.+--+-- = Usage+--+-- @+-- import Lightning.Protocol.BOLT3+-- import Lightning.Protocol.BOLT5+--+-- -- Classify outputs of our local commitment+-- let outputs = classify_local_commit_outputs+-- commitTx keys delay features htlcs+--+-- -- For each unresolved output, construct spending tx+-- case uo_type output of+-- SpendToLocal delay revpk delayedpk ->+-- spend_to_local (uo_outpoint output)+-- (uo_value output) revpk delay delayedpk+-- destScript feerate+-- ...+-- @++module Lightning.Protocol.BOLT5 (+ -- * Types+ -- ** Close identification+ CloseType(..)++ -- ** Output classification+ , UnresolvedOutput(..)+ , OutputResolution(..)++ -- ** Spending transactions+ , SpendingTx(..)++ -- ** Penalty batching+ , PenaltyContext(..)++ -- * Weight constants (Appendix A)+ , to_local_penalty_witness_weight+ , offered_htlc_penalty_witness_weight+ , accepted_htlc_penalty_witness_weight+ , to_local_penalty_input_weight+ , offered_htlc_penalty_input_weight+ , accepted_htlc_penalty_input_weight+ , to_remote_input_weight+ , penalty_tx_base_weight+ , max_standard_weight++ -- * Fee calculation+ , spending_fee++ -- * Close identification+ , identify_close++ -- * Output classification+ , classify_local_commit_outputs+ , classify_remote_commit_outputs+ , classify_revoked_commit_outputs++ -- * Preimage extraction+ , extract_preimage_offered+ , extract_preimage_htlc_success++ -- * Timeout check+ , htlc_timed_out++ -- * Spending transaction construction+ -- ** Local commitment+ , spend_to_local+ , spend_htlc_timeout+ , spend_htlc_success+ , spend_htlc_output++ -- ** Remote commitment+ , spend_remote_htlc_timeout+ , spend_remote_htlc_preimage++ -- ** Revoked commitment+ , spend_revoked_to_local+ , spend_revoked_htlc+ , spend_revoked_htlc_output+ , spend_revoked_batch++ -- ** Anchor outputs+ , spend_anchor_owner+ , spend_anchor_anyone+ ) where++import Lightning.Protocol.BOLT5.Types+import Lightning.Protocol.BOLT5.Detect+import Lightning.Protocol.BOLT5.Spend
+ lib/Lightning/Protocol/BOLT5/Detect.hs view
@@ -0,0 +1,350 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Lightning.Protocol.BOLT5.Detect+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Close identification, output classification, and preimage+-- extraction for BOLT #5 on-chain transaction handling.++module Lightning.Protocol.BOLT5.Detect (+ -- * Close identification+ identify_close++ -- * Output classification+ , classify_local_commit_outputs+ , classify_remote_commit_outputs+ , classify_revoked_commit_outputs++ -- * Preimage extraction+ , extract_preimage_offered+ , extract_preimage_htlc_success++ -- * Timeout check+ , htlc_timed_out+ ) where++import qualified Bitcoin.Prim.Tx as BT+import Data.Word (Word32)+import qualified Data.ByteString as BS+import Lightning.Protocol.BOLT3+import Lightning.Protocol.BOLT5.Types++-- close identification -----------------------------------------------++-- | Identify the type of channel close from a transaction that+-- spends the funding output.+--+-- Compares the on-chain transaction bytes against the known+-- local and remote commitment transaction serializations+-- (stripped/unsigned) to determine whether it's a local or+-- remote commitment close.+--+-- Returns 'Nothing' if the transaction doesn't match either+-- commitment. Mutual close and revoked commitment detection+-- require additional checks by the caller (e.g. comparing+-- closing tx format, checking a secret store for older+-- commitment numbers).+identify_close+ :: CommitmentTx+ -- ^ Our local commitment tx.+ -> CommitmentTx+ -- ^ The remote commitment tx (current).+ -> BS.ByteString+ -- ^ Raw serialized transaction found on chain.+ -> Maybe CloseType+identify_close !localCommitTx !remoteCommitTx+ !onChainBytes =+ let !localBytes = encode_tx_for_signing localCommitTx+ !remoteBytes = encode_tx_for_signing remoteCommitTx+ in if localBytes == Just onChainBytes+ then Just LocalCommitClose+ else if remoteBytes == Just onChainBytes+ then Just RemoteCommitClose+ else Nothing++-- output classification ----------------------------------------------++-- | Classify outputs of our local commitment transaction.+--+-- Per BOLT #5: when we discover our local commitment on chain,+-- we must resolve each output. to_local requires a CSV-delayed+-- spend, to_remote is resolved by the commitment itself, HTLC+-- outputs need second-stage transactions, and anchors can be+-- spent immediately.+classify_local_commit_outputs+ :: CommitmentTx+ -- ^ Our local commitment transaction.+ -> CommitmentKeys+ -- ^ Derived keys for this commitment.+ -> ToSelfDelay+ -- ^ Remote's to_self_delay (CSV delay for our outputs).+ -> ChannelFeatures+ -- ^ Channel feature flags.+ -> [HTLC]+ -- ^ HTLCs in this commitment.+ -> [UnresolvedOutput]+classify_local_commit_outputs !commitTx !keys !delay+ !features !htlcs =+ case commitment_txid commitTx of+ Nothing -> []+ Just !txid ->+ let !outputs = ctx_outputs commitTx+ !revpk = ck_revocation_pubkey keys+ !delayedpk = ck_local_delayed keys+ in zipWith (classifyLocalOutput txid revpk delayedpk+ delay features keys htlcs)+ [0..] outputs++-- | Classify a single output from a local commitment tx.+classifyLocalOutput+ :: TxId+ -> RevocationPubkey+ -> LocalDelayedPubkey+ -> ToSelfDelay+ -> ChannelFeatures+ -> CommitmentKeys+ -> [HTLC]+ -> Word32+ -> TxOutput+ -> UnresolvedOutput+classifyLocalOutput !txid !revpk !delayedpk !delay+ !features !keys !htlcs !idx !out =+ let !op = OutPoint txid idx+ !val = txout_value out+ !resolution = case txout_type out of+ OutputToLocal ->+ SpendToLocal delay revpk delayedpk+ OutputToRemote ->+ Resolved+ OutputLocalAnchor ->+ AnchorSpend (ck_local_funding keys)+ OutputRemoteAnchor ->+ Resolved+ OutputOfferedHTLC _expiry ->+ case findHTLC HTLCOffered+ (txout_script out) keys features htlcs of+ Just htlc ->+ SpendHTLCTimeout htlc keys features+ Nothing -> Resolved+ OutputReceivedHTLC _expiry ->+ case findHTLC HTLCReceived+ (txout_script out) keys features htlcs of+ Just htlc ->+ SpendHTLCSuccess htlc keys features+ Nothing -> Resolved+ in UnresolvedOutput op val resolution++-- | Classify outputs of the remote commitment transaction.+--+-- Per BOLT #5: when we discover the remote commitment on chain,+-- there are no CSV delays on our outputs. We can spend offered+-- HTLCs directly after timeout, and received HTLCs directly+-- with the preimage.+classify_remote_commit_outputs+ :: CommitmentTx+ -- ^ The remote commitment transaction.+ -> CommitmentKeys+ -- ^ Derived keys for this commitment (from remote's+ -- perspective, so local/remote are swapped).+ -> ChannelFeatures+ -- ^ Channel feature flags.+ -> [HTLC]+ -- ^ HTLCs in this commitment.+ -> [UnresolvedOutput]+classify_remote_commit_outputs !commitTx !keys+ !features !htlcs =+ case commitment_txid commitTx of+ Nothing -> []+ Just !txid ->+ let !outputs = ctx_outputs commitTx+ in zipWith+ (classifyRemoteOutput txid features keys htlcs)+ [0..] outputs++-- | Classify a single output from a remote commitment tx.+classifyRemoteOutput+ :: TxId+ -> ChannelFeatures+ -> CommitmentKeys+ -> [HTLC]+ -> Word32+ -> TxOutput+ -> UnresolvedOutput+classifyRemoteOutput !txid !features !keys+ !htlcs !idx !out =+ let !op = OutPoint txid idx+ !val = txout_value out+ !resolution = case txout_type out of+ OutputToLocal ->+ Resolved -- Remote's to_local; not ours+ OutputToRemote ->+ Resolved -- Our to_remote; resolved by commitment+ OutputLocalAnchor ->+ Resolved -- Remote's anchor+ OutputRemoteAnchor ->+ AnchorSpend (ck_remote_funding keys)+ OutputOfferedHTLC _expiry ->+ -- On remote's commit, their offered = our received.+ -- We can claim with preimage.+ case findHTLC HTLCOffered+ (txout_script out) keys features htlcs of+ Just htlc ->+ SpendHTLCPreimageDirect htlc+ Nothing -> Resolved+ OutputReceivedHTLC _expiry ->+ -- On remote's commit, their received = our offered.+ -- We can claim after timeout.+ case findHTLC HTLCReceived+ (txout_script out) keys features htlcs of+ Just htlc ->+ SpendHTLCTimeoutDirect htlc+ Nothing -> Resolved+ in UnresolvedOutput op val resolution++-- | Classify outputs of a revoked commitment transaction.+--+-- Per BOLT #5: when we discover a revoked commitment, we can+-- claim everything using the revocation key. to_local is spent+-- via revocation, HTLCs are spent via revocation, and we can+-- also optionally sweep to_remote.+classify_revoked_commit_outputs+ :: CommitmentTx+ -- ^ The revoked commitment transaction.+ -> CommitmentKeys+ -- ^ Derived keys for the revoked commitment.+ -> RevocationPubkey+ -- ^ Revocation pubkey (derived from the revealed secret).+ -> ChannelFeatures+ -- ^ Channel feature flags.+ -> [HTLC]+ -- ^ HTLCs in the revoked commitment.+ -> [UnresolvedOutput]+classify_revoked_commit_outputs !commitTx !_keys+ !revpk !_features !_htlcs =+ case commitment_txid commitTx of+ Nothing -> []+ Just !txid ->+ let !outputs = ctx_outputs commitTx+ in zipWith (classifyRevokedOutput txid revpk)+ [0..] outputs++-- | Classify a single output from a revoked commitment tx.+classifyRevokedOutput+ :: TxId+ -> RevocationPubkey+ -> Word32+ -> TxOutput+ -> UnresolvedOutput+classifyRevokedOutput !txid !revpk !idx !out =+ let !op = OutPoint txid idx+ !val = txout_value out+ !resolution = case txout_type out of+ OutputToLocal ->+ Revoke revpk+ OutputToRemote ->+ Resolved -- Our funds; resolved by commitment+ OutputLocalAnchor ->+ Resolved -- Can be swept by anyone after 16 blocks+ OutputRemoteAnchor ->+ Resolved -- Our anchor+ otype@(OutputOfferedHTLC _) ->+ RevokeHTLC revpk otype+ otype@(OutputReceivedHTLC _) ->+ RevokeHTLC revpk otype+ in UnresolvedOutput op val resolution++-- preimage extraction ------------------------------------------------++-- | Extract a payment preimage from an offered HTLC witness.+--+-- When the remote party claims an offered HTLC on our local+-- commitment, the witness contains the preimage. The witness+-- stack for a preimage claim is:+--+-- @\<remotehtlcsig\> \<payment_preimage\>@+--+-- The preimage is the second item (32 bytes) and must hash to+-- the expected payment hash.+extract_preimage_offered :: Witness -> Maybe PaymentPreimage+extract_preimage_offered (Witness items) =+ case items of+ [_sig, preimageBytes]+ | BS.length preimageBytes == 32 ->+ payment_preimage preimageBytes+ _ -> Nothing++-- | Extract a payment preimage from an HTLC-success transaction+-- witness.+--+-- When the remote party uses an HTLC-success tx on their+-- commitment to claim a received HTLC, the witness contains the+-- preimage. The witness stack is:+--+-- @0 \<remotehtlcsig\> \<localhtlcsig\> \<payment_preimage\>@+--+-- The preimage is the fourth item (32 bytes).+extract_preimage_htlc_success+ :: Witness -> Maybe PaymentPreimage+extract_preimage_htlc_success (Witness items) =+ case items of+ [_zero, _remoteSig, _localSig, preimageBytes]+ | BS.length preimageBytes == 32 ->+ payment_preimage preimageBytes+ _ -> Nothing++-- timeout check ------------------------------------------------------++-- | Check if an HTLC has timed out at the given block height.+--+-- An HTLC has timed out when the current block height is equal+-- to or greater than the HTLC's CLTV expiry.+htlc_timed_out :: Word32 -> HTLC -> Bool+htlc_timed_out !currentHeight !htlc =+ currentHeight >= unCltvExpiry (htlc_cltv_expiry htlc)+{-# INLINE htlc_timed_out #-}++-- internal helpers ---------------------------------------------------++-- | Compute the txid of a commitment transaction.+--+-- Returns 'Nothing' if the commitment has no outputs.+commitment_txid :: CommitmentTx -> Maybe TxId+commitment_txid !tx = fmap BT.txid (commitment_to_tx tx)++-- | Find an HTLC matching a given script in the output list.+findHTLC+ :: HTLCDirection+ -> Script+ -> CommitmentKeys+ -> ChannelFeatures+ -> [HTLC]+ -> Maybe HTLC+findHTLC !dir !targetScript !keys !features =+ go+ where+ go [] = Nothing+ go (htlc:rest)+ | htlc_direction htlc == dir+ , htlcScript htlc == targetScript = Just htlc+ | otherwise = go rest++ htlcScript htlc = case dir of+ HTLCOffered ->+ to_p2wsh $ offered_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ features+ HTLCReceived ->+ to_p2wsh $ received_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ (htlc_cltv_expiry htlc)+ features
+ lib/Lightning/Protocol/BOLT5/Spend.hs view
@@ -0,0 +1,515 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Lightning.Protocol.BOLT5.Spend+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Spending transaction construction for BOLT #5 on-chain+-- transaction handling.+--+-- All functions produce unsigned 'SpendingTx' values. The caller+-- is responsible for signing (using the sighash metadata+-- provided) and assembling final witnesses via bolt3 witness+-- constructors.++module Lightning.Protocol.BOLT5.Spend (+ -- * Local commitment spends+ spend_to_local+ , spend_htlc_timeout+ , spend_htlc_success+ , spend_htlc_output++ -- * Remote commitment spends+ , spend_remote_htlc_timeout+ , spend_remote_htlc_preimage++ -- * Revoked commitment spends+ , spend_revoked_to_local+ , spend_revoked_htlc+ , spend_revoked_htlc_output+ , spend_revoked_batch++ -- * Anchor spends+ , spend_anchor_owner+ , spend_anchor_anyone+ ) where++import Bitcoin.Prim.Tx (TxOut(..))+import Bitcoin.Prim.Tx.Sighash (SighashType(..))+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Word (Word32)+import qualified Data.ByteString as BS+import Lightning.Protocol.BOLT3 hiding+ (txout_value, txout_script)+import Lightning.Protocol.BOLT5.Types++-- local commitment spends --------------------------------------------++-- | Spend the to_local output of our local commitment tx.+--+-- Requires waiting for the CSV delay (to_self_delay) before+-- broadcasting. The caller signs with the local delayed privkey+-- and uses 'to_local_witness_spend' from bolt3.+--+-- The input nSequence is set to the to_self_delay value.+spend_to_local+ :: OutPoint+ -- ^ Outpoint of the to_local output.+ -> Satoshi+ -- ^ Value of the to_local output.+ -> RevocationPubkey+ -> ToSelfDelay+ -> LocalDelayedPubkey+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> SpendingTx+spend_to_local !op !value !revpk !delay !delayedpk+ !destScript !feerate =+ let !witnessScript =+ to_local_script revpk delay delayedpk+ !weight = to_local_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !tx = mk_spending_tx op+ (fromIntegral (unToSelfDelay delay))+ destScript outputValue 0+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- | Construct an HTLC-timeout second-stage transaction.+--+-- Used when we offered an HTLC on our local commitment and it+-- has timed out. The bolt3 'build_htlc_timeout_tx' function+-- constructs the HTLC-timeout tx; this wraps it as a+-- 'SpendingTx' with the witness script and sighash metadata.+spend_htlc_timeout+ :: HTLCContext+ -> CommitmentKeys+ -- ^ Full commitment keys (needed for witness script).+ -> SpendingTx+spend_htlc_timeout !ctx !keys =+ let !htlcTx = build_htlc_timeout_tx ctx+ !htlc = hc_htlc ctx+ !features = hc_features ctx+ !witnessScript = offered_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ features+ !inputValue =+ msat_to_sat (htlc_amount_msat htlc)+ !sighashType = if has_anchors features+ then SIGHASH_SINGLE_ANYONECANPAY+ else SIGHASH_ALL+ !tx = htlc_tx_to_tx htlcTx+ in SpendingTx tx witnessScript inputValue sighashType++-- | Construct an HTLC-success second-stage transaction.+--+-- Used when we received an HTLC on our local commitment and+-- have the preimage. The bolt3 'build_htlc_success_tx' function+-- constructs the HTLC-success tx; this wraps it as a+-- 'SpendingTx'.+spend_htlc_success+ :: HTLCContext+ -> CommitmentKeys+ -- ^ Full commitment keys (needed for witness script).+ -> SpendingTx+spend_htlc_success !ctx !keys =+ let !htlcTx = build_htlc_success_tx ctx+ !htlc = hc_htlc ctx+ !features = hc_features ctx+ !witnessScript = received_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ (htlc_cltv_expiry htlc)+ features+ !inputValue =+ msat_to_sat (htlc_amount_msat htlc)+ !sighashType = if has_anchors features+ then SIGHASH_SINGLE_ANYONECANPAY+ else SIGHASH_ALL+ !tx = htlc_tx_to_tx htlcTx+ in SpendingTx tx witnessScript inputValue sighashType++-- | Spend a second-stage HTLC output (HTLC-timeout or+-- HTLC-success output) after the CSV delay.+--+-- The output of an HTLC-timeout or HTLC-success tx uses the+-- same to_local script. The caller signs with the local+-- delayed privkey and uses 'htlc_output_witness_spend'.+spend_htlc_output+ :: OutPoint+ -- ^ Outpoint of the second-stage output.+ -> Satoshi+ -- ^ Value of the second-stage output.+ -> RevocationPubkey+ -> ToSelfDelay+ -> LocalDelayedPubkey+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> SpendingTx+spend_htlc_output = spend_to_local++-- remote commitment spends -------------------------------------------++-- | Spend an offered HTLC directly after timeout on the remote+-- commitment.+--+-- On the remote commitment, their received HTLCs (our offered)+-- have timed out and we can sweep them directly.+spend_remote_htlc_timeout+ :: OutPoint+ -- ^ Outpoint of the HTLC output.+ -> Satoshi+ -- ^ Value of the HTLC output.+ -> HTLC+ -- ^ The HTLC being spent.+ -> CommitmentKeys+ -- ^ Keys for the remote commitment.+ -> ChannelFeatures+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> SpendingTx+spend_remote_htlc_timeout !op !value !htlc !keys+ !features !destScript !feerate =+ let !witnessScript = received_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ (htlc_cltv_expiry htlc)+ features+ !weight = accepted_htlc_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !locktime =+ unCltvExpiry (htlc_cltv_expiry htlc)+ !seqNo = if has_anchors features then 1 else 0+ !tx = mk_spending_tx op seqNo destScript+ outputValue locktime+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- | Spend a received HTLC directly with preimage on the remote+-- commitment.+--+-- On the remote commitment, their offered HTLCs (our received)+-- can be claimed with the payment preimage.+spend_remote_htlc_preimage+ :: OutPoint+ -- ^ Outpoint of the HTLC output.+ -> Satoshi+ -- ^ Value of the HTLC output.+ -> HTLC+ -- ^ The HTLC being spent.+ -> CommitmentKeys+ -- ^ Keys for the remote commitment.+ -> ChannelFeatures+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> SpendingTx+spend_remote_htlc_preimage !op !value !htlc !keys+ !features !destScript !feerate =+ let !witnessScript = offered_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ features+ !weight = offered_htlc_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !seqNo = if has_anchors features then 1 else 0+ !tx = mk_spending_tx op seqNo destScript+ outputValue 0+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- revoked commitment spends ------------------------------------------++-- | Spend a revoked to_local output using the revocation key.+--+-- The caller signs with the revocation privkey and uses+-- 'to_local_witness_revoke' from bolt3.+spend_revoked_to_local+ :: OutPoint+ -- ^ Outpoint of the to_local output.+ -> Satoshi+ -- ^ Value of the to_local output.+ -> RevocationPubkey+ -> ToSelfDelay+ -> LocalDelayedPubkey+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> SpendingTx+spend_revoked_to_local !op !value !revpk !delay+ !delayedpk !destScript !feerate =+ let !witnessScript =+ to_local_script revpk delay delayedpk+ !weight = to_local_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !tx = mk_spending_tx op 0xFFFFFFFF destScript+ outputValue 0+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- | Spend a revoked HTLC output using the revocation key.+--+-- The caller signs with the revocation privkey and uses+-- 'offered_htlc_witness_revoke' or+-- 'received_htlc_witness_revoke' from bolt3, depending on+-- the output type.+spend_revoked_htlc+ :: OutPoint+ -- ^ Outpoint of the HTLC output.+ -> Satoshi+ -- ^ Value of the HTLC output.+ -> OutputType+ -- ^ Whether offered or received HTLC.+ -> RevocationPubkey+ -> CommitmentKeys+ -> ChannelFeatures+ -> PaymentHash+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> Maybe SpendingTx+spend_revoked_htlc !op !value !otype !revpk !keys+ !features !ph !destScript !feerate =+ case otype of+ OutputOfferedHTLC _ ->+ let !witnessScript = offered_htlc_script+ revpk+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ ph+ features+ !weight = offered_htlc_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !tx = mk_spending_tx op 0xFFFFFFFF destScript+ outputValue 0+ in Just (SpendingTx tx witnessScript value+ SIGHASH_ALL)+ OutputReceivedHTLC expiry ->+ let !witnessScript = received_htlc_script+ revpk+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ ph+ expiry+ features+ !weight = accepted_htlc_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !tx = mk_spending_tx op 0xFFFFFFFF destScript+ outputValue 0+ in Just (SpendingTx tx witnessScript value+ SIGHASH_ALL)+ _ -> Nothing++-- | Spend a revoked second-stage HTLC output (HTLC-timeout or+-- HTLC-success output) using the revocation key.+--+-- The output of a revoked HTLC-timeout/success tx uses the+-- to_local script. The caller signs with the revocation privkey+-- and uses 'htlc_output_witness_revoke'.+spend_revoked_htlc_output+ :: OutPoint+ -- ^ Outpoint of the second-stage output.+ -> Satoshi+ -- ^ Value of the second-stage output.+ -> RevocationPubkey+ -> ToSelfDelay+ -> LocalDelayedPubkey+ -> Script+ -- ^ Destination scriptPubKey.+ -> FeeratePerKw+ -> SpendingTx+spend_revoked_htlc_output !op !value !revpk !delay+ !delayedpk !destScript !feerate =+ let !witnessScript =+ to_local_script revpk delay delayedpk+ !weight = to_local_penalty_input_weight+ + penalty_tx_base_weight+ !fee = spending_fee feerate weight+ !outputValue =+ Satoshi (unSatoshi value - unSatoshi fee)+ !tx = mk_spending_tx op 0xFFFFFFFF destScript+ outputValue 0+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- | Construct a batched penalty transaction spending multiple+-- revoked outputs.+--+-- Per BOLT #5, up to 483 bidirectional HTLCs plus to_local can+-- be resolved in a single penalty transaction (within the+-- 400,000 weight limit). The caller signs each input with the+-- revocation privkey.+spend_revoked_batch :: PenaltyContext -> SpendingTx+spend_revoked_batch !ctx =+ let !outs = pc_outputs ctx+ !destScript = pc_destination ctx+ !feerate = pc_feerate ctx++ -- Calculate total input value and weight+ !(totalValue, totalWeight) =+ go (Satoshi 0) penalty_tx_base_weight+ (NE.toList outs)++ !fee = spending_fee feerate totalWeight+ !outputValue =+ Satoshi (unSatoshi totalValue - unSatoshi fee)++ -- Build inputs+ !txInputs = fmap mkPenaltyInput outs++ -- Single output+ !txOutput = TxOut+ (unSatoshi outputValue)+ (unScript destScript)++ !tx = Tx+ { tx_version = 2+ , tx_inputs = txInputs+ , tx_outputs = txOutput :| []+ , tx_witnesses = []+ , tx_locktime = 0+ }++ !witnessScript = Script BS.empty+ in SpendingTx tx witnessScript totalValue SIGHASH_ALL+ where+ go !totalVal !totalWt [] = (totalVal, totalWt)+ go !totalVal !totalWt (uo:rest) =+ let !w = case uo_type uo of+ Revoke _ ->+ to_local_penalty_input_weight+ RevokeHTLC _ (OutputOfferedHTLC _) ->+ offered_htlc_penalty_input_weight+ RevokeHTLC _ (OutputReceivedHTLC _) ->+ accepted_htlc_penalty_input_weight+ _ -> 0+ !v = Satoshi+ (unSatoshi totalVal + unSatoshi (uo_value uo))+ in go v (totalWt + w) rest++ mkPenaltyInput !uo =+ TxIn+ { txin_prevout = uo_outpoint uo+ , txin_script_sig = BS.empty+ , txin_sequence = 0xFFFFFFFF+ }++-- anchor spends ------------------------------------------------------++-- | Spend an anchor output as the owner (immediately).+--+-- The caller signs with the funding privkey and uses+-- 'anchor_witness_owner' from bolt3.+spend_anchor_owner+ :: OutPoint+ -- ^ Outpoint of the anchor output.+ -> Satoshi+ -- ^ Value of the anchor output (330 sats).+ -> FundingPubkey+ -> Script+ -- ^ Destination scriptPubKey.+ -> SpendingTx+spend_anchor_owner !op !value !fundpk !destScript =+ let !witnessScript = anchor_script fundpk+ !tx = mk_spending_tx op 0xFFFFFFFE destScript+ value 0+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- | Spend an anchor output as anyone (after 16 blocks).+--+-- Uses 'anchor_witness_anyone' from bolt3 (empty signature).+spend_anchor_anyone+ :: OutPoint+ -- ^ Outpoint of the anchor output.+ -> Satoshi+ -- ^ Value of the anchor output (330 sats).+ -> FundingPubkey+ -> Script+ -- ^ Destination scriptPubKey.+ -> SpendingTx+spend_anchor_anyone !op !value !fundpk !destScript =+ let !witnessScript = anchor_script fundpk+ !tx = mk_spending_tx op 16 destScript value 0+ in SpendingTx tx witnessScript value SIGHASH_ALL++-- internal helpers ---------------------------------------------------++-- | Build a simple single-input single-output spending tx.+mk_spending_tx+ :: OutPoint -- ^ Input outpoint+ -> Word32 -- ^ Input nSequence+ -> Script -- ^ Output scriptPubKey+ -> Satoshi -- ^ Output value+ -> Word32 -- ^ Locktime+ -> Tx+mk_spending_tx !op !seqNo !destScript !outputValue+ !locktime =+ let !txIn = TxIn+ { txin_prevout = op+ , txin_script_sig = BS.empty+ , txin_sequence = seqNo+ }+ !txOut = TxOut+ { txout_value = unSatoshi outputValue+ , txout_script_pubkey = unScript destScript+ }+ in Tx+ { tx_version = 2+ , tx_inputs = txIn :| []+ , tx_outputs = txOut :| []+ , tx_witnesses = []+ , tx_locktime = locktime+ }++-- | Convert a bolt3 HTLCTx to a ppad-tx Tx.+htlc_tx_to_tx :: HTLCTx -> Tx+htlc_tx_to_tx !htx =+ let !txIn = TxIn+ { txin_prevout = htx_input_outpoint htx+ , txin_script_sig = BS.empty+ , txin_sequence =+ unSequence (htx_input_sequence htx)+ }+ !txOut = TxOut+ { txout_value =+ unSatoshi (htx_output_value htx)+ , txout_script_pubkey =+ unScript (htx_output_script htx)+ }+ in Tx+ { tx_version = htx_version htx+ , tx_inputs = txIn :| []+ , tx_outputs = txOut :| []+ , tx_witnesses = []+ , tx_locktime =+ unLocktime (htx_locktime htx)+ }
+ lib/Lightning/Protocol/BOLT5/Types.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT5.Types+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Types for BOLT #5 on-chain transaction handling.++module Lightning.Protocol.BOLT5.Types (+ -- * Close identification+ CloseType(..)++ -- * Output classification+ , UnresolvedOutput(..)+ , OutputResolution(..)++ -- * Spending transactions+ , SpendingTx(..)++ -- * Penalty batching+ , PenaltyContext(..)++ -- * Weight constants (Appendix A)+ , to_local_penalty_witness_weight+ , offered_htlc_penalty_witness_weight+ , accepted_htlc_penalty_witness_weight+ , to_local_penalty_input_weight+ , offered_htlc_penalty_input_weight+ , accepted_htlc_penalty_input_weight+ , to_remote_input_weight+ , penalty_tx_base_weight+ , max_standard_weight++ -- * Fee calculation+ , spending_fee+ ) where++import Bitcoin.Prim.Tx (Tx(..))+import Bitcoin.Prim.Tx.Sighash (SighashType(..))+import Data.List.NonEmpty (NonEmpty)+import Data.Word (Word64)+import GHC.Generics (Generic)+import Lightning.Protocol.BOLT3.Types+import Lightning.Protocol.BOLT3.Tx (+ CommitmentKeys(..)+ , OutputType(..)+ )++-- close identification -----------------------------------------------++-- | What kind of close was detected on chain.+data CloseType+ = MutualClose+ -- ^ Cooperative closure agreed by both parties.+ | LocalCommitClose+ -- ^ Our commitment transaction was broadcast.+ | RemoteCommitClose+ -- ^ The remote party's commitment transaction was broadcast.+ | RevokedCommitClose+ -- ^ A revoked (outdated) commitment transaction was broadcast.+ deriving (Eq, Show, Generic)++-- output classification ----------------------------------------------++-- | An unresolved commitment transaction output.+data UnresolvedOutput = UnresolvedOutput+ { uo_outpoint :: !OutPoint+ , uo_value :: {-# UNPACK #-} !Satoshi+ , uo_type :: !OutputResolution+ } deriving (Eq, Show, Generic)++-- | How to resolve an output, per BOLT #5 rules.+data OutputResolution+ = Resolved+ -- ^ Already resolved (e.g. to_remote on local commit).+ | SpendToLocal+ !ToSelfDelay !RevocationPubkey !LocalDelayedPubkey+ -- ^ Spend to_local after CSV delay.+ | SpendHTLCTimeout+ !HTLC !CommitmentKeys !ChannelFeatures+ -- ^ Spend via HTLC-timeout second-stage tx (local commit,+ -- local offer).+ | SpendHTLCSuccess+ !HTLC !CommitmentKeys !ChannelFeatures+ -- ^ Spend via HTLC-success second-stage tx (local commit,+ -- remote offer).+ | SpendHTLCTimeoutDirect !HTLC+ -- ^ Spend HTLC directly after timeout (remote commit,+ -- local offer).+ | SpendHTLCPreimageDirect !HTLC+ -- ^ Spend HTLC directly with preimage (remote commit,+ -- remote offer).+ | Revoke !RevocationPubkey+ -- ^ Spend revoked to_local with revocation key.+ | RevokeHTLC !RevocationPubkey !OutputType+ -- ^ Spend revoked HTLC output with revocation key.+ | AnchorSpend !FundingPubkey+ -- ^ Spend anchor output.+ deriving (Eq, Show, Generic)++-- spending transactions ----------------------------------------------++-- | Unsigned spending transaction, ready for caller to sign.+--+-- The caller uses bolt3 witness constructors to assemble the+-- final witness after signing.+data SpendingTx = SpendingTx+ { stx_tx :: !Tx+ -- ^ The unsigned transaction.+ , stx_input_script :: !Script+ -- ^ Witness script for the input being spent.+ , stx_input_value :: {-# UNPACK #-} !Satoshi+ -- ^ Value of the input being spent (for sighash).+ , stx_sighash_type :: !SighashType+ -- ^ Sighash type to use when signing.+ } deriving (Eq, Show, Generic)++-- penalty batching ---------------------------------------------------++-- | Context for constructing batched penalty transactions.+data PenaltyContext = PenaltyContext+ { pc_outputs :: !(NonEmpty UnresolvedOutput)+ -- ^ Revoked outputs to sweep (must be non-empty).+ , pc_revocation_key :: !RevocationPubkey+ -- ^ Revocation pubkey for all outputs.+ , pc_destination :: !Script+ -- ^ Destination scriptPubKey.+ , pc_feerate :: !FeeratePerKw+ -- ^ Fee rate for the penalty transaction.+ } deriving (Eq, Show, Generic)++-- weight constants (BOLT #5 Appendix A) ------------------------------++-- | Expected weight of the to_local penalty transaction witness+-- (160 bytes).+to_local_penalty_witness_weight :: Word64+to_local_penalty_witness_weight = 160++-- | Expected weight of the offered_htlc penalty transaction+-- witness (243 bytes).+offered_htlc_penalty_witness_weight :: Word64+offered_htlc_penalty_witness_weight = 243++-- | Expected weight of the accepted_htlc penalty transaction+-- witness (249 bytes).+accepted_htlc_penalty_witness_weight :: Word64+accepted_htlc_penalty_witness_weight = 249++-- | Weight of a to_local penalty input (164 + 160 = 324 bytes).+to_local_penalty_input_weight :: Word64+to_local_penalty_input_weight = 324++-- | Weight of an offered_htlc penalty input+-- (164 + 243 = 407 bytes).+offered_htlc_penalty_input_weight :: Word64+offered_htlc_penalty_input_weight = 407++-- | Weight of an accepted_htlc penalty input+-- (164 + 249 = 413 bytes).+accepted_htlc_penalty_input_weight :: Word64+accepted_htlc_penalty_input_weight = 413++-- | Weight of a to_remote P2WPKH input+-- (108 + 164 = 272 bytes).+to_remote_input_weight :: Word64+to_remote_input_weight = 272++-- | Base weight of a penalty transaction (4*53 + 2 = 214 bytes).+--+-- Non-witness: version(4) + input_count(1) + output_count(1) ++-- value(8) + script_len(1) + p2wsh_script(34) + locktime(4) = 53+-- Witness header: 2 bytes.+penalty_tx_base_weight :: Word64+penalty_tx_base_weight = 214++-- | Maximum standard transaction weight (400,000 bytes).+max_standard_weight :: Word64+max_standard_weight = 400000++-- fee calculation ----------------------------------------------------++-- | Calculate the fee for a spending transaction given its weight.+--+-- @fee = feerate_per_kw * weight / 1000@+spending_fee :: FeeratePerKw -> Word64 -> Satoshi+spending_fee (FeeratePerKw !rate) !weight =+ Satoshi ((fromIntegral rate * weight) `div` 1000)+{-# INLINE spending_fee #-}
+ ppad-bolt5.cabal view
@@ -0,0 +1,92 @@+cabal-version: 3.0+name: ppad-bolt5+version: 0.0.1+synopsis: On-chain transaction handling per BOLT #5+license: MIT+license-file: LICENSE+author: Jared Tobin+maintainer: jared@ppad.tech+category: Cryptography+build-type: Simple+tested-with: GHC == 9.10.3+extra-doc-files: CHANGELOG+description:+ On-chain transaction handling, per+ [BOLT #5](https://github.com/lightning/bolts/blob/master/05-onchain.md).++source-repository head+ type: git+ location: git.ppad.tech/bolt5.git++library+ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options:+ -Wall+ exposed-modules:+ Lightning.Protocol.BOLT5+ Lightning.Protocol.BOLT5.Detect+ Lightning.Protocol.BOLT5.Spend+ Lightning.Protocol.BOLT5.Types+ build-depends:+ base >= 4.9 && < 5+ , bytestring >= 0.9 && < 0.13+ , ppad-bolt3 >= 0.0.1 && < 0.1+ , ppad-sha256 >= 0.3.2 && < 0.4+ , ppad-tx >= 0.1 && < 0.2++test-suite bolt5-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs++ ghc-options:+ -rtsopts -Wall -O2++ build-depends:+ base+ , bytestring+ , ppad-bolt3+ , ppad-bolt5+ , ppad-tx+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , QuickCheck++benchmark bolt5-bench+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Main.hs++ ghc-options:+ -rtsopts -O2 -Wall -fno-warn-orphans++ build-depends:+ base+ , bytestring+ , criterion+ , deepseq+ , ppad-bolt3+ , ppad-bolt5+ , ppad-tx++benchmark bolt5-weigh+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Weight.hs++ ghc-options:+ -rtsopts -O2 -Wall -fno-warn-orphans++ build-depends:+ base+ , bytestring+ , deepseq+ , ppad-bolt3+ , ppad-bolt5+ , ppad-tx+ , weigh
+ test/Main.hs view
@@ -0,0 +1,764 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Bitcoin.Prim.Tx (TxOut(..))+import Bitcoin.Prim.Tx.Sighash (SighashType(..))+import qualified Data.ByteString as BS+import Data.List.NonEmpty (NonEmpty(..))+import Lightning.Protocol.BOLT3 hiding+ (txout_value, txout_script)+import qualified Lightning.Protocol.BOLT5 as B5+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain $ testGroup "ppad-bolt5" [+ types_tests+ , detect_tests+ , classify_tests+ , spend_tests+ , htlc_spend_tests+ , remote_spend_tests+ , revoked_htlc_spend_tests+ , weight_tests+ , property_tests+ ]++-- test fixtures ------------------------------------------------------++-- Dummy 33-byte pubkey+dummyPubkeyBytes :: BS.ByteString+dummyPubkeyBytes = BS.pack $+ 0x02 : replicate 32 0x01++-- Dummy 32-byte hash+dummyHash32 :: BS.ByteString+dummyHash32 = BS.replicate 32 0xAA++-- Dummy 32-byte preimage+dummyPreimage :: BS.ByteString+dummyPreimage = BS.replicate 32 0xBB++dummyTxId :: TxId+dummyTxId = case mkTxId (BS.replicate 32 0x00) of+ Just tid -> tid+ Nothing -> error "impossible"++dummyOutPoint :: OutPoint+dummyOutPoint = OutPoint dummyTxId 0++dummyPubkey :: Pubkey+dummyPubkey = case pubkey dummyPubkeyBytes of+ Just pk -> pk+ Nothing -> error "impossible"++dummyRevocationPubkey :: RevocationPubkey+dummyRevocationPubkey = RevocationPubkey dummyPubkey++dummyLocalDelayedPubkey :: LocalDelayedPubkey+dummyLocalDelayedPubkey = LocalDelayedPubkey dummyPubkey++dummyLocalHtlcPubkey :: LocalHtlcPubkey+dummyLocalHtlcPubkey = LocalHtlcPubkey dummyPubkey++dummyRemoteHtlcPubkey :: RemoteHtlcPubkey+dummyRemoteHtlcPubkey = RemoteHtlcPubkey dummyPubkey++dummyFundingPubkey :: FundingPubkey+dummyFundingPubkey = FundingPubkey dummyPubkey++dummyPaymentHash :: PaymentHash+dummyPaymentHash = case payment_hash dummyHash32 of+ Just ph -> ph+ Nothing -> error "impossible"++dummyDelay :: ToSelfDelay+dummyDelay = ToSelfDelay 144++dummyFeerate :: FeeratePerKw+dummyFeerate = FeeratePerKw 253++dummyFeatures :: ChannelFeatures+dummyFeatures = ChannelFeatures False++dummyFeaturesAnchors :: ChannelFeatures+dummyFeaturesAnchors = ChannelFeatures True++dummyDestScript :: Script+dummyDestScript = Script $ BS.pack+ [0x00, 0x14] <> BS.replicate 20 0xCC++dummyKeys :: CommitmentKeys+dummyKeys = CommitmentKeys+ { ck_revocation_pubkey = dummyRevocationPubkey+ , ck_local_delayed = dummyLocalDelayedPubkey+ , ck_local_htlc = dummyLocalHtlcPubkey+ , ck_remote_htlc = dummyRemoteHtlcPubkey+ , ck_local_payment = LocalPubkey dummyPubkey+ , ck_remote_payment = RemotePubkey dummyPubkey+ , ck_local_funding = dummyFundingPubkey+ , ck_remote_funding = dummyFundingPubkey+ }++dummyHTLC :: HTLC+dummyHTLC = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 1000000+ , htlc_payment_hash = dummyPaymentHash+ , htlc_cltv_expiry = CltvExpiry 500000+ }++dummyReceivedHTLC :: HTLC+dummyReceivedHTLC = dummyHTLC+ { htlc_direction = HTLCReceived }++dummyHTLCContext :: HTLCContext+dummyHTLCContext = HTLCContext+ { hc_commitment_txid = dummyTxId+ , hc_output_index = 0+ , hc_htlc = dummyHTLC+ , hc_to_self_delay = dummyDelay+ , hc_feerate = dummyFeerate+ , hc_features = dummyFeatures+ , hc_revocation_pubkey = dummyRevocationPubkey+ , hc_local_delayed = dummyLocalDelayedPubkey+ }++-- Script that matches what findHTLC expects for offered+offeredScript :: Script+offeredScript = to_p2wsh $ offered_htlc_script+ dummyRevocationPubkey+ dummyRemoteHtlcPubkey+ dummyLocalHtlcPubkey+ dummyPaymentHash+ dummyFeatures++-- Script that matches what findHTLC expects for received+receivedScript :: Script+receivedScript = to_p2wsh $ received_htlc_script+ dummyRevocationPubkey+ dummyRemoteHtlcPubkey+ dummyLocalHtlcPubkey+ dummyPaymentHash+ (CltvExpiry 500000)+ dummyFeatures++toLocalScript :: Script+toLocalScript = to_p2wsh $ to_local_script+ dummyRevocationPubkey dummyDelay+ dummyLocalDelayedPubkey++-- CommitmentTx with to_local + to_remote outputs+dummyLocalCommitTx :: CommitmentTx+dummyLocalCommitTx = CommitmentTx+ { ctx_version = 2+ , ctx_locktime = Locktime 0+ , ctx_input_outpoint = dummyOutPoint+ , ctx_input_sequence = Sequence 0+ , ctx_outputs =+ [ TxOutput (Satoshi 50000) toLocalScript+ OutputToLocal+ , TxOutput (Satoshi 30000) dummyDestScript+ OutputToRemote+ ]+ , ctx_funding_script = dummyDestScript+ }++-- CommitmentTx with HTLC outputs+dummyLocalCommitWithHTLCs :: CommitmentTx+dummyLocalCommitWithHTLCs = CommitmentTx+ { ctx_version = 2+ , ctx_locktime = Locktime 0+ , ctx_input_outpoint = dummyOutPoint+ , ctx_input_sequence = Sequence 0+ , ctx_outputs =+ [ TxOutput (Satoshi 50000) toLocalScript+ OutputToLocal+ , TxOutput (Satoshi 30000) dummyDestScript+ OutputToRemote+ , TxOutput (Satoshi 10000) offeredScript+ (OutputOfferedHTLC (CltvExpiry 500000))+ , TxOutput (Satoshi 10000) receivedScript+ (OutputReceivedHTLC (CltvExpiry 500000))+ ]+ , ctx_funding_script = dummyDestScript+ }++-- A distinct CommitmentTx (different locktime)+dummyRemoteCommitTx :: CommitmentTx+dummyRemoteCommitTx = CommitmentTx+ { ctx_version = 2+ , ctx_locktime = Locktime 1+ , ctx_input_outpoint = dummyOutPoint+ , ctx_input_sequence = Sequence 0+ , ctx_outputs =+ [ TxOutput (Satoshi 40000) toLocalScript+ OutputToLocal+ , TxOutput (Satoshi 20000) dummyDestScript+ OutputToRemote+ ]+ , ctx_funding_script = dummyDestScript+ }++-- types tests --------------------------------------------------------++types_tests :: TestTree+types_tests = testGroup "Types" [+ testCase "CloseType constructors" $ do+ B5.MutualClose @?= B5.MutualClose+ B5.LocalCommitClose @?= B5.LocalCommitClose+ B5.RemoteCommitClose @?= B5.RemoteCommitClose+ B5.RevokedCommitClose @?= B5.RevokedCommitClose++ , testCase "spending_fee calculation" $ do+ let fee = B5.spending_fee (FeeratePerKw 1000) 500+ fee @?= Satoshi 500++ , testCase "spending_fee at low feerate" $ do+ let fee = B5.spending_fee (FeeratePerKw 253) 324+ -- 253 * 324 / 1000 = 81.972 -> 81+ fee @?= Satoshi 81++ , testCase "weight constants" $ do+ B5.to_local_penalty_witness_weight @?= 160+ B5.to_local_penalty_input_weight @?= 324+ B5.offered_htlc_penalty_input_weight @?= 407+ B5.accepted_htlc_penalty_input_weight @?= 413+ B5.to_remote_input_weight @?= 272+ B5.max_standard_weight @?= 400000+ ]++-- detect tests -------------------------------------------------------++detect_tests :: TestTree+detect_tests = testGroup "Detect" [+ testCase "extract_preimage_offered - valid" $ do+ let sig = BS.replicate 72 0x30+ preimage = dummyPreimage+ wit = Witness [sig, preimage]+ case B5.extract_preimage_offered wit of+ Just (PaymentPreimage bs) ->+ bs @?= preimage+ Nothing ->+ assertFailure "expected preimage"++ , testCase "extract_preimage_offered - wrong length" $ do+ let sig = BS.replicate 72 0x30+ badPreimage = BS.replicate 31 0xBB+ wit = Witness [sig, badPreimage]+ B5.extract_preimage_offered wit @?= Nothing++ , testCase "extract_preimage_offered - wrong count" $ do+ let sig = BS.replicate 72 0x30+ wit = Witness [sig]+ B5.extract_preimage_offered wit @?= Nothing++ , testCase "extract_preimage_htlc_success - valid" $ do+ let zero = BS.empty+ remoteSig = BS.replicate 72 0x30+ localSig = BS.replicate 72 0x30+ preimage = dummyPreimage+ wit = Witness [zero, remoteSig, localSig, preimage]+ case B5.extract_preimage_htlc_success wit of+ Just (PaymentPreimage bs) ->+ bs @?= preimage+ Nothing ->+ assertFailure "expected preimage"++ , testCase "extract_preimage_htlc_success - wrong count" $ do+ let wit = Witness [BS.empty, dummyPreimage]+ B5.extract_preimage_htlc_success wit @?= Nothing++ , testCase "htlc_timed_out - at expiry" $ do+ let htlc = dummyHTLC+ { htlc_cltv_expiry = CltvExpiry 500000 }+ B5.htlc_timed_out 500000 htlc @?= True++ , testCase "htlc_timed_out - past expiry" $ do+ let htlc = dummyHTLC+ { htlc_cltv_expiry = CltvExpiry 500000 }+ B5.htlc_timed_out 500001 htlc @?= True++ , testCase "htlc_timed_out - before expiry" $ do+ let htlc = dummyHTLC+ { htlc_cltv_expiry = CltvExpiry 500000 }+ B5.htlc_timed_out 499999 htlc @?= False+ ]++-- classify tests -----------------------------------------------------++classify_tests :: TestTree+classify_tests = testGroup "Classify" [+ testCase "identify_close - local commit" $ do+ case encode_tx_for_signing dummyLocalCommitTx of+ Nothing -> assertFailure "encode failed"+ Just localBytes ->+ B5.identify_close+ dummyLocalCommitTx+ dummyRemoteCommitTx+ localBytes+ @?= Just B5.LocalCommitClose++ , testCase "identify_close - remote commit" $ do+ case encode_tx_for_signing dummyRemoteCommitTx of+ Nothing -> assertFailure "encode failed"+ Just remoteBytes ->+ B5.identify_close+ dummyLocalCommitTx+ dummyRemoteCommitTx+ remoteBytes+ @?= Just B5.RemoteCommitClose++ , testCase "identify_close - no match" $ do+ B5.identify_close+ dummyLocalCommitTx+ dummyRemoteCommitTx+ "unknown bytes"+ @?= Nothing++ , testCase "classify_local - to_local and to_remote" $ do+ let outs = B5.classify_local_commit_outputs+ dummyLocalCommitTx dummyKeys+ dummyDelay dummyFeatures []+ length outs @?= 2+ case outs of+ [o1, o2] -> do+ case B5.uo_type o1 of+ B5.SpendToLocal d rk dk -> do+ d @?= dummyDelay+ rk @?= dummyRevocationPubkey+ dk @?= dummyLocalDelayedPubkey+ other -> assertFailure $+ "expected SpendToLocal, got " <> show other+ B5.uo_type o2 @?= B5.Resolved+ _ -> assertFailure "expected 2 outputs"++ , testCase "classify_local - HTLC outputs" $ do+ let outs = B5.classify_local_commit_outputs+ dummyLocalCommitWithHTLCs dummyKeys+ dummyDelay dummyFeatures+ [dummyHTLC, dummyReceivedHTLC]+ length outs @?= 4+ case outs of+ [_, _, o3, o4] -> do+ case B5.uo_type o3 of+ B5.SpendHTLCTimeout _ _ _ -> pure ()+ other -> assertFailure $+ "expected SpendHTLCTimeout, got "+ <> show other+ case B5.uo_type o4 of+ B5.SpendHTLCSuccess _ _ _ -> pure ()+ other -> assertFailure $+ "expected SpendHTLCSuccess, got "+ <> show other+ _ -> assertFailure "expected 4 outputs"++ , testCase "classify_remote - HTLC outputs" $ do+ let commitTx = CommitmentTx+ { ctx_version = 2+ , ctx_locktime = Locktime 0+ , ctx_input_outpoint = dummyOutPoint+ , ctx_input_sequence = Sequence 0+ , ctx_outputs =+ [ TxOutput (Satoshi 50000) toLocalScript+ OutputToLocal+ , TxOutput (Satoshi 10000) offeredScript+ (OutputOfferedHTLC+ (CltvExpiry 500000))+ , TxOutput (Satoshi 10000) receivedScript+ (OutputReceivedHTLC+ (CltvExpiry 500000))+ ]+ , ctx_funding_script = dummyDestScript+ }+ outs = B5.classify_remote_commit_outputs+ commitTx dummyKeys dummyFeatures+ [dummyHTLC, dummyReceivedHTLC]+ length outs @?= 3+ case outs of+ [o1, o2, o3] -> do+ B5.uo_type o1 @?= B5.Resolved+ case B5.uo_type o2 of+ B5.SpendHTLCPreimageDirect _ -> pure ()+ other -> assertFailure $+ "expected SpendHTLCPreimageDirect, got "+ <> show other+ case B5.uo_type o3 of+ B5.SpendHTLCTimeoutDirect _ -> pure ()+ other -> assertFailure $+ "expected SpendHTLCTimeoutDirect, got "+ <> show other+ _ -> assertFailure "expected 3 outputs"++ , testCase "classify_revoked - to_local revoked" $ do+ let outs = B5.classify_revoked_commit_outputs+ dummyLocalCommitWithHTLCs dummyKeys+ dummyRevocationPubkey dummyFeatures+ [dummyHTLC, dummyReceivedHTLC]+ length outs @?= 4+ case outs of+ [o1, o2, o3, o4] -> do+ B5.uo_type o1+ @?= B5.Revoke dummyRevocationPubkey+ B5.uo_type o2 @?= B5.Resolved+ case B5.uo_type o3 of+ B5.RevokeHTLC _ (OutputOfferedHTLC _) ->+ pure ()+ other -> assertFailure $+ "expected RevokeHTLC offered, got "+ <> show other+ case B5.uo_type o4 of+ B5.RevokeHTLC _ (OutputReceivedHTLC _) ->+ pure ()+ other -> assertFailure $+ "expected RevokeHTLC received, got "+ <> show other+ _ -> assertFailure "expected 4 outputs"++ , testCase "classify_local - empty commit" $ do+ let emptyCommit = CommitmentTx+ { ctx_version = 2+ , ctx_locktime = Locktime 0+ , ctx_input_outpoint = dummyOutPoint+ , ctx_input_sequence = Sequence 0+ , ctx_outputs = []+ , ctx_funding_script = dummyDestScript+ }+ B5.classify_local_commit_outputs+ emptyCommit dummyKeys dummyDelay+ dummyFeatures []+ @?= []+ ]++-- spend tests --------------------------------------------------------++spend_tests :: TestTree+spend_tests = testGroup "Spend" [+ testCase "spend_to_local produces valid tx" $ do+ let stx = B5.spend_to_local+ dummyOutPoint+ (Satoshi 100000)+ dummyRevocationPubkey+ dummyDelay+ dummyLocalDelayedPubkey+ dummyDestScript+ dummyFeerate+ tx = B5.stx_tx stx+ -- Version should be 2+ tx_version tx @?= 2+ -- Single input+ length (tx_inputs tx) @?= 1+ -- Single output+ length (tx_outputs tx) @?= 1+ -- Output value should be less than input+ let outVal = txout_value+ (head' (tx_outputs tx))+ assertBool "output < input"+ (outVal < 100000)+ -- Sighash should be ALL+ B5.stx_sighash_type stx @?= SIGHASH_ALL+ -- Input value should match+ B5.stx_input_value stx @?= Satoshi 100000+ -- nSequence should encode delay+ let inp = head' (tx_inputs tx)+ txin_sequence inp @?= fromIntegral+ (unToSelfDelay dummyDelay)++ , testCase "spend_to_local fee deduction" $ do+ let value = Satoshi 100000+ stx = B5.spend_to_local+ dummyOutPoint value+ dummyRevocationPubkey dummyDelay+ dummyLocalDelayedPubkey+ dummyDestScript dummyFeerate+ tx = B5.stx_tx stx+ outVal = txout_value+ (head' (tx_outputs tx))+ expectedFee = B5.spending_fee dummyFeerate+ (B5.to_local_penalty_input_weight+ + B5.penalty_tx_base_weight)+ Satoshi outVal @?=+ Satoshi (unSatoshi value+ - unSatoshi expectedFee)++ , testCase "spend_revoked_to_local nSequence" $ do+ let stx = B5.spend_revoked_to_local+ dummyOutPoint (Satoshi 100000)+ dummyRevocationPubkey dummyDelay+ dummyLocalDelayedPubkey+ dummyDestScript dummyFeerate+ tx = B5.stx_tx stx+ inp = head' (tx_inputs tx)+ txin_sequence inp @?= 0xFFFFFFFF++ , testCase "spend_anchor_owner tx structure" $ do+ let stx = B5.spend_anchor_owner+ dummyOutPoint (Satoshi 330)+ dummyFundingPubkey dummyDestScript+ tx = B5.stx_tx stx+ tx_version tx @?= 2+ tx_locktime tx @?= 0+ B5.stx_sighash_type stx @?= SIGHASH_ALL++ , testCase "spend_anchor_anyone nSequence" $ do+ let stx = B5.spend_anchor_anyone+ dummyOutPoint (Satoshi 330)+ dummyFundingPubkey dummyDestScript+ tx = B5.stx_tx stx+ inp = head' (tx_inputs tx)+ txin_sequence inp @?= 16++ , testCase "spend_htlc_output is spend_to_local" $ do+ let stx1 = B5.spend_to_local+ dummyOutPoint (Satoshi 50000)+ dummyRevocationPubkey dummyDelay+ dummyLocalDelayedPubkey+ dummyDestScript dummyFeerate+ stx2 = B5.spend_htlc_output+ dummyOutPoint (Satoshi 50000)+ dummyRevocationPubkey dummyDelay+ dummyLocalDelayedPubkey+ dummyDestScript dummyFeerate+ B5.stx_tx stx1 @?= B5.stx_tx stx2+ B5.stx_input_script stx1 @?=+ B5.stx_input_script stx2++ , testCase "spend_revoked_batch total value" $ do+ let op1 = OutPoint dummyTxId 0+ op2 = OutPoint dummyTxId 1+ uo1 = B5.UnresolvedOutput op1 (Satoshi 50000)+ (B5.Revoke dummyRevocationPubkey)+ uo2 = B5.UnresolvedOutput op2 (Satoshi 30000)+ (B5.Revoke dummyRevocationPubkey)+ pctx = B5.PenaltyContext+ { B5.pc_outputs = uo1 :| [uo2]+ , B5.pc_revocation_key =+ dummyRevocationPubkey+ , B5.pc_destination = dummyDestScript+ , B5.pc_feerate = dummyFeerate+ }+ stx = B5.spend_revoked_batch pctx+ tx = B5.stx_tx stx+ outVal = txout_value+ (head' (tx_outputs tx))+ -- Output should be less than total input+ assertBool "output < total input"+ (outVal < 80000)+ -- Should have 2 inputs+ length (tx_inputs tx) @?= 2+ ]++-- htlc spend tests ---------------------------------------------------++htlc_spend_tests :: TestTree+htlc_spend_tests = testGroup "HTLC Spend" [+ testCase "spend_htlc_timeout produces valid tx" $ do+ let stx = B5.spend_htlc_timeout+ dummyHTLCContext dummyKeys+ tx = B5.stx_tx stx+ tx_version tx @?= 2+ length (tx_inputs tx) @?= 1+ length (tx_outputs tx) @?= 1+ B5.stx_sighash_type stx @?= SIGHASH_ALL+ B5.stx_input_value stx+ @?= msat_to_sat (MilliSatoshi 1000000)++ , testCase "spend_htlc_success produces valid tx" $ do+ let ctx = dummyHTLCContext+ { hc_htlc = dummyReceivedHTLC }+ stx = B5.spend_htlc_success ctx dummyKeys+ tx = B5.stx_tx stx+ tx_version tx @?= 2+ length (tx_inputs tx) @?= 1+ B5.stx_sighash_type stx @?= SIGHASH_ALL++ , testCase "spend_htlc_timeout anchors sighash" $ do+ let ctx = dummyHTLCContext+ { hc_features = dummyFeaturesAnchors }+ stx = B5.spend_htlc_timeout ctx dummyKeys+ B5.stx_sighash_type stx+ @?= SIGHASH_SINGLE_ANYONECANPAY++ , testCase "spend_htlc_success anchors sighash" $ do+ let ctx = dummyHTLCContext+ { hc_htlc = dummyReceivedHTLC+ , hc_features = dummyFeaturesAnchors+ }+ stx = B5.spend_htlc_success ctx dummyKeys+ B5.stx_sighash_type stx+ @?= SIGHASH_SINGLE_ANYONECANPAY+ ]++-- remote spend tests -------------------------------------------------++remote_spend_tests :: TestTree+remote_spend_tests = testGroup "Remote Spend" [+ testCase "spend_remote_htlc_timeout structure" $ do+ let stx = B5.spend_remote_htlc_timeout+ dummyOutPoint (Satoshi 50000)+ dummyHTLC dummyKeys dummyFeatures+ dummyDestScript dummyFeerate+ tx = B5.stx_tx stx+ tx_version tx @?= 2+ length (tx_inputs tx) @?= 1+ B5.stx_sighash_type stx @?= SIGHASH_ALL+ B5.stx_input_value stx @?= Satoshi 50000+ -- locktime should be HTLC CLTV expiry+ tx_locktime tx @?= 500000++ , testCase "spend_remote_htlc_timeout fee deduction" $ do+ let value = Satoshi 50000+ stx = B5.spend_remote_htlc_timeout+ dummyOutPoint value dummyHTLC+ dummyKeys dummyFeatures+ dummyDestScript dummyFeerate+ tx = B5.stx_tx stx+ outVal = txout_value (head' (tx_outputs tx))+ assertBool "output < input" (outVal < 50000)++ , testCase "spend_remote_htlc_preimage structure" $ do+ let stx = B5.spend_remote_htlc_preimage+ dummyOutPoint (Satoshi 50000)+ dummyReceivedHTLC dummyKeys+ dummyFeatures dummyDestScript dummyFeerate+ tx = B5.stx_tx stx+ tx_version tx @?= 2+ B5.stx_sighash_type stx @?= SIGHASH_ALL+ -- locktime should be 0 for preimage claims+ tx_locktime tx @?= 0++ , testCase "spend_remote_htlc_timeout anchors seq" $+ do+ let stx = B5.spend_remote_htlc_timeout+ dummyOutPoint (Satoshi 50000)+ dummyHTLC dummyKeys dummyFeaturesAnchors+ dummyDestScript dummyFeerate+ tx = B5.stx_tx stx+ inp = head' (tx_inputs tx)+ txin_sequence inp @?= 1+ ]++-- revoked htlc spend tests ------------------------------------------++revoked_htlc_spend_tests :: TestTree+revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [+ testCase "spend_revoked_htlc - offered" $ do+ case B5.spend_revoked_htlc+ dummyOutPoint (Satoshi 50000)+ (OutputOfferedHTLC (CltvExpiry 500000))+ dummyRevocationPubkey dummyKeys+ dummyFeatures dummyPaymentHash+ dummyDestScript dummyFeerate of+ Nothing -> assertFailure "expected Just"+ Just stx -> do+ let tx = B5.stx_tx stx+ tx_version tx @?= 2+ B5.stx_sighash_type stx @?= SIGHASH_ALL+ let inp = head' (tx_inputs tx)+ txin_sequence inp @?= 0xFFFFFFFF++ , testCase "spend_revoked_htlc - received" $ do+ case B5.spend_revoked_htlc+ dummyOutPoint (Satoshi 50000)+ (OutputReceivedHTLC (CltvExpiry 500000))+ dummyRevocationPubkey dummyKeys+ dummyFeatures dummyPaymentHash+ dummyDestScript dummyFeerate of+ Nothing -> assertFailure "expected Just"+ Just stx -> do+ B5.stx_sighash_type stx @?= SIGHASH_ALL+ let tx = B5.stx_tx stx+ outVal = txout_value+ (head' (tx_outputs tx))+ assertBool "output < input"+ (outVal < 50000)++ , testCase "spend_revoked_htlc - invalid type" $ do+ B5.spend_revoked_htlc+ dummyOutPoint (Satoshi 50000)+ OutputToLocal+ dummyRevocationPubkey dummyKeys+ dummyFeatures dummyPaymentHash+ dummyDestScript dummyFeerate+ @?= Nothing+ ]++-- weight tests -------------------------------------------------------++weight_tests :: TestTree+weight_tests = testGroup "Weight" [+ testCase "penalty input = base + witness" $ do+ -- to_local: 164 (txinput) + 160 (witness) = 324+ B5.to_local_penalty_input_weight @?=+ (164 + B5.to_local_penalty_witness_weight)+ -- offered: 164 + 243 = 407+ B5.offered_htlc_penalty_input_weight @?=+ (164 + B5.offered_htlc_penalty_witness_weight)+ -- accepted: 164 + 249 = 413+ B5.accepted_htlc_penalty_input_weight @?=+ (164 + B5.accepted_htlc_penalty_witness_weight)++ , testCase "max HTLCs in single penalty tx" $ do+ -- Per spec: (400000 - 324 - 272 - 212 - 2) / 413+ -- = 399190 / 413 = 966+ let maxHtlcs = (B5.max_standard_weight+ - B5.to_local_penalty_input_weight+ - B5.to_remote_input_weight+ - B5.penalty_tx_base_weight+ - 2) `div`+ B5.accepted_htlc_penalty_input_weight+ assertBool "can sweep 483 bidirectional HTLCs"+ (maxHtlcs >= 966)+ ]++-- property tests -----------------------------------------------------++property_tests :: TestTree+property_tests = testGroup "Properties" [+ testProperty "spending_fee always non-negative" $+ \(NonNegative rate) (NonNegative weight) ->+ let fee = B5.spending_fee+ (FeeratePerKw (fromIntegral (rate :: Int)))+ (fromIntegral (weight :: Int))+ in unSatoshi fee >= 0++ , testProperty "spend_to_local fee deduction correct" $+ \(Positive val) ->+ let value = Satoshi+ (fromIntegral (val :: Int) + 100000)+ stx = B5.spend_to_local+ dummyOutPoint value+ dummyRevocationPubkey dummyDelay+ dummyLocalDelayedPubkey+ dummyDestScript (FeeratePerKw 253)+ tx = B5.stx_tx stx+ outVal = txout_value+ (head' (tx_outputs tx))+ expectedFee = B5.spending_fee+ (FeeratePerKw 253)+ (B5.to_local_penalty_input_weight+ + B5.penalty_tx_base_weight)+ in Satoshi outVal ==+ Satoshi (unSatoshi value+ - unSatoshi expectedFee)++ , testProperty "htlc_timed_out monotonic" $+ \(NonNegative h1) (NonNegative h2) ->+ let height1 = fromIntegral (h1 :: Int)+ height2 = fromIntegral (h2 :: Int)+ htlc = dummyHTLC+ { htlc_cltv_expiry = CltvExpiry 1000 }+ in if height1 <= height2+ then not (B5.htlc_timed_out height1 htlc)+ || B5.htlc_timed_out height2 htlc+ else True+ ]++-- helpers ------------------------------------------------------------++-- | Total head for NonEmpty.+head' :: NonEmpty a -> a+head' (x :| _) = x