diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,31 @@ # Changelog -- 0.0.1 (unreleased) +- 0.1.0 (2026-10-10) + * Breaking: the API is redesigned and now lives entirely in + Lightning.Protocol.BOLT9, with snake_case names. The submodules, + the bit-index newtypes, the name-based feature lookups and the + duplicate bit operations are gone. + + * Breaking: features are a closed enumeration matching the BOLT #9 + table at lightning/bolts@1aadb719, which adds zero_fee_commitments, + option_splice and option_onion_messages_only_channels. + + * Breaking: contexts follow the spec. C- and C+ are no longer + contexts, and channel_type is validated as a BOLT #2 channel type + (the new ChannelType) rather than as a feature vector. + + * FeatureVector preserves received bytes exactly for re-encoding, + compares equal regardless of leading zero bytes, and gains union. + + * Fixes remote validation, which skipped the dependency check, let + bits above 65535 wrap onto known features, and applied the init + rules in every context. Local validation now rejects unknown bits, + and a dependency on an ASSUMED feature counts as met. + + * Fixes setting a feature, which could leave both bits of its pair + set. + + * Drops the dependency on containers. + +- 0.0.1 (2026-04-18) * Initial release. diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs --- a/bench/Fixtures.hs +++ b/bench/Fixtures.hs @@ -1,57 +1,36 @@ module Fixtures ( - -- * ByteString fixtures - typicalBytes - , emptyBytes - , largeBytes - - -- * FeatureVector fixtures - , typicalFV - , emptyFV - , validFV - , unknownBitsFV + typical + , padded + , large + , maximal + , zeroconf_type + , zeroconf_type_features ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Lightning.Protocol.BOLT9 as B9 --- ByteString fixtures -------------------------------------------------------- - --- | A typical 8-byte feature vector with several common features set: --- basic_mpp (bit 17), option_anchors (bit 23), option_route_blinding (bit 25) -typicalBytes :: ByteString -typicalBytes = BS.pack [0x02, 0x82, 0x00, 0x00] - --- | Empty ByteString for parsing. -emptyBytes :: ByteString -emptyBytes = BS.empty - --- | Large 64-byte feature vector for stress testing. -largeBytes :: ByteString -largeBytes = BS.pack $ replicate 64 0xAA +-- | An init feature vector of the sort deployed nodes send (8 bytes). +typical :: B9.FeatureVector +typical = foldr B9.set_bit B9.empty + [1, 5, 7, 8, 11, 12, 14, 17, 23, 25, 27, 35, 39, 45, 47, 51, 61] --- FeatureVector fixtures ----------------------------------------------------- +-- | 'typical' with four leading zero bytes. +padded :: B9.FeatureVector +padded = B9.parse (BS.replicate 4 0 <> B9.render typical) --- | A typical feature vector with common features set (optional bits): --- basic_mpp (17), option_anchors (23), option_route_blinding (25) -typicalFV :: B9.FeatureVector -typicalFV = B9.parse typicalBytes +-- | 64 bytes with every odd bit set. +large :: B9.FeatureVector +large = B9.parse (BS.replicate 64 0xAA) --- | Empty feature vector. -emptyFV :: B9.FeatureVector -emptyFV = B9.empty +-- | A maximum-length (65535-byte) vector with every bit set. +maximal :: B9.FeatureVector +maximal = B9.parse (BS.replicate 65535 0xFF) --- | A valid feature vector for validation benchmarks. --- Sets payment_secret (required for basic_mpp dependency) and basic_mpp. -validFV :: B9.FeatureVector -validFV = B9.setBit 15 -- payment_secret (optional) - $ B9.setBit 17 -- basic_mpp (optional) - $ B9.setBit 23 -- option_anchors (optional) - $ B9.empty +-- | An anchors channel type with both variations. +zeroconf_type :: B9.ChannelType +zeroconf_type = B9.ChannelType B9.BasicAnchors True True --- | A feature vector with unknown bits for remote validation. --- Contains a known feature plus an unknown odd bit (safe to ignore). -unknownBitsFV :: B9.FeatureVector -unknownBitsFV = B9.setBit 15 -- payment_secret (optional, known) - $ B9.setBit 99 -- unknown odd bit (should be ignored) - $ B9.empty +-- | The vector for 'zeroconf_type'. +zeroconf_type_features :: B9.FeatureVector +zeroconf_type_features = B9.channel_type_features zeroconf_type diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,42 +1,48 @@ module Main where import Criterion.Main -import Data.Maybe (fromJust) import qualified Lightning.Protocol.BOLT9 as B9 import Fixtures -basic_mpp :: B9.Feature -basic_mpp = fromJust (B9.featureByName "basic_mpp") - main :: IO () main = defaultMain [ - bgroup "parse" [ - bench "typical (8 bytes)" $ nf B9.parse typicalBytes - , bench "empty" $ nf B9.parse emptyBytes - , bench "large (64 bytes)" $ nf B9.parse largeBytes - ] - - , bgroup "render" [ - bench "typical" $ nf B9.render typicalFV - , bench "empty" $ nf B9.render emptyFV + bgroup "vector" [ + bench "union" $ nf (B9.union typical) large + , bench "set_bit" $ nf (B9.set_bit 101) typical + , bench "clear_bit" $ nf (B9.clear_bit 17) typical + , bench "test_bit" $ nf (B9.test_bit 17) typical + , bench "set_bits" $ nf B9.set_bits typical + , bench "== (leading zeros)" $ nf (== typical) padded ] - , bgroup "bit-ops" [ - bench "setBit" $ nf (B9.setBit 50) typicalFV - , bench "testBit" $ nf (B9.testBit 17) typicalFV - , bench "hasFeature" $ - nf (flip B9.hasFeature typicalFV) basic_mpp + , bgroup "feature" [ + bench "set_feature" $ + nf (B9.set_feature B9.OptionSplice B9.Optional) typical + , bench "set_feature_with_deps" $ + nf (B9.set_feature_with_deps B9.OptionZeroconf B9.Optional) + B9.empty + , bench "test_feature" $ nf (B9.test_feature B9.BasicMpp) typical + , bench "list_features" $ nf B9.list_features typical + , bench "feature_by_bit" $ nf B9.feature_by_bit 51 ] , bgroup "validate" [ - bench "validateLocal (valid)" $ - nf (B9.validateLocal B9.Init) validFV - , bench "validateRemote (unknown bits)" $ - nf (B9.validateRemote B9.Init) unknownBitsFV + bench "validate_local (init)" $ + nf (B9.validate_local B9.InitContext) typical + , bench "validate_remote (init)" $ + nf (B9.validate_remote B9.InitContext) typical + , bench "validate_remote (init, 64 bytes)" $ + nf (B9.validate_remote B9.InitContext) large + , bench "validate_remote (init, 65535 bytes)" $ + nf (B9.validate_remote B9.InitContext) maximal + , bench "validate_remote (channel_type)" $ + nf (B9.validate_remote B9.ChannelTypeContext) + zeroconf_type_features ] - , bgroup "lookup" [ - bench "featureByBit" $ nf B9.featureByBit 16 - , bench "featureByName" $ nf B9.featureByName "basic_mpp" + , bgroup "channel type" [ + bench "channel_type" $ nf B9.channel_type zeroconf_type_features + , bench "channel_type_features" $ + nf B9.channel_type_features zeroconf_type ] ] diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -1,21 +1,18 @@ module Main where -import Weigh import qualified Lightning.Protocol.BOLT9 as B9 +import Weigh import Fixtures main :: IO () main = mainWith $ do - func "FeatureVector (5 features)" mkFiveFeatures () - func "validateLocal" (B9.validateLocal B9.Init) validFV - func "listFeatures" B9.listFeatures validFV - --- | Create a FeatureVector with 5 features set. -mkFiveFeatures :: () -> B9.FeatureVector -mkFiveFeatures _ = - B9.setBit 15 -- payment_secret - $ B9.setBit 17 -- basic_mpp - $ B9.setBit 23 -- option_anchors - $ B9.setBit 25 -- option_route_blinding - $ B9.setBit 27 -- option_shutdown_anysegwit - $ B9.empty + func "union" (B9.union typical) large + func "set_feature" (B9.set_feature B9.OptionSplice B9.Optional) typical + func "set_feature_with_deps" + (B9.set_feature_with_deps B9.OptionZeroconf B9.Optional) B9.empty + func "list_features" B9.list_features typical + func "validate_local (init)" (B9.validate_local B9.InitContext) typical + func "validate_remote (init)" (B9.validate_remote B9.InitContext) typical + func "validate_remote (init, 64 bytes)" + (B9.validate_remote B9.InitContext) large + func "channel_type" B9.channel_type zeroconf_type_features diff --git a/lib/Lightning/Protocol/BOLT9.hs b/lib/Lightning/Protocol/BOLT9.hs --- a/lib/Lightning/Protocol/BOLT9.hs +++ b/lib/Lightning/Protocol/BOLT9.hs @@ -11,126 +11,707 @@ -- Feature flags for the Lightning Network, per -- [BOLT #9](https://github.com/lightning/bolts/blob/master/09-features.md). -- --- == Overview +-- A feature vector is a big-endian bit field. Features are assigned +-- pairs of bits: setting the even bit means the feature is required, +-- setting the odd bit means it is optional (/it's ok to be odd/). -- --- BOLT #9 defines feature flags that Lightning nodes advertise to indicate --- support for optional protocol features. Features are represented as bit --- positions in a variable-length bit vector, where even bits indicate --- required (compulsory) support and odd bits indicate optional support. +-- The examples below assume: -- --- This library provides: +-- >>> :set -XOverloadedStrings +-- >>> import Lightning.Protocol.BOLT9 -- --- * Type-safe feature vectors with efficient bit manipulation --- * A complete table of known features from the BOLT #9 specification --- * Validation for both locally-created and remotely-received vectors --- * Context-aware validation (init, node_announcement, invoice, etc.) +-- Build a vector, check it before sending it, and render it: -- --- == Quick Start +-- >>> let fv = set_feature_with_deps OptionZeroconf Optional empty +-- >>> list_features fv +-- [(OptionScidAlias,Optional),(OptionZeroconf,Optional)] +-- >>> validate_local InitContext fv +-- Right () +-- >>> render fv +-- "\b\128\NUL\NUL\NUL\NUL\NUL" -- --- Create a feature vector and set some features: +-- Check a vector received from a peer: -- --- >>> import Lightning.Protocol.BOLT9 --- >>> let Just mpp = featureByName "basic_mpp" --- >>> let fv = setFeature mpp Optional empty --- >>> hasFeature mpp fv --- Just Optional +-- >>> validate_remote InitContext (parse "\DLE\NUL\NUL") +-- Left (UnknownBit 20 :| []) +-- >>> validate_remote InitContext (parse "\STX\NUL\NUL") +-- Right () + +module Lightning.Protocol.BOLT9 ( + -- * Feature vectors + FeatureVector + , parse + , render + , empty + , union + + -- * Bits + , set_bit + , clear_bit + , test_bit + , set_bits + + -- * Known features + , Feature(..) + , known_features + , feature_by_bit + , feature_bit + , feature_name + , feature_contexts + , feature_dependencies + , feature_assumed + + -- * Feature operations + , FeatureLevel(..) + , set_feature + , set_feature_with_deps + , clear_feature + , test_feature + , list_features + + -- * Validation + , Context(..) + , ValidationError(..) + , validate_local + , validate_remote + + -- * Channel types + , ChannelType(..) + , BasicChannelType(..) + , channel_type + , channel_type_features + ) where + +import Control.DeepSeq (NFData(..)) +import qualified Data.Bits as B +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.List (find) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (isNothing) +import Data.Word (Word8) +import GHC.Generics (Generic) + +-- feature vectors ----------------------------------------------------------- + +-- | A feature vector. -- --- Validate a feature vector for a specific context: +-- Bit 0 is the least significant bit of the last byte. A vector +-- produced by 'parse' keeps its bytes exactly, so 'render' gives +-- them back unchanged (signatures over gossip messages cover them). +-- Every other operation produces a minimally-encoded vector, i.e. +-- one without leading zero bytes. -- --- >>> validateLocal Init fv --- Left [MissingDependency "basic_mpp" "payment_secret"] +-- Equality ignores leading zero bytes. -- --- Fix by adding the dependency: +-- >>> parse "\NUL\STX" == parse "\STX" +-- True +-- >>> set_bit 1 empty +-- parse "\STX" +newtype FeatureVector = FeatureVector ByteString + +instance Eq FeatureVector where + FeatureVector a == FeatureVector b = strip a == strip b + +instance Show FeatureVector where + showsPrec d (FeatureVector bs) = showParen (d > 10) $ + showString "parse " . showsPrec 11 bs + +instance NFData FeatureVector where + rnf (FeatureVector bs) = rnf bs + +-- | Parse a feature vector from its wire bytes. Every byte string is a +-- valid feature vector. -- --- >>> let Just ps = featureByName "payment_secret" --- >>> let fv' = setFeature ps Optional (setFeature mpp Optional empty) --- >>> validateLocal Init fv' --- Right () +-- >>> test_bit 9 (parse "\STX\NUL") +-- True +parse :: ByteString -> FeatureVector +parse = FeatureVector +{-# INLINE parse #-} + +-- | The wire bytes of a feature vector: the original bytes of a vector +-- produced by 'parse', and the minimal encoding of any other. -- --- == Bit Numbering +-- >>> render (parse "\NUL\STX") +-- "\NUL\STX" +-- >>> render (union (parse "\NUL\STX") empty) +-- "\STX" +render :: FeatureVector -> ByteString +render (FeatureVector bs) = bs +{-# INLINE render #-} + +-- | The empty feature vector. -- --- Features use paired bits: even bits (0, 2, 4, ...) indicate required --- support, while odd bits (1, 3, 5, ...) indicate optional support. --- For example, @basic_mpp@ uses bit 16 (required) and 17 (optional). +-- >>> render empty +-- "" +empty :: FeatureVector +empty = FeatureVector BS.empty + +-- | The bitwise OR of two feature vectors. -- --- A node setting bit 16 requires all peers to support @basic_mpp@. --- A node setting bit 17 indicates optional support (peers without it --- may still connect). +-- BOLT #1 requires the receiver of an @init@ message to combine its +-- @globalfeatures@ and @features@ fields this way. +-- +-- >>> set_bits (union (parse "\STX") (parse "\SOH\NUL")) +-- [1,8] +union :: FeatureVector -> FeatureVector -> FeatureVector +union (FeatureVector a) (FeatureVector b) = + FeatureVector (combine (B..|.) a b) -module Lightning.Protocol.BOLT9 ( - -- * Context - -- | Contexts specify where feature flags appear in the protocol. - Context(..) - , isChannelContext - , channelParity +-- bits ---------------------------------------------------------------------- - -- * Bit indices - -- | Low-level bit index types for direct bit manipulation. - , BitIndex - , unBitIndex - , bitIndex +-- | Set the bit at the given index. Negative indices are ignored. +-- +-- >>> render (set_bit 9 empty) +-- "\STX\NUL" +set_bit :: Int -> FeatureVector -> FeatureVector +set_bit !i (FeatureVector bs) + | i < 0 = FeatureVector (strip bs) + | otherwise = FeatureVector (combine (B..|.) bs (single i)) - -- * Required/optional level - -- | Whether a feature is set as required or optional. - , FeatureLevel(..) +-- | Clear the bit at the given index. Negative indices are ignored. +-- +-- >>> render (clear_bit 9 (parse "\STX\SOH")) +-- "\SOH" +clear_bit :: Int -> FeatureVector -> FeatureVector +clear_bit !i (FeatureVector bs) + | i < 0 || i `quot` 8 >= BS.length s = FeatureVector s + | otherwise = FeatureVector (combine clr s (single i)) + where + s = strip bs + clr x y = x B..&. B.complement y - -- * Required/optional bits - -- | Type-safe wrappers ensuring correct parity. - , RequiredBit - , unRequiredBit - , requiredBit - , requiredFromBitIndex +-- | Test the bit at the given index. Negative indices are never set. +-- +-- >>> test_bit 9 (parse "\STX\NUL") +-- True +-- >>> test_bit 8 (parse "\STX\NUL") +-- False +test_bit :: Int -> FeatureVector -> Bool +test_bit !i (FeatureVector bs) + | i < 0 || q >= len = False + | otherwise = B.testBit (BS.index bs (len - 1 - q)) r + where + len = BS.length bs + (q, r) = i `quotRem` 8 - , OptionalBit - , unOptionalBit - , optionalBit - , optionalFromBitIndex +-- | The indices of all set bits, in ascending order. +-- +-- >>> set_bits (parse "\STX\NUL\SOH") +-- [0,17] +set_bits :: FeatureVector -> [Int] +set_bits (FeatureVector bs) = go 0 + where + !len = BS.length bs + go !q + | q >= len = [] + | otherwise = + let !w = BS.index bs (len - 1 - q) + in [q * 8 + r | r <- [0 .. 7], B.testBit w r] ++ go (q + 1) - -- * Feature vectors - -- | The core feature vector type and basic operations. - , FeatureVector - , unFeatureVector - , FV.empty - , fromByteString - , set - , clear - , member +-- Drop leading zero bytes. +strip :: ByteString -> ByteString +strip = BS.dropWhile (== 0) +{-# INLINE strip #-} - -- * Known features - -- | The BOLT #9 feature table and lookup functions. - , Feature(..) - , featureByBit - , featureByName - , knownFeatures +-- The minimal encoding of a vector with only bit i set (i >= 0). +single :: Int -> ByteString +single i = BS.cons (B.bit r) (BS.replicate q 0) + where + (q, r) = i `quotRem` 8 - -- * Parsing and rendering - -- | Wire format conversion. - , parse - , render +-- Combine two encodings bytewise, aligned at their last bytes (the +-- shorter one padded with leading zeros), and strip the result. +combine + :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString +combine f a b = strip (fst (BS.unfoldrN n step 0)) + where + !la = BS.length a + !lb = BS.length b + !n = max la lb + byte s ls k + | k < n - ls = 0 + | otherwise = BS.index s (k - n + ls) + step !k = Just (f (byte a la k) (byte b lb k), k + 1) - -- * Low-level bit operations - -- | Direct bit manipulation by index. - , Codec.setBit - , Codec.clearBit - , Codec.testBit +-- known features ------------------------------------------------------------ - -- * Feature operations - -- | High-level operations using 'Feature' values. - , setFeature - , hasFeature - , isFeatureSet - , listFeatures +-- | The features assigned in the BOLT #9 table. +data Feature + = OptionDataLossProtect -- ^ 0/1 @option_data_loss_protect@ + | OptionUpfrontShutdownScript -- ^ 4/5 @option_upfront_shutdown_script@ + | GossipQueries -- ^ 6/7 @gossip_queries@ + | VarOnionOptin -- ^ 8/9 @var_onion_optin@ + | GossipQueriesEx -- ^ 10/11 @gossip_queries_ex@ + | OptionStaticRemotekey -- ^ 12/13 @option_static_remotekey@ + | PaymentSecret -- ^ 14/15 @payment_secret@ + | BasicMpp -- ^ 16/17 @basic_mpp@ + | OptionSupportLargeChannel -- ^ 18/19 @option_support_large_channel@ + | OptionAnchors -- ^ 22/23 @option_anchors@ + | OptionRouteBlinding -- ^ 24/25 @option_route_blinding@ + | OptionShutdownAnysegwit -- ^ 26/27 @option_shutdown_anysegwit@ + | OptionDualFund -- ^ 28/29 @option_dual_fund@ + | OptionQuiesce -- ^ 34/35 @option_quiesce@ + | OptionAttributionData -- ^ 36/37 @option_attribution_data@ + | OptionOnionMessages -- ^ 38/39 @option_onion_messages@ + | ZeroFeeCommitments -- ^ 40/41 @zero_fee_commitments@ + | OptionProvideStorage -- ^ 42/43 @option_provide_storage@ + | OptionChannelType -- ^ 44/45 @option_channel_type@ + | OptionScidAlias -- ^ 46/47 @option_scid_alias@ + | OptionPaymentMetadata -- ^ 48/49 @option_payment_metadata@ + | OptionZeroconf -- ^ 50/51 @option_zeroconf@ + | OptionSimpleClose -- ^ 60/61 @option_simple_close@ + | OptionSplice -- ^ 62/63 @option_splice@ + | OptionOnionMessagesOnlyChannels + -- ^ 66/67 @option_onion_messages_only_channels@ + deriving (Eq, Ord, Show, Generic) - -- * Validation - -- | Validate feature vectors for correctness. - , ValidationError(..) - , validateLocal - , validateRemote - , highestSetBit - , Validate.setBits - ) where +instance NFData Feature -import Lightning.Protocol.BOLT9.Codec as Codec -import Lightning.Protocol.BOLT9.Features -import Lightning.Protocol.BOLT9.Types as FV -import Lightning.Protocol.BOLT9.Validate as Validate +-- | All known features, in bit order. +-- +-- >>> length known_features +-- 25 +known_features :: [Feature] +known_features = [ + OptionDataLossProtect + , OptionUpfrontShutdownScript + , GossipQueries + , VarOnionOptin + , GossipQueriesEx + , OptionStaticRemotekey + , PaymentSecret + , BasicMpp + , OptionSupportLargeChannel + , OptionAnchors + , OptionRouteBlinding + , OptionShutdownAnysegwit + , OptionDualFund + , OptionQuiesce + , OptionAttributionData + , OptionOnionMessages + , ZeroFeeCommitments + , OptionProvideStorage + , OptionChannelType + , OptionScidAlias + , OptionPaymentMetadata + , OptionZeroconf + , OptionSimpleClose + , OptionSplice + , OptionOnionMessagesOnlyChannels + ] + +-- A row of the BOLT #9 table. +data Entry = Entry { + e_bit :: !Int + , e_name :: !String + , e_contexts :: ![Context] + , e_deps :: ![Feature] + , e_assumed :: !Bool + } + +entry :: Feature -> Entry +entry f = case f of + OptionDataLossProtect -> + Entry 0 "option_data_loss_protect" [] [] True + OptionUpfrontShutdownScript -> + Entry 4 "option_upfront_shutdown_script" _IN [] False + GossipQueries -> + Entry 6 "gossip_queries" [] [] False + VarOnionOptin -> + Entry 8 "var_onion_optin" [] [] True + GossipQueriesEx -> + Entry 10 "gossip_queries_ex" _IN [] False + OptionStaticRemotekey -> + Entry 12 "option_static_remotekey" [] [] True + PaymentSecret -> + Entry 14 "payment_secret" [] [] True + BasicMpp -> + Entry 16 "basic_mpp" _IN9 [PaymentSecret] False + OptionSupportLargeChannel -> + Entry 18 "option_support_large_channel" _IN [] False + OptionAnchors -> + Entry 22 "option_anchors" _INT [] False + OptionRouteBlinding -> + Entry 24 "option_route_blinding" _IN9 [] False + OptionShutdownAnysegwit -> + Entry 26 "option_shutdown_anysegwit" _IN [] False + OptionDualFund -> + Entry 28 "option_dual_fund" _IN [] False + OptionQuiesce -> + Entry 34 "option_quiesce" _IN [] False + OptionAttributionData -> + Entry 36 "option_attribution_data" _IN9 [] False + OptionOnionMessages -> + Entry 38 "option_onion_messages" _IN [] False + ZeroFeeCommitments -> + Entry 40 "zero_fee_commitments" _IN [OptionChannelType] False + OptionProvideStorage -> + Entry 42 "option_provide_storage" _IN [] False + OptionChannelType -> + Entry 44 "option_channel_type" [] [] True + OptionScidAlias -> + Entry 46 "option_scid_alias" _INT [] False + OptionPaymentMetadata -> + Entry 48 "option_payment_metadata" [InvoiceContext] [] False + OptionZeroconf -> + Entry 50 "option_zeroconf" _INT [OptionScidAlias] False + OptionSimpleClose -> + Entry 60 "option_simple_close" _IN [OptionShutdownAnysegwit] False + OptionSplice -> + Entry 62 "option_splice" _IN [] False + OptionOnionMessagesOnlyChannels -> + Entry 66 "option_onion_messages_only_channels" _IN + [OptionOnionMessages] False + where + _IN = [InitContext, NodeContext] + _IN9 = [InitContext, NodeContext, InvoiceContext] + _INT = [InitContext, NodeContext, ChannelTypeContext] + +-- | The feature that a bit (even or odd) belongs to, if any. +-- +-- >>> feature_by_bit 16 +-- Just BasicMpp +-- >>> feature_by_bit 17 +-- Just BasicMpp +-- >>> feature_by_bit 20 +-- Nothing +feature_by_bit :: Int -> Maybe Feature +feature_by_bit !i + | i < 0 || i > max_known_bit = Nothing + | otherwise = find ((== base) . feature_bit) known_features + where + base = i - i `rem` 2 + +-- The highest bit assigned to any known feature. +max_known_bit :: Int +max_known_bit = foldr (max . (+ 1) . feature_bit) 0 known_features + +-- | A feature's even (required) bit. Its odd (optional) bit is the +-- next one up. +-- +-- >>> feature_bit BasicMpp +-- 16 +feature_bit :: Feature -> Int +feature_bit = e_bit . entry + +-- | A feature's name in the BOLT #9 table. +-- +-- >>> feature_name BasicMpp +-- "basic_mpp" +feature_name :: Feature -> String +feature_name = e_name . entry + +-- | The contexts the BOLT #9 table lists for a feature, in table order. +-- The list is empty for ASSUMED features and for 'GossipQueries'. +-- +-- >>> feature_contexts BasicMpp +-- [InitContext,NodeContext,InvoiceContext] +-- >>> feature_contexts PaymentSecret +-- [] +feature_contexts :: Feature -> [Context] +feature_contexts = e_contexts . entry + +-- | A feature's direct dependencies. +-- +-- >>> feature_dependencies OptionZeroconf +-- [OptionScidAlias] +feature_dependencies :: Feature -> [Feature] +feature_dependencies = e_deps . entry + +-- | Whether BOLT #9 marks a feature ASSUMED, i.e. supported by all +-- nodes. +-- +-- >>> feature_assumed PaymentSecret +-- True +feature_assumed :: Feature -> Bool +feature_assumed = e_assumed . entry + +-- feature operations -------------------------------------------------------- + +-- | The level at which a feature is set. +data FeatureLevel + = Required -- ^ the even bit is set + | Optional -- ^ the odd bit is set + deriving (Eq, Ord, Show, Generic) + +instance NFData FeatureLevel + +level_bit :: Feature -> FeatureLevel -> Int +level_bit f Required = feature_bit f +level_bit f Optional = feature_bit f + 1 +{-# INLINE level_bit #-} + +-- | Set a feature at the given level, clearing the other bit of its +-- pair. +-- +-- >>> set_bits (set_feature BasicMpp Optional empty) +-- [17] +-- >>> set_bits (set_feature BasicMpp Required (set_bit 17 empty)) +-- [16] +set_feature :: Feature -> FeatureLevel -> FeatureVector -> FeatureVector +set_feature f l = set_bit (level_bit f l) . clear_bit (level_bit f other) + where + other = case l of + Required -> Optional + Optional -> Required + +-- | Set a feature at the given level, together with its transitive +-- dependencies (ASSUMED ones included). Dependencies that are not +-- yet set are set at the same level; those already set keep theirs. +-- +-- >>> list_features (set_feature_with_deps BasicMpp Optional empty) +-- [(PaymentSecret,Optional),(BasicMpp,Optional)] +set_feature_with_deps + :: Feature -> FeatureLevel -> FeatureVector -> FeatureVector +set_feature_with_deps f l fv = + foldr ensure (set_feature f l fv) (feature_dependencies f) + where + ensure d acc = + let acc' = case test_feature d acc of + Just _ -> acc + Nothing -> set_feature d l acc + in foldr ensure acc' (feature_dependencies d) + +-- | Clear both bits of a feature. +-- +-- >>> clear_feature BasicMpp (set_feature BasicMpp Optional empty) +-- parse "" +clear_feature :: Feature -> FeatureVector -> FeatureVector +clear_feature f = + clear_bit (level_bit f Required) . clear_bit (level_bit f Optional) + +-- | The level at which a feature is set, if it is. +-- +-- A feature with both bits set is 'Required', as BOLT #9 directs the +-- receiver to treat it. +-- +-- >>> test_feature BasicMpp (set_bit 17 empty) +-- Just Optional +-- >>> test_feature BasicMpp (set_bit 16 (set_bit 17 empty)) +-- Just Required +-- >>> test_feature BasicMpp empty +-- Nothing +test_feature :: Feature -> FeatureVector -> Maybe FeatureLevel +test_feature f fv + | test_bit (level_bit f Required) fv = Just Required + | test_bit (level_bit f Optional) fv = Just Optional + | otherwise = Nothing + +-- | The known features set in a vector, in bit order. +-- +-- >>> list_features (parse "\SOH\128\NUL") +-- [(PaymentSecret,Optional),(BasicMpp,Required)] +list_features :: FeatureVector -> [(Feature, FeatureLevel)] +list_features fv = + [(f, l) | f <- known_features, Just l <- [test_feature f fv]] + +-- validation ---------------------------------------------------------------- + +-- | A field in which feature bits are presented: the values of the +-- Context column of the BOLT #9 table. +-- +-- The table's @C-@ and @C+@ are not further contexts. They mark a +-- feature presented in @channel_announcement@ as always optional or +-- always required. No feature at the implemented spec revision is +-- presented in @channel_announcement@ in any form. +data Context + = InitContext -- ^ @I@: the @init@ message + | NodeContext -- ^ @N@: @node_announcement@ + | ChannelContext -- ^ @C@: @channel_announcement@ + | InvoiceContext -- ^ @9@: BOLT #11 invoices + | BlindedContext -- ^ @B@: @allowed_features@ of a blinded path + | ChannelTypeContext -- ^ @T@: the @channel_type@ field + deriving (Eq, Ord, Show, Generic) + +instance NFData Context + +-- | A rule a feature vector breaks. +data ValidationError + = UnknownBit {-# UNPACK #-} !Int + -- ^ a bit belonging to no known feature is set + | BothBitsSet !Feature + -- ^ both bits of a feature are set + | ContextNotAllowed !Feature !Context + -- ^ a feature is set in a context that doesn't present it + | MissingDependency !Feature !Feature + -- ^ a set feature (first) lacks a dependency (second) + | InvalidChannelType + -- ^ a @channel_type@ is not a type that BOLT #2 defines + deriving (Eq, Show, Generic) + +instance NFData ValidationError + +-- | Validate a feature vector that we're about to send in the given +-- context, per the origin requirements of BOLT #9 and BOLT #1. +-- +-- For 'ChannelTypeContext', the vector must be a channel type that +-- BOLT #2 defines (see 'channel_type'). For every other context, +-- checks that: +-- +-- * no bit outside the known features is set; +-- * no feature has both bits set; +-- * each set feature is presented in the context. A feature with an +-- empty Context column (the ASSUMED features and 'GossipQueries') +-- is accepted in 'InitContext', 'NodeContext' and +-- 'InvoiceContext', where deployed nodes still present it; +-- * each set feature's dependencies are set. A dependency on an +-- ASSUMED feature counts as met even when its bits are clear. +-- +-- Errors are reported in that order. No known feature is presented +-- in 'ChannelContext' or 'BlindedContext', so only the empty vector +-- passes there (as BOLT #4 requires of @allowed_features@). +-- +-- >>> validate_local InitContext (set_feature OptionZeroconf Optional empty) +-- Left (MissingDependency OptionZeroconf OptionScidAlias :| []) +-- >>> validate_local InitContext (set_feature BasicMpp Optional empty) +-- Right () +-- >>> validate_local InitContext (set_bit 101 empty) +-- Left (UnknownBit 101 :| []) +validate_local + :: Context -> FeatureVector -> Either (NonEmpty ValidationError) () +validate_local ctx fv = to_either $ case ctx of + ChannelTypeContext -> channel_type_errors fv + _ -> unknown_bits (const True) fv + ++ both_bits_errors fv + ++ context_errors ctx fv + ++ dependency_errors fv + +-- | Validate a feature vector received in the given context, per the +-- receiver requirements for that context: +-- +-- * 'InitContext' (BOLT #1) and 'InvoiceContext' (BOLT #11): no +-- unknown even bit is set, and each set feature's dependencies are +-- set (ASSUMED dependencies count as met). +-- * 'NodeContext' and 'ChannelContext' (BOLT #7): no unknown even +-- bit is set. A failure here means the node or channel must not be +-- routed through; the announcement itself is still valid. +-- * 'BlindedContext' (BOLT #4): no unknown bit is set, odd or even. +-- * 'ChannelTypeContext' (BOLT #2): the vector is a defined channel +-- type (see 'channel_type'). +-- +-- Unknown odd bits are otherwise ignored. A feature with both bits +-- set is not an error; it counts as 'Required' (see 'test_feature'). +-- Nor is a known feature outside its listed contexts, since that +-- rule binds only the sender. +-- +-- >>> validate_remote InitContext (set_bit 101 empty) +-- Right () +-- >>> validate_remote InitContext (set_bit 100 empty) +-- Left (UnknownBit 100 :| []) +-- >>> validate_remote BlindedContext (set_bit 101 empty) +-- Left (UnknownBit 101 :| []) +validate_remote + :: Context -> FeatureVector -> Either (NonEmpty ValidationError) () +validate_remote ctx fv = to_either $ case ctx of + InitContext -> unknown_even ++ dependency_errors fv + NodeContext -> unknown_even + ChannelContext -> unknown_even + InvoiceContext -> unknown_even ++ dependency_errors fv + BlindedContext -> unknown_bits (const True) fv + ChannelTypeContext -> channel_type_errors fv + where + unknown_even = unknown_bits even fv + +to_either :: [e] -> Either (NonEmpty e) () +to_either [] = Right () +to_either (e : es) = Left (e :| es) + +-- Unknown set bits satisfying the predicate. +unknown_bits :: (Int -> Bool) -> FeatureVector -> [ValidationError] +unknown_bits p fv = + [ UnknownBit i + | i <- set_bits fv, p i, isNothing (feature_by_bit i) ] + +both_bits_errors :: FeatureVector -> [ValidationError] +both_bits_errors fv = + [ BothBitsSet f + | f <- known_features + , test_bit (level_bit f Required) fv + , test_bit (level_bit f Optional) fv ] + +context_errors :: Context -> FeatureVector -> [ValidationError] +context_errors ctx fv = + [ ContextNotAllowed f ctx + | (f, _) <- list_features fv, not (presented f) ] + where + presented f = case feature_contexts f of + [] -> ctx `elem` [InitContext, NodeContext, InvoiceContext] + cs -> ctx `elem` cs + +dependency_errors :: FeatureVector -> [ValidationError] +dependency_errors fv = + [ MissingDependency f d + | (f, _) <- list_features fv + , d <- feature_dependencies f + , not (feature_assumed d) + , isNothing (test_feature d fv) ] + +channel_type_errors :: FeatureVector -> [ValidationError] +channel_type_errors fv = case channel_type fv of + Nothing -> [InvalidChannelType] + Just _ -> [] + +-- channel types ------------------------------------------------------------- + +-- | The basic channel types of BOLT #2. +data BasicChannelType + = BasicStaticRemotekey + -- ^ 'OptionStaticRemotekey' (bit 12) + | BasicAnchors + -- ^ 'OptionAnchors' and 'OptionStaticRemotekey' (bits 22 and 12) + | BasicZeroFeeCommitments + -- ^ 'ZeroFeeCommitments' (bit 40) + deriving (Eq, Ord, Show, Generic) + +instance NFData BasicChannelType + +-- | A channel type, per BOLT #2: a basic type plus any of the +-- 'OptionScidAlias' and 'OptionZeroconf' variations. +-- +-- Channel types are an enumeration that reuses even feature bits; +-- they aren't subject to the dependency or context rules for +-- feature vectors. BOLT #2 also forbids 'OptionScidAlias' in the +-- channel type of a channel to be announced, which needs the +-- @announce_channel@ flag to check. +data ChannelType = ChannelType { + ct_basic :: !BasicChannelType + , ct_scid_alias :: !Bool + , ct_zeroconf :: !Bool + } + deriving (Eq, Show, Generic) + +instance NFData ChannelType + +-- | The channel type that a @channel_type@ vector encodes, if it is a +-- defined one. Leading zero bytes are ignored. +-- +-- >>> let zeroconf = ChannelType BasicStaticRemotekey False True +-- >>> channel_type (parse "\EOT\NUL\NUL\NUL\NUL\DLE\NUL") == Just zeroconf +-- True +-- >>> channel_type (set_bit 13 empty) +-- Nothing +channel_type :: FeatureVector -> Maybe ChannelType +channel_type fv = find ((== fv) . channel_type_features) channel_types + +-- All defined channel types. +channel_types :: [ChannelType] +channel_types = + [ ChannelType b s z + | b <- [BasicStaticRemotekey, BasicAnchors, BasicZeroFeeCommitments] + , s <- [False, True] + , z <- [False, True] ] + +-- | The @channel_type@ vector for a channel type. +-- +-- >>> let anchors = ChannelType BasicAnchors False False +-- >>> render (channel_type_features anchors) +-- "@\DLE\NUL" +channel_type_features :: ChannelType -> FeatureVector +channel_type_features (ChannelType b s z) = + foldr (\f -> set_feature f Required) empty + (basic b ++ [OptionScidAlias | s] ++ [OptionZeroconf | z]) + where + basic BasicStaticRemotekey = [OptionStaticRemotekey] + basic BasicAnchors = [OptionAnchors, OptionStaticRemotekey] + basic BasicZeroFeeCommitments = [ZeroFeeCommitments] diff --git a/lib/Lightning/Protocol/BOLT9/Codec.hs b/lib/Lightning/Protocol/BOLT9/Codec.hs deleted file mode 100644 --- a/lib/Lightning/Protocol/BOLT9/Codec.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} - --- | --- Module: Lightning.Protocol.BOLT9.Codec --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Parsing and rendering for BOLT #9 feature vectors. - -module Lightning.Protocol.BOLT9.Codec ( - -- * Parsing and rendering - parse - , render - - -- * Bit operations - , setBit - , clearBit - , testBit - - -- * Feature operations - , setFeature - , hasFeature - , isFeatureSet - , listFeatures - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Word (Word16) -import Lightning.Protocol.BOLT9.Features -import Lightning.Protocol.BOLT9.Types - ( FeatureLevel(..) - , FeatureVector - , bitIndex - , clear - , fromByteString - , member - , set - , unFeatureVector - ) - --- Parsing and rendering ------------------------------------------------------ - --- | Parse a ByteString into a FeatureVector. --- --- Alias for 'fromByteString'. -parse :: ByteString -> FeatureVector -parse = fromByteString -{-# INLINE parse #-} - --- | Render a FeatureVector to a ByteString, trimming leading zero bytes --- for compact encoding. -render :: FeatureVector -> ByteString -render = BS.dropWhile (== 0) . unFeatureVector -{-# INLINE render #-} - --- Bit operations ------------------------------------------------------------- - --- | Set a bit by raw index. --- --- >>> setBit 17 empty --- FeatureVector {unFeatureVector = "\STX"} -setBit :: Word16 -> FeatureVector -> FeatureVector -setBit !idx = set (bitIndex idx) -{-# INLINE setBit #-} - --- | Clear a bit by raw index. --- --- >>> clearBit 17 (setBit 17 empty) --- FeatureVector {unFeatureVector = ""} -clearBit :: Word16 -> FeatureVector -> FeatureVector -clearBit !idx = clear (bitIndex idx) -{-# INLINE clearBit #-} - --- | Test if a bit is set. --- --- >>> testBit 17 (setBit 17 empty) --- True --- >>> testBit 16 (setBit 17 empty) --- False -testBit :: Word16 -> FeatureVector -> Bool -testBit !idx = member (bitIndex idx) -{-# INLINE testBit #-} - --- Feature operations --------------------------------------------------------- - --- | Set a feature's bit at the given level. --- --- 'Required' sets the even bit, 'Optional' sets the odd bit. --- --- >>> import Data.Maybe (fromJust) --- >>> let mpp = fromJust (featureByName "basic_mpp") --- >>> setFeature mpp Optional empty -- set optional bit (17) --- FeatureVector {unFeatureVector = "\STX"} --- >>> setFeature mpp Required empty -- set required bit (16) --- FeatureVector {unFeatureVector = "\SOH"} -setFeature :: Feature -> FeatureLevel -> FeatureVector -> FeatureVector -setFeature !f !level = setBit targetBit - where - !baseBit = featureBaseBit f - !targetBit = case level of - Required -> baseBit - Optional -> baseBit + 1 -{-# INLINE setFeature #-} - --- | Check if a feature is set in the vector. --- --- Returns: --- --- * @Just Required@ if the required (even) bit is set --- * @Just Optional@ if the optional (odd) bit is set (and required is not) --- * @Nothing@ if neither bit is set --- --- >>> import Data.Maybe (fromJust) --- >>> let mpp = fromJust (featureByName "basic_mpp") --- >>> hasFeature mpp (setFeature mpp Optional empty) --- Just Optional --- >>> hasFeature mpp (setFeature mpp Required empty) --- Just Required --- >>> hasFeature mpp empty --- Nothing -hasFeature :: Feature -> FeatureVector -> Maybe FeatureLevel -hasFeature !f !fv - | testBit baseBit fv = Just Required - | testBit (baseBit + 1) fv = Just Optional - | otherwise = Nothing - where - !baseBit = featureBaseBit f -{-# INLINE hasFeature #-} - --- | Check if either bit of a feature is set in the vector. --- --- >>> import Data.Maybe (fromJust) --- >>> let mpp = fromJust (featureByName "basic_mpp") --- >>> isFeatureSet mpp (setFeature mpp Optional empty) --- True --- >>> isFeatureSet mpp empty --- False -isFeatureSet :: Feature -> FeatureVector -> Bool -isFeatureSet !f !fv = - let !baseBit = featureBaseBit f - in testBit baseBit fv || testBit (baseBit + 1) fv -{-# INLINE isFeatureSet #-} - --- | List all known features that are set in the vector. --- --- Returns pairs of (Feature, FeatureLevel) indicating whether each --- feature is set as required or optional. --- --- >>> import Data.Maybe (fromJust) --- >>> let mpp = fromJust (featureByName "basic_mpp") --- >>> let ps = fromJust (featureByName "payment_secret") --- >>> let fv = setFeature mpp Optional (setFeature ps Required empty) --- >>> map (\(f, l) -> (featureName f, l)) (listFeatures fv) --- [("payment_secret",Required),("basic_mpp",Optional)] -listFeatures :: FeatureVector -> [(Feature, FeatureLevel)] -listFeatures !fv = foldr check [] knownFeatures - where - check !f !acc = case hasFeature f fv of - Just level -> (f, level) : acc - Nothing -> acc diff --git a/lib/Lightning/Protocol/BOLT9/Features.hs b/lib/Lightning/Protocol/BOLT9/Features.hs deleted file mode 100644 --- a/lib/Lightning/Protocol/BOLT9/Features.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} - --- | --- Module: Lightning.Protocol.BOLT9.Features --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Known feature table for the Lightning Network, per --- [BOLT #9](https://github.com/lightning/bolts/blob/master/09-features.md). - -module Lightning.Protocol.BOLT9.Features ( - -- * Feature - Feature(..) - - -- * Lookup - , featureByBit - , featureByName - - -- * Known features table - , knownFeatures - ) where - -import Control.DeepSeq (NFData) -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IM -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Word (Word16) -import GHC.Generics (Generic) -import Lightning.Protocol.BOLT9.Types (Context(..)) - --- | A known feature from the BOLT #9 specification. -data Feature = Feature { - featureName :: !String - -- ^ The canonical name of the feature. - , featureBaseBit :: {-# UNPACK #-} !Word16 - -- ^ The even (compulsory) bit number; the odd (optional) bit is - -- @baseBit + 1@. - , featureContexts :: ![Context] - -- ^ Contexts in which this feature may be presented. - , featureDependencies :: ![String] - -- ^ Names of features this feature depends on. - , featureAssumed :: !Bool - -- ^ Whether this feature is assumed to be universally supported. - } - deriving (Eq, Show, Generic) - -instance NFData Feature - --- | The complete table of known features from BOLT #9. -knownFeatures :: [Feature] -knownFeatures = [ - Feature "option_data_loss_protect" 0 [] [] True - , Feature "option_upfront_shutdown_script" 4 [Init, NodeAnn] [] False - , Feature "gossip_queries" 6 [] [] False - , Feature "var_onion_optin" 8 [] [] True - , Feature "gossip_queries_ex" 10 [Init, NodeAnn] [] False - , Feature "option_static_remotekey" 12 [] [] True - , Feature "payment_secret" 14 [] [] True - , Feature "basic_mpp" 16 [Init, NodeAnn, Invoice] - ["payment_secret"] False - , Feature "option_support_large_channel" 18 [Init, NodeAnn] [] False - , Feature "option_anchors" 22 [Init, NodeAnn, ChanType] [] False - , Feature "option_route_blinding" 24 [Init, NodeAnn, Invoice] [] False - , Feature "option_shutdown_anysegwit" 26 [Init, NodeAnn] [] False - , Feature "option_dual_fund" 28 [Init, NodeAnn] [] False - , Feature "option_quiesce" 34 [Init, NodeAnn] [] False - , Feature "option_attribution_data" 36 [Init, NodeAnn, Invoice] - [] False - , Feature "option_onion_messages" 38 [Init, NodeAnn] [] False - , Feature "option_provide_storage" 42 [Init, NodeAnn] [] False - , Feature "option_channel_type" 44 [] [] True - , Feature "option_scid_alias" 46 [Init, NodeAnn, ChanType] [] False - , Feature "option_payment_metadata" 48 [Invoice] [] False - , Feature "option_zeroconf" 50 [Init, NodeAnn, ChanType] - ["option_scid_alias"] False - , Feature "option_simple_close" 60 [Init, NodeAnn] - ["option_shutdown_anysegwit"] False - ] - --- | Look up a feature by bit number. --- --- Accepts either the even (compulsory) or odd (optional) bit of the pair. --- --- >>> fmap featureName (featureByBit 16) --- Just "basic_mpp" --- >>> fmap featureName (featureByBit 17) -- odd bit also works --- Just "basic_mpp" --- >>> featureByBit 999 --- Nothing -featureByBit :: Word16 -> Maybe Feature -featureByBit !bit = - let !baseBit = fromIntegral bit - (fromIntegral bit `mod` 2) - in IM.lookup baseBit featuresByBit -{-# INLINE featureByBit #-} - --- | Look up a feature by its canonical name. --- --- >>> fmap featureBaseBit (featureByName "basic_mpp") --- Just 16 --- >>> featureByName "nonexistent" --- Nothing -featureByName :: String -> Maybe Feature -featureByName !name = M.lookup name featuresByName -{-# INLINE featureByName #-} - --- Lookup tables ------------------------------------------------------------- - --- | Features indexed by base bit (even bit number). -featuresByBit :: IntMap Feature -featuresByBit = IM.fromList - [(fromIntegral (featureBaseBit f), f) | f <- knownFeatures] - --- | Features indexed by canonical name. -featuresByName :: Map String Feature -featuresByName = M.fromList - [(featureName f, f) | f <- knownFeatures] diff --git a/lib/Lightning/Protocol/BOLT9/Types.hs b/lib/Lightning/Protocol/BOLT9/Types.hs deleted file mode 100644 --- a/lib/Lightning/Protocol/BOLT9/Types.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} - --- | --- Module: Lightning.Protocol.BOLT9.Types --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Baseline types for BOLT #9 feature flags. - -module Lightning.Protocol.BOLT9.Types ( - -- * Context - Context(..) - , isChannelContext - , channelParity - - -- * Bit indices - , BitIndex - , unBitIndex - , bitIndex - - -- * Required/optional level - , FeatureLevel(..) - - -- * Required/optional bits - , RequiredBit - , unRequiredBit - , requiredBit - , requiredFromBitIndex - - , OptionalBit - , unOptionalBit - , optionalBit - , optionalFromBitIndex - - -- * Feature vectors - , FeatureVector - , unFeatureVector - , empty - , fromByteString - , set - , clear - , member - ) where - -import Control.DeepSeq (NFData) -import qualified Data.Bits as B -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Word (Word8, Word16) -import GHC.Generics (Generic) - --- Context ------------------------------------------------------------------ - --- | Presentation context for feature flags. --- --- Per BOLT #9, features are presented in different message contexts: --- --- * 'Init' - the @init@ message --- * 'NodeAnn' - @node_announcement@ messages --- * 'ChanAnn' - @channel_announcement@ messages (normal) --- * 'ChanAnnOdd' - @channel_announcement@, always odd (optional) --- * 'ChanAnnEven' - @channel_announcement@, always even (required) --- * 'Invoice' - BOLT 11 invoices --- * 'Blinded' - @allowed_features@ field of a blinded path --- * 'ChanType' - @channel_type@ field when opening channels -data Context - = Init -- ^ I: presented in the @init@ message - | NodeAnn -- ^ N: presented in @node_announcement@ messages - | ChanAnn -- ^ C: presented in @channel_announcement@ message - | ChanAnnOdd -- ^ C-: @channel_announcement@, always odd (optional) - | ChanAnnEven -- ^ C+: @channel_announcement@, always even (required) - | Invoice -- ^ 9: presented in BOLT 11 invoices - | Blinded -- ^ B: @allowed_features@ field of a blinded path - | ChanType -- ^ T: @channel_type@ field when opening channels - deriving (Eq, Ord, Show, Generic) - -instance NFData Context - --- | Check if a context is a channel announcement context (C, C-, or C+). -isChannelContext :: Context -> Bool -isChannelContext ChanAnn = True -isChannelContext ChanAnnOdd = True -isChannelContext ChanAnnEven = True -isChannelContext _ = False -{-# INLINE isChannelContext #-} - --- | For channel contexts with forced parity, return 'Just' the required --- parity: 'True' for even (C+), 'False' for odd (C-). Returns 'Nothing' --- for contexts without forced parity. -channelParity :: Context -> Maybe Bool -channelParity ChanAnnOdd = Just False -- odd -channelParity ChanAnnEven = Just True -- even -channelParity _ = Nothing -{-# INLINE channelParity #-} - --- FeatureLevel ------------------------------------------------------------- - --- | Whether a feature is set as required or optional. --- --- Per BOLT #9, each feature has a pair of bits: the even bit indicates --- required (compulsory) support, the odd bit indicates optional support. -data FeatureLevel - = Required -- ^ The feature is required (even bit set) - | Optional -- ^ The feature is optional (odd bit set) - deriving (Eq, Ord, Show, Generic) - -instance NFData FeatureLevel - --- BitIndex ----------------------------------------------------------------- - --- | A bit index into a feature vector. Bit 0 is the least significant bit. --- --- Valid range: 0-65535 (sufficient for any practical feature flag). -newtype BitIndex = BitIndex { unBitIndex :: Word16 } - deriving (Eq, Ord, Show, Generic) - -instance NFData BitIndex - --- | Smart constructor for 'BitIndex'. Always succeeds since all Word16 --- values are valid. -bitIndex :: Word16 -> BitIndex -bitIndex = BitIndex -{-# INLINE bitIndex #-} - --- RequiredBit -------------------------------------------------------------- - --- | A required (compulsory) feature bit. Required bits are always even. -newtype RequiredBit = RequiredBit { unRequiredBit :: Word16 } - deriving (Eq, Ord, Show, Generic) - -instance NFData RequiredBit - --- | Smart constructor for 'RequiredBit'. Returns 'Nothing' if the bit --- index is odd. --- --- >>> requiredBit 16 --- Just (RequiredBit {unRequiredBit = 16}) --- >>> requiredBit 17 --- Nothing -requiredBit :: Word16 -> Maybe RequiredBit -requiredBit !w - | w B..&. 1 == 0 = Just (RequiredBit w) - | otherwise = Nothing -{-# INLINE requiredBit #-} - --- | Convert a 'BitIndex' to a 'RequiredBit'. Returns 'Nothing' if odd. -requiredFromBitIndex :: BitIndex -> Maybe RequiredBit -requiredFromBitIndex (BitIndex w) = requiredBit w -{-# INLINE requiredFromBitIndex #-} - --- OptionalBit -------------------------------------------------------------- - --- | An optional feature bit. Optional bits are always odd. -newtype OptionalBit = OptionalBit { unOptionalBit :: Word16 } - deriving (Eq, Ord, Show, Generic) - -instance NFData OptionalBit - --- | Smart constructor for 'OptionalBit'. Returns 'Nothing' if the bit --- index is even. --- --- >>> optionalBit 17 --- Just (OptionalBit {unOptionalBit = 17}) --- >>> optionalBit 16 --- Nothing -optionalBit :: Word16 -> Maybe OptionalBit -optionalBit !w - | w B..&. 1 == 1 = Just (OptionalBit w) - | otherwise = Nothing -{-# INLINE optionalBit #-} - --- | Convert a 'BitIndex' to an 'OptionalBit'. Returns 'Nothing' if even. -optionalFromBitIndex :: BitIndex -> Maybe OptionalBit -optionalFromBitIndex (BitIndex w) = optionalBit w -{-# INLINE optionalFromBitIndex #-} - --- FeatureVector ------------------------------------------------------------ - --- | A feature vector represented as a strict ByteString. --- --- The vector is stored in big-endian byte order (most significant byte --- first), with bits numbered from the least significant bit of the last --- byte. Bit 0 is at position 0 of the last byte. -newtype FeatureVector = FeatureVector { unFeatureVector :: ByteString } - deriving (Eq, Ord, Show, Generic) - -instance NFData FeatureVector - --- | The empty feature vector (no features set). --- --- >>> empty --- FeatureVector {unFeatureVector = ""} -empty :: FeatureVector -empty = FeatureVector BS.empty -{-# INLINE empty #-} - --- | Wrap a ByteString as a FeatureVector. -fromByteString :: ByteString -> FeatureVector -fromByteString = FeatureVector -{-# INLINE fromByteString #-} - --- | Set a bit in the feature vector. --- --- >>> set (bitIndex 0) empty --- FeatureVector {unFeatureVector = "\SOH"} --- >>> set (bitIndex 8) empty --- FeatureVector {unFeatureVector = "\SOH\NUL"} -set :: BitIndex -> FeatureVector -> FeatureVector -set (BitIndex idx) (FeatureVector bs) = - let byteIdx = fromIntegral idx `div` 8 - bitOffset = fromIntegral idx `mod` 8 - len = BS.length bs - -- Number of bytes needed to hold this bit - needed = byteIdx + 1 - -- Pad with zeros if necessary (prepend to maintain big-endian) - bs' = if needed > len - then BS.replicate (needed - len) 0 <> bs - else bs - len' = BS.length bs' - -- Index from the end (big-endian: last byte has lowest bits) - realIdx = len' - 1 - byteIdx - oldByte = BS.index bs' realIdx - newByte = oldByte B..|. B.shiftL 1 bitOffset - in FeatureVector (updateByteAt realIdx newByte bs') -{-# INLINE set #-} - --- | Clear a bit in the feature vector. -clear :: BitIndex -> FeatureVector -> FeatureVector -clear (BitIndex idx) (FeatureVector bs) - | BS.null bs = FeatureVector bs - | otherwise = - let byteIdx = fromIntegral idx `div` 8 - bitOffset = fromIntegral idx `mod` 8 - len = BS.length bs - in if byteIdx >= len - then FeatureVector bs -- bit not in range, already clear - else - let realIdx = len - 1 - byteIdx - oldByte = BS.index bs realIdx - newByte = oldByte B..&. B.complement (B.shiftL 1 bitOffset) - in FeatureVector (stripLeadingZeros (updateByteAt realIdx newByte bs)) -{-# INLINE clear #-} - --- | Test if a bit is set in the feature vector. --- --- >>> member (bitIndex 0) (set (bitIndex 0) empty) --- True --- >>> member (bitIndex 1) (set (bitIndex 0) empty) --- False -member :: BitIndex -> FeatureVector -> Bool -member (BitIndex idx) (FeatureVector bs) - | BS.null bs = False - | otherwise = - let byteIdx = fromIntegral idx `div` 8 - bitOffset = fromIntegral idx `mod` 8 - len = BS.length bs - in if byteIdx >= len - then False - else - let realIdx = len - 1 - byteIdx - byte = BS.index bs realIdx - in byte B..&. B.shiftL 1 bitOffset /= 0 -{-# INLINE member #-} - --- Internal helpers --------------------------------------------------------- - --- | Update a single byte at the given index. -updateByteAt :: Int -> Word8 -> ByteString -> ByteString -updateByteAt !i !w !bs = - let (before, after) = BS.splitAt i bs - in case BS.uncons after of - Nothing -> bs -- shouldn't happen if i is valid - Just (_, rest) -> before <> BS.singleton w <> rest -{-# INLINE updateByteAt #-} - --- | Remove leading zero bytes from a ByteString. -stripLeadingZeros :: ByteString -> ByteString -stripLeadingZeros = BS.dropWhile (== 0) -{-# INLINE stripLeadingZeros #-} diff --git a/lib/Lightning/Protocol/BOLT9/Validate.hs b/lib/Lightning/Protocol/BOLT9/Validate.hs deleted file mode 100644 --- a/lib/Lightning/Protocol/BOLT9/Validate.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} - --- | --- Module: Lightning.Protocol.BOLT9.Validate --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Validation for BOLT #9 feature vectors. - -module Lightning.Protocol.BOLT9.Validate ( - -- * Error types - ValidationError(..) - - -- * Local validation - , validateLocal - - -- * Remote validation - , validateRemote - - -- * Helpers - , highestSetBit - , setBits - ) where - -import Control.DeepSeq (NFData) -import Data.ByteString (ByteString) -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.Features -import Lightning.Protocol.BOLT9.Types - --- | Validation errors for feature vectors. -data ValidationError - = BothBitsSet {-# UNPACK #-} !Word16 !String - -- ^ Both optional and required bits are set for a feature. - -- Arguments: base bit index, feature name. - | MissingDependency !String !String - -- ^ A feature's dependency is not set. - -- Arguments: feature name, missing dependency name. - | ContextNotAllowed !String !Context - -- ^ A feature is not allowed in the given context. - -- Arguments: feature name, context. - | UnknownRequiredBit {-# UNPACK #-} !Word16 - -- ^ An unknown required (even) bit is set (remote validation only). - -- Argument: bit index. - | InvalidParity {-# UNPACK #-} !Word16 !Context - -- ^ A bit has invalid parity for a channel context. - -- Arguments: bit index, context (ChanAnnOdd or ChanAnnEven). - deriving (Eq, Show, Generic) - -instance NFData ValidationError - --- Local validation ----------------------------------------------------------- - --- | Validate a feature vector for local use (vectors we create/send). --- --- Checks: --- --- * No feature has both optional and required bits set --- * All set features are valid for the given context --- * All dependencies of set features are also set --- * C- context forces odd bits only, C+ forces even bits only --- --- >>> import Data.Maybe (fromJust) --- >>> import Lightning.Protocol.BOLT9.Codec (setFeature) --- >>> let mpp = fromJust (featureByName "basic_mpp") --- >>> let ps = fromJust (featureByName "payment_secret") --- >>> validateLocal Init (setFeature mpp False empty) --- Left [MissingDependency "basic_mpp" "payment_secret"] --- >>> validateLocal Init (setFeature mpp False (setFeature ps False empty)) --- Right () -validateLocal :: Context -> FeatureVector -> Either [ValidationError] () -validateLocal !ctx !fv = - let errs = bothBitsErrors fv - ++ contextErrors ctx fv - ++ dependencyErrors fv - ++ parityErrors ctx fv - in if null errs - then Right () - else Left errs - --- | Check for features with both bits set. -bothBitsErrors :: FeatureVector -> [ValidationError] -bothBitsErrors !fv = foldr check [] knownFeatures - where - check !f !acc = - let !baseBit = featureBaseBit f - in if testBit baseBit fv && testBit (baseBit + 1) fv - then BothBitsSet baseBit (featureName f) : acc - else acc - --- | Check for features not allowed in the given context. -contextErrors :: Context -> FeatureVector -> [ValidationError] -contextErrors !ctx !fv = foldr check [] knownFeatures - where - check !f !acc = - let !contexts = featureContexts f - in if isFeatureSet f fv - && not (null contexts) - && not (contextAllowed ctx contexts) - then ContextNotAllowed (featureName f) ctx : acc - else acc - --- | Check if a context is allowed given a list of allowed contexts. -contextAllowed :: Context -> [Context] -> Bool -contextAllowed !ctx !allowed = ctx `elem` allowed || channelMatch - where - channelMatch = isChannelContext ctx && any isChannelContext allowed - --- | Check for missing dependencies. -dependencyErrors :: FeatureVector -> [ValidationError] -dependencyErrors !fv = foldr check [] knownFeatures - where - check !f !acc = - if isFeatureSet f fv - then checkDeps f (featureDependencies f) ++ acc - else acc - - checkDeps !f = foldr (checkOneDep f) [] - - checkOneDep !f !depName !acc = - case featureByName depName of - Nothing -> acc -- unknown dep, skip - Just !dep -> - if isFeatureSet dep fv - then acc - else MissingDependency (featureName f) depName : acc - --- | Check for parity errors in C- and C+ contexts. -parityErrors :: Context -> FeatureVector -> [ValidationError] -parityErrors !ctx !fv = case channelParity ctx of - Nothing -> [] - Just wantEven -> foldr (checkParity wantEven) [] (setBits fv) - where - checkParity !wantEven !bit !acc = - let isEven = bit `mod` 2 == 0 - in if isEven /= wantEven - then InvalidParity bit ctx : acc - else acc - --- Remote validation ---------------------------------------------------------- - --- | Validate a feature vector received from a remote peer. --- --- Checks: --- --- * Unknown odd (optional) bits are acceptable (ignored) --- * Unknown even (required) bits are errors --- * If both bits of a pair are set, treat as required (not an error) --- * Context restrictions still apply for known features --- --- >>> import Lightning.Protocol.BOLT9.Codec (setBit) --- >>> validateRemote Init (setBit 999 empty) -- unknown odd bit: ok --- Right () --- >>> validateRemote Init (setBit 998 empty) -- unknown even bit: error --- Left [UnknownRequiredBit 998] -validateRemote :: Context -> FeatureVector -> Either [ValidationError] () -validateRemote !ctx !fv = - let errs = unknownRequiredErrors fv - ++ contextErrors ctx fv - ++ parityErrors ctx fv - in if null errs - then Right () - else Left errs - --- | Check for unknown required bits. -unknownRequiredErrors :: FeatureVector -> [ValidationError] -unknownRequiredErrors !fv = foldr check [] (setBits fv) - where - check !bit !acc - | bit `mod` 2 == 1 = acc -- odd bit, optional, ignore - | otherwise = case featureByBit bit of - Just _ -> acc -- known feature - Nothing -> UnknownRequiredBit bit : acc - --- Helpers -------------------------------------------------------------------- - --- | Find the highest set bit in a feature vector. --- --- Returns 'Nothing' if the vector is empty or has no bits set. -highestSetBit :: FeatureVector -> Maybe Word16 -highestSetBit !fv = - let !bs = unFeatureVector fv - in if BS.null bs - then Nothing - else findHighestBit bs - --- | Find the highest set bit in a non-empty ByteString. -findHighestBit :: ByteString -> Maybe Word16 -findHighestBit !bs = go 0 - where - !len = BS.length bs - - go !i - | i >= len = Nothing - | otherwise = - let !byte = BS.index bs i - in if byte == 0 - then go (i + 1) - else - let !bytePos = len - 1 - i - !highBit = 7 - B.countLeadingZeros byte - !bitIdx = fromIntegral bytePos * 8 + fromIntegral highBit - in Just bitIdx - --- | Collect all set bits in a feature vector. --- --- Returns a list of bit indices in ascending order. -setBits :: FeatureVector -> [Word16] -setBits !fv = - let !bs = unFeatureVector fv - !len = BS.length bs - in collectBits bs len 0 [] - --- | Collect bits from a ByteString into a list. -collectBits :: ByteString -> Int -> Int -> [Word16] -> [Word16] -collectBits !bs !len !i !acc - | i >= len = acc - | otherwise = - let !byte = BS.index bs (len - 1 - i) - !baseIdx = fromIntegral i * 8 - !acc' = collectByteBits byte baseIdx acc - in collectBits bs len (i + 1) acc' - --- | Collect set bits from a single byte. -collectByteBits :: B.Bits a => a -> Word16 -> [Word16] -> [Word16] -collectByteBits !byte !baseIdx = go 7 - where - go !bit !acc - | bit < 0 = acc - | B.testBit byte bit = go (bit - 1) ((baseIdx + fromIntegral bit) : acc) - | otherwise = go (bit - 1) acc diff --git a/ppad-bolt9.cabal b/ppad-bolt9.cabal --- a/ppad-bolt9.cabal +++ b/ppad-bolt9.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-bolt9 -version: 0.0.1 +version: 0.1.0 synopsis: Feature flags per BOLT #9 license: MIT license-file: LICENSE @@ -8,11 +8,15 @@ maintainer: jared@ppad.tech category: Cryptography build-type: Simple -tested-with: GHC == 9.10.3 +tested-with: GHC == { 9.10.3 } extra-doc-files: CHANGELOG description: - Feature flags, per + Lightning Network feature flags, per [BOLT #9](https://github.com/lightning/bolts/blob/master/09-features.md). + Provides an abstract feature vector type that preserves its wire + bytes, the table of known features with their contexts and + dependencies, sender- and receiver-side validation for each context, + and BOLT #2 channel types. source-repository head type: git @@ -25,14 +29,9 @@ -Wall exposed-modules: Lightning.Protocol.BOLT9 - Lightning.Protocol.BOLT9.Codec - Lightning.Protocol.BOLT9.Features - Lightning.Protocol.BOLT9.Types - Lightning.Protocol.BOLT9.Validate build-depends: base >= 4.9 && < 5 , bytestring >= 0.9 && < 0.13 - , containers >= 0.6 && < 0.9 , deepseq >= 1.4 && < 1.6 test-suite bolt9-tests @@ -42,7 +41,7 @@ main-is: Main.hs ghc-options: - -rtsopts -Wall -O2 + -rtsopts -Wall build-depends: base @@ -60,7 +59,7 @@ other-modules: Fixtures ghc-options: - -rtsopts -O2 -Wall -fno-warn-orphans + -rtsopts -O2 -Wall build-depends: base @@ -77,7 +76,7 @@ other-modules: Fixtures ghc-options: - -rtsopts -O2 -Wall -fno-warn-orphans + -rtsopts -O2 -Wall build-depends: base diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,287 +1,564 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Main where +import qualified Data.Bits as B +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Maybe (isJust, isNothing) -import Data.Word (Word16) +import Data.List (elemIndex, subsequences) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Word (Word8) import Lightning.Protocol.BOLT9 import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck main :: IO () -main = defaultMain tests +main = defaultMain $ testGroup "ppad-bolt9" [ + table_tests + , vector_tests + , feature_tests + , local_tests + , remote_tests + , invoice_tests + , blinded_tests + , channel_type_tests + , properties + ] -tests :: TestTree -tests = testGroup "ppad-bolt9" [ - featureTableTests - , bitParityTests - , featureVectorTests - , validationTests - , propertyTests +-- feature table ------------------------------------------------------------- + +-- | The BOLT #9 table at lightning/bolts@1aadb719: bits, name, whether +-- it is ASSUMED, the Context column, and the dependency names. +spec_table :: [(Int, String, Bool, String, [String])] +spec_table = [ + (0, "option_data_loss_protect", True, "", []) + , (4, "option_upfront_shutdown_script", False, "IN", []) + , (6, "gossip_queries", False, "", []) + , (8, "var_onion_optin", True, "", []) + , (10, "gossip_queries_ex", False, "IN", []) + , (12, "option_static_remotekey", True, "", []) + , (14, "payment_secret", True, "", []) + , (16, "basic_mpp", False, "IN9", ["payment_secret"]) + , (18, "option_support_large_channel", False, "IN", []) + , (22, "option_anchors", False, "INT", []) + , (24, "option_route_blinding", False, "IN9", []) + , (26, "option_shutdown_anysegwit", False, "IN", []) + , (28, "option_dual_fund", False, "IN", []) + , (34, "option_quiesce", False, "IN", []) + , (36, "option_attribution_data", False, "IN9", []) + , (38, "option_onion_messages", False, "IN", []) + , (40, "zero_fee_commitments", False, "IN", ["option_channel_type"]) + , (42, "option_provide_storage", False, "IN", []) + , (44, "option_channel_type", True, "", []) + , (46, "option_scid_alias", False, "INT", []) + , (48, "option_payment_metadata", False, "9", []) + , (50, "option_zeroconf", False, "INT", ["option_scid_alias"]) + , (60, "option_simple_close", False, "IN" + , ["option_shutdown_anysegwit"]) + , (62, "option_splice", False, "IN", []) + , (66, "option_onion_messages_only_channels", False, "IN" + , ["option_onion_messages"]) ] --- Feature table tests --------------------------------------------------------- +table_row :: Feature -> (Int, String, Bool, String, [String]) +table_row f = + ( feature_bit f + , feature_name f + , feature_assumed f + , concatMap letter (feature_contexts f) + , fmap feature_name (feature_dependencies f) ) + where + letter c = case c of + InitContext -> "I" + NodeContext -> "N" + ChannelContext -> "C" + InvoiceContext -> "9" + BlindedContext -> "B" + ChannelTypeContext -> "T" -featureTableTests :: TestTree -featureTableTests = testGroup "Feature table" [ - testCase "all features have even baseBit" $ - all (even . featureBaseBit) knownFeatures @?= True +table_tests :: TestTree +table_tests = testGroup "feature table" [ + testCase "matches the spec table" $ + fmap table_row known_features @?= spec_table - , testCase "featureByBit works for even bit" $ - case featureByBit 14 of - Nothing -> assertFailure "expected to find payment_secret" - Just f -> featureName f @?= "payment_secret" + , testCase "feature_by_bit maps both bits to the feature" $ + mapM_ (\f -> do + feature_by_bit (feature_bit f) @?= Just f + feature_by_bit (feature_bit f + 1) @?= Just f) + known_features - , testCase "featureByBit works for odd bit" $ - case featureByBit 15 of - Nothing -> assertFailure "expected to find payment_secret" - Just f -> featureName f @?= "payment_secret" + , testCase "feature_by_bit rejects unassigned bits" $ do + let assigned = concatMap (\f -> [feature_bit f, feature_bit f + 1]) + known_features + free = filter (`notElem` assigned) [0 .. 600] + mapM_ (\i -> feature_by_bit i @?= Nothing) free + feature_by_bit (-1) @?= Nothing + feature_by_bit (-2) @?= Nothing + ] - , testCase "featureByBit returns Nothing for unknown bit" $ - featureByBit 100 @?= Nothing +-- feature vectors ----------------------------------------------------------- - , testCase "featureByName finds known features" $ do - isJust (featureByName "var_onion_optin") @?= True - isJust (featureByName "payment_secret") @?= True - isJust (featureByName "basic_mpp") @?= True +-- | A vector of (n + 1) bytes whose most significant byte is b. +long_vector :: Int -> Word8 -> FeatureVector +long_vector n b = parse (BS.cons b (BS.replicate n 0)) - , testCase "featureByName returns Nothing for unknown names" $ - featureByName "nonexistent_feature" @?= Nothing +vector_tests :: TestTree +vector_tests = testGroup "feature vectors" [ + testCase "empty" $ do + render empty @?= "" + set_bits empty @?= [] - , testCase "assumed features are present" $ do - let assumedNames = [ "option_data_loss_protect" - , "var_onion_optin" - , "option_static_remotekey" - , "payment_secret" - , "option_channel_type" - ] - mapM_ (\n -> isJust (featureByName n) @? - ("assumed feature missing: " ++ n)) assumedNames + , testCase "render returns parsed bytes exactly" $ do + render (parse "\NUL\NUL\STX") @?= "\NUL\NUL\STX" + render (parse "\NUL") @?= "\NUL" - , testCase "assumed features are marked as assumed" $ do - let checkAssumed n = case featureByName n of - Nothing -> assertFailure $ "feature not found: " ++ n - Just f -> featureAssumed f @?= True - mapM_ checkAssumed [ "option_data_loss_protect" - , "var_onion_optin" - , "option_static_remotekey" - , "payment_secret" - , "option_channel_type" - ] + , testCase "equality ignores leading zero bytes" $ do + parse "\NUL\STX" @?= parse "\STX" + parse "\NUL\NUL" @?= empty + assertBool "distinct" (parse "\STX" /= parse "\SOH") + assertBool "distinct" (parse "\SOH\NUL" /= parse "\SOH") + + , testCase "show" $ + show (parse "\NUL\STX") @?= "parse \"\\NUL\\STX\"" + + , testCase "bit numbering" $ do + render (set_bit 0 empty) @?= "\SOH" + render (set_bit 7 empty) @?= "\128" + render (set_bit 8 empty) @?= "\SOH\NUL" + render (set_bit 17 empty) @?= "\STX\NUL\NUL" + set_bits (parse "\128\NUL\SOH") @?= [0, 23] + + , testCase "operations encode minimally" $ do + render (set_bit 1 (parse "\NUL\NUL\SOH")) @?= "\ETX" + render (clear_bit 0 (parse "\NUL\SOH\SOH")) @?= "\SOH\NUL" + render (clear_bit 8 (parse "\SOH\SOH")) @?= "\SOH" + render (union (parse "\NUL\NUL") empty) @?= "" + + , testCase "union" $ do + union (parse "\SOH\NUL") (parse "\STX") @?= parse "\SOH\STX" + union (parse "\STX") empty @?= parse "\STX" + set_bits (union (parse "\SOH\SOH") (parse "\128\SOH")) @?= [0, 8, 15] + + , testCase "negative indices are ignored" $ do + set_bit (-1) (parse "\STX") @?= parse "\STX" + clear_bit (-1) (parse "\STX") @?= parse "\STX" + test_bit (-1) (parse "\255") @?= False + + , testCase "clearing a bit beyond the vector is a no-op" $ + render (clear_bit 1000 (parse "\STX")) @?= "\STX" + + , testCase "bit 65536 does not wrap" $ do + let fv = long_vector 8192 0x01 + set_bits fv @?= [65536] + test_bit 65536 fv @?= True + test_bit 0 fv @?= False + + , testCase "bits of a maximum-length vector" $ do + let fv = long_vector 65534 0x80 + BS.length (render fv) @?= 65535 + set_bits fv @?= [524279] + set_bit 524279 empty @?= fv + clear_bit 524279 fv @?= empty ] --- Bit parity tests ------------------------------------------------------------ +-- feature operations -------------------------------------------------------- -bitParityTests :: TestTree -bitParityTests = testGroup "Bit parity" [ - testCase "requiredBit accepts even numbers" $ do - isJust (requiredBit 0) @?= True - isJust (requiredBit 2) @?= True - isJust (requiredBit 100) @?= True +feature_tests :: TestTree +feature_tests = testGroup "feature operations" [ + testCase "set_feature sets the bit for its level" $ do + set_bits (set_feature BasicMpp Required empty) @?= [16] + set_bits (set_feature BasicMpp Optional empty) @?= [17] - , testCase "requiredBit rejects odd numbers" $ do - isNothing (requiredBit 1) @?= True - isNothing (requiredBit 3) @?= True - isNothing (requiredBit 101) @?= True + , testCase "set_feature clears the other bit" $ do + set_bits (set_feature PaymentSecret Optional (set_bit 14 empty)) + @?= [15] + set_bits (set_feature PaymentSecret Required (set_bit 15 empty)) + @?= [14] - , testCase "optionalBit accepts odd numbers" $ do - isJust (optionalBit 1) @?= True - isJust (optionalBit 3) @?= True - isJust (optionalBit 101) @?= True + , testCase "set_feature leaves other features alone" $ + set_bits (set_feature BasicMpp Optional (parse "\STX\NUL")) + @?= [9, 17] - , testCase "optionalBit rejects even numbers" $ do - isNothing (optionalBit 0) @?= True - isNothing (optionalBit 2) @?= True - isNothing (optionalBit 100) @?= True + , testCase "clear_feature clears both bits" $ do + clear_feature BasicMpp (set_bit 16 (set_bit 17 empty)) @?= empty + clear_feature BasicMpp (set_bit 9 (set_bit 17 empty)) + @?= set_bit 9 empty - , testCase "requiredBit smart constructor preserves value" $ - case requiredBit 42 of - Nothing -> assertFailure "expected Just" - Just rb -> unRequiredBit rb @?= 42 + , testCase "test_feature" $ do + test_feature BasicMpp (set_bit 16 empty) @?= Just Required + test_feature BasicMpp (set_bit 17 empty) @?= Just Optional + test_feature BasicMpp (set_bit 16 (set_bit 17 empty)) + @?= Just Required + test_feature BasicMpp (set_bit 18 empty) @?= Nothing - , testCase "optionalBit smart constructor preserves value" $ - case optionalBit 43 of - Nothing -> assertFailure "expected Just" - Just ob -> unOptionalBit ob @?= 43 + , testCase "list_features is in bit order and skips unknown bits" $ + list_features (set_bit 100 (set_bit 51 (set_bit 46 (set_bit 15 empty)))) + @?= [ (PaymentSecret, Optional), (OptionScidAlias, Required) + , (OptionZeroconf, Optional) ] + + , testCase "set_feature_with_deps sets dependencies" $ do + list_features (set_feature_with_deps OptionZeroconf Required empty) + @?= [(OptionScidAlias, Required), (OptionZeroconf, Required)] + list_features (set_feature_with_deps ZeroFeeCommitments Optional empty) + @?= [(ZeroFeeCommitments, Optional), (OptionChannelType, Optional)] + + , testCase "set_feature_with_deps keeps a set dependency's level" $ + list_features + (set_feature_with_deps OptionSimpleClose Optional + (set_feature OptionShutdownAnysegwit Required empty)) + @?= [ (OptionShutdownAnysegwit, Required) + , (OptionSimpleClose, Optional) ] ] --- FeatureVector tests --------------------------------------------------------- +-- local validation ---------------------------------------------------------- -featureVectorTests :: TestTree -featureVectorTests = testGroup "FeatureVector" [ - testCase "empty has no bits set" $ do - unFeatureVector empty @?= BS.empty - member (bitIndex 0) empty @?= False - member (bitIndex 100) empty @?= False +-- | A vector with the given bits set. +bits :: [Int] -> FeatureVector +bits = foldr set_bit empty - , testCase "set adds a bit" $ do - let fv = set (bitIndex 0) empty - member (bitIndex 0) fv @?= True +contexts :: [Context] +contexts = + [ InitContext, NodeContext, ChannelContext, InvoiceContext + , BlindedContext, ChannelTypeContext ] - , testCase "set multiple bits" $ do - let fv = set (bitIndex 8) (set (bitIndex 0) empty) - member (bitIndex 0) fv @?= True - member (bitIndex 8) fv @?= True - member (bitIndex 1) fv @?= False +local_tests :: TestTree +local_tests = testGroup "validate_local" [ + testCase "empty is valid in every context but channel_type" $ do + mapM_ (\c -> validate_local c empty @?= Right ()) + (filter (/= ChannelTypeContext) contexts) + validate_local ChannelTypeContext empty + @?= Left (InvalidChannelType :| []) - , testCase "clear removes a bit" $ do - let fv = set (bitIndex 5) empty - fv' = clear (bitIndex 5) fv - member (bitIndex 5) fv @?= True - member (bitIndex 5) fv' @?= False + , testCase "rejects unknown bits, odd or even" $ do + validate_local InitContext (bits [20, 101]) + @?= Left (UnknownBit 20 :| [UnknownBit 101]) + validate_local NodeContext (bits [200]) @?= Left (UnknownBit 200 :| []) - , testCase "clear on unset bit is no-op" $ do - let fv = clear (bitIndex 10) empty - unFeatureVector fv @?= BS.empty + , testCase "rejects both bits set" $ + validate_local InitContext (bits [46, 47]) + @?= Left (BothBitsSet OptionScidAlias :| []) - , testCase "member returns False for unset bits" $ do - let fv = set (bitIndex 4) empty - member (bitIndex 0) fv @?= False - member (bitIndex 1) fv @?= False - member (bitIndex 5) fv @?= False + , testCase "rejects features outside their contexts" $ do + validate_local InitContext (bits [49]) + @?= Left (ContextNotAllowed OptionPaymentMetadata InitContext :| []) + validate_local InvoiceContext (bits [23]) + @?= Left (ContextNotAllowed OptionAnchors InvoiceContext :| []) + validate_local ChannelContext (bits [17, 15]) + @?= Left (ContextNotAllowed PaymentSecret ChannelContext + :| [ContextNotAllowed BasicMpp ChannelContext]) - , testCase "render strips leading zeros" $ do - let fv = set (bitIndex 0) empty - render fv @?= BS.pack [0x01] + , testCase "accepts features in their contexts" $ do + validate_local InvoiceContext (bits [49]) @?= Right () + validate_local NodeContext (bits [23, 47]) @?= Right () + validate_local InitContext (bits [63, 67, 39]) @?= Right () - , testCase "render handles high bits correctly" $ do - let fv = set (bitIndex 15) empty - render fv @?= BS.pack [0x80, 0x00] + , testCase "empty-context features: accepted in I, N and 9 only" $ do + let fv = bits [1, 7, 9, 13, 15, 45] + mapM_ (\c -> validate_local c fv @?= Right ()) + [InitContext, NodeContext, InvoiceContext] + validate_local ChannelContext (bits [9]) + @?= Left (ContextNotAllowed VarOnionOptin ChannelContext :| []) + validate_local BlindedContext (bits [15]) + @?= Left (ContextNotAllowed PaymentSecret BlindedContext :| []) - , testCase "render of empty is empty" $ - render empty @?= BS.empty + , testCase "allowed_features must be empty" $ + validate_local BlindedContext (bits [17]) + @?= Left (ContextNotAllowed BasicMpp BlindedContext :| []) + + , testCase "rejects missing dependencies" $ do + validate_local InitContext (bits [51]) + @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| []) + validate_local InitContext (bits [61]) + @?= Left (MissingDependency OptionSimpleClose + OptionShutdownAnysegwit :| []) + validate_local NodeContext (bits [67]) + @?= Left (MissingDependency OptionOnionMessagesOnlyChannels + OptionOnionMessages :| []) + + , testCase "dependencies on ASSUMED features count as met" $ do + validate_local InitContext (bits [17]) @?= Right () + validate_local InvoiceContext (bits [16]) @?= Right () + validate_local InitContext (bits [41]) @?= Right () + + , testCase "reports errors in rule order" $ + validate_local InitContext (bits [20, 22, 23, 48, 61]) + @?= Left (UnknownBit 20 :| + [ BothBitsSet OptionAnchors + , ContextNotAllowed OptionPaymentMetadata InitContext + , MissingDependency OptionSimpleClose + OptionShutdownAnysegwit ]) + + , testCase "channel_type follows BOLT #2, not the generic rules" $ do + validate_local ChannelTypeContext (bits [12, 50]) @?= Right () + validate_local ChannelTypeContext (bits [12, 23]) + @?= Left (InvalidChannelType :| []) ] --- Validation tests ------------------------------------------------------------ +-- remote validation --------------------------------------------------------- -validationTests :: TestTree -validationTests = testGroup "Validation" [ - testCase "BothBitsSet error when both bits of a pair are set" $ do - let baseBit = 14 -- payment_secret - fv = setBit (baseBit + 1) (setBit baseBit empty) - case validateLocal Init fv of - Right () -> assertFailure "expected BothBitsSet error" - Left errs -> any isBothBitsSet errs @?= True +remote_tests :: TestTree +remote_tests = testGroup "validate_remote" [ + testCase "init: unknown odd bits are ignored" $ + validate_remote InitContext (bits [101, 201]) @?= Right () - , testCase "MissingDependency error when dep not set" $ do - -- basic_mpp (16) depends on payment_secret (14) - case featureByName "basic_mpp" of - Nothing -> assertFailure "basic_mpp not found" - Just f -> do - let fv = setBit (featureBaseBit f) empty - case validateLocal Init fv of - Right () -> assertFailure "expected MissingDependency error" - Left errs -> any isMissingDependency errs @?= True + , testCase "init: unknown even bits are rejected" $ + validate_remote InitContext (bits [20, 100, 101]) + @?= Left (UnknownBit 20 :| [UnknownBit 100]) - , testCase "ContextNotAllowed error for wrong context" $ do - -- option_payment_metadata (48) is only allowed in Invoice context - case featureByName "option_payment_metadata" of - Nothing -> assertFailure "option_payment_metadata not found" - Just f -> do - let fv = setBit (featureBaseBit f) empty - case validateLocal Init fv of - Right () -> assertFailure "expected ContextNotAllowed error" - Left errs -> any isContextNotAllowed errs @?= True + , testCase "init: missing dependencies are rejected" $ do + validate_remote InitContext (bits [51]) + @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| []) + validate_remote InitContext (bits [60]) + @?= Left (MissingDependency OptionSimpleClose + OptionShutdownAnysegwit :| []) + validate_remote InitContext (bits [51, 47]) @?= Right () - , testCase "Remote validation accepts unknown optional bits" $ do - -- bit 201 is unknown and odd (optional) - let fv = setBit 201 empty - validateRemote Init fv @?= Right () + , testCase "init: ASSUMED dependencies count as met" $ do + validate_remote InitContext (bits [17]) @?= Right () + validate_remote InitContext (bits [40]) @?= Right () - , testCase "Remote validation rejects unknown required bits" $ do - -- bit 200 is unknown and even (required) - let fv = setBit 200 empty - case validateRemote Init fv of - Right () -> assertFailure "expected UnknownRequiredBit error" - Left errs -> any isUnknownRequiredBit errs @?= True + , testCase "init: both bits set is not an error" $ + validate_remote InitContext (bits [46, 47]) @?= Right () - , testCase "Valid local vector passes validation" $ do - -- payment_secret (14) with its required bit set - case featureByName "payment_secret" of - Nothing -> assertFailure "payment_secret not found" - Just f -> do - let fv = setBit (featureBaseBit f) empty - validateLocal Init fv @?= Right () + , testCase "init: known features outside their contexts pass" $ + validate_remote InitContext (bits [49]) @?= Right () - , testCase "Valid feature with dependency passes" $ do - -- basic_mpp (16) with payment_secret (14) dependency set - case (featureByName "basic_mpp", featureByName "payment_secret") of - (Just mpp, Just ps) -> do - let fv = setBit (featureBaseBit mpp) - $ setBit (featureBaseBit ps) empty - validateLocal Init fv @?= Right () - _ -> assertFailure "features not found" + , testCase "node and channel announcements: unknown even bits" $ do + validate_remote NodeContext (bits [100]) + @?= Left (UnknownBit 100 :| []) + validate_remote ChannelContext (bits [100]) + @?= Left (UnknownBit 100 :| []) + validate_remote NodeContext (bits [101]) @?= Right () + validate_remote ChannelContext (bits [101]) @?= Right () + + , testCase "node and channel announcements: no dependency rule" $ do + validate_remote NodeContext (bits [51]) @?= Right () + validate_remote ChannelContext (bits [51]) @?= Right () + + , testCase "invoice: unknown even bits and dependencies" $ do + validate_remote InvoiceContext (bits [100]) + @?= Left (UnknownBit 100 :| []) + validate_remote InvoiceContext (bits [51]) + @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| []) + validate_remote InvoiceContext (bits [101, 17]) @?= Right () + + , testCase "blinded path: any unknown bit is rejected" $ do + validate_remote BlindedContext (bits [101]) + @?= Left (UnknownBit 101 :| []) + validate_remote BlindedContext (bits [100]) + @?= Left (UnknownBit 100 :| []) + validate_remote BlindedContext (bits [15, 17]) @?= Right () + validate_remote BlindedContext empty @?= Right () + + , testCase "channel_type: must be a defined type" $ do + validate_remote ChannelTypeContext (bits [12, 22]) @?= Right () + validate_remote ChannelTypeContext (bits [22]) + @?= Left (InvalidChannelType :| []) + + , testCase "bits above 65535 do not wrap" $ do + validate_remote InitContext (long_vector 8192 0x01) + @?= Left (UnknownBit 65536 :| []) + validate_remote InitContext (long_vector 8192 0x04) + @?= Left (UnknownBit 65538 :| []) + validate_remote InitContext (long_vector 8194 0x01) + @?= Left (UnknownBit 65552 :| []) + + , testCase "maximum-length vectors" $ do + validate_remote InitContext (long_vector 65534 0x80) @?= Right () + validate_remote InitContext (long_vector 65534 0x40) + @?= Left (UnknownBit 524278 :| []) ] -isBothBitsSet :: ValidationError -> Bool -isBothBitsSet (BothBitsSet _ _) = True -isBothBitsSet _ = False +-- BOLT #11 vectors ---------------------------------------------------------- -isMissingDependency :: ValidationError -> Bool -isMissingDependency (MissingDependency _ _) = True -isMissingDependency _ = False +-- | The feature vector carried by a BOLT #11 @9@ field, given the +-- field's data as bech32 characters. +invoice_features :: String -> Maybe FeatureVector +invoice_features cs = do + vs <- traverse (`elemIndex` charset) cs + let n = length vs + pure $ bits + [ (n - 1 - k) * 5 + j + | (k, v) <- zip [0 ..] vs, j <- [0 .. 4], B.testBit v j ] + where + charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" -isContextNotAllowed :: ValidationError -> Bool -isContextNotAllowed (ContextNotAllowed _ _) = True -isContextNotAllowed _ = False +invoice_case + :: String -> String -> [Int] + -> Either (NonEmpty ValidationError) () -> TestTree +invoice_case name dat expected result = testCase name $ + case invoice_features dat of + Nothing -> assertFailure "invalid bech32 data" + Just fv -> do + set_bits fv @?= expected + validate_remote InvoiceContext fv @?= result -isUnknownRequiredBit :: ValidationError -> Bool -isUnknownRequiredBit (UnknownRequiredBit _) = True -isUnknownRequiredBit _ = False +invoice_tests :: TestTree +invoice_tests = testGroup "BOLT #11 invoice features" [ + invoice_case "features 8, 14 and 99" "sqqqqqqqqqqqqqqqqsgq" + [8, 14, 99] (Right ()) + , invoice_case "payment metadata (8, 14, 48)" "gqqqqqqsgq" + [8, 14, 48] (Right ()) + , invoice_case "high-S signature example (8, 14)" "sgq" + [8, 14] (Right ()) + , invoice_case "invalid unknown feature 100" "psqqqqqqqqqqqqqqqqsgq" + [8, 14, 99, 100] (Left (UnknownBit 100 :| [])) + , testCase "a writer may set 8, 14 and 48" $ + validate_local InvoiceContext (bits [8, 14, 48]) @?= Right () + ] --- Property tests -------------------------------------------------------------- +-- BOLT #4 vectors ----------------------------------------------------------- -propertyTests :: TestTree -propertyTests = testGroup "Properties" [ - testProperty "render . parse == id for stripped ByteStrings" $ - \bs -> let stripped = BS.dropWhile (== 0) (BS.pack bs) - in render (parse stripped) === stripped +-- | allowed_features from bolt04/route-blinding-test.json. +blinded_tests :: TestTree +blinded_tests = testGroup "BOLT #4 allowed_features" [ + testCase "features [] (Bob, Carol, Dave)" $ do + set_bits (parse "") @?= [] + validate_remote BlindedContext (parse "") @?= Right () - , testProperty "set then member returns True" $ - \(Small n) -> let idx = bitIndex (n `mod` 256) - fv = set idx empty - in member idx fv === True + , testCase "features [113] (Eve)" $ do + let fv = parse (BS.pack (0x02 : replicate 14 0)) + set_bits fv @?= [113] + validate_remote BlindedContext fv @?= Left (UnknownBit 113 :| []) + validate_local BlindedContext fv @?= Left (UnknownBit 113 :| []) + ] - , testProperty "clear then member returns False" $ - \(Small n) -> let idx = bitIndex (n `mod` 256) - fv = set idx empty - fv' = clear idx fv - in member idx fv' === False +-- channel types ------------------------------------------------------------- - , testProperty "setBits returns all set bits without duplicates" $ - \bs -> let fv = parse (BS.pack bs) - bits = setBits fv - -- Verify no duplicates and length matches unique count - in length bits === length (removeDups bits) +all_channel_types :: [ChannelType] +all_channel_types = + [ ChannelType b s z + | b <- [BasicStaticRemotekey, BasicAnchors, BasicZeroFeeCommitments] + , s <- [False, True] + , z <- [False, True] ] - , testProperty "double set is idempotent" $ - \(Small n) -> let idx = bitIndex (n `mod` 256) - fv = set idx empty - fv' = set idx fv - in unFeatureVector fv === unFeatureVector fv' +channel_type_tests :: TestTree +channel_type_tests = testGroup "channel types" [ + testCase "every defined type round-trips" $ + mapM_ (\ct -> channel_type (channel_type_features ct) @?= Just ct) + all_channel_types - , testProperty "set then clear restores original (when was unset)" $ - \(Small n) -> let idx = bitIndex (n `mod` 256) - fv = set idx empty - fv' = clear idx fv - in unFeatureVector fv' === BS.empty + , testCase "encodings" $ do + let enc b s z = render (channel_type_features (ChannelType b s z)) + enc BasicStaticRemotekey False False @?= BS.pack [0x10, 0x00] + enc BasicAnchors False False @?= BS.pack [0x40, 0x10, 0x00] + enc BasicZeroFeeCommitments False False + @?= BS.pack [0x01, 0, 0, 0, 0, 0] + enc BasicAnchors True True + @?= BS.pack [0x04, 0x40, 0, 0, 0x40, 0x10, 0x00] - , testProperty "member consistent with setBits" $ - \bs -> let fv = parse (BS.pack bs) - bits = setBits fv - in all (\b -> member (bitIndex b) fv) bits === True + , testCase "exactly the twelve defined types decode" $ do + let candidates = [12, 13, 14, 22, 23, 40, 46, 47, 50, 51, 52] + decoded = [ ct | s <- subsequences candidates + , Just ct <- [channel_type (bits s)] ] + length decoded @?= 12 + mapM_ (\ct -> assertBool (show ct) (ct `elem` all_channel_types)) + decoded - , testProperty "requiredBit only succeeds for even" $ - \(n :: Word16) -> isJust (requiredBit n) === (n `mod` 2 == 0) + , testCase "rejects undefined types" $ + mapM_ (\s -> channel_type (bits s) @?= Nothing) + [ [], [13], [22], [23, 13], [12, 40], [12, 14], [46], [50] + , [12, 47], [12, 51], [12, 52], [40, 44] ] - , testProperty "optionalBit only succeeds for odd" $ - \(n :: Word16) -> isJust (optionalBit n) === (n `mod` 2 == 1) + , testCase "variations need no dependency closure" $ + channel_type (bits [12, 50]) + @?= Just (ChannelType BasicStaticRemotekey False True) + + , testCase "leading zero bytes are ignored" $ + channel_type (parse "\NUL\NUL\DLE\NUL") + @?= Just (ChannelType BasicStaticRemotekey False False) ] --- | Remove duplicates from a list. -removeDups :: Eq a => [a] -> [a] -removeDups [] = [] -removeDups (x:xs) = x : removeDups (filter (/= x) xs) +-- properties ---------------------------------------------------------------- + +gen_bytes :: Gen ByteString +gen_bytes = BS.pack <$> arbitrary + +gen_vector :: Gen FeatureVector +gen_vector = parse <$> gen_bytes + +gen_feature :: Gen Feature +gen_feature = elements known_features + +gen_level :: Gen FeatureLevel +gen_level = elements [Required, Optional] + +-- | A bit index somewhat beyond the end of a vector. +gen_index :: FeatureVector -> Gen Int +gen_index fv = choose (0, 8 * BS.length (render fv) + 16) + +has_leading_zero :: FeatureVector -> Bool +has_leading_zero fv = BS.take 1 (render fv) == BS.singleton 0 + +properties :: TestTree +properties = testGroup "properties" [ + testProperty "render . parse == id" $ + forAll gen_bytes $ \bs -> render (parse bs) === bs + + , testProperty "equality ignores leading zero bytes" $ + forAll gen_bytes $ \bs (Small k) -> + parse (BS.replicate k 0 <> bs) === parse bs + + , testProperty "equality agrees with set_bits" $ + forAll gen_vector $ \a -> forAll gen_vector $ \b -> + (a == b) === (set_bits a == set_bits b) + + , testProperty "set_bits lists exactly the set bits, ascending" $ + forAll gen_vector $ \fv -> + set_bits fv + === filter (`test_bit` fv) [0 .. 8 * BS.length (render fv) - 1] + + , testProperty "set_bit sets only its bit" $ + forAll gen_vector $ \fv -> forAll (gen_index fv) $ \i -> + let fv' = set_bit i fv + in test_bit i fv' + .&&. filter (/= i) (set_bits fv') + === filter (/= i) (set_bits fv) + + , testProperty "clear_bit clears only its bit" $ + forAll gen_vector $ \fv -> forAll (gen_index fv) $ \i -> + let fv' = clear_bit i fv + in not (test_bit i fv') + .&&. set_bits fv' === filter (/= i) (set_bits fv) + + , testProperty "union is bitwise OR" $ + forAll gen_vector $ \a -> forAll gen_vector $ \b -> + let u = union a b + n = 8 * max (BS.length (render a)) (BS.length (render b)) + in fmap (`test_bit` u) [0 .. n - 1] + === fmap (\i -> test_bit i a || test_bit i b) [0 .. n - 1] + + , testProperty "operations encode minimally" $ + forAll gen_vector $ \a -> forAll gen_vector $ \b -> + forAll (gen_index a) $ \i -> + not (any has_leading_zero + [union a b, set_bit i a, clear_bit i a]) + + , testProperty "set_feature sets exactly one bit of the pair" $ + forAll gen_vector $ \fv -> forAll gen_feature $ \f -> + forAll gen_level $ \l -> + let fv' = set_feature f l fv + b = feature_bit f + other = filter (\i -> i /= b && i /= b + 1) + in test_feature f fv' === Just l + .&&. test_bit b fv' =/= test_bit (b + 1) fv' + .&&. other (set_bits fv') === other (set_bits fv) + + , testProperty "vectors built with set_feature_with_deps validate" $ + forAll (elements (filter (/= ChannelTypeContext) contexts)) $ \c -> + forAll (gen_presented c) $ \fs -> + let fv = foldr (\(f, l) -> set_feature_with_deps f l) empty fs + in validate_local c fv === Right () + .&&. validate_remote c fv === Right () + ] + +-- | Features presented in a context, each with a level. +gen_presented :: Context -> Gen [(Feature, FeatureLevel)] +gen_presented c = do + fs <- sublistOf (filter presented known_features) + traverse (\f -> (,) f <$> gen_level) fs + where + presented f = case feature_contexts f of + [] -> c `elem` [InitContext, NodeContext, InvoiceContext] + cs -> c `elem` cs