Main.hs (17662B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import qualified Data.ByteString as BS 6 import qualified Data.ByteString.Base16 as B16 7 import Data.Maybe (isJust, isNothing) 8 import Data.Word (Word32, Word64) 9 import Test.Tasty 10 import Test.Tasty.HUnit 11 import Test.Tasty.QuickCheck 12 import Lightning.Protocol.BOLT3 13 import Lightning.Protocol.BOLT3.Types 14 ( Pubkey(..), Point(..) 15 , PaymentHash(..), PerCommitmentPoint(..) 16 ) 17 18 main :: IO () 19 main = defaultMain $ testGroup "ppad-bolt3" [ 20 testGroup "Key derivation" [ 21 keyDerivationTests 22 ] 23 , testGroup "Secret generation" [ 24 secretGenerationTests 25 ] 26 , testGroup "Secret storage" [ 27 secretStorageTests 28 ] 29 , testGroup "Fee calculation" [ 30 feeCalculationTests 31 ] 32 , testGroup "Trimming" [ 33 trimmingTests 34 ] 35 , testGroup "Smart constructors" [ 36 smartConstructorTests 37 ] 38 , testGroup "Properties" [ 39 propertyTests 40 ] 41 ] 42 43 -- hex decoding helper 44 hex :: BS.ByteString -> BS.ByteString 45 hex h = case B16.decode h of 46 Right bs -> bs 47 Left _ -> error "invalid hex" 48 49 -- Key derivation test vectors from Appendix E --------------------------------- 50 51 keyDerivationTests :: TestTree 52 keyDerivationTests = testGroup "BOLT #3 Appendix E" [ 53 testCase "derive_pubkey" $ do 54 let basepoint = Point $ hex 55 "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2" 56 perCommitmentPoint = PerCommitmentPoint $ Point $ hex 57 "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486" 58 expected = hex 59 "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5" 60 case derive_pubkey basepoint perCommitmentPoint of 61 Nothing -> assertFailure "derive_pubkey returned Nothing" 62 Just (Pubkey pk) -> pk @?= expected 63 64 , testCase "derive_revocationpubkey" $ do 65 let revocationBasepoint = RevocationBasepoint $ Point $ hex 66 "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2" 67 perCommitmentPoint = PerCommitmentPoint $ Point $ hex 68 "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486" 69 expected = hex 70 "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0" 71 case derive_revocationpubkey revocationBasepoint perCommitmentPoint of 72 Nothing -> assertFailure "derive_revocationpubkey returned Nothing" 73 Just (RevocationPubkey (Pubkey pk)) -> pk @?= expected 74 ] 75 76 -- Secret generation test vectors from Appendix D ------------------------------ 77 78 secretGenerationTests :: TestTree 79 secretGenerationTests = testGroup "BOLT #3 Appendix D - Generation" [ 80 testCase "generate_from_seed 0 final node" $ do 81 let seed = hex 82 "0000000000000000000000000000000000000000000000000000000000000000" 83 i = 281474976710655 84 expected = hex 85 "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148" 86 generate_from_seed seed i @?= expected 87 88 , testCase "generate_from_seed FF final node" $ do 89 let seed = hex 90 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF" 91 i = 281474976710655 92 expected = hex 93 "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc" 94 generate_from_seed seed i @?= expected 95 96 , testCase "generate_from_seed FF alternate bits 1" $ do 97 let seed = hex 98 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF" 99 i = 0xaaaaaaaaaaa 100 expected = hex 101 "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528" 102 generate_from_seed seed i @?= expected 103 104 , testCase "generate_from_seed FF alternate bits 2" $ do 105 let seed = hex 106 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF" 107 i = 0x555555555555 108 expected = hex 109 "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31" 110 generate_from_seed seed i @?= expected 111 112 , testCase "generate_from_seed 01 last nontrivial node" $ do 113 let seed = hex 114 "0101010101010101010101010101010101010101010101010101010101010101" 115 i = 1 116 expected = hex 117 "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c" 118 generate_from_seed seed i @?= expected 119 ] 120 121 -- Secret storage test vectors from Appendix D --------------------------------- 122 123 secretStorageTests :: TestTree 124 secretStorageTests = testGroup "BOLT #3 Appendix D - Storage" [ 125 testCase "insert_secret correct sequence" $ do 126 let secrets = [ 127 (281474976710655, hex 128 "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc") 129 , (281474976710654, hex 130 "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964") 131 , (281474976710653, hex 132 "2273e227a5b7449b6e70f1fb4652864038b1cbf9cd7c043a7d6456b7fc275ad8") 133 , (281474976710652, hex 134 "27cddaa5624534cb6cb9d7da077cf2b22ab21e9b506fd4998a51d54502e99116") 135 , (281474976710651, hex 136 "c65716add7aa98ba7acb236352d665cab17345fe45b55fb879ff80e6bd0c41dd") 137 , (281474976710650, hex 138 "969660042a28f32d9be17344e09374b379962d03db1574df5a8a5a47e19ce3f2") 139 , (281474976710649, hex 140 "a5a64476122ca0925fb344bdc1854c1c0a59fc614298e50a33e331980a220f32") 141 , (281474976710648, hex 142 "05cde6323d949933f7f7b78776bcc1ea6d9b31447732e3802e1f7ac44b650e17") 143 ] 144 let insertAll store [] = Just store 145 insertAll store ((idx, secret):rest) = 146 case insert_secret secret idx store of 147 Nothing -> Nothing 148 Just store' -> insertAll store' rest 149 case insertAll empty_store secrets of 150 Nothing -> assertFailure "insert_secret failed on correct sequence" 151 Just _ -> return () 152 153 , testCase "insert_secret #1 incorrect" $ do 154 -- First secret is from wrong seed, second should fail 155 let store0 = empty_store 156 case insert_secret (hex 157 "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148") 158 281474976710655 store0 of 159 Nothing -> assertFailure "First insert should succeed" 160 Just store1 -> 161 case insert_secret (hex 162 "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964") 163 281474976710654 store1 of 164 Nothing -> return () -- Expected to fail 165 Just _ -> assertFailure "Second insert should fail" 166 ] 167 168 -- Fee calculation tests ------------------------------------------------------- 169 170 feeCalculationTests :: TestTree 171 feeCalculationTests = testGroup "Fee calculation" [ 172 testCase "commitment_fee no anchors, 0 htlcs" $ do 173 let feerate = FeeratePerKw 5000 174 features = ChannelFeatures { cf_option_anchors = False } 175 fee = commitment_fee feerate features 0 176 fee @?= Satoshi 3620 -- 5000 * 724 / 1000 = 3620 177 178 , testCase "commitment_fee no anchors, 2 htlcs" $ do 179 let feerate = FeeratePerKw 5000 180 features = ChannelFeatures { cf_option_anchors = False } 181 fee = commitment_fee feerate features 2 182 -- weight = 724 + 172*2 = 1068 183 -- fee = 5000 * 1068 / 1000 = 5340 184 fee @?= Satoshi 5340 185 186 , testCase "commitment_fee with anchors, 0 htlcs" $ do 187 let feerate = FeeratePerKw 5000 188 features = ChannelFeatures { cf_option_anchors = True } 189 fee = commitment_fee feerate features 0 190 -- 5000 * 1124 / 1000 = 5620 191 fee @?= Satoshi 5620 192 193 , testCase "htlc_timeout_fee no anchors" $ do 194 let feerate = FeeratePerKw 5000 195 features = ChannelFeatures { cf_option_anchors = False } 196 fee = htlc_timeout_fee feerate features 197 -- 5000 * 663 / 1000 = 3315 198 fee @?= Satoshi 3315 199 200 , testCase "htlc_success_fee no anchors" $ do 201 let feerate = FeeratePerKw 5000 202 features = ChannelFeatures { cf_option_anchors = False } 203 fee = htlc_success_fee feerate features 204 -- 5000 * 703 / 1000 = 3515 205 fee @?= Satoshi 3515 206 207 , testCase "htlc_timeout_fee with anchors is 0" $ do 208 let feerate = FeeratePerKw 5000 209 features = ChannelFeatures { cf_option_anchors = True } 210 fee = htlc_timeout_fee feerate features 211 fee @?= Satoshi 0 212 213 , testCase "htlc_success_fee with anchors is 0" $ do 214 let feerate = FeeratePerKw 5000 215 features = ChannelFeatures { cf_option_anchors = True } 216 fee = htlc_success_fee feerate features 217 fee @?= Satoshi 0 218 ] 219 220 -- Trimming tests -------------------------------------------------------------- 221 222 trimmingTests :: TestTree 223 trimmingTests = testGroup "HTLC trimming" [ 224 testCase "offered HTLC above threshold not trimmed" $ do 225 let dust = DustLimit (Satoshi 546) 226 feerate = FeeratePerKw 5000 227 features = ChannelFeatures { cf_option_anchors = False } 228 htlc = HTLC 229 { htlc_direction = HTLCOffered 230 , htlc_amount_msat = MilliSatoshi 5000000 -- 5000 sats 231 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 232 , htlc_cltv_expiry = CltvExpiry 500000 233 } 234 -- threshold = 546 + 3315 = 3861 235 -- 5000 > 3861, so not trimmed 236 is_trimmed dust feerate features htlc @?= False 237 238 , testCase "offered HTLC below threshold is trimmed" $ do 239 let dust = DustLimit (Satoshi 546) 240 feerate = FeeratePerKw 5000 241 features = ChannelFeatures { cf_option_anchors = False } 242 htlc = HTLC 243 { htlc_direction = HTLCOffered 244 , htlc_amount_msat = MilliSatoshi 1000000 -- 1000 sats 245 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 246 , htlc_cltv_expiry = CltvExpiry 500000 247 } 248 -- threshold = 546 + 3315 = 3861 249 -- 1000 < 3861, so trimmed 250 is_trimmed dust feerate features htlc @?= True 251 252 , testCase "received HTLC above threshold not trimmed" $ do 253 let dust = DustLimit (Satoshi 546) 254 feerate = FeeratePerKw 5000 255 features = ChannelFeatures { cf_option_anchors = False } 256 htlc = HTLC 257 { htlc_direction = HTLCReceived 258 , htlc_amount_msat = MilliSatoshi 7000000 -- 7000 sats 259 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 260 , htlc_cltv_expiry = CltvExpiry 500000 261 } 262 -- threshold = 546 + 3515 = 4061 263 -- 7000 > 4061, so not trimmed 264 is_trimmed dust feerate features htlc @?= False 265 266 , testCase "received HTLC below threshold is trimmed" $ do 267 let dust = DustLimit (Satoshi 546) 268 feerate = FeeratePerKw 5000 269 features = ChannelFeatures { cf_option_anchors = False } 270 htlc = HTLC 271 { htlc_direction = HTLCReceived 272 , htlc_amount_msat = MilliSatoshi 800000 -- 800 sats 273 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 274 , htlc_cltv_expiry = CltvExpiry 500000 275 } 276 -- threshold = 546 + 3515 = 4061 277 -- 800 < 4061, so trimmed 278 is_trimmed dust feerate features htlc @?= True 279 ] 280 281 -- Smart constructor tests ----------------------------------------------------- 282 283 smartConstructorTests :: TestTree 284 smartConstructorTests = testGroup "validation" [ 285 -- 33-byte types 286 testCase "pubkey accepts 33 bytes" $ do 287 let bs = BS.replicate 33 0x02 288 isJust (pubkey bs) @?= True 289 , testCase "pubkey rejects 32 bytes" $ do 290 let bs = BS.replicate 32 0x02 291 isNothing (pubkey bs) @?= True 292 , testCase "pubkey rejects 34 bytes" $ do 293 let bs = BS.replicate 34 0x02 294 isNothing (pubkey bs) @?= True 295 , testCase "point accepts 33 bytes" $ do 296 let bs = BS.replicate 33 0x03 297 isJust (point bs) @?= True 298 , testCase "point rejects 32 bytes" $ do 299 let bs = BS.replicate 32 0x03 300 isNothing (point bs) @?= True 301 302 -- 32-byte types 303 , testCase "seckey accepts 32 bytes" $ do 304 let bs = BS.replicate 32 0x01 305 isJust (seckey bs) @?= True 306 , testCase "seckey rejects 31 bytes" $ do 307 let bs = BS.replicate 31 0x01 308 isNothing (seckey bs) @?= True 309 , testCase "seckey rejects 33 bytes" $ do 310 let bs = BS.replicate 33 0x01 311 isNothing (seckey bs) @?= True 312 , testCase "mkTxId accepts 32 bytes" $ do 313 let bs = BS.replicate 32 0x00 314 isJust (mkTxId bs) @?= True 315 , testCase "mkTxId rejects 31 bytes" $ do 316 let bs = BS.replicate 31 0x00 317 isNothing (mkTxId bs) @?= True 318 , testCase "paymentHash accepts 32 bytes" $ do 319 let bs = BS.replicate 32 0xab 320 isJust (paymentHash bs) @?= True 321 , testCase "paymentHash rejects 33 bytes" $ do 322 let bs = BS.replicate 33 0xab 323 isNothing (paymentHash bs) @?= True 324 , testCase "paymentPreimage accepts 32 bytes" $ do 325 let bs = BS.replicate 32 0xcd 326 isJust (paymentPreimage bs) @?= True 327 , testCase "paymentPreimage rejects 31 bytes" $ do 328 let bs = BS.replicate 31 0xcd 329 isNothing (paymentPreimage bs) @?= True 330 , testCase "perCommitmentSecret accepts 32 bytes" $ do 331 let bs = BS.replicate 32 0xef 332 isJust (perCommitmentSecret bs) @?= True 333 , testCase "perCommitmentSecret rejects 33 bytes" $ do 334 let bs = BS.replicate 33 0xef 335 isNothing (perCommitmentSecret bs) @?= True 336 337 -- 48-bit commitment number 338 , testCase "commitment_number accepts 0" $ do 339 isJust (commitment_number 0) @?= True 340 , testCase "commitment_number accepts 2^48-1" $ do 341 isJust (commitment_number 281474976710655) @?= True 342 , testCase "commitment_number rejects 2^48" $ do 343 isNothing (commitment_number 281474976710656) @?= True 344 , testCase "commitment_number rejects maxBound Word64" $ do 345 isNothing (commitment_number maxBound) @?= True 346 347 -- next_commitment_number 348 , testCase "next_commitment_number 0 -> 1" $ 349 case commitment_number 0 of 350 Nothing -> assertFailure "commitment_number 0" 351 Just cn0 -> case next_commitment_number cn0 of 352 Nothing -> assertFailure "next failed" 353 Just cn1 -> unCommitmentNumber cn1 @?= 1 354 , testCase "next_commitment_number (2^48-2) -> (2^48-1)" $ 355 case commitment_number 281474976710654 of 356 Nothing -> assertFailure "commitment_number" 357 Just cn -> case next_commitment_number cn of 358 Nothing -> assertFailure "next failed" 359 Just cn' -> 360 unCommitmentNumber cn' @?= 281474976710655 361 , testCase "next_commitment_number (2^48-1) -> Nothing" $ 362 case commitment_number 281474976710655 of 363 Nothing -> assertFailure "commitment_number" 364 Just cn -> 365 isNothing (next_commitment_number cn) @?= True 366 ] 367 368 -- Property tests ------------------------------------------------------- 369 370 -- | Maximum valid commitment number (2^48 - 1). 371 maxCommitNum :: Word64 372 maxCommitNum = 281474976710655 373 374 propertyTests :: TestTree 375 propertyTests = testGroup "invariants" [ 376 testProperty "commitment_number validates 48-bit" 377 propCommitmentNumberRange 378 , testProperty "next_commitment_number stays valid" 379 propNextCommitmentNumber 380 , testProperty "trimmed/untrimmed partition" 381 propTrimPartition 382 , testProperty "commitment_fee increases with HTLCs" 383 propFeeMonotonic 384 ] 385 386 -- | commitment_number accepts values in [0, 2^48-1] and 387 -- rejects values >= 2^48. 388 propCommitmentNumberRange :: Property 389 propCommitmentNumberRange = 390 forAll (choose (0, maxBound)) $ \n -> 391 case commitment_number n of 392 Just cn -> n <= maxCommitNum 393 && unCommitmentNumber cn == n 394 Nothing -> n > maxCommitNum 395 396 -- | If cn is a valid commitment number below the max, 397 -- next_commitment_number yields a valid successor. 398 propNextCommitmentNumber :: Property 399 propNextCommitmentNumber = 400 forAll (choose (0, maxCommitNum)) $ \n -> 401 case commitment_number n of 402 Nothing -> False 403 Just cn 404 | n < maxCommitNum -> 405 case next_commitment_number cn of 406 Nothing -> False 407 Just cn' -> 408 unCommitmentNumber cn' == n + 1 409 | otherwise -> 410 isNothing (next_commitment_number cn) 411 412 -- | trimmed_htlcs and untrimmed_htlcs partition the 413 -- input list: every HTLC is in exactly one set and 414 -- trimmed HTLCs have amount below the threshold. 415 propTrimPartition :: Property 416 propTrimPartition = 417 forAll (choose (1 :: Word32, 50000)) $ \feeW -> 418 forAll (choose (1, 20)) $ \numHtlcs -> 419 forAll (vectorOf numHtlcs genHTLC) $ \htlcs -> 420 let dust = DustLimit (Satoshi 546) 421 feerate = FeeratePerKw feeW 422 features = ChannelFeatures 423 { cf_option_anchors = False } 424 trimmed = trimmed_htlcs 425 dust feerate features htlcs 426 untrimmed = untrimmed_htlcs 427 dust feerate features htlcs 428 in length trimmed + length untrimmed 429 == length htlcs 430 431 -- | commitment_fee is monotonically non-decreasing in 432 -- the number of HTLCs. 433 propFeeMonotonic :: Property 434 propFeeMonotonic = 435 forAll (choose (1 :: Word32, 50000)) $ \feeW -> 436 forAll (choose (0, 100)) $ \n -> 437 let feerate = FeeratePerKw feeW 438 features = ChannelFeatures 439 { cf_option_anchors = False } 440 fee0 = commitment_fee feerate features n 441 fee1 = commitment_fee feerate features (n + 1) 442 in fee1 >= fee0 443 444 -- | Generate a random HTLC. 445 genHTLC :: Gen HTLC 446 genHTLC = do 447 dir <- elements [HTLCOffered, HTLCReceived] 448 amt <- choose (0, 10000000) 449 cltv <- choose (0, 1000000) 450 pure HTLC 451 { htlc_direction = dir 452 , htlc_amount_msat = MilliSatoshi amt 453 , htlc_payment_hash = PaymentHash 454 (BS.replicate 32 0x00) 455 , htlc_cltv_expiry = CltvExpiry cltv 456 }