Main.hs (10654B)
1 {-# LANGUAGE OverloadedStrings #-} 2 {-# LANGUAGE ScopedTypeVariables #-} 3 4 module Main where 5 6 import qualified Data.ByteString as BS 7 import Data.Maybe (isJust, isNothing) 8 import Data.Word (Word16) 9 import Lightning.Protocol.BOLT9 10 import Test.Tasty 11 import Test.Tasty.HUnit 12 import Test.Tasty.QuickCheck 13 14 main :: IO () 15 main = defaultMain tests 16 17 tests :: TestTree 18 tests = testGroup "ppad-bolt9" [ 19 featureTableTests 20 , bitParityTests 21 , featureVectorTests 22 , validationTests 23 , propertyTests 24 ] 25 26 -- Feature table tests --------------------------------------------------------- 27 28 featureTableTests :: TestTree 29 featureTableTests = testGroup "Feature table" [ 30 testCase "all features have even baseBit" $ 31 all (even . featureBaseBit) knownFeatures @?= True 32 33 , testCase "featureByBit works for even bit" $ 34 case featureByBit 14 of 35 Nothing -> assertFailure "expected to find payment_secret" 36 Just f -> featureName f @?= "payment_secret" 37 38 , testCase "featureByBit works for odd bit" $ 39 case featureByBit 15 of 40 Nothing -> assertFailure "expected to find payment_secret" 41 Just f -> featureName f @?= "payment_secret" 42 43 , testCase "featureByBit returns Nothing for unknown bit" $ 44 featureByBit 100 @?= Nothing 45 46 , testCase "featureByName finds known features" $ do 47 isJust (featureByName "var_onion_optin") @?= True 48 isJust (featureByName "payment_secret") @?= True 49 isJust (featureByName "basic_mpp") @?= True 50 51 , testCase "featureByName returns Nothing for unknown names" $ 52 featureByName "nonexistent_feature" @?= Nothing 53 54 , testCase "assumed features are present" $ do 55 let assumedNames = [ "option_data_loss_protect" 56 , "var_onion_optin" 57 , "option_static_remotekey" 58 , "payment_secret" 59 , "option_channel_type" 60 ] 61 mapM_ (\n -> isJust (featureByName n) @? 62 ("assumed feature missing: " ++ n)) assumedNames 63 64 , testCase "assumed features are marked as assumed" $ do 65 let checkAssumed n = case featureByName n of 66 Nothing -> assertFailure $ "feature not found: " ++ n 67 Just f -> featureAssumed f @?= True 68 mapM_ checkAssumed [ "option_data_loss_protect" 69 , "var_onion_optin" 70 , "option_static_remotekey" 71 , "payment_secret" 72 , "option_channel_type" 73 ] 74 ] 75 76 -- Bit parity tests ------------------------------------------------------------ 77 78 bitParityTests :: TestTree 79 bitParityTests = testGroup "Bit parity" [ 80 testCase "requiredBit accepts even numbers" $ do 81 isJust (requiredBit 0) @?= True 82 isJust (requiredBit 2) @?= True 83 isJust (requiredBit 100) @?= True 84 85 , testCase "requiredBit rejects odd numbers" $ do 86 isNothing (requiredBit 1) @?= True 87 isNothing (requiredBit 3) @?= True 88 isNothing (requiredBit 101) @?= True 89 90 , testCase "optionalBit accepts odd numbers" $ do 91 isJust (optionalBit 1) @?= True 92 isJust (optionalBit 3) @?= True 93 isJust (optionalBit 101) @?= True 94 95 , testCase "optionalBit rejects even numbers" $ do 96 isNothing (optionalBit 0) @?= True 97 isNothing (optionalBit 2) @?= True 98 isNothing (optionalBit 100) @?= True 99 100 , testCase "requiredBit smart constructor preserves value" $ 101 case requiredBit 42 of 102 Nothing -> assertFailure "expected Just" 103 Just rb -> unRequiredBit rb @?= 42 104 105 , testCase "optionalBit smart constructor preserves value" $ 106 case optionalBit 43 of 107 Nothing -> assertFailure "expected Just" 108 Just ob -> unOptionalBit ob @?= 43 109 ] 110 111 -- FeatureVector tests --------------------------------------------------------- 112 113 featureVectorTests :: TestTree 114 featureVectorTests = testGroup "FeatureVector" [ 115 testCase "empty has no bits set" $ do 116 unFeatureVector empty @?= BS.empty 117 member (bitIndex 0) empty @?= False 118 member (bitIndex 100) empty @?= False 119 120 , testCase "set adds a bit" $ do 121 let fv = set (bitIndex 0) empty 122 member (bitIndex 0) fv @?= True 123 124 , testCase "set multiple bits" $ do 125 let fv = set (bitIndex 8) (set (bitIndex 0) empty) 126 member (bitIndex 0) fv @?= True 127 member (bitIndex 8) fv @?= True 128 member (bitIndex 1) fv @?= False 129 130 , testCase "clear removes a bit" $ do 131 let fv = set (bitIndex 5) empty 132 fv' = clear (bitIndex 5) fv 133 member (bitIndex 5) fv @?= True 134 member (bitIndex 5) fv' @?= False 135 136 , testCase "clear on unset bit is no-op" $ do 137 let fv = clear (bitIndex 10) empty 138 unFeatureVector fv @?= BS.empty 139 140 , testCase "member returns False for unset bits" $ do 141 let fv = set (bitIndex 4) empty 142 member (bitIndex 0) fv @?= False 143 member (bitIndex 1) fv @?= False 144 member (bitIndex 5) fv @?= False 145 146 , testCase "render strips leading zeros" $ do 147 let fv = set (bitIndex 0) empty 148 render fv @?= BS.pack [0x01] 149 150 , testCase "render handles high bits correctly" $ do 151 let fv = set (bitIndex 15) empty 152 render fv @?= BS.pack [0x80, 0x00] 153 154 , testCase "render of empty is empty" $ 155 render empty @?= BS.empty 156 ] 157 158 -- Validation tests ------------------------------------------------------------ 159 160 validationTests :: TestTree 161 validationTests = testGroup "Validation" [ 162 testCase "BothBitsSet error when both bits of a pair are set" $ do 163 let baseBit = 14 -- payment_secret 164 fv = setBit (baseBit + 1) (setBit baseBit empty) 165 case validateLocal Init fv of 166 Right () -> assertFailure "expected BothBitsSet error" 167 Left errs -> any isBothBitsSet errs @?= True 168 169 , testCase "MissingDependency error when dep not set" $ do 170 -- basic_mpp (16) depends on payment_secret (14) 171 case featureByName "basic_mpp" of 172 Nothing -> assertFailure "basic_mpp not found" 173 Just f -> do 174 let fv = setBit (featureBaseBit f) empty 175 case validateLocal Init fv of 176 Right () -> assertFailure "expected MissingDependency error" 177 Left errs -> any isMissingDependency errs @?= True 178 179 , testCase "ContextNotAllowed error for wrong context" $ do 180 -- option_payment_metadata (48) is only allowed in Invoice context 181 case featureByName "option_payment_metadata" of 182 Nothing -> assertFailure "option_payment_metadata not found" 183 Just f -> do 184 let fv = setBit (featureBaseBit f) empty 185 case validateLocal Init fv of 186 Right () -> assertFailure "expected ContextNotAllowed error" 187 Left errs -> any isContextNotAllowed errs @?= True 188 189 , testCase "Remote validation accepts unknown optional bits" $ do 190 -- bit 201 is unknown and odd (optional) 191 let fv = setBit 201 empty 192 validateRemote Init fv @?= Right () 193 194 , testCase "Remote validation rejects unknown required bits" $ do 195 -- bit 200 is unknown and even (required) 196 let fv = setBit 200 empty 197 case validateRemote Init fv of 198 Right () -> assertFailure "expected UnknownRequiredBit error" 199 Left errs -> any isUnknownRequiredBit errs @?= True 200 201 , testCase "Valid local vector passes validation" $ do 202 -- payment_secret (14) with its required bit set 203 case featureByName "payment_secret" of 204 Nothing -> assertFailure "payment_secret not found" 205 Just f -> do 206 let fv = setBit (featureBaseBit f) empty 207 validateLocal Init fv @?= Right () 208 209 , testCase "Valid feature with dependency passes" $ do 210 -- basic_mpp (16) with payment_secret (14) dependency set 211 case (featureByName "basic_mpp", featureByName "payment_secret") of 212 (Just mpp, Just ps) -> do 213 let fv = setBit (featureBaseBit mpp) 214 $ setBit (featureBaseBit ps) empty 215 validateLocal Init fv @?= Right () 216 _ -> assertFailure "features not found" 217 ] 218 219 isBothBitsSet :: ValidationError -> Bool 220 isBothBitsSet (BothBitsSet _ _) = True 221 isBothBitsSet _ = False 222 223 isMissingDependency :: ValidationError -> Bool 224 isMissingDependency (MissingDependency _ _) = True 225 isMissingDependency _ = False 226 227 isContextNotAllowed :: ValidationError -> Bool 228 isContextNotAllowed (ContextNotAllowed _ _) = True 229 isContextNotAllowed _ = False 230 231 isUnknownRequiredBit :: ValidationError -> Bool 232 isUnknownRequiredBit (UnknownRequiredBit _) = True 233 isUnknownRequiredBit _ = False 234 235 -- Property tests -------------------------------------------------------------- 236 237 propertyTests :: TestTree 238 propertyTests = testGroup "Properties" [ 239 testProperty "render . parse == id for stripped ByteStrings" $ 240 \bs -> let stripped = BS.dropWhile (== 0) (BS.pack bs) 241 in render (parse stripped) === stripped 242 243 , testProperty "set then member returns True" $ 244 \(Small n) -> let idx = bitIndex (n `mod` 256) 245 fv = set idx empty 246 in member idx fv === True 247 248 , testProperty "clear then member returns False" $ 249 \(Small n) -> let idx = bitIndex (n `mod` 256) 250 fv = set idx empty 251 fv' = clear idx fv 252 in member idx fv' === False 253 254 , testProperty "setBits returns all set bits without duplicates" $ 255 \bs -> let fv = parse (BS.pack bs) 256 bits = setBits fv 257 -- Verify no duplicates and length matches unique count 258 in length bits === length (removeDups bits) 259 260 , testProperty "double set is idempotent" $ 261 \(Small n) -> let idx = bitIndex (n `mod` 256) 262 fv = set idx empty 263 fv' = set idx fv 264 in unFeatureVector fv === unFeatureVector fv' 265 266 , testProperty "set then clear restores original (when was unset)" $ 267 \(Small n) -> let idx = bitIndex (n `mod` 256) 268 fv = set idx empty 269 fv' = clear idx fv 270 in unFeatureVector fv' === BS.empty 271 272 , testProperty "member consistent with setBits" $ 273 \bs -> let fv = parse (BS.pack bs) 274 bits = setBits fv 275 in all (\b -> member (bitIndex b) fv) bits === True 276 277 , testProperty "requiredBit only succeeds for even" $ 278 \(n :: Word16) -> isJust (requiredBit n) === (n `mod` 2 == 0) 279 280 , testProperty "optionalBit only succeeds for odd" $ 281 \(n :: Word16) -> isJust (optionalBit n) === (n `mod` 2 == 1) 282 ] 283 284 -- | Remove duplicates from a list. 285 removeDups :: Eq a => [a] -> [a] 286 removeDups [] = [] 287 removeDups (x:xs) = x : removeDups (filter (/= x) xs)