commit a78a10eb8237f34273ae59a43093fd8c75d24277
parent d3f7c77e629d7bd13b2e9e5831f85f6e02583519
Author: Jared Tobin <jared@jtobin.io>
Date: Mon, 20 Apr 2026 15:32:08 +0800
types: introduce HTLCOutputType and RevokedOutput for type safety
HTLCOutputType is a restricted ADT with only HTLCOfferedOutput and
HTLCReceivedOutput constructors, replacing the use of bolt3's
OutputType (which has 6 constructors) in HTLC revocation contexts.
This eliminates the impossible catch-all branch in spend_revoked_htlc.
RevokedOutput is a new type for penalty transaction inputs,
restricted to RevokedToLocal and RevokedHTLC variants. PenaltyContext
now uses NonEmpty RevokedOutput instead of NonEmpty UnresolvedOutput,
guaranteeing at the type level that only revokeable outputs appear
in penalty batches. This eliminates the _ -> 0 default weight branch
in spend_revoked_batch.
Also fixes test usage of PaymentPreimage constructor (now hidden by
updated bolt1) to use unPaymentPreimage accessor instead.
Diffstat:
5 files changed, 150 insertions(+), 64 deletions(-)
diff --git a/lib/Lightning/Protocol/BOLT5.hs b/lib/Lightning/Protocol/BOLT5.hs
@@ -52,11 +52,19 @@ module Lightning.Protocol.BOLT5 (
, UnresolvedOutput(..)
, OutputResolution(..)
+ -- ** HTLC output type
+ , HTLCOutputType(..)
+ , htlcOutputType
+ , htlcOutputTypeWeight
+
-- ** Spending transactions
, SpendingTx(..)
-- ** Penalty batching
+ , RevokedOutput(..)
+ , RevokedOutputType(..)
, PenaltyContext(..)
+ , revoked_output_weight
-- * Weight constants (Appendix A)
, to_local_penalty_witness_weight
diff --git a/lib/Lightning/Protocol/BOLT5/Detect.hs b/lib/Lightning/Protocol/BOLT5/Detect.hs
@@ -251,10 +251,10 @@ classifyRevokedOutput !txid !revpk !idx !out =
Resolved -- Can be swept by anyone after 16 blocks
OutputRemoteAnchor ->
Resolved -- Our anchor
- otype@(OutputOfferedHTLC _) ->
- RevokeHTLC revpk otype
- otype@(OutputReceivedHTLC _) ->
- RevokeHTLC revpk otype
+ OutputOfferedHTLC expiry ->
+ RevokeHTLC revpk (HTLCOfferedOutput expiry)
+ OutputReceivedHTLC expiry ->
+ RevokeHTLC revpk (HTLCReceivedOutput expiry)
in UnresolvedOutput op val resolution
-- preimage extraction ------------------------------------------------
diff --git a/lib/Lightning/Protocol/BOLT5/Spend.hs b/lib/Lightning/Protocol/BOLT5/Spend.hs
@@ -306,14 +306,14 @@ spend_revoked_to_local !op !value !revpk !delay
-- 'received_htlc_witness_revoke' from bolt3, depending on
-- the output type.
--
--- Returns 'Nothing' if the output type is not an HTLC, or
--- if the fee would exceed the output value.
+-- Returns 'Nothing' if the fee would exceed the output
+-- value.
spend_revoked_htlc
:: OutPoint
-- ^ Outpoint of the HTLC output.
-> Satoshi
-- ^ Value of the HTLC output.
- -> OutputType
+ -> HTLCOutputType
-- ^ Whether offered or received HTLC.
-> RevocationPubkey
-> CommitmentKeys
@@ -323,10 +323,10 @@ spend_revoked_htlc
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_revoked_htlc !op !value !otype !revpk !keys
+spend_revoked_htlc !op !value !htype !revpk !keys
!features !ph !destScript !feerate =
- case otype of
- OutputOfferedHTLC _ ->
+ case htype of
+ HTLCOfferedOutput _ ->
let !witnessScript = offered_htlc_script
revpk
(ck_remote_htlc keys)
@@ -346,7 +346,7 @@ spend_revoked_htlc !op !value !otype !revpk !keys
destScript outputValue 0
in Just (SpendingTx tx witnessScript value
SIGHASH_ALL)
- OutputReceivedHTLC expiry ->
+ HTLCReceivedOutput expiry ->
let !witnessScript = received_htlc_script
revpk
(ck_remote_htlc keys)
@@ -367,7 +367,6 @@ spend_revoked_htlc !op !value !otype !revpk !keys
destScript outputValue 0
in Just (SpendingTx tx witnessScript value
SIGHASH_ALL)
- _ -> Nothing
-- | Spend a revoked second-stage HTLC output (HTLC-timeout or
-- HTLC-success output) using the revocation key.
@@ -413,8 +412,9 @@ spend_revoked_htlc_output !op !value !revpk !delay
-- be resolved in a single penalty transaction (within the
-- 400,000 weight limit). The caller signs each input with the
-- revocation privkey.
--- | Returns 'Nothing' if the total fee would exceed the
--- total input value.
+--
+-- Returns 'Nothing' if the total fee would exceed the total
+-- input value.
spend_revoked_batch :: PenaltyContext -> Maybe SpendingTx
spend_revoked_batch !ctx =
let !outs = pc_outputs ctx
@@ -455,22 +455,16 @@ spend_revoked_batch !ctx =
SIGHASH_ALL)
where
go !totalVal !totalWt [] = (totalVal, totalWt)
- go !totalVal !totalWt (uo:rest) =
- let !w = case uo_type uo of
- Revoke _ ->
- to_local_penalty_input_weight
- RevokeHTLC _ (OutputOfferedHTLC _) ->
- offered_htlc_penalty_input_weight
- RevokeHTLC _ (OutputReceivedHTLC _) ->
- accepted_htlc_penalty_input_weight
- _ -> 0
+ go !totalVal !totalWt (ro:rest) =
+ let !w = revoked_output_weight ro
!v = Satoshi
- (unSatoshi totalVal + unSatoshi (uo_value uo))
+ (unSatoshi totalVal
+ + unSatoshi (ro_value ro))
in go v (totalWt + w) rest
- mkPenaltyInput !uo =
+ mkPenaltyInput !ro =
TxIn
- { txin_prevout = uo_outpoint uo
+ { txin_prevout = ro_outpoint ro
, txin_script_sig = BS.empty
, txin_sequence = 0xFFFFFFFF
}
diff --git a/lib/Lightning/Protocol/BOLT5/Types.hs b/lib/Lightning/Protocol/BOLT5/Types.hs
@@ -18,11 +18,19 @@ module Lightning.Protocol.BOLT5.Types (
, UnresolvedOutput(..)
, OutputResolution(..)
+ -- * HTLC output type
+ , HTLCOutputType(..)
+ , htlcOutputType
+ , htlcOutputTypeWeight
+
-- * Spending transactions
, SpendingTx(..)
-- * Penalty batching
+ , RevokedOutput(..)
+ , RevokedOutputType(..)
, PenaltyContext(..)
+ , revoked_output_weight
-- * Weight constants (Appendix A)
, to_local_penalty_witness_weight
@@ -96,12 +104,50 @@ data OutputResolution
-- remote offer).
| Revoke !RevocationPubkey
-- ^ Spend revoked to_local with revocation key.
- | RevokeHTLC !RevocationPubkey !OutputType
+ | RevokeHTLC !RevocationPubkey !HTLCOutputType
-- ^ Spend revoked HTLC output with revocation key.
| AnchorSpend !FundingPubkey
-- ^ Spend anchor output.
deriving (Eq, Show, Generic)
+-- HTLC output type -------------------------------------------------
+
+-- | Type of HTLC output, restricted to only HTLC variants.
+--
+-- Unlike bolt3's 'OutputType' which includes all six output
+-- types, this ADT makes it impossible to confuse HTLC outputs
+-- with to_local, to_remote, or anchor outputs.
+data HTLCOutputType
+ = HTLCOfferedOutput {-# UNPACK #-} !CltvExpiry
+ -- ^ Offered HTLC output with CLTV expiry.
+ | HTLCReceivedOutput {-# UNPACK #-} !CltvExpiry
+ -- ^ Received HTLC output with CLTV expiry.
+ deriving (Eq, Show, Generic)
+
+-- | Extract an 'HTLCOutputType' from a bolt3 'OutputType'.
+--
+-- Returns 'Nothing' for non-HTLC output types.
+--
+-- >>> htlcOutputType (OutputOfferedHTLC (CltvExpiry 500))
+-- Just (HTLCOfferedOutput (CltvExpiry ...))
+-- >>> htlcOutputType OutputToLocal
+-- Nothing
+htlcOutputType :: OutputType -> Maybe HTLCOutputType
+htlcOutputType (OutputOfferedHTLC e) =
+ Just (HTLCOfferedOutput e)
+htlcOutputType (OutputReceivedHTLC e) =
+ Just (HTLCReceivedOutput e)
+htlcOutputType _ = Nothing
+{-# INLINE htlcOutputType #-}
+
+-- | Penalty input weight for an HTLC output type.
+htlcOutputTypeWeight :: HTLCOutputType -> Word64
+htlcOutputTypeWeight (HTLCOfferedOutput _) =
+ offered_htlc_penalty_input_weight
+htlcOutputTypeWeight (HTLCReceivedOutput _) =
+ accepted_htlc_penalty_input_weight
+{-# INLINE htlcOutputTypeWeight #-}
+
-- spending transactions ----------------------------------------------
-- | Unsigned spending transaction, ready for caller to sign.
@@ -121,9 +167,38 @@ data SpendingTx = SpendingTx
-- penalty batching ---------------------------------------------------
+-- | A revoked output that can be swept with a revocation key.
+--
+-- This type restricts penalty transaction inputs to only
+-- valid revocation targets: to_local outputs and HTLC outputs.
+-- Other output types (to_remote, anchors) cannot appear in
+-- penalty transactions.
+data RevokedOutput = RevokedOutput
+ { ro_outpoint :: !OutPoint
+ , ro_value :: {-# UNPACK #-} !Satoshi
+ , ro_type :: !RevokedOutputType
+ } deriving (Eq, Show, Generic)
+
+-- | What kind of revoked output is being swept.
+data RevokedOutputType
+ = RevokedToLocal
+ -- ^ Revoked to_local output.
+ | RevokedHTLC !HTLCOutputType
+ -- ^ Revoked HTLC output.
+ deriving (Eq, Show, Generic)
+
+-- | Penalty input weight for a revoked output.
+revoked_output_weight :: RevokedOutput -> Word64
+revoked_output_weight !ro = case ro_type ro of
+ RevokedToLocal ->
+ to_local_penalty_input_weight
+ RevokedHTLC !htype ->
+ htlcOutputTypeWeight htype
+{-# INLINE revoked_output_weight #-}
+
-- | Context for constructing batched penalty transactions.
data PenaltyContext = PenaltyContext
- { pc_outputs :: !(NonEmpty UnresolvedOutput)
+ { pc_outputs :: !(NonEmpty RevokedOutput)
-- ^ Revoked outputs to sweep (must be non-empty).
, pc_revocation_key :: !RevocationPubkey
-- ^ Revocation pubkey for all outputs.
diff --git a/test/Main.hs b/test/Main.hs
@@ -240,8 +240,8 @@ detect_tests = testGroup "Detect" [
preimage = dummyPreimage
wit = Witness [sig, preimage]
case B5.extract_preimage_offered wit of
- Just (PaymentPreimage bs) ->
- bs @?= preimage
+ Just pp ->
+ unPaymentPreimage pp @?= preimage
Nothing ->
assertFailure "expected preimage"
@@ -263,8 +263,8 @@ detect_tests = testGroup "Detect" [
preimage = dummyPreimage
wit = Witness [zero, remoteSig, localSig, preimage]
case B5.extract_preimage_htlc_success wit of
- Just (PaymentPreimage bs) ->
- bs @?= preimage
+ Just pp ->
+ unPaymentPreimage pp @?= preimage
Nothing ->
assertFailure "expected preimage"
@@ -415,13 +415,13 @@ classify_tests = testGroup "Classify" [
@?= B5.Revoke dummyRevocationPubkey
B5.uo_type o2 @?= B5.Resolved
case B5.uo_type o3 of
- B5.RevokeHTLC _ (OutputOfferedHTLC _) ->
+ B5.RevokeHTLC _ (B5.HTLCOfferedOutput _) ->
pure ()
other -> assertFailure $
"expected RevokeHTLC offered, got "
<> show other
case B5.uo_type o4 of
- B5.RevokeHTLC _ (OutputReceivedHTLC _) ->
+ B5.RevokeHTLC _ (B5.HTLCReceivedOutput _) ->
pure ()
other -> assertFailure $
"expected RevokeHTLC received, got "
@@ -600,12 +600,12 @@ spend_tests = testGroup "Spend" [
, testCase "spend_revoked_batch total value" $ do
let op1 = OutPoint dummyTxId 0
op2 = OutPoint dummyTxId 1
- uo1 = B5.UnresolvedOutput op1 (Satoshi 50000)
- (B5.Revoke dummyRevocationPubkey)
- uo2 = B5.UnresolvedOutput op2 (Satoshi 30000)
- (B5.Revoke dummyRevocationPubkey)
+ ro1 = B5.RevokedOutput op1 (Satoshi 50000)
+ B5.RevokedToLocal
+ ro2 = B5.RevokedOutput op2 (Satoshi 30000)
+ B5.RevokedToLocal
pctx = B5.PenaltyContext
- { B5.pc_outputs = uo1 :| [uo2]
+ { B5.pc_outputs = ro1 :| [ro2]
, B5.pc_revocation_key =
dummyRevocationPubkey
, B5.pc_destination = dummyDestScript
@@ -623,11 +623,11 @@ spend_tests = testGroup "Spend" [
length (tx_inputs tx) @?= 2
, testCase "spend_revoked_batch single element" $ do
- let uo = B5.UnresolvedOutput
+ let ro = B5.RevokedOutput
dummyOutPoint (Satoshi 50000)
- (B5.Revoke dummyRevocationPubkey)
+ B5.RevokedToLocal
pctx = B5.PenaltyContext
- { B5.pc_outputs = uo :| []
+ { B5.pc_outputs = ro :| []
, B5.pc_revocation_key =
dummyRevocationPubkey
, B5.pc_destination = dummyDestScript
@@ -643,19 +643,21 @@ spend_tests = testGroup "Spend" [
let op1 = OutPoint dummyTxId 0
op2 = OutPoint dummyTxId 1
op3 = OutPoint dummyTxId 2
- uo1 = B5.UnresolvedOutput op1
+ ro1 = B5.RevokedOutput op1
(Satoshi 50000)
- (B5.Revoke dummyRevocationPubkey)
- uo2 = B5.UnresolvedOutput op2
+ B5.RevokedToLocal
+ ro2 = B5.RevokedOutput op2
(Satoshi 10000)
- (B5.RevokeHTLC dummyRevocationPubkey
- (OutputOfferedHTLC (CltvExpiry 500000)))
- uo3 = B5.UnresolvedOutput op3
+ (B5.RevokedHTLC
+ (B5.HTLCOfferedOutput
+ (CltvExpiry 500000)))
+ ro3 = B5.RevokedOutput op3
(Satoshi 10000)
- (B5.RevokeHTLC dummyRevocationPubkey
- (OutputReceivedHTLC (CltvExpiry 500000)))
+ (B5.RevokedHTLC
+ (B5.HTLCReceivedOutput
+ (CltvExpiry 500000)))
pctx = B5.PenaltyContext
- { B5.pc_outputs = uo1 :| [uo2, uo3]
+ { B5.pc_outputs = ro1 :| [ro2, ro3]
, B5.pc_revocation_key =
dummyRevocationPubkey
, B5.pc_destination = dummyDestScript
@@ -675,11 +677,11 @@ spend_tests = testGroup "Spend" [
@?= Nothing
, testCase "spend_revoked_batch fee underflow" $ do
- let uo = B5.UnresolvedOutput
+ let ro = B5.RevokedOutput
dummyOutPoint (Satoshi 1)
- (B5.Revoke dummyRevocationPubkey)
+ B5.RevokedToLocal
pctx = B5.PenaltyContext
- { B5.pc_outputs = uo :| []
+ { B5.pc_outputs = ro :| []
, B5.pc_revocation_key =
dummyRevocationPubkey
, B5.pc_destination = dummyDestScript
@@ -810,7 +812,7 @@ revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [
testCase "spend_revoked_htlc - offered" $ do
case B5.spend_revoked_htlc
dummyOutPoint (Satoshi 50000)
- (OutputOfferedHTLC (CltvExpiry 500000))
+ (B5.HTLCOfferedOutput (CltvExpiry 500000))
dummyRevocationPubkey dummyKeys
dummyFeatures dummyPaymentHash
dummyDestScript dummyFeerate of
@@ -825,7 +827,8 @@ revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [
, testCase "spend_revoked_htlc - received" $ do
case B5.spend_revoked_htlc
dummyOutPoint (Satoshi 50000)
- (OutputReceivedHTLC (CltvExpiry 500000))
+ (B5.HTLCReceivedOutput
+ (CltvExpiry 500000))
dummyRevocationPubkey dummyKeys
dummyFeatures dummyPaymentHash
dummyDestScript dummyFeerate of
@@ -838,14 +841,20 @@ revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [
assertBool "output < input"
(outVal < 50000)
- , testCase "spend_revoked_htlc - invalid type" $ do
- B5.spend_revoked_htlc
- dummyOutPoint (Satoshi 50000)
- OutputToLocal
- dummyRevocationPubkey dummyKeys
- dummyFeatures dummyPaymentHash
- dummyDestScript dummyFeerate
- @?= Nothing
+ , testCase "htlcOutputType - valid HTLC types" $ do
+ B5.htlcOutputType
+ (OutputOfferedHTLC (CltvExpiry 500))
+ @?= Just (B5.HTLCOfferedOutput (CltvExpiry 500))
+ B5.htlcOutputType
+ (OutputReceivedHTLC (CltvExpiry 600))
+ @?= Just (B5.HTLCReceivedOutput
+ (CltvExpiry 600))
+
+ , testCase "htlcOutputType - non-HTLC types" $ do
+ B5.htlcOutputType OutputToLocal @?= Nothing
+ B5.htlcOutputType OutputToRemote @?= Nothing
+ B5.htlcOutputType OutputLocalAnchor @?= Nothing
+ B5.htlcOutputType OutputRemoteAnchor @?= Nothing
, testCase "spend_revoked_htlc_output structure" $ do
stx <- assertJust "spend_revoked_htlc_output" $
