commit 5e927388a31a1ee047259c12fc5ce4984ecf83cc
parent 39bd0dcf9fe8bd5afba7a873e6f450245a69fe2d
Author: Jared Tobin <jared@jtobin.io>
Date: Mon, 20 Apr 2026 14:56:42 +0800
Merge impl/type-safety: type system improvements
Add validated alternatives alongside the existing unvalidated API:
- KnownFeature newtype: wraps Feature with proof of membership
in the BOLT #9 known features table. Smart constructors
knownFeatureByBit and knownFeatureByName validate lookup.
- setFeatureWithDeps: sets a feature and all its transitive
dependencies at the same level. Silently skips unknown deps.
- setFeatureForContext: validates context allowance and parity
(ChanAnnOdd forces odd/Optional, ChanAnnEven forces
even/Required) before setting. Returns Either ValidationError.
- validateNoBothBits: checks that no known feature has both its
required and optional bits set. Returns first violation found.
All existing API is unchanged. 20 new test cases (59 total).
Diffstat:
5 files changed, 328 insertions(+), 1 deletion(-)
diff --git a/lib/Lightning/Protocol/BOLT9.hs b/lib/Lightning/Protocol/BOLT9.hs
@@ -99,6 +99,9 @@ module Lightning.Protocol.BOLT9 (
-- * Known features
-- | The BOLT #9 feature table and lookup functions.
, Feature(..)
+ , KnownFeature(..)
+ , knownFeatureByBit
+ , knownFeatureByName
, featureByBit
, featureByName
, knownFeatures
@@ -117,6 +120,7 @@ module Lightning.Protocol.BOLT9 (
-- * Feature operations
-- | High-level operations using 'Feature' values.
, setFeature
+ , setFeatureWithDeps
, hasFeature
, isFeatureSet
, listFeatures
@@ -126,6 +130,8 @@ module Lightning.Protocol.BOLT9 (
, ValidationError(..)
, validateLocal
, validateRemote
+ , setFeatureForContext
+ , validateNoBothBits
, highestSetBit
, Validate.setBits
) where
diff --git a/lib/Lightning/Protocol/BOLT9/Codec.hs b/lib/Lightning/Protocol/BOLT9/Codec.hs
@@ -21,6 +21,7 @@ module Lightning.Protocol.BOLT9.Codec (
-- * Feature operations
, setFeature
+ , setFeatureWithDeps
, hasFeature
, isFeatureSet
, listFeatures
@@ -105,6 +106,30 @@ setFeature !f !level = setBit targetBit
Optional -> baseBit + 1
{-# INLINE setFeature #-}
+-- | Set a feature and all its transitive dependencies.
+--
+-- Dependencies are set at the same level as the feature itself.
+-- Unknown dependencies (not in the known features table) are
+-- silently skipped.
+--
+-- >>> import Data.Maybe (fromJust)
+-- >>> let mpp = fromJust (featureByName "basic_mpp")
+-- >>> let fv = setFeatureWithDeps mpp Optional empty
+-- >>> isFeatureSet mpp fv
+-- True
+-- >>> let Just ps = featureByName "payment_secret"
+-- >>> isFeatureSet ps fv -- dependency auto-set
+-- True
+setFeatureWithDeps
+ :: Feature -> FeatureLevel -> FeatureVector -> FeatureVector
+setFeatureWithDeps !f !level !fv =
+ let !fv' = setFeature f level fv
+ in foldr setDep fv' (featureDependencies f)
+ where
+ setDep !depName !acc = case featureByName depName of
+ Nothing -> acc
+ Just dep -> setFeatureWithDeps dep level acc
+
-- | Check if a feature is set in the vector.
--
-- Returns:
diff --git a/lib/Lightning/Protocol/BOLT9/Features.hs b/lib/Lightning/Protocol/BOLT9/Features.hs
@@ -15,6 +15,11 @@ module Lightning.Protocol.BOLT9.Features (
-- * Feature
Feature(..)
+ -- * Known feature
+ , KnownFeature(..)
+ , knownFeatureByBit
+ , knownFeatureByName
+
-- * Lookup
, featureByBit
, featureByName
@@ -50,6 +55,42 @@ data Feature = Feature {
instance NFData Feature
+-- | A feature that is known to be in the BOLT #9 specification.
+--
+-- Constructed via 'knownFeatureByBit' or 'knownFeatureByName',
+-- which validate that the feature exists in the known table.
+newtype KnownFeature = KnownFeature {
+ unKnownFeature :: Feature
+ -- ^ Extract the underlying 'Feature'.
+ }
+ deriving (Eq, Show, Generic)
+
+instance NFData KnownFeature
+
+-- | Look up a known feature by bit number.
+--
+-- Accepts either the even (compulsory) or odd (optional) bit.
+--
+-- >>> fmap (featureName . unKnownFeature) (knownFeatureByBit 16)
+-- Just "basic_mpp"
+-- >>> knownFeatureByBit 999
+-- Nothing
+knownFeatureByBit :: Word16 -> Maybe KnownFeature
+knownFeatureByBit !bit = fmap KnownFeature (featureByBit bit)
+{-# INLINE knownFeatureByBit #-}
+
+-- | Look up a known feature by its canonical name.
+--
+-- >>> fmap (featureName . unKnownFeature)
+-- ... (knownFeatureByName "basic_mpp")
+-- Just "basic_mpp"
+-- >>> knownFeatureByName "nonexistent"
+-- Nothing
+knownFeatureByName :: String -> Maybe KnownFeature
+knownFeatureByName !name =
+ fmap KnownFeature (featureByName name)
+{-# INLINE knownFeatureByName #-}
+
-- | The complete table of known features from BOLT #9.
knownFeatures :: [Feature]
knownFeatures = [
diff --git a/lib/Lightning/Protocol/BOLT9/Validate.hs b/lib/Lightning/Protocol/BOLT9/Validate.hs
@@ -20,6 +20,10 @@ module Lightning.Protocol.BOLT9.Validate (
-- * Remote validation
, validateRemote
+ -- * Validated construction
+ , setFeatureForContext
+ , validateNoBothBits
+
-- * Helpers
, highestSetBit
, setBits
@@ -31,7 +35,8 @@ import qualified Data.ByteString as BS
import qualified Data.Bits as B
import Data.Word (Word16)
import GHC.Generics (Generic)
-import Lightning.Protocol.BOLT9.Codec (isFeatureSet, testBit)
+import Lightning.Protocol.BOLT9.Codec
+ (isFeatureSet, setFeature, testBit)
import Lightning.Protocol.BOLT9.Features
import Lightning.Protocol.BOLT9.Types
@@ -144,6 +149,67 @@ parityErrors !ctx !fv = case channelParity ctx of
then InvalidParity bit ctx : acc
else acc
+-- Validated construction -------------------------------------------------------
+
+-- | Set a feature in a vector, validating that the feature is
+-- allowed in the given context and has correct parity.
+--
+-- Checks:
+--
+-- * The feature's context list includes the given context
+-- (or is empty, meaning all contexts are allowed)
+-- * For 'ChanAnnOdd', only 'Optional' (odd bit) is allowed
+-- * For 'ChanAnnEven', only 'Required' (even bit) is allowed
+--
+-- >>> import Data.Maybe (fromJust)
+-- >>> let pm = fromJust (featureByName "option_payment_metadata")
+-- >>> setFeatureForContext Invoice pm Optional empty
+-- Right ...
+-- >>> setFeatureForContext Init pm Optional empty
+-- Left (ContextNotAllowed "option_payment_metadata" Init)
+setFeatureForContext
+ :: Context
+ -> Feature
+ -> FeatureLevel
+ -> FeatureVector
+ -> Either ValidationError FeatureVector
+setFeatureForContext !ctx !f !level !fv
+ | not (null contexts)
+ , not (contextAllowed ctx contexts)
+ = Left (ContextNotAllowed (featureName f) ctx)
+ | otherwise
+ = case channelParity ctx of
+ Just True | level == Optional ->
+ Left (InvalidParity targetBit ctx)
+ Just False | level == Required ->
+ Left (InvalidParity targetBit ctx)
+ _ -> Right (setFeature f level fv)
+ where
+ !contexts = featureContexts f
+ !baseBit = featureBaseBit f
+ !targetBit = case level of
+ Required -> baseBit
+ Optional -> baseBit + 1
+
+-- | Validate that no feature has both its required and optional
+-- bits set simultaneously.
+--
+-- Returns the input vector unchanged on success.
+--
+-- >>> validateNoBothBits empty
+-- Right ...
+validateNoBothBits
+ :: FeatureVector -> Either ValidationError FeatureVector
+validateNoBothBits !fv = go knownFeatures
+ where
+ go [] = Right fv
+ go (f:fs) =
+ let !baseBit = featureBaseBit f
+ in if testBit baseBit fv
+ && testBit (baseBit + 1) fv
+ then Left (BothBitsSet baseBit (featureName f))
+ else go fs
+
-- Remote validation ----------------------------------------------------------
-- | Validate a feature vector received from a remote peer.
diff --git a/test/Main.hs b/test/Main.hs
@@ -4,6 +4,7 @@
module Main where
import qualified Data.ByteString as BS
+import Data.Either (isLeft, isRight)
import Data.Maybe (isJust, isNothing)
import Data.Word (Word16)
import Lightning.Protocol.BOLT9
@@ -20,6 +21,10 @@ tests = testGroup "ppad-bolt9" [
, bitParityTests
, featureVectorTests
, validationTests
+ , knownFeatureTests
+ , setFeatureWithDepsTests
+ , setFeatureForContextTests
+ , validateNoBothBitsTests
, propertyTests
]
@@ -232,6 +237,190 @@ isUnknownRequiredBit :: ValidationError -> Bool
isUnknownRequiredBit (UnknownRequiredBit _) = True
isUnknownRequiredBit _ = False
+-- KnownFeature tests -----------------------------------------------------------
+
+knownFeatureTests :: TestTree
+knownFeatureTests = testGroup "KnownFeature" [
+ testCase "knownFeatureByBit finds known feature" $
+ case knownFeatureByBit 16 of
+ Nothing -> assertFailure "expected basic_mpp"
+ Just kf ->
+ featureName (unKnownFeature kf) @?= "basic_mpp"
+
+ , testCase "knownFeatureByBit works for odd bit" $
+ case knownFeatureByBit 17 of
+ Nothing -> assertFailure "expected basic_mpp"
+ Just kf ->
+ featureName (unKnownFeature kf) @?= "basic_mpp"
+
+ , testCase "knownFeatureByBit returns Nothing for unknown" $
+ knownFeatureByBit 999 @?= Nothing
+
+ , testCase "knownFeatureByName finds known feature" $
+ case knownFeatureByName "payment_secret" of
+ Nothing -> assertFailure "expected payment_secret"
+ Just kf ->
+ featureBaseBit (unKnownFeature kf) @?= 14
+
+ , testCase "knownFeatureByName returns Nothing for unknown" $
+ knownFeatureByName "nonexistent" @?= Nothing
+ ]
+
+-- setFeatureWithDeps tests -----------------------------------------------------
+
+setFeatureWithDepsTests :: TestTree
+setFeatureWithDepsTests = testGroup "setFeatureWithDeps" [
+ testCase "sets feature and its dependency" $ do
+ case featureByName "basic_mpp" of
+ Nothing -> assertFailure "basic_mpp not found"
+ Just mpp -> do
+ let fv = setFeatureWithDeps mpp Optional empty
+ isFeatureSet mpp fv @?= True
+ -- payment_secret should also be set
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps -> isFeatureSet ps fv @?= True
+
+ , testCase "sets transitive dependencies" $ do
+ -- option_zeroconf depends on option_scid_alias
+ case featureByName "option_zeroconf" of
+ Nothing ->
+ assertFailure "option_zeroconf not found"
+ Just zc -> do
+ let fv = setFeatureWithDeps zc Required empty
+ isFeatureSet zc fv @?= True
+ case featureByName "option_scid_alias" of
+ Nothing ->
+ assertFailure "option_scid_alias not found"
+ Just sa -> isFeatureSet sa fv @?= True
+
+ , testCase "feature without deps sets only itself" $ do
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps -> do
+ let fv = setFeatureWithDeps ps Optional empty
+ isFeatureSet ps fv @?= True
+ -- no other features should be set
+ let others = filter
+ (\(f, _) -> featureName f /= "payment_secret")
+ (listFeatures fv)
+ null others @?= True
+
+ , testCase "passes validateLocal after setFeatureWithDeps" $ do
+ case featureByName "basic_mpp" of
+ Nothing -> assertFailure "basic_mpp not found"
+ Just mpp -> do
+ let fv = setFeatureWithDeps mpp Optional empty
+ validateLocal Init fv @?= Right ()
+ ]
+
+-- setFeatureForContext tests ---------------------------------------------------
+
+setFeatureForContextTests :: TestTree
+setFeatureForContextTests = testGroup "setFeatureForContext" [
+ testCase "allows feature in valid context" $ do
+ case featureByName "option_payment_metadata" of
+ Nothing ->
+ assertFailure "option_payment_metadata not found"
+ Just pm ->
+ isRight
+ (setFeatureForContext Invoice pm Optional empty)
+ @?= True
+
+ , testCase "rejects feature in wrong context" $ do
+ case featureByName "option_payment_metadata" of
+ Nothing ->
+ assertFailure "option_payment_metadata not found"
+ Just pm ->
+ case setFeatureForContext Init pm Optional empty of
+ Right _ -> assertFailure "expected error"
+ Left err -> isContextNotAllowed err @?= True
+
+ , testCase "allows feature with empty context list" $ do
+ -- payment_secret has empty context list (all allowed)
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps ->
+ isRight
+ (setFeatureForContext Init ps Optional empty)
+ @?= True
+
+ , testCase "rejects Required in ChanAnnOdd context" $ do
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps ->
+ case setFeatureForContext
+ ChanAnnOdd ps Required empty of
+ Right _ -> assertFailure "expected parity error"
+ Left err -> isInvalidParity err @?= True
+
+ , testCase "allows Optional in ChanAnnOdd context" $ do
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps ->
+ isRight
+ (setFeatureForContext
+ ChanAnnOdd ps Optional empty)
+ @?= True
+
+ , testCase "rejects Optional in ChanAnnEven context" $ do
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps ->
+ case setFeatureForContext
+ ChanAnnEven ps Optional empty of
+ Right _ -> assertFailure "expected parity error"
+ Left err -> isInvalidParity err @?= True
+
+ , testCase "allows Required in ChanAnnEven context" $ do
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps ->
+ isRight
+ (setFeatureForContext
+ ChanAnnEven ps Required empty)
+ @?= True
+ ]
+
+-- validateNoBothBits tests -----------------------------------------------------
+
+validateNoBothBitsTests :: TestTree
+validateNoBothBitsTests = testGroup "validateNoBothBits" [
+ testCase "passes for empty vector" $
+ isRight (validateNoBothBits empty) @?= True
+
+ , testCase "passes when only one bit of pair is set" $ do
+ case featureByName "payment_secret" of
+ Nothing ->
+ assertFailure "payment_secret not found"
+ Just ps -> do
+ let fv = setFeature ps Optional empty
+ isRight (validateNoBothBits fv) @?= True
+
+ , testCase "fails when both bits of pair are set" $ do
+ let fv = setBit 15 (setBit 14 empty)
+ case validateNoBothBits fv of
+ Right _ -> assertFailure "expected BothBitsSet"
+ Left err -> isBothBitsSet err @?= True
+
+ , testCase "returns first error found" $ do
+ -- set both bits for two features
+ let fv = setBit 15 (setBit 14
+ (setBit 17 (setBit 16 empty)))
+ isLeft (validateNoBothBits fv) @?= True
+ ]
+
+isInvalidParity :: ValidationError -> Bool
+isInvalidParity (InvalidParity _ _) = True
+isInvalidParity _ = False
+
-- Property tests --------------------------------------------------------------
propertyTests :: TestTree
