commit 0accd2e83523fd3c545c34624af4ef97ef1e1228
parent a73d905ce85de3538a23add833feeb400f4b1752
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 25 Jan 2026 11:19:20 +0400
Implement Validate module for BOLT #3
Adds stateless validation for BOLT #3 transactions:
Validation errors:
- ValidationError ADT with descriptive error cases
- InvalidVersion, InvalidLocktime, InvalidSequence
- DustLimitViolation, MissingAnchorOutput, InvalidAnchorValue
- InvalidFee, InvalidHTLCLocktime, InvalidHTLCSequence
- NoOutputs, TooManyOutputs
Commitment transaction validation:
- validate_commitment_tx: full validation with all checks
- validate_commitment_locktime: upper 8 bits must be 0x20
- validate_commitment_sequence: upper 8 bits must be 0x80
HTLC transaction validation:
- validate_htlc_tx: base validation (version check)
- validate_htlc_timeout_tx: locktime=cltv_expiry, sequence check
- validate_htlc_success_tx: locktime=0, sequence check
Closing transaction validation:
- validate_closing_tx: option_simple_close (seq 0xFFFFFFFD)
- validate_legacy_closing_tx: closing_signed (seq 0xFFFFFFFF)
Output validation:
- validate_output_ordering: BIP69+CLTV ordering
- validate_dust_limits: all non-anchor outputs above dust
- validate_anchor_outputs: present and 330 sats
Fee validation:
- validate_commitment_fee: matches expected calculation
- validate_htlc_fee: matches expected calculation
Also includes bug fixes to Keys.hs secret storage (bucket tracking)
and minor adjustments to Scripts.hs.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
Diffstat:
3 files changed, 376 insertions(+), 49 deletions(-)
diff --git a/lib/Lightning/Protocol/BOLT3/Keys.hs b/lib/Lightning/Protocol/BOLT3/Keys.hs
@@ -289,9 +289,10 @@ flip_bit b bs =
-- Per-commitment secret storage ------------------------------------------
--- | Entry in the secret store: (index, secret).
+-- | Entry in the secret store: (bucket, index, secret).
data SecretEntry = SecretEntry
- { se_index :: {-# UNPACK #-} !Word64
+ { se_bucket :: {-# UNPACK #-} !Int
+ , se_index :: {-# UNPACK #-} !Word64
, se_secret :: !BS.ByteString
} deriving (Eq, Show, Generic)
@@ -335,33 +336,27 @@ insert_secret
-> Maybe SecretStore
insert_secret secret idx (SecretStore known) = do
let !bucket = where_to_put_secret idx
- -- Validate: for each bucket 0..bucket-1, check derivation
+ -- Validate: for each bucket < this bucket, check we can derive
validated <- validateBuckets bucket known
if validated
then
- -- Insert at bucket position, removing any existing entry at
- -- same or higher bucket
- let !known' = insertAt bucket (SecretEntry idx secret) known
- in pure $! SecretStore known'
+ -- 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 0 entries where
- go !_ [] = Just True
- go !currentB (SecretEntry knownIdx knownSecret : rest)
- | currentB >= b = Just True
+ 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 (currentB + 1) rest
+ then go rest
else Nothing
-
- insertAt :: Int -> SecretEntry -> [SecretEntry] -> [SecretEntry]
- insertAt _ entry [] = [entry]
- insertAt b entry entries@(_:_)
- | length entries <= b = entries ++ [entry]
- | otherwise = take b entries ++ [entry]
{-# INLINE insert_secret #-}
-- | Derive a previously-received secret from the store.
@@ -375,15 +370,15 @@ derive_old_secret
:: Word64 -- ^ target index
-> SecretStore -- ^ store
-> Maybe BS.ByteString
-derive_old_secret targetIdx (SecretStore known) = go 0 known where
- go :: Int -> [SecretEntry] -> Maybe BS.ByteString
- go !_ [] = Nothing
- go !b (SecretEntry knownIdx knownSecret : rest) =
- -- Mask off the non-zero prefix of the index
- let !mask = complement ((1 `shiftL` b) - 1)
+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 b targetIdx
- else go (b + 1) rest
+ then Just $! derive_secret knownSecret bucket targetIdx
+ else go rest
complement :: Word64 -> Word64
complement x = x `xor` 0xFFFFFFFFFFFFFFFF
diff --git a/lib/Lightning/Protocol/BOLT3/Scripts.hs b/lib/Lightning/Protocol/BOLT3/Scripts.hs
@@ -198,17 +198,17 @@ push_cltv !n
encode_scriptnum :: Word32 -> BS.ByteString
encode_scriptnum 0 = BS.empty
encode_scriptnum !v =
- let -- Build bytes little-endian
- go :: Word32 -> [Word8] -> [Word8]
- go 0 acc = acc
- go !x acc = go (x `shiftR` 8) (fromIntegral (x .&. 0xff) : acc)
- !bytes = reverse (go v [])
- -- If high bit set, need to add 0x00 for positive numbers
- !result = case bytes of
- [] -> []
- (b:_) | b .&. 0x80 /= 0 -> 0x00 : bytes
+ 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 (reverse result)
+ in BS.pack result
{-# INLINE push_cltv #-}
-- | Build script from builder.
@@ -364,15 +364,18 @@ to_remote_script (RemotePubkey (Pubkey !pk)) !features
-- | Witness for spending to_remote output.
--
--- With option_anchors, input nSequence must be 1.
+-- With option_anchors (P2WSH), input nSequence must be 1.
+-- Witness: @<remote_sig>@ (witness script appended by caller)
--
--- Witness: @<remote_sig>@ (for anchors, witness script appended by caller)
--- For P2WPKH: @<remote_sig> <remotepubkey>@
+-- Without option_anchors (P2WPKH):
+-- Witness: @<remote_sig> <remotepubkey>@
--
--- >>> to_remote_witness sig
--- Witness [sig]
-to_remote_witness :: BS.ByteString -> Witness
-to_remote_witness !sig = Witness [sig]
+-- >>> 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 --------------------------------------------------------------
diff --git a/lib/Lightning/Protocol/BOLT3/Validate.hs b/lib/Lightning/Protocol/BOLT3/Validate.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module: Lightning.Protocol.BOLT3.Validate
@@ -8,23 +9,351 @@
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Stateless validation for BOLT #3 transactions.
+--
+-- Provides validation for:
+--
+-- * Commitment transaction structure and outputs
+-- * HTLC transaction structure
+-- * Closing transaction structure
+-- * Output ordering per BIP69+CLTV
+-- * Dust limit compliance
module Lightning.Protocol.BOLT3.Validate (
-- * Validation errors
- -- ValidationError(..)
+ ValidationError(..)
-- * Commitment transaction validation
- -- , validate_commitment_tx
+ , validate_commitment_tx
+ , validate_commitment_locktime
+ , validate_commitment_sequence
-- * HTLC transaction validation
- -- , validate_htlc_tx
+ , validate_htlc_tx
+ , validate_htlc_timeout_tx
+ , validate_htlc_success_tx
-- * Closing transaction validation
- -- , validate_closing_tx
+ , validate_closing_tx
+ , validate_legacy_closing_tx
-- * Output validation
- -- , validate_output_ordering
- -- , validate_dust_limits
+ , 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 #-}
