ppad-bolt3 (empty) → 0.0.1
raw patch · 14 files changed
+4885/−0 lines, 14 filesdep +basedep +base16-bytestringdep +bytestring
Dependencies added: base, base16-bytestring, bytestring, criterion, deepseq, ppad-bolt3, ppad-ripemd160, ppad-secp256k1, ppad-sha256, tasty, tasty-hunit, weigh
Files
- CHANGELOG +0/−0
- LICENSE +20/−0
- bench/Main.hs +489/−0
- bench/Weight.hs +479/−0
- lib/Lightning/Protocol/BOLT3.hs +287/−0
- lib/Lightning/Protocol/BOLT3/Decode.hs +389/−0
- lib/Lightning/Protocol/BOLT3/Encode.hs +298/−0
- lib/Lightning/Protocol/BOLT3/Keys.hs +426/−0
- lib/Lightning/Protocol/BOLT3/Scripts.hs +677/−0
- lib/Lightning/Protocol/BOLT3/Tx.hs +591/−0
- lib/Lightning/Protocol/BOLT3/Types.hs +443/−0
- lib/Lightning/Protocol/BOLT3/Validate.hs +359/−0
- ppad-bolt3.cabal +90/−0
- test/Main.hs +337/−0
+ CHANGELOG view
+ 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,489 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.DeepSeq (NFData(..))+import Criterion.Main+import Data.Word (Word64)+import qualified Data.ByteString as BS+import Lightning.Protocol.BOLT3++-- NFData instances for benchmarking++-- Existing instances+instance NFData Satoshi where+ rnf (Satoshi x) = rnf x++instance NFData MilliSatoshi where+ rnf (MilliSatoshi x) = rnf x++instance NFData Pubkey where+ rnf (Pubkey x) = rnf x++instance NFData Point where+ rnf (Point x) = rnf x++instance NFData PerCommitmentPoint where+ rnf (PerCommitmentPoint x) = rnf x++instance NFData RevocationPubkey where+ rnf (RevocationPubkey x) = rnf x++instance NFData RevocationBasepoint where+ rnf (RevocationBasepoint x) = rnf x++instance NFData ChannelFeatures where+ rnf (ChannelFeatures x) = rnf x++instance NFData FeeratePerKw where+ rnf (FeeratePerKw x) = rnf x++instance NFData DustLimit where+ rnf (DustLimit 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++-- Transaction types+instance NFData CommitmentTx where+ rnf (CommitmentTx v l i s o f) =+ rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f++instance NFData HTLCTx where+ rnf (HTLCTx v l i s ov os) =+ rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os++instance NFData ClosingTx where+ rnf (ClosingTx v l i s o f) =+ rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f++-- Output types+instance NFData TxOutput where+ rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t++instance NFData OutputType where+ rnf OutputToLocal = ()+ rnf OutputToRemote = ()+ rnf OutputLocalAnchor = ()+ rnf OutputRemoteAnchor = ()+ rnf (OutputOfferedHTLC e) = rnf e+ rnf (OutputReceivedHTLC e) = rnf e++-- Primitives+instance NFData Script where+ rnf (Script bs) = rnf bs++instance NFData Witness where+ rnf (Witness items) = rnf items++instance NFData Outpoint where+ rnf (Outpoint t i) = rnf t `seq` rnf i++instance NFData Sequence where+ rnf (Sequence x) = rnf x++instance NFData Locktime where+ rnf (Locktime x) = rnf x++instance NFData TxId where+ rnf (TxId bs) = rnf bs++instance NFData ToSelfDelay where+ rnf (ToSelfDelay x) = rnf x++instance NFData CommitmentNumber where+ rnf (CommitmentNumber x) = rnf x++-- Parsing types+instance NFData RawTx where+ rnf (RawTx v i o w l) =+ rnf v `seq` rnf i `seq` rnf o `seq` rnf w `seq` rnf l++instance NFData RawInput where+ rnf (RawInput o scr sq) = rnf o `seq` rnf scr `seq` rnf sq++instance NFData RawOutput where+ rnf (RawOutput v s) = rnf v `seq` rnf s++-- Context types+instance NFData CommitmentContext where+ rnf ctx = rnf (cc_funding_outpoint ctx) `seq`+ rnf (cc_commitment_number ctx) `seq`+ rnf (cc_htlcs ctx) `seq`+ rnf (cc_keys ctx)++instance NFData CommitmentKeys where+ rnf keys = rnf (ck_revocation_pubkey keys) `seq`+ rnf (ck_local_delayed keys) `seq`+ rnf (ck_local_htlc keys) `seq`+ rnf (ck_remote_htlc keys)++instance NFData HTLCContext where+ rnf ctx = rnf (hc_commitment_txid ctx) `seq`+ rnf (hc_htlc ctx)++instance NFData ClosingContext where+ rnf ctx = rnf (clc_funding_outpoint ctx) `seq`+ rnf (clc_local_amount ctx) `seq`+ rnf (clc_remote_amount ctx)++-- Key types+instance NFData LocalDelayedPubkey where+ rnf (LocalDelayedPubkey p) = rnf p++instance NFData RemoteDelayedPubkey where+ rnf (RemoteDelayedPubkey p) = rnf p++instance NFData LocalHtlcPubkey where+ rnf (LocalHtlcPubkey p) = rnf p++instance NFData RemoteHtlcPubkey where+ rnf (RemoteHtlcPubkey p) = rnf p++instance NFData LocalPubkey where+ rnf (LocalPubkey p) = rnf p++instance NFData RemotePubkey where+ rnf (RemotePubkey p) = rnf p++instance NFData PaymentBasepoint where+ rnf (PaymentBasepoint p) = rnf p++instance NFData DelayedPaymentBasepoint where+ rnf (DelayedPaymentBasepoint p) = rnf p++instance NFData HtlcBasepoint where+ rnf (HtlcBasepoint p) = rnf p++instance NFData FundingPubkey where+ rnf (FundingPubkey p) = rnf p++instance NFData PerCommitmentSecret where+ rnf (PerCommitmentSecret bs) = rnf bs++-- Secret storage (SecretStore is a newtype over list)+instance NFData SecretStore where+ rnf store = rnf (derive_old_secret 0 store)++-- Validation errors+instance NFData ValidationError where+ rnf (InvalidVersion a b) = rnf a `seq` rnf b+ rnf (InvalidLocktime a) = rnf a+ rnf (InvalidSequence a) = rnf a+ rnf InvalidOutputOrdering = ()+ rnf (DustLimitViolation a b c) = rnf a `seq` rnf b `seq` rnf c+ rnf MissingAnchorOutput = ()+ rnf (InvalidAnchorValue a) = rnf a+ rnf (InvalidFee a b) = rnf a `seq` rnf b+ rnf (InvalidHTLCLocktime a b) = rnf a `seq` rnf b+ rnf (InvalidHTLCSequence a b) = rnf a `seq` rnf b+ rnf NoOutputs = ()+ rnf (TooManyOutputs a) = rnf a++-- Decode errors+instance NFData DecodeError where+ rnf (InsufficientBytes a b) = rnf a `seq` rnf b+ rnf (InvalidMarker a) = rnf a+ rnf (InvalidFlag a) = rnf a+ rnf InvalidVarint = ()+ rnf EmptyInput = ()++main :: IO ()+main = defaultMain [+ bgroup "key derivation" [+ bench "derive_pubkey" $+ whnf (derive_pubkey basepoint) perCommitmentPoint+ , bench "derive_revocationpubkey" $+ whnf (derive_revocationpubkey revocationBasepoint) perCommitmentPoint+ ]+ , bgroup "secret generation" [+ bench "generate_from_seed (final node)" $+ whnf (generate_from_seed seed) 281474976710655+ , bench "generate_from_seed (first node)" $+ whnf (generate_from_seed seed) 0+ ]+ , bgroup "fee calculation" [+ bench "commitment_fee (no anchors, 0 htlcs)" $+ whnf (commitment_fee feerate noAnchors) 0+ , bench "commitment_fee (no anchors, 10 htlcs)" $+ whnf (commitment_fee feerate noAnchors) 10+ , bench "commitment_fee (anchors, 10 htlcs)" $+ whnf (commitment_fee feerate withAnchors) 10+ , bench "htlc_timeout_fee" $+ whnf (htlc_timeout_fee feerate) noAnchors+ , bench "htlc_success_fee" $+ whnf (htlc_success_fee feerate) noAnchors+ ]+ , bgroup "trimming" [+ bench "is_trimmed (offered, not trimmed)" $+ whnf (is_trimmed dust feerate noAnchors) htlcNotTrimmed+ , bench "is_trimmed (offered, trimmed)" $+ whnf (is_trimmed dust feerate noAnchors) htlcTrimmed+ , bench "htlc_trim_threshold (offered)" $+ whnf (htlc_trim_threshold dust feerate noAnchors) HTLCOffered+ ]+ , bgroup "tx building" [+ bench "build_commitment_tx (0 htlcs, no anchors)" $+ whnf build_commitment_tx (mkCommitmentContext htlcs0 noAnchors)+ , bench "build_commitment_tx (10 htlcs, no anchors)" $+ whnf build_commitment_tx (mkCommitmentContext htlcs10 noAnchors)+ , bench "build_commitment_tx (100 htlcs, no anchors)" $+ whnf build_commitment_tx (mkCommitmentContext htlcs100 noAnchors)+ , bench "build_commitment_tx (10 htlcs, anchors)" $+ whnf build_commitment_tx (mkCommitmentContext htlcs10 withAnchors)+ , bench "build_htlc_timeout_tx" $+ whnf build_htlc_timeout_tx sampleHtlcContext+ , bench "build_htlc_success_tx" $+ whnf build_htlc_success_tx sampleHtlcContext+ , bench "build_closing_tx" $+ whnf build_closing_tx sampleClosingContext+ ]+ , bgroup "script generation" [+ bench "funding_script" $+ whnf (funding_script (FundingPubkey samplePubkey1))+ (FundingPubkey samplePubkey2)+ , bench "to_local_script" $+ whnf (to_local_script (RevocationPubkey samplePubkey1)+ (ToSelfDelay 144))+ (LocalDelayedPubkey samplePubkey2)+ , bench "to_remote_script (no anchors)" $+ whnf (to_remote_script (RemotePubkey samplePubkey1)) noAnchors+ , bench "to_remote_script (anchors)" $+ whnf (to_remote_script (RemotePubkey samplePubkey1)) withAnchors+ , bench "anchor_script" $+ whnf anchor_script (FundingPubkey samplePubkey1)+ , bench "offered_htlc_script" $+ whnf (offered_htlc_script (RevocationPubkey samplePubkey1)+ (RemoteHtlcPubkey samplePubkey2)+ (LocalHtlcPubkey samplePubkey3)+ (PaymentHash $ BS.replicate 32 0))+ noAnchors+ , bench "received_htlc_script" $+ whnf (received_htlc_script (RevocationPubkey samplePubkey1)+ (RemoteHtlcPubkey samplePubkey2)+ (LocalHtlcPubkey samplePubkey3)+ (PaymentHash $ BS.replicate 32 0)+ (CltvExpiry 500000))+ noAnchors+ ]+ , bgroup "serialization" [+ env (pure $ build_commitment_tx $ mkCommitmentContext htlcs0 noAnchors)+ $ \tx -> bench "encode_tx (0 htlcs)" $ whnf encode_tx tx+ , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)+ $ \tx -> bench "encode_tx (10 htlcs)" $ whnf encode_tx tx+ , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs100 noAnchors)+ $ \tx -> bench "encode_tx (100 htlcs)" $ whnf encode_tx tx+ , bench "encode_htlc_tx" $+ whnf encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)+ , bench "encode_closing_tx" $+ whnf encode_closing_tx (build_closing_tx sampleClosingContext)+ ]+ , bgroup "parsing" [+ env (pure $ encode_tx $ build_commitment_tx $+ mkCommitmentContext htlcs0 noAnchors)+ $ \bs -> bench "decode_tx (0 htlcs)" $ whnf decode_tx bs+ , env (pure $ encode_tx $ build_commitment_tx $+ mkCommitmentContext htlcs10 noAnchors)+ $ \bs -> bench "decode_tx (10 htlcs)" $ whnf decode_tx bs+ , env (pure $ encode_tx $ build_commitment_tx $+ mkCommitmentContext htlcs100 noAnchors)+ $ \bs -> bench "decode_tx (100 htlcs)" $ whnf decode_tx bs+ ]+ , bgroup "validation" [+ env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)+ $ \tx -> bench "validate_commitment_tx (valid)" $+ whnf (validate_commitment_tx dust noAnchors) tx+ , env (pure $ build_htlc_timeout_tx sampleHtlcContext)+ $ \tx -> bench "validate_htlc_tx" $+ whnf validate_htlc_tx tx+ , env (pure $ build_closing_tx sampleClosingContext)+ $ \tx -> bench "validate_closing_tx" $+ whnf validate_closing_tx tx+ , env (pure $ ctx_outputs $ build_commitment_tx $+ mkCommitmentContext htlcs10 noAnchors)+ $ \outs -> bench "validate_output_ordering" $+ whnf validate_output_ordering outs+ ]+ , bgroup "secret storage" [+ bench "insert_secret (first)" $+ whnf (insert_secret (BS.replicate 32 0xFF) 281474976710655)+ empty_store+ , env setupFilledStore $ \store ->+ bench "derive_old_secret (recent)" $+ whnf (derive_old_secret 281474976710654) store+ , env setupFilledStore $ \store ->+ bench "derive_old_secret (old)" $+ whnf (derive_old_secret 281474976710600) store+ ]+ , bgroup "output sorting" [+ env (pure $ ctx_outputs $ build_commitment_tx $+ mkCommitmentContext htlcs10 noAnchors)+ $ \outs -> bench "sort_outputs (10)" $ nf sort_outputs outs+ , env (pure $ ctx_outputs $ build_commitment_tx $+ mkCommitmentContext htlcs100 noAnchors)+ $ \outs -> bench "sort_outputs (100)" $ nf sort_outputs outs+ ]+ ]+ where+ -- Key derivation test data+ basepoint = Point $ BS.pack+ [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,+ 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,+ 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]++ perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack+ [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,+ 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,+ 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]++ revocationBasepoint = RevocationBasepoint $ Point $ BS.pack+ [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,+ 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,+ 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]++ -- Secret generation test data+ seed = BS.replicate 32 0xFF++ -- Fee calculation test data+ feerate = FeeratePerKw 5000+ noAnchors = ChannelFeatures { cf_option_anchors = False }+ withAnchors = ChannelFeatures { cf_option_anchors = True }++ -- Trimming test data+ dust = DustLimit (Satoshi 546)++ htlcNotTrimmed = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 5000000+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }++ htlcTrimmed = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 1000000+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }++ -- Sample pubkeys+ samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey+ samplePubkey1 = Pubkey $ BS.pack+ [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,+ 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,+ 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]+ samplePubkey2 = Pubkey $ BS.pack+ [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,+ 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,+ 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]+ samplePubkey3 = samplePubkey1++ -- Funding outpoint+ sampleFundingOutpoint :: Outpoint+ sampleFundingOutpoint = Outpoint (TxId $ BS.replicate 32 0x01) 0++ -- HTLC lists+ mkHtlc :: HTLCDirection -> Word64 -> Word64 -> HTLC+ mkHtlc dir amtMsat expiry = HTLC+ { htlc_direction = dir+ , htlc_amount_msat = MilliSatoshi amtMsat+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00)+ , htlc_cltv_expiry = CltvExpiry (fromIntegral expiry)+ }++ htlcs0, htlcs10, htlcs100 :: [HTLC]+ htlcs0 = []+ htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)+ (5000000 + i * 100000) (500000 + i)+ | i <- [0..9]]+ htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)+ (5000000 + i * 10000) (500000 + i)+ | i <- [0..99]]++ -- CommitmentKeys fixture+ sampleCommitmentKeys :: CommitmentKeys+ sampleCommitmentKeys = CommitmentKeys+ { ck_revocation_pubkey = RevocationPubkey samplePubkey1+ , ck_local_delayed = LocalDelayedPubkey samplePubkey1+ , ck_local_htlc = LocalHtlcPubkey samplePubkey1+ , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2+ , ck_local_payment = LocalPubkey samplePubkey1+ , ck_remote_payment = RemotePubkey samplePubkey2+ , ck_local_funding = FundingPubkey samplePubkey1+ , ck_remote_funding = FundingPubkey samplePubkey2+ }++ -- CommitmentContext builder+ mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext+ mkCommitmentContext htlcs features = CommitmentContext+ { cc_funding_outpoint = sampleFundingOutpoint+ , cc_commitment_number = CommitmentNumber 42+ , cc_local_payment_bp =+ PaymentBasepoint $ Point $ unPubkey samplePubkey1+ , cc_remote_payment_bp =+ PaymentBasepoint $ Point $ unPubkey samplePubkey2+ , cc_to_self_delay = ToSelfDelay 144+ , cc_dust_limit = DustLimit (Satoshi 546)+ , cc_feerate = FeeratePerKw 5000+ , cc_features = features+ , cc_is_funder = True+ , cc_to_local_msat = MilliSatoshi 500000000+ , cc_to_remote_msat = MilliSatoshi 500000000+ , cc_htlcs = htlcs+ , cc_keys = sampleCommitmentKeys+ }++ -- HTLC context+ sampleHtlcContext :: HTLCContext+ sampleHtlcContext = HTLCContext+ { hc_commitment_txid = TxId $ BS.replicate 32 0x01+ , hc_output_index = 0+ , hc_htlc = mkHtlc HTLCOffered 5000000 500000+ , hc_to_self_delay = ToSelfDelay 144+ , hc_feerate = FeeratePerKw 5000+ , hc_features = noAnchors+ , hc_revocation_pubkey = RevocationPubkey samplePubkey1+ , hc_local_delayed = LocalDelayedPubkey samplePubkey1+ }++ -- Closing context+ sampleClosingContext :: ClosingContext+ sampleClosingContext = ClosingContext+ { clc_funding_outpoint = sampleFundingOutpoint+ , clc_local_amount = Satoshi 500000+ , clc_remote_amount = Satoshi 500000+ , clc_local_script =+ Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x01+ , clc_remote_script =+ Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x02+ , clc_local_dust_limit = DustLimit (Satoshi 546)+ , clc_remote_dust_limit = DustLimit (Satoshi 546)+ , clc_fee = Satoshi 1000+ , clc_is_funder = True+ , clc_locktime = Locktime 0+ , clc_funding_script = funding_script (FundingPubkey samplePubkey1)+ (FundingPubkey samplePubkey2)+ }++ -- Setup for secret storage benchmarks+ setupFilledStore :: IO SecretStore+ setupFilledStore = do+ let secrets = [(generate_from_seed seed i, i)+ | i <- [281474976710655, 281474976710654 .. 281474976710600]]+ pure $! foldl insertOrFail empty_store secrets+ where+ insertOrFail store (sec, idx) =+ case insert_secret sec idx store of+ Just s -> s+ Nothing -> store
+ bench/Weight.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.DeepSeq (NFData(..))+import qualified Data.ByteString as BS+import Data.Word (Word32, Word64)+import Lightning.Protocol.BOLT3+import Weigh++-- NFData instances for weigh++-- Monetary types+instance NFData Satoshi where+ rnf (Satoshi x) = rnf x++instance NFData MilliSatoshi where+ rnf (MilliSatoshi x) = rnf x++-- Key types+instance NFData Pubkey where+ rnf (Pubkey x) = rnf x++instance NFData Point where+ rnf (Point x) = rnf x++instance NFData PerCommitmentPoint where+ rnf (PerCommitmentPoint x) = rnf x++instance NFData RevocationPubkey where+ rnf (RevocationPubkey x) = rnf x++instance NFData RevocationBasepoint where+ rnf (RevocationBasepoint x) = rnf x++instance NFData LocalDelayedPubkey where+ rnf (LocalDelayedPubkey p) = rnf p++instance NFData RemoteDelayedPubkey where+ rnf (RemoteDelayedPubkey p) = rnf p++instance NFData LocalHtlcPubkey where+ rnf (LocalHtlcPubkey p) = rnf p++instance NFData RemoteHtlcPubkey where+ rnf (RemoteHtlcPubkey p) = rnf p++instance NFData LocalPubkey where+ rnf (LocalPubkey p) = rnf p++instance NFData RemotePubkey where+ rnf (RemotePubkey p) = rnf p++instance NFData PaymentBasepoint where+ rnf (PaymentBasepoint p) = rnf p++instance NFData DelayedPaymentBasepoint where+ rnf (DelayedPaymentBasepoint p) = rnf p++instance NFData HtlcBasepoint where+ rnf (HtlcBasepoint p) = rnf p++instance NFData FundingPubkey where+ rnf (FundingPubkey p) = rnf p++instance NFData PerCommitmentSecret where+ rnf (PerCommitmentSecret bs) = rnf bs++-- Channel features+instance NFData ChannelFeatures where+ rnf (ChannelFeatures x) = rnf x++instance NFData FeeratePerKw where+ rnf (FeeratePerKw x) = rnf x++instance NFData DustLimit where+ rnf (DustLimit x) = rnf x++-- Hash types+instance NFData PaymentHash where+ rnf (PaymentHash x) = rnf x++instance NFData CltvExpiry where+ rnf (CltvExpiry x) = rnf x++-- HTLC types+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++-- Transaction types+instance NFData CommitmentTx where+ rnf (CommitmentTx v l i s o f) =+ rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f++instance NFData HTLCTx where+ rnf (HTLCTx v l i s ov os) =+ rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os++instance NFData ClosingTx where+ rnf (ClosingTx v l i s o f) =+ rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f++-- Output types+instance NFData TxOutput where+ rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t++instance NFData OutputType where+ rnf OutputToLocal = ()+ rnf OutputToRemote = ()+ rnf OutputLocalAnchor = ()+ rnf OutputRemoteAnchor = ()+ rnf (OutputOfferedHTLC e) = rnf e+ rnf (OutputReceivedHTLC e) = rnf e++-- Primitives+instance NFData Script where+ rnf (Script bs) = rnf bs++instance NFData Witness where+ rnf (Witness items) = rnf items++instance NFData Outpoint where+ rnf (Outpoint t i) = rnf t `seq` rnf i++instance NFData Sequence where+ rnf (Sequence x) = rnf x++instance NFData Locktime where+ rnf (Locktime x) = rnf x++instance NFData TxId where+ rnf (TxId bs) = rnf bs++instance NFData ToSelfDelay where+ rnf (ToSelfDelay x) = rnf x++instance NFData CommitmentNumber where+ rnf (CommitmentNumber x) = rnf x++-- Parsing types+instance NFData RawTx where+ rnf (RawTx v i o w l) =+ rnf v `seq` rnf i `seq` rnf o `seq` rnf w `seq` rnf l++instance NFData RawInput where+ rnf (RawInput o scr sq) = rnf o `seq` rnf scr `seq` rnf sq++instance NFData RawOutput where+ rnf (RawOutput v s) = rnf v `seq` rnf s++-- Context types+instance NFData CommitmentContext where+ rnf ctx = rnf (cc_funding_outpoint ctx) `seq`+ rnf (cc_commitment_number ctx) `seq`+ rnf (cc_htlcs ctx) `seq`+ rnf (cc_keys ctx)++instance NFData CommitmentKeys where+ rnf keys = rnf (ck_revocation_pubkey keys) `seq`+ rnf (ck_local_delayed keys) `seq`+ rnf (ck_local_htlc keys) `seq`+ rnf (ck_remote_htlc keys)++instance NFData HTLCContext where+ rnf ctx = rnf (hc_commitment_txid ctx) `seq`+ rnf (hc_htlc ctx)++instance NFData ClosingContext where+ rnf ctx = rnf (clc_funding_outpoint ctx) `seq`+ rnf (clc_local_amount ctx) `seq`+ rnf (clc_remote_amount ctx)++-- Error types+instance NFData DecodeError where+ rnf (InsufficientBytes e a) = rnf e `seq` rnf a+ rnf (InvalidMarker w) = rnf w+ rnf (InvalidFlag w) = rnf w+ rnf InvalidVarint = ()+ rnf EmptyInput = ()++instance NFData ValidationError where+ rnf (InvalidVersion e a) = rnf e `seq` rnf a+ rnf (InvalidLocktime lt) = rnf lt+ rnf (InvalidSequence sq) = rnf sq+ rnf InvalidOutputOrdering = ()+ rnf (DustLimitViolation i v d) = rnf i `seq` rnf v `seq` rnf d+ rnf MissingAnchorOutput = ()+ rnf (InvalidAnchorValue v) = rnf v+ rnf (InvalidFee e a) = rnf e `seq` rnf a+ rnf (InvalidHTLCLocktime e a) = rnf e `seq` rnf a+ rnf (InvalidHTLCSequence e a) = rnf e `seq` rnf a+ rnf NoOutputs = ()+ rnf (TooManyOutputs n) = rnf n++-- Secret store (opaque, use generic rnf on the list)+instance NFData SecretStore where+ rnf ss = ss `seq` ()++main :: IO ()+main = mainWith $ do+ setColumns [Case, Allocated, GCs, Max]++ -- Key derivation allocations+ func "derive_pubkey" (derive_pubkey basepoint) perCommitmentPoint+ func "derive_revocationpubkey"+ (derive_revocationpubkey revocationBasepoint) perCommitmentPoint++ -- Secret generation allocations+ func "generate_from_seed (final)" (generate_from_seed seed) 281474976710655+ func "generate_from_seed (first)" (generate_from_seed seed) 0++ -- Fee calculation allocations+ func "commitment_fee (0 htlcs)" (commitment_fee feerate noAnchors) 0+ func "commitment_fee (10 htlcs)" (commitment_fee feerate noAnchors) 10+ func "htlc_timeout_fee" (htlc_timeout_fee feerate) noAnchors+ func "htlc_success_fee" (htlc_success_fee feerate) noAnchors++ -- Trimming allocations+ func "is_trimmed (not trimmed)"+ (is_trimmed dust feerate noAnchors) htlcNotTrimmed+ func "is_trimmed (trimmed)"+ (is_trimmed dust feerate noAnchors) htlcTrimmed+ func "htlc_trim_threshold"+ (htlc_trim_threshold dust feerate noAnchors) HTLCOffered++ -- Transaction building allocations+ func "build_commitment_tx (0 htlcs, no anchors)"+ build_commitment_tx (mkCommitmentContext htlcs0 noAnchors)+ func "build_commitment_tx (10 htlcs, no anchors)"+ build_commitment_tx (mkCommitmentContext htlcs10 noAnchors)+ func "build_commitment_tx (100 htlcs, no anchors)"+ build_commitment_tx (mkCommitmentContext htlcs100 noAnchors)+ func "build_commitment_tx (10 htlcs, anchors)"+ build_commitment_tx (mkCommitmentContext htlcs10 withAnchors)+ func "build_htlc_timeout_tx"+ build_htlc_timeout_tx sampleHtlcContext+ func "build_htlc_success_tx"+ build_htlc_success_tx sampleHtlcContext+ func "build_closing_tx"+ build_closing_tx sampleClosingContext++ -- Script generation allocations+ func "funding_script"+ (funding_script (FundingPubkey samplePubkey1))+ (FundingPubkey samplePubkey2)+ func "to_local_script"+ (to_local_script (RevocationPubkey samplePubkey1)+ (ToSelfDelay 144))+ (LocalDelayedPubkey samplePubkey2)+ func "to_remote_script (no anchors)"+ (to_remote_script (RemotePubkey samplePubkey1)) noAnchors+ func "to_remote_script (anchors)"+ (to_remote_script (RemotePubkey samplePubkey1)) withAnchors+ func "anchor_script"+ anchor_script (FundingPubkey samplePubkey1)+ func "offered_htlc_script"+ (offered_htlc_script (RevocationPubkey samplePubkey1)+ (RemoteHtlcPubkey samplePubkey2)+ (LocalHtlcPubkey samplePubkey3)+ (PaymentHash $ BS.replicate 32 0))+ noAnchors+ func "received_htlc_script"+ (received_htlc_script (RevocationPubkey samplePubkey1)+ (RemoteHtlcPubkey samplePubkey2)+ (LocalHtlcPubkey samplePubkey3)+ (PaymentHash $ BS.replicate 32 0)+ (CltvExpiry 500000))+ noAnchors++ -- Serialization allocations+ func "encode_tx (0 htlcs)"+ encode_tx (build_commitment_tx $ mkCommitmentContext htlcs0 noAnchors)+ func "encode_tx (10 htlcs)"+ encode_tx (build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)+ func "encode_tx (100 htlcs)"+ encode_tx (build_commitment_tx $ mkCommitmentContext htlcs100 noAnchors)+ func "encode_htlc_tx"+ encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)+ func "encode_closing_tx"+ encode_closing_tx (build_closing_tx sampleClosingContext)++ -- Parsing allocations+ func "decode_tx (0 htlcs)"+ decode_tx (encode_tx $ build_commitment_tx $+ mkCommitmentContext htlcs0 noAnchors)+ func "decode_tx (10 htlcs)"+ decode_tx (encode_tx $ build_commitment_tx $+ mkCommitmentContext htlcs10 noAnchors)+ func "decode_tx (100 htlcs)"+ decode_tx (encode_tx $ build_commitment_tx $+ mkCommitmentContext htlcs100 noAnchors)++ -- Validation allocations+ func "validate_commitment_tx (valid)"+ (validate_commitment_tx dust noAnchors)+ (build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)+ func "validate_htlc_tx"+ validate_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)+ func "validate_closing_tx"+ validate_closing_tx (build_closing_tx sampleClosingContext)+ func "validate_output_ordering"+ validate_output_ordering (ctx_outputs $ build_commitment_tx $+ mkCommitmentContext htlcs10 noAnchors)++ -- Secret storage allocations+ func "insert_secret (first)"+ (insert_secret (BS.replicate 32 0xFF) 281474976710655)+ empty_store+ func "derive_old_secret (recent)"+ (derive_old_secret 281474976710654)+ filledStore+ func "derive_old_secret (old)"+ (derive_old_secret 281474976710600)+ filledStore++ -- Output sorting allocations+ func "sort_outputs (10)"+ sort_outputs (ctx_outputs $ build_commitment_tx $+ mkCommitmentContext htlcs10 noAnchors)+ func "sort_outputs (100)"+ sort_outputs (ctx_outputs $ build_commitment_tx $+ mkCommitmentContext htlcs100 noAnchors)++ where+ -- Key derivation test data+ basepoint = Point $ BS.pack+ [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,+ 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,+ 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]++ perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack+ [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,+ 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,+ 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]++ revocationBasepoint = RevocationBasepoint $ Point $ BS.pack+ [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,+ 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,+ 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]++ -- Secret generation test data+ seed = BS.replicate 32 0xFF++ -- Fee calculation test data+ feerate = FeeratePerKw 5000+ noAnchors = ChannelFeatures { cf_option_anchors = False }+ withAnchors = ChannelFeatures { cf_option_anchors = True }++ -- Trimming test data+ dust = DustLimit (Satoshi 546)++ htlcNotTrimmed = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 5000000+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }++ htlcTrimmed = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 1000000+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }++ -- Sample pubkeys+ samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey+ samplePubkey1 = Pubkey $ BS.pack+ [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,+ 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,+ 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]+ samplePubkey2 = Pubkey $ BS.pack+ [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,+ 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,+ 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]+ samplePubkey3 = samplePubkey1++ -- Funding outpoint+ sampleFundingOutpoint :: Outpoint+ sampleFundingOutpoint = Outpoint (TxId $ BS.replicate 32 0x01) 0++ -- HTLC builder+ mkHtlc :: HTLCDirection -> Word64 -> Word32 -> HTLC+ mkHtlc dir amtMsat expiry = HTLC+ { htlc_direction = dir+ , htlc_amount_msat = MilliSatoshi amtMsat+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00)+ , htlc_cltv_expiry = CltvExpiry expiry+ }++ htlcs0, htlcs10, htlcs100 :: [HTLC]+ htlcs0 = []+ htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)+ (5000000 + i * 100000) (500000 + fromIntegral i)+ | i <- [0..9]]+ htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)+ (5000000 + i * 10000) (500000 + fromIntegral i)+ | i <- [0..99]]++ -- CommitmentKeys+ sampleCommitmentKeys :: CommitmentKeys+ sampleCommitmentKeys = CommitmentKeys+ { ck_revocation_pubkey = RevocationPubkey samplePubkey1+ , ck_local_delayed = LocalDelayedPubkey samplePubkey1+ , ck_local_htlc = LocalHtlcPubkey samplePubkey1+ , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2+ , ck_local_payment = LocalPubkey samplePubkey1+ , ck_remote_payment = RemotePubkey samplePubkey2+ , ck_local_funding = FundingPubkey samplePubkey1+ , ck_remote_funding = FundingPubkey samplePubkey2+ }++ -- CommitmentContext builder+ mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext+ mkCommitmentContext htlcs features = CommitmentContext+ { cc_funding_outpoint = sampleFundingOutpoint+ , cc_commitment_number = CommitmentNumber 42+ , cc_local_payment_bp = PaymentBasepoint $+ Point $ unPubkey samplePubkey1+ , cc_remote_payment_bp = PaymentBasepoint $+ Point $ unPubkey samplePubkey2+ , cc_to_self_delay = ToSelfDelay 144+ , cc_dust_limit = DustLimit (Satoshi 546)+ , cc_feerate = FeeratePerKw 5000+ , cc_features = features+ , cc_is_funder = True+ , cc_to_local_msat = MilliSatoshi 500000000+ , cc_to_remote_msat = MilliSatoshi 500000000+ , cc_htlcs = htlcs+ , cc_keys = sampleCommitmentKeys+ }++ -- HTLC context+ sampleHtlcContext :: HTLCContext+ sampleHtlcContext = HTLCContext+ { hc_commitment_txid = TxId $ BS.replicate 32 0x01+ , hc_output_index = 0+ , hc_htlc = mkHtlc HTLCOffered 5000000 500000+ , hc_to_self_delay = ToSelfDelay 144+ , hc_feerate = FeeratePerKw 5000+ , hc_features = noAnchors+ , hc_revocation_pubkey = RevocationPubkey samplePubkey1+ , hc_local_delayed = LocalDelayedPubkey samplePubkey1+ }++ -- Closing context+ sampleClosingContext :: ClosingContext+ sampleClosingContext = ClosingContext+ { clc_funding_outpoint = sampleFundingOutpoint+ , clc_local_amount = Satoshi 500000+ , clc_remote_amount = Satoshi 500000+ , clc_local_script = Script $+ BS.pack [0x00, 0x14] <> BS.replicate 20 0x01+ , clc_remote_script = Script $+ BS.pack [0x00, 0x14] <> BS.replicate 20 0x02+ , clc_local_dust_limit = DustLimit (Satoshi 546)+ , clc_remote_dust_limit = DustLimit (Satoshi 546)+ , clc_fee = Satoshi 1000+ , clc_is_funder = True+ , clc_locktime = Locktime 0+ , clc_funding_script = funding_script (FundingPubkey samplePubkey1)+ (FundingPubkey samplePubkey2)+ }++ -- Secret storage for benchmarks+ filledStore :: SecretStore+ filledStore = foldl insertOne empty_store [0..99]+ where+ insertOne store i =+ let idx = 281474976710655 - i+ sec = BS.replicate 32 (fromIntegral i)+ in case insert_secret sec idx store of+ Just s -> s+ Nothing -> store
+ lib/Lightning/Protocol/BOLT3.hs view
@@ -0,0 +1,287 @@+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Module: Lightning.Protocol.BOLT3+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Bitcoin transaction formats for the Lightning Network, per+-- [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md).+--+-- = Overview+--+-- This library implements the transaction and script formats defined in+-- BOLT #3, including:+--+-- * Commitment transactions with to_local, to_remote, anchor, and HTLC+-- outputs+-- * HTLC-timeout and HTLC-success second-stage transactions+-- * Closing transactions (legacy and option_simple_close)+-- * Per-commitment key derivation and secret storage+-- * Transaction serialization and parsing+-- * Stateless validation+--+-- = Quick Start+--+-- @+-- import Lightning.Protocol.BOLT3+--+-- -- Build a commitment transaction+-- let ctx = CommitmentContext { ... }+-- tx = build_commitment_tx ctx+--+-- -- Serialize for signing+-- let bytes = encode_tx tx+--+-- -- Validate the transaction+-- case validate_commitment_tx dustLimit features tx of+-- Right () -> putStrLn "Valid"+-- Left err -> print err+-- @+--+-- = Modules+--+-- * "Lightning.Protocol.BOLT3.Types" - Core types (Satoshi, Pubkey, HTLC,+-- etc.)+-- * "Lightning.Protocol.BOLT3.Keys" - Per-commitment key derivation and+-- secret storage+-- * "Lightning.Protocol.BOLT3.Scripts" - Witness script templates (funding,+-- to_local, HTLC, anchor)+-- * "Lightning.Protocol.BOLT3.Tx" - Transaction assembly+-- * "Lightning.Protocol.BOLT3.Encode" - Transaction serialization+-- * "Lightning.Protocol.BOLT3.Decode" - Transaction parsing+-- * "Lightning.Protocol.BOLT3.Validate" - Stateless validation++module Lightning.Protocol.BOLT3 (+ -- * Types+ -- ** Monetary amounts+ Satoshi(..)+ , MilliSatoshi(..)+ , msat_to_sat+ , sat_to_msat++ -- ** Keys and points+ , Pubkey(..)+ , pubkey+ , Seckey(..)+ , seckey+ , Point(..)+ , point++ -- ** Hashes+ , PaymentHash(..)+ , payment_hash+ , PaymentPreimage(..)+ , payment_preimage++ -- ** Transaction primitives+ , TxId(..)+ , txid+ , Outpoint(..)+ , Sequence(..)+ , Locktime(..)++ -- ** Channel parameters+ , CommitmentNumber(..)+ , commitment_number+ , ToSelfDelay(..)+ , CltvExpiry(..)+ , DustLimit(..)+ , FeeratePerKw(..)++ -- ** HTLC types+ , HTLC(..)+ , HTLCDirection(..)++ -- ** Basepoints+ , Basepoints(..)+ , PerCommitmentPoint(..)+ , PerCommitmentSecret(..)+ , per_commitment_secret+ , RevocationBasepoint(..)+ , PaymentBasepoint(..)+ , DelayedPaymentBasepoint(..)+ , HtlcBasepoint(..)++ -- ** Derived keys+ , LocalPubkey(..)+ , RemotePubkey(..)+ , LocalDelayedPubkey(..)+ , RemoteDelayedPubkey(..)+ , LocalHtlcPubkey(..)+ , RemoteHtlcPubkey(..)+ , RevocationPubkey(..)+ , FundingPubkey(..)++ -- ** Script and witness+ , Script(..)+ , Witness(..)++ -- ** Channel features+ , ChannelFeatures(..)+ , has_anchors++ -- ** Constants+ , commitment_weight_no_anchors+ , commitment_weight_anchors+ , htlc_timeout_weight_no_anchors+ , htlc_timeout_weight_anchors+ , htlc_success_weight_no_anchors+ , htlc_success_weight_anchors+ , htlc_output_weight+ , dust_p2pkh+ , dust_p2sh+ , dust_p2wpkh+ , dust_p2wsh+ , anchor_output_value++ -- * Key derivation+ , derive_per_commitment_point+ , derive_pubkey+ , derive_localpubkey+ , derive_local_htlcpubkey+ , derive_remote_htlcpubkey+ , derive_local_delayedpubkey+ , derive_remote_delayedpubkey+ , derive_revocationpubkey++ -- ** Secret generation+ , generate_from_seed+ , derive_secret++ -- ** Secret storage+ , SecretStore+ , empty_store+ , insert_secret+ , derive_old_secret++ -- ** Commitment number+ , obscured_commitment_number++ -- * Scripts+ -- ** Funding output+ , funding_script+ , funding_witness++ -- ** to_local output+ , to_local_script+ , to_local_witness_spend+ , to_local_witness_revoke++ -- ** to_remote output+ , to_remote_script+ , to_remote_witness++ -- ** Anchor outputs+ , anchor_script+ , anchor_witness_owner+ , anchor_witness_anyone++ -- ** Offered HTLC+ , offered_htlc_script+ , offered_htlc_witness_preimage+ , offered_htlc_witness_revoke++ -- ** Received HTLC+ , received_htlc_script+ , received_htlc_witness_timeout+ , received_htlc_witness_revoke++ -- ** HTLC output (same as to_local)+ , htlc_output_script+ , htlc_output_witness_spend+ , htlc_output_witness_revoke++ -- ** P2WSH helpers+ , to_p2wsh+ , witness_script_hash++ -- * Transaction assembly+ -- ** Commitment transactions+ , CommitmentTx(..)+ , CommitmentContext(..)+ , CommitmentKeys(..)+ , build_commitment_tx++ -- ** HTLC transactions+ , HTLCTx(..)+ , HTLCContext(..)+ , build_htlc_timeout_tx+ , build_htlc_success_tx++ -- ** Closing transactions+ , ClosingTx(..)+ , ClosingContext(..)+ , build_closing_tx+ , build_legacy_closing_tx++ -- ** Transaction outputs+ , TxOutput(..)+ , OutputType(..)++ -- ** Fee calculation+ , commitment_fee+ , commitment_weight+ , htlc_timeout_fee+ , htlc_success_fee++ -- ** Trimming+ , htlc_trim_threshold+ , is_trimmed+ , trimmed_htlcs+ , untrimmed_htlcs++ -- ** Output ordering+ , sort_outputs++ -- * Serialization+ , encode_tx+ , encode_htlc_tx+ , encode_closing_tx+ , encode_tx_for_signing+ , encode_varint+ , encode_le32+ , encode_le64+ , encode_outpoint+ , encode_output+ , encode_witness+ , encode_funding_witness++ -- * Parsing+ , DecodeError(..)+ , RawTx(..)+ , RawInput(..)+ , RawOutput(..)+ , decode_tx+ , decode_varint+ , decode_le32+ , decode_le64+ , decode_outpoint+ , decode_output+ , decode_witness++ -- * Validation+ , ValidationError(..)+ , validate_commitment_tx+ , validate_commitment_locktime+ , validate_commitment_sequence+ , validate_htlc_tx+ , validate_htlc_timeout_tx+ , validate_htlc_success_tx+ , validate_closing_tx+ , validate_legacy_closing_tx+ , validate_output_ordering+ , validate_dust_limits+ , validate_anchor_outputs+ , validate_commitment_fee+ , validate_htlc_fee+ ) where++import Lightning.Protocol.BOLT3.Types+import Lightning.Protocol.BOLT3.Keys+import Lightning.Protocol.BOLT3.Scripts+import Lightning.Protocol.BOLT3.Tx+import Lightning.Protocol.BOLT3.Encode+import Lightning.Protocol.BOLT3.Decode+import Lightning.Protocol.BOLT3.Validate
+ lib/Lightning/Protocol/BOLT3/Decode.hs view
@@ -0,0 +1,389 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Decode+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Parsing for BOLT #3 transactions and scripts.+--+-- Decodes SegWit Bitcoin transactions from raw bytes.++module Lightning.Protocol.BOLT3.Decode (+ -- * Error types+ DecodeError(..)++ -- * Raw transaction type+ , RawTx(..)+ , RawInput(..)+ , RawOutput(..)++ -- * Transaction parsing+ , decode_tx++ -- * Witness parsing+ , decode_witness++ -- * Primitive decoding+ , decode_varint+ , decode_le32+ , decode_le64+ , decode_outpoint+ , decode_output+ ) where++import Data.Bits ((.|.), shiftL)+import Data.Word (Word8, Word32, Word64)+import qualified Data.ByteString as BS+import GHC.Generics (Generic)+import Lightning.Protocol.BOLT3.Types++-- error types -----------------------------------------------------------------++-- | Errors that can occur during transaction decoding.+data DecodeError+ = InsufficientBytes !Int !Int+ -- ^ Expected bytes, actual bytes available+ | InvalidMarker !Word8+ -- ^ Invalid SegWit marker byte (expected 0x00)+ | InvalidFlag !Word8+ -- ^ Invalid SegWit flag byte (expected 0x01)+ | InvalidVarint+ -- ^ Malformed varint encoding+ | EmptyInput+ -- ^ No bytes to decode+ deriving (Eq, Show, Generic)++-- raw transaction types -------------------------------------------------------++-- | A raw transaction input as parsed from bytes.+data RawInput = RawInput+ { ri_outpoint :: !Outpoint+ , ri_script_sig :: !BS.ByteString+ , ri_sequence :: !Sequence+ } deriving (Eq, Show, Generic)++-- | A raw transaction output as parsed from bytes.+data RawOutput = RawOutput+ { ro_value :: !Satoshi+ , ro_script :: !Script+ } deriving (Eq, Show, Generic)++-- | A raw transaction as parsed from bytes.+--+-- Supports both legacy and SegWit transaction formats.+data RawTx = RawTx+ { rtx_version :: {-# UNPACK #-} !Word32+ , rtx_inputs :: ![RawInput]+ , rtx_outputs :: ![RawOutput]+ , rtx_witness :: ![[BS.ByteString]]+ -- ^ Witness stack for each input (empty list for legacy tx)+ , rtx_locktime :: !Locktime+ } deriving (Eq, Show, Generic)++-- primitive decoding ----------------------------------------------------------++-- | Decode a little-endian 32-bit integer.+--+-- >>> decode_le32 (BS.pack [0x01, 0x00, 0x00, 0x00])+-- Right (1, "")+decode_le32 :: BS.ByteString -> Either DecodeError (Word32, BS.ByteString)+decode_le32 !bs+ | BS.length bs < 4 = Left (InsufficientBytes 4 (BS.length bs))+ | otherwise =+ let !b0 = fromIntegral (BS.index bs 0)+ !b1 = fromIntegral (BS.index bs 1)+ !b2 = fromIntegral (BS.index bs 2)+ !b3 = fromIntegral (BS.index bs 3)+ !val = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16)+ .|. (b3 `shiftL` 24)+ !rest = BS.drop 4 bs+ in Right (val, rest)+{-# INLINE decode_le32 #-}++-- | Decode a little-endian 64-bit integer.+--+-- >>> decode_le64 (BS.pack [0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])+-- Right (1, "")+decode_le64 :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)+decode_le64 !bs+ | BS.length bs < 8 = Left (InsufficientBytes 8 (BS.length bs))+ | otherwise =+ let !b0 = fromIntegral (BS.index bs 0)+ !b1 = fromIntegral (BS.index bs 1)+ !b2 = fromIntegral (BS.index bs 2)+ !b3 = fromIntegral (BS.index bs 3)+ !b4 = fromIntegral (BS.index bs 4)+ !b5 = fromIntegral (BS.index bs 5)+ !b6 = fromIntegral (BS.index bs 6)+ !b7 = fromIntegral (BS.index bs 7)+ !val = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16)+ .|. (b3 `shiftL` 24) .|. (b4 `shiftL` 32)+ .|. (b5 `shiftL` 40) .|. (b6 `shiftL` 48)+ .|. (b7 `shiftL` 56)+ !rest = BS.drop 8 bs+ in Right (val, rest)+{-# INLINE decode_le64 #-}++-- | Decode a Bitcoin varint (CompactSize).+--+-- Encoding:+-- * 0x00-0xFC: 1 byte+-- * 0xFD: 2 bytes little-endian follow+-- * 0xFE: 4 bytes little-endian follow+-- * 0xFF: 8 bytes little-endian follow+--+-- >>> decode_varint (BS.pack [0x01])+-- Right (1, "")+-- >>> decode_varint (BS.pack [0xfd, 0x00, 0x01])+-- Right (256, "")+decode_varint :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)+decode_varint !bs+ | BS.null bs = Left EmptyInput+ | otherwise =+ let !first = BS.index bs 0+ !rest = BS.drop 1 bs+ in case first of+ 0xFD -> decode_varint_16 rest+ 0xFE -> decode_varint_32 rest+ 0xFF -> decode_le64 rest+ _ -> Right (fromIntegral first, rest)+{-# INLINE decode_varint #-}++-- | Decode a 16-bit varint payload.+decode_varint_16 :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)+decode_varint_16 !bs+ | BS.length bs < 2 = Left (InsufficientBytes 2 (BS.length bs))+ | otherwise =+ let !b0 = fromIntegral (BS.index bs 0) :: Word64+ !b1 = fromIntegral (BS.index bs 1) :: Word64+ !val = b0 .|. (b1 `shiftL` 8)+ !rest = BS.drop 2 bs+ in Right (val, rest)+{-# INLINE decode_varint_16 #-}++-- | Decode a 32-bit varint payload.+decode_varint_32 :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)+decode_varint_32 !bs+ | BS.length bs < 4 = Left (InsufficientBytes 4 (BS.length bs))+ | otherwise =+ let !b0 = fromIntegral (BS.index bs 0) :: Word64+ !b1 = fromIntegral (BS.index bs 1) :: Word64+ !b2 = fromIntegral (BS.index bs 2) :: Word64+ !b3 = fromIntegral (BS.index bs 3) :: Word64+ !val = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16)+ .|. (b3 `shiftL` 24)+ !rest = BS.drop 4 bs+ in Right (val, rest)+{-# INLINE decode_varint_32 #-}++-- | Decode a transaction outpoint (txid + output index).+--+-- Format: 32 bytes txid (little-endian) + 4 bytes index (little-endian)+--+-- >>> let txid = BS.replicate 32 0+-- >>> let idx = BS.pack [0x01, 0x00, 0x00, 0x00]+-- >>> decode_outpoint (txid <> idx)+-- Right (Outpoint {outpoint_txid = ..., outpoint_index = 1}, "")+decode_outpoint+ :: BS.ByteString+ -> Either DecodeError (Outpoint, BS.ByteString)+decode_outpoint !bs+ | BS.length bs < 36 = Left (InsufficientBytes 36 (BS.length bs))+ | otherwise =+ let !txid = TxId (BS.take 32 bs)+ !rest1 = BS.drop 32 bs+ in case decode_le32 rest1 of+ Left err -> Left err+ Right (!idx, !rest2) ->+ let !outpoint = Outpoint txid idx+ in Right (outpoint, rest2)+{-# INLINE decode_outpoint #-}++-- | Decode a transaction output (value + scriptPubKey).+--+-- Format: 8 bytes value (little-endian) + varint script length + script+decode_output :: BS.ByteString -> Either DecodeError (RawOutput, BS.ByteString)+decode_output !bs = do+ (!value, !rest1) <- decode_le64 bs+ (!scriptLen, !rest2) <- decode_varint rest1+ let !len = fromIntegral scriptLen+ if BS.length rest2 < len+ then Left (InsufficientBytes len (BS.length rest2))+ else+ let !script = Script (BS.take len rest2)+ !rest3 = BS.drop len rest2+ !output = RawOutput (Satoshi value) script+ in Right (output, rest3)+{-# INLINE decode_output #-}++-- witness parsing -------------------------------------------------------------++-- | Decode a witness stack for one input.+--+-- Format: varint num_items + (varint length + data) for each item+decode_witness+ :: BS.ByteString+ -> Either DecodeError (Witness, BS.ByteString)+decode_witness !bs = do+ (!numItems, !rest1) <- decode_varint bs+ (!items, !rest2) <- decode_witness_items (fromIntegral numItems) rest1 []+ Right (Witness items, rest2)+{-# INLINE decode_witness #-}++-- | Decode witness items recursively.+decode_witness_items+ :: Int+ -> BS.ByteString+ -> [BS.ByteString]+ -> Either DecodeError ([BS.ByteString], BS.ByteString)+decode_witness_items 0 !bs !acc = Right (reverse acc, bs)+decode_witness_items !n !bs !acc = do+ (!itemLen, !rest1) <- decode_varint bs+ let !len = fromIntegral itemLen+ if BS.length rest1 < len+ then Left (InsufficientBytes len (BS.length rest1))+ else+ let !item = BS.take len rest1+ !rest2 = BS.drop len rest1+ in decode_witness_items (n - 1) rest2 (item : acc)++-- | Decode witness stacks for all inputs (internal, returns list).+decode_witness_stacks+ :: Int+ -> BS.ByteString+ -> [[BS.ByteString]]+ -> Either DecodeError ([[BS.ByteString]], BS.ByteString)+decode_witness_stacks 0 !bs !acc = Right (reverse acc, bs)+decode_witness_stacks !n !bs !acc = do+ (Witness !items, !rest) <- decode_witness bs+ decode_witness_stacks (n - 1) rest (items : acc)++-- transaction parsing ---------------------------------------------------------++-- | Decode a raw Bitcoin transaction from bytes.+--+-- Handles both legacy and SegWit transaction formats.+--+-- SegWit format:+-- * version (4 bytes LE)+-- * marker (0x00) + flag (0x01)+-- * input count (varint)+-- * inputs: outpoint (32+4), scriptSig length (varint), scriptSig, sequence+-- * output count (varint)+-- * outputs: value (8 LE), scriptPubKey length (varint), scriptPubKey+-- * witness data (for each input)+-- * locktime (4 bytes LE)+--+-- >>> decode_tx rawTxBytes+-- Right (RawTx {...})+decode_tx :: BS.ByteString -> Either DecodeError RawTx+decode_tx !bs = do+ -- Version (4 bytes LE)+ (!version, !rest1) <- decode_le32 bs++ -- Check for SegWit marker/flag+ let !hasWitness = BS.length rest1 >= 2 &&+ BS.index rest1 0 == 0x00 &&+ BS.index rest1 1 == 0x01++ if hasWitness+ then decode_tx_segwit version (BS.drop 2 rest1)+ else decode_tx_legacy version rest1+{-# INLINE decode_tx #-}++-- | Decode a SegWit transaction (after marker/flag consumed).+decode_tx_segwit+ :: Word32+ -> BS.ByteString+ -> Either DecodeError RawTx+decode_tx_segwit !version !bs = do+ -- Input count and inputs+ (!inputCount, !rest1) <- decode_varint bs+ (!inputs, !rest2) <- decode_inputs (fromIntegral inputCount) rest1 []++ -- Output count and outputs+ (!outputCount, !rest3) <- decode_varint rest2+ (!outputs, !rest4) <- decode_outputs (fromIntegral outputCount) rest3 []++ -- Witness data for each input+ (!witnesses, !rest5) <- decode_witness_stacks (length inputs) rest4 []++ -- Locktime (4 bytes LE)+ (!locktime, !_rest6) <- decode_le32 rest5++ Right RawTx+ { rtx_version = version+ , rtx_inputs = inputs+ , rtx_outputs = outputs+ , rtx_witness = witnesses+ , rtx_locktime = Locktime locktime+ }++-- | Decode a legacy (non-SegWit) transaction.+decode_tx_legacy+ :: Word32+ -> BS.ByteString+ -> Either DecodeError RawTx+decode_tx_legacy !version !bs = do+ -- Input count and inputs+ (!inputCount, !rest1) <- decode_varint bs+ (!inputs, !rest2) <- decode_inputs (fromIntegral inputCount) rest1 []++ -- Output count and outputs+ (!outputCount, !rest3) <- decode_varint rest2+ (!outputs, !rest4) <- decode_outputs (fromIntegral outputCount) rest3 []++ -- Locktime (4 bytes LE)+ (!locktime, !_rest5) <- decode_le32 rest4++ Right RawTx+ { rtx_version = version+ , rtx_inputs = inputs+ , rtx_outputs = outputs+ , rtx_witness = []+ , rtx_locktime = Locktime locktime+ }++-- | Decode transaction inputs recursively.+decode_inputs+ :: Int+ -> BS.ByteString+ -> [RawInput]+ -> Either DecodeError ([RawInput], BS.ByteString)+decode_inputs 0 !bs !acc = Right (reverse acc, bs)+decode_inputs !n !bs !acc = do+ (!input, !rest) <- decode_input bs+ decode_inputs (n - 1) rest (input : acc)++-- | Decode a single transaction input.+--+-- Format: outpoint (36 bytes) + scriptSig length (varint) + scriptSig ++-- sequence (4 bytes LE)+decode_input :: BS.ByteString -> Either DecodeError (RawInput, BS.ByteString)+decode_input !bs = do+ (!outpoint, !rest1) <- decode_outpoint bs+ (!scriptLen, !rest2) <- decode_varint rest1+ let !len = fromIntegral scriptLen+ if BS.length rest2 < len+ then Left (InsufficientBytes len (BS.length rest2))+ else do+ let !scriptSig = BS.take len rest2+ !rest3 = BS.drop len rest2+ (!seqNum, !rest4) <- decode_le32 rest3+ let !input = RawInput outpoint scriptSig (Sequence seqNum)+ Right (input, rest4)++-- | Decode transaction outputs recursively.+decode_outputs+ :: Int+ -> BS.ByteString+ -> [RawOutput]+ -> Either DecodeError ([RawOutput], BS.ByteString)+decode_outputs 0 !bs !acc = Right (reverse acc, bs)+decode_outputs !n !bs !acc = do+ (!output, !rest) <- decode_output bs+ decode_outputs (n - 1) rest (output : acc)
+ lib/Lightning/Protocol/BOLT3/Encode.hs view
@@ -0,0 +1,298 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Encode+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Serialization for BOLT #3 transactions and scripts.+--+-- Provides Bitcoin transaction serialization in both standard SegWit+-- format (with witness data) and the stripped format used for signing.+--+-- == Transaction Format (SegWit)+--+-- * version (4 bytes LE)+-- * marker (0x00) + flag (0x01)+-- * input count (varint)+-- * inputs: outpoint (32+4), scriptSig length (varint), scriptSig, sequence+-- * output count (varint)+-- * outputs: value (8 LE), scriptPubKey length (varint), scriptPubKey+-- * witness data (for each input)+-- * locktime (4 bytes LE)++module Lightning.Protocol.BOLT3.Encode (+ -- * Transaction serialization+ encode_tx+ , encode_htlc_tx+ , encode_closing_tx+ , encode_tx_for_signing++ -- * Witness serialization+ , encode_witness+ , encode_funding_witness++ -- * Primitive encoding+ , encode_varint+ , encode_le32+ , encode_le64+ , encode_outpoint+ , encode_output+ ) where++import Data.Word (Word32, Word64)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL+import Lightning.Protocol.BOLT3.Types+import Lightning.Protocol.BOLT3.Tx++-- primitive encoding ----------------------------------------------------------++-- | Encode a 32-bit value in little-endian format.+--+-- >>> encode_le32 0x12345678+-- "\x78\x56\x34\x12"+encode_le32 :: Word32 -> BS.ByteString+encode_le32 = BSL.toStrict . BSB.toLazyByteString . BSB.word32LE+{-# INLINE encode_le32 #-}++-- | Encode a 64-bit value in little-endian format.+--+-- >>> encode_le64 0x123456789ABCDEF0+-- "\xF0\xDE\xBC\x9A\x78\x56\x34\x12"+encode_le64 :: Word64 -> BS.ByteString+encode_le64 = BSL.toStrict . BSB.toLazyByteString . BSB.word64LE+{-# INLINE encode_le64 #-}++-- | Encode a value as a Bitcoin varint (CompactSize).+--+-- Encoding scheme:+--+-- * 0-252: 1 byte+-- * 253-65535: 0xFD followed by 2 bytes LE+-- * 65536-4294967295: 0xFE followed by 4 bytes LE+-- * larger: 0xFF followed by 8 bytes LE+--+-- >>> encode_varint 100+-- "\x64"+-- >>> encode_varint 1000+-- "\xFD\xE8\x03"+encode_varint :: Word64 -> BS.ByteString+encode_varint !n+ | n < 0xFD = BS.singleton (fromIntegral n)+ | n <= 0xFFFF = BSL.toStrict $ BSB.toLazyByteString $+ BSB.word8 0xFD <> BSB.word16LE (fromIntegral n)+ | n <= 0xFFFFFFFF = BSL.toStrict $ BSB.toLazyByteString $+ BSB.word8 0xFE <> BSB.word32LE (fromIntegral n)+ | otherwise = BSL.toStrict $ BSB.toLazyByteString $+ BSB.word8 0xFF <> BSB.word64LE n+{-# INLINE encode_varint #-}++-- | Encode an outpoint (txid + output index).+--+-- Format: 32 bytes txid (already LE in TxId) + 4 bytes output index LE+--+-- >>> encode_outpoint (Outpoint txid 0)+-- <32-byte txid><4-byte index>+encode_outpoint :: Outpoint -> BS.ByteString+encode_outpoint !op = BSL.toStrict $ BSB.toLazyByteString $+ BSB.byteString (unTxId $ outpoint_txid op) <>+ BSB.word32LE (outpoint_index op)+{-# INLINE encode_outpoint #-}++-- | Encode a transaction output.+--+-- Format: 8 bytes value LE + varint scriptPubKey length + scriptPubKey+--+-- >>> encode_output (TxOutput (Satoshi 100000) script OutputToLocal)+-- <8-byte value><varint length><scriptPubKey>+encode_output :: TxOutput -> BS.ByteString+encode_output !out = BSL.toStrict $ BSB.toLazyByteString $+ let !script = unScript (txout_script out)+ !scriptLen = fromIntegral (BS.length script) :: Word64+ in BSB.word64LE (unSatoshi $ txout_value out) <>+ varint_builder scriptLen <>+ BSB.byteString script+{-# INLINE encode_output #-}++-- witness encoding ------------------------------------------------------------++-- | Encode a witness stack.+--+-- Format: varint item count + (varint length + data) for each item+--+-- >>> encode_witness (Witness [sig, pubkey])+-- <varint 2><varint sigLen><sig><varint pkLen><pubkey>+encode_witness :: Witness -> BS.ByteString+encode_witness (Witness !items) = BSL.toStrict $ BSB.toLazyByteString $+ let !count = fromIntegral (length items) :: Word64+ in varint_builder count <> mconcat (map encode_witness_item items)+{-# INLINE encode_witness #-}++-- | Encode a single witness stack item.+encode_witness_item :: BS.ByteString -> BSB.Builder+encode_witness_item !bs =+ let !len = fromIntegral (BS.length bs) :: Word64+ in varint_builder len <> BSB.byteString bs+{-# INLINE encode_witness_item #-}++-- | Encode a funding witness (2-of-2 multisig).+--+-- The witness stack is: @0 <sig1> <sig2> <witnessScript>@+--+-- Signatures must be ordered to match pubkey order in the funding script.+--+-- >>> encode_funding_witness sig1 sig2 fundingScript+-- <witness with 4 items: empty, sig1, sig2, script>+encode_funding_witness+ :: BS.ByteString -- ^ Signature for pubkey1 (lexicographically lesser)+ -> BS.ByteString -- ^ Signature for pubkey2 (lexicographically greater)+ -> Script -- ^ The funding witness script+ -> BS.ByteString+encode_funding_witness !sig1 !sig2 (Script !witnessScript) =+ BSL.toStrict $ BSB.toLazyByteString $+ varint_builder 4 <>+ encode_witness_item BS.empty <>+ encode_witness_item sig1 <>+ encode_witness_item sig2 <>+ encode_witness_item witnessScript+{-# INLINE encode_funding_witness #-}++-- transaction encoding --------------------------------------------------------++-- | Encode a commitment transaction (SegWit format with witness).+--+-- SegWit format:+--+-- * version (4 bytes LE)+-- * marker (0x00)+-- * flag (0x01)+-- * input count (varint)+-- * inputs+-- * output count (varint)+-- * outputs+-- * witness data+-- * locktime (4 bytes LE)+--+-- Note: The witness is empty (just count=0) since the commitment tx+-- spending the funding output requires external signatures.+encode_tx :: CommitmentTx -> BS.ByteString+encode_tx !tx = BSL.toStrict $ BSB.toLazyByteString $+ -- Version+ BSB.word32LE (ctx_version tx) <>+ -- SegWit marker and flag+ BSB.word8 0x00 <>+ BSB.word8 0x01 <>+ -- Input count (always 1 for commitment tx)+ varint_builder 1 <>+ -- Input: outpoint + empty scriptSig + sequence+ BSB.byteString (encode_outpoint (ctx_input_outpoint tx)) <>+ varint_builder 0 <> -- scriptSig length (empty for SegWit)+ BSB.word32LE (unSequence $ ctx_input_sequence tx) <>+ -- Output count+ varint_builder (fromIntegral $ length $ ctx_outputs tx) <>+ -- Outputs+ mconcat (map (BSB.byteString . encode_output) (ctx_outputs tx)) <>+ -- Witness (empty stack for unsigned tx)+ varint_builder 0 <>+ -- Locktime+ BSB.word32LE (unLocktime $ ctx_locktime tx)++-- | Encode an HTLC transaction (SegWit format with witness).+--+-- HTLC transactions have a single input (the commitment tx HTLC output)+-- and a single output (the to_local-style delayed output).+encode_htlc_tx :: HTLCTx -> BS.ByteString+encode_htlc_tx !tx = BSL.toStrict $ BSB.toLazyByteString $+ -- Version+ BSB.word32LE (htx_version tx) <>+ -- SegWit marker and flag+ BSB.word8 0x00 <>+ BSB.word8 0x01 <>+ -- Input count (always 1)+ varint_builder 1 <>+ -- Input: outpoint + empty scriptSig + sequence+ BSB.byteString (encode_outpoint (htx_input_outpoint tx)) <>+ varint_builder 0 <> -- scriptSig length (empty for SegWit)+ BSB.word32LE (unSequence $ htx_input_sequence tx) <>+ -- Output count (always 1)+ varint_builder 1 <>+ -- Output: value + scriptPubKey+ BSB.word64LE (unSatoshi $ htx_output_value tx) <>+ let !script = unScript (htx_output_script tx)+ !scriptLen = fromIntegral (BS.length script) :: Word64+ in varint_builder scriptLen <> BSB.byteString script <>+ -- Witness (empty stack for unsigned tx)+ varint_builder 0 <>+ -- Locktime+ BSB.word32LE (unLocktime $ htx_locktime tx)++-- | Encode a closing transaction (SegWit format with witness).+--+-- Closing transactions have a single input (the funding output) and+-- one or two outputs (to_local and/or to_remote).+encode_closing_tx :: ClosingTx -> BS.ByteString+encode_closing_tx !tx = BSL.toStrict $ BSB.toLazyByteString $+ -- Version+ BSB.word32LE (cltx_version tx) <>+ -- SegWit marker and flag+ BSB.word8 0x00 <>+ BSB.word8 0x01 <>+ -- Input count (always 1)+ varint_builder 1 <>+ -- Input: outpoint + empty scriptSig + sequence+ BSB.byteString (encode_outpoint (cltx_input_outpoint tx)) <>+ varint_builder 0 <> -- scriptSig length (empty for SegWit)+ BSB.word32LE (unSequence $ cltx_input_sequence tx) <>+ -- Output count+ varint_builder (fromIntegral $ length $ cltx_outputs tx) <>+ -- Outputs+ mconcat (map (BSB.byteString . encode_output) (cltx_outputs tx)) <>+ -- Witness (empty stack for unsigned tx)+ varint_builder 0 <>+ -- Locktime+ BSB.word32LE (unLocktime $ cltx_locktime tx)++-- | Encode a commitment transaction for signing (stripped format).+--+-- The stripped format omits the SegWit marker, flag, and witness data.+-- This is the format used to compute the sighash for signing.+--+-- Format:+--+-- * version (4 bytes LE)+-- * input count (varint)+-- * inputs+-- * output count (varint)+-- * outputs+-- * locktime (4 bytes LE)+encode_tx_for_signing :: CommitmentTx -> BS.ByteString+encode_tx_for_signing !tx = BSL.toStrict $ BSB.toLazyByteString $+ -- Version+ BSB.word32LE (ctx_version tx) <>+ -- Input count (always 1 for commitment tx)+ varint_builder 1 <>+ -- Input: outpoint + empty scriptSig + sequence+ BSB.byteString (encode_outpoint (ctx_input_outpoint tx)) <>+ varint_builder 0 <> -- scriptSig length (empty for SegWit)+ BSB.word32LE (unSequence $ ctx_input_sequence tx) <>+ -- Output count+ varint_builder (fromIntegral $ length $ ctx_outputs tx) <>+ -- Outputs+ mconcat (map (BSB.byteString . encode_output) (ctx_outputs tx)) <>+ -- Locktime+ BSB.word32LE (unLocktime $ ctx_locktime tx)++-- internal helpers ------------------------------------------------------------++-- | Build a varint directly to Builder.+varint_builder :: Word64 -> BSB.Builder+varint_builder !n+ | n < 0xFD = BSB.word8 (fromIntegral n)+ | n <= 0xFFFF = BSB.word8 0xFD <> BSB.word16LE (fromIntegral n)+ | n <= 0xFFFFFFFF = BSB.word8 0xFE <> BSB.word32LE (fromIntegral n)+ | otherwise = BSB.word8 0xFF <> BSB.word64LE n+{-# INLINE varint_builder #-}
+ lib/Lightning/Protocol/BOLT3/Keys.hs view
@@ -0,0 +1,426 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Keys+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Per-commitment key derivation per BOLT #3.+--+-- Implements key derivation formulas:+--+-- @+-- pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G+-- revocationpubkey = revocation_basepoint * SHA256(revocation_basepoint+-- || per_commitment_point)+-- + per_commitment_point * SHA256(per_commitment_point+-- || revocation_basepoint)+-- @++module Lightning.Protocol.BOLT3.Keys (+ -- * Per-commitment point derivation+ derive_per_commitment_point++ -- * Key derivation+ , derive_pubkey+ , derive_localpubkey+ , derive_local_htlcpubkey+ , derive_remote_htlcpubkey+ , derive_local_delayedpubkey+ , derive_remote_delayedpubkey++ -- * Revocation key derivation+ , derive_revocationpubkey++ -- * Per-commitment secret generation+ , generate_from_seed+ , derive_secret++ -- * Per-commitment secret storage+ , SecretStore+ , empty_store+ , insert_secret+ , derive_old_secret++ -- * Commitment number obscuring+ , obscured_commitment_number+ ) where++import Data.Bits ((.&.), xor, shiftL, testBit, complementBit)+import qualified Data.ByteString as BS+import Data.Word (Word64)+import GHC.Generics (Generic)+import qualified Crypto.Curve.Secp256k1 as S+import qualified Crypto.Hash.SHA256 as SHA256+import Lightning.Protocol.BOLT3.Types++-- Per-commitment point derivation ----------------------------------------++-- | Derive the per-commitment point from a per-commitment secret.+--+-- @per_commitment_point = per_commitment_secret * G@+--+-- >>> let secret = PerCommitmentSecret (BS.replicate 32 0x01)+-- >>> derive_per_commitment_point secret+-- Just (PerCommitmentPoint ...)+derive_per_commitment_point+ :: PerCommitmentSecret+ -> Maybe PerCommitmentPoint+derive_per_commitment_point (PerCommitmentSecret sec) = do+ sk <- S.parse_int256 sec+ pk <- S.derive_pub sk+ let !bs = S.serialize_point pk+ pure $! PerCommitmentPoint (Point bs)+{-# INLINE derive_per_commitment_point #-}++-- Key derivation ---------------------------------------------------------++-- | Derive a pubkey from a basepoint and per-commitment point.+--+-- @pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G@+--+-- This is the general derivation formula used for localpubkey,+-- local_htlcpubkey, remote_htlcpubkey, local_delayedpubkey, and+-- remote_delayedpubkey.+--+-- >>> derive_pubkey basepoint per_commitment_point+-- Just (Pubkey ...)+derive_pubkey+ :: Point -- ^ basepoint+ -> PerCommitmentPoint -- ^ per_commitment_point+ -> Maybe Pubkey+derive_pubkey (Point basepointBs) (PerCommitmentPoint (Point pcpBs)) = do+ basepoint <- S.parse_point basepointBs+ -- SHA256(per_commitment_point || basepoint)+ let !h = SHA256.hash (pcpBs <> basepointBs)+ -- Treat hash as scalar and multiply by G+ tweak <- S.parse_int256 h+ tweakPoint <- S.derive_pub tweak+ -- Add basepoint + tweak*G+ let !result = S.add basepoint tweakPoint+ !bs = S.serialize_point result+ pure $! Pubkey bs+{-# INLINE derive_pubkey #-}++-- | Derive localpubkey from payment_basepoint and per_commitment_point.+--+-- >>> derive_localpubkey payment_basepoint per_commitment_point+-- Just (LocalPubkey ...)+derive_localpubkey+ :: PaymentBasepoint+ -> PerCommitmentPoint+ -> Maybe LocalPubkey+derive_localpubkey (PaymentBasepoint pt) pcp =+ LocalPubkey <$> derive_pubkey pt pcp+{-# INLINE derive_localpubkey #-}++-- | Derive local_htlcpubkey from htlc_basepoint and per_commitment_point.+--+-- >>> derive_local_htlcpubkey htlc_basepoint per_commitment_point+-- Just (LocalHtlcPubkey ...)+derive_local_htlcpubkey+ :: HtlcBasepoint+ -> PerCommitmentPoint+ -> Maybe LocalHtlcPubkey+derive_local_htlcpubkey (HtlcBasepoint pt) pcp =+ LocalHtlcPubkey <$> derive_pubkey pt pcp+{-# INLINE derive_local_htlcpubkey #-}++-- | Derive remote_htlcpubkey from htlc_basepoint and per_commitment_point.+--+-- >>> derive_remote_htlcpubkey htlc_basepoint per_commitment_point+-- Just (RemoteHtlcPubkey ...)+derive_remote_htlcpubkey+ :: HtlcBasepoint+ -> PerCommitmentPoint+ -> Maybe RemoteHtlcPubkey+derive_remote_htlcpubkey (HtlcBasepoint pt) pcp =+ RemoteHtlcPubkey <$> derive_pubkey pt pcp+{-# INLINE derive_remote_htlcpubkey #-}++-- | Derive local_delayedpubkey from delayed_payment_basepoint and+-- per_commitment_point.+--+-- >>> derive_local_delayedpubkey delayed_payment_basepoint per_commitment_point+-- Just (LocalDelayedPubkey ...)+derive_local_delayedpubkey+ :: DelayedPaymentBasepoint+ -> PerCommitmentPoint+ -> Maybe LocalDelayedPubkey+derive_local_delayedpubkey (DelayedPaymentBasepoint pt) pcp =+ LocalDelayedPubkey <$> derive_pubkey pt pcp+{-# INLINE derive_local_delayedpubkey #-}++-- | Derive remote_delayedpubkey from delayed_payment_basepoint and+-- per_commitment_point.+--+-- >>> derive_remote_delayedpubkey delayed_payment_basepoint pcp+-- Just (RemoteDelayedPubkey ...)+derive_remote_delayedpubkey+ :: DelayedPaymentBasepoint+ -> PerCommitmentPoint+ -> Maybe RemoteDelayedPubkey+derive_remote_delayedpubkey (DelayedPaymentBasepoint pt) pcp =+ RemoteDelayedPubkey <$> derive_pubkey pt pcp+{-# INLINE derive_remote_delayedpubkey #-}++-- Revocation key derivation ----------------------------------------------++-- | Derive revocationpubkey from revocation_basepoint and+-- per_commitment_point.+--+-- @+-- revocationpubkey = revocation_basepoint+-- * SHA256(revocation_basepoint || per_commitment_point)+-- + per_commitment_point+-- * SHA256(per_commitment_point || revocation_basepoint)+-- @+--+-- >>> derive_revocationpubkey revocation_basepoint per_commitment_point+-- Just (RevocationPubkey ...)+derive_revocationpubkey+ :: RevocationBasepoint+ -> PerCommitmentPoint+ -> Maybe RevocationPubkey+derive_revocationpubkey+ (RevocationBasepoint (Point rbpBs))+ (PerCommitmentPoint (Point pcpBs)) = do+ rbp <- S.parse_point rbpBs+ pcp <- S.parse_point pcpBs+ -- SHA256(revocation_basepoint || per_commitment_point)+ let !h1 = SHA256.hash (rbpBs <> pcpBs)+ -- SHA256(per_commitment_point || revocation_basepoint)+ let !h2 = SHA256.hash (pcpBs <> rbpBs)+ -- Multiply points by their respective scalars+ s1 <- S.parse_int256 h1+ s2 <- S.parse_int256 h2+ p1 <- S.mul rbp s1 -- revocation_basepoint * h1+ p2 <- S.mul pcp s2 -- per_commitment_point * h2+ -- Add the two points+ let !result = S.add p1 p2+ !bs = S.serialize_point result+ pure $! RevocationPubkey (Pubkey bs)+{-# INLINE derive_revocationpubkey #-}++-- Per-commitment secret generation ---------------------------------------++-- | Generate the I'th per-commitment secret from a seed.+--+-- Implements the generate_from_seed algorithm from BOLT #3:+--+-- @+-- generate_from_seed(seed, I):+-- P = seed+-- for B in 47 down to 0:+-- if B set in I:+-- flip(B) in P+-- P = SHA256(P)+-- return P+-- @+--+-- >>> generate_from_seed seed 281474976710655+-- <32-byte secret>+generate_from_seed+ :: BS.ByteString -- ^ seed (32 bytes)+ -> Word64 -- ^ index I (max 2^48 - 1)+ -> BS.ByteString -- ^ per-commitment secret (32 bytes)+generate_from_seed seed idx = go 47 seed where+ go :: Int -> BS.ByteString -> BS.ByteString+ go !b !p+ | b < 0 = p+ | testBit idx b =+ let !p' = flip_bit b p+ !p'' = SHA256.hash p'+ in go (b - 1) p''+ | otherwise = go (b - 1) p+{-# INLINE generate_from_seed #-}++-- | Derive a secret from a base secret.+--+-- This is a generalization of generate_from_seed used for efficient+-- secret storage. Given a base secret whose index has bits..47 the same+-- as target index I, derive the I'th secret.+--+-- @+-- derive_secret(base, bits, I):+-- P = base+-- for B in bits - 1 down to 0:+-- if B set in I:+-- flip(B) in P+-- P = SHA256(P)+-- return P+-- @+derive_secret+ :: BS.ByteString -- ^ base secret+ -> Int -- ^ bits (number of trailing bits to process)+ -> Word64 -- ^ target index I+ -> BS.ByteString -- ^ derived secret+derive_secret base bits idx = go (bits - 1) base where+ go :: Int -> BS.ByteString -> BS.ByteString+ go !b !p+ | b < 0 = p+ | testBit idx b =+ let !p' = flip_bit b p+ !p'' = SHA256.hash p'+ in go (b - 1) p''+ | otherwise = go (b - 1) p+{-# INLINE derive_secret #-}++-- | Flip bit B in a 32-byte bytestring.+--+-- "flip(B)" alternates the (B mod 8) bit of the (B div 8) byte.+flip_bit :: Int -> BS.ByteString -> BS.ByteString+flip_bit b bs =+ let !byteIdx = b `div` 8+ !bitIdx = b `mod` 8+ !len = BS.length bs+ in if byteIdx >= len+ then bs+ else+ let !prefix = BS.take byteIdx bs+ !byte = BS.index bs byteIdx+ !byte' = complementBit byte bitIdx+ !suffix = BS.drop (byteIdx + 1) bs+ in prefix <> BS.singleton byte' <> suffix+{-# INLINE flip_bit #-}++-- Per-commitment secret storage ------------------------------------------++-- | Entry in the secret store: (bucket, index, secret).+data SecretEntry = SecretEntry+ { se_bucket :: {-# UNPACK #-} !Int+ , se_index :: {-# UNPACK #-} !Word64+ , se_secret :: !BS.ByteString+ } deriving (Eq, Show, Generic)++-- | Compact storage for per-commitment secrets.+--+-- Stores up to 49 (value, index) pairs, allowing efficient derivation+-- of any previously-received secret. This is possible because for a+-- given secret on a 2^X boundary, all secrets up to the next 2^X+-- boundary can be derived from it.+newtype SecretStore = SecretStore { unSecretStore :: [SecretEntry] }+ deriving (Eq, Show, Generic)++-- | Empty secret store.+empty_store :: SecretStore+empty_store = SecretStore []+{-# INLINE empty_store #-}++-- | Determine which bucket to store a secret in based on its index.+--+-- Counts trailing zeros in the index. Returns 0-47 for normal indices,+-- or 48 if index is 0 (the seed).+where_to_put_secret :: Word64 -> Int+where_to_put_secret idx = go 0 where+ go !b+ | b > 47 = 48 -- index 0, this is the seed+ | testBit idx b = b+ | otherwise = go (b + 1)+{-# INLINE where_to_put_secret #-}++-- | Insert a secret into the store, validating against existing secrets.+--+-- Returns Nothing if the secret doesn't derive correctly from known+-- secrets (indicating the secrets weren't generated from the same seed).+--+-- >>> insert_secret secret 281474976710655 empty_store+-- Just (SecretStore ...)+insert_secret+ :: BS.ByteString -- ^ secret (32 bytes)+ -> Word64 -- ^ index+ -> SecretStore -- ^ current store+ -> Maybe SecretStore+insert_secret secret idx (SecretStore known) = do+ let !bucket = where_to_put_secret idx+ -- Validate: for each bucket < this bucket, check we can derive+ validated <- validateBuckets bucket known+ if validated+ then+ -- Remove entries at bucket >= this bucket, then insert+ let !known' = filter (\e -> se_bucket e < bucket) known+ !entry = SecretEntry bucket idx secret+ in pure $! SecretStore (known' ++ [entry])+ else Nothing+ where+ validateBuckets :: Int -> [SecretEntry] -> Maybe Bool+ validateBuckets b entries = go entries where+ go [] = Just True+ go (SecretEntry entryBucket knownIdx knownSecret : rest)+ | entryBucket >= b = go rest -- skip entries at higher buckets+ | otherwise =+ -- Check if we can derive the known secret from the new one+ let !derived = derive_secret secret b knownIdx+ in if derived == knownSecret+ then go rest+ else Nothing+{-# INLINE insert_secret #-}++-- | Derive a previously-received secret from the store.+--+-- Iterates over known secrets to find one whose index is a prefix of+-- the target index, then derives the target secret from it.+--+-- >>> derive_old_secret 281474976710654 store+-- Just <32-byte secret>+derive_old_secret+ :: Word64 -- ^ target index+ -> SecretStore -- ^ store+ -> Maybe BS.ByteString+derive_old_secret targetIdx (SecretStore known) = go known where+ go :: [SecretEntry] -> Maybe BS.ByteString+ go [] = Nothing+ go (SecretEntry bucket knownIdx knownSecret : rest) =+ -- Mask off the non-zero prefix of the index using the entry's bucket+ let !mask = complement ((1 `shiftL` bucket) - 1)+ in if (targetIdx .&. mask) == knownIdx+ then Just $! derive_secret knownSecret bucket targetIdx+ else go rest++ complement :: Word64 -> Word64+ complement x = x `xor` 0xFFFFFFFFFFFFFFFF+{-# INLINE derive_old_secret #-}++-- Commitment number obscuring --------------------------------------------++-- | Calculate the obscured commitment number.+--+-- The 48-bit commitment number is obscured by XOR with the lower 48 bits+-- of SHA256(payment_basepoint from open_channel+-- || payment_basepoint from accept_channel).+--+-- >>> obscured_commitment_number local_payment_bp remote_payment_bp cn+-- <obscured value>+obscured_commitment_number+ :: PaymentBasepoint -- ^ opener's payment_basepoint+ -> PaymentBasepoint -- ^ accepter's payment_basepoint+ -> CommitmentNumber -- ^ commitment number (48-bit)+ -> Word64 -- ^ obscured commitment number+obscured_commitment_number+ (PaymentBasepoint (Point openerBs))+ (PaymentBasepoint (Point accepterBs))+ (CommitmentNumber cn) =+ let !h = SHA256.hash (openerBs <> accepterBs)+ -- Extract lower 48 bits (6 bytes) from the hash+ !lower48 = extractLower48 h+ -- Mask commitment number to 48 bits+ !cn48 = cn .&. 0xFFFFFFFFFFFF+ in cn48 `xor` lower48+{-# INLINE obscured_commitment_number #-}++-- | Extract lower 48 bits from a 32-byte hash.+--+-- Takes bytes 26-31 (last 6 bytes) and interprets as big-endian Word64.+extractLower48 :: BS.ByteString -> Word64+extractLower48 h =+ let !b0 = fromIntegral (BS.index h 26) `shiftL` 40+ !b1 = fromIntegral (BS.index h 27) `shiftL` 32+ !b2 = fromIntegral (BS.index h 28) `shiftL` 24+ !b3 = fromIntegral (BS.index h 29) `shiftL` 16+ !b4 = fromIntegral (BS.index h 30) `shiftL` 8+ !b5 = fromIntegral (BS.index h 31)+ in b0 + b1 + b2 + b3 + b4 + b5+{-# INLINE extractLower48 #-}
+ lib/Lightning/Protocol/BOLT3/Scripts.hs view
@@ -0,0 +1,677 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Scripts+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Script templates for BOLT #3 transaction outputs.+--+-- Includes witness scripts for:+--+-- * Funding output (2-of-2 multisig)+-- * to_local output (revocable with CSV delay)+-- * to_remote output (P2WPKH or anchored)+-- * Anchor outputs+-- * Offered HTLC outputs+-- * Received HTLC outputs+-- * HTLC-timeout/success output (revocable with delay)++module Lightning.Protocol.BOLT3.Scripts (+ -- * Funding output+ funding_script+ , funding_witness++ -- * to_local output+ , to_local_script+ , to_local_witness_spend+ , to_local_witness_revoke++ -- * to_remote output+ , to_remote_script+ , to_remote_witness++ -- * Anchor outputs+ , anchor_script+ , anchor_witness_owner+ , anchor_witness_anyone++ -- * Offered HTLC output+ , offered_htlc_script+ , offered_htlc_witness_preimage+ , offered_htlc_witness_revoke++ -- * Received HTLC output+ , received_htlc_script+ , received_htlc_witness_timeout+ , received_htlc_witness_revoke++ -- * HTLC-timeout/success output (same as to_local)+ , htlc_output_script+ , htlc_output_witness_spend+ , htlc_output_witness_revoke++ -- * P2WSH helpers+ , to_p2wsh+ , witness_script_hash+ ) where++import Data.Bits ((.&.), shiftR)+import Data.Word (Word8, Word16, Word32)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Hash.RIPEMD160 as RIPEMD160+import Lightning.Protocol.BOLT3.Types++-- opcodes ---------------------------------------------------------------------++-- | OP_0 / OP_FALSE (0x00)+op_0 :: Word8+op_0 = 0x00++-- | OP_PUSHDATA for 1-75 bytes just uses the length as opcode+-- For data <=75 bytes, opcode is just the length++-- | OP_IF (0x63)+op_if :: Word8+op_if = 0x63++-- | OP_NOTIF (0x64)+op_notif :: Word8+op_notif = 0x64++-- | OP_ELSE (0x67)+op_else :: Word8+op_else = 0x67++-- | OP_ENDIF (0x68)+op_endif :: Word8+op_endif = 0x68++-- | OP_DROP (0x75)+op_drop :: Word8+op_drop = 0x75++-- | OP_DUP (0x76)+op_dup :: Word8+op_dup = 0x76++-- | OP_SWAP (0x7c)+op_swap :: Word8+op_swap = 0x7c++-- | OP_SIZE (0x82)+op_size :: Word8+op_size = 0x82++-- | OP_EQUAL (0x87)+op_equal :: Word8+op_equal = 0x87++-- | OP_EQUALVERIFY (0x88)+op_equalverify :: Word8+op_equalverify = 0x88++-- | OP_IFDUP (0x73)+op_ifdup :: Word8+op_ifdup = 0x73++-- | OP_HASH160 (0xa9)+op_hash160 :: Word8+op_hash160 = 0xa9++-- | OP_CHECKSIG (0xac)+op_checksig :: Word8+op_checksig = 0xac++-- | OP_CHECKSIGVERIFY (0xad)+op_checksigverify :: Word8+op_checksigverify = 0xad++-- | OP_CHECKMULTISIG (0xae)+op_checkmultisig :: Word8+op_checkmultisig = 0xae++-- | OP_CHECKLOCKTIMEVERIFY (0xb1)+op_checklocktimeverify :: Word8+op_checklocktimeverify = 0xb1++-- | OP_CHECKSEQUENCEVERIFY (0xb2)+op_checksequenceverify :: Word8+op_checksequenceverify = 0xb2++-- | OP_1 (0x51)+op_1 :: Word8+op_1 = 0x51++-- | OP_2 (0x52)+op_2 :: Word8+op_2 = 0x52++-- | OP_16 (0x60)+op_16 :: Word8+op_16 = 0x60++-- helpers ---------------------------------------------------------------------++-- | Push a bytestring onto the stack (handles length encoding).+--+-- For data <= 75 bytes, the length itself is the opcode.+push_data :: BS.ByteString -> BSB.Builder+push_data !bs+ | len <= 75 = BSB.word8 (fromIntegral len) <> BSB.byteString bs+ | len <= 255 = BSB.word8 0x4c <> BSB.word8 (fromIntegral len)+ <> BSB.byteString bs+ | len <= 65535 = BSB.word8 0x4d <> BSB.word16LE (fromIntegral len)+ <> BSB.byteString bs+ | otherwise = BSB.word8 0x4e <> BSB.word32LE (fromIntegral len)+ <> BSB.byteString bs+ where+ !len = BS.length bs+{-# INLINE push_data #-}++-- | Encode a Word16 as minimal script number (for CSV delays).+push_csv_delay :: Word16 -> BSB.Builder+push_csv_delay !n+ | n == 0 = BSB.word8 op_0+ | n <= 16 = BSB.word8 (0x50 + fromIntegral n)+ | n <= 0x7f = push_data (BS.singleton (fromIntegral n))+ | n <= 0x7fff = push_data (BS.pack [lo, hi])+ | otherwise = push_data (BS.pack [lo, hi, 0x00]) -- need sign byte+ where+ !lo = fromIntegral (n .&. 0xff)+ !hi = fromIntegral ((n `shiftR` 8) .&. 0xff)+{-# INLINE push_csv_delay #-}++-- | Encode a Word32 as minimal script number (for CLTV).+push_cltv :: Word32 -> BSB.Builder+push_cltv !n+ | n == 0 = BSB.word8 op_0+ | n <= 16 = BSB.word8 (0x50 + fromIntegral n)+ | otherwise = push_data (encode_scriptnum n)+ where+ encode_scriptnum :: Word32 -> BS.ByteString+ encode_scriptnum 0 = BS.empty+ encode_scriptnum !v =+ let -- Build bytes little-endian (LSB first)+ go :: Word32 -> [Word8]+ go 0 = []+ go !x = fromIntegral (x .&. 0xff) : go (x `shiftR` 8)+ !bytes = go v+ -- If MSB has high bit set, need 0x00 suffix for positive numbers+ !result = case reverse bytes of+ [] -> bytes+ (msb:_) | msb .&. 0x80 /= 0 -> bytes ++ [0x00]+ _ -> bytes+ in BS.pack result+{-# INLINE push_cltv #-}++-- | Build script from builder.+build_script :: BSB.Builder -> Script+build_script = Script . BSL.toStrict . BSB.toLazyByteString+{-# INLINE build_script #-}++-- | HASH160 = RIPEMD160(SHA256(x))+hash160 :: BS.ByteString -> BS.ByteString+hash160 = RIPEMD160.hash . SHA256.hash+{-# INLINE hash160 #-}++-- P2WSH helpers ---------------------------------------------------------------++-- | Compute SHA256 hash of a witness script.+--+-- >>> witness_script_hash (Script "some_script")+-- <32-byte SHA256 hash>+witness_script_hash :: Script -> BS.ByteString+witness_script_hash (Script !s) = SHA256.hash s+{-# INLINE witness_script_hash #-}++-- | Convert a witness script to P2WSH scriptPubKey.+--+-- P2WSH format: OP_0 <32-byte-hash>+--+-- >>> to_p2wsh some_witness_script+-- Script "\x00\x20<32-byte-hash>"+to_p2wsh :: Script -> Script+to_p2wsh !script =+ let !h = witness_script_hash script+ in build_script (BSB.word8 op_0 <> push_data h)+{-# INLINE to_p2wsh #-}++-- funding output --------------------------------------------------------------++-- | Funding output witness script (2-of-2 multisig).+--+-- Script: @2 <pubkey1> <pubkey2> 2 OP_CHECKMULTISIG@+--+-- Where pubkey1 is lexicographically lesser.+--+-- >>> funding_script pk1 pk2+-- Script "R!<pk_lesser>!<pk_greater>R\xae"+funding_script :: FundingPubkey -> FundingPubkey -> Script+funding_script (FundingPubkey (Pubkey !pk1)) (FundingPubkey (Pubkey !pk2)) =+ let (!lesser, !greater) = if pk1 <= pk2 then (pk1, pk2) else (pk2, pk1)+ in build_script $+ BSB.word8 op_2+ <> push_data lesser+ <> push_data greater+ <> BSB.word8 op_2+ <> BSB.word8 op_checkmultisig++-- | Witness for spending funding output.+--+-- Witness: @0 <sig1> <sig2>@+--+-- Signatures ordered to match pubkey order in script.+--+-- >>> funding_witness sig1 sig2+-- Witness ["", sig1, sig2]+funding_witness :: BS.ByteString -> BS.ByteString -> Witness+funding_witness !sig1 !sig2 = Witness [BS.empty, sig1, sig2]++-- to_local output -------------------------------------------------------------++-- | to_local witness script (revocable with CSV delay).+--+-- Script:+--+-- @+-- OP_IF+-- <revocationpubkey>+-- OP_ELSE+-- <to_self_delay>+-- OP_CHECKSEQUENCEVERIFY+-- OP_DROP+-- <local_delayedpubkey>+-- OP_ENDIF+-- OP_CHECKSIG+-- @+--+-- >>> to_local_script revpk delay localpk+-- Script "c!<revpk>g<delay>\xb2u!<localpk>h\xac"+to_local_script+ :: RevocationPubkey+ -> ToSelfDelay+ -> LocalDelayedPubkey+ -> Script+to_local_script+ (RevocationPubkey (Pubkey !revpk))+ (ToSelfDelay !delay)+ (LocalDelayedPubkey (Pubkey !localpk)) =+ build_script $+ BSB.word8 op_if+ <> push_data revpk+ <> BSB.word8 op_else+ <> push_csv_delay delay+ <> BSB.word8 op_checksequenceverify+ <> BSB.word8 op_drop+ <> push_data localpk+ <> BSB.word8 op_endif+ <> BSB.word8 op_checksig++-- | Witness for delayed spend of to_local output.+--+-- Input nSequence must be set to to_self_delay.+--+-- Witness: @<local_delayedsig> <>@+--+-- >>> to_local_witness_spend sig+-- Witness [sig, ""]+to_local_witness_spend :: BS.ByteString -> Witness+to_local_witness_spend !sig = Witness [sig, BS.empty]++-- | Witness for revocation spend of to_local output.+--+-- Witness: @<revocation_sig> 1@+--+-- >>> to_local_witness_revoke sig+-- Witness [sig, "\x01"]+to_local_witness_revoke :: BS.ByteString -> Witness+to_local_witness_revoke !sig = Witness [sig, BS.singleton 0x01]++-- to_remote output ------------------------------------------------------------++-- | to_remote witness script.+--+-- With option_anchors:+--+-- @+-- <remotepubkey> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY+-- @+--+-- Without option_anchors: P2WPKH (just the pubkey hash).+--+-- >>> to_remote_script pk (ChannelFeatures True)+-- Script "!<pk>\xadQ\xb2"+to_remote_script :: RemotePubkey -> ChannelFeatures -> Script+to_remote_script (RemotePubkey (Pubkey !pk)) !features+ | has_anchors features =+ -- Anchors: script with 1-block CSV+ build_script $+ push_data pk+ <> BSB.word8 op_checksigverify+ <> BSB.word8 op_1+ <> BSB.word8 op_checksequenceverify+ | otherwise =+ -- No anchors: P2WPKH (OP_0 <20-byte-hash>)+ let !h = hash160 pk+ in build_script (BSB.word8 op_0 <> push_data h)++-- | Witness for spending to_remote output.+--+-- With option_anchors (P2WSH), input nSequence must be 1.+-- Witness: @<remote_sig>@ (witness script appended by caller)+--+-- Without option_anchors (P2WPKH):+-- Witness: @<remote_sig> <remotepubkey>@+--+-- >>> to_remote_witness sig pk (ChannelFeatures False)+-- Witness [sig, pk]+to_remote_witness :: BS.ByteString -> RemotePubkey -> ChannelFeatures -> Witness+to_remote_witness !sig (RemotePubkey (Pubkey !pk)) !features+ | has_anchors features = Witness [sig]+ | otherwise = Witness [sig, pk]++-- anchor outputs --------------------------------------------------------------++-- | Anchor output witness script.+--+-- Script:+--+-- @+-- <funding_pubkey> OP_CHECKSIG OP_IFDUP+-- OP_NOTIF+-- OP_16 OP_CHECKSEQUENCEVERIFY+-- OP_ENDIF+-- @+--+-- >>> anchor_script fundpk+-- Script "!<fundpk>\xac\x73d`\xb2h"+anchor_script :: FundingPubkey -> Script+anchor_script (FundingPubkey (Pubkey !pk)) =+ build_script $+ push_data pk+ <> BSB.word8 op_checksig+ <> BSB.word8 op_ifdup+ <> BSB.word8 op_notif+ <> BSB.word8 op_16+ <> BSB.word8 op_checksequenceverify+ <> BSB.word8 op_endif++-- | Witness for owner to spend anchor output.+--+-- Witness: @<sig>@+--+-- >>> anchor_witness_owner sig+-- Witness [sig]+anchor_witness_owner :: BS.ByteString -> Witness+anchor_witness_owner !sig = Witness [sig]++-- | Witness for anyone to sweep anchor output after 16 blocks.+--+-- Witness: @<>@+--+-- >>> anchor_witness_anyone+-- Witness [""]+anchor_witness_anyone :: Witness+anchor_witness_anyone = Witness [BS.empty]++-- offered HTLC output ---------------------------------------------------------++-- | Offered HTLC witness script.+--+-- Without option_anchors:+--+-- @+-- OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL+-- OP_IF+-- OP_CHECKSIG+-- OP_ELSE+-- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL+-- OP_NOTIF+-- OP_DROP 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG+-- OP_ELSE+-- OP_HASH160 <RIPEMD160(payment_hash)> OP_EQUALVERIFY+-- OP_CHECKSIG+-- OP_ENDIF+-- OP_ENDIF+-- @+--+-- With option_anchors, adds @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ before+-- final OP_ENDIF.+offered_htlc_script+ :: RevocationPubkey+ -> RemoteHtlcPubkey+ -> LocalHtlcPubkey+ -> PaymentHash+ -> ChannelFeatures+ -> Script+offered_htlc_script+ (RevocationPubkey (Pubkey !revpk))+ (RemoteHtlcPubkey (Pubkey !remotepk))+ (LocalHtlcPubkey (Pubkey !localpk))+ (PaymentHash !ph)+ !features =+ let !revpk_hash = hash160 revpk+ !payment_hash160 = RIPEMD160.hash ph+ !csv_suffix = if has_anchors features+ then BSB.word8 op_1+ <> BSB.word8 op_checksequenceverify+ <> BSB.word8 op_drop+ else mempty+ in build_script $+ -- OP_DUP OP_HASH160 <revpk_hash> OP_EQUAL+ BSB.word8 op_dup+ <> BSB.word8 op_hash160+ <> push_data revpk_hash+ <> BSB.word8 op_equal+ -- OP_IF OP_CHECKSIG+ <> BSB.word8 op_if+ <> BSB.word8 op_checksig+ -- OP_ELSE+ <> BSB.word8 op_else+ -- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL+ <> push_data remotepk+ <> BSB.word8 op_swap+ <> BSB.word8 op_size+ <> push_data (BS.singleton 32)+ <> BSB.word8 op_equal+ -- OP_NOTIF+ <> BSB.word8 op_notif+ -- OP_DROP 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG+ <> BSB.word8 op_drop+ <> BSB.word8 op_2+ <> BSB.word8 op_swap+ <> push_data localpk+ <> BSB.word8 op_2+ <> BSB.word8 op_checkmultisig+ -- OP_ELSE+ <> BSB.word8 op_else+ -- OP_HASH160 <payment_hash160> OP_EQUALVERIFY OP_CHECKSIG+ <> BSB.word8 op_hash160+ <> push_data payment_hash160+ <> BSB.word8 op_equalverify+ <> BSB.word8 op_checksig+ -- OP_ENDIF+ <> BSB.word8 op_endif+ -- CSV suffix for anchors+ <> csv_suffix+ -- OP_ENDIF+ <> BSB.word8 op_endif++-- | Witness for remote node to claim offered HTLC with preimage.+--+-- With option_anchors, input nSequence must be 1.+--+-- Witness: @<remotehtlcsig> <payment_preimage>@+--+-- >>> offered_htlc_witness_preimage sig preimage+-- Witness [sig, preimage]+offered_htlc_witness_preimage+ :: BS.ByteString -> PaymentPreimage -> Witness+offered_htlc_witness_preimage !sig (PaymentPreimage !preimage) =+ Witness [sig, preimage]++-- | Witness for revocation spend of offered HTLC.+--+-- Witness: @<revocation_sig> <revocationpubkey>@+--+-- >>> offered_htlc_witness_revoke sig revpk+-- Witness [sig, revpk]+offered_htlc_witness_revoke :: BS.ByteString -> Pubkey -> Witness+offered_htlc_witness_revoke !sig (Pubkey !revpk) = Witness [sig, revpk]++-- received HTLC output --------------------------------------------------------++-- | Received HTLC witness script.+--+-- Without option_anchors:+--+-- @+-- OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL+-- OP_IF+-- OP_CHECKSIG+-- OP_ELSE+-- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL+-- OP_IF+-- OP_HASH160 <RIPEMD160(payment_hash)> OP_EQUALVERIFY+-- 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG+-- OP_ELSE+-- OP_DROP <cltv_expiry> OP_CHECKLOCKTIMEVERIFY OP_DROP+-- OP_CHECKSIG+-- OP_ENDIF+-- OP_ENDIF+-- @+--+-- With option_anchors, adds @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ before+-- final OP_ENDIF.+received_htlc_script+ :: RevocationPubkey+ -> RemoteHtlcPubkey+ -> LocalHtlcPubkey+ -> PaymentHash+ -> CltvExpiry+ -> ChannelFeatures+ -> Script+received_htlc_script+ (RevocationPubkey (Pubkey !revpk))+ (RemoteHtlcPubkey (Pubkey !remotepk))+ (LocalHtlcPubkey (Pubkey !localpk))+ (PaymentHash !ph)+ (CltvExpiry !expiry)+ !features =+ let !revpk_hash = hash160 revpk+ !payment_hash160 = RIPEMD160.hash ph+ !csv_suffix = if has_anchors features+ then BSB.word8 op_1+ <> BSB.word8 op_checksequenceverify+ <> BSB.word8 op_drop+ else mempty+ in build_script $+ -- OP_DUP OP_HASH160 <revpk_hash> OP_EQUAL+ BSB.word8 op_dup+ <> BSB.word8 op_hash160+ <> push_data revpk_hash+ <> BSB.word8 op_equal+ -- OP_IF OP_CHECKSIG+ <> BSB.word8 op_if+ <> BSB.word8 op_checksig+ -- OP_ELSE+ <> BSB.word8 op_else+ -- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL+ <> push_data remotepk+ <> BSB.word8 op_swap+ <> BSB.word8 op_size+ <> push_data (BS.singleton 32)+ <> BSB.word8 op_equal+ -- OP_IF+ <> BSB.word8 op_if+ -- OP_HASH160 <payment_hash160> OP_EQUALVERIFY+ <> BSB.word8 op_hash160+ <> push_data payment_hash160+ <> BSB.word8 op_equalverify+ -- 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG+ <> BSB.word8 op_2+ <> BSB.word8 op_swap+ <> push_data localpk+ <> BSB.word8 op_2+ <> BSB.word8 op_checkmultisig+ -- OP_ELSE+ <> BSB.word8 op_else+ -- OP_DROP <cltv_expiry> OP_CHECKLOCKTIMEVERIFY OP_DROP OP_CHECKSIG+ <> BSB.word8 op_drop+ <> push_cltv expiry+ <> BSB.word8 op_checklocktimeverify+ <> BSB.word8 op_drop+ <> BSB.word8 op_checksig+ -- OP_ENDIF+ <> BSB.word8 op_endif+ -- CSV suffix for anchors+ <> csv_suffix+ -- OP_ENDIF+ <> BSB.word8 op_endif++-- | Witness for remote node to timeout received HTLC.+--+-- With option_anchors, input nSequence must be 1.+--+-- Witness: @<remotehtlcsig> <>@+--+-- >>> received_htlc_witness_timeout sig+-- Witness [sig, ""]+received_htlc_witness_timeout :: BS.ByteString -> Witness+received_htlc_witness_timeout !sig = Witness [sig, BS.empty]++-- | Witness for revocation spend of received HTLC.+--+-- Witness: @<revocation_sig> <revocationpubkey>@+--+-- >>> received_htlc_witness_revoke sig revpk+-- Witness [sig, revpk]+received_htlc_witness_revoke :: BS.ByteString -> Pubkey -> Witness+received_htlc_witness_revoke !sig (Pubkey !revpk) = Witness [sig, revpk]++-- HTLC-timeout/success output -------------------------------------------------++-- | HTLC output witness script (same structure as to_local).+--+-- Used for HTLC-timeout and HTLC-success transaction outputs.+--+-- Script:+--+-- @+-- OP_IF+-- <revocationpubkey>+-- OP_ELSE+-- <to_self_delay>+-- OP_CHECKSEQUENCEVERIFY+-- OP_DROP+-- <local_delayedpubkey>+-- OP_ENDIF+-- OP_CHECKSIG+-- @+htlc_output_script+ :: RevocationPubkey+ -> ToSelfDelay+ -> LocalDelayedPubkey+ -> Script+htlc_output_script = to_local_script++-- | Witness for delayed spend of HTLC output.+--+-- Input nSequence must be set to to_self_delay.+--+-- Witness: @<local_delayedsig> 0@+htlc_output_witness_spend :: BS.ByteString -> Witness+htlc_output_witness_spend = to_local_witness_spend++-- | Witness for revocation spend of HTLC output.+--+-- Witness: @<revocationsig> 1@+htlc_output_witness_revoke :: BS.ByteString -> Witness+htlc_output_witness_revoke = to_local_witness_revoke
+ lib/Lightning/Protocol/BOLT3/Tx.hs view
@@ -0,0 +1,591 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Tx+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Transaction assembly for BOLT #3.+--+-- Constructs:+--+-- * Commitment transactions+-- * HTLC-timeout transactions+-- * HTLC-success transactions+-- * Closing transactions++module Lightning.Protocol.BOLT3.Tx (+ -- * Commitment transaction+ CommitmentTx(..)+ , CommitmentContext(..)+ , CommitmentKeys(..)+ , build_commitment_tx++ -- * HTLC transactions+ , HTLCTx(..)+ , HTLCContext(..)+ , build_htlc_timeout_tx+ , build_htlc_success_tx++ -- * Closing transaction+ , ClosingTx(..)+ , ClosingContext(..)+ , build_closing_tx+ , build_legacy_closing_tx++ -- * Transaction outputs+ , TxOutput(..)+ , OutputType(..)++ -- * Fee calculation+ , commitment_fee+ , htlc_timeout_fee+ , htlc_success_fee+ , commitment_weight++ -- * Trimming+ , is_trimmed+ , trimmed_htlcs+ , untrimmed_htlcs+ , htlc_trim_threshold++ -- * Output ordering+ , sort_outputs+ ) where++import Data.Bits ((.&.), (.|.), shiftL, shiftR)+import Data.List (sortBy)+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)+import Lightning.Protocol.BOLT3.Keys+import Lightning.Protocol.BOLT3.Scripts+import Lightning.Protocol.BOLT3.Types++-- transaction outputs ---------------------------------------------------------++-- | Type of output in a commitment transaction.+data OutputType+ = OutputToLocal+ | OutputToRemote+ | OutputLocalAnchor+ | OutputRemoteAnchor+ | OutputOfferedHTLC {-# UNPACK #-} !CltvExpiry+ | OutputReceivedHTLC {-# UNPACK #-} !CltvExpiry+ deriving (Eq, Show, Generic)++-- | A transaction output with value, script, and type information.+data TxOutput = TxOutput+ { txout_value :: {-# UNPACK #-} !Satoshi+ , txout_script :: !Script+ , txout_type :: !OutputType+ } deriving (Eq, Show, Generic)++-- commitment transaction ------------------------------------------------------++-- | Derived keys needed for commitment transaction outputs.+data CommitmentKeys = CommitmentKeys+ { ck_revocation_pubkey :: !RevocationPubkey+ , ck_local_delayed :: !LocalDelayedPubkey+ , ck_local_htlc :: !LocalHtlcPubkey+ , ck_remote_htlc :: !RemoteHtlcPubkey+ , ck_local_payment :: !LocalPubkey+ , ck_remote_payment :: !RemotePubkey+ , ck_local_funding :: !FundingPubkey+ , ck_remote_funding :: !FundingPubkey+ } deriving (Eq, Show, Generic)++-- | Context for building a commitment transaction.+data CommitmentContext = CommitmentContext+ { cc_funding_outpoint :: !Outpoint+ , cc_commitment_number :: !CommitmentNumber+ , cc_local_payment_bp :: !PaymentBasepoint+ , cc_remote_payment_bp :: !PaymentBasepoint+ , cc_to_self_delay :: !ToSelfDelay+ , cc_dust_limit :: !DustLimit+ , cc_feerate :: !FeeratePerKw+ , cc_features :: !ChannelFeatures+ , cc_is_funder :: !Bool+ , cc_to_local_msat :: !MilliSatoshi+ , cc_to_remote_msat :: !MilliSatoshi+ , cc_htlcs :: ![HTLC]+ , cc_keys :: !CommitmentKeys+ } deriving (Eq, Show, Generic)++-- | A commitment transaction.+data CommitmentTx = CommitmentTx+ { ctx_version :: {-# UNPACK #-} !Word32+ , ctx_locktime :: !Locktime+ , ctx_input_outpoint :: !Outpoint+ , ctx_input_sequence :: !Sequence+ , ctx_outputs :: ![TxOutput]+ , ctx_funding_script :: !Script+ } deriving (Eq, Show, Generic)++-- | Build a commitment transaction.+--+-- Follows the algorithm from BOLT #3:+--+-- 1. Initialize input and locktime with obscured commitment number+-- 2. Calculate which HTLCs are trimmed+-- 3. Calculate base fee and subtract from funder+-- 4. Add untrimmed HTLC outputs+-- 5. Add to_local output if above dust+-- 6. Add to_remote output if above dust+-- 7. Add anchor outputs if option_anchors+-- 8. Sort outputs per BIP69+CLTV+build_commitment_tx :: CommitmentContext -> CommitmentTx+build_commitment_tx ctx =+ let !obscured = obscured_commitment_number+ (cc_local_payment_bp ctx)+ (cc_remote_payment_bp ctx)+ (cc_commitment_number ctx)++ -- Locktime: upper 8 bits are 0x20, lower 24 bits are lower 24 of obscured+ !locktime = Locktime $+ (0x20 `shiftL` 24) .|. (fromIntegral obscured .&. 0x00FFFFFF)++ -- Sequence: upper 8 bits are 0x80, lower 24 bits are upper 24 of obscured+ !inputSeq = Sequence $+ (0x80 `shiftL` 24) .|.+ (fromIntegral (obscured `shiftR` 24) .&. 0x00FFFFFF)++ -- Funding script for witness+ !fundingScript = funding_script+ (ck_local_funding $ cc_keys ctx)+ (ck_remote_funding $ cc_keys ctx)++ -- Calculate untrimmed HTLCs+ !untrimmedHtlcs = untrimmed_htlcs+ (cc_dust_limit ctx)+ (cc_feerate ctx)+ (cc_features ctx)+ (cc_htlcs ctx)++ -- Calculate base fee+ !baseFee = commitment_fee+ (cc_feerate ctx)+ (cc_features ctx)+ (fromIntegral $ length untrimmedHtlcs)++ -- Anchor cost if applicable+ !anchorCost = if has_anchors (cc_features ctx)+ then 2 * anchor_output_value+ else Satoshi 0++ -- Subtract fees and anchors from funder+ !totalDeduction = baseFee + anchorCost+ !(toLocalSat, toRemoteSat) = if cc_is_funder ctx+ then+ let !local = msat_to_sat (cc_to_local_msat ctx)+ !deducted = if unSatoshi local >= unSatoshi totalDeduction+ then Satoshi (unSatoshi local - unSatoshi totalDeduction)+ else Satoshi 0+ in (deducted, msat_to_sat (cc_to_remote_msat ctx))+ else+ let !remote = msat_to_sat (cc_to_remote_msat ctx)+ !deducted = if unSatoshi remote >= unSatoshi totalDeduction+ then Satoshi (unSatoshi remote - unSatoshi totalDeduction)+ else Satoshi 0+ in (msat_to_sat (cc_to_local_msat ctx), deducted)++ !dustLimit = unDustLimit (cc_dust_limit ctx)++ -- Build HTLC outputs+ !htlcOutputs = map (htlcOutput ctx) untrimmedHtlcs++ -- Build to_local output if above dust+ !toLocalOutput =+ if unSatoshi toLocalSat >= unSatoshi dustLimit+ then+ let !script = to_p2wsh $ to_local_script+ (ck_revocation_pubkey $ cc_keys ctx)+ (cc_to_self_delay ctx)+ (ck_local_delayed $ cc_keys ctx)+ in [TxOutput toLocalSat script OutputToLocal]+ else []++ -- Build to_remote output if above dust+ !toRemoteOutput =+ if unSatoshi toRemoteSat >= unSatoshi dustLimit+ then+ let !script = if has_anchors (cc_features ctx)+ then to_p2wsh $ to_remote_script+ (ck_remote_payment $ cc_keys ctx)+ (cc_features ctx)+ else to_remote_script+ (ck_remote_payment $ cc_keys ctx)+ (cc_features ctx)+ in [TxOutput toRemoteSat script OutputToRemote]+ else []++ -- Build anchor outputs if option_anchors+ !hasUntrimmedHtlcs = not (null untrimmedHtlcs)+ !toLocalExists = not (null toLocalOutput)+ !toRemoteExists = not (null toRemoteOutput)++ !localAnchorOutput =+ if has_anchors (cc_features ctx) &&+ (toLocalExists || hasUntrimmedHtlcs)+ then+ let !script = to_p2wsh $ anchor_script+ (ck_local_funding $ cc_keys ctx)+ in [TxOutput anchor_output_value script OutputLocalAnchor]+ else []++ !remoteAnchorOutput =+ if has_anchors (cc_features ctx) &&+ (toRemoteExists || hasUntrimmedHtlcs)+ then+ let !script = to_p2wsh $ anchor_script+ (ck_remote_funding $ cc_keys ctx)+ in [TxOutput anchor_output_value script OutputRemoteAnchor]+ else []++ -- Combine and sort all outputs+ !allOutputs = toLocalOutput ++ toRemoteOutput +++ localAnchorOutput ++ remoteAnchorOutput +++ htlcOutputs+ !sortedOutputs = sort_outputs allOutputs++ in CommitmentTx+ { ctx_version = 2+ , ctx_locktime = locktime+ , ctx_input_outpoint = cc_funding_outpoint ctx+ , ctx_input_sequence = inputSeq+ , ctx_outputs = sortedOutputs+ , ctx_funding_script = fundingScript+ }+{-# INLINE build_commitment_tx #-}++-- | Build an HTLC output for commitment transaction.+htlcOutput :: CommitmentContext -> HTLC -> TxOutput+htlcOutput ctx htlc =+ let !amountSat = msat_to_sat (htlc_amount_msat htlc)+ !keys = cc_keys ctx+ !features = cc_features ctx+ !expiry = htlc_cltv_expiry htlc+ in case htlc_direction htlc of+ HTLCOffered ->+ let !script = to_p2wsh $ offered_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ features+ in TxOutput amountSat script (OutputOfferedHTLC expiry)+ HTLCReceived ->+ let !script = to_p2wsh $ received_htlc_script+ (ck_revocation_pubkey keys)+ (ck_remote_htlc keys)+ (ck_local_htlc keys)+ (htlc_payment_hash htlc)+ expiry+ features+ in TxOutput amountSat script (OutputReceivedHTLC expiry)+{-# INLINE htlcOutput #-}++-- HTLC transactions -----------------------------------------------------------++-- | Context for building HTLC transactions.+data HTLCContext = HTLCContext+ { hc_commitment_txid :: !TxId+ , hc_output_index :: {-# UNPACK #-} !Word32+ , hc_htlc :: !HTLC+ , hc_to_self_delay :: !ToSelfDelay+ , hc_feerate :: !FeeratePerKw+ , hc_features :: !ChannelFeatures+ , hc_revocation_pubkey :: !RevocationPubkey+ , hc_local_delayed :: !LocalDelayedPubkey+ } deriving (Eq, Show, Generic)++-- | An HTLC transaction (timeout or success).+data HTLCTx = HTLCTx+ { htx_version :: {-# UNPACK #-} !Word32+ , htx_locktime :: !Locktime+ , htx_input_outpoint :: !Outpoint+ , htx_input_sequence :: !Sequence+ , htx_output_value :: !Satoshi+ , htx_output_script :: !Script+ } deriving (Eq, Show, Generic)++-- | Internal helper for HTLC transaction construction.+--+-- Both HTLC-timeout and HTLC-success transactions share the same+-- structure, differing only in locktime and fee calculation.+build_htlc_tx_common+ :: HTLCContext+ -> Locktime -- ^ Transaction locktime+ -> Satoshi -- ^ Fee to subtract from output+ -> HTLCTx+build_htlc_tx_common ctx locktime fee =+ let !amountSat = msat_to_sat (htlc_amount_msat $ hc_htlc ctx)+ !outputValue = if unSatoshi amountSat >= unSatoshi fee+ then Satoshi (unSatoshi amountSat - unSatoshi fee)+ else Satoshi 0+ !inputSeq = if has_anchors (hc_features ctx)+ then Sequence 1+ else Sequence 0+ !outpoint = Outpoint (hc_commitment_txid ctx) (hc_output_index ctx)+ !outputScript = to_p2wsh $ htlc_output_script+ (hc_revocation_pubkey ctx)+ (hc_to_self_delay ctx)+ (hc_local_delayed ctx)+ in HTLCTx+ { htx_version = 2+ , htx_locktime = locktime+ , htx_input_outpoint = outpoint+ , htx_input_sequence = inputSeq+ , htx_output_value = outputValue+ , htx_output_script = outputScript+ }+{-# INLINE build_htlc_tx_common #-}++-- | Build an HTLC-timeout transaction.+--+-- * locktime: cltv_expiry+-- * sequence: 0 (or 1 with option_anchors)+-- * output: to_local style script with revocation and delayed paths+build_htlc_timeout_tx :: HTLCContext -> HTLCTx+build_htlc_timeout_tx ctx =+ let !fee = htlc_timeout_fee (hc_feerate ctx) (hc_features ctx)+ !locktime = Locktime (unCltvExpiry $ htlc_cltv_expiry $ hc_htlc ctx)+ in build_htlc_tx_common ctx locktime fee+{-# INLINE build_htlc_timeout_tx #-}++-- | Build an HTLC-success transaction.+--+-- * locktime: 0+-- * sequence: 0 (or 1 with option_anchors)+-- * output: to_local style script with revocation and delayed paths+build_htlc_success_tx :: HTLCContext -> HTLCTx+build_htlc_success_tx ctx =+ let !fee = htlc_success_fee (hc_feerate ctx) (hc_features ctx)+ in build_htlc_tx_common ctx (Locktime 0) fee+{-# INLINE build_htlc_success_tx #-}++-- closing transaction ---------------------------------------------------------++-- | Context for building closing transactions.+data ClosingContext = ClosingContext+ { clc_funding_outpoint :: !Outpoint+ , clc_local_amount :: !Satoshi+ , clc_remote_amount :: !Satoshi+ , clc_local_script :: !Script+ , clc_remote_script :: !Script+ , clc_local_dust_limit :: !DustLimit+ , clc_remote_dust_limit :: !DustLimit+ , clc_fee :: !Satoshi+ , clc_is_funder :: !Bool+ , clc_locktime :: !Locktime+ , clc_funding_script :: !Script+ } deriving (Eq, Show, Generic)++-- | A closing transaction.+data ClosingTx = ClosingTx+ { cltx_version :: {-# UNPACK #-} !Word32+ , cltx_locktime :: !Locktime+ , cltx_input_outpoint :: !Outpoint+ , cltx_input_sequence :: !Sequence+ , cltx_outputs :: ![TxOutput]+ , cltx_funding_script :: !Script+ } deriving (Eq, Show, Generic)++-- | Build a closing transaction (option_simple_close).+--+-- * locktime: from closing_complete message+-- * sequence: 0xFFFFFFFD+-- * outputs: sorted per BIP69+build_closing_tx :: ClosingContext -> ClosingTx+build_closing_tx ctx =+ let -- Subtract fee from closer+ !(localAmt, remoteAmt) = if clc_is_funder ctx+ then+ let !deducted = if unSatoshi (clc_local_amount ctx) >=+ unSatoshi (clc_fee ctx)+ then Satoshi (unSatoshi (clc_local_amount ctx) -+ unSatoshi (clc_fee ctx))+ else Satoshi 0+ in (deducted, clc_remote_amount ctx)+ else+ let !deducted = if unSatoshi (clc_remote_amount ctx) >=+ unSatoshi (clc_fee ctx)+ then Satoshi (unSatoshi (clc_remote_amount ctx) -+ unSatoshi (clc_fee ctx))+ else Satoshi 0+ in (clc_local_amount ctx, deducted)++ -- Build outputs, omitting dust+ !localOutput =+ if unSatoshi localAmt >= unSatoshi (unDustLimit $ clc_local_dust_limit ctx)+ then [TxOutput localAmt (clc_local_script ctx) OutputToLocal]+ else []++ !remoteOutput =+ if unSatoshi remoteAmt >= unSatoshi (unDustLimit $ clc_remote_dust_limit ctx)+ then [TxOutput remoteAmt (clc_remote_script ctx) OutputToRemote]+ else []++ !allOutputs = localOutput ++ remoteOutput+ !sortedOutputs = sort_outputs allOutputs++ in ClosingTx+ { cltx_version = 2+ , cltx_locktime = clc_locktime ctx+ , cltx_input_outpoint = clc_funding_outpoint ctx+ , cltx_input_sequence = Sequence 0xFFFFFFFD+ , cltx_outputs = sortedOutputs+ , cltx_funding_script = clc_funding_script ctx+ }+{-# INLINE build_closing_tx #-}++-- | Build a legacy closing transaction (closing_signed).+--+-- * locktime: 0+-- * sequence: 0xFFFFFFFF+-- * outputs: sorted per BIP69+build_legacy_closing_tx :: ClosingContext -> ClosingTx+build_legacy_closing_tx ctx =+ let !result = build_closing_tx ctx+ { clc_locktime = Locktime 0 }+ in result { cltx_input_sequence = Sequence 0xFFFFFFFF }+{-# INLINE build_legacy_closing_tx #-}++-- fee calculation -------------------------------------------------------------++-- | Calculate the base commitment transaction fee.+--+-- @fee = feerate_per_kw * weight / 1000@+--+-- where @weight = base_weight + 172 * num_htlcs@+commitment_fee :: FeeratePerKw -> ChannelFeatures -> Word64 -> Satoshi+commitment_fee feerate features numHtlcs =+ let !weight = commitment_weight features numHtlcs+ !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000+ in Satoshi fee+{-# INLINE commitment_fee #-}++-- | Calculate commitment transaction weight.+--+-- @weight = base + 172 * num_htlcs@+commitment_weight :: ChannelFeatures -> Word64 -> Word64+commitment_weight features numHtlcs =+ let !base = if has_anchors features+ then commitment_weight_anchors+ else commitment_weight_no_anchors+ in base + htlc_output_weight * numHtlcs+{-# INLINE commitment_weight #-}++-- | Calculate HTLC-timeout transaction fee.+--+-- With option_anchors, fee is 0 (CPFP).+-- Otherwise, @fee = feerate_per_kw * 663 / 1000@+htlc_timeout_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi+htlc_timeout_fee feerate features+ | has_anchors features = Satoshi 0+ | otherwise =+ let !weight = htlc_timeout_weight_no_anchors+ !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000+ in Satoshi fee+{-# INLINE htlc_timeout_fee #-}++-- | Calculate HTLC-success transaction fee.+--+-- With option_anchors, fee is 0 (CPFP).+-- Otherwise, @fee = feerate_per_kw * 703 / 1000@+htlc_success_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi+htlc_success_fee feerate features+ | has_anchors features = Satoshi 0+ | otherwise =+ let !weight = htlc_success_weight_no_anchors+ !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000+ in Satoshi fee+{-# INLINE htlc_success_fee #-}++-- trimming --------------------------------------------------------------------++-- | Calculate the trim threshold for an HTLC.+--+-- An HTLC is trimmed if:+-- @amount < dust_limit + htlc_tx_fee@+htlc_trim_threshold+ :: DustLimit+ -> FeeratePerKw+ -> ChannelFeatures+ -> HTLCDirection+ -> Satoshi+htlc_trim_threshold dust feerate features direction =+ let !dustVal = unDustLimit dust+ !htlcFee = case direction of+ HTLCOffered -> htlc_timeout_fee feerate features+ HTLCReceived -> htlc_success_fee feerate features+ in Satoshi (unSatoshi dustVal + unSatoshi htlcFee)+{-# INLINE htlc_trim_threshold #-}++-- | Check if an HTLC should be trimmed.+--+-- An HTLC is trimmed if its amount minus the HTLC tx fee is below+-- the dust limit.+is_trimmed :: DustLimit -> FeeratePerKw -> ChannelFeatures -> HTLC -> Bool+is_trimmed dust feerate features htlc =+ let !threshold = htlc_trim_threshold dust feerate features+ (htlc_direction htlc)+ !amountSat = msat_to_sat (htlc_amount_msat htlc)+ in unSatoshi amountSat < unSatoshi threshold+{-# INLINE is_trimmed #-}++-- | Filter HTLCs that are trimmed.+trimmed_htlcs+ :: DustLimit+ -> FeeratePerKw+ -> ChannelFeatures+ -> [HTLC]+ -> [HTLC]+trimmed_htlcs dust feerate features =+ filter (is_trimmed dust feerate features)+{-# INLINE trimmed_htlcs #-}++-- | Filter HTLCs that are not trimmed.+untrimmed_htlcs+ :: DustLimit+ -> FeeratePerKw+ -> ChannelFeatures+ -> [HTLC]+ -> [HTLC]+untrimmed_htlcs dust feerate features =+ filter (not . is_trimmed dust feerate features)+{-# INLINE untrimmed_htlcs #-}++-- output ordering -------------------------------------------------------------++-- | Sort outputs per BOLT #3 ordering.+--+-- Outputs are sorted by:+-- 1. Value (smallest first)+-- 2. ScriptPubKey (lexicographic)+-- 3. CLTV expiry (for HTLCs)+sort_outputs :: [TxOutput] -> [TxOutput]+sort_outputs = sortBy compareOutputs+{-# INLINE sort_outputs #-}++-- | Compare two outputs for ordering.+compareOutputs :: TxOutput -> TxOutput -> Ordering+compareOutputs o1 o2 =+ case compare (txout_value o1) (txout_value o2) of+ EQ -> case compare (unScript $ txout_script o1)+ (unScript $ txout_script o2) of+ EQ -> compareCltvExpiry (txout_type o1) (txout_type o2)+ other -> other+ other -> other+{-# INLINE compareOutputs #-}++-- | Compare CLTV expiry for HTLC outputs.+compareCltvExpiry :: OutputType -> OutputType -> Ordering+compareCltvExpiry (OutputOfferedHTLC e1) (OutputOfferedHTLC e2) = compare e1 e2+compareCltvExpiry (OutputReceivedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2+compareCltvExpiry (OutputOfferedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2+compareCltvExpiry (OutputReceivedHTLC e1) (OutputOfferedHTLC e2) = compare e1 e2+compareCltvExpiry _ _ = EQ+{-# INLINE compareCltvExpiry #-}
+ lib/Lightning/Protocol/BOLT3/Types.hs view
@@ -0,0 +1,443 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Types+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Core types for BOLT #3 transaction and script formats.++module Lightning.Protocol.BOLT3.Types (+ -- * Monetary amounts+ Satoshi(..)+ , MilliSatoshi(..)+ , msat_to_sat+ , sat_to_msat++ -- * Keys and points+ , Pubkey(..)+ , pubkey+ , Seckey(..)+ , seckey+ , Point(..)+ , point++ -- * Hashes+ , PaymentHash(..)+ , payment_hash+ , PaymentPreimage(..)+ , payment_preimage++ -- * Transaction primitives+ , TxId(..)+ , txid+ , Outpoint(..)+ , Sequence(..)+ , Locktime(..)++ -- * Channel parameters+ , CommitmentNumber(..)+ , commitment_number+ , ToSelfDelay(..)+ , CltvExpiry(..)+ , DustLimit(..)+ , FeeratePerKw(..)++ -- * HTLC types+ , HTLC(..)+ , HTLCDirection(..)++ -- * Basepoints+ , Basepoints(..)+ , PerCommitmentPoint(..)+ , PerCommitmentSecret(..)+ , per_commitment_secret+ , RevocationBasepoint(..)+ , PaymentBasepoint(..)+ , DelayedPaymentBasepoint(..)+ , HtlcBasepoint(..)++ -- * Derived keys+ , LocalPubkey(..)+ , RemotePubkey(..)+ , LocalDelayedPubkey(..)+ , RemoteDelayedPubkey(..)+ , LocalHtlcPubkey(..)+ , RemoteHtlcPubkey(..)+ , RevocationPubkey(..)+ , FundingPubkey(..)++ -- * Script and witness+ , Script(..)+ , Witness(..)++ -- * Channel options+ , ChannelFeatures(..)+ , has_anchors++ -- * Transaction weights (constants)+ , commitment_weight_no_anchors+ , commitment_weight_anchors+ , htlc_timeout_weight_no_anchors+ , htlc_timeout_weight_anchors+ , htlc_success_weight_no_anchors+ , htlc_success_weight_anchors+ , htlc_output_weight++ -- * Dust thresholds (constants)+ , dust_p2pkh+ , dust_p2sh+ , dust_p2wpkh+ , dust_p2wsh+ , anchor_output_value+ ) where++import Data.Word (Word16, Word32, Word64)+import qualified Data.ByteString as BS+import GHC.Generics (Generic)++-- monetary amounts ------------------------------------------------------------++-- | Amount in satoshis.+newtype Satoshi = Satoshi { unSatoshi :: Word64 }+ deriving (Eq, Ord, Show, Generic, Num)++-- | Amount in millisatoshis.+newtype MilliSatoshi = MilliSatoshi { unMilliSatoshi :: Word64 }+ deriving (Eq, Ord, Show, Generic, Num)++-- | Convert millisatoshis to satoshis (rounds down).+msat_to_sat :: MilliSatoshi -> Satoshi+msat_to_sat (MilliSatoshi m) = Satoshi (m `div` 1000)+{-# INLINE msat_to_sat #-}++-- | Convert satoshis to millisatoshis.+sat_to_msat :: Satoshi -> MilliSatoshi+sat_to_msat (Satoshi s) = MilliSatoshi (s * 1000)+{-# INLINE sat_to_msat #-}++-- keys and points -------------------------------------------------------------++-- | Compressed public key (33 bytes).+newtype Pubkey = Pubkey { unPubkey :: BS.ByteString }+ deriving (Eq, Ord, Show, Generic)++-- | Parse a 33-byte compressed public key.+--+-- Returns Nothing if the input is not exactly 33 bytes.+--+-- >>> pubkey (BS.replicate 33 0x02)+-- Just (Pubkey ...)+-- >>> pubkey (BS.replicate 32 0x02)+-- Nothing+pubkey :: BS.ByteString -> Maybe Pubkey+pubkey bs+ | BS.length bs == 33 = Just (Pubkey bs)+ | otherwise = Nothing+{-# INLINE pubkey #-}++-- | Secret key (32 bytes).+newtype Seckey = Seckey { unSeckey :: BS.ByteString }+ deriving (Eq, Generic)++-- Don't show secret keys+instance Show Seckey where+ show _ = "Seckey <redacted>"++-- | Parse a 32-byte secret key.+--+-- Returns Nothing if the input is not exactly 32 bytes.+seckey :: BS.ByteString -> Maybe Seckey+seckey bs+ | BS.length bs == 32 = Just (Seckey bs)+ | otherwise = Nothing+{-# INLINE seckey #-}++-- | Elliptic curve point (33-byte compressed form).+newtype Point = Point { unPoint :: BS.ByteString }+ deriving (Eq, Ord, Show, Generic)++-- | Parse a 33-byte elliptic curve point.+--+-- Returns Nothing if the input is not exactly 33 bytes.+point :: BS.ByteString -> Maybe Point+point bs+ | BS.length bs == 33 = Just (Point bs)+ | otherwise = Nothing+{-# INLINE point #-}++-- hashes ----------------------------------------------------------------------++-- | Payment hash (32 bytes, SHA256 of preimage).+newtype PaymentHash = PaymentHash { unPaymentHash :: BS.ByteString }+ deriving (Eq, Ord, Show, Generic)++-- | Parse a 32-byte payment hash.+--+-- Returns Nothing if the input is not exactly 32 bytes.+payment_hash :: BS.ByteString -> Maybe PaymentHash+payment_hash bs+ | BS.length bs == 32 = Just (PaymentHash bs)+ | otherwise = Nothing+{-# INLINE payment_hash #-}++-- | Payment preimage (32 bytes).+newtype PaymentPreimage = PaymentPreimage { unPaymentPreimage :: BS.ByteString }+ deriving (Eq, Generic)++instance Show PaymentPreimage where+ show _ = "PaymentPreimage <redacted>"++-- | Parse a 32-byte payment preimage.+--+-- Returns Nothing if the input is not exactly 32 bytes.+payment_preimage :: BS.ByteString -> Maybe PaymentPreimage+payment_preimage bs+ | BS.length bs == 32 = Just (PaymentPreimage bs)+ | otherwise = Nothing+{-# INLINE payment_preimage #-}++-- transaction primitives ------------------------------------------------------++-- | Transaction ID (32 bytes, little-endian hash).+newtype TxId = TxId { unTxId :: BS.ByteString }+ deriving (Eq, Ord, Show, Generic)++-- | Parse a 32-byte transaction ID.+--+-- Returns Nothing if the input is not exactly 32 bytes.+txid :: BS.ByteString -> Maybe TxId+txid bs+ | BS.length bs == 32 = Just (TxId bs)+ | otherwise = Nothing+{-# INLINE txid #-}++-- | Transaction outpoint (txid + output index).+data Outpoint = Outpoint+ { outpoint_txid :: {-# UNPACK #-} !TxId+ , outpoint_index :: {-# UNPACK #-} !Word32+ } deriving (Eq, Ord, Show, Generic)++-- | Transaction input sequence number.+newtype Sequence = Sequence { unSequence :: Word32 }+ deriving (Eq, Ord, Show, Generic, Num)++-- | Transaction locktime.+newtype Locktime = Locktime { unLocktime :: Word32 }+ deriving (Eq, Ord, Show, Generic, Num)++-- channel parameters ----------------------------------------------------------++-- | 48-bit commitment number.+newtype CommitmentNumber = CommitmentNumber { unCommitmentNumber :: Word64 }+ deriving (Eq, Ord, Show, Generic, Num)++-- | Parse a 48-bit commitment number.+--+-- Returns Nothing if the value exceeds 2^48 - 1.+commitment_number :: Word64 -> Maybe CommitmentNumber+commitment_number n+ | n <= 281474976710655 = Just (CommitmentNumber n)+ | otherwise = Nothing+{-# INLINE commitment_number #-}++-- | CSV delay for to_local outputs.+newtype ToSelfDelay = ToSelfDelay { unToSelfDelay :: Word16 }+ deriving (Eq, Ord, Show, Generic, Num)++-- | CLTV expiry for HTLCs.+newtype CltvExpiry = CltvExpiry { unCltvExpiry :: Word32 }+ deriving (Eq, Ord, Show, Generic, Num)++-- | Dust limit threshold.+newtype DustLimit = DustLimit { unDustLimit :: Satoshi }+ deriving (Eq, Ord, Show, Generic)++-- | Fee rate in satoshis per 1000 weight units.+newtype FeeratePerKw = FeeratePerKw { unFeeratePerKw :: Word32 }+ deriving (Eq, Ord, Show, Generic, Num)++-- HTLC types ------------------------------------------------------------------++-- | Direction of an HTLC from the commitment tx owner's perspective.+data HTLCDirection+ = HTLCOffered -- ^ We offered this HTLC (outgoing)+ | HTLCReceived -- ^ We received this HTLC (incoming)+ deriving (Eq, Ord, Show, Generic)++-- | HTLC output details.+--+-- NOTE: No Ord instance is provided. BOLT #3 requires output ordering by+-- amount then scriptPubKey, but scriptPubKey depends on derived keys which+-- are not available here. Use 'sort_outputs' in Tx module for proper BIP69+-- output ordering.+data HTLC = HTLC+ { htlc_direction :: !HTLCDirection+ , htlc_amount_msat :: {-# UNPACK #-} !MilliSatoshi+ , htlc_payment_hash :: {-# UNPACK #-} !PaymentHash+ , htlc_cltv_expiry :: {-# UNPACK #-} !CltvExpiry+ } deriving (Eq, Show, Generic)++-- basepoints ------------------------------------------------------------------++-- | Per-commitment point (used to derive keys).+newtype PerCommitmentPoint = PerCommitmentPoint { unPerCommitmentPoint :: Point }+ deriving (Eq, Ord, Show, Generic)++-- | Per-commitment secret (32 bytes).+newtype PerCommitmentSecret = PerCommitmentSecret+ { unPerCommitmentSecret :: BS.ByteString }+ deriving (Eq, Generic)++instance Show PerCommitmentSecret where+ show _ = "PerCommitmentSecret <redacted>"++-- | Parse a 32-byte per-commitment secret.+--+-- Returns Nothing if the input is not exactly 32 bytes.+per_commitment_secret :: BS.ByteString -> Maybe PerCommitmentSecret+per_commitment_secret bs+ | BS.length bs == 32 = Just (PerCommitmentSecret bs)+ | otherwise = Nothing+{-# INLINE per_commitment_secret #-}++-- | Revocation basepoint.+newtype RevocationBasepoint = RevocationBasepoint+ { unRevocationBasepoint :: Point }+ deriving (Eq, Ord, Show, Generic)++-- | Payment basepoint.+newtype PaymentBasepoint = PaymentBasepoint+ { unPaymentBasepoint :: Point }+ deriving (Eq, Ord, Show, Generic)++-- | Delayed payment basepoint.+newtype DelayedPaymentBasepoint = DelayedPaymentBasepoint+ { unDelayedPaymentBasepoint :: Point }+ deriving (Eq, Ord, Show, Generic)++-- | HTLC basepoint.+newtype HtlcBasepoint = HtlcBasepoint { unHtlcBasepoint :: Point }+ deriving (Eq, Ord, Show, Generic)++-- | Collection of all basepoints for one party.+data Basepoints = Basepoints+ { bp_revocation :: !RevocationBasepoint+ , bp_payment :: !PaymentBasepoint+ , bp_delayed_payment :: !DelayedPaymentBasepoint+ , bp_htlc :: !HtlcBasepoint+ } deriving (Eq, Show, Generic)++-- derived keys ----------------------------------------------------------------++-- | Local pubkey (derived from payment_basepoint + per_commitment_point).+newtype LocalPubkey = LocalPubkey { unLocalPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Remote pubkey (simply the remote's payment_basepoint).+newtype RemotePubkey = RemotePubkey { unRemotePubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Local delayed pubkey.+newtype LocalDelayedPubkey = LocalDelayedPubkey+ { unLocalDelayedPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Remote delayed pubkey.+newtype RemoteDelayedPubkey = RemoteDelayedPubkey+ { unRemoteDelayedPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Local HTLC pubkey.+newtype LocalHtlcPubkey = LocalHtlcPubkey { unLocalHtlcPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Remote HTLC pubkey.+newtype RemoteHtlcPubkey = RemoteHtlcPubkey { unRemoteHtlcPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Revocation pubkey (derived from revocation_basepoint + per_commitment).+newtype RevocationPubkey = RevocationPubkey { unRevocationPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- | Funding pubkey (used in 2-of-2 multisig).+newtype FundingPubkey = FundingPubkey { unFundingPubkey :: Pubkey }+ deriving (Eq, Ord, Show, Generic)++-- script and witness ----------------------------------------------------------++-- | Bitcoin script (serialized).+newtype Script = Script { unScript :: BS.ByteString }+ deriving (Eq, Ord, Show, Generic)++-- | Transaction witness stack.+newtype Witness = Witness { unWitness :: [BS.ByteString] }+ deriving (Eq, Ord, Show, Generic)++-- channel options -------------------------------------------------------------++-- | Channel feature flags relevant to BOLT #3.+data ChannelFeatures = ChannelFeatures+ { cf_option_anchors :: !Bool+ } deriving (Eq, Show, Generic)++-- | Check if option_anchors is enabled.+has_anchors :: ChannelFeatures -> Bool+has_anchors = cf_option_anchors+{-# INLINE has_anchors #-}++-- transaction weights (constants from spec) -----------------------------------++-- | Base commitment tx weight without option_anchors.+commitment_weight_no_anchors :: Word64+commitment_weight_no_anchors = 724++-- | Base commitment tx weight with option_anchors.+commitment_weight_anchors :: Word64+commitment_weight_anchors = 1124++-- | HTLC-timeout tx weight without option_anchors.+htlc_timeout_weight_no_anchors :: Word64+htlc_timeout_weight_no_anchors = 663++-- | HTLC-timeout tx weight with option_anchors.+htlc_timeout_weight_anchors :: Word64+htlc_timeout_weight_anchors = 666++-- | HTLC-success tx weight without option_anchors.+htlc_success_weight_no_anchors :: Word64+htlc_success_weight_no_anchors = 703++-- | HTLC-success tx weight with option_anchors.+htlc_success_weight_anchors :: Word64+htlc_success_weight_anchors = 706++-- | Weight added per HTLC output in commitment tx.+htlc_output_weight :: Word64+htlc_output_weight = 172++-- dust thresholds (constants from Bitcoin Core) -------------------------------++-- | P2PKH dust threshold (546 satoshis).+dust_p2pkh :: Satoshi+dust_p2pkh = Satoshi 546++-- | P2SH dust threshold (540 satoshis).+dust_p2sh :: Satoshi+dust_p2sh = Satoshi 540++-- | P2WPKH dust threshold (294 satoshis).+dust_p2wpkh :: Satoshi+dust_p2wpkh = Satoshi 294++-- | P2WSH dust threshold (330 satoshis).+dust_p2wsh :: Satoshi+dust_p2wsh = Satoshi 330++-- | Fixed anchor output value (330 satoshis).+anchor_output_value :: Satoshi+anchor_output_value = Satoshi 330
+ lib/Lightning/Protocol/BOLT3/Validate.hs view
@@ -0,0 +1,359 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT3.Validate+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Stateless validation for BOLT #3 transactions.+--+-- Provides validation for:+--+-- * Commitment transaction structure and outputs+-- * HTLC transaction structure+-- * Closing transaction structure+-- * Output ordering per BIP69+CLTV+-- * Dust limit compliance++module Lightning.Protocol.BOLT3.Validate (+ -- * Validation errors+ ValidationError(..)++ -- * Commitment transaction validation+ , validate_commitment_tx+ , validate_commitment_locktime+ , validate_commitment_sequence++ -- * HTLC transaction validation+ , validate_htlc_tx+ , validate_htlc_timeout_tx+ , validate_htlc_success_tx++ -- * Closing transaction validation+ , validate_closing_tx+ , validate_legacy_closing_tx++ -- * Output validation+ , validate_output_ordering+ , validate_dust_limits+ , validate_anchor_outputs++ -- * Fee validation+ , validate_commitment_fee+ , validate_htlc_fee+ ) where++import Data.Bits ((.&.), shiftR)+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)+import Lightning.Protocol.BOLT3.Types+import Lightning.Protocol.BOLT3.Tx++-- validation errors -----------------------------------------------------------++-- | Errors that can occur during validation.+data ValidationError+ = InvalidVersion {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32+ -- ^ Expected version, actual version+ | InvalidLocktime {-# UNPACK #-} !Word32+ -- ^ Invalid locktime format+ | InvalidSequence {-# UNPACK #-} !Word32+ -- ^ Invalid sequence format+ | InvalidOutputOrdering+ -- ^ Outputs not in BIP69+CLTV order+ | DustLimitViolation {-# UNPACK #-} !Int !Satoshi !Satoshi+ -- ^ Output index, actual value, dust limit+ | MissingAnchorOutput+ -- ^ Expected anchor output not present+ | InvalidAnchorValue {-# UNPACK #-} !Satoshi+ -- ^ Anchor value not 330 satoshis+ | InvalidFee {-# UNPACK #-} !Satoshi {-# UNPACK #-} !Satoshi+ -- ^ Expected fee, actual fee+ | InvalidHTLCLocktime {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32+ -- ^ Expected locktime, actual locktime+ | InvalidHTLCSequence {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32+ -- ^ Expected sequence, actual sequence+ | NoOutputs+ -- ^ Transaction has no outputs+ | TooManyOutputs {-# UNPACK #-} !Int+ -- ^ More outputs than expected+ deriving (Eq, Show, Generic)++-- commitment transaction validation -------------------------------------------++-- | Validate a commitment transaction.+--+-- Checks:+--+-- * Version is 2+-- * Locktime format (upper 8 bits = 0x20)+-- * Sequence format (upper 8 bits = 0x80)+-- * Output ordering per BIP69+CLTV+-- * Dust limit compliance+-- * Anchor outputs if option_anchors+validate_commitment_tx+ :: DustLimit+ -> ChannelFeatures+ -> CommitmentTx+ -> Either ValidationError ()+validate_commitment_tx dust features tx = do+ -- Version must be 2+ validateVersion 2 (ctx_version tx)+ -- Locktime format+ validate_commitment_locktime (ctx_locktime tx)+ -- Sequence format+ validate_commitment_sequence (ctx_input_sequence tx)+ -- Output ordering+ validate_output_ordering (ctx_outputs tx)+ -- Dust limits+ validate_dust_limits dust (ctx_outputs tx)+ -- Anchors if applicable+ if has_anchors features+ then validate_anchor_outputs (ctx_outputs tx)+ else pure ()+{-# INLINE validate_commitment_tx #-}++-- | Validate commitment transaction locktime format.+--+-- Upper 8 bits must be 0x20.+validate_commitment_locktime :: Locktime -> Either ValidationError ()+validate_commitment_locktime (Locktime lt) =+ let !upper = (lt `shiftR` 24) .&. 0xFF+ in if upper == 0x20+ then Right ()+ else Left (InvalidLocktime lt)+{-# INLINE validate_commitment_locktime #-}++-- | Validate commitment transaction sequence format.+--+-- Upper 8 bits must be 0x80.+validate_commitment_sequence :: Sequence -> Either ValidationError ()+validate_commitment_sequence (Sequence sq) =+ let !upper = (sq `shiftR` 24) .&. 0xFF+ in if upper == 0x80+ then Right ()+ else Left (InvalidSequence sq)+{-# INLINE validate_commitment_sequence #-}++-- HTLC transaction validation -------------------------------------------------++-- | Validate an HTLC transaction (timeout or success).+--+-- Checks:+--+-- * Version is 2+-- * Single output+validate_htlc_tx :: HTLCTx -> Either ValidationError ()+validate_htlc_tx tx = do+ validateVersion 2 (htx_version tx)+ pure ()+{-# INLINE validate_htlc_tx #-}++-- | Validate an HTLC-timeout transaction.+--+-- Checks:+--+-- * Base HTLC validation+-- * Locktime equals HTLC cltv_expiry+-- * Sequence is 0 (or 1 with option_anchors)+validate_htlc_timeout_tx+ :: ChannelFeatures+ -> CltvExpiry+ -> HTLCTx+ -> Either ValidationError ()+validate_htlc_timeout_tx features expiry tx = do+ validate_htlc_tx tx+ -- Locktime must be cltv_expiry+ let !expectedLt = unCltvExpiry expiry+ !actualLt = unLocktime (htx_locktime tx)+ if expectedLt == actualLt+ then pure ()+ else Left (InvalidHTLCLocktime expectedLt actualLt)+ -- Sequence+ let !expectedSeq = if has_anchors features then 1 else 0+ !actualSeq = unSequence (htx_input_sequence tx)+ if expectedSeq == actualSeq+ then pure ()+ else Left (InvalidHTLCSequence expectedSeq actualSeq)+{-# INLINE validate_htlc_timeout_tx #-}++-- | Validate an HTLC-success transaction.+--+-- Checks:+--+-- * Base HTLC validation+-- * Locktime is 0+-- * Sequence is 0 (or 1 with option_anchors)+validate_htlc_success_tx+ :: ChannelFeatures+ -> HTLCTx+ -> Either ValidationError ()+validate_htlc_success_tx features tx = do+ validate_htlc_tx tx+ -- Locktime must be 0+ let !actualLt = unLocktime (htx_locktime tx)+ if actualLt == 0+ then pure ()+ else Left (InvalidHTLCLocktime 0 actualLt)+ -- Sequence+ let !expectedSeq = if has_anchors features then 1 else 0+ !actualSeq = unSequence (htx_input_sequence tx)+ if expectedSeq == actualSeq+ then pure ()+ else Left (InvalidHTLCSequence expectedSeq actualSeq)+{-# INLINE validate_htlc_success_tx #-}++-- closing transaction validation ----------------------------------------------++-- | Validate a closing transaction (option_simple_close).+--+-- Checks:+--+-- * Version is 2+-- * Sequence is 0xFFFFFFFD+-- * At least one output+-- * Output ordering per BIP69+validate_closing_tx :: ClosingTx -> Either ValidationError ()+validate_closing_tx tx = do+ validateVersion 2 (cltx_version tx)+ let !actualSeq = unSequence (cltx_input_sequence tx)+ if actualSeq == 0xFFFFFFFD+ then pure ()+ else Left (InvalidSequence actualSeq)+ validateOutputCount (cltx_outputs tx)+ validate_output_ordering (cltx_outputs tx)+{-# INLINE validate_closing_tx #-}++-- | Validate a legacy closing transaction (closing_signed).+--+-- Checks:+--+-- * Version is 2+-- * Locktime is 0+-- * Sequence is 0xFFFFFFFF+-- * At least one output+-- * Output ordering per BIP69+validate_legacy_closing_tx :: ClosingTx -> Either ValidationError ()+validate_legacy_closing_tx tx = do+ validateVersion 2 (cltx_version tx)+ let !actualLt = unLocktime (cltx_locktime tx)+ if actualLt == 0+ then pure ()+ else Left (InvalidLocktime actualLt)+ let !actualSeq = unSequence (cltx_input_sequence tx)+ if actualSeq == 0xFFFFFFFF+ then pure ()+ else Left (InvalidSequence actualSeq)+ validateOutputCount (cltx_outputs tx)+ validate_output_ordering (cltx_outputs tx)+{-# INLINE validate_legacy_closing_tx #-}++-- output validation -----------------------------------------------------------++-- | Validate output ordering per BIP69+CLTV.+--+-- Outputs must be sorted by:+-- 1. Value (smallest first)+-- 2. ScriptPubKey (lexicographic)+-- 3. CLTV expiry (for HTLC outputs)+validate_output_ordering :: [TxOutput] -> Either ValidationError ()+validate_output_ordering outputs =+ let !sorted = sort_outputs outputs+ in if outputs == sorted+ then Right ()+ else Left InvalidOutputOrdering+{-# INLINE validate_output_ordering #-}++-- | Validate that no output violates dust limits.+validate_dust_limits+ :: DustLimit+ -> [TxOutput]+ -> Either ValidationError ()+validate_dust_limits dust = go 0 where+ !limit = unDustLimit dust+ go !_ [] = Right ()+ go !idx (out:rest) =+ let !val = txout_value out+ in case txout_type out of+ -- Anchors have fixed value, don't check against dust limit+ OutputLocalAnchor -> go (idx + 1) rest+ OutputRemoteAnchor -> go (idx + 1) rest+ -- All other outputs must be above dust+ _ -> if unSatoshi val >= unSatoshi limit+ then go (idx + 1) rest+ else Left (DustLimitViolation idx val limit)+{-# INLINE validate_dust_limits #-}++-- | Validate anchor outputs are present and correctly valued.+validate_anchor_outputs :: [TxOutput] -> Either ValidationError ()+validate_anchor_outputs outputs =+ let !anchors = filter isAnchor outputs+ in if null anchors+ then Left MissingAnchorOutput+ else validateAnchorValues anchors+ where+ isAnchor out = case txout_type out of+ OutputLocalAnchor -> True+ OutputRemoteAnchor -> True+ _ -> False++ validateAnchorValues [] = Right ()+ validateAnchorValues (a:as) =+ let !val = txout_value a+ in if val == anchor_output_value+ then validateAnchorValues as+ else Left (InvalidAnchorValue val)+{-# INLINE validate_anchor_outputs #-}++-- fee validation --------------------------------------------------------------++-- | Validate commitment transaction fee.+--+-- Checks that the fee matches the expected calculation.+validate_commitment_fee+ :: FeeratePerKw+ -> ChannelFeatures+ -> Word64 -- ^ Number of untrimmed HTLCs+ -> Satoshi -- ^ Actual fee+ -> Either ValidationError ()+validate_commitment_fee feerate features numHtlcs actualFee =+ let !expectedFee = commitment_fee feerate features numHtlcs+ in if actualFee == expectedFee+ then Right ()+ else Left (InvalidFee expectedFee actualFee)+{-# INLINE validate_commitment_fee #-}++-- | Validate HTLC transaction fee.+validate_htlc_fee+ :: FeeratePerKw+ -> ChannelFeatures+ -> HTLCDirection+ -> Satoshi -- ^ Actual fee+ -> Either ValidationError ()+validate_htlc_fee feerate features direction actualFee =+ let !expectedFee = case direction of+ HTLCOffered -> htlc_timeout_fee feerate features+ HTLCReceived -> htlc_success_fee feerate features+ in if actualFee == expectedFee+ then Right ()+ else Left (InvalidFee expectedFee actualFee)+{-# INLINE validate_htlc_fee #-}++-- helpers ---------------------------------------------------------------------++-- | Validate transaction version.+validateVersion :: Word32 -> Word32 -> Either ValidationError ()+validateVersion expected actual =+ if expected == actual+ then Right ()+ else Left (InvalidVersion expected actual)+{-# INLINE validateVersion #-}++-- | Validate that transaction has at least one output.+validateOutputCount :: [TxOutput] -> Either ValidationError ()+validateOutputCount [] = Left NoOutputs+validateOutputCount _ = Right ()+{-# INLINE validateOutputCount #-}
+ ppad-bolt3.cabal view
@@ -0,0 +1,90 @@+cabal-version: 3.0+name: ppad-bolt3+version: 0.0.1+synopsis: Bitcoin transaction formats per BOLT #3+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:+ Bitcoin transaction formats for the Lightning Network, per+ [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md).++source-repository head+ type: git+ location: git.ppad.tech/bolt3.git++library+ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options:+ -Wall+ exposed-modules:+ Lightning.Protocol.BOLT3+ Lightning.Protocol.BOLT3.Decode+ Lightning.Protocol.BOLT3.Encode+ Lightning.Protocol.BOLT3.Keys+ Lightning.Protocol.BOLT3.Scripts+ Lightning.Protocol.BOLT3.Tx+ Lightning.Protocol.BOLT3.Types+ Lightning.Protocol.BOLT3.Validate+ build-depends:+ base >= 4.9 && < 5+ , bytestring >= 0.9 && < 0.13+ , ppad-ripemd160 >= 0.1.4 && < 0.2+ , ppad-secp256k1 >= 0.5.4 && < 0.6+ , ppad-sha256 >= 0.3.2 && < 0.4++test-suite bolt3-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+ , base16-bytestring+ , bytestring+ , ppad-bolt3+ , tasty+ , tasty-hunit++benchmark bolt3-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++benchmark bolt3-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+ , weigh+
+ test/Main.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Data.Maybe (isJust, isNothing)+import Test.Tasty+import Test.Tasty.HUnit+import Lightning.Protocol.BOLT3++main :: IO ()+main = defaultMain $ testGroup "ppad-bolt3" [+ testGroup "Key derivation" [+ keyDerivationTests+ ]+ , testGroup "Secret generation" [+ secretGenerationTests+ ]+ , testGroup "Secret storage" [+ secretStorageTests+ ]+ , testGroup "Fee calculation" [+ feeCalculationTests+ ]+ , testGroup "Trimming" [+ trimmingTests+ ]+ , testGroup "Smart constructors" [+ smartConstructorTests+ ]+ ]++-- hex decoding helper+hex :: BS.ByteString -> BS.ByteString+hex h = case B16.decode h of+ Right bs -> bs+ Left _ -> error "invalid hex"++-- Key derivation test vectors from Appendix E ---------------------------------++keyDerivationTests :: TestTree+keyDerivationTests = testGroup "BOLT #3 Appendix E" [+ testCase "derive_pubkey" $ do+ let basepoint = Point $ hex+ "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"+ perCommitmentPoint = PerCommitmentPoint $ Point $ hex+ "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"+ expected = hex+ "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"+ case derive_pubkey basepoint perCommitmentPoint of+ Nothing -> assertFailure "derive_pubkey returned Nothing"+ Just (Pubkey pk) -> pk @?= expected++ , testCase "derive_revocationpubkey" $ do+ let revocationBasepoint = RevocationBasepoint $ Point $ hex+ "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"+ perCommitmentPoint = PerCommitmentPoint $ Point $ hex+ "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"+ expected = hex+ "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0"+ case derive_revocationpubkey revocationBasepoint perCommitmentPoint of+ Nothing -> assertFailure "derive_revocationpubkey returned Nothing"+ Just (RevocationPubkey (Pubkey pk)) -> pk @?= expected+ ]++-- Secret generation test vectors from Appendix D ------------------------------++secretGenerationTests :: TestTree+secretGenerationTests = testGroup "BOLT #3 Appendix D - Generation" [+ testCase "generate_from_seed 0 final node" $ do+ let seed = hex+ "0000000000000000000000000000000000000000000000000000000000000000"+ i = 281474976710655+ expected = hex+ "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148"+ generate_from_seed seed i @?= expected++ , testCase "generate_from_seed FF final node" $ do+ let seed = hex+ "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"+ i = 281474976710655+ expected = hex+ "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"+ generate_from_seed seed i @?= expected++ , testCase "generate_from_seed FF alternate bits 1" $ do+ let seed = hex+ "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"+ i = 0xaaaaaaaaaaa+ expected = hex+ "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528"+ generate_from_seed seed i @?= expected++ , testCase "generate_from_seed FF alternate bits 2" $ do+ let seed = hex+ "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"+ i = 0x555555555555+ expected = hex+ "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31"+ generate_from_seed seed i @?= expected++ , testCase "generate_from_seed 01 last nontrivial node" $ do+ let seed = hex+ "0101010101010101010101010101010101010101010101010101010101010101"+ i = 1+ expected = hex+ "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c"+ generate_from_seed seed i @?= expected+ ]++-- Secret storage test vectors from Appendix D ---------------------------------++secretStorageTests :: TestTree+secretStorageTests = testGroup "BOLT #3 Appendix D - Storage" [+ testCase "insert_secret correct sequence" $ do+ let secrets = [+ (281474976710655, hex+ "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc")+ , (281474976710654, hex+ "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964")+ , (281474976710653, hex+ "2273e227a5b7449b6e70f1fb4652864038b1cbf9cd7c043a7d6456b7fc275ad8")+ , (281474976710652, hex+ "27cddaa5624534cb6cb9d7da077cf2b22ab21e9b506fd4998a51d54502e99116")+ , (281474976710651, hex+ "c65716add7aa98ba7acb236352d665cab17345fe45b55fb879ff80e6bd0c41dd")+ , (281474976710650, hex+ "969660042a28f32d9be17344e09374b379962d03db1574df5a8a5a47e19ce3f2")+ , (281474976710649, hex+ "a5a64476122ca0925fb344bdc1854c1c0a59fc614298e50a33e331980a220f32")+ , (281474976710648, hex+ "05cde6323d949933f7f7b78776bcc1ea6d9b31447732e3802e1f7ac44b650e17")+ ]+ let insertAll store [] = Just store+ insertAll store ((idx, secret):rest) =+ case insert_secret secret idx store of+ Nothing -> Nothing+ Just store' -> insertAll store' rest+ case insertAll empty_store secrets of+ Nothing -> assertFailure "insert_secret failed on correct sequence"+ Just _ -> return ()++ , testCase "insert_secret #1 incorrect" $ do+ -- First secret is from wrong seed, second should fail+ let store0 = empty_store+ case insert_secret (hex+ "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148")+ 281474976710655 store0 of+ Nothing -> assertFailure "First insert should succeed"+ Just store1 ->+ case insert_secret (hex+ "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964")+ 281474976710654 store1 of+ Nothing -> return () -- Expected to fail+ Just _ -> assertFailure "Second insert should fail"+ ]++-- Fee calculation tests -------------------------------------------------------++feeCalculationTests :: TestTree+feeCalculationTests = testGroup "Fee calculation" [+ testCase "commitment_fee no anchors, 0 htlcs" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ fee = commitment_fee feerate features 0+ fee @?= Satoshi 3620 -- 5000 * 724 / 1000 = 3620++ , testCase "commitment_fee no anchors, 2 htlcs" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ fee = commitment_fee feerate features 2+ -- weight = 724 + 172*2 = 1068+ -- fee = 5000 * 1068 / 1000 = 5340+ fee @?= Satoshi 5340++ , testCase "commitment_fee with anchors, 0 htlcs" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = True }+ fee = commitment_fee feerate features 0+ -- 5000 * 1124 / 1000 = 5620+ fee @?= Satoshi 5620++ , testCase "htlc_timeout_fee no anchors" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ fee = htlc_timeout_fee feerate features+ -- 5000 * 663 / 1000 = 3315+ fee @?= Satoshi 3315++ , testCase "htlc_success_fee no anchors" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ fee = htlc_success_fee feerate features+ -- 5000 * 703 / 1000 = 3515+ fee @?= Satoshi 3515++ , testCase "htlc_timeout_fee with anchors is 0" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = True }+ fee = htlc_timeout_fee feerate features+ fee @?= Satoshi 0++ , testCase "htlc_success_fee with anchors is 0" $ do+ let feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = True }+ fee = htlc_success_fee feerate features+ fee @?= Satoshi 0+ ]++-- Trimming tests --------------------------------------------------------------++trimmingTests :: TestTree+trimmingTests = testGroup "HTLC trimming" [+ testCase "offered HTLC above threshold not trimmed" $ do+ let dust = DustLimit (Satoshi 546)+ feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ htlc = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 5000000 -- 5000 sats+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }+ -- threshold = 546 + 3315 = 3861+ -- 5000 > 3861, so not trimmed+ is_trimmed dust feerate features htlc @?= False++ , testCase "offered HTLC below threshold is trimmed" $ do+ let dust = DustLimit (Satoshi 546)+ feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ htlc = HTLC+ { htlc_direction = HTLCOffered+ , htlc_amount_msat = MilliSatoshi 1000000 -- 1000 sats+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }+ -- threshold = 546 + 3315 = 3861+ -- 1000 < 3861, so trimmed+ is_trimmed dust feerate features htlc @?= True++ , testCase "received HTLC above threshold not trimmed" $ do+ let dust = DustLimit (Satoshi 546)+ feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ htlc = HTLC+ { htlc_direction = HTLCReceived+ , htlc_amount_msat = MilliSatoshi 7000000 -- 7000 sats+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }+ -- threshold = 546 + 3515 = 4061+ -- 7000 > 4061, so not trimmed+ is_trimmed dust feerate features htlc @?= False++ , testCase "received HTLC below threshold is trimmed" $ do+ let dust = DustLimit (Satoshi 546)+ feerate = FeeratePerKw 5000+ features = ChannelFeatures { cf_option_anchors = False }+ htlc = HTLC+ { htlc_direction = HTLCReceived+ , htlc_amount_msat = MilliSatoshi 800000 -- 800 sats+ , htlc_payment_hash = PaymentHash (BS.replicate 32 0)+ , htlc_cltv_expiry = CltvExpiry 500000+ }+ -- threshold = 546 + 3515 = 4061+ -- 800 < 4061, so trimmed+ is_trimmed dust feerate features htlc @?= True+ ]++-- Smart constructor tests -----------------------------------------------------++smartConstructorTests :: TestTree+smartConstructorTests = testGroup "validation" [+ -- 33-byte types+ testCase "pubkey accepts 33 bytes" $ do+ let bs = BS.replicate 33 0x02+ isJust (pubkey bs) @?= True+ , testCase "pubkey rejects 32 bytes" $ do+ let bs = BS.replicate 32 0x02+ isNothing (pubkey bs) @?= True+ , testCase "pubkey rejects 34 bytes" $ do+ let bs = BS.replicate 34 0x02+ isNothing (pubkey bs) @?= True+ , testCase "point accepts 33 bytes" $ do+ let bs = BS.replicate 33 0x03+ isJust (point bs) @?= True+ , testCase "point rejects 32 bytes" $ do+ let bs = BS.replicate 32 0x03+ isNothing (point bs) @?= True++ -- 32-byte types+ , testCase "seckey accepts 32 bytes" $ do+ let bs = BS.replicate 32 0x01+ isJust (seckey bs) @?= True+ , testCase "seckey rejects 31 bytes" $ do+ let bs = BS.replicate 31 0x01+ isNothing (seckey bs) @?= True+ , testCase "seckey rejects 33 bytes" $ do+ let bs = BS.replicate 33 0x01+ isNothing (seckey bs) @?= True+ , testCase "txid accepts 32 bytes" $ do+ let bs = BS.replicate 32 0x00+ isJust (txid bs) @?= True+ , testCase "txid rejects 31 bytes" $ do+ let bs = BS.replicate 31 0x00+ isNothing (txid bs) @?= True+ , testCase "payment_hash accepts 32 bytes" $ do+ let bs = BS.replicate 32 0xab+ isJust (payment_hash bs) @?= True+ , testCase "payment_hash rejects 33 bytes" $ do+ let bs = BS.replicate 33 0xab+ isNothing (payment_hash bs) @?= True+ , testCase "payment_preimage accepts 32 bytes" $ do+ let bs = BS.replicate 32 0xcd+ isJust (payment_preimage bs) @?= True+ , testCase "payment_preimage rejects 31 bytes" $ do+ let bs = BS.replicate 31 0xcd+ isNothing (payment_preimage bs) @?= True+ , testCase "per_commitment_secret accepts 32 bytes" $ do+ let bs = BS.replicate 32 0xef+ isJust (per_commitment_secret bs) @?= True+ , testCase "per_commitment_secret rejects 33 bytes" $ do+ let bs = BS.replicate 33 0xef+ isNothing (per_commitment_secret bs) @?= True++ -- 48-bit commitment number+ , testCase "commitment_number accepts 0" $ do+ isJust (commitment_number 0) @?= True+ , testCase "commitment_number accepts 2^48-1" $ do+ isJust (commitment_number 281474976710655) @?= True+ , testCase "commitment_number rejects 2^48" $ do+ isNothing (commitment_number 281474976710656) @?= True+ , testCase "commitment_number rejects maxBound Word64" $ do+ isNothing (commitment_number maxBound) @?= True+ ]