packages feed

ppad-bolt9 (empty) → 0.0.1

raw patch · 12 files changed

+1457/−0 lines, 12 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, criterion, deepseq, ppad-bolt9, tasty, tasty-hunit, tasty-quickcheck, weigh

Files

+ CHANGELOG view
@@ -0,0 +1,4 @@+# Changelog++- 0.0.1 (unreleased)+  * Initial release.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2025 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ bench/Fixtures.hs view
@@ -0,0 +1,57 @@+module Fixtures (+    -- * ByteString fixtures+    typicalBytes+  , emptyBytes+  , largeBytes++    -- * FeatureVector fixtures+  , typicalFV+  , emptyFV+  , validFV+  , unknownBitsFV+  ) 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++-- FeatureVector fixtures -----------------------------------------------------++-- | 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++-- | Empty feature vector.+emptyFV :: B9.FeatureVector+emptyFV = B9.empty++-- | 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++-- | 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
+ bench/Main.hs view
@@ -0,0 +1,42 @@+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 "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 "validate" [+        bench "validateLocal (valid)"   $+          nf (B9.validateLocal B9.Init) validFV+      , bench "validateRemote (unknown bits)" $+          nf (B9.validateRemote B9.Init) unknownBitsFV+      ]++  , bgroup "lookup" [+        bench "featureByBit"  $ nf B9.featureByBit 16+      , bench "featureByName" $ nf B9.featureByName "basic_mpp"+      ]+  ]
+ bench/Weight.hs view
@@ -0,0 +1,21 @@+module Main where++import Weigh+import qualified Lightning.Protocol.BOLT9 as B9+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
+ lib/Lightning/Protocol/BOLT9.hs view
@@ -0,0 +1,136 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT9+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Feature flags for the Lightning Network, per+-- [BOLT #9](https://github.com/lightning/bolts/blob/master/09-features.md).+--+-- == Overview+--+-- 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.+--+-- This library provides:+--+-- * 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.)+--+-- == Quick Start+--+-- Create a feature vector and set some features:+--+-- >>> import Lightning.Protocol.BOLT9+-- >>> let Just mpp = featureByName "basic_mpp"+-- >>> let fv = setFeature mpp Optional empty+-- >>> hasFeature mpp fv+-- Just Optional+--+-- Validate a feature vector for a specific context:+--+-- >>> validateLocal Init fv+-- Left [MissingDependency "basic_mpp" "payment_secret"]+--+-- Fix by adding the dependency:+--+-- >>> let Just ps = featureByName "payment_secret"+-- >>> let fv' = setFeature ps Optional (setFeature mpp Optional empty)+-- >>> validateLocal Init fv'+-- Right ()+--+-- == Bit Numbering+--+-- 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).+--+-- 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).++module Lightning.Protocol.BOLT9 (+    -- * Context+    -- | Contexts specify where feature flags appear in the protocol.+    Context(..)+  , isChannelContext+  , channelParity++    -- * Bit indices+    -- | Low-level bit index types for direct bit manipulation.+  , BitIndex+  , unBitIndex+  , bitIndex++    -- * Required/optional level+    -- | Whether a feature is set as required or optional.+  , FeatureLevel(..)++    -- * Required/optional bits+    -- | Type-safe wrappers ensuring correct parity.+  , RequiredBit+  , unRequiredBit+  , requiredBit+  , requiredFromBitIndex++  , OptionalBit+  , unOptionalBit+  , optionalBit+  , optionalFromBitIndex++    -- * Feature vectors+    -- | The core feature vector type and basic operations.+  , FeatureVector+  , unFeatureVector+  , FV.empty+  , fromByteString+  , set+  , clear+  , member++    -- * Known features+    -- | The BOLT #9 feature table and lookup functions.+  , Feature(..)+  , featureByBit+  , featureByName+  , knownFeatures++    -- * Parsing and rendering+    -- | Wire format conversion.+  , parse+  , render++    -- * Low-level bit operations+    -- | Direct bit manipulation by index.+  , Codec.setBit+  , Codec.clearBit+  , Codec.testBit++    -- * Feature operations+    -- | High-level operations using 'Feature' values.+  , setFeature+  , hasFeature+  , isFeatureSet+  , listFeatures++    -- * Validation+    -- | Validate feature vectors for correctness.+  , ValidationError(..)+  , validateLocal+  , validateRemote+  , highestSetBit+  , Validate.setBits+  ) where++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
+ lib/Lightning/Protocol/BOLT9/Codec.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Lightning.Protocol.BOLT9.Codec+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ lib/Lightning/Protocol/BOLT9/Features.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT9.Features+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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]
+ lib/Lightning/Protocol/BOLT9/Types.hs view
@@ -0,0 +1,282 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT9.Types+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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 #-}
+ lib/Lightning/Protocol/BOLT9/Validate.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT9.Validate+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ ppad-bolt9.cabal view
@@ -0,0 +1,87 @@+cabal-version:      3.0+name:               ppad-bolt9+version:            0.0.1+synopsis:           Feature flags per BOLT #9+license:            MIT+license-file:       LICENSE+author:             Jared Tobin+maintainer:         jared@ppad.tech+category:           Cryptography+build-type:         Simple+tested-with:        GHC == 9.10.3+extra-doc-files:    CHANGELOG+description:+  Feature flags, per+  [BOLT #9](https://github.com/lightning/bolts/blob/master/09-features.md).++source-repository head+  type:     git+  location: git.ppad.tech/bolt9.git++library+  default-language: Haskell2010+  hs-source-dirs:   lib+  ghc-options:+      -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+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  hs-source-dirs:      test+  main-is:             Main.hs++  ghc-options:+    -rtsopts -Wall -O2++  build-depends:+      base+    , bytestring+    , ppad-bolt9+    , tasty+    , tasty-hunit+    , tasty-quickcheck++benchmark bolt9-bench+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  hs-source-dirs:      bench+  main-is:             Main.hs+  other-modules:       Fixtures++  ghc-options:+    -rtsopts -O2 -Wall -fno-warn-orphans++  build-depends:+      base+    , bytestring+    , criterion+    , deepseq+    , ppad-bolt9++benchmark bolt9-weigh+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  hs-source-dirs:      bench+  main-is:             Weight.hs+  other-modules:       Fixtures++  ghc-options:+    -rtsopts -O2 -Wall -fno-warn-orphans++  build-depends:+      base+    , bytestring+    , deepseq+    , ppad-bolt9+    , weigh
+ test/Main.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import qualified Data.ByteString as BS+import Data.Maybe (isJust, isNothing)+import Data.Word (Word16)+import Lightning.Protocol.BOLT9+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "ppad-bolt9" [+    featureTableTests+  , bitParityTests+  , featureVectorTests+  , validationTests+  , propertyTests+  ]++-- Feature table tests ---------------------------------------------------------++featureTableTests :: TestTree+featureTableTests = testGroup "Feature table" [+    testCase "all features have even baseBit" $+      all (even . featureBaseBit) knownFeatures @?= True++  , testCase "featureByBit works for even bit" $+      case featureByBit 14 of+        Nothing -> assertFailure "expected to find payment_secret"+        Just f  -> featureName f @?= "payment_secret"++  , testCase "featureByBit works for odd bit" $+      case featureByBit 15 of+        Nothing -> assertFailure "expected to find payment_secret"+        Just f  -> featureName f @?= "payment_secret"++  , testCase "featureByBit returns Nothing for unknown bit" $+      featureByBit 100 @?= Nothing++  , testCase "featureByName finds known features" $ do+      isJust (featureByName "var_onion_optin") @?= True+      isJust (featureByName "payment_secret") @?= True+      isJust (featureByName "basic_mpp") @?= True++  , testCase "featureByName returns Nothing for unknown names" $+      featureByName "nonexistent_feature" @?= Nothing++  , 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 "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"+                         ]+  ]++-- Bit parity tests ------------------------------------------------------------++bitParityTests :: TestTree+bitParityTests = testGroup "Bit parity" [+    testCase "requiredBit accepts even numbers" $ do+      isJust (requiredBit 0) @?= True+      isJust (requiredBit 2) @?= True+      isJust (requiredBit 100) @?= True++  , testCase "requiredBit rejects odd numbers" $ do+      isNothing (requiredBit 1) @?= True+      isNothing (requiredBit 3) @?= True+      isNothing (requiredBit 101) @?= True++  , testCase "optionalBit accepts odd numbers" $ do+      isJust (optionalBit 1) @?= True+      isJust (optionalBit 3) @?= True+      isJust (optionalBit 101) @?= True++  , testCase "optionalBit rejects even numbers" $ do+      isNothing (optionalBit 0) @?= True+      isNothing (optionalBit 2) @?= True+      isNothing (optionalBit 100) @?= True++  , testCase "requiredBit smart constructor preserves value" $+      case requiredBit 42 of+        Nothing -> assertFailure "expected Just"+        Just rb -> unRequiredBit rb @?= 42++  , testCase "optionalBit smart constructor preserves value" $+      case optionalBit 43 of+        Nothing -> assertFailure "expected Just"+        Just ob -> unOptionalBit ob @?= 43+  ]++-- FeatureVector tests ---------------------------------------------------------++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++  , testCase "set adds a bit" $ do+      let fv = set (bitIndex 0) empty+      member (bitIndex 0) fv @?= True++  , 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++  , 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 "clear on unset bit is no-op" $ do+      let fv = clear (bitIndex 10) empty+      unFeatureVector fv @?= BS.empty++  , 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 "render strips leading zeros" $ do+      let fv = set (bitIndex 0) empty+      render fv @?= BS.pack [0x01]++  , testCase "render handles high bits correctly" $ do+      let fv = set (bitIndex 15) empty+      render fv @?= BS.pack [0x80, 0x00]++  , testCase "render of empty is empty" $+      render empty @?= BS.empty+  ]++-- Validation tests ------------------------------------------------------------++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++  , 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 "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 "Remote validation accepts unknown optional bits" $ do+      -- bit 201 is unknown and odd (optional)+      let fv = setBit 201 empty+      validateRemote Init fv @?= 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 "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 "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"+  ]++isBothBitsSet :: ValidationError -> Bool+isBothBitsSet (BothBitsSet _ _) = True+isBothBitsSet _ = False++isMissingDependency :: ValidationError -> Bool+isMissingDependency (MissingDependency _ _) = True+isMissingDependency _ = False++isContextNotAllowed :: ValidationError -> Bool+isContextNotAllowed (ContextNotAllowed _ _) = True+isContextNotAllowed _ = False++isUnknownRequiredBit :: ValidationError -> Bool+isUnknownRequiredBit (UnknownRequiredBit _) = True+isUnknownRequiredBit _ = False++-- Property tests --------------------------------------------------------------++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++  , testProperty "set then member returns True" $+      \(Small n) -> let idx = bitIndex (n `mod` 256)+                        fv  = set idx empty+                    in  member idx fv === True++  , 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++  , 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)++  , 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'++  , 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++  , testProperty "member consistent with setBits" $+      \bs -> let fv   = parse (BS.pack bs)+                 bits = setBits fv+             in  all (\b -> member (bitIndex b) fv) bits === True++  , testProperty "requiredBit only succeeds for even" $+      \(n :: Word16) -> isJust (requiredBit n) === (n `mod` 2 == 0)++  , testProperty "optionalBit only succeeds for odd" $+      \(n :: Word16) -> isJust (optionalBit n) === (n `mod` 2 == 1)+  ]++-- | Remove duplicates from a list.+removeDups :: Eq a => [a] -> [a]+removeDups [] = []+removeDups (x:xs) = x : removeDups (filter (/= x) xs)