commit 710798bbc64d9aad92da076b5a56896a53fbd847
parent 5c2e239fdd5d5ccce99572aad742bef4cdd3e70f
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 13:28:21 +0400
test: rewrite against the new API
Asserts the feature table against the spec, adds the BOLT #11 invoice
feature vectors, channel-type cases, negative tests for each
validation rule per context, and properties over arbitrary vectors.
Diffstat:
| M | test/Main.hs | | | 1117 | ++++++++++++++++++++++++++++++++++++------------------------------------------- |
1 file changed, 513 insertions(+), 604 deletions(-)
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,638 +1,547 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
module Main where
+import qualified Data.Bits as B
+import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
-import Data.Either (isLeft, isRight)
-import Data.Maybe (isJust, isNothing)
-import Data.Word (Word8, Word16)
+import Data.List (elemIndex, subsequences)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Word (Word8)
import Lightning.Protocol.BOLT9
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
main :: IO ()
-main = defaultMain tests
-
-tests :: TestTree
-tests = testGroup "ppad-bolt9" [
- featureTableTests
- , bitParityTests
- , featureVectorTests
- , validationTests
- , knownFeatureTests
- , setFeatureWithDepsTests
- , setFeatureForContextTests
- , validateNoBothBitsTests
- , remoteDependencyTests
- , longVectorTests
- , oppositeBitTests
- , propertyTests
+main = defaultMain $ testGroup "ppad-bolt9" [
+ table_tests
+ , vector_tests
+ , feature_tests
+ , local_tests
+ , remote_tests
+ , invoice_tests
+ , channel_type_tests
+ , properties
]
--- 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"
- ]
+-- feature table -------------------------------------------------------------
+
+-- | The BOLT #9 table at lightning/bolts@1aadb719: bits, name, whether
+-- it is ASSUMED, the Context column, and the dependency names.
+spec_table :: [(Int, String, Bool, String, [String])]
+spec_table = [
+ (0, "option_data_loss_protect", True, "", [])
+ , (4, "option_upfront_shutdown_script", False, "IN", [])
+ , (6, "gossip_queries", False, "", [])
+ , (8, "var_onion_optin", True, "", [])
+ , (10, "gossip_queries_ex", False, "IN", [])
+ , (12, "option_static_remotekey", True, "", [])
+ , (14, "payment_secret", True, "", [])
+ , (16, "basic_mpp", False, "IN9", ["payment_secret"])
+ , (18, "option_support_large_channel", False, "IN", [])
+ , (22, "option_anchors", False, "INT", [])
+ , (24, "option_route_blinding", False, "IN9", [])
+ , (26, "option_shutdown_anysegwit", False, "IN", [])
+ , (28, "option_dual_fund", False, "IN", [])
+ , (34, "option_quiesce", False, "IN", [])
+ , (36, "option_attribution_data", False, "IN9", [])
+ , (38, "option_onion_messages", False, "IN", [])
+ , (40, "zero_fee_commitments", False, "IN", ["option_channel_type"])
+ , (42, "option_provide_storage", False, "IN", [])
+ , (44, "option_channel_type", True, "", [])
+ , (46, "option_scid_alias", False, "INT", [])
+ , (48, "option_payment_metadata", False, "9", [])
+ , (50, "option_zeroconf", False, "INT", ["option_scid_alias"])
+ , (60, "option_simple_close", False, "IN"
+ , ["option_shutdown_anysegwit"])
+ , (62, "option_splice", False, "IN", [])
+ , (66, "option_onion_messages_only_channels", False, "IN"
+ , ["option_onion_messages"])
]
--- 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
+table_row :: Feature -> (Int, String, Bool, String, [String])
+table_row f =
+ ( feature_bit f
+ , feature_name f
+ , feature_assumed f
+ , concatMap letter (feature_contexts f)
+ , fmap feature_name (feature_dependencies f) )
+ where
+ letter c = case c of
+ InitContext -> "I"
+ NodeContext -> "N"
+ ChannelContext -> "C"
+ InvoiceContext -> "9"
+ BlindedContext -> "B"
+ ChannelTypeContext -> "T"
+
+table_tests :: TestTree
+table_tests = testGroup "feature table" [
+ testCase "matches the spec table" $
+ fmap table_row known_features @?= spec_table
+
+ , testCase "feature_by_bit maps both bits to the feature" $
+ mapM_ (\f -> do
+ feature_by_bit (feature_bit f) @?= Just f
+ feature_by_bit (feature_bit f + 1) @?= Just f)
+ known_features
+
+ , testCase "feature_by_bit rejects unassigned bits" $ do
+ let assigned = concatMap (\f -> [feature_bit f, feature_bit f + 1])
+ known_features
+ free = filter (`notElem` assigned) [0 .. 600]
+ mapM_ (\i -> feature_by_bit i @?= Nothing) free
+ feature_by_bit (-1) @?= Nothing
+ feature_by_bit (-2) @?= Nothing
]
--- 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"
- ]
+-- feature vectors -----------------------------------------------------------
-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
-
--- KnownFeature tests -----------------------------------------------------------
-
-knownFeatureTests :: TestTree
-knownFeatureTests = testGroup "KnownFeature" [
- testCase "knownFeatureByBit finds known feature" $
- case knownFeatureByBit 16 of
- Nothing -> assertFailure "expected basic_mpp"
- Just kf ->
- featureName (unKnownFeature kf) @?= "basic_mpp"
-
- , testCase "knownFeatureByBit works for odd bit" $
- case knownFeatureByBit 17 of
- Nothing -> assertFailure "expected basic_mpp"
- Just kf ->
- featureName (unKnownFeature kf) @?= "basic_mpp"
-
- , testCase "knownFeatureByBit returns Nothing for unknown" $
- knownFeatureByBit 999 @?= Nothing
-
- , testCase "knownFeatureByName finds known feature" $
- case knownFeatureByName "payment_secret" of
- Nothing -> assertFailure "expected payment_secret"
- Just kf ->
- featureBaseBit (unKnownFeature kf) @?= 14
-
- , testCase "knownFeatureByName returns Nothing for unknown" $
- knownFeatureByName "nonexistent" @?= Nothing
+-- | A vector of (n + 1) bytes whose most significant byte is b.
+long_vector :: Int -> Word8 -> FeatureVector
+long_vector n b = parse (BS.cons b (BS.replicate n 0))
+
+vector_tests :: TestTree
+vector_tests = testGroup "feature vectors" [
+ testCase "empty" $ do
+ render empty @?= ""
+ set_bits empty @?= []
+
+ , testCase "render returns parsed bytes exactly" $ do
+ render (parse "\NUL\NUL\STX") @?= "\NUL\NUL\STX"
+ render (parse "\NUL") @?= "\NUL"
+
+ , testCase "equality ignores leading zero bytes" $ do
+ parse "\NUL\STX" @?= parse "\STX"
+ parse "\NUL\NUL" @?= empty
+ assertBool "distinct" (parse "\STX" /= parse "\SOH")
+ assertBool "distinct" (parse "\SOH\NUL" /= parse "\SOH")
+
+ , testCase "show" $
+ show (parse "\NUL\STX") @?= "parse \"\\NUL\\STX\""
+
+ , testCase "bit numbering" $ do
+ render (set_bit 0 empty) @?= "\SOH"
+ render (set_bit 7 empty) @?= "\128"
+ render (set_bit 8 empty) @?= "\SOH\NUL"
+ render (set_bit 17 empty) @?= "\STX\NUL\NUL"
+ set_bits (parse "\128\NUL\SOH") @?= [0, 23]
+
+ , testCase "operations encode minimally" $ do
+ render (set_bit 1 (parse "\NUL\NUL\SOH")) @?= "\ETX"
+ render (clear_bit 0 (parse "\NUL\SOH\SOH")) @?= "\SOH\NUL"
+ render (clear_bit 8 (parse "\SOH\SOH")) @?= "\SOH"
+ render (union (parse "\NUL\NUL") empty) @?= ""
+
+ , testCase "union" $ do
+ union (parse "\SOH\NUL") (parse "\STX") @?= parse "\SOH\STX"
+ union (parse "\STX") empty @?= parse "\STX"
+ set_bits (union (parse "\SOH\SOH") (parse "\128\SOH")) @?= [0, 8, 15]
+
+ , testCase "negative indices are ignored" $ do
+ set_bit (-1) (parse "\STX") @?= parse "\STX"
+ clear_bit (-1) (parse "\STX") @?= parse "\STX"
+ test_bit (-1) (parse "\255") @?= False
+
+ , testCase "clearing a bit beyond the vector is a no-op" $
+ render (clear_bit 1000 (parse "\STX")) @?= "\STX"
+
+ , testCase "bit 65536 does not wrap" $ do
+ let fv = long_vector 8192 0x01
+ set_bits fv @?= [65536]
+ test_bit 65536 fv @?= True
+ test_bit 0 fv @?= False
+
+ , testCase "bits of a maximum-length vector" $ do
+ let fv = long_vector 65534 0x80
+ BS.length (render fv) @?= 65535
+ set_bits fv @?= [524279]
+ set_bit 524279 empty @?= fv
+ clear_bit 524279 fv @?= empty
]
--- setFeatureWithDeps tests -----------------------------------------------------
-
-setFeatureWithDepsTests :: TestTree
-setFeatureWithDepsTests = testGroup "setFeatureWithDeps" [
- testCase "sets feature and its dependency" $ do
- case featureByName "basic_mpp" of
- Nothing -> assertFailure "basic_mpp not found"
- Just mpp -> do
- let fv = setFeatureWithDeps mpp Optional empty
- isFeatureSet mpp fv @?= True
- -- payment_secret should also be set
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps -> isFeatureSet ps fv @?= True
-
- , testCase "sets transitive dependencies" $ do
- -- option_zeroconf depends on option_scid_alias
- case featureByName "option_zeroconf" of
- Nothing ->
- assertFailure "option_zeroconf not found"
- Just zc -> do
- let fv = setFeatureWithDeps zc Required empty
- isFeatureSet zc fv @?= True
- case featureByName "option_scid_alias" of
- Nothing ->
- assertFailure "option_scid_alias not found"
- Just sa -> isFeatureSet sa fv @?= True
-
- , testCase "feature without deps sets only itself" $ do
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps -> do
- let fv = setFeatureWithDeps ps Optional empty
- isFeatureSet ps fv @?= True
- -- no other features should be set
- let others = filter
- (\(f, _) -> featureName f /= "payment_secret")
- (listFeatures fv)
- null others @?= True
-
- , testCase "passes validateLocal after setFeatureWithDeps" $ do
- case featureByName "basic_mpp" of
- Nothing -> assertFailure "basic_mpp not found"
- Just mpp -> do
- let fv = setFeatureWithDeps mpp Optional empty
- validateLocal Init fv @?= Right ()
+-- feature operations --------------------------------------------------------
+
+feature_tests :: TestTree
+feature_tests = testGroup "feature operations" [
+ testCase "set_feature sets the bit for its level" $ do
+ set_bits (set_feature BasicMpp Required empty) @?= [16]
+ set_bits (set_feature BasicMpp Optional empty) @?= [17]
+
+ , testCase "set_feature clears the other bit" $ do
+ set_bits (set_feature PaymentSecret Optional (set_bit 14 empty))
+ @?= [15]
+ set_bits (set_feature PaymentSecret Required (set_bit 15 empty))
+ @?= [14]
+
+ , testCase "set_feature leaves other features alone" $
+ set_bits (set_feature BasicMpp Optional (parse "\STX\NUL"))
+ @?= [9, 17]
+
+ , testCase "clear_feature clears both bits" $ do
+ clear_feature BasicMpp (set_bit 16 (set_bit 17 empty)) @?= empty
+ clear_feature BasicMpp (set_bit 9 (set_bit 17 empty))
+ @?= set_bit 9 empty
+
+ , testCase "test_feature" $ do
+ test_feature BasicMpp (set_bit 16 empty) @?= Just Required
+ test_feature BasicMpp (set_bit 17 empty) @?= Just Optional
+ test_feature BasicMpp (set_bit 16 (set_bit 17 empty))
+ @?= Just Required
+ test_feature BasicMpp (set_bit 18 empty) @?= Nothing
+
+ , testCase "list_features is in bit order and skips unknown bits" $
+ list_features (set_bit 100 (set_bit 51 (set_bit 46 (set_bit 15 empty))))
+ @?= [ (PaymentSecret, Optional), (OptionScidAlias, Required)
+ , (OptionZeroconf, Optional) ]
+
+ , testCase "set_feature_with_deps sets dependencies" $ do
+ list_features (set_feature_with_deps OptionZeroconf Required empty)
+ @?= [(OptionScidAlias, Required), (OptionZeroconf, Required)]
+ list_features (set_feature_with_deps ZeroFeeCommitments Optional empty)
+ @?= [(ZeroFeeCommitments, Optional), (OptionChannelType, Optional)]
+
+ , testCase "set_feature_with_deps keeps a set dependency's level" $
+ list_features
+ (set_feature_with_deps OptionSimpleClose Optional
+ (set_feature OptionShutdownAnysegwit Required empty))
+ @?= [ (OptionShutdownAnysegwit, Required)
+ , (OptionSimpleClose, Optional) ]
]
--- setFeatureForContext tests ---------------------------------------------------
-
-setFeatureForContextTests :: TestTree
-setFeatureForContextTests = testGroup "setFeatureForContext" [
- testCase "allows feature in valid context" $ do
- case featureByName "option_payment_metadata" of
- Nothing ->
- assertFailure "option_payment_metadata not found"
- Just pm ->
- isRight
- (setFeatureForContext Invoice pm Optional empty)
- @?= True
-
- , testCase "rejects feature in wrong context" $ do
- case featureByName "option_payment_metadata" of
- Nothing ->
- assertFailure "option_payment_metadata not found"
- Just pm ->
- case setFeatureForContext Init pm Optional empty of
- Right _ -> assertFailure "expected error"
- Left err -> isContextNotAllowed err @?= True
-
- , testCase "allows feature with empty context list" $ do
- -- payment_secret has empty context list (all allowed)
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps ->
- isRight
- (setFeatureForContext Init ps Optional empty)
- @?= True
-
- , testCase "rejects Required in ChanAnnOdd context" $ do
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps ->
- case setFeatureForContext
- ChanAnnOdd ps Required empty of
- Right _ -> assertFailure "expected parity error"
- Left err -> isInvalidParity err @?= True
-
- , testCase "allows Optional in ChanAnnOdd context" $ do
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps ->
- isRight
- (setFeatureForContext
- ChanAnnOdd ps Optional empty)
- @?= True
-
- , testCase "rejects Optional in ChanAnnEven context" $ do
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps ->
- case setFeatureForContext
- ChanAnnEven ps Optional empty of
- Right _ -> assertFailure "expected parity error"
- Left err -> isInvalidParity err @?= True
-
- , testCase "allows Required in ChanAnnEven context" $ do
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps ->
- isRight
- (setFeatureForContext
- ChanAnnEven ps Required empty)
- @?= True
+-- local validation ----------------------------------------------------------
+
+-- | A vector with the given bits set.
+bits :: [Int] -> FeatureVector
+bits = foldr set_bit empty
+
+contexts :: [Context]
+contexts =
+ [ InitContext, NodeContext, ChannelContext, InvoiceContext
+ , BlindedContext, ChannelTypeContext ]
+
+local_tests :: TestTree
+local_tests = testGroup "validate_local" [
+ testCase "empty is valid in every context but channel_type" $ do
+ mapM_ (\c -> validate_local c empty @?= Right ())
+ (filter (/= ChannelTypeContext) contexts)
+ validate_local ChannelTypeContext empty
+ @?= Left (InvalidChannelType :| [])
+
+ , testCase "rejects unknown bits, odd or even" $ do
+ validate_local InitContext (bits [20, 101])
+ @?= Left (UnknownBit 20 :| [UnknownBit 101])
+ validate_local NodeContext (bits [200]) @?= Left (UnknownBit 200 :| [])
+
+ , testCase "rejects both bits set" $
+ validate_local InitContext (bits [46, 47])
+ @?= Left (BothBitsSet OptionScidAlias :| [])
+
+ , testCase "rejects features outside their contexts" $ do
+ validate_local InitContext (bits [49])
+ @?= Left (ContextNotAllowed OptionPaymentMetadata InitContext :| [])
+ validate_local InvoiceContext (bits [23])
+ @?= Left (ContextNotAllowed OptionAnchors InvoiceContext :| [])
+ validate_local ChannelContext (bits [17, 15])
+ @?= Left (ContextNotAllowed PaymentSecret ChannelContext
+ :| [ContextNotAllowed BasicMpp ChannelContext])
+
+ , testCase "accepts features in their contexts" $ do
+ validate_local InvoiceContext (bits [49]) @?= Right ()
+ validate_local NodeContext (bits [23, 47]) @?= Right ()
+ validate_local InitContext (bits [63, 67, 39]) @?= Right ()
+
+ , testCase "empty-context features: accepted in I, N and 9 only" $ do
+ let fv = bits [1, 7, 9, 13, 15, 45]
+ mapM_ (\c -> validate_local c fv @?= Right ())
+ [InitContext, NodeContext, InvoiceContext]
+ validate_local ChannelContext (bits [9])
+ @?= Left (ContextNotAllowed VarOnionOptin ChannelContext :| [])
+ validate_local BlindedContext (bits [15])
+ @?= Left (ContextNotAllowed PaymentSecret BlindedContext :| [])
+
+ , testCase "allowed_features must be empty" $
+ validate_local BlindedContext (bits [17])
+ @?= Left (ContextNotAllowed BasicMpp BlindedContext :| [])
+
+ , testCase "rejects missing dependencies" $ do
+ validate_local InitContext (bits [51])
+ @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| [])
+ validate_local InitContext (bits [61])
+ @?= Left (MissingDependency OptionSimpleClose
+ OptionShutdownAnysegwit :| [])
+ validate_local NodeContext (bits [67])
+ @?= Left (MissingDependency OptionOnionMessagesOnlyChannels
+ OptionOnionMessages :| [])
+
+ , testCase "dependencies on ASSUMED features count as met" $ do
+ validate_local InitContext (bits [17]) @?= Right ()
+ validate_local InvoiceContext (bits [16]) @?= Right ()
+ validate_local InitContext (bits [41]) @?= Right ()
+
+ , testCase "reports errors in rule order" $
+ validate_local InitContext (bits [20, 22, 23, 48, 61])
+ @?= Left (UnknownBit 20 :|
+ [ BothBitsSet OptionAnchors
+ , ContextNotAllowed OptionPaymentMetadata InitContext
+ , MissingDependency OptionSimpleClose
+ OptionShutdownAnysegwit ])
+
+ , testCase "channel_type follows BOLT #2, not the generic rules" $ do
+ validate_local ChannelTypeContext (bits [12, 50]) @?= Right ()
+ validate_local ChannelTypeContext (bits [12, 23])
+ @?= Left (InvalidChannelType :| [])
]
--- validateNoBothBits tests -----------------------------------------------------
-
-validateNoBothBitsTests :: TestTree
-validateNoBothBitsTests = testGroup "validateNoBothBits" [
- testCase "passes for empty vector" $
- isRight (validateNoBothBits empty) @?= True
-
- , testCase "passes when only one bit of pair is set" $ do
- case featureByName "payment_secret" of
- Nothing ->
- assertFailure "payment_secret not found"
- Just ps -> do
- let fv = setFeature ps Optional empty
- isRight (validateNoBothBits fv) @?= True
-
- , testCase "fails when both bits of pair are set" $ do
- let fv = setBit 15 (setBit 14 empty)
- case validateNoBothBits fv of
- Right _ -> assertFailure "expected BothBitsSet"
- Left err -> isBothBitsSet err @?= True
-
- , testCase "returns first error found" $ do
- -- set both bits for two features
- let fv = setBit 15 (setBit 14
- (setBit 17 (setBit 16 empty)))
- isLeft (validateNoBothBits fv) @?= True
+-- remote validation ---------------------------------------------------------
+
+remote_tests :: TestTree
+remote_tests = testGroup "validate_remote" [
+ testCase "init: unknown odd bits are ignored" $
+ validate_remote InitContext (bits [101, 201]) @?= Right ()
+
+ , testCase "init: unknown even bits are rejected" $
+ validate_remote InitContext (bits [20, 100, 101])
+ @?= Left (UnknownBit 20 :| [UnknownBit 100])
+
+ , testCase "init: missing dependencies are rejected" $ do
+ validate_remote InitContext (bits [51])
+ @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| [])
+ validate_remote InitContext (bits [60])
+ @?= Left (MissingDependency OptionSimpleClose
+ OptionShutdownAnysegwit :| [])
+ validate_remote InitContext (bits [51, 47]) @?= Right ()
+
+ , testCase "init: ASSUMED dependencies count as met" $ do
+ validate_remote InitContext (bits [17]) @?= Right ()
+ validate_remote InitContext (bits [40]) @?= Right ()
+
+ , testCase "init: both bits set is not an error" $
+ validate_remote InitContext (bits [46, 47]) @?= Right ()
+
+ , testCase "init: known features outside their contexts pass" $
+ validate_remote InitContext (bits [49]) @?= Right ()
+
+ , testCase "node and channel announcements: unknown even bits" $ do
+ validate_remote NodeContext (bits [100])
+ @?= Left (UnknownBit 100 :| [])
+ validate_remote ChannelContext (bits [100])
+ @?= Left (UnknownBit 100 :| [])
+ validate_remote NodeContext (bits [101]) @?= Right ()
+ validate_remote ChannelContext (bits [101]) @?= Right ()
+
+ , testCase "node and channel announcements: no dependency rule" $ do
+ validate_remote NodeContext (bits [51]) @?= Right ()
+ validate_remote ChannelContext (bits [51]) @?= Right ()
+
+ , testCase "invoice: unknown even bits and dependencies" $ do
+ validate_remote InvoiceContext (bits [100])
+ @?= Left (UnknownBit 100 :| [])
+ validate_remote InvoiceContext (bits [51])
+ @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| [])
+ validate_remote InvoiceContext (bits [101, 17]) @?= Right ()
+
+ , testCase "blinded path: any unknown bit is rejected" $ do
+ validate_remote BlindedContext (bits [101])
+ @?= Left (UnknownBit 101 :| [])
+ validate_remote BlindedContext (bits [100])
+ @?= Left (UnknownBit 100 :| [])
+ validate_remote BlindedContext (bits [15, 17]) @?= Right ()
+ validate_remote BlindedContext empty @?= Right ()
+
+ , testCase "channel_type: must be a defined type" $ do
+ validate_remote ChannelTypeContext (bits [12, 22]) @?= Right ()
+ validate_remote ChannelTypeContext (bits [22])
+ @?= Left (InvalidChannelType :| [])
+
+ , testCase "bits above 65535 do not wrap" $ do
+ validate_remote InitContext (long_vector 8192 0x01)
+ @?= Left (UnknownBit 65536 :| [])
+ validate_remote InitContext (long_vector 8192 0x04)
+ @?= Left (UnknownBit 65538 :| [])
+ validate_remote InitContext (long_vector 8194 0x01)
+ @?= Left (UnknownBit 65552 :| [])
+
+ , testCase "maximum-length vectors" $ do
+ validate_remote InitContext (long_vector 65534 0x80) @?= Right ()
+ validate_remote InitContext (long_vector 65534 0x40)
+ @?= Left (UnknownBit 524278 :| [])
]
--- Remote dependency tests -----------------------------------------------------
-
-remoteDependencyTests :: TestTree
-remoteDependencyTests = testGroup "validateRemote dependencies" [
- testCase "rejects option_zeroconf without option_scid_alias" $
- validateRemote Init (setBit 51 empty) @?=
- Left [MissingDependency "option_zeroconf" "option_scid_alias"]
-
- , testCase "rejects basic_mpp without payment_secret (init)" $
- validateRemote Init (setBit 17 empty) @?=
- Left [MissingDependency "basic_mpp" "payment_secret"]
-
- , testCase "rejects basic_mpp without payment_secret (invoice)" $
- validateRemote Invoice (setBit 17 empty) @?=
- Left [MissingDependency "basic_mpp" "payment_secret"]
-
- , testCase "rejects option_simple_close without anysegwit" $
- validateRemote Init (setBit 60 empty) @?=
- Left [ MissingDependency
- "option_simple_close" "option_shutdown_anysegwit" ]
-
- , testCase "accepts features with dependencies set" $ do
- validateRemote Init (setBit 51 (setBit 47 empty)) @?= Right ()
- validateRemote Invoice (setBit 17 (setBit 14 empty)) @?= Right ()
+-- BOLT #11 vectors ----------------------------------------------------------
+
+-- | The feature vector carried by a BOLT #11 @9@ field, given the
+-- field's data as bech32 characters.
+invoice_features :: String -> Maybe FeatureVector
+invoice_features cs = do
+ vs <- traverse (`elemIndex` charset) cs
+ let n = length vs
+ pure $ bits
+ [ (n - 1 - k) * 5 + j
+ | (k, v) <- zip [0 ..] vs, j <- [0 .. 4], B.testBit v j ]
+ where
+ charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
+
+invoice_case
+ :: String -> String -> [Int]
+ -> Either (NonEmpty ValidationError) () -> TestTree
+invoice_case name dat expected result = testCase name $
+ case invoice_features dat of
+ Nothing -> assertFailure "invalid bech32 data"
+ Just fv -> do
+ set_bits fv @?= expected
+ validate_remote InvoiceContext fv @?= result
+
+invoice_tests :: TestTree
+invoice_tests = testGroup "BOLT #11 invoice features" [
+ invoice_case "features 8, 14 and 99" "sqqqqqqqqqqqqqqqqsgq"
+ [8, 14, 99] (Right ())
+ , invoice_case "payment metadata (8, 14, 48)" "gqqqqqqsgq"
+ [8, 14, 48] (Right ())
+ , invoice_case "high-S signature example (8, 14)" "sgq"
+ [8, 14] (Right ())
+ , invoice_case "invalid unknown feature 100" "psqqqqqqqqqqqqqqqqsgq"
+ [8, 14, 99, 100] (Left (UnknownBit 100 :| []))
+ , testCase "a writer may set 8, 14 and 48" $
+ validate_local InvoiceContext (bits [8, 14, 48]) @?= Right ()
]
--- Long vector tests -----------------------------------------------------------
-
--- | A vector of (n + 1) bytes whose most significant byte is b.
-longVector :: Int -> Word8 -> FeatureVector
-longVector n b = parse (BS.cons b (BS.replicate n 0))
-
-longVectorTests :: TestTree
-longVectorTests = testGroup "Long vectors" [
- testCase "bit 65536 is reported without wrapping" $ do
- let fv = longVector 8192 0x01
- setBits fv @?= [65536]
- highestSetBit fv @?= Just 65536
- validateRemote Init fv @?= Left [UnknownRequiredBit 65536]
-
- , testCase "bit 65538 is reported as itself" $
- validateRemote Init (longVector 8192 0x04) @?=
- Left [UnknownRequiredBit 65538]
-
- , testCase "bit 65552 does not alias basic_mpp" $
- validateRemote Init (longVector 8194 0x01) @?=
- Left [UnknownRequiredBit 65552]
-
- , testCase "max-length vector, top odd bit accepted" $ do
- let fv = longVector 65534 0x80
- setBits fv @?= [524279]
- highestSetBit fv @?= Just 524279
- validateRemote Init fv @?= Right ()
-
- , testCase "max-length vector, top even bit rejected" $
- validateRemote Init (longVector 65534 0x40) @?=
- Left [UnknownRequiredBit 524278]
+-- channel types -------------------------------------------------------------
+
+all_channel_types :: [ChannelType]
+all_channel_types =
+ [ ChannelType b s z
+ | b <- [BasicStaticRemotekey, BasicAnchors, BasicZeroFeeCommitments]
+ , s <- [False, True]
+ , z <- [False, True] ]
+
+channel_type_tests :: TestTree
+channel_type_tests = testGroup "channel types" [
+ testCase "every defined type round-trips" $
+ mapM_ (\ct -> channel_type (channel_type_features ct) @?= Just ct)
+ all_channel_types
+
+ , testCase "encodings" $ do
+ let enc b s z = render (channel_type_features (ChannelType b s z))
+ enc BasicStaticRemotekey False False @?= BS.pack [0x10, 0x00]
+ enc BasicAnchors False False @?= BS.pack [0x40, 0x10, 0x00]
+ enc BasicZeroFeeCommitments False False
+ @?= BS.pack [0x01, 0, 0, 0, 0, 0]
+ enc BasicAnchors True True
+ @?= BS.pack [0x04, 0x40, 0, 0, 0x40, 0x10, 0x00]
+
+ , testCase "exactly the twelve defined types decode" $ do
+ let candidates = [12, 13, 14, 22, 23, 40, 46, 47, 50, 51, 52]
+ decoded = [ ct | s <- subsequences candidates
+ , Just ct <- [channel_type (bits s)] ]
+ length decoded @?= 12
+ mapM_ (\ct -> assertBool (show ct) (ct `elem` all_channel_types))
+ decoded
+
+ , testCase "rejects undefined types" $
+ mapM_ (\s -> channel_type (bits s) @?= Nothing)
+ [ [], [13], [22], [23, 13], [12, 40], [12, 14], [46], [50]
+ , [12, 47], [12, 51], [12, 52], [40, 44] ]
+
+ , testCase "variations need no dependency closure" $
+ channel_type (bits [12, 50])
+ @?= Just (ChannelType BasicStaticRemotekey False True)
+
+ , testCase "leading zero bytes are ignored" $
+ channel_type (parse "\NUL\NUL\DLE\NUL")
+ @?= Just (ChannelType BasicStaticRemotekey False False)
]
--- Opposite bit tests ----------------------------------------------------------
-
--- | Look up a known feature by name, failing the test if absent.
-knownFeature :: String -> IO Feature
-knownFeature n = case featureByName n of
- Nothing -> assertFailure ("feature not found: " ++ n)
- Just f -> pure f
-
-oppositeBitTests :: TestTree
-oppositeBitTests = testGroup "Opposite bit" [
- testCase "setFeature Optional clears the required bit" $ do
- ps <- knownFeature "payment_secret"
- let fv = setFeature ps Optional (setFeature ps Required empty)
- setBits fv @?= [15]
- hasFeature ps fv @?= Just Optional
-
- , testCase "setFeature Required clears the optional bit" $ do
- ps <- knownFeature "payment_secret"
- let fv = setFeature ps Required (setBit 15 empty)
- setBits fv @?= [14]
- hasFeature ps fv @?= Just Required
-
- , testCase "setFeatureWithDeps keeps a set dependency's level" $ do
- ps <- knownFeature "payment_secret"
- mpp <- knownFeature "basic_mpp"
- let fv = setFeatureWithDeps mpp Optional
- (setFeature ps Required empty)
- hasFeature ps fv @?= Just Required
- hasFeature mpp fv @?= Just Optional
- validateLocal Init fv @?= Right ()
-
- , testCase "setFeatureForContext clears the opposite bit" $ do
- anc <- knownFeature "option_anchors"
- let start = setFeature anc Required empty
- case setFeatureForContext Init anc Optional start of
- Left e -> assertFailure (show e)
- Right fv -> do
- hasFeature anc fv @?= Just Optional
- validateNoBothBits fv @?= Right fv
-
- , testProperty "setFeature never sets both bits (any start)" $
- forAll genFeatureAndLevel $ \(f, lvl) bs ->
- let fv = setFeature f lvl (parse (BS.pack bs))
- b = featureBaseBit f
- in not (testBit b fv && testBit (b + 1) fv)
- && hasFeature f fv == Just lvl
-
- , testProperty "setFeature leaves other bits alone" $
- forAll genFeatureAndLevel $ \(f, lvl) bs ->
- let fv0 = parse (BS.pack bs)
- fv = setFeature f lvl fv0
- b = fromIntegral (featureBaseBit f)
+-- properties ----------------------------------------------------------------
+
+gen_bytes :: Gen ByteString
+gen_bytes = BS.pack <$> arbitrary
+
+gen_vector :: Gen FeatureVector
+gen_vector = parse <$> gen_bytes
+
+gen_feature :: Gen Feature
+gen_feature = elements known_features
+
+gen_level :: Gen FeatureLevel
+gen_level = elements [Required, Optional]
+
+-- | A bit index somewhat beyond the end of a vector.
+gen_index :: FeatureVector -> Gen Int
+gen_index fv = choose (0, 8 * BS.length (render fv) + 16)
+
+has_leading_zero :: FeatureVector -> Bool
+has_leading_zero fv = BS.take 1 (render fv) == BS.singleton 0
+
+properties :: TestTree
+properties = testGroup "properties" [
+ testProperty "render . parse == id" $
+ forAll gen_bytes $ \bs -> render (parse bs) === bs
+
+ , testProperty "equality ignores leading zero bytes" $
+ forAll gen_bytes $ \bs (Small k) ->
+ parse (BS.replicate k 0 <> bs) === parse bs
+
+ , testProperty "equality agrees with set_bits" $
+ forAll gen_vector $ \a -> forAll gen_vector $ \b ->
+ (a == b) === (set_bits a == set_bits b)
+
+ , testProperty "set_bits lists exactly the set bits, ascending" $
+ forAll gen_vector $ \fv ->
+ set_bits fv
+ === filter (`test_bit` fv) [0 .. 8 * BS.length (render fv) - 1]
+
+ , testProperty "set_bit sets only its bit" $
+ forAll gen_vector $ \fv -> forAll (gen_index fv) $ \i ->
+ let fv' = set_bit i fv
+ in test_bit i fv'
+ .&&. filter (/= i) (set_bits fv')
+ === filter (/= i) (set_bits fv)
+
+ , testProperty "clear_bit clears only its bit" $
+ forAll gen_vector $ \fv -> forAll (gen_index fv) $ \i ->
+ let fv' = clear_bit i fv
+ in not (test_bit i fv')
+ .&&. set_bits fv' === filter (/= i) (set_bits fv)
+
+ , testProperty "union is bitwise OR" $
+ forAll gen_vector $ \a -> forAll gen_vector $ \b ->
+ let u = union a b
+ n = 8 * max (BS.length (render a)) (BS.length (render b))
+ in fmap (`test_bit` u) [0 .. n - 1]
+ === fmap (\i -> test_bit i a || test_bit i b) [0 .. n - 1]
+
+ , testProperty "operations encode minimally" $
+ forAll gen_vector $ \a -> forAll gen_vector $ \b ->
+ forAll (gen_index a) $ \i ->
+ not (any has_leading_zero
+ [union a b, set_bit i a, clear_bit i a])
+
+ , testProperty "set_feature sets exactly one bit of the pair" $
+ forAll gen_vector $ \fv -> forAll gen_feature $ \f ->
+ forAll gen_level $ \l ->
+ let fv' = set_feature f l fv
+ b = feature_bit f
other = filter (\i -> i /= b && i /= b + 1)
- in other (setBits fv) === other (setBits fv0)
- ]
-
-isInvalidParity :: ValidationError -> Bool
-isInvalidParity (InvalidParity _ _) = True
-isInvalidParity _ = 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 (fromIntegral 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)
-
- , testProperty "setFeature then hasFeature" $
- forAll genFeatureAndLevel $ \(f, lvl) ->
- let fv = setFeature f lvl empty
- in hasFeature f fv == Just lvl
-
- , testProperty
- "setFeatureWithDeps passes validateLocal" $
- forAll genInitFeatureAndLevel $ \(f, lvl) ->
- let fv = setFeatureWithDeps f lvl empty
- in isRight (validateLocal Init fv)
-
- , testProperty "parse . render is identity" $
- \bs ->
- let stripped = BS.dropWhile (== 0) (BS.pack bs)
- fv = parse stripped
- in parse (render fv) == fv
-
- , testProperty
- "setFeature never sets both bits" $
- forAll genFeatureAndLevel $ \(f, lvl) ->
- let fv = setFeature f lvl empty
- in isRight (validateNoBothBits fv)
+ in test_feature f fv' === Just l
+ .&&. test_bit b fv' =/= test_bit (b + 1) fv'
+ .&&. other (set_bits fv') === other (set_bits fv)
+
+ , testProperty "vectors built with set_feature_with_deps validate" $
+ forAll (elements (filter (/= ChannelTypeContext) contexts)) $ \c ->
+ forAll (gen_presented c) $ \fs ->
+ let fv = foldr (\(f, l) -> set_feature_with_deps f l) empty fs
+ in validate_local c fv === Right ()
+ .&&. validate_remote c fv === Right ()
]
--- | Generate a random known feature and level.
-genFeatureAndLevel :: Gen (Feature, FeatureLevel)
-genFeatureAndLevel = do
- f <- elements knownFeatures
- lvl <- elements [Required, Optional]
- pure (f, lvl)
-
--- | Generate a feature valid in Init context with a level.
-genInitFeatureAndLevel :: Gen (Feature, FeatureLevel)
-genInitFeatureAndLevel = do
- f <- elements initFeatures
- lvl <- elements [Required, Optional]
- pure (f, lvl)
+-- | Features presented in a context, each with a level.
+gen_presented :: Context -> Gen [(Feature, FeatureLevel)]
+gen_presented c = do
+ fs <- sublistOf (filter presented known_features)
+ traverse (\f -> (,) f <$> gen_level) fs
where
- initFeatures =
- filter validForInit knownFeatures
- validForInit f =
- null (featureContexts f)
- || Init `elem` featureContexts f
-
--- | Remove duplicates from a list.
-removeDups :: Eq a => [a] -> [a]
-removeDups [] = []
-removeDups (x:xs) = x : removeDups (filter (/= x) xs)
+ presented f = case feature_contexts f of
+ [] -> c `elem` [InitContext, NodeContext, InvoiceContext]
+ cs -> c `elem` cs
