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