Main.hs (18967B)
1 {-# LANGUAGE OverloadedStrings #-} 2 {-# LANGUAGE ScopedTypeVariables #-} 3 4 module Main where 5 6 import qualified Data.ByteString as BS 7 import Data.Either (isLeft, isRight) 8 import Data.Maybe (isJust, isNothing) 9 import Data.Word (Word16) 10 import Lightning.Protocol.BOLT9 11 import Test.Tasty 12 import Test.Tasty.HUnit 13 import Test.Tasty.QuickCheck 14 15 main :: IO () 16 main = defaultMain tests 17 18 tests :: TestTree 19 tests = testGroup "ppad-bolt9" [ 20 featureTableTests 21 , bitParityTests 22 , featureVectorTests 23 , validationTests 24 , knownFeatureTests 25 , setFeatureWithDepsTests 26 , setFeatureForContextTests 27 , validateNoBothBitsTests 28 , propertyTests 29 ] 30 31 -- Feature table tests --------------------------------------------------------- 32 33 featureTableTests :: TestTree 34 featureTableTests = testGroup "Feature table" [ 35 testCase "all features have even baseBit" $ 36 all (even . featureBaseBit) knownFeatures @?= True 37 38 , testCase "featureByBit works for even bit" $ 39 case featureByBit 14 of 40 Nothing -> assertFailure "expected to find payment_secret" 41 Just f -> featureName f @?= "payment_secret" 42 43 , testCase "featureByBit works for odd bit" $ 44 case featureByBit 15 of 45 Nothing -> assertFailure "expected to find payment_secret" 46 Just f -> featureName f @?= "payment_secret" 47 48 , testCase "featureByBit returns Nothing for unknown bit" $ 49 featureByBit 100 @?= Nothing 50 51 , testCase "featureByName finds known features" $ do 52 isJust (featureByName "var_onion_optin") @?= True 53 isJust (featureByName "payment_secret") @?= True 54 isJust (featureByName "basic_mpp") @?= True 55 56 , testCase "featureByName returns Nothing for unknown names" $ 57 featureByName "nonexistent_feature" @?= Nothing 58 59 , testCase "assumed features are present" $ do 60 let assumedNames = [ "option_data_loss_protect" 61 , "var_onion_optin" 62 , "option_static_remotekey" 63 , "payment_secret" 64 , "option_channel_type" 65 ] 66 mapM_ (\n -> isJust (featureByName n) @? 67 ("assumed feature missing: " ++ n)) assumedNames 68 69 , testCase "assumed features are marked as assumed" $ do 70 let checkAssumed n = case featureByName n of 71 Nothing -> assertFailure $ "feature not found: " ++ n 72 Just f -> featureAssumed f @?= True 73 mapM_ checkAssumed [ "option_data_loss_protect" 74 , "var_onion_optin" 75 , "option_static_remotekey" 76 , "payment_secret" 77 , "option_channel_type" 78 ] 79 ] 80 81 -- Bit parity tests ------------------------------------------------------------ 82 83 bitParityTests :: TestTree 84 bitParityTests = testGroup "Bit parity" [ 85 testCase "requiredBit accepts even numbers" $ do 86 isJust (requiredBit 0) @?= True 87 isJust (requiredBit 2) @?= True 88 isJust (requiredBit 100) @?= True 89 90 , testCase "requiredBit rejects odd numbers" $ do 91 isNothing (requiredBit 1) @?= True 92 isNothing (requiredBit 3) @?= True 93 isNothing (requiredBit 101) @?= True 94 95 , testCase "optionalBit accepts odd numbers" $ do 96 isJust (optionalBit 1) @?= True 97 isJust (optionalBit 3) @?= True 98 isJust (optionalBit 101) @?= True 99 100 , testCase "optionalBit rejects even numbers" $ do 101 isNothing (optionalBit 0) @?= True 102 isNothing (optionalBit 2) @?= True 103 isNothing (optionalBit 100) @?= True 104 105 , testCase "requiredBit smart constructor preserves value" $ 106 case requiredBit 42 of 107 Nothing -> assertFailure "expected Just" 108 Just rb -> unRequiredBit rb @?= 42 109 110 , testCase "optionalBit smart constructor preserves value" $ 111 case optionalBit 43 of 112 Nothing -> assertFailure "expected Just" 113 Just ob -> unOptionalBit ob @?= 43 114 ] 115 116 -- FeatureVector tests --------------------------------------------------------- 117 118 featureVectorTests :: TestTree 119 featureVectorTests = testGroup "FeatureVector" [ 120 testCase "empty has no bits set" $ do 121 unFeatureVector empty @?= BS.empty 122 member (bitIndex 0) empty @?= False 123 member (bitIndex 100) empty @?= False 124 125 , testCase "set adds a bit" $ do 126 let fv = set (bitIndex 0) empty 127 member (bitIndex 0) fv @?= True 128 129 , testCase "set multiple bits" $ do 130 let fv = set (bitIndex 8) (set (bitIndex 0) empty) 131 member (bitIndex 0) fv @?= True 132 member (bitIndex 8) fv @?= True 133 member (bitIndex 1) fv @?= False 134 135 , testCase "clear removes a bit" $ do 136 let fv = set (bitIndex 5) empty 137 fv' = clear (bitIndex 5) fv 138 member (bitIndex 5) fv @?= True 139 member (bitIndex 5) fv' @?= False 140 141 , testCase "clear on unset bit is no-op" $ do 142 let fv = clear (bitIndex 10) empty 143 unFeatureVector fv @?= BS.empty 144 145 , testCase "member returns False for unset bits" $ do 146 let fv = set (bitIndex 4) empty 147 member (bitIndex 0) fv @?= False 148 member (bitIndex 1) fv @?= False 149 member (bitIndex 5) fv @?= False 150 151 , testCase "render strips leading zeros" $ do 152 let fv = set (bitIndex 0) empty 153 render fv @?= BS.pack [0x01] 154 155 , testCase "render handles high bits correctly" $ do 156 let fv = set (bitIndex 15) empty 157 render fv @?= BS.pack [0x80, 0x00] 158 159 , testCase "render of empty is empty" $ 160 render empty @?= BS.empty 161 ] 162 163 -- Validation tests ------------------------------------------------------------ 164 165 validationTests :: TestTree 166 validationTests = testGroup "Validation" [ 167 testCase "BothBitsSet error when both bits of a pair are set" $ do 168 let baseBit = 14 -- payment_secret 169 fv = setBit (baseBit + 1) (setBit baseBit empty) 170 case validateLocal Init fv of 171 Right () -> assertFailure "expected BothBitsSet error" 172 Left errs -> any isBothBitsSet errs @?= True 173 174 , testCase "MissingDependency error when dep not set" $ do 175 -- basic_mpp (16) depends on payment_secret (14) 176 case featureByName "basic_mpp" of 177 Nothing -> assertFailure "basic_mpp not found" 178 Just f -> do 179 let fv = setBit (featureBaseBit f) empty 180 case validateLocal Init fv of 181 Right () -> assertFailure "expected MissingDependency error" 182 Left errs -> any isMissingDependency errs @?= True 183 184 , testCase "ContextNotAllowed error for wrong context" $ do 185 -- option_payment_metadata (48) is only allowed in Invoice context 186 case featureByName "option_payment_metadata" of 187 Nothing -> assertFailure "option_payment_metadata not found" 188 Just f -> do 189 let fv = setBit (featureBaseBit f) empty 190 case validateLocal Init fv of 191 Right () -> assertFailure "expected ContextNotAllowed error" 192 Left errs -> any isContextNotAllowed errs @?= True 193 194 , testCase "Remote validation accepts unknown optional bits" $ do 195 -- bit 201 is unknown and odd (optional) 196 let fv = setBit 201 empty 197 validateRemote Init fv @?= Right () 198 199 , testCase "Remote validation rejects unknown required bits" $ do 200 -- bit 200 is unknown and even (required) 201 let fv = setBit 200 empty 202 case validateRemote Init fv of 203 Right () -> assertFailure "expected UnknownRequiredBit error" 204 Left errs -> any isUnknownRequiredBit errs @?= True 205 206 , testCase "Valid local vector passes validation" $ do 207 -- payment_secret (14) with its required bit set 208 case featureByName "payment_secret" of 209 Nothing -> assertFailure "payment_secret not found" 210 Just f -> do 211 let fv = setBit (featureBaseBit f) empty 212 validateLocal Init fv @?= Right () 213 214 , testCase "Valid feature with dependency passes" $ do 215 -- basic_mpp (16) with payment_secret (14) dependency set 216 case (featureByName "basic_mpp", featureByName "payment_secret") of 217 (Just mpp, Just ps) -> do 218 let fv = setBit (featureBaseBit mpp) 219 $ setBit (featureBaseBit ps) empty 220 validateLocal Init fv @?= Right () 221 _ -> assertFailure "features not found" 222 ] 223 224 isBothBitsSet :: ValidationError -> Bool 225 isBothBitsSet (BothBitsSet _ _) = True 226 isBothBitsSet _ = False 227 228 isMissingDependency :: ValidationError -> Bool 229 isMissingDependency (MissingDependency _ _) = True 230 isMissingDependency _ = False 231 232 isContextNotAllowed :: ValidationError -> Bool 233 isContextNotAllowed (ContextNotAllowed _ _) = True 234 isContextNotAllowed _ = False 235 236 isUnknownRequiredBit :: ValidationError -> Bool 237 isUnknownRequiredBit (UnknownRequiredBit _) = True 238 isUnknownRequiredBit _ = False 239 240 -- KnownFeature tests ----------------------------------------------------------- 241 242 knownFeatureTests :: TestTree 243 knownFeatureTests = testGroup "KnownFeature" [ 244 testCase "knownFeatureByBit finds known feature" $ 245 case knownFeatureByBit 16 of 246 Nothing -> assertFailure "expected basic_mpp" 247 Just kf -> 248 featureName (unKnownFeature kf) @?= "basic_mpp" 249 250 , testCase "knownFeatureByBit works for odd bit" $ 251 case knownFeatureByBit 17 of 252 Nothing -> assertFailure "expected basic_mpp" 253 Just kf -> 254 featureName (unKnownFeature kf) @?= "basic_mpp" 255 256 , testCase "knownFeatureByBit returns Nothing for unknown" $ 257 knownFeatureByBit 999 @?= Nothing 258 259 , testCase "knownFeatureByName finds known feature" $ 260 case knownFeatureByName "payment_secret" of 261 Nothing -> assertFailure "expected payment_secret" 262 Just kf -> 263 featureBaseBit (unKnownFeature kf) @?= 14 264 265 , testCase "knownFeatureByName returns Nothing for unknown" $ 266 knownFeatureByName "nonexistent" @?= Nothing 267 ] 268 269 -- setFeatureWithDeps tests ----------------------------------------------------- 270 271 setFeatureWithDepsTests :: TestTree 272 setFeatureWithDepsTests = testGroup "setFeatureWithDeps" [ 273 testCase "sets feature and its dependency" $ do 274 case featureByName "basic_mpp" of 275 Nothing -> assertFailure "basic_mpp not found" 276 Just mpp -> do 277 let fv = setFeatureWithDeps mpp Optional empty 278 isFeatureSet mpp fv @?= True 279 -- payment_secret should also be set 280 case featureByName "payment_secret" of 281 Nothing -> 282 assertFailure "payment_secret not found" 283 Just ps -> isFeatureSet ps fv @?= True 284 285 , testCase "sets transitive dependencies" $ do 286 -- option_zeroconf depends on option_scid_alias 287 case featureByName "option_zeroconf" of 288 Nothing -> 289 assertFailure "option_zeroconf not found" 290 Just zc -> do 291 let fv = setFeatureWithDeps zc Required empty 292 isFeatureSet zc fv @?= True 293 case featureByName "option_scid_alias" of 294 Nothing -> 295 assertFailure "option_scid_alias not found" 296 Just sa -> isFeatureSet sa fv @?= True 297 298 , testCase "feature without deps sets only itself" $ do 299 case featureByName "payment_secret" of 300 Nothing -> 301 assertFailure "payment_secret not found" 302 Just ps -> do 303 let fv = setFeatureWithDeps ps Optional empty 304 isFeatureSet ps fv @?= True 305 -- no other features should be set 306 let others = filter 307 (\(f, _) -> featureName f /= "payment_secret") 308 (listFeatures fv) 309 null others @?= True 310 311 , testCase "passes validateLocal after setFeatureWithDeps" $ do 312 case featureByName "basic_mpp" of 313 Nothing -> assertFailure "basic_mpp not found" 314 Just mpp -> do 315 let fv = setFeatureWithDeps mpp Optional empty 316 validateLocal Init fv @?= Right () 317 ] 318 319 -- setFeatureForContext tests --------------------------------------------------- 320 321 setFeatureForContextTests :: TestTree 322 setFeatureForContextTests = testGroup "setFeatureForContext" [ 323 testCase "allows feature in valid context" $ do 324 case featureByName "option_payment_metadata" of 325 Nothing -> 326 assertFailure "option_payment_metadata not found" 327 Just pm -> 328 isRight 329 (setFeatureForContext Invoice pm Optional empty) 330 @?= True 331 332 , testCase "rejects feature in wrong context" $ do 333 case featureByName "option_payment_metadata" of 334 Nothing -> 335 assertFailure "option_payment_metadata not found" 336 Just pm -> 337 case setFeatureForContext Init pm Optional empty of 338 Right _ -> assertFailure "expected error" 339 Left err -> isContextNotAllowed err @?= True 340 341 , testCase "allows feature with empty context list" $ do 342 -- payment_secret has empty context list (all allowed) 343 case featureByName "payment_secret" of 344 Nothing -> 345 assertFailure "payment_secret not found" 346 Just ps -> 347 isRight 348 (setFeatureForContext Init ps Optional empty) 349 @?= True 350 351 , testCase "rejects Required in ChanAnnOdd context" $ do 352 case featureByName "payment_secret" of 353 Nothing -> 354 assertFailure "payment_secret not found" 355 Just ps -> 356 case setFeatureForContext 357 ChanAnnOdd ps Required empty of 358 Right _ -> assertFailure "expected parity error" 359 Left err -> isInvalidParity err @?= True 360 361 , testCase "allows Optional in ChanAnnOdd context" $ do 362 case featureByName "payment_secret" of 363 Nothing -> 364 assertFailure "payment_secret not found" 365 Just ps -> 366 isRight 367 (setFeatureForContext 368 ChanAnnOdd ps Optional empty) 369 @?= True 370 371 , testCase "rejects Optional in ChanAnnEven context" $ do 372 case featureByName "payment_secret" of 373 Nothing -> 374 assertFailure "payment_secret not found" 375 Just ps -> 376 case setFeatureForContext 377 ChanAnnEven ps Optional empty of 378 Right _ -> assertFailure "expected parity error" 379 Left err -> isInvalidParity err @?= True 380 381 , testCase "allows Required in ChanAnnEven context" $ do 382 case featureByName "payment_secret" of 383 Nothing -> 384 assertFailure "payment_secret not found" 385 Just ps -> 386 isRight 387 (setFeatureForContext 388 ChanAnnEven ps Required empty) 389 @?= True 390 ] 391 392 -- validateNoBothBits tests ----------------------------------------------------- 393 394 validateNoBothBitsTests :: TestTree 395 validateNoBothBitsTests = testGroup "validateNoBothBits" [ 396 testCase "passes for empty vector" $ 397 isRight (validateNoBothBits empty) @?= True 398 399 , testCase "passes when only one bit of pair is set" $ do 400 case featureByName "payment_secret" of 401 Nothing -> 402 assertFailure "payment_secret not found" 403 Just ps -> do 404 let fv = setFeature ps Optional empty 405 isRight (validateNoBothBits fv) @?= True 406 407 , testCase "fails when both bits of pair are set" $ do 408 let fv = setBit 15 (setBit 14 empty) 409 case validateNoBothBits fv of 410 Right _ -> assertFailure "expected BothBitsSet" 411 Left err -> isBothBitsSet err @?= True 412 413 , testCase "returns first error found" $ do 414 -- set both bits for two features 415 let fv = setBit 15 (setBit 14 416 (setBit 17 (setBit 16 empty))) 417 isLeft (validateNoBothBits fv) @?= True 418 ] 419 420 isInvalidParity :: ValidationError -> Bool 421 isInvalidParity (InvalidParity _ _) = True 422 isInvalidParity _ = False 423 424 -- Property tests -------------------------------------------------------------- 425 426 propertyTests :: TestTree 427 propertyTests = testGroup "Properties" [ 428 testProperty "render . parse == id for stripped ByteStrings" $ 429 \bs -> let stripped = BS.dropWhile (== 0) (BS.pack bs) 430 in render (parse stripped) === stripped 431 432 , testProperty "set then member returns True" $ 433 \(Small n) -> let idx = bitIndex (n `mod` 256) 434 fv = set idx empty 435 in member idx fv === True 436 437 , testProperty "clear then member returns False" $ 438 \(Small n) -> let idx = bitIndex (n `mod` 256) 439 fv = set idx empty 440 fv' = clear idx fv 441 in member idx fv' === False 442 443 , testProperty "setBits returns all set bits without duplicates" $ 444 \bs -> let fv = parse (BS.pack bs) 445 bits = setBits fv 446 -- Verify no duplicates and length matches unique count 447 in length bits === length (removeDups bits) 448 449 , testProperty "double set is idempotent" $ 450 \(Small n) -> let idx = bitIndex (n `mod` 256) 451 fv = set idx empty 452 fv' = set idx fv 453 in unFeatureVector fv === unFeatureVector fv' 454 455 , testProperty "set then clear restores original (when was unset)" $ 456 \(Small n) -> let idx = bitIndex (n `mod` 256) 457 fv = set idx empty 458 fv' = clear idx fv 459 in unFeatureVector fv' === BS.empty 460 461 , testProperty "member consistent with setBits" $ 462 \bs -> let fv = parse (BS.pack bs) 463 bits = setBits fv 464 in all (\b -> member (bitIndex b) fv) bits === True 465 466 , testProperty "requiredBit only succeeds for even" $ 467 \(n :: Word16) -> isJust (requiredBit n) === (n `mod` 2 == 0) 468 469 , testProperty "optionalBit only succeeds for odd" $ 470 \(n :: Word16) -> isJust (optionalBit n) === (n `mod` 2 == 1) 471 472 , testProperty "setFeature then hasFeature" $ 473 forAll genFeatureAndLevel $ \(f, lvl) -> 474 let fv = setFeature f lvl empty 475 in hasFeature f fv == Just lvl 476 477 , testProperty 478 "setFeatureWithDeps passes validateLocal" $ 479 forAll genInitFeatureAndLevel $ \(f, lvl) -> 480 let fv = setFeatureWithDeps f lvl empty 481 in isRight (validateLocal Init fv) 482 483 , testProperty "parse . render is identity" $ 484 \bs -> 485 let stripped = BS.dropWhile (== 0) (BS.pack bs) 486 fv = parse stripped 487 in parse (render fv) == fv 488 489 , testProperty 490 "setFeature never sets both bits" $ 491 forAll genFeatureAndLevel $ \(f, lvl) -> 492 let fv = setFeature f lvl empty 493 in isRight (validateNoBothBits fv) 494 ] 495 496 -- | Generate a random known feature and level. 497 genFeatureAndLevel :: Gen (Feature, FeatureLevel) 498 genFeatureAndLevel = do 499 f <- elements knownFeatures 500 lvl <- elements [Required, Optional] 501 pure (f, lvl) 502 503 -- | Generate a feature valid in Init context with a level. 504 genInitFeatureAndLevel :: Gen (Feature, FeatureLevel) 505 genInitFeatureAndLevel = do 506 f <- elements initFeatures 507 lvl <- elements [Required, Optional] 508 pure (f, lvl) 509 where 510 initFeatures = 511 filter validForInit knownFeatures 512 validForInit f = 513 null (featureContexts f) 514 || Init `elem` featureContexts f 515 516 -- | Remove duplicates from a list. 517 removeDups :: Eq a => [a] -> [a] 518 removeDups [] = [] 519 removeDups (x:xs) = x : removeDups (filter (/= x) xs)