diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +# Changelog + +- 0.0.1 (UNRELEASED) + * Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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" diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -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) diff --git a/lib/Lightning/Protocol/BOLT5.hs b/lib/Lightning/Protocol/BOLT5.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT5.hs @@ -0,0 +1,114 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module: Lightning.Protocol.BOLT5 +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT5/Detect.hs b/lib/Lightning/Protocol/BOLT5/Detect.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT5/Detect.hs @@ -0,0 +1,350 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Lightning.Protocol.BOLT5.Detect +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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: +-- +-- @\ \@ +-- +-- 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 \ \ \@ +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT5/Spend.hs b/lib/Lightning/Protocol/BOLT5/Spend.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT5/Spend.hs @@ -0,0 +1,515 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Lightning.Protocol.BOLT5.Spend +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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) + } diff --git a/lib/Lightning/Protocol/BOLT5/Types.hs b/lib/Lightning/Protocol/BOLT5/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT5/Types.hs @@ -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 +-- +-- 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 #-} diff --git a/ppad-bolt5.cabal b/ppad-bolt5.cabal new file mode 100644 --- /dev/null +++ b/ppad-bolt5.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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