diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +# Changelog + +- 0.0.1 (unreleased) + * Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs new file mode 100644 --- /dev/null +++ b/bench/Fixtures.hs @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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" + ] + ] diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -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 diff --git a/lib/Lightning/Protocol/BOLT9.hs b/lib/Lightning/Protocol/BOLT9.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT9.hs @@ -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 +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT9/Codec.hs b/lib/Lightning/Protocol/BOLT9/Codec.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT9/Codec.hs @@ -0,0 +1,163 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT9/Features.hs @@ -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 +-- +-- 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 new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT9/Types.hs @@ -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 +-- +-- 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 new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT9/Validate.hs @@ -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 +-- +-- 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 new file mode 100644 --- /dev/null +++ b/ppad-bolt9.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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)