Main.hs (50786B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import Data.Bits (xor) 6 import qualified Data.ByteString as BS 7 import qualified Data.ByteString.Base16 as B16 8 import qualified Crypto.Curve.Secp256k1 as Secp256k1 9 import Data.Word (Word8, Word16, Word32) 10 import Lightning.Protocol.BOLT4.Blinding 11 import Lightning.Protocol.BOLT4.Codec 12 import Lightning.Protocol.BOLT4.Construct 13 import Lightning.Protocol.BOLT4.Error 14 import Lightning.Protocol.BOLT4.Internal 15 import Lightning.Protocol.BOLT4.Prim 16 import Lightning.Protocol.BOLT4.Process 17 import Lightning.Protocol.BOLT4.Types 18 import Test.Tasty 19 import Test.Tasty.HUnit 20 import Test.Tasty.QuickCheck 21 22 -- | Demand a Just value in IO, failing the test on Nothing. 23 demand :: String -> Maybe a -> IO a 24 demand _ (Just a) = pure a 25 demand msg Nothing = assertFailure msg 26 27 -- | Construct a ShortChannelId, failing if invalid. 28 assertScid :: Word32 -> Word32 -> Word16 29 -> IO ShortChannelId 30 assertScid b t o = demand "shortChannelId" (shortChannelId b t o) 31 32 -- | Construct a ShortChannelId for test fixtures. 33 mkScid :: Word32 -> Word32 -> Word16 -> ShortChannelId 34 mkScid b t o = case shortChannelId b t o of 35 Just s -> s 36 Nothing -> error "mkScid: invalid test fixture" 37 38 main :: IO () 39 main = defaultMain $ testGroup "ppad-bolt4" [ 40 testGroup "Prim" [ 41 primTests 42 ] 43 , testGroup "BigSize" [ 44 bigsizeTests 45 , bigsizeRoundtripProp 46 ] 47 , testGroup "TLV" [ 48 tlvTests 49 ] 50 , testGroup "ShortChannelId" [ 51 sciTests 52 ] 53 , testGroup "OnionPacket" [ 54 onionPacketTests 55 ] 56 , testGroup "Construct" [ 57 constructTests 58 ] 59 , testGroup "Process" [ 60 processTests 61 ] 62 , testGroup "Error" [ 63 errorTests 64 ] 65 , testGroup "properties" [ 66 propertyTests 67 ] 68 , testGroup "Blinding" [ 69 blindingKeyDerivationTests 70 , blindingEphemeralKeyTests 71 , blindingTlvTests 72 , blindingEncryptionTests 73 , blindingCreatePathTests 74 , blindingProcessHopTests 75 ] 76 ] 77 78 -- BigSize tests ------------------------------------------------------------ 79 80 bigsizeTests :: TestTree 81 bigsizeTests = testGroup "boundary values" [ 82 testCase "0" $ 83 encodeBigSize 0 @?= BS.pack [0x00] 84 , testCase "0xFC" $ 85 encodeBigSize 0xFC @?= BS.pack [0xFC] 86 , testCase "0xFD" $ 87 encodeBigSize 0xFD @?= BS.pack [0xFD, 0x00, 0xFD] 88 , testCase "0xFFFF" $ 89 encodeBigSize 0xFFFF @?= BS.pack [0xFD, 0xFF, 0xFF] 90 , testCase "0x10000" $ 91 encodeBigSize 0x10000 @?= 92 BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00] 93 , testCase "0xFFFFFFFF" $ 94 encodeBigSize 0xFFFFFFFF @?= 95 BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF] 96 , testCase "0x100000000" $ 97 encodeBigSize 0x100000000 @?= 98 BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01, 99 0x00, 0x00, 0x00, 0x00] 100 , testCase "decode 0" $ do 101 let result = decodeBigSize (BS.pack [0x00]) 102 result @?= Just (0, BS.empty) 103 , testCase "decode 0xFC" $ do 104 let result = decodeBigSize (BS.pack [0xFC]) 105 result @?= Just (0xFC, BS.empty) 106 , testCase "decode 0xFD" $ do 107 let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFD]) 108 result @?= Just (0xFD, BS.empty) 109 , testCase "decode 0xFFFF" $ do 110 let result = decodeBigSize (BS.pack [0xFD, 0xFF, 0xFF]) 111 result @?= Just (0xFFFF, BS.empty) 112 , testCase "decode 0x10000" $ do 113 let result = decodeBigSize $ 114 BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00] 115 result @?= Just (0x10000, BS.empty) 116 , testCase "decode 0xFFFFFFFF" $ do 117 let result = decodeBigSize $ 118 BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF] 119 result @?= Just (0xFFFFFFFF, BS.empty) 120 , testCase "decode 0x100000000" $ do 121 let result = decodeBigSize $ 122 BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01, 123 0x00, 0x00, 0x00, 0x00] 124 result @?= Just (0x100000000, BS.empty) 125 , testCase "reject non-canonical 0xFD encoding" $ do 126 let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFC]) 127 result @?= Nothing 128 , testCase "reject non-canonical 0xFE encoding" $ do 129 let result = decodeBigSize $ 130 BS.pack [0xFE, 0x00, 0x00, 0xFF, 0xFF] 131 result @?= Nothing 132 , testCase "bigSizeLen" $ do 133 bigSizeLen 0 @?= 1 134 bigSizeLen 0xFC @?= 1 135 bigSizeLen 0xFD @?= 3 136 bigSizeLen 0xFFFF @?= 3 137 bigSizeLen 0x10000 @?= 5 138 bigSizeLen 0xFFFFFFFF @?= 5 139 bigSizeLen 0x100000000 @?= 9 140 ] 141 142 bigsizeRoundtripProp :: TestTree 143 bigsizeRoundtripProp = testProperty "roundtrip" $ \n -> 144 let encoded = encodeBigSize n 145 decoded = decodeBigSize encoded 146 in decoded == Just (n, BS.empty) 147 148 -- TLV tests ---------------------------------------------------------------- 149 150 tlvTests :: TestTree 151 tlvTests = testGroup "encoding/decoding" [ 152 testCase "single record" $ do 153 let rec = TlvRecord 2 (BS.pack [0x01, 0x02, 0x03]) 154 encoded = encodeTlv rec 155 decoded = decodeTlv encoded 156 decoded @?= Just (rec, BS.empty) 157 , testCase "stream roundtrip" $ do 158 let recs = [ TlvRecord 2 (BS.pack [0x01]) 159 , TlvRecord 4 (BS.pack [0x02, 0x03]) 160 , TlvRecord 100 (BS.pack [0x04, 0x05, 0x06]) 161 ] 162 encoded = encodeTlvStream recs 163 decoded = decodeTlvStream encoded 164 decoded @?= Just recs 165 , testCase "reject out-of-order types" $ do 166 let rec1 = encodeTlv (TlvRecord 4 (BS.pack [0x01])) 167 rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02])) 168 badStream = rec1 <> rec2 169 decoded = decodeTlvStream badStream 170 decoded @?= Nothing 171 , testCase "reject duplicate types" $ do 172 let rec1 = encodeTlv (TlvRecord 2 (BS.pack [0x01])) 173 rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02])) 174 badStream = rec1 <> rec2 175 decoded = decodeTlvStream badStream 176 decoded @?= Nothing 177 , testCase "empty stream" $ do 178 let decoded = decodeTlvStream BS.empty 179 decoded @?= Just [] 180 ] 181 182 -- ShortChannelId tests ----------------------------------------------------- 183 184 sciTests :: TestTree 185 sciTests = testGroup "encoding/decoding" [ 186 testCase "known value" $ do 187 sci <- assertScid 700000 1234 5 188 let encoded = encodeShortChannelId sci 189 BS.length encoded @?= 8 190 let decoded = decodeShortChannelId encoded 191 decoded @?= Just sci 192 , testCase "maximum values" $ do 193 sci <- assertScid 0xFFFFFF 0xFFFFFF 0xFFFF 194 let encoded = encodeShortChannelId sci 195 BS.length encoded @?= 8 196 let decoded = decodeShortChannelId encoded 197 decoded @?= Just sci 198 , testCase "zero values" $ do 199 sci <- assertScid 0 0 0 200 let encoded = encodeShortChannelId sci 201 expected = BS.pack [0, 0, 0, 0, 0, 0, 0, 0] 202 encoded @?= expected 203 let decoded = decodeShortChannelId encoded 204 decoded @?= Just sci 205 , testCase "reject wrong length" $ do 206 let decoded = 207 decodeShortChannelId (BS.pack [0, 1, 2, 3, 4, 5, 6]) 208 decoded @?= Nothing 209 ] 210 211 -- OnionPacket tests -------------------------------------------------------- 212 213 onionPacketTests :: TestTree 214 onionPacketTests = testGroup "encoding/decoding" [ 215 testCase "roundtrip" $ do 216 let packet = OnionPacket 217 { opVersion = 0x00 218 , opEphemeralKey = BS.replicate 33 0xAB 219 , opHopPayloads = 220 unsafeHopPayloads (BS.replicate 1300 0xCD) 221 , opHmac = unsafeHmac32 (BS.replicate 32 0xEF) 222 } 223 encoded = encodeOnionPacket packet 224 BS.length encoded @?= onionPacketSize 225 let decoded = decodeOnionPacket encoded 226 decoded @?= Just packet 227 , testCase "reject wrong size" $ do 228 let decoded = 229 decodeOnionPacket (BS.replicate 1000 0x00) 230 decoded @?= Nothing 231 ] 232 233 -- Prim tests --------------------------------------------------------------- 234 235 sessionKey :: BS.ByteString 236 sessionKey = BS.replicate 32 0x41 237 238 hop0PubKeyHex :: BS.ByteString 239 hop0PubKeyHex = 240 "02eec7245d6b7d2ccb30380bfbe2a3648cd7a942653f5aa340edcea1f283686619" 241 242 hop0SharedSecretHex :: BS.ByteString 243 hop0SharedSecretHex = 244 "53eb63ea8a3fec3b3cd433b85cd62a4b145e1dda09391b348c4e1cd36a03ea66" 245 246 hop0BlindingFactorHex :: BS.ByteString 247 hop0BlindingFactorHex = 248 "2ec2e5da605776054187180343287683aa6a51b4b1c04d6dd49c45d8cffb3c36" 249 250 fromHex :: BS.ByteString -> BS.ByteString 251 fromHex h = case B16.decode h of 252 Just bs -> bs 253 Nothing -> error "fromHex: invalid hex" 254 255 primTests :: TestTree 256 primTests = testGroup "cryptographic primitives" [ 257 testSharedSecret 258 , testBlindingFactor 259 , testKeyDerivation 260 , testBlindPubKey 261 , testGenerateStream 262 , testHmacOperations 263 ] 264 265 testSharedSecret :: TestTree 266 testSharedSecret = 267 testCase "computeSharedSecret (BOLT4 spec hop 0)" $ do 268 pubKey <- demand "parse_point" $ 269 Secp256k1.parse_point (fromHex hop0PubKeyHex) 270 case computeSharedSecret sessionKey pubKey of 271 Nothing -> 272 assertFailure "computeSharedSecret returned Nothing" 273 Just (SharedSecret computed) -> do 274 let expected = fromHex hop0SharedSecretHex 275 computed @?= expected 276 277 testBlindingFactor :: TestTree 278 testBlindingFactor = 279 testCase "computeBlindingFactor (BOLT4 spec hop 0)" $ do 280 sk <- demand "roll32" $ Secp256k1.roll32 sessionKey 281 ephemPubKey <- demand "derive_pub" $ 282 Secp256k1.derive_pub sk 283 nodePubKey <- demand "parse_point" $ 284 Secp256k1.parse_point (fromHex hop0PubKeyHex) 285 case computeSharedSecret sessionKey nodePubKey of 286 Nothing -> 287 assertFailure "computeSharedSecret returned Nothing" 288 Just sharedSecret -> do 289 let BlindingFactor computed = 290 computeBlindingFactor ephemPubKey sharedSecret 291 expected = fromHex hop0BlindingFactorHex 292 computed @?= expected 293 294 testKeyDerivation :: TestTree 295 testKeyDerivation = testGroup "key derivation" [ 296 testCase "deriveRho produces 32 bytes" $ do 297 let ss = SharedSecret (BS.replicate 32 0) 298 DerivedKey rho = deriveRho ss 299 BS.length rho @?= 32 300 , testCase "deriveMu produces 32 bytes" $ do 301 let ss = SharedSecret (BS.replicate 32 0) 302 DerivedKey mu = deriveMu ss 303 BS.length mu @?= 32 304 , testCase "deriveUm produces 32 bytes" $ do 305 let ss = SharedSecret (BS.replicate 32 0) 306 DerivedKey um = deriveUm ss 307 BS.length um @?= 32 308 , testCase "derivePad produces 32 bytes" $ do 309 let ss = SharedSecret (BS.replicate 32 0) 310 DerivedKey pad = derivePad ss 311 BS.length pad @?= 32 312 , testCase "deriveAmmag produces 32 bytes" $ do 313 let ss = SharedSecret (BS.replicate 32 0) 314 DerivedKey ammag = deriveAmmag ss 315 BS.length ammag @?= 32 316 , testCase "different key types produce different results" $ do 317 let ss = SharedSecret (BS.replicate 32 0x42) 318 DerivedKey rho = deriveRho ss 319 DerivedKey mu = deriveMu ss 320 DerivedKey um = deriveUm ss 321 assertBool "rho /= mu" (rho /= mu) 322 assertBool "mu /= um" (mu /= um) 323 assertBool "rho /= um" (rho /= um) 324 ] 325 326 testBlindPubKey :: TestTree 327 testBlindPubKey = testGroup "key blinding" [ 328 testCase "blindPubKey produces valid key" $ do 329 sk <- demand "roll32" $ Secp256k1.roll32 sessionKey 330 pubKey <- demand "derive_pub" $ Secp256k1.derive_pub sk 331 let bf = BlindingFactor (fromHex hop0BlindingFactorHex) 332 case blindPubKey pubKey bf of 333 Nothing -> 334 assertFailure "blindPubKey returned Nothing" 335 Just _blinded -> return () 336 , testCase "blindSecKey produces valid key" $ do 337 let bf = BlindingFactor (fromHex hop0BlindingFactorHex) 338 case blindSecKey sessionKey bf of 339 Nothing -> 340 assertFailure "blindSecKey returned Nothing" 341 Just _blinded -> return () 342 ] 343 344 testGenerateStream :: TestTree 345 testGenerateStream = testGroup "generateStream" [ 346 testCase "produces correct length" $ do 347 let dk = DerivedKey (BS.replicate 32 0) 348 stream = generateStream dk 100 349 BS.length stream @?= 100 350 , testCase "1300-byte stream for hop_payloads" $ do 351 let dk = DerivedKey (BS.replicate 32 0x42) 352 stream = generateStream dk 1300 353 BS.length stream @?= 1300 354 , testCase "deterministic output" $ do 355 let dk = DerivedKey (BS.replicate 32 0x55) 356 stream1 = generateStream dk 64 357 stream2 = generateStream dk 64 358 stream1 @?= stream2 359 ] 360 361 testHmacOperations :: TestTree 362 testHmacOperations = testGroup "HMAC operations" [ 363 testCase "computeHmac produces 32 bytes" $ do 364 let dk = DerivedKey (BS.replicate 32 0) 365 hm = computeHmac dk "payloads" "assocdata" 366 BS.length hm @?= 32 367 , testCase "verifyHmac succeeds for matching" $ do 368 let dk = DerivedKey (BS.replicate 32 0) 369 hm = computeHmac dk "payloads" "assocdata" 370 assertBool "verifyHmac should succeed" 371 (verifyHmac hm hm) 372 , testCase "verifyHmac fails for different" $ do 373 let dk = DerivedKey (BS.replicate 32 0) 374 hm1 = computeHmac dk "payloads1" "assocdata" 375 hm2 = computeHmac dk "payloads2" "assocdata" 376 assertBool "verifyHmac should fail" 377 (not $ verifyHmac hm1 hm2) 378 , testCase "verifyHmac fails for different lengths" $ do 379 assertBool "verifyHmac should fail" 380 (not $ verifyHmac "short" "different length") 381 ] 382 383 -- Construct tests ---------------------------------------------------------- 384 385 -- Test vectors from BOLT4 spec 386 hop1PubKeyHex :: BS.ByteString 387 hop1PubKeyHex = 388 "0324653eac434488002cc06bbfb7f10fe18991e35f9fe4302dbea6d2353dc0ab1c" 389 390 hop2PubKeyHex :: BS.ByteString 391 hop2PubKeyHex = 392 "027f31ebc5462c1fdce1b737ecff52d37d75dea43ce11c74d25aa297165faa2007" 393 394 hop3PubKeyHex :: BS.ByteString 395 hop3PubKeyHex = 396 "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991" 397 398 hop4PubKeyHex :: BS.ByteString 399 hop4PubKeyHex = 400 "02edabbd16b41c8371b92ef2f04c1185b4f03b6dcd52ba9b78d9d7c89c8f221145" 401 402 -- Expected shared secrets from BOLT4 error test vectors 403 hop1SharedSecretHex :: BS.ByteString 404 hop1SharedSecretHex = 405 "a6519e98832a0b179f62123b3567c106db99ee37bef036e783263602f3488fae" 406 407 hop2SharedSecretHex :: BS.ByteString 408 hop2SharedSecretHex = 409 "3a6b412548762f0dbccce5c7ae7bb8147d1caf9b5471c34120b30bc9c04891cc" 410 411 hop3SharedSecretHex :: BS.ByteString 412 hop3SharedSecretHex = 413 "21e13c2d7cfe7e18836df50872466117a295783ab8aab0e7ecc8c725503ad02d" 414 415 hop4SharedSecretHex :: BS.ByteString 416 hop4SharedSecretHex = 417 "b5756b9b542727dbafc6765a49488b023a725d631af688fc031217e90770c328" 418 419 constructTests :: TestTree 420 constructTests = testGroup "packet construction" [ 421 testConstructErrorCases 422 , testSharedSecretComputation 423 , testPacketStructure 424 , testSingleHop 425 ] 426 427 testConstructErrorCases :: TestTree 428 testConstructErrorCases = testGroup "error cases" [ 429 testCase "rejects invalid session key (too short)" $ do 430 let result = construct (BS.replicate 31 0x41) [] "" 431 case result of 432 Left InvalidSessionKey -> return () 433 _ -> assertFailure "Expected InvalidSessionKey" 434 , testCase "rejects invalid session key (too long)" $ do 435 let result = construct (BS.replicate 33 0x41) [] "" 436 case result of 437 Left InvalidSessionKey -> return () 438 _ -> assertFailure "Expected InvalidSessionKey" 439 , testCase "rejects empty route" $ do 440 let result = construct sessionKey [] "" 441 case result of 442 Left EmptyRoute -> return () 443 _ -> assertFailure "Expected EmptyRoute" 444 , testCase "rejects too many hops" $ do 445 pub <- demand "parse_point" $ 446 Secp256k1.parse_point (fromHex hop0PubKeyHex) 447 let emptyPayload = HopPayload Nothing Nothing Nothing 448 Nothing Nothing Nothing [] 449 hop = Hop pub emptyPayload 450 hops = replicate 21 hop 451 result = construct sessionKey hops "" 452 case result of 453 Left TooManyHops -> return () 454 _ -> assertFailure "Expected TooManyHops" 455 ] 456 457 testSharedSecretComputation :: TestTree 458 testSharedSecretComputation = 459 testCase "computes correct shared secrets (BOLT4 spec)" $ do 460 pub0 <- demand "parse_point" $ 461 Secp256k1.parse_point (fromHex hop0PubKeyHex) 462 pub1 <- demand "parse_point" $ 463 Secp256k1.parse_point (fromHex hop1PubKeyHex) 464 pub2 <- demand "parse_point" $ 465 Secp256k1.parse_point (fromHex hop2PubKeyHex) 466 pub3 <- demand "parse_point" $ 467 Secp256k1.parse_point (fromHex hop3PubKeyHex) 468 pub4 <- demand "parse_point" $ 469 Secp256k1.parse_point (fromHex hop4PubKeyHex) 470 let emptyPayload = HopPayload Nothing Nothing Nothing 471 Nothing Nothing Nothing [] 472 hops = [ Hop pub0 emptyPayload 473 , Hop pub1 emptyPayload 474 , Hop pub2 emptyPayload 475 , Hop pub3 emptyPayload 476 , Hop pub4 emptyPayload 477 ] 478 result = construct sessionKey hops "" 479 case result of 480 Left err -> 481 assertFailure $ "construct failed: " ++ show err 482 Right (_, secrets) -> case secrets of 483 [SharedSecret ss0, SharedSecret ss1, 484 SharedSecret ss2, SharedSecret ss3, 485 SharedSecret ss4] -> do 486 ss0 @?= fromHex hop0SharedSecretHex 487 ss1 @?= fromHex hop1SharedSecretHex 488 ss2 @?= fromHex hop2SharedSecretHex 489 ss3 @?= fromHex hop3SharedSecretHex 490 ss4 @?= fromHex hop4SharedSecretHex 491 _ -> assertFailure "expected 5 shared secrets" 492 493 testPacketStructure :: TestTree 494 testPacketStructure = 495 testCase "produces valid packet structure" $ do 496 pub0 <- demand "parse_point" $ 497 Secp256k1.parse_point (fromHex hop0PubKeyHex) 498 pub1 <- demand "parse_point" $ 499 Secp256k1.parse_point (fromHex hop1PubKeyHex) 500 let emptyPayload = HopPayload Nothing Nothing Nothing 501 Nothing Nothing Nothing [] 502 hops = [Hop pub0 emptyPayload, 503 Hop pub1 emptyPayload] 504 result = construct sessionKey hops "" 505 case result of 506 Left err -> 507 assertFailure $ "construct failed: " ++ show err 508 Right (packet, _) -> do 509 opVersion packet @?= versionByte 510 BS.length (opEphemeralKey packet) @?= pubkeySize 511 BS.length (unHopPayloads (opHopPayloads packet)) 512 @?= hopPayloadsSize 513 BS.length (unHmac32 (opHmac packet)) @?= hmacSize 514 sk <- demand "roll32" $ Secp256k1.roll32 sessionKey 515 expectedPub <- demand "derive_pub" $ 516 Secp256k1.derive_pub sk 517 let expectedPubBytes = 518 Secp256k1.serialize_point expectedPub 519 opEphemeralKey packet @?= expectedPubBytes 520 521 testSingleHop :: TestTree 522 testSingleHop = 523 testCase "constructs single-hop packet" $ do 524 pub0 <- demand "parse_point" $ 525 Secp256k1.parse_point (fromHex hop0PubKeyHex) 526 let payload = HopPayload 527 { hpAmtToForward = Just 1000 528 , hpOutgoingCltv = Just 500000 529 , hpShortChannelId = Nothing 530 , hpPaymentData = Nothing 531 , hpEncryptedData = Nothing 532 , hpCurrentPathKey = Nothing 533 , hpUnknownTlvs = [] 534 } 535 hops = [Hop pub0 payload] 536 result = construct sessionKey hops "" 537 case result of 538 Left err -> 539 assertFailure $ "construct failed: " ++ show err 540 Right (packet, secrets) -> do 541 length secrets @?= 1 542 -- Packet should be valid structure 543 let encoded = encodeOnionPacket packet 544 BS.length encoded @?= onionPacketSize 545 -- Should decode back 546 decoded <- demand "decodeOnionPacket" $ 547 decodeOnionPacket encoded 548 decoded @?= packet 549 550 -- Process tests ----------------------------------------------------------- 551 552 processTests :: TestTree 553 processTests = testGroup "packet processing" [ 554 testVersionValidation 555 , testEphemeralKeyValidation 556 , testHmacValidation 557 , testProcessBasic 558 ] 559 560 testVersionValidation :: TestTree 561 testVersionValidation = testGroup "version validation" [ 562 testCase "reject invalid version 0x01" $ do 563 let packet = OnionPacket 564 { opVersion = 0x01 565 , opEphemeralKey = BS.replicate 33 0x02 566 , opHopPayloads = 567 unsafeHopPayloads (BS.replicate 1300 0x00) 568 , opHmac = 569 unsafeHmac32 (BS.replicate 32 0x00) 570 } 571 case process sessionKey packet BS.empty of 572 Left (InvalidVersion v) -> v @?= 0x01 573 Left other -> 574 assertFailure $ "expected InvalidVersion, got: " 575 ++ show other 576 Right _ -> 577 assertFailure "expected rejection, got success" 578 , testCase "reject invalid version 0xFF" $ do 579 let packet = OnionPacket 580 { opVersion = 0xFF 581 , opEphemeralKey = BS.replicate 33 0x02 582 , opHopPayloads = 583 unsafeHopPayloads (BS.replicate 1300 0x00) 584 , opHmac = 585 unsafeHmac32 (BS.replicate 32 0x00) 586 } 587 case process sessionKey packet BS.empty of 588 Left (InvalidVersion v) -> v @?= 0xFF 589 Left other -> 590 assertFailure $ "expected InvalidVersion, got: " 591 ++ show other 592 Right _ -> 593 assertFailure "expected rejection, got success" 594 ] 595 596 testEphemeralKeyValidation :: TestTree 597 testEphemeralKeyValidation = 598 testGroup "ephemeral key validation" [ 599 testCase "reject invalid ephemeral key (all zeros)" $ do 600 let packet = OnionPacket 601 { opVersion = 0x00 602 , opEphemeralKey = BS.replicate 33 0x00 603 , opHopPayloads = 604 unsafeHopPayloads (BS.replicate 1300 0x00) 605 , opHmac = 606 unsafeHmac32 (BS.replicate 32 0x00) 607 } 608 case process sessionKey packet BS.empty of 609 Left InvalidEphemeralKey -> return () 610 Left other -> 611 assertFailure $ 612 "expected InvalidEphemeralKey, got: " 613 ++ show other 614 Right _ -> 615 assertFailure "expected rejection, got success" 616 , testCase "reject malformed ephemeral key" $ do 617 let packet = OnionPacket 618 { opVersion = 0x00 619 , opEphemeralKey = 620 BS.pack (0x04 : replicate 32 0xAB) 621 , opHopPayloads = 622 unsafeHopPayloads (BS.replicate 1300 0x00) 623 , opHmac = 624 unsafeHmac32 (BS.replicate 32 0x00) 625 } 626 case process sessionKey packet BS.empty of 627 Left InvalidEphemeralKey -> return () 628 Left other -> 629 assertFailure $ 630 "expected InvalidEphemeralKey, got: " 631 ++ show other 632 Right _ -> 633 assertFailure "expected rejection, got success" 634 ] 635 636 testHmacValidation :: TestTree 637 testHmacValidation = testGroup "HMAC validation" [ 638 testCase "reject invalid HMAC" $ do 639 hop0PubKey <- demand "parse_point" $ 640 Secp256k1.parse_point (fromHex hop0PubKeyHex) 641 let ephKeyBytes = 642 Secp256k1.serialize_point hop0PubKey 643 packet = OnionPacket 644 { opVersion = 0x00 645 , opEphemeralKey = ephKeyBytes 646 , opHopPayloads = 647 unsafeHopPayloads (BS.replicate 1300 0x00) 648 , opHmac = 649 unsafeHmac32 (BS.replicate 32 0xFF) 650 } 651 case process sessionKey packet BS.empty of 652 Left HmacMismatch -> return () 653 Left other -> 654 assertFailure $ "expected HmacMismatch, got: " 655 ++ show other 656 Right _ -> 657 assertFailure "expected rejection, got success" 658 ] 659 660 -- | Test basic packet processing with a properly constructed 661 -- packet. 662 testProcessBasic :: TestTree 663 testProcessBasic = testGroup "basic processing" [ 664 testCase "process valid packet (final hop)" $ do 665 hop0PubKey <- demand "parse_point" $ 666 Secp256k1.parse_point (fromHex hop0PubKeyHex) 667 let ephKeyBytes = 668 Secp256k1.serialize_point hop0PubKey 669 hopPayloadTlv = encodeHopPayload HopPayload 670 { hpAmtToForward = Just 1000 671 , hpOutgoingCltv = Just 500000 672 , hpShortChannelId = Nothing 673 , hpPaymentData = Nothing 674 , hpEncryptedData = Nothing 675 , hpCurrentPathKey = Nothing 676 , hpUnknownTlvs = [] 677 } 678 payloadLen = BS.length hopPayloadTlv 679 lenPrefix = 680 encodeBigSize (fromIntegral payloadLen) 681 payloadWithHmac = lenPrefix <> hopPayloadTlv 682 <> BS.replicate 32 0x00 683 padding = BS.replicate 684 (1300 - BS.length payloadWithHmac) 0x00 685 rawPayloads = payloadWithHmac <> padding 686 ss <- demand "computeSharedSecret" $ 687 computeSharedSecret sessionKey hop0PubKey 688 let rhoKey = deriveRho ss 689 muKey = deriveMu ss 690 stream = generateStream rhoKey 1300 691 encryptedPayloads = 692 BS.pack (BS.zipWith xor rawPayloads stream) 693 correctHmac = 694 computeHmac muKey encryptedPayloads BS.empty 695 packet = OnionPacket 696 { opVersion = 0x00 697 , opEphemeralKey = ephKeyBytes 698 , opHopPayloads = 699 unsafeHopPayloads encryptedPayloads 700 , opHmac = unsafeHmac32 correctHmac 701 } 702 703 case process sessionKey packet BS.empty of 704 Left err -> 705 assertFailure $ 706 "expected success, got: " ++ show err 707 Right (Receive ri) -> do 708 hpAmtToForward (riPayload ri) @?= Just 1000 709 hpOutgoingCltv (riPayload ri) @?= Just 500000 710 Right (Forward _) -> 711 assertFailure "expected Receive, got Forward" 712 ] 713 714 -- Error tests ------------------------------------------------------------- 715 716 errorTests :: TestTree 717 errorTests = testGroup "error handling" [ 718 testErrorConstruction 719 , testErrorRoundtrip 720 , testMultiHopWrapping 721 , testErrorAttribution 722 , testFailureMessageParsing 723 ] 724 725 -- Shared secrets for testing (deterministic) 726 testSecret1 :: SharedSecret 727 testSecret1 = SharedSecret (BS.replicate 32 0x11) 728 729 testSecret2 :: SharedSecret 730 testSecret2 = SharedSecret (BS.replicate 32 0x22) 731 732 testSecret3 :: SharedSecret 733 testSecret3 = SharedSecret (BS.replicate 32 0x33) 734 735 testSecret4 :: SharedSecret 736 testSecret4 = SharedSecret (BS.replicate 32 0x44) 737 738 -- Simple failure message for testing 739 testFailure :: FailureMessage 740 testFailure = 741 FailureMessage IncorrectOrUnknownPaymentDetails BS.empty [] 742 743 testErrorConstruction :: TestTree 744 testErrorConstruction = 745 testCase "error packet construction" $ do 746 let errPacket = constructError testSecret1 testFailure 747 ErrorPacket bs = errPacket 748 assertBool "error packet >= 256 bytes" 749 (BS.length bs >= minErrorPacketSize) 750 751 testErrorRoundtrip :: TestTree 752 testErrorRoundtrip = 753 testCase "construct and unwrap roundtrip" $ do 754 let errPacket = constructError testSecret1 testFailure 755 result = unwrapError [testSecret1] errPacket 756 case result of 757 Attributed idx msg -> do 758 idx @?= 0 759 fmCode msg @?= IncorrectOrUnknownPaymentDetails 760 UnknownOrigin _ -> 761 assertFailure 762 "Expected Attributed, got UnknownOrigin" 763 764 testMultiHopWrapping :: TestTree 765 testMultiHopWrapping = testGroup "multi-hop wrapping" [ 766 testCase "3-hop route, error from hop 2 (final)" $ do 767 let secrets = 768 [testSecret1, testSecret2, testSecret3] 769 err0 = constructError testSecret3 testFailure 770 err1 = wrapError testSecret2 err0 771 err2 = wrapError testSecret1 err1 772 result = unwrapError secrets err2 773 case result of 774 Attributed idx msg -> do 775 idx @?= 2 776 fmCode msg @?= IncorrectOrUnknownPaymentDetails 777 UnknownOrigin _ -> 778 assertFailure 779 "Expected Attributed, got UnknownOrigin" 780 781 , testCase "4-hop route, error from hop 1" $ do 782 let secrets = [testSecret1, testSecret2, 783 testSecret3, testSecret4] 784 err0 = constructError testSecret2 testFailure 785 err1 = wrapError testSecret1 err0 786 result = unwrapError secrets err1 787 case result of 788 Attributed idx msg -> do 789 idx @?= 1 790 fmCode msg @?= IncorrectOrUnknownPaymentDetails 791 UnknownOrigin _ -> 792 assertFailure 793 "Expected Attributed, got UnknownOrigin" 794 795 , testCase "4-hop route, error from hop 0 (first)" $ do 796 let secrets = [testSecret1, testSecret2, 797 testSecret3, testSecret4] 798 err0 = constructError testSecret1 testFailure 799 result = unwrapError secrets err0 800 case result of 801 Attributed idx msg -> do 802 idx @?= 0 803 fmCode msg @?= IncorrectOrUnknownPaymentDetails 804 UnknownOrigin _ -> 805 assertFailure 806 "Expected Attributed, got UnknownOrigin" 807 ] 808 809 testErrorAttribution :: TestTree 810 testErrorAttribution = testGroup "error attribution" [ 811 testCase "wrong secrets gives UnknownOrigin" $ do 812 let err = constructError testSecret1 testFailure 813 wrongSecrets = [testSecret2, testSecret3] 814 result = unwrapError wrongSecrets err 815 case result of 816 UnknownOrigin _ -> return () 817 Attributed _ _ -> 818 assertFailure 819 "Expected UnknownOrigin with wrong secrets" 820 821 , testCase "empty secrets gives UnknownOrigin" $ do 822 let err = constructError testSecret1 testFailure 823 result = unwrapError [] err 824 case result of 825 UnknownOrigin _ -> return () 826 Attributed _ _ -> 827 assertFailure 828 "Expected UnknownOrigin with empty secrets" 829 830 , testCase "correct attribution with multiple failures" $ do 831 let failures = 832 [ (TemporaryNodeFailure, testSecret1) 833 , (PermanentNodeFailure, testSecret2) 834 , (InvalidOnionHmac, testSecret3) 835 ] 836 mapM_ (\(code, secret) -> do 837 let failure = FailureMessage code BS.empty [] 838 err = constructError secret failure 839 result = unwrapError [secret] err 840 case result of 841 Attributed 0 msg -> fmCode msg @?= code 842 _ -> assertFailure $ 843 "Failed for code: " ++ show code 844 ) failures 845 ] 846 847 testFailureMessageParsing :: TestTree 848 testFailureMessageParsing = 849 testGroup "failure message parsing" [ 850 testCase "code with data" $ do 851 let failData = BS.replicate 10 0xAB 852 failure = 853 FailureMessage AmountBelowMinimum failData [] 854 err = constructError testSecret1 failure 855 result = unwrapError [testSecret1] err 856 case result of 857 Attributed 0 msg -> do 858 fmCode msg @?= AmountBelowMinimum 859 fmData msg @?= failData 860 _ -> assertFailure "Expected Attributed" 861 862 , testCase "various failure codes roundtrip" $ do 863 let codes = 864 [ InvalidRealm 865 , TemporaryNodeFailure 866 , PermanentNodeFailure 867 , InvalidOnionHmac 868 , TemporaryChannelFailure 869 , IncorrectOrUnknownPaymentDetails 870 ] 871 mapM_ (\code -> do 872 let failure = FailureMessage code BS.empty [] 873 err = constructError testSecret1 failure 874 result = unwrapError [testSecret1] err 875 case result of 876 Attributed 0 msg -> fmCode msg @?= code 877 _ -> assertFailure $ 878 "Failed for code: " ++ show code 879 ) codes 880 ] 881 882 -- Blinding tests ----------------------------------------------------------- 883 884 -- Test data setup 885 886 testSeed :: BS.ByteString 887 testSeed = BS.pack [1..32] 888 889 makeSecKey :: Word8 -> BS.ByteString 890 makeSecKey seed = BS.pack $ replicate 31 0x00 ++ [seed] 891 892 makePubKey :: Word8 -> Maybe Secp256k1.Projective 893 makePubKey seed = do 894 sk <- Secp256k1.roll32 (makeSecKey seed) 895 Secp256k1.derive_pub sk 896 897 testNodeSecKey1, testNodeSecKey2, 898 testNodeSecKey3 :: BS.ByteString 899 testNodeSecKey1 = makeSecKey 0x11 900 testNodeSecKey2 = makeSecKey 0x22 901 testNodeSecKey3 = makeSecKey 0x33 902 903 testNodePubKey1, testNodePubKey2, 904 testNodePubKey3 :: Secp256k1.Projective 905 testNodePubKey1 = case makePubKey 0x11 of 906 Just pk -> pk 907 Nothing -> error "testNodePubKey1: invalid key" 908 testNodePubKey2 = case makePubKey 0x22 of 909 Just pk -> pk 910 Nothing -> error "testNodePubKey2: invalid key" 911 testNodePubKey3 = case makePubKey 0x33 of 912 Just pk -> pk 913 Nothing -> error "testNodePubKey3: invalid key" 914 915 testSharedSecretBS :: SharedSecret 916 testSharedSecretBS = SharedSecret (BS.pack [0x42..0x61]) 917 918 emptyHopData :: BlindedHopData 919 emptyHopData = BlindedHopData 920 Nothing Nothing Nothing Nothing 921 Nothing Nothing Nothing Nothing 922 923 sampleHopData :: BlindedHopData 924 sampleHopData = BlindedHopData 925 { bhdPadding = Nothing 926 , bhdShortChannelId = Just (mkScid 700000 1234 0) 927 , bhdNextNodeId = Nothing 928 , bhdPathId = Just (BS.pack [0x42, 0x42]) 929 , bhdNextPathKeyOverride = Nothing 930 , bhdPaymentRelay = Just (PaymentRelay 40 1000 500) 931 , bhdPaymentConstraints = 932 Just (PaymentConstraints 144 1000000) 933 , bhdAllowedFeatures = Nothing 934 } 935 936 hopDataWithNextNode :: BlindedHopData 937 hopDataWithNextNode = emptyHopData 938 { bhdNextNodeId = 939 Just (Secp256k1.serialize_point testNodePubKey2) 940 } 941 942 -- 1. Key Derivation Tests ------------------------------------------------- 943 944 blindingKeyDerivationTests :: TestTree 945 blindingKeyDerivationTests = testGroup "key derivation" [ 946 testCase "deriveBlindingRho produces 32 bytes" $ do 947 let DerivedKey rho = 948 deriveBlindingRho testSharedSecretBS 949 BS.length rho @?= 32 950 951 , testCase "deriveBlindingRho is deterministic" $ do 952 let rho1 = deriveBlindingRho testSharedSecretBS 953 rho2 = deriveBlindingRho testSharedSecretBS 954 rho1 @?= rho2 955 956 , testCase "deriveBlindingRho differs for diff secrets" $ do 957 let ss1 = SharedSecret (BS.replicate 32 0x00) 958 ss2 = SharedSecret (BS.replicate 32 0x01) 959 rho1 = deriveBlindingRho ss1 960 rho2 = deriveBlindingRho ss2 961 assertBool "rho values should differ" (rho1 /= rho2) 962 963 , testCase "deriveBlindedNodeId produces 33 bytes" $ do 964 case deriveBlindedNodeId 965 testSharedSecretBS testNodePubKey1 of 966 Nothing -> 967 assertFailure 968 "deriveBlindedNodeId returned Nothing" 969 Just blindedId -> BS.length blindedId @?= 33 970 971 , testCase "deriveBlindedNodeId is deterministic" $ do 972 let result1 = deriveBlindedNodeId 973 testSharedSecretBS testNodePubKey1 974 result2 = deriveBlindedNodeId 975 testSharedSecretBS testNodePubKey1 976 result1 @?= result2 977 978 , testCase "deriveBlindedNodeId differs for diff nodes" $ do 979 let result1 = deriveBlindedNodeId 980 testSharedSecretBS testNodePubKey1 981 result2 = deriveBlindedNodeId 982 testSharedSecretBS testNodePubKey2 983 assertBool "blinded node IDs should differ" 984 (result1 /= result2) 985 ] 986 987 -- 2. Ephemeral Key Iteration Tests ---------------------------------------- 988 989 -- | Derive the public key for testSeed 990 testSeedPubKey :: Secp256k1.Projective 991 testSeedPubKey = case Secp256k1.roll32 testSeed of 992 Nothing -> error "testSeedPubKey: invalid seed" 993 Just sk -> case Secp256k1.derive_pub sk of 994 Nothing -> error "testSeedPubKey: invalid key" 995 Just pk -> pk 996 997 blindingEphemeralKeyTests :: TestTree 998 blindingEphemeralKeyTests = 999 testGroup "ephemeral key iteration" [ 1000 testCase "nextEphemeral produces valid keys" $ do 1001 case nextEphemeral 1002 testSeed testSeedPubKey testSharedSecretBS of 1003 Nothing -> 1004 assertFailure "nextEphemeral returned Nothing" 1005 Just (newSecKey, newPubKey) -> do 1006 BS.length newSecKey @?= 32 1007 let serialized = 1008 Secp256k1.serialize_point newPubKey 1009 BS.length serialized @?= 33 1010 1011 , testCase "nextEphemeral: sec key derives pub key" $ do 1012 case nextEphemeral 1013 testSeed testSeedPubKey testSharedSecretBS of 1014 Nothing -> 1015 assertFailure "nextEphemeral returned Nothing" 1016 Just (newSecKey, newPubKey) -> do 1017 sk <- demand "roll32" $ 1018 Secp256k1.roll32 newSecKey 1019 derivedPub <- demand "derive_pub" $ 1020 Secp256k1.derive_pub sk 1021 derivedPub @?= newPubKey 1022 1023 , testCase "nextEphemeral is deterministic" $ do 1024 let result1 = nextEphemeral 1025 testSeed testSeedPubKey 1026 testSharedSecretBS 1027 result2 = nextEphemeral 1028 testSeed testSeedPubKey 1029 testSharedSecretBS 1030 result1 @?= result2 1031 1032 , testCase "nextEphemeral differs for diff secrets" $ do 1033 let ss1 = SharedSecret (BS.replicate 32 0xAA) 1034 ss2 = SharedSecret (BS.replicate 32 0xBB) 1035 result1 = nextEphemeral 1036 testSeed testSeedPubKey ss1 1037 result2 = nextEphemeral 1038 testSeed testSeedPubKey ss2 1039 assertBool "results should differ" 1040 (result1 /= result2) 1041 ] 1042 1043 -- 3. TLV Encoding/Decoding Tests ----------------------------------------- 1044 1045 blindingTlvTests :: TestTree 1046 blindingTlvTests = testGroup "TLV encoding/decoding" [ 1047 testCase "roundtrip: empty hop data" $ do 1048 let encoded = encodeBlindedHopData emptyHopData 1049 decoded = decodeBlindedHopData encoded 1050 decoded @?= Just emptyHopData 1051 1052 , testCase "roundtrip: sample hop data" $ do 1053 let encoded = encodeBlindedHopData sampleHopData 1054 decoded = decodeBlindedHopData encoded 1055 decoded @?= Just sampleHopData 1056 1057 , testCase "roundtrip: hop data with next node ID" $ do 1058 let encoded = encodeBlindedHopData hopDataWithNextNode 1059 decoded = decodeBlindedHopData encoded 1060 decoded @?= Just hopDataWithNextNode 1061 1062 , testCase "roundtrip: hop data with padding" $ do 1063 let hd = emptyHopData 1064 { bhdPadding = Just (BS.replicate 16 0x00) } 1065 encoded = encodeBlindedHopData hd 1066 decoded = decodeBlindedHopData encoded 1067 decoded @?= Just hd 1068 1069 , testCase "PaymentRelay encoding/decoding" $ do 1070 let relay = PaymentRelay 40 1000 500 1071 hd = emptyHopData 1072 { bhdPaymentRelay = Just relay } 1073 encoded = encodeBlindedHopData hd 1074 decoded = decodeBlindedHopData encoded 1075 case decoded of 1076 Nothing -> 1077 assertFailure 1078 "decodeBlindedHopData returned Nothing" 1079 Just d -> bhdPaymentRelay d @?= Just relay 1080 1081 , testCase "PaymentConstraints encoding/decoding" $ do 1082 let constraints = PaymentConstraints 144 1000000 1083 hd = emptyHopData 1084 { bhdPaymentConstraints = Just constraints } 1085 encoded = encodeBlindedHopData hd 1086 decoded = decodeBlindedHopData encoded 1087 case decoded of 1088 Nothing -> 1089 assertFailure 1090 "decodeBlindedHopData returned Nothing" 1091 Just d -> 1092 bhdPaymentConstraints d @?= Just constraints 1093 1094 , testCase "decode empty bytestring" $ do 1095 let decoded = decodeBlindedHopData BS.empty 1096 decoded @?= Just emptyHopData 1097 ] 1098 1099 -- 4. Encryption/Decryption Tests ------------------------------------------ 1100 1101 blindingEncryptionTests :: TestTree 1102 blindingEncryptionTests = 1103 testGroup "encryption/decryption" [ 1104 testCase "roundtrip: encrypt then decrypt" $ do 1105 let rho = deriveBlindingRho testSharedSecretBS 1106 encrypted = encryptHopData rho sampleHopData 1107 decrypted = decryptHopData rho encrypted 1108 decrypted @?= Just sampleHopData 1109 1110 , testCase "roundtrip: empty hop data" $ do 1111 let rho = deriveBlindingRho testSharedSecretBS 1112 encrypted = encryptHopData rho emptyHopData 1113 decrypted = decryptHopData rho encrypted 1114 decrypted @?= Just emptyHopData 1115 1116 , testCase "decryption with wrong key fails" $ do 1117 let rho1 = deriveBlindingRho testSharedSecretBS 1118 rho2 = deriveBlindingRho 1119 (SharedSecret (BS.replicate 32 0xFF)) 1120 encrypted = encryptHopData rho1 sampleHopData 1121 decrypted = decryptHopData rho2 encrypted 1122 assertBool "decryption should fail or produce garbage" 1123 (decrypted /= Just sampleHopData) 1124 1125 , testCase "encrypt is deterministic" $ do 1126 let rho = deriveBlindingRho testSharedSecretBS 1127 encrypted1 = encryptHopData rho sampleHopData 1128 encrypted2 = encryptHopData rho sampleHopData 1129 encrypted1 @?= encrypted2 1130 ] 1131 1132 -- 5. createBlindedPath Tests ---------------------------------------------- 1133 1134 blindingCreatePathTests :: TestTree 1135 blindingCreatePathTests = testGroup "createBlindedPath" [ 1136 testCase "create path with 2 hops" $ do 1137 let nodes = [(testNodePubKey1, emptyHopData), 1138 (testNodePubKey2, sampleHopData)] 1139 case createBlindedPath testSeed nodes of 1140 Left err -> 1141 assertFailure $ 1142 "createBlindedPath failed: " ++ show err 1143 Right path -> do 1144 length (bpBlindedHops path) @?= 2 1145 let serialized = 1146 Secp256k1.serialize_point 1147 (bpBlindingKey path) 1148 BS.length serialized @?= 33 1149 1150 , testCase "create path with 3 hops" $ do 1151 let nodes = [ (testNodePubKey1, emptyHopData) 1152 , (testNodePubKey2, hopDataWithNextNode) 1153 , (testNodePubKey3, sampleHopData) 1154 ] 1155 case createBlindedPath testSeed nodes of 1156 Left err -> 1157 assertFailure $ 1158 "createBlindedPath failed: " ++ show err 1159 Right path -> 1160 length (bpBlindedHops path) @?= 3 1161 1162 , testCase "all blinded node IDs are 33 bytes" $ do 1163 let nodes = [ (testNodePubKey1, emptyHopData) 1164 , (testNodePubKey2, emptyHopData) 1165 , (testNodePubKey3, emptyHopData) 1166 ] 1167 case createBlindedPath testSeed nodes of 1168 Left err -> 1169 assertFailure $ 1170 "createBlindedPath failed: " ++ show err 1171 Right path -> do 1172 let blindedIds = 1173 map bhBlindedNodeId (bpBlindedHops path) 1174 mapM_ (\bid -> BS.length bid @?= 33) blindedIds 1175 1176 , testCase "empty path returns EmptyPath error" $ do 1177 case createBlindedPath testSeed [] of 1178 Left EmptyPath -> return () 1179 Left err -> 1180 assertFailure $ 1181 "Expected EmptyPath, got: " ++ show err 1182 Right _ -> 1183 assertFailure "Expected error, got success" 1184 1185 , testCase "invalid seed returns InvalidSeed error" $ do 1186 let invalidSeed = BS.pack [1..16] 1187 nodes = [(testNodePubKey1, emptyHopData)] 1188 case createBlindedPath invalidSeed nodes of 1189 Left InvalidSeed -> return () 1190 Left err -> 1191 assertFailure $ 1192 "Expected InvalidSeed, got: " ++ show err 1193 Right _ -> 1194 assertFailure "Expected error, got success" 1195 1196 , testCase "createBlindedPath is deterministic" $ do 1197 let nodes = [(testNodePubKey1, emptyHopData), 1198 (testNodePubKey2, sampleHopData)] 1199 result1 = createBlindedPath testSeed nodes 1200 result2 = createBlindedPath testSeed nodes 1201 result1 @?= result2 1202 ] 1203 1204 -- 6. processBlindedHop Tests ---------------------------------------------- 1205 1206 blindingProcessHopTests :: TestTree 1207 blindingProcessHopTests = 1208 testGroup "processBlindedHop" [ 1209 testCase "process first hop decrypts correctly" $ do 1210 let nodes = [(testNodePubKey1, sampleHopData), 1211 (testNodePubKey2, emptyHopData)] 1212 case createBlindedPath testSeed nodes of 1213 Left err -> 1214 assertFailure $ 1215 "createBlindedPath failed: " ++ show err 1216 Right path -> case bpBlindedHops path of 1217 firstHop : _ -> do 1218 let pathKey = bpBlindingKey path 1219 case processBlindedHop testNodeSecKey1 1220 pathKey (bhEncryptedData firstHop) of 1221 Left err -> assertFailure $ 1222 "processBlindedHop failed: " ++ show err 1223 Right (decryptedData, _) -> 1224 decryptedData @?= sampleHopData 1225 [] -> assertFailure "expected non-empty hops" 1226 1227 , testCase "process hop chain correctly" $ do 1228 let nodes = 1229 [ (testNodePubKey1, emptyHopData) 1230 , (testNodePubKey2, sampleHopData) 1231 , (testNodePubKey3, hopDataWithNextNode) 1232 ] 1233 case createBlindedPath testSeed nodes of 1234 Left err -> 1235 assertFailure $ 1236 "createBlindedPath failed: " ++ show err 1237 Right path -> case bpBlindedHops path of 1238 [hop1, hop2, hop3] -> do 1239 let pathKey1 = bpBlindingKey path 1240 case processBlindedHop testNodeSecKey1 1241 pathKey1 (bhEncryptedData hop1) of 1242 Left err -> assertFailure $ 1243 "processBlindedHop hop1 failed: " 1244 ++ show err 1245 Right (data1, pathKey2) -> do 1246 data1 @?= emptyHopData 1247 case processBlindedHop testNodeSecKey2 1248 pathKey2 1249 (bhEncryptedData hop2) of 1250 Left err -> assertFailure $ 1251 "processBlindedHop hop2 failed: " 1252 ++ show err 1253 Right (data2, pathKey3) -> do 1254 data2 @?= sampleHopData 1255 case processBlindedHop 1256 testNodeSecKey3 pathKey3 1257 (bhEncryptedData hop3) of 1258 Left err -> assertFailure $ 1259 "processBlindedHop hop3: " 1260 ++ show err 1261 Right (data3, _) -> 1262 data3 @?= hopDataWithNextNode 1263 _ -> assertFailure "expected 3 blinded hops" 1264 1265 , testCase "process hop with wrong node key fails" $ do 1266 let nodes = [(testNodePubKey1, sampleHopData)] 1267 case createBlindedPath testSeed nodes of 1268 Left err -> 1269 assertFailure $ 1270 "createBlindedPath failed: " ++ show err 1271 Right path -> case bpBlindedHops path of 1272 firstHop : _ -> do 1273 let pathKey = bpBlindingKey path 1274 case processBlindedHop testNodeSecKey2 1275 pathKey (bhEncryptedData firstHop) of 1276 Left _ -> return () 1277 Right (decryptedData, _) -> 1278 assertBool "should not decrypt correctly" 1279 (decryptedData /= sampleHopData) 1280 [] -> assertFailure "expected non-empty hops" 1281 1282 , testCase "next path key is valid point" $ do 1283 let nodes = [(testNodePubKey1, emptyHopData), 1284 (testNodePubKey2, emptyHopData)] 1285 case createBlindedPath testSeed nodes of 1286 Left err -> 1287 assertFailure $ 1288 "createBlindedPath failed: " ++ show err 1289 Right path -> case bpBlindedHops path of 1290 firstHop : _ -> do 1291 let pathKey = bpBlindingKey path 1292 case processBlindedHop testNodeSecKey1 1293 pathKey (bhEncryptedData firstHop) of 1294 Left err -> assertFailure $ 1295 "processBlindedHop failed: " ++ show err 1296 Right (_, nextPK) -> do 1297 let serialized = 1298 Secp256k1.serialize_point nextPK 1299 BS.length serialized @?= 33 1300 [] -> assertFailure "expected non-empty hops" 1301 1302 , testCase "next_path_key_override is used" $ do 1303 let overrideKey = 1304 Secp256k1.serialize_point testNodePubKey3 1305 hopDataWithOverride' = emptyHopData 1306 { bhdNextPathKeyOverride = Just overrideKey } 1307 nodes = [(testNodePubKey1, hopDataWithOverride'), 1308 (testNodePubKey2, emptyHopData)] 1309 case createBlindedPath testSeed nodes of 1310 Left err -> 1311 assertFailure $ 1312 "createBlindedPath failed: " ++ show err 1313 Right path -> case bpBlindedHops path of 1314 firstHop : _ -> do 1315 let pathKey = bpBlindingKey path 1316 case processBlindedHop testNodeSecKey1 1317 pathKey (bhEncryptedData firstHop) of 1318 Left err -> assertFailure $ 1319 "processBlindedHop failed: " ++ show err 1320 Right (decryptedData, nextPK) -> do 1321 bhdNextPathKeyOverride decryptedData 1322 @?= Just overrideKey 1323 nextPK @?= testNodePubKey3 1324 [] -> assertFailure "expected non-empty hops" 1325 ] 1326 1327 -- Property tests ------------------------------------------------------------ 1328 1329 propertyTests :: TestTree 1330 propertyTests = testGroup "invariants" [ 1331 testProperty "ShortChannelId encode/decode roundtrip" 1332 propScidRoundtrip 1333 , testProperty "HopPayload encode/decode roundtrip" 1334 propHopPayloadRoundtrip 1335 , testProperty "fixed-size newtypes validate length" 1336 propNewtypeValidation 1337 , testProperty "FailureMessage encode/decode roundtrip" 1338 propFailureMessageRoundtrip 1339 ] 1340 1341 propScidRoundtrip :: Property 1342 propScidRoundtrip = 1343 forAll (choose (0, 0xFFFFFF)) $ \bh -> 1344 forAll (choose (0, 0xFFFFFF)) $ \ti -> 1345 forAll arbitrary $ \oi -> 1346 case shortChannelId bh ti oi of 1347 Nothing -> False 1348 Just scid -> 1349 let encoded = encodeShortChannelId scid 1350 in decodeShortChannelId encoded == Just scid 1351 1352 propHopPayloadRoundtrip :: Property 1353 propHopPayloadRoundtrip = 1354 forAll genHopPayload $ \hp -> 1355 let encoded = encodeHopPayload hp 1356 in decodeHopPayload encoded == Just hp 1357 1358 genHopPayload :: Gen HopPayload 1359 genHopPayload = do 1360 amt <- oneof [pure Nothing, Just <$> arbitrary] 1361 cltv <- oneof [pure Nothing, Just <$> arbitrary] 1362 sci <- oneof [pure Nothing, genScid] 1363 pure HopPayload 1364 { hpAmtToForward = amt 1365 , hpOutgoingCltv = cltv 1366 , hpShortChannelId = sci 1367 , hpPaymentData = Nothing 1368 , hpEncryptedData = Nothing 1369 , hpCurrentPathKey = Nothing 1370 , hpUnknownTlvs = [] 1371 } 1372 where 1373 genScid :: Gen (Maybe ShortChannelId) 1374 genScid = do 1375 bh <- choose (0, 0xFFFFFF) 1376 ti <- choose (0, 0xFFFFFF) 1377 oi <- arbitrary 1378 pure (shortChannelId bh ti oi) 1379 1380 propNewtypeValidation :: NonNegative Int -> Property 1381 propNewtypeValidation (NonNegative n) = property $ 1382 let len = n `mod` 2000 1383 bs = BS.replicate len 0x00 1384 h32 = hmac32 bs 1385 hp = hopPayloads bs 1386 ps = paymentSecret bs 1387 in (case h32 of 1388 Just _ -> len == 32 1389 Nothing -> len /= 32) 1390 && 1391 (case hp of 1392 Just _ -> len == hopPayloadsSize 1393 Nothing -> len /= hopPayloadsSize) 1394 && 1395 (case ps of 1396 Just _ -> len == 32 1397 Nothing -> len /= 32) 1398 1399 propFailureMessageRoundtrip :: Property 1400 propFailureMessageRoundtrip = 1401 forAll genFailureMessage $ \fm -> 1402 let encoded = encodeFailureMessage fm 1403 in decodeFailureMessage encoded == Just fm 1404 1405 genFailureMessage :: Gen FailureMessage 1406 genFailureMessage = do 1407 code <- elements 1408 [ InvalidRealm 1409 , TemporaryNodeFailure 1410 , PermanentNodeFailure 1411 , InvalidOnionHmac 1412 , TemporaryChannelFailure 1413 , IncorrectOrUnknownPaymentDetails 1414 , AmountBelowMinimum 1415 , FeeInsufficient 1416 , ExpiryTooSoon 1417 , MppTimeout 1418 ] 1419 dlen <- choose (0, 100 :: Int) 1420 dat <- BS.pack <$> vectorOf dlen arbitrary 1421 pure (FailureMessage code dat [])