diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,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 diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -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 diff --git a/lib/Lightning/Protocol/BOLT3.hs b/lib/Lightning/Protocol/BOLT3.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3.hs @@ -0,0 +1,287 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module: Lightning.Protocol.BOLT3 +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT3/Decode.hs b/lib/Lightning/Protocol/BOLT3/Decode.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Decode.hs @@ -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 +-- +-- 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) diff --git a/lib/Lightning/Protocol/BOLT3/Encode.hs b/lib/Lightning/Protocol/BOLT3/Encode.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Encode.hs @@ -0,0 +1,298 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Lightning.Protocol.BOLT3.Encode +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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> +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]) +-- +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 @ +-- +-- Signatures must be ordered to match pubkey order in the funding script. +-- +-- >>> encode_funding_witness sig1 sig2 fundingScript +-- +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 #-} diff --git a/lib/Lightning/Protocol/BOLT3/Keys.hs b/lib/Lightning/Protocol/BOLT3/Keys.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Keys.hs @@ -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 +-- +-- 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_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 #-} diff --git a/lib/Lightning/Protocol/BOLT3/Scripts.hs b/lib/Lightning/Protocol/BOLT3/Scripts.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Scripts.hs @@ -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 +-- +-- 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 2 OP_CHECKMULTISIG@ +-- +-- Where pubkey1 is lexicographically lesser. +-- +-- >>> funding_script pk1 pk2 +-- Script "R!!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 @ +-- +-- 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 +-- +-- OP_ELSE +-- +-- OP_CHECKSEQUENCEVERIFY +-- OP_DROP +-- +-- OP_ENDIF +-- OP_CHECKSIG +-- @ +-- +-- >>> to_local_script revpk delay localpk +-- Script "c!g\xb2u!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: @ <>@ +-- +-- >>> 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: @ 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: +-- +-- @ +-- OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY +-- @ +-- +-- Without option_anchors: P2WPKH (just the pubkey hash). +-- +-- >>> to_remote_script pk (ChannelFeatures True) +-- Script "!\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: @@ (witness script appended by caller) +-- +-- Without option_anchors (P2WPKH): +-- Witness: @ @ +-- +-- >>> 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: +-- +-- @ +-- OP_CHECKSIG OP_IFDUP +-- OP_NOTIF +-- OP_16 OP_CHECKSEQUENCEVERIFY +-- OP_ENDIF +-- @ +-- +-- >>> anchor_script fundpk +-- Script "!\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: @@ +-- +-- >>> 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 OP_EQUAL +-- OP_IF +-- OP_CHECKSIG +-- OP_ELSE +-- OP_SWAP OP_SIZE 32 OP_EQUAL +-- OP_NOTIF +-- OP_DROP 2 OP_SWAP 2 OP_CHECKMULTISIG +-- OP_ELSE +-- OP_HASH160 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 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 + -- 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 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 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: @ @ +-- +-- >>> 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: @ @ +-- +-- >>> 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 OP_EQUAL +-- OP_IF +-- OP_CHECKSIG +-- OP_ELSE +-- OP_SWAP OP_SIZE 32 OP_EQUAL +-- OP_IF +-- OP_HASH160 OP_EQUALVERIFY +-- 2 OP_SWAP 2 OP_CHECKMULTISIG +-- OP_ELSE +-- OP_DROP 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 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 + -- 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 OP_EQUALVERIFY + <> BSB.word8 op_hash160 + <> push_data payment_hash160 + <> BSB.word8 op_equalverify + -- 2 OP_SWAP 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 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: @ <>@ +-- +-- >>> 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: @ @ +-- +-- >>> 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 +-- +-- OP_ELSE +-- +-- OP_CHECKSEQUENCEVERIFY +-- OP_DROP +-- +-- 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: @ 0@ +htlc_output_witness_spend :: BS.ByteString -> Witness +htlc_output_witness_spend = to_local_witness_spend + +-- | Witness for revocation spend of HTLC output. +-- +-- Witness: @ 1@ +htlc_output_witness_revoke :: BS.ByteString -> Witness +htlc_output_witness_revoke = to_local_witness_revoke diff --git a/lib/Lightning/Protocol/BOLT3/Tx.hs b/lib/Lightning/Protocol/BOLT3/Tx.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Tx.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Lightning/Protocol/BOLT3/Types.hs b/lib/Lightning/Protocol/BOLT3/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Types.hs @@ -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 +-- +-- 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 " + +-- | 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 " + +-- | 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 " + +-- | 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 diff --git a/lib/Lightning/Protocol/BOLT3/Validate.hs b/lib/Lightning/Protocol/BOLT3/Validate.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT3/Validate.hs @@ -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 +-- +-- 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 #-} diff --git a/ppad-bolt3.cabal b/ppad-bolt3.cabal new file mode 100644 --- /dev/null +++ b/ppad-bolt3.cabal @@ -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 + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]