Main.hs (22404B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import qualified Data.Bits as B 6 import Data.ByteString (ByteString) 7 import qualified Data.ByteString as BS 8 import Data.List (elemIndex, subsequences) 9 import Data.List.NonEmpty (NonEmpty(..)) 10 import Data.Word (Word8) 11 import Lightning.Protocol.BOLT9 12 import Test.Tasty 13 import Test.Tasty.HUnit 14 import Test.Tasty.QuickCheck 15 16 main :: IO () 17 main = defaultMain $ testGroup "ppad-bolt9" [ 18 table_tests 19 , vector_tests 20 , feature_tests 21 , local_tests 22 , remote_tests 23 , invoice_tests 24 , blinded_tests 25 , channel_type_tests 26 , properties 27 ] 28 29 -- feature table ------------------------------------------------------------- 30 31 -- | The BOLT #9 table at lightning/bolts@1aadb719: bits, name, whether 32 -- it is ASSUMED, the Context column, and the dependency names. 33 spec_table :: [(Int, String, Bool, String, [String])] 34 spec_table = [ 35 (0, "option_data_loss_protect", True, "", []) 36 , (4, "option_upfront_shutdown_script", False, "IN", []) 37 , (6, "gossip_queries", False, "", []) 38 , (8, "var_onion_optin", True, "", []) 39 , (10, "gossip_queries_ex", False, "IN", []) 40 , (12, "option_static_remotekey", True, "", []) 41 , (14, "payment_secret", True, "", []) 42 , (16, "basic_mpp", False, "IN9", ["payment_secret"]) 43 , (18, "option_support_large_channel", False, "IN", []) 44 , (22, "option_anchors", False, "INT", []) 45 , (24, "option_route_blinding", False, "IN9", []) 46 , (26, "option_shutdown_anysegwit", False, "IN", []) 47 , (28, "option_dual_fund", False, "IN", []) 48 , (34, "option_quiesce", False, "IN", []) 49 , (36, "option_attribution_data", False, "IN9", []) 50 , (38, "option_onion_messages", False, "IN", []) 51 , (40, "zero_fee_commitments", False, "IN", ["option_channel_type"]) 52 , (42, "option_provide_storage", False, "IN", []) 53 , (44, "option_channel_type", True, "", []) 54 , (46, "option_scid_alias", False, "INT", []) 55 , (48, "option_payment_metadata", False, "9", []) 56 , (50, "option_zeroconf", False, "INT", ["option_scid_alias"]) 57 , (60, "option_simple_close", False, "IN" 58 , ["option_shutdown_anysegwit"]) 59 , (62, "option_splice", False, "IN", []) 60 , (66, "option_onion_messages_only_channels", False, "IN" 61 , ["option_onion_messages"]) 62 ] 63 64 table_row :: Feature -> (Int, String, Bool, String, [String]) 65 table_row f = 66 ( feature_bit f 67 , feature_name f 68 , feature_assumed f 69 , concatMap letter (feature_contexts f) 70 , fmap feature_name (feature_dependencies f) ) 71 where 72 letter c = case c of 73 InitContext -> "I" 74 NodeContext -> "N" 75 ChannelContext -> "C" 76 InvoiceContext -> "9" 77 BlindedContext -> "B" 78 ChannelTypeContext -> "T" 79 80 table_tests :: TestTree 81 table_tests = testGroup "feature table" [ 82 testCase "matches the spec table" $ 83 fmap table_row known_features @?= spec_table 84 85 , testCase "feature_by_bit maps both bits to the feature" $ 86 mapM_ (\f -> do 87 feature_by_bit (feature_bit f) @?= Just f 88 feature_by_bit (feature_bit f + 1) @?= Just f) 89 known_features 90 91 , testCase "feature_by_bit rejects unassigned bits" $ do 92 let assigned = concatMap (\f -> [feature_bit f, feature_bit f + 1]) 93 known_features 94 free = filter (`notElem` assigned) [0 .. 600] 95 mapM_ (\i -> feature_by_bit i @?= Nothing) free 96 feature_by_bit (-1) @?= Nothing 97 feature_by_bit (-2) @?= Nothing 98 ] 99 100 -- feature vectors ----------------------------------------------------------- 101 102 -- | A vector of (n + 1) bytes whose most significant byte is b. 103 long_vector :: Int -> Word8 -> FeatureVector 104 long_vector n b = parse (BS.cons b (BS.replicate n 0)) 105 106 vector_tests :: TestTree 107 vector_tests = testGroup "feature vectors" [ 108 testCase "empty" $ do 109 render empty @?= "" 110 set_bits empty @?= [] 111 112 , testCase "render returns parsed bytes exactly" $ do 113 render (parse "\NUL\NUL\STX") @?= "\NUL\NUL\STX" 114 render (parse "\NUL") @?= "\NUL" 115 116 , testCase "equality ignores leading zero bytes" $ do 117 parse "\NUL\STX" @?= parse "\STX" 118 parse "\NUL\NUL" @?= empty 119 assertBool "distinct" (parse "\STX" /= parse "\SOH") 120 assertBool "distinct" (parse "\SOH\NUL" /= parse "\SOH") 121 122 , testCase "show" $ 123 show (parse "\NUL\STX") @?= "parse \"\\NUL\\STX\"" 124 125 , testCase "bit numbering" $ do 126 render (set_bit 0 empty) @?= "\SOH" 127 render (set_bit 7 empty) @?= "\128" 128 render (set_bit 8 empty) @?= "\SOH\NUL" 129 render (set_bit 17 empty) @?= "\STX\NUL\NUL" 130 set_bits (parse "\128\NUL\SOH") @?= [0, 23] 131 132 , testCase "operations encode minimally" $ do 133 render (set_bit 1 (parse "\NUL\NUL\SOH")) @?= "\ETX" 134 render (clear_bit 0 (parse "\NUL\SOH\SOH")) @?= "\SOH\NUL" 135 render (clear_bit 8 (parse "\SOH\SOH")) @?= "\SOH" 136 render (union (parse "\NUL\NUL") empty) @?= "" 137 138 , testCase "union" $ do 139 union (parse "\SOH\NUL") (parse "\STX") @?= parse "\SOH\STX" 140 union (parse "\STX") empty @?= parse "\STX" 141 set_bits (union (parse "\SOH\SOH") (parse "\128\SOH")) @?= [0, 8, 15] 142 143 , testCase "negative indices are ignored" $ do 144 set_bit (-1) (parse "\STX") @?= parse "\STX" 145 clear_bit (-1) (parse "\STX") @?= parse "\STX" 146 test_bit (-1) (parse "\255") @?= False 147 148 , testCase "clearing a bit beyond the vector is a no-op" $ 149 render (clear_bit 1000 (parse "\STX")) @?= "\STX" 150 151 , testCase "bit 65536 does not wrap" $ do 152 let fv = long_vector 8192 0x01 153 set_bits fv @?= [65536] 154 test_bit 65536 fv @?= True 155 test_bit 0 fv @?= False 156 157 , testCase "bits of a maximum-length vector" $ do 158 let fv = long_vector 65534 0x80 159 BS.length (render fv) @?= 65535 160 set_bits fv @?= [524279] 161 set_bit 524279 empty @?= fv 162 clear_bit 524279 fv @?= empty 163 ] 164 165 -- feature operations -------------------------------------------------------- 166 167 feature_tests :: TestTree 168 feature_tests = testGroup "feature operations" [ 169 testCase "set_feature sets the bit for its level" $ do 170 set_bits (set_feature BasicMpp Required empty) @?= [16] 171 set_bits (set_feature BasicMpp Optional empty) @?= [17] 172 173 , testCase "set_feature clears the other bit" $ do 174 set_bits (set_feature PaymentSecret Optional (set_bit 14 empty)) 175 @?= [15] 176 set_bits (set_feature PaymentSecret Required (set_bit 15 empty)) 177 @?= [14] 178 179 , testCase "set_feature leaves other features alone" $ 180 set_bits (set_feature BasicMpp Optional (parse "\STX\NUL")) 181 @?= [9, 17] 182 183 , testCase "clear_feature clears both bits" $ do 184 clear_feature BasicMpp (set_bit 16 (set_bit 17 empty)) @?= empty 185 clear_feature BasicMpp (set_bit 9 (set_bit 17 empty)) 186 @?= set_bit 9 empty 187 188 , testCase "test_feature" $ do 189 test_feature BasicMpp (set_bit 16 empty) @?= Just Required 190 test_feature BasicMpp (set_bit 17 empty) @?= Just Optional 191 test_feature BasicMpp (set_bit 16 (set_bit 17 empty)) 192 @?= Just Required 193 test_feature BasicMpp (set_bit 18 empty) @?= Nothing 194 195 , testCase "list_features is in bit order and skips unknown bits" $ 196 list_features (set_bit 100 (set_bit 51 (set_bit 46 (set_bit 15 empty)))) 197 @?= [ (PaymentSecret, Optional), (OptionScidAlias, Required) 198 , (OptionZeroconf, Optional) ] 199 200 , testCase "set_feature_with_deps sets dependencies" $ do 201 list_features (set_feature_with_deps OptionZeroconf Required empty) 202 @?= [(OptionScidAlias, Required), (OptionZeroconf, Required)] 203 list_features (set_feature_with_deps ZeroFeeCommitments Optional empty) 204 @?= [(ZeroFeeCommitments, Optional), (OptionChannelType, Optional)] 205 206 , testCase "set_feature_with_deps keeps a set dependency's level" $ 207 list_features 208 (set_feature_with_deps OptionSimpleClose Optional 209 (set_feature OptionShutdownAnysegwit Required empty)) 210 @?= [ (OptionShutdownAnysegwit, Required) 211 , (OptionSimpleClose, Optional) ] 212 ] 213 214 -- local validation ---------------------------------------------------------- 215 216 -- | A vector with the given bits set. 217 bits :: [Int] -> FeatureVector 218 bits = foldr set_bit empty 219 220 contexts :: [Context] 221 contexts = 222 [ InitContext, NodeContext, ChannelContext, InvoiceContext 223 , BlindedContext, ChannelTypeContext ] 224 225 local_tests :: TestTree 226 local_tests = testGroup "validate_local" [ 227 testCase "empty is valid in every context but channel_type" $ do 228 mapM_ (\c -> validate_local c empty @?= Right ()) 229 (filter (/= ChannelTypeContext) contexts) 230 validate_local ChannelTypeContext empty 231 @?= Left (InvalidChannelType :| []) 232 233 , testCase "rejects unknown bits, odd or even" $ do 234 validate_local InitContext (bits [20, 101]) 235 @?= Left (UnknownBit 20 :| [UnknownBit 101]) 236 validate_local NodeContext (bits [200]) @?= Left (UnknownBit 200 :| []) 237 238 , testCase "rejects both bits set" $ 239 validate_local InitContext (bits [46, 47]) 240 @?= Left (BothBitsSet OptionScidAlias :| []) 241 242 , testCase "rejects features outside their contexts" $ do 243 validate_local InitContext (bits [49]) 244 @?= Left (ContextNotAllowed OptionPaymentMetadata InitContext :| []) 245 validate_local InvoiceContext (bits [23]) 246 @?= Left (ContextNotAllowed OptionAnchors InvoiceContext :| []) 247 validate_local ChannelContext (bits [17, 15]) 248 @?= Left (ContextNotAllowed PaymentSecret ChannelContext 249 :| [ContextNotAllowed BasicMpp ChannelContext]) 250 251 , testCase "accepts features in their contexts" $ do 252 validate_local InvoiceContext (bits [49]) @?= Right () 253 validate_local NodeContext (bits [23, 47]) @?= Right () 254 validate_local InitContext (bits [63, 67, 39]) @?= Right () 255 256 , testCase "empty-context features: accepted in I, N and 9 only" $ do 257 let fv = bits [1, 7, 9, 13, 15, 45] 258 mapM_ (\c -> validate_local c fv @?= Right ()) 259 [InitContext, NodeContext, InvoiceContext] 260 validate_local ChannelContext (bits [9]) 261 @?= Left (ContextNotAllowed VarOnionOptin ChannelContext :| []) 262 validate_local BlindedContext (bits [15]) 263 @?= Left (ContextNotAllowed PaymentSecret BlindedContext :| []) 264 265 , testCase "allowed_features must be empty" $ 266 validate_local BlindedContext (bits [17]) 267 @?= Left (ContextNotAllowed BasicMpp BlindedContext :| []) 268 269 , testCase "rejects missing dependencies" $ do 270 validate_local InitContext (bits [51]) 271 @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| []) 272 validate_local InitContext (bits [61]) 273 @?= Left (MissingDependency OptionSimpleClose 274 OptionShutdownAnysegwit :| []) 275 validate_local NodeContext (bits [67]) 276 @?= Left (MissingDependency OptionOnionMessagesOnlyChannels 277 OptionOnionMessages :| []) 278 279 , testCase "dependencies on ASSUMED features count as met" $ do 280 validate_local InitContext (bits [17]) @?= Right () 281 validate_local InvoiceContext (bits [16]) @?= Right () 282 validate_local InitContext (bits [41]) @?= Right () 283 284 , testCase "reports errors in rule order" $ 285 validate_local InitContext (bits [20, 22, 23, 48, 61]) 286 @?= Left (UnknownBit 20 :| 287 [ BothBitsSet OptionAnchors 288 , ContextNotAllowed OptionPaymentMetadata InitContext 289 , MissingDependency OptionSimpleClose 290 OptionShutdownAnysegwit ]) 291 292 , testCase "channel_type follows BOLT #2, not the generic rules" $ do 293 validate_local ChannelTypeContext (bits [12, 50]) @?= Right () 294 validate_local ChannelTypeContext (bits [12, 23]) 295 @?= Left (InvalidChannelType :| []) 296 ] 297 298 -- remote validation --------------------------------------------------------- 299 300 remote_tests :: TestTree 301 remote_tests = testGroup "validate_remote" [ 302 testCase "init: unknown odd bits are ignored" $ 303 validate_remote InitContext (bits [101, 201]) @?= Right () 304 305 , testCase "init: unknown even bits are rejected" $ 306 validate_remote InitContext (bits [20, 100, 101]) 307 @?= Left (UnknownBit 20 :| [UnknownBit 100]) 308 309 , testCase "init: missing dependencies are rejected" $ do 310 validate_remote InitContext (bits [51]) 311 @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| []) 312 validate_remote InitContext (bits [60]) 313 @?= Left (MissingDependency OptionSimpleClose 314 OptionShutdownAnysegwit :| []) 315 validate_remote InitContext (bits [51, 47]) @?= Right () 316 317 , testCase "init: ASSUMED dependencies count as met" $ do 318 validate_remote InitContext (bits [17]) @?= Right () 319 validate_remote InitContext (bits [40]) @?= Right () 320 321 , testCase "init: both bits set is not an error" $ 322 validate_remote InitContext (bits [46, 47]) @?= Right () 323 324 , testCase "init: known features outside their contexts pass" $ 325 validate_remote InitContext (bits [49]) @?= Right () 326 327 , testCase "node and channel announcements: unknown even bits" $ do 328 validate_remote NodeContext (bits [100]) 329 @?= Left (UnknownBit 100 :| []) 330 validate_remote ChannelContext (bits [100]) 331 @?= Left (UnknownBit 100 :| []) 332 validate_remote NodeContext (bits [101]) @?= Right () 333 validate_remote ChannelContext (bits [101]) @?= Right () 334 335 , testCase "node and channel announcements: no dependency rule" $ do 336 validate_remote NodeContext (bits [51]) @?= Right () 337 validate_remote ChannelContext (bits [51]) @?= Right () 338 339 , testCase "invoice: unknown even bits and dependencies" $ do 340 validate_remote InvoiceContext (bits [100]) 341 @?= Left (UnknownBit 100 :| []) 342 validate_remote InvoiceContext (bits [51]) 343 @?= Left (MissingDependency OptionZeroconf OptionScidAlias :| []) 344 validate_remote InvoiceContext (bits [101, 17]) @?= Right () 345 346 , testCase "blinded path: any unknown bit is rejected" $ do 347 validate_remote BlindedContext (bits [101]) 348 @?= Left (UnknownBit 101 :| []) 349 validate_remote BlindedContext (bits [100]) 350 @?= Left (UnknownBit 100 :| []) 351 validate_remote BlindedContext (bits [15, 17]) @?= Right () 352 validate_remote BlindedContext empty @?= Right () 353 354 , testCase "channel_type: must be a defined type" $ do 355 validate_remote ChannelTypeContext (bits [12, 22]) @?= Right () 356 validate_remote ChannelTypeContext (bits [22]) 357 @?= Left (InvalidChannelType :| []) 358 359 , testCase "bits above 65535 do not wrap" $ do 360 validate_remote InitContext (long_vector 8192 0x01) 361 @?= Left (UnknownBit 65536 :| []) 362 validate_remote InitContext (long_vector 8192 0x04) 363 @?= Left (UnknownBit 65538 :| []) 364 validate_remote InitContext (long_vector 8194 0x01) 365 @?= Left (UnknownBit 65552 :| []) 366 367 , testCase "maximum-length vectors" $ do 368 validate_remote InitContext (long_vector 65534 0x80) @?= Right () 369 validate_remote InitContext (long_vector 65534 0x40) 370 @?= Left (UnknownBit 524278 :| []) 371 ] 372 373 -- BOLT #11 vectors ---------------------------------------------------------- 374 375 -- | The feature vector carried by a BOLT #11 @9@ field, given the 376 -- field's data as bech32 characters. 377 invoice_features :: String -> Maybe FeatureVector 378 invoice_features cs = do 379 vs <- traverse (`elemIndex` charset) cs 380 let n = length vs 381 pure $ bits 382 [ (n - 1 - k) * 5 + j 383 | (k, v) <- zip [0 ..] vs, j <- [0 .. 4], B.testBit v j ] 384 where 385 charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" 386 387 invoice_case 388 :: String -> String -> [Int] 389 -> Either (NonEmpty ValidationError) () -> TestTree 390 invoice_case name dat expected result = testCase name $ 391 case invoice_features dat of 392 Nothing -> assertFailure "invalid bech32 data" 393 Just fv -> do 394 set_bits fv @?= expected 395 validate_remote InvoiceContext fv @?= result 396 397 invoice_tests :: TestTree 398 invoice_tests = testGroup "BOLT #11 invoice features" [ 399 invoice_case "features 8, 14 and 99" "sqqqqqqqqqqqqqqqqsgq" 400 [8, 14, 99] (Right ()) 401 , invoice_case "payment metadata (8, 14, 48)" "gqqqqqqsgq" 402 [8, 14, 48] (Right ()) 403 , invoice_case "high-S signature example (8, 14)" "sgq" 404 [8, 14] (Right ()) 405 , invoice_case "invalid unknown feature 100" "psqqqqqqqqqqqqqqqqsgq" 406 [8, 14, 99, 100] (Left (UnknownBit 100 :| [])) 407 , testCase "a writer may set 8, 14 and 48" $ 408 validate_local InvoiceContext (bits [8, 14, 48]) @?= Right () 409 ] 410 411 -- BOLT #4 vectors ----------------------------------------------------------- 412 413 -- | allowed_features from bolt04/route-blinding-test.json. 414 blinded_tests :: TestTree 415 blinded_tests = testGroup "BOLT #4 allowed_features" [ 416 testCase "features [] (Bob, Carol, Dave)" $ do 417 set_bits (parse "") @?= [] 418 validate_remote BlindedContext (parse "") @?= Right () 419 420 , testCase "features [113] (Eve)" $ do 421 let fv = parse (BS.pack (0x02 : replicate 14 0)) 422 set_bits fv @?= [113] 423 validate_remote BlindedContext fv @?= Left (UnknownBit 113 :| []) 424 validate_local BlindedContext fv @?= Left (UnknownBit 113 :| []) 425 ] 426 427 -- channel types ------------------------------------------------------------- 428 429 all_channel_types :: [ChannelType] 430 all_channel_types = 431 [ ChannelType b s z 432 | b <- [BasicStaticRemotekey, BasicAnchors, BasicZeroFeeCommitments] 433 , s <- [False, True] 434 , z <- [False, True] ] 435 436 channel_type_tests :: TestTree 437 channel_type_tests = testGroup "channel types" [ 438 testCase "every defined type round-trips" $ 439 mapM_ (\ct -> channel_type (channel_type_features ct) @?= Just ct) 440 all_channel_types 441 442 , testCase "encodings" $ do 443 let enc b s z = render (channel_type_features (ChannelType b s z)) 444 enc BasicStaticRemotekey False False @?= BS.pack [0x10, 0x00] 445 enc BasicAnchors False False @?= BS.pack [0x40, 0x10, 0x00] 446 enc BasicZeroFeeCommitments False False 447 @?= BS.pack [0x01, 0, 0, 0, 0, 0] 448 enc BasicAnchors True True 449 @?= BS.pack [0x04, 0x40, 0, 0, 0x40, 0x10, 0x00] 450 451 , testCase "exactly the twelve defined types decode" $ do 452 let candidates = [12, 13, 14, 22, 23, 40, 46, 47, 50, 51, 52] 453 decoded = [ ct | s <- subsequences candidates 454 , Just ct <- [channel_type (bits s)] ] 455 length decoded @?= 12 456 mapM_ (\ct -> assertBool (show ct) (ct `elem` all_channel_types)) 457 decoded 458 459 , testCase "rejects undefined types" $ 460 mapM_ (\s -> channel_type (bits s) @?= Nothing) 461 [ [], [13], [22], [23, 13], [12, 40], [12, 14], [46], [50] 462 , [12, 47], [12, 51], [12, 52], [40, 44] ] 463 464 , testCase "variations need no dependency closure" $ 465 channel_type (bits [12, 50]) 466 @?= Just (ChannelType BasicStaticRemotekey False True) 467 468 , testCase "leading zero bytes are ignored" $ 469 channel_type (parse "\NUL\NUL\DLE\NUL") 470 @?= Just (ChannelType BasicStaticRemotekey False False) 471 ] 472 473 -- properties ---------------------------------------------------------------- 474 475 gen_bytes :: Gen ByteString 476 gen_bytes = BS.pack <$> arbitrary 477 478 gen_vector :: Gen FeatureVector 479 gen_vector = parse <$> gen_bytes 480 481 gen_feature :: Gen Feature 482 gen_feature = elements known_features 483 484 gen_level :: Gen FeatureLevel 485 gen_level = elements [Required, Optional] 486 487 -- | A bit index somewhat beyond the end of a vector. 488 gen_index :: FeatureVector -> Gen Int 489 gen_index fv = choose (0, 8 * BS.length (render fv) + 16) 490 491 has_leading_zero :: FeatureVector -> Bool 492 has_leading_zero fv = BS.take 1 (render fv) == BS.singleton 0 493 494 properties :: TestTree 495 properties = testGroup "properties" [ 496 testProperty "render . parse == id" $ 497 forAll gen_bytes $ \bs -> render (parse bs) === bs 498 499 , testProperty "equality ignores leading zero bytes" $ 500 forAll gen_bytes $ \bs (Small k) -> 501 parse (BS.replicate k 0 <> bs) === parse bs 502 503 , testProperty "equality agrees with set_bits" $ 504 forAll gen_vector $ \a -> forAll gen_vector $ \b -> 505 (a == b) === (set_bits a == set_bits b) 506 507 , testProperty "set_bits lists exactly the set bits, ascending" $ 508 forAll gen_vector $ \fv -> 509 set_bits fv 510 === filter (`test_bit` fv) [0 .. 8 * BS.length (render fv) - 1] 511 512 , testProperty "set_bit sets only its bit" $ 513 forAll gen_vector $ \fv -> forAll (gen_index fv) $ \i -> 514 let fv' = set_bit i fv 515 in test_bit i fv' 516 .&&. filter (/= i) (set_bits fv') 517 === filter (/= i) (set_bits fv) 518 519 , testProperty "clear_bit clears only its bit" $ 520 forAll gen_vector $ \fv -> forAll (gen_index fv) $ \i -> 521 let fv' = clear_bit i fv 522 in not (test_bit i fv') 523 .&&. set_bits fv' === filter (/= i) (set_bits fv) 524 525 , testProperty "union is bitwise OR" $ 526 forAll gen_vector $ \a -> forAll gen_vector $ \b -> 527 let u = union a b 528 n = 8 * max (BS.length (render a)) (BS.length (render b)) 529 in fmap (`test_bit` u) [0 .. n - 1] 530 === fmap (\i -> test_bit i a || test_bit i b) [0 .. n - 1] 531 532 , testProperty "operations encode minimally" $ 533 forAll gen_vector $ \a -> forAll gen_vector $ \b -> 534 forAll (gen_index a) $ \i -> 535 not (any has_leading_zero 536 [union a b, set_bit i a, clear_bit i a]) 537 538 , testProperty "set_feature sets exactly one bit of the pair" $ 539 forAll gen_vector $ \fv -> forAll gen_feature $ \f -> 540 forAll gen_level $ \l -> 541 let fv' = set_feature f l fv 542 b = feature_bit f 543 other = filter (\i -> i /= b && i /= b + 1) 544 in test_feature f fv' === Just l 545 .&&. test_bit b fv' =/= test_bit (b + 1) fv' 546 .&&. other (set_bits fv') === other (set_bits fv) 547 548 , testProperty "vectors built with set_feature_with_deps validate" $ 549 forAll (elements (filter (/= ChannelTypeContext) contexts)) $ \c -> 550 forAll (gen_presented c) $ \fs -> 551 let fv = foldr (\(f, l) -> set_feature_with_deps f l) empty fs 552 in validate_local c fv === Right () 553 .&&. validate_remote c fv === Right () 554 ] 555 556 -- | Features presented in a context, each with a level. 557 gen_presented :: Context -> Gen [(Feature, FeatureLevel)] 558 gen_presented c = do 559 fs <- sublistOf (filter presented known_features) 560 traverse (\f -> (,) f <$> gen_level) fs 561 where 562 presented f = case feature_contexts f of 563 [] -> c `elem` [InitContext, NodeContext, InvoiceContext] 564 cs -> c `elem` cs