commit 5e84a235ed9ceb051653fba1fd2d09661a70839d
parent bba3bab650ff572546b91c3d3330203a259331a5
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 14:54:04 +0400
test: rewrite the suite against the public API
Assert onion-test.json, onion-error-test.json, the Returning Errors
trace, route-blinding-test.json and blinded-payment-onion-test.json
through the public API only. Bob's and Eve's encrypted_data, which carry
unknown odd TLVs, are now reproduced exactly, and the blinded payment is
processed end to end with each hop's path_key.
Add negative tests for each rejection rule (key validation, packet and
payload decoding, the path key rules of process, failure message
decoding, construction limits) and round-trip properties for the
codecs, error wrapping and multi-hop routes.
Diffstat:
| M | test/Main.hs | | | 3554 | ++++++++++++++++++++++++++++++------------------------------------------------- |
1 file changed, 1363 insertions(+), 2191 deletions(-)
diff --git a/test/Main.hs b/test/Main.hs
@@ -2,1706 +2,867 @@
module Main where
-import Control.Monad (foldM)
+import Control.Monad (forM_)
+import qualified Crypto.Cipher.ChaCha20 as ChaCha
+import qualified Crypto.Curve.Secp256k1 as Secp256k1
+import qualified Crypto.Hash.SHA256 as SHA256
import Data.Bits (xor)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
-import qualified Crypto.Curve.Secp256k1 as Secp256k1
-import qualified Crypto.Hash.SHA256 as SHA256
-import Data.List (nub, sort)
-import Data.Maybe (isJust)
-import Data.Word (Word8, Word16, Word32)
-import Lightning.Protocol.BOLT4.Blinding
-import Lightning.Protocol.BOLT4.Codec
-import Lightning.Protocol.BOLT4.Construct
-import Lightning.Protocol.BOLT4.Error
-import Lightning.Protocol.BOLT4.Internal
-import Lightning.Protocol.BOLT4.Prim
-import Lightning.Protocol.BOLT4.Process
-import Lightning.Protocol.BOLT4.Types
+import Data.List (nubBy)
+import Data.Word (Word8, Word16, Word32, Word64)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT4
+import qualified Lightning.Protocol.BOLT9 as BOLT9
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import qualified Vectors as V
--- | Demand a Just value in IO, failing the test on Nothing.
-demand :: String -> Maybe a -> IO a
-demand _ (Just a) = pure a
-demand msg Nothing = assertFailure msg
-
--- | Decode hex, failing the test on invalid input.
-unhex :: BS.ByteString -> IO BS.ByteString
-unhex = demand "invalid hex" . B16.decode
-
--- | Decode a hex-encoded public key, failing the test if invalid.
-unhexPoint :: BS.ByteString -> IO Secp256k1.Projective
-unhexPoint h = unhex h >>= demand "invalid point" . Secp256k1.parse_point
-
--- | Strip a BigSize length prefix, checking that it is exact.
-unprefix :: BS.ByteString -> IO BS.ByteString
-unprefix bs = do
- (len, body) <- demand "invalid length prefix" (decodeBigSize bs)
- assertEqual "length prefix" (fromIntegral len) (BS.length body)
- pure body
-
--- | Construct a ShortChannelId, failing if invalid.
-assertScid :: Word32 -> Word32 -> Word16
- -> IO ShortChannelId
-assertScid b t o = demand "shortChannelId" (shortChannelId b t o)
-
--- | Construct a ShortChannelId for test fixtures.
-mkScid :: Word32 -> Word32 -> Word16 -> ShortChannelId
-mkScid b t o = case shortChannelId b t o of
- Just s -> s
- Nothing -> error "mkScid: invalid test fixture"
-
main :: IO ()
main = defaultMain $ testGroup "ppad-bolt4" [
- testGroup "Prim" [
- primTests
- ]
- , testGroup "BigSize" [
- bigsizeTests
- , bigsizeRoundtripProp
- ]
- , testGroup "TLV" [
- tlvTests
- , tlvRejectionTests
- ]
- , testGroup "ShortChannelId" [
- sciTests
- ]
- , testGroup "OnionPacket" [
- onionPacketTests
- ]
- , testGroup "Construct" [
- constructTests
- ]
- , testGroup "Process" [
- processTests
- ]
- , testGroup "Error" [
- errorTests
- ]
- , testGroup "properties" [
- propertyTests
- ]
- , testGroup "Blinding" [
- blindingKeyDerivationTests
- , blindingEphemeralKeyTests
- , blindingTlvTests
- , blindingEncryptionTests
- , blindingCreatePathTests
- , blindingProcessHopTests
- ]
+ key_tests
+ , codec_tests
+ , failure_tests
+ , construct_tests
+ , process_tests
+ , blinding_tests
+ , error_tests
, testGroup "spec vectors" [
- onionVectorTests
- , errorVectorTests
- , traceVectorTests
- , routeBlindingTests
- , blindedPaymentTests
+ onion_vectors
+ , error_vectors
+ , trace_vectors
+ , route_blinding_vectors
+ , blinded_payment_vectors
]
- , testGroup "multi-hop" [
- multiHopTests
- ]
- ]
-
--- BigSize tests ------------------------------------------------------------
-
-bigsizeTests :: TestTree
-bigsizeTests = testGroup "boundary values" [
- testCase "0" $
- encodeBigSize 0 @?= BS.pack [0x00]
- , testCase "0xFC" $
- encodeBigSize 0xFC @?= BS.pack [0xFC]
- , testCase "0xFD" $
- encodeBigSize 0xFD @?= BS.pack [0xFD, 0x00, 0xFD]
- , testCase "0xFFFF" $
- encodeBigSize 0xFFFF @?= BS.pack [0xFD, 0xFF, 0xFF]
- , testCase "0x10000" $
- encodeBigSize 0x10000 @?=
- BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00]
- , testCase "0xFFFFFFFF" $
- encodeBigSize 0xFFFFFFFF @?=
- BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF]
- , testCase "0x100000000" $
- encodeBigSize 0x100000000 @?=
- BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01,
- 0x00, 0x00, 0x00, 0x00]
- , testCase "decode 0" $ do
- let result = decodeBigSize (BS.pack [0x00])
- result @?= Just (0, BS.empty)
- , testCase "decode 0xFC" $ do
- let result = decodeBigSize (BS.pack [0xFC])
- result @?= Just (0xFC, BS.empty)
- , testCase "decode 0xFD" $ do
- let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFD])
- result @?= Just (0xFD, BS.empty)
- , testCase "decode 0xFFFF" $ do
- let result = decodeBigSize (BS.pack [0xFD, 0xFF, 0xFF])
- result @?= Just (0xFFFF, BS.empty)
- , testCase "decode 0x10000" $ do
- let result = decodeBigSize $
- BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00]
- result @?= Just (0x10000, BS.empty)
- , testCase "decode 0xFFFFFFFF" $ do
- let result = decodeBigSize $
- BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF]
- result @?= Just (0xFFFFFFFF, BS.empty)
- , testCase "decode 0x100000000" $ do
- let result = decodeBigSize $
- BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01,
- 0x00, 0x00, 0x00, 0x00]
- result @?= Just (0x100000000, BS.empty)
- , testCase "reject non-canonical 0xFD encoding" $ do
- let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFC])
- result @?= Nothing
- , testCase "reject non-canonical 0xFE encoding" $ do
- let result = decodeBigSize $
- BS.pack [0xFE, 0x00, 0x00, 0xFF, 0xFF]
- result @?= Nothing
- , testCase "bigSizeLen" $ do
- bigSizeLen 0 @?= 1
- bigSizeLen 0xFC @?= 1
- bigSizeLen 0xFD @?= 3
- bigSizeLen 0xFFFF @?= 3
- bigSizeLen 0x10000 @?= 5
- bigSizeLen 0xFFFFFFFF @?= 5
- bigSizeLen 0x100000000 @?= 9
- ]
-
-bigsizeRoundtripProp :: TestTree
-bigsizeRoundtripProp = testProperty "roundtrip" $ \n ->
- let encoded = encodeBigSize n
- decoded = decodeBigSize encoded
- in decoded == Just (n, BS.empty)
-
--- TLV tests ----------------------------------------------------------------
-
-tlvTests :: TestTree
-tlvTests = testGroup "encoding/decoding" [
- testCase "single record" $ do
- let rec = TlvRecord 2 (BS.pack [0x01, 0x02, 0x03])
- encoded = encodeTlv rec
- decoded = decodeTlv encoded
- decoded @?= Just (rec, BS.empty)
- , testCase "stream roundtrip" $ do
- let recs = [ TlvRecord 2 (BS.pack [0x01])
- , TlvRecord 4 (BS.pack [0x02, 0x03])
- , TlvRecord 100 (BS.pack [0x04, 0x05, 0x06])
- ]
- encoded = encodeTlvStream recs
- decoded = decodeTlvStream encoded
- decoded @?= Just recs
- , testCase "reject out-of-order types" $ do
- let rec1 = encodeTlv (TlvRecord 4 (BS.pack [0x01]))
- rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02]))
- badStream = rec1 <> rec2
- decoded = decodeTlvStream badStream
- decoded @?= Nothing
- , testCase "reject duplicate types" $ do
- let rec1 = encodeTlv (TlvRecord 2 (BS.pack [0x01]))
- rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02]))
- badStream = rec1 <> rec2
- decoded = decodeTlvStream badStream
- decoded @?= Nothing
- , testCase "empty stream" $ do
- let decoded = decodeTlvStream BS.empty
- decoded @?= Just []
- ]
-
-tlvRejectionTests :: TestTree
-tlvRejectionTests = testGroup "rejection" [
- testCase "length of 2^64 - 1" $ do
- let huge = BS.pack (0xff : replicate 8 0xff)
- decodeTlv (BS.singleton 0x01 <> huge <> BS.pack [0xaa, 0xbb])
- @?= Nothing
- decodeTlvStream (BS.singleton 0x01 <> huge <> BS.pack [0x03, 0x00])
- @?= Nothing
- decodeHopPayload
- (BS.singleton 0x02 <> huge <> BS.pack [0x04, 0x01, 0x07])
- @?= Nothing
- , testCase "hop payload: unknown even type" $
- decodeHopPayload (BS.pack [0x02, 0x01, 0x05, 0x0e, 0x01, 0x07])
- @?= Nothing
- , testCase "hop payload: unknown odd type is kept" $
- fmap hpUnknownTlvs
- (decodeHopPayload (BS.pack [0x02, 0x01, 0x05, 0x0f, 0x01, 0x07]))
- @?= Just [TlvRecord 15 (BS.singleton 0x07)]
- , testCase "hop payload: types 16 and 18 are accepted" $
- fmap hpUnknownTlvs
- (decodeHopPayload (BS.pack [0x10, 0x01, 0x01, 0x12, 0x01, 0x02]))
- @?= Just [ TlvRecord 16 (BS.singleton 0x01)
- , TlvRecord 18 (BS.singleton 0x02) ]
- , testCase "blinded hop data: unknown even type" $
- decodeBlindedHopData (BS.pack [0x10, 0x01, 0x00]) @?= Nothing
- , testCase "blinded hop data: unknown odd type is skipped" $
- decodeBlindedHopData (BS.pack [0x06, 0x01, 0x2a, 0xfd, 0x02, 0x31,
- 0x01, 0x00])
- @?= Just emptyHopData { bhdPathId = Just (BS.singleton 0x2a) }
- ]
-
--- ShortChannelId tests -----------------------------------------------------
-
-sciTests :: TestTree
-sciTests = testGroup "encoding/decoding" [
- testCase "known value" $ do
- sci <- assertScid 700000 1234 5
- let encoded = encodeShortChannelId sci
- BS.length encoded @?= 8
- let decoded = decodeShortChannelId encoded
- decoded @?= Just sci
- , testCase "maximum values" $ do
- sci <- assertScid 0xFFFFFF 0xFFFFFF 0xFFFF
- let encoded = encodeShortChannelId sci
- BS.length encoded @?= 8
- let decoded = decodeShortChannelId encoded
- decoded @?= Just sci
- , testCase "zero values" $ do
- sci <- assertScid 0 0 0
- let encoded = encodeShortChannelId sci
- expected = BS.pack [0, 0, 0, 0, 0, 0, 0, 0]
- encoded @?= expected
- let decoded = decodeShortChannelId encoded
- decoded @?= Just sci
- , testCase "reject wrong length" $ do
- let decoded =
- decodeShortChannelId (BS.pack [0, 1, 2, 3, 4, 5, 6])
- decoded @?= Nothing
- ]
-
--- OnionPacket tests --------------------------------------------------------
-
-onionPacketTests :: TestTree
-onionPacketTests = testGroup "encoding/decoding" [
- testCase "roundtrip" $ do
- let packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = BS.replicate 33 0xAB
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0xCD)
- , opHmac = unsafeHmac32 (BS.replicate 32 0xEF)
- }
- encoded = encodeOnionPacket packet
- BS.length encoded @?= onionPacketSize
- let decoded = decodeOnionPacket encoded
- decoded @?= Just packet
- , testCase "reject wrong size" $ do
- let decoded =
- decodeOnionPacket (BS.replicate 1000 0x00)
- decoded @?= Nothing
+ , properties
]
--- Prim tests ---------------------------------------------------------------
+-- helpers --------------------------------------------------------------------
-sessionKey :: BS.ByteString
-sessionKey = BS.replicate 32 0x41
-
-hop0PubKeyHex :: BS.ByteString
-hop0PubKeyHex =
- "02eec7245d6b7d2ccb30380bfbe2a3648cd7a942653f5aa340edcea1f283686619"
-
-hop0SharedSecretHex :: BS.ByteString
-hop0SharedSecretHex =
- "53eb63ea8a3fec3b3cd433b85cd62a4b145e1dda09391b348c4e1cd36a03ea66"
-
-hop0BlindingFactorHex :: BS.ByteString
-hop0BlindingFactorHex =
- "2ec2e5da605776054187180343287683aa6a51b4b1c04d6dd49c45d8cffb3c36"
-
-fromHex :: BS.ByteString -> BS.ByteString
-fromHex h = case B16.decode h of
- Just bs -> bs
- Nothing -> error "fromHex: invalid hex"
-
-primTests :: TestTree
-primTests = testGroup "cryptographic primitives" [
- testSharedSecret
- , testBlindingFactor
- , testKeyDerivation
- , testBlindPubKey
- , testGenerateStream
- , testHmacOperations
- ]
-
-testSharedSecret :: TestTree
-testSharedSecret =
- testCase "computeSharedSecret (BOLT4 spec hop 0)" $ do
- pubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- case computeSharedSecret sessionKey pubKey of
- Nothing ->
- assertFailure "computeSharedSecret returned Nothing"
- Just (SharedSecret computed) -> do
- let expected = fromHex hop0SharedSecretHex
- computed @?= expected
-
-testBlindingFactor :: TestTree
-testBlindingFactor =
- testCase "computeBlindingFactor (BOLT4 spec hop 0)" $ do
- sk <- demand "roll32" $ Secp256k1.roll32 sessionKey
- ephemPubKey <- demand "derive_pub" $
- Secp256k1.derive_pub sk
- nodePubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- case computeSharedSecret sessionKey nodePubKey of
- Nothing ->
- assertFailure "computeSharedSecret returned Nothing"
- Just sharedSecret -> do
- let BlindingFactor computed =
- computeBlindingFactor ephemPubKey sharedSecret
- expected = fromHex hop0BlindingFactorHex
- computed @?= expected
-
-testKeyDerivation :: TestTree
-testKeyDerivation = testGroup "key derivation" [
- testCase "deriveRho produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey rho = deriveRho ss
- BS.length rho @?= 32
- , testCase "deriveMu produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey mu = deriveMu ss
- BS.length mu @?= 32
- , testCase "deriveUm produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey um = deriveUm ss
- BS.length um @?= 32
- , testCase "derivePad produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey pad = derivePad ss
- BS.length pad @?= 32
- , testCase "deriveAmmag produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey ammag = deriveAmmag ss
- BS.length ammag @?= 32
- , testCase "different key types produce different results" $ do
- let ss = SharedSecret (BS.replicate 32 0x42)
- DerivedKey rho = deriveRho ss
- DerivedKey mu = deriveMu ss
- DerivedKey um = deriveUm ss
- assertBool "rho /= mu" (rho /= mu)
- assertBool "mu /= um" (mu /= um)
- assertBool "rho /= um" (rho /= um)
- ]
-
-testBlindPubKey :: TestTree
-testBlindPubKey = testGroup "key blinding" [
- testCase "blindPubKey produces valid key" $ do
- sk <- demand "roll32" $ Secp256k1.roll32 sessionKey
- pubKey <- demand "derive_pub" $ Secp256k1.derive_pub sk
- let bf = BlindingFactor (fromHex hop0BlindingFactorHex)
- case blindPubKey pubKey bf of
- Nothing ->
- assertFailure "blindPubKey returned Nothing"
- Just _blinded -> return ()
- , testCase "blindSecKey produces valid key" $ do
- let bf = BlindingFactor (fromHex hop0BlindingFactorHex)
- case blindSecKey sessionKey bf of
- Nothing ->
- assertFailure "blindSecKey returned Nothing"
- Just _blinded -> return ()
- ]
-
-testGenerateStream :: TestTree
-testGenerateStream = testGroup "generateStream" [
- testCase "produces correct length" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- fmap BS.length (generateStream dk 100) @?= Just 100
- , testCase "1300-byte stream for hop_payloads" $ do
- let dk = DerivedKey (BS.replicate 32 0x42)
- fmap BS.length (generateStream dk 1300) @?= Just 1300
- , testCase "deterministic output" $ do
- let dk = DerivedKey (BS.replicate 32 0x55)
- stream1 = generateStream dk 64
- stream2 = generateStream dk 64
- stream1 @?= stream2
- , testCase "fails on a key that is not 32 bytes" $
- generateStream (DerivedKey "short") 16 @?= Nothing
- ]
-
-testHmacOperations :: TestTree
-testHmacOperations = testGroup "HMAC operations" [
- testCase "computeHmac produces 32 bytes" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- hm = computeHmac dk "payloads" "assocdata"
- BS.length hm @?= 32
- , testCase "verifyHmac succeeds for matching" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- hm = computeHmac dk "payloads" "assocdata"
- assertBool "verifyHmac should succeed"
- (verifyHmac hm hm)
- , testCase "verifyHmac fails for different" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- hm1 = computeHmac dk "payloads1" "assocdata"
- hm2 = computeHmac dk "payloads2" "assocdata"
- assertBool "verifyHmac should fail"
- (not $ verifyHmac hm1 hm2)
- , testCase "verifyHmac fails for different lengths" $ do
- assertBool "verifyHmac should fail"
- (not $ verifyHmac "short" "different length")
- ]
-
--- Construct tests ----------------------------------------------------------
-
--- Test vectors from BOLT4 spec
-hop1PubKeyHex :: BS.ByteString
-hop1PubKeyHex =
- "0324653eac434488002cc06bbfb7f10fe18991e35f9fe4302dbea6d2353dc0ab1c"
-
-hop2PubKeyHex :: BS.ByteString
-hop2PubKeyHex =
- "027f31ebc5462c1fdce1b737ecff52d37d75dea43ce11c74d25aa297165faa2007"
-
-hop3PubKeyHex :: BS.ByteString
-hop3PubKeyHex =
- "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"
-
-hop4PubKeyHex :: BS.ByteString
-hop4PubKeyHex =
- "02edabbd16b41c8371b92ef2f04c1185b4f03b6dcd52ba9b78d9d7c89c8f221145"
-
--- Expected shared secrets from BOLT4 error test vectors
-hop1SharedSecretHex :: BS.ByteString
-hop1SharedSecretHex =
- "a6519e98832a0b179f62123b3567c106db99ee37bef036e783263602f3488fae"
-
-hop2SharedSecretHex :: BS.ByteString
-hop2SharedSecretHex =
- "3a6b412548762f0dbccce5c7ae7bb8147d1caf9b5471c34120b30bc9c04891cc"
-
-hop3SharedSecretHex :: BS.ByteString
-hop3SharedSecretHex =
- "21e13c2d7cfe7e18836df50872466117a295783ab8aab0e7ecc8c725503ad02d"
+demand :: String -> Maybe a -> IO a
+demand _ (Just a) = pure a
+demand msg Nothing = assertFailure msg
-hop4SharedSecretHex :: BS.ByteString
-hop4SharedSecretHex =
- "b5756b9b542727dbafc6765a49488b023a725d631af688fc031217e90770c328"
+right :: Show e => String -> Either e a -> IO a
+right _ (Right a) = pure a
+right msg (Left e) = assertFailure (msg ++ ": " ++ show e)
-constructTests :: TestTree
-constructTests = testGroup "packet construction" [
- testConstructErrorCases
- , testSharedSecretComputation
- , testPacketStructure
- , testSingleHop
- ]
+unhex :: BS.ByteString -> IO BS.ByteString
+unhex = demand "invalid hex" . B16.decode
-testConstructErrorCases :: TestTree
-testConstructErrorCases = testGroup "error cases" [
- testCase "rejects invalid session key (too short)" $ do
- let result = construct (BS.replicate 31 0x41) [] ""
- case result of
- Left InvalidSessionKey -> return ()
- _ -> assertFailure "Expected InvalidSessionKey"
- , testCase "rejects invalid session key (too long)" $ do
- let result = construct (BS.replicate 33 0x41) [] ""
- case result of
- Left InvalidSessionKey -> return ()
- _ -> assertFailure "Expected InvalidSessionKey"
- , testCase "rejects empty route" $ do
- let result = construct sessionKey [] ""
- case result of
- Left EmptyRoute -> return ()
- _ -> assertFailure "Expected EmptyRoute"
- , testCase "rejects too many hops" $ do
- pub <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let emptyPayload = HopPayload Nothing Nothing Nothing
- Nothing Nothing Nothing []
- hop = Hop pub emptyPayload
- hops = replicate 21 hop
- result = construct sessionKey hops ""
- case result of
- Left TooManyHops -> return ()
- _ -> assertFailure "Expected TooManyHops"
- , testCase "rejects an empty hop payload" $ do
- pub <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let emptyPayload = HopPayload Nothing Nothing Nothing
- Nothing Nothing Nothing []
- hops = [Hop pub minimalPayload, Hop pub emptyPayload]
- construct sessionKey hops "" @?= Left (InvalidHopPayload 1)
- ]
+hex_key :: BS.ByteString -> IO SecretKey
+hex_key h = unhex h >>= demand "invalid secret key" . secret_key
--- | A small, valid hop payload.
-minimalPayload :: HopPayload
-minimalPayload =
- HopPayload (Just 1000) (Just 500000) Nothing Nothing Nothing Nothing []
-
-testSharedSecretComputation :: TestTree
-testSharedSecretComputation =
- testCase "computes correct shared secrets (BOLT4 spec)" $ do
- pub0 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- pub1 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop1PubKeyHex)
- pub2 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop2PubKeyHex)
- pub3 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop3PubKeyHex)
- pub4 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop4PubKeyHex)
- let hops = [ Hop pub0 minimalPayload
- , Hop pub1 minimalPayload
- , Hop pub2 minimalPayload
- , Hop pub3 minimalPayload
- , Hop pub4 minimalPayload
- ]
- result = construct sessionKey hops ""
- case result of
- Left err ->
- assertFailure $ "construct failed: " ++ show err
- Right (_, secrets) -> case secrets of
- [SharedSecret ss0, SharedSecret ss1,
- SharedSecret ss2, SharedSecret ss3,
- SharedSecret ss4] -> do
- ss0 @?= fromHex hop0SharedSecretHex
- ss1 @?= fromHex hop1SharedSecretHex
- ss2 @?= fromHex hop2SharedSecretHex
- ss3 @?= fromHex hop3SharedSecretHex
- ss4 @?= fromHex hop4SharedSecretHex
- _ -> assertFailure "expected 5 shared secrets"
-
-testPacketStructure :: TestTree
-testPacketStructure =
- testCase "produces valid packet structure" $ do
- pub0 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- pub1 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop1PubKeyHex)
- let hops = [Hop pub0 minimalPayload,
- Hop pub1 minimalPayload]
- result = construct sessionKey hops ""
- case result of
- Left err ->
- assertFailure $ "construct failed: " ++ show err
- Right (packet, _) -> do
- opVersion packet @?= versionByte
- BS.length (opEphemeralKey packet) @?= pubkeySize
- BS.length (unHopPayloads (opHopPayloads packet))
- @?= hopPayloadsSize
- BS.length (unHmac32 (opHmac packet)) @?= hmacSize
- sk <- demand "roll32" $ Secp256k1.roll32 sessionKey
- expectedPub <- demand "derive_pub" $
- Secp256k1.derive_pub sk
- let expectedPubBytes =
- Secp256k1.serialize_point expectedPub
- opEphemeralKey packet @?= expectedPubBytes
-
-testSingleHop :: TestTree
-testSingleHop =
- testCase "constructs single-hop packet" $ do
- pub0 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let payload = HopPayload
- { hpAmtToForward = Just 1000
- , hpOutgoingCltv = Just 500000
- , hpShortChannelId = Nothing
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
- }
- hops = [Hop pub0 payload]
- result = construct sessionKey hops ""
- case result of
- Left err ->
- assertFailure $ "construct failed: " ++ show err
- Right (packet, secrets) -> do
- length secrets @?= 1
- -- Packet should be valid structure
- let encoded = encodeOnionPacket packet
- BS.length encoded @?= onionPacketSize
- -- Should decode back
- decoded <- demand "decodeOnionPacket" $
- decodeOnionPacket encoded
- decoded @?= packet
-
--- Process tests -----------------------------------------------------------
-
-processTests :: TestTree
-processTests = testGroup "packet processing" [
- testVersionValidation
- , testEphemeralKeyValidation
- , testHmacValidation
- , testProcessBasic
- , testPayloadLength
- ]
+hex_point :: BS.ByteString -> IO BOLT1.Point
+hex_point h = unhex h >>= demand "invalid point" . BOLT1.point
-testVersionValidation :: TestTree
-testVersionValidation = testGroup "version validation" [
- testCase "reject invalid version 0x01" $ do
- let packet = OnionPacket
- { opVersion = 0x01
- , opEphemeralKey = BS.replicate 33 0x02
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left (InvalidVersion v) -> v @?= 0x01
- Left other ->
- assertFailure $ "expected InvalidVersion, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- , testCase "reject invalid version 0xFF" $ do
- let packet = OnionPacket
- { opVersion = 0xFF
- , opEphemeralKey = BS.replicate 33 0x02
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left (InvalidVersion v) -> v @?= 0xFF
- Left other ->
- assertFailure $ "expected InvalidVersion, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- ]
+hex_secret :: BS.ByteString -> IO SharedSecret
+hex_secret h = unhex h >>= demand "invalid shared secret" . shared_secret
-testEphemeralKeyValidation :: TestTree
-testEphemeralKeyValidation =
- testGroup "ephemeral key validation" [
- testCase "reject invalid ephemeral key (all zeros)" $ do
- let packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = BS.replicate 33 0x00
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left InvalidEphemeralKey -> return ()
- Left other ->
- assertFailure $
- "expected InvalidEphemeralKey, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- , testCase "reject malformed ephemeral key" $ do
- let packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey =
- BS.pack (0x04 : replicate 32 0xAB)
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left InvalidEphemeralKey -> return ()
- Left other ->
- assertFailure $
- "expected InvalidEphemeralKey, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- ]
+-- strip a BigSize length prefix, checking that it is exact
+unprefix :: BS.ByteString -> IO BS.ByteString
+unprefix bs = do
+ (len, body) <- demand "invalid length prefix" (BOLT1.decode_bigsize bs)
+ assertEqual "length prefix" (fromIntegral len) (BS.length body)
+ pure body
-testHmacValidation :: TestTree
-testHmacValidation = testGroup "HMAC validation" [
- testCase "reject invalid HMAC" $ do
- hop0PubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let ephKeyBytes =
- Secp256k1.serialize_point hop0PubKey
- packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = ephKeyBytes
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0xFF)
- }
- case process sessionKey packet BS.empty of
- Left HmacMismatch -> return ()
- Left other ->
- assertFailure $ "expected HmacMismatch, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
+msat :: Word64 -> IO BOLT1.MilliSatoshi
+msat = demand "invalid amount" . BOLT1.milli_satoshi
+
+scid :: Word32 -> Word32 -> Word16 -> IO BOLT1.ShortChannelId
+scid b t o = demand "invalid scid" (BOLT1.short_channel_id b t o)
+
+tlvs :: [BOLT1.TlvRecord] -> IO BOLT1.TlvStream
+tlvs = demand "invalid tlv stream" . BOLT1.tlv_stream
+
+no_tlvs :: BOLT1.TlvStream
+no_tlvs = BOLT1.empty_tlv_stream
+
+key :: Word8 -> IO SecretKey
+key b = demand "invalid secret key" (secret_key (BS.replicate 32 b))
+
+ad :: BS.ByteString
+ad = BS.replicate 32 0x42
+
+-- a point with a valid prefix but not on the curve
+off_curve :: IO BOLT1.Point
+off_curve =
+ case [ p | x <- [0 .. 255 :: Word8]
+ , let bs = BS.cons 0x02 (BS.replicate 31 0 <> BS.singleton x)
+ , Secp256k1.parse_point bs == Nothing
+ , Just p <- [BOLT1.point bs] ] of
+ p : _ -> pure p
+ [] -> assertFailure "no off-curve point found"
+
+-- a payload with the given outgoing_cltv_value
+cltv_payload :: Word32 -> HopPayload
+cltv_payload c = empty_hop_payload { hp_outgoing_cltv_value = Just c }
+
+expect_process
+ :: ProcessError -> Either ProcessError ProcessResult -> Assertion
+expect_process e r = case r of
+ Left e' -> e' @?= e
+ Right _ -> assertFailure ("expected " ++ show e)
+
+forward :: Either ProcessError ProcessResult -> IO ForwardInfo
+forward r = case r of
+ Right (Forward f) -> pure f
+ Right (Receive _) -> assertFailure "expected Forward, got Receive"
+ Left e -> assertFailure ("process: " ++ show e)
+
+receive :: Either ProcessError ProcessResult -> IO ReceiveInfo
+receive r = case r of
+ Right (Receive i) -> pure i
+ Right (Forward _) -> assertFailure "expected Receive, got Forward"
+ Left e -> assertFailure ("process: " ++ show e)
+
+-- A single-hop onion, built independently of the library, whose
+-- decrypted hop_payloads is the given 1300-byte plaintext.
+raw_onion :: SecretKey -> BS.ByteString -> IO OnionPacket
+raw_onion node plain = do
+ let session = BS.replicate 32 0x77
+ e <- demand "session" (Secp256k1.parse_int256 session)
+ epub <- demand "session pub" (Secp256k1.derive_pub e)
+ n <- demand "node pub"
+ (Secp256k1.parse_point (BOLT1.un_point (public_key node)))
+ pt <- demand "ecdh" (Secp256k1.mul n e)
+ let ss = SHA256.hash (Secp256k1.serialize_point pt)
+ derive l = let SHA256.MAC k = SHA256.hmac l ss in k
+ stream <- right "chacha"
+ (ChaCha.cipher (derive "rho") 0 (BS.replicate 12 0)
+ (BS.replicate 1300 0))
+ let body = BS.packZipWith xor plain stream
+ SHA256.MAC mac = SHA256.hmac (derive "mu") (body <> ad)
+ pk <- demand "point" (BOLT1.point (Secp256k1.serialize_point epub))
+ OnionPacket 0 pk
+ <$> demand "hop_payloads" (hop_payloads body)
+ <*> demand "hmac" (hmac32 mac)
+
+-- pad a plaintext region to 1300 bytes
+pad1300 :: BS.ByteString -> BS.ByteString
+pad1300 bs = bs <> BS.replicate (1300 - BS.length bs) 0
+
+-- keys -----------------------------------------------------------------------
+
+key_tests :: TestTree
+key_tests = testGroup "keys" [
+ testCase "secret_key accepts 32-byte keys in range" $ do
+ _ <- key 0x01
+ sk <- demand "n - 1" . secret_key =<< unhex
+ "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140"
+ BS.length (BOLT1.un_point (public_key sk)) @?= 33
+ , testCase "secret_key rejects other lengths" $ do
+ assertNone (secret_key (BS.replicate 31 0x01))
+ assertNone (secret_key (BS.replicate 33 0x01))
+ assertNone (secret_key (BS.cons 0x00 (BS.replicate 32 0x01)))
+ assertNone (secret_key BS.empty)
+ , testCase "secret_key rejects zero and keys >= n" $ do
+ assertNone (secret_key (BS.replicate 32 0x00))
+ n <- unhex
+ "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141"
+ assertNone (secret_key n)
+ assertNone (secret_key (BS.replicate 32 0xff))
+ , testCase "public_key matches secp256k1" $ do
+ sk <- key 0x41
+ expected <- unhex V.onionPubKey0
+ BOLT1.un_point (public_key sk) @?= expected
+ , testCase "shared_secret requires 32 bytes" $ do
+ assertNone (shared_secret (BS.replicate 31 0))
+ assertNone (shared_secret (BS.replicate 33 0))
+ ss <- demand "ss" (shared_secret (BS.replicate 32 7))
+ un_shared_secret ss @?= BS.replicate 32 7
+ , testCase "shared secrets compare by value" $ do
+ a <- demand "a" (shared_secret (BS.replicate 32 7))
+ b <- demand "b" (shared_secret (BS.replicate 32 7))
+ c <- demand "c" (shared_secret (BS.cons 8 (BS.replicate 31 7)))
+ assertBool "equal" (a == b)
+ assertBool "not equal" (a /= c)
+ , testCase "secrets don't show their bytes" $ do
+ sk <- key 0x41
+ ss <- demand "ss" (shared_secret (BS.replicate 32 0x41))
+ ps <- demand "ps" (payment_secret (BS.replicate 32 0x41))
+ show sk @?= "SecretKey <redacted>"
+ show ss @?= "SharedSecret <redacted>"
+ show ps @?= "PaymentSecret <redacted>"
]
-
--- | Test basic packet processing with a properly constructed
--- packet.
-testProcessBasic :: TestTree
-testProcessBasic = testGroup "basic processing" [
- testCase "process valid packet (final hop)" $ do
- hop0PubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let ephKeyBytes =
- Secp256k1.serialize_point hop0PubKey
- hopPayloadTlv = encodeHopPayload HopPayload
- { hpAmtToForward = Just 1000
- , hpOutgoingCltv = Just 500000
- , hpShortChannelId = Nothing
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
+ where
+ assertNone m = case m of
+ Nothing -> pure ()
+ Just _ -> assertFailure "expected Nothing"
+
+-- codecs ---------------------------------------------------------------------
+
+codec_tests :: TestTree
+codec_tests = testGroup "codecs" [
+ testCase "decode_onion_packet rejects other lengths" $ do
+ decode_onion_packet (BS.replicate 1365 0) @?= Left InvalidLength
+ decode_onion_packet (BS.replicate 1367 0) @?= Left InvalidLength
+ decode_onion_packet BS.empty @?= Left InvalidLength
+ , testCase "decode_onion_packet rejects a bad point prefix" $ do
+ let bs = BS.concat [ BS.singleton 0, BS.singleton 0x04
+ , BS.replicate 1364 0 ]
+ decode_onion_packet bs @?= Left InvalidPoint
+ , testCase "decode_onion_packet keeps the version byte" $ do
+ let bs = BS.concat [ BS.singleton 7, BS.singleton 0x02
+ , BS.replicate 1364 0 ]
+ pkt <- right "decode" (decode_onion_packet bs)
+ onion_version pkt @?= 7
+ encode_onion_packet pkt @?= bs
+ , testCase "smart constructors check lengths" $ do
+ hop_payloads (BS.replicate 1299 0) @?= Nothing
+ hop_payloads (BS.replicate 1301 0) @?= Nothing
+ hmac32 (BS.replicate 31 0) @?= Nothing
+ onion_hash (BS.replicate 33 0) @?= Nothing
+ case payment_secret (BS.replicate 31 0) of
+ Nothing -> pure ()
+ Just _ -> assertFailure "short payment secret"
+
+ , testCase "hop payload: all typed fields" $ do
+ amt <- msat 1000
+ tot <- msat 5000
+ s <- scid 1 2 3
+ ps <- demand "ps" (payment_secret (BS.replicate 32 0xaa))
+ pk <- hex_point V.onionPubKey0
+ ex <- tlvs [BOLT1.TlvRecord 19 "x"]
+ let hp = HopPayload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 500000
+ , hp_short_channel_id = Just s
+ , hp_payment_data = Just (PaymentData ps tot)
+ , hp_encrypted_data = Just "enc"
+ , hp_current_path_key = Just pk
+ , hp_payment_metadata = Just "meta"
+ , hp_total_amount_msat = Just tot
+ , hp_extra = ex
}
- payloadLen = BS.length hopPayloadTlv
- lenPrefix =
- encodeBigSize (fromIntegral payloadLen)
- payloadWithHmac = lenPrefix <> hopPayloadTlv
- <> BS.replicate 32 0x00
- padding = BS.replicate
- (1300 - BS.length payloadWithHmac) 0x00
- rawPayloads = payloadWithHmac <> padding
- ss <- demand "computeSharedSecret" $
- computeSharedSecret sessionKey hop0PubKey
- stream <- demand "generateStream" $
- generateStream (deriveRho ss) 1300
- let muKey = deriveMu ss
- encryptedPayloads =
- BS.pack (BS.zipWith xor rawPayloads stream)
- correctHmac =
- computeHmac muKey encryptedPayloads BS.empty
- packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = ephKeyBytes
- , opHopPayloads =
- unsafeHopPayloads encryptedPayloads
- , opHmac = unsafeHmac32 correctHmac
+ bs <- right "encode" (encode_hop_payload hp)
+ expected <- unhex $ BS.concat
+ [ "020203e8", "040307a120", "06080000010000020003"
+ , "0822", BS.concat (replicate 32 "aa"), "1388"
+ , "0a03656e63", "0c21", V.onionPubKey0, "10046d657461"
+ , "12021388", "130178" ]
+ bs @?= expected
+ decode_hop_payload bs @?= Right hp
+ , testCase "hop payload: zero values encode minimally" $ do
+ zero <- msat 0
+ let hp = empty_hop_payload { hp_amt_to_forward = Just zero
+ , hp_outgoing_cltv_value = Just 0 }
+ encode_hop_payload hp @?= Right "\STX\NUL\EOT\NUL"
+ decode_hop_payload "\STX\NUL\EOT\NUL" @?= Right hp
+ , testCase "hop payload: unknown odd types are kept" $ do
+ hp <- right "decode" (decode_hop_payload "\STX\SOH\SOH\ETX\NUL")
+ ex <- tlvs [BOLT1.TlvRecord 3 ""]
+ hp_extra hp @?= ex
+ encode_hop_payload hp @?= Right "\STX\SOH\SOH\ETX\NUL"
+ , testCase "hop payload: rejects unknown even types" $ do
+ decode_hop_payload "\DC4\NUL" @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 20))
+ decode_hop_payload "\SO\NUL" @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 14))
+ , testCase "hop payload: rejects malformed streams" $ do
+ decode_hop_payload "\EOT\SOH\SOH\STX\SOH\SOH" @?=
+ Left (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing)
+ decode_hop_payload "\STX\SOH\SOH\STX\SOH\SOH" @?=
+ Left (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing)
+ decode_hop_payload "\STX\ENQ\SOH" @?=
+ Left (InvalidTlvStream BOLT1.TlvTruncated)
+ decode_hop_payload "\STX\255\255\255\255\255\255\255\255\255" @?=
+ Left (InvalidTlvStream BOLT1.TlvTruncated)
+ decode_hop_payload "\253\NUL\STX\NUL" @?=
+ Left (InvalidTlvStream BOLT1.TlvNonMinimalBigSize)
+ , testCase "hop payload: rejects malformed values" $ do
+ -- non-minimal tu64 and tu32
+ decode_hop_payload "\STX\STX\NUL\SOH" @?= Left (InvalidTlvValue 2)
+ decode_hop_payload "\EOT\STX\NUL\SOH" @?= Left (InvalidTlvValue 4)
+ -- tu32 longer than 4 bytes
+ decode_hop_payload "\EOT\ENQ\SOH\SOH\SOH\SOH\SOH" @?=
+ Left (InvalidTlvValue 4)
+ -- amount above 21M BTC
+ decode_hop_payload "\STX\b\255\255\255\255\255\255\255\255" @?=
+ Left (InvalidTlvValue 2)
+ -- short_channel_id of 7 bytes
+ decode_hop_payload (BS.pack [6, 7] <> BS.replicate 7 0) @?=
+ Left (InvalidTlvValue 6)
+ -- payment_data with a 31-byte secret
+ decode_hop_payload (BS.pack [8, 31] <> BS.replicate 31 0) @?=
+ Left (InvalidTlvValue 8)
+ -- current_path_key of the wrong length or prefix
+ decode_hop_payload (BS.pack [12, 32] <> BS.replicate 32 2) @?=
+ Left (InvalidTlvValue 12)
+ decode_hop_payload (BS.pack [12, 33, 4] <> BS.replicate 32 2) @?=
+ Left (InvalidTlvValue 12)
+ -- total_amount_msat non-minimal
+ decode_hop_payload "\DC2\STX\NUL\SOH" @?= Left (InvalidTlvValue 18)
+ , testCase "hop payload: extra records may not have known types" $ do
+ ex <- tlvs [BOLT1.TlvRecord 16 "meta"]
+ encode_hop_payload empty_hop_payload { hp_extra = ex } @?=
+ Left ConflictingTlv
+ ex' <- tlvs [BOLT1.TlvRecord 2 "\SOH"]
+ encode_hop_payload (cltv_payload 1) { hp_extra = ex' } @?=
+ Left ConflictingTlv
+ , testCase "hop payload: extra records may have unknown even types" $ do
+ ex <- tlvs [BOLT1.TlvRecord 5482373484 (BS.replicate 32 1)]
+ bs <- right "encode" (encode_hop_payload (cltv_payload 1)
+ { hp_extra = ex })
+ decode_hop_payload bs @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 5482373484))
+
+ , testCase "blinded hop data: all typed fields" $ do
+ s <- scid 0 0 1729
+ pk <- hex_point V.rbDavePathKey
+ m <- msat 1500
+ ex <- tlvs [BOLT1.TlvRecord 561 "\DC24V"]
+ let d = BlindedHopData
+ { bhd_padding = Just (BS.replicate 3 0)
+ , bhd_short_channel_id = Just s
+ , bhd_next_node_id = Just pk
+ , bhd_path_id = Just "id"
+ , bhd_next_path_key_override = Just pk
+ , bhd_payment_relay = Just (PaymentRelay 36 150 10000)
+ , bhd_payment_constraints =
+ Just (PaymentConstraints 748005 m)
+ , bhd_allowed_features = Just (BOLT9.parse "\STX")
+ , bhd_extra = ex
}
-
- case process sessionKey packet BS.empty of
- Left err ->
- assertFailure $
- "expected success, got: " ++ show err
- Right (Receive ri) -> do
- hpAmtToForward (riPayload ri) @?= Just 1000
- hpOutgoingCltv (riPayload ri) @?= Just 500000
- Right (Forward _) ->
- assertFailure "expected Receive, got Forward"
- ]
-
--- | Encrypt 1300 bytes of plaintext hop_payloads into a packet for
--- the node with secret key 'sessionKey' (using its own public key
--- as the ephemeral key), with empty associated data.
-mkPacket :: BS.ByteString -> IO OnionPacket
-mkPacket plain = do
- pub <- demand "derive_pub"
- (Secp256k1.roll32 sessionKey >>= Secp256k1.derive_pub)
- ss <- demand "computeSharedSecret" (computeSharedSecret sessionKey pub)
- stream <- demand "generateStream" $
- generateStream (deriveRho ss) hopPayloadsSize
- let enc = BS.pack (BS.zipWith xor plain stream)
- mac = computeHmac (deriveMu ss) enc BS.empty
- hp <- demand "hopPayloads" (hopPayloads enc)
- hm <- demand "hmac32" (hmac32 mac)
- pure (OnionPacket versionByte (Secp256k1.serialize_point pub) hp hm)
-
--- | Pad (or truncate) plaintext hop_payloads to 1300 bytes.
-pad1300 :: BS.ByteString -> BS.ByteString
-pad1300 bs = BS.take hopPayloadsSize (bs <> BS.replicate hopPayloadsSize 0)
-
-assertInvalidPayload :: Either RejectReason ProcessResult -> Assertion
-assertInvalidPayload r = case r of
- Left (InvalidPayload _) -> pure ()
- Left e -> assertFailure ("expected InvalidPayload, got " ++ show e)
- Right _ -> assertFailure "expected rejection, got success"
-
-testPayloadLength :: TestTree
-testPayloadLength = testGroup "payload_length bounds" [
- testCase "rejects payload_length below 2" $ do
- pkt <- mkPacket (pad1300 (BS.pack [0x01, 0x02]))
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "rejects payload_length past hop_payloads" $ do
- -- payload_length 2000, covered by an odd TLV (type 257, length
- -- 1994) that runs into the zero-extension stream
- let prefix = BS.pack [0xfd, 0x07, 0xd0, 0xfd, 0x01, 0x01,
- 0xfd, 0x07, 0xca]
- pkt <- mkPacket (pad1300 prefix)
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "rejects payload_length of 2^64 - 1" $ do
- pkt <- mkPacket (pad1300 (BS.pack (0xff : replicate 8 0xff)))
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "rejects payload one byte too long" $ do
- -- 3-byte prefix + 1266-byte payload + 32-byte HMAC = 1301
- let tlv = BS.pack [0x01, 0xfd, 0x04, 0xee] <> BS.replicate 1262 0
- pkt <- mkPacket (pad1300 (encodeBigSize 1266 <> tlv))
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "accepts the largest payload that fits" $ do
- -- 3-byte prefix + 1265-byte payload + 32-byte HMAC = 1300
- let val = BS.replicate 1261 0
- tlv = BS.pack [0x01, 0xfd, 0x04, 0xed] <> val
- pkt <- mkPacket (pad1300 (encodeBigSize 1265 <> tlv))
- case process sessionKey pkt BS.empty of
- Right (Receive ri) ->
- hpUnknownTlvs (riPayload ri) @?= [TlvRecord 1 val]
- Right (Forward _) -> assertFailure "expected Receive"
- Left e -> assertFailure ("expected success, got " ++ show e)
- ]
-
--- Error tests -------------------------------------------------------------
-
-errorTests :: TestTree
-errorTests = testGroup "error handling" [
- testErrorConstruction
- , testErrorRoundtrip
- , testMultiHopWrapping
- , testErrorAttribution
- , testFailureMessageParsing
- , testFailureMessageFraming
- ]
-
--- Shared secrets for testing (deterministic)
-testSecret1 :: SharedSecret
-testSecret1 = SharedSecret (BS.replicate 32 0x11)
-
-testSecret2 :: SharedSecret
-testSecret2 = SharedSecret (BS.replicate 32 0x22)
-
-testSecret3 :: SharedSecret
-testSecret3 = SharedSecret (BS.replicate 32 0x33)
-
-testSecret4 :: SharedSecret
-testSecret4 = SharedSecret (BS.replicate 32 0x44)
-
--- Simple failure message for testing (htlc_msat 1000, height 800000)
-testFailure :: FailureMessage
-testFailure = FailureMessage IncorrectOrUnknownPaymentDetails
- (BS.pack [0, 0, 0, 0, 0, 0, 0x03, 0xe8, 0, 0x0c, 0x35, 0x00]) []
-
--- | Minimal well-formed data for a failure code.
-failureData :: FailureCode -> BS.ByteString
-failureData c
- | c `elem` [InvalidOnionVersion, InvalidOnionHmac, InvalidOnionKey] =
- BS.replicate 32 0xab
- | c `elem` [TemporaryChannelFailure, ExpiryTooSoon] = BS.pack [0, 0]
- | c `elem` [AmountBelowMinimum, FeeInsufficient] =
- BS.replicate 8 0x01 <> BS.pack [0, 0]
- | c == IncorrectCltvExpiry = BS.replicate 4 0x01 <> BS.pack [0, 0]
- | c == ChannelDisabled = BS.pack [0, 1, 0, 0]
- | c == IncorrectOrUnknownPaymentDetails = BS.replicate 12 0x01
- | c == FinalIncorrectCltvExpiry = BS.replicate 4 0x01
- | c == FinalIncorrectHtlcAmount = BS.replicate 8 0x01
- | c == InvalidOnionPayload = BS.pack [0x02, 0x00, 0x05]
- | otherwise = BS.empty
-
--- | Read a big-endian u16 at an offset, failing the test if short.
-u16At :: Int -> BS.ByteString -> IO Int
-u16At off bs = case BS.unpack (BS.take 2 (BS.drop off bs)) of
- [hi, lo] -> pure (fromIntegral hi * 256 + fromIntegral lo)
- _ -> assertFailure "u16At: input too short"
-
--- | 'constructError', failing the test on Nothing.
-mkError :: SharedSecret -> FailureMessage -> IO ErrorPacket
-mkError ss fm = demand "constructError" (constructError ss fm)
-
--- | 'wrapError', failing the test on Nothing.
-wrapErr :: SharedSecret -> ErrorPacket -> IO ErrorPacket
-wrapErr ss pkt = demand "wrapError" (wrapError ss pkt)
-
--- | Strip the failing node's obfuscation from a return packet and
--- return (failure_len, pad_len, packet length).
-returnPacketLengths :: SharedSecret -> ErrorPacket -> IO (Int, Int, Int)
-returnPacketLengths ss pkt = do
- ErrorPacket raw <- wrapErr ss pkt
- failureLen <- u16At 32 raw
- padLen <- u16At (34 + failureLen) raw
- pure (failureLen, padLen, BS.length raw)
-
-testErrorConstruction :: TestTree
-testErrorConstruction = testGroup "error packet construction" [
- testCase "short message is padded to 256" $ do
- let failure = FailureMessage TemporaryNodeFailure BS.empty []
- errPacket <- mkError testSecret1 failure
- (fl, pl, size) <- returnPacketLengths testSecret1 errPacket
- fl @?= 2
- fl + pl @?= minErrorPacketSize
- size @?= 32 + 2 + fl + 2 + pl
- , testCase "long message is not truncated or padded" $ do
- let failure = FailureMessage TemporaryNodeFailure BS.empty
- [TlvRecord 1 (BS.replicate 300 0x00)]
- errPacket <- mkError testSecret1 failure
- (fl, pl, size) <- returnPacketLengths testSecret1 errPacket
- fl @?= 2 + 1 + 3 + 300
- pl @?= 0
- size @?= 32 + 2 + fl + 2
- ]
-
-testErrorRoundtrip :: TestTree
-testErrorRoundtrip =
- testCase "construct and unwrap roundtrip" $ do
- errPacket <- mkError testSecret1 testFailure
- let result = unwrapError [testSecret1] errPacket
- case result of
- Attributed idx msg -> do
- idx @?= 0
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
-
-testMultiHopWrapping :: TestTree
-testMultiHopWrapping = testGroup "multi-hop wrapping" [
- testCase "3-hop route, error from hop 2 (final)" $ do
- let secrets =
- [testSecret1, testSecret2, testSecret3]
- err0 <- mkError testSecret3 testFailure
- err1 <- wrapErr testSecret2 err0
- err2 <- wrapErr testSecret1 err1
- let result = unwrapError secrets err2
- case result of
- Attributed idx msg -> do
- idx @?= 2
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
-
- , testCase "4-hop route, error from hop 1" $ do
- let secrets = [testSecret1, testSecret2,
- testSecret3, testSecret4]
- err0 <- mkError testSecret2 testFailure
- err1 <- wrapErr testSecret1 err0
- let result = unwrapError secrets err1
- case result of
- Attributed idx msg -> do
- idx @?= 1
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
-
- , testCase "4-hop route, error from hop 0 (first)" $ do
- let secrets = [testSecret1, testSecret2,
- testSecret3, testSecret4]
- err0 <- mkError testSecret1 testFailure
- let result = unwrapError secrets err0
- case result of
- Attributed idx msg -> do
- idx @?= 0
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
+ bs <- right "encode" (encode_blinded_hop_data d)
+ expected <- unhex $ BS.concat
+ [ "0103000000", "020800000000000006c1", "0421", V.rbDavePathKey
+ , "06026964", "0821", V.rbDavePathKey, "0a080024000000962710"
+ , "0c06000b69e505dc", "0e0102", "fd023103123456" ]
+ bs @?= expected
+ decode_blinded_hop_data bs @?= Right d
+ , testCase "blinded hop data: unknown types" $ do
+ decode_blinded_hop_data "\DLE\NUL" @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 16))
+ d <- right "decode" (decode_blinded_hop_data "\ETX\NUL")
+ ex <- tlvs [BOLT1.TlvRecord 3 ""]
+ bhd_extra d @?= ex
+ , testCase "blinded hop data: rejects malformed values" $ do
+ -- payment_relay shorter than its fixed fields
+ decode_blinded_hop_data "\n\ENQ\NUL\NUL\NUL\NUL\NUL" @?=
+ Left (InvalidTlvValue 10)
+ -- payment_relay with a non-minimal fee_base_msat
+ decode_blinded_hop_data "\n\a\NUL\NUL\NUL\NUL\NUL\NUL\NUL" @?=
+ Left (InvalidTlvValue 10)
+ -- payment_constraints shorter than its fixed fields
+ decode_blinded_hop_data "\f\ETX\NUL\NUL\NUL" @?=
+ Left (InvalidTlvValue 12)
+ -- next_node_id and next_path_key_override of the wrong length
+ decode_blinded_hop_data (BS.pack [4, 2, 2, 2]) @?=
+ Left (InvalidTlvValue 4)
+ decode_blinded_hop_data (BS.pack [8, 2, 2, 2]) @?=
+ Left (InvalidTlvValue 8)
+ -- short_channel_id of 9 bytes
+ decode_blinded_hop_data (BS.pack [2, 9] <> BS.replicate 9 0) @?=
+ Left (InvalidTlvValue 2)
+ , testCase "blinded hop data: extra records may not have known types" $ do
+ ex <- tlvs [BOLT1.TlvRecord 1 ""]
+ encode_blinded_hop_data empty_blinded_hop_data { bhd_extra = ex } @?=
+ Left ConflictingTlv
]
-testErrorAttribution :: TestTree
-testErrorAttribution = testGroup "error attribution" [
- testCase "wrong secrets gives UnknownOrigin" $ do
- err <- mkError testSecret1 testFailure
- let wrongSecrets = [testSecret2, testSecret3]
- result = unwrapError wrongSecrets err
- case result of
- UnknownOrigin _ -> return ()
- Attributed _ _ ->
- assertFailure
- "Expected UnknownOrigin with wrong secrets"
-
- , testCase "empty secrets gives UnknownOrigin" $ do
- err <- mkError testSecret1 testFailure
- let result = unwrapError [] err
- case result of
- UnknownOrigin _ -> return ()
- Attributed _ _ ->
- assertFailure
- "Expected UnknownOrigin with empty secrets"
-
- , testCase "correct attribution with multiple failures" $ do
- let failures =
- [ (TemporaryNodeFailure, testSecret1)
- , (PermanentNodeFailure, testSecret2)
- , (InvalidOnionHmac, testSecret3)
+-- failure messages -----------------------------------------------------------
+
+failure_tests :: TestTree
+failure_tests = testGroup "failure messages" [
+ testCase "encodings and codes of every failure" $ do
+ h <- demand "hash" (onion_hash (BS.replicate 32 0xab))
+ m <- msat 100
+ let hh = BS.concat (replicate 32 "ab")
+ cases =
+ [ (TemporaryNodeFailure, "2002")
+ , (PermanentNodeFailure, "6002")
+ , (RequiredNodeFeatureMissing, "6003")
+ , (InvalidOnionVersion h, "c004" <> hh)
+ , (InvalidOnionHmac h, "c005" <> hh)
+ , (InvalidOnionKey h, "c006" <> hh)
+ , (TemporaryChannelFailure "cu", "100700026375")
+ , (PermanentChannelFailure, "4008")
+ , (RequiredChannelFeatureMissing, "4009")
+ , (UnknownNextPeer, "400a")
+ , (AmountBelowMinimum m "", "100b00000000000000640000")
+ , (FeeInsufficient m "cu", "100c000000000000006400026375")
+ , (IncorrectCltvExpiry 800000 "", "100d000c35000000")
+ , (ExpiryTooSoon "", "100e0000")
+ , ( IncorrectOrUnknownPaymentDetails m 800000
+ , "400f0000000000000064000c3500" )
+ , (FinalIncorrectCltvExpiry 800000, "0012000c3500")
+ , (FinalIncorrectHtlcAmount m, "00130000000000000064")
+ , (ChannelDisabled 0 "", "101400000000")
+ , (ExpiryTooFar, "0015")
+ , (InvalidOnionPayload Nothing, "4016")
+ , (InvalidOnionPayload (Just (2, 7)), "401602 0007")
+ , (MppTimeout, "0017")
+ , (InvalidOnionBlinding h, "c018" <> hh)
+ , (UnknownFailure 0x0042 "data", "004264617461")
]
- mapM_ (\(code, secret) -> do
- let failure = FailureMessage code (failureData code) []
- err <- mkError secret failure
- let result = unwrapError [secret] err
- case result of
- Attributed 0 msg -> fmCode msg @?= code
- _ -> assertFailure $
- "Failed for code: " ++ show code
- ) failures
- ]
-
-testFailureMessageParsing :: TestTree
-testFailureMessageParsing =
- testGroup "failure message parsing" [
- testCase "code with data" $ do
- let failData = BS.pack [0, 0, 0, 0, 0, 0, 0x03, 0xe8, 0, 0]
- failure =
- FailureMessage AmountBelowMinimum failData []
- err <- mkError testSecret1 failure
- let result = unwrapError [testSecret1] err
- case result of
- Attributed 0 msg -> do
- fmCode msg @?= AmountBelowMinimum
- fmData msg @?= failData
- _ -> assertFailure "Expected Attributed"
-
- , testCase "various failure codes roundtrip" $ do
- let codes =
- [ InvalidRealm
- , TemporaryNodeFailure
- , PermanentNodeFailure
- , InvalidOnionHmac
- , TemporaryChannelFailure
- , IncorrectOrUnknownPaymentDetails
- ]
- mapM_ (\code -> do
- let failure = FailureMessage code (failureData code) []
- err <- mkError testSecret1 failure
- let result = unwrapError [testSecret1] err
- case result of
- Attributed 0 msg -> fmCode msg @?= code
- _ -> assertFailure $
- "Failed for code: " ++ show code
- ) codes
- ]
-
-testFailureMessageFraming :: TestTree
-testFailureMessageFraming = testGroup "failure message framing" [
- testCase "no length after the failure code" $ do
- encodeFailureMessage
- (FailureMessage TemporaryNodeFailure BS.empty [])
- @?= BS.pack [0x20, 0x02]
- encodeFailureMessage testFailure
- @?= BS.pack [ 0x40, 0x0f, 0, 0, 0, 0, 0, 0, 0x03, 0xe8
- , 0, 0x0c, 0x35, 0x00 ]
- , testCase "decodes spec-framed messages" $ do
- decodeFailureMessage (BS.pack [0x20, 0x02])
- @?= Just (FailureMessage TemporaryNodeFailure BS.empty [])
- decodeFailureMessage (encodeFailureMessage testFailure)
- @?= Just testFailure
- , testCase "splits data from the TLV stream by code" $ do
- let fm = FailureMessage FinalIncorrectHtlcAmount
- (BS.replicate 8 0x07) [TlvRecord 3 (BS.pack [1, 2])]
- decodeFailureMessage (encodeFailureMessage fm) @?= Just fm
- , testCase "channel_update length is honoured" $ do
- let fm = FailureMessage TemporaryChannelFailure
- (BS.pack [0, 3, 0xaa, 0xbb, 0xcc]) []
- decodeFailureMessage (encodeFailureMessage fm) @?= Just fm
- , testCase "ignores extra bytes" $
- decodeFailureMessage (BS.pack [0x20, 0x02, 0xff])
- @?= Just (FailureMessage TemporaryNodeFailure BS.empty [])
- , testCase "unknown code keeps the remainder as data" $
- decodeFailureMessage (BS.pack [0x20, 0x63, 0x01, 0x02])
- @?= Just (FailureMessage (FailureCode 0x2063)
- (BS.pack [0x01, 0x02]) [])
- , testCase "rejects truncated data" $ do
- decodeFailureMessage (BS.pack [0x40, 0x0f, 0, 0, 0]) @?= Nothing
- decodeFailureMessage (BS.pack [0x10, 0x07, 0, 2, 0xaa]) @?= Nothing
- decodeFailureMessage (BS.pack [0x20]) @?= Nothing
+ forM_ cases $ \(f, hx) -> do
+ bs <- unhex (BS.filter (/= 0x20) hx)
+ let fm = FailureMessage f no_tlvs
+ encode_failure_message fm @?= Right bs
+ decode_failure_message bs @?= Right fm
+ Just (failure_code f) @?= fmap fst (BOLT1.decode_u16 bs)
+ , testCase "flags" $ do
+ h <- demand "hash" (onion_hash (BS.replicate 32 0))
+ let flags f = (is_badonion f, is_perm f, is_node f, is_update f)
+ flags TemporaryNodeFailure @?= (False, False, True, False)
+ flags PermanentNodeFailure @?= (False, True, True, False)
+ flags (InvalidOnionBlinding h) @?= (True, True, False, False)
+ flags (ExpiryTooSoon "") @?= (False, False, False, True)
+ flags MppTimeout @?= (False, False, False, False)
+ flags (UnknownFailure 0xf000 "") @?= (True, True, True, True)
+ , testCase "spec example: incorrect_or_unknown_payment_details" $ do
+ bs <- unhex "400f0000000000000064000c3500"
+ m <- msat 100
+ decode_failure_message bs @?= Right
+ (FailureMessage (IncorrectOrUnknownPaymentDetails m 800000) no_tlvs)
+ , testCase "a trailing TLV stream is kept" $ do
+ ex <- tlvs [BOLT1.TlvRecord 34001 (BS.replicate 3 0x80)]
+ let fm = FailureMessage TemporaryNodeFailure ex
+ bs <- right "encode" (encode_failure_message fm)
+ bs @?= "\x20\x02\xfd\x84\xd1\x03\x80\x80\x80"
+ decode_failure_message bs @?= Right fm
+ , testCase "other trailing bytes are ignored" $ do
+ let ignored f bs = decode_failure_message bs @?=
+ Right (FailureMessage f no_tlvs)
+ ignored TemporaryNodeFailure "\x20\x02\xff"
+ -- an even type: not a valid stream without known types
+ ignored TemporaryNodeFailure "\x20\x02\x02\x00"
+ ignored (FinalIncorrectCltvExpiry 1) "\NUL\DC2\NUL\NUL\NUL\SOH\SOH"
+ , testCase "truncated data is rejected" $ do
+ decode_failure_message "" @?= Left InvalidLength
+ decode_failure_message "\x20" @?= Left InvalidLength
+ decode_failure_message "\xc0\x05\x00" @?=
+ Left (InvalidFailureData 0xc005)
+ decode_failure_message "\x10\x07\x00\x02\x00" @?=
+ Left (InvalidFailureData 0x1007)
+ decode_failure_message "\x40\x0f\x00\x00\x00\x00\x00\x00\x00\x64" @?=
+ Left (InvalidFailureData 0x400f)
+ decode_failure_message "\x00\x13\x00" @?=
+ Left (InvalidFailureData 0x0013)
+ decode_failure_message "\x10\x14\x00\x00\x00" @?=
+ Left (InvalidFailureData 0x1014)
+ , testCase "amounts above 21M BTC are rejected" $
+ decode_failure_message "\x00\x13\xff\xff\xff\xff\xff\xff\xff\xff" @?=
+ Left (InvalidFailureData 0x0013)
+ , testCase "unknown codes keep their data" $
+ decode_failure_message "\x12\x34\x01\x00" @?=
+ Right (FailureMessage (UnknownFailure 0x1234 "\x01\x00") no_tlvs)
+ , testCase "channel_update longer than 65535 bytes" $
+ encode_failure_message
+ (FailureMessage (ExpiryTooSoon (BS.replicate 65536 0)) no_tlvs)
+ @?= Left FieldTooLong
]
--- Blinding tests -----------------------------------------------------------
-
--- Test data setup
-
-testSeed :: BS.ByteString
-testSeed = BS.pack [1..32]
-
-makeSecKey :: Word8 -> BS.ByteString
-makeSecKey seed = BS.pack $ replicate 31 0x00 ++ [seed]
-
-makePubKey :: Word8 -> Maybe Secp256k1.Projective
-makePubKey seed = do
- sk <- Secp256k1.roll32 (makeSecKey seed)
- Secp256k1.derive_pub sk
-
-testNodeSecKey1, testNodeSecKey2,
- testNodeSecKey3 :: BS.ByteString
-testNodeSecKey1 = makeSecKey 0x11
-testNodeSecKey2 = makeSecKey 0x22
-testNodeSecKey3 = makeSecKey 0x33
-
-testNodePubKey1, testNodePubKey2,
- testNodePubKey3 :: Secp256k1.Projective
-testNodePubKey1 = case makePubKey 0x11 of
- Just pk -> pk
- Nothing -> error "testNodePubKey1: invalid key"
-testNodePubKey2 = case makePubKey 0x22 of
- Just pk -> pk
- Nothing -> error "testNodePubKey2: invalid key"
-testNodePubKey3 = case makePubKey 0x33 of
- Just pk -> pk
- Nothing -> error "testNodePubKey3: invalid key"
-
-testSharedSecretBS :: SharedSecret
-testSharedSecretBS = SharedSecret (BS.pack [0x42..0x61])
-
-emptyHopData :: BlindedHopData
-emptyHopData = BlindedHopData
- Nothing Nothing Nothing Nothing
- Nothing Nothing Nothing Nothing
-
-sampleHopData :: BlindedHopData
-sampleHopData = BlindedHopData
- { bhdPadding = Nothing
- , bhdShortChannelId = Just (mkScid 700000 1234 0)
- , bhdNextNodeId = Nothing
- , bhdPathId = Just (BS.pack [0x42, 0x42])
- , bhdNextPathKeyOverride = Nothing
- , bhdPaymentRelay = Just (PaymentRelay 40 1000 500)
- , bhdPaymentConstraints =
- Just (PaymentConstraints 144 1000000)
- , bhdAllowedFeatures = Nothing
- }
-
-hopDataWithNextNode :: BlindedHopData
-hopDataWithNextNode = emptyHopData
- { bhdNextNodeId =
- Just (Secp256k1.serialize_point testNodePubKey2)
- }
-
--- 1. Key Derivation Tests -------------------------------------------------
-
-blindingKeyDerivationTests :: TestTree
-blindingKeyDerivationTests = testGroup "key derivation" [
- testCase "deriveBlindingRho produces 32 bytes" $ do
- let DerivedKey rho =
- deriveBlindingRho testSharedSecretBS
- BS.length rho @?= 32
-
- , testCase "deriveBlindingRho is deterministic" $ do
- let rho1 = deriveBlindingRho testSharedSecretBS
- rho2 = deriveBlindingRho testSharedSecretBS
- rho1 @?= rho2
-
- , testCase "deriveBlindingRho differs for diff secrets" $ do
- let ss1 = SharedSecret (BS.replicate 32 0x00)
- ss2 = SharedSecret (BS.replicate 32 0x01)
- rho1 = deriveBlindingRho ss1
- rho2 = deriveBlindingRho ss2
- assertBool "rho values should differ" (rho1 /= rho2)
-
- , testCase "deriveBlindedNodeId produces 33 bytes" $ do
- case deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1 of
- Nothing ->
- assertFailure
- "deriveBlindedNodeId returned Nothing"
- Just blindedId -> BS.length blindedId @?= 33
-
- , testCase "deriveBlindedNodeId is deterministic" $ do
- let result1 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1
- result2 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1
- result1 @?= result2
-
- , testCase "deriveBlindedNodeId differs for diff nodes" $ do
- let result1 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1
- result2 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey2
- assertBool "blinded node IDs should differ"
- (result1 /= result2)
- ]
-
--- 2. Ephemeral Key Iteration Tests ----------------------------------------
-
--- | Derive the public key for testSeed
-testSeedPubKey :: Secp256k1.Projective
-testSeedPubKey = case Secp256k1.roll32 testSeed of
- Nothing -> error "testSeedPubKey: invalid seed"
- Just sk -> case Secp256k1.derive_pub sk of
- Nothing -> error "testSeedPubKey: invalid key"
- Just pk -> pk
-
-blindingEphemeralKeyTests :: TestTree
-blindingEphemeralKeyTests =
- testGroup "ephemeral key iteration" [
- testCase "nextEphemeral produces valid keys" $ do
- case nextEphemeral
- testSeed testSeedPubKey testSharedSecretBS of
- Nothing ->
- assertFailure "nextEphemeral returned Nothing"
- Just (newSecKey, newPubKey) -> do
- BS.length newSecKey @?= 32
- let serialized =
- Secp256k1.serialize_point newPubKey
- BS.length serialized @?= 33
-
- , testCase "nextEphemeral: sec key derives pub key" $ do
- case nextEphemeral
- testSeed testSeedPubKey testSharedSecretBS of
- Nothing ->
- assertFailure "nextEphemeral returned Nothing"
- Just (newSecKey, newPubKey) -> do
- sk <- demand "roll32" $
- Secp256k1.roll32 newSecKey
- derivedPub <- demand "derive_pub" $
- Secp256k1.derive_pub sk
- derivedPub @?= newPubKey
-
- , testCase "nextEphemeral is deterministic" $ do
- let result1 = nextEphemeral
- testSeed testSeedPubKey
- testSharedSecretBS
- result2 = nextEphemeral
- testSeed testSeedPubKey
- testSharedSecretBS
- result1 @?= result2
-
- , testCase "nextEphemeral differs for diff secrets" $ do
- let ss1 = SharedSecret (BS.replicate 32 0xAA)
- ss2 = SharedSecret (BS.replicate 32 0xBB)
- result1 = nextEphemeral
- testSeed testSeedPubKey ss1
- result2 = nextEphemeral
- testSeed testSeedPubKey ss2
- assertBool "results should differ"
- (result1 /= result2)
-
- , testCase "nextEphemeral rejects a secret not of 32 bytes" $ do
- nextEphemeral (BS.singleton 0x07) testSeedPubKey testSharedSecretBS
- @?= Nothing
- nextEphemeral (BS.cons 0x00 testSeed) testSeedPubKey
- testSharedSecretBS @?= Nothing
- ]
-
--- 3. TLV Encoding/Decoding Tests -----------------------------------------
-
-blindingTlvTests :: TestTree
-blindingTlvTests = testGroup "TLV encoding/decoding" [
- testCase "roundtrip: empty hop data" $ do
- let encoded = encodeBlindedHopData emptyHopData
- decoded = decodeBlindedHopData encoded
- decoded @?= Just emptyHopData
-
- , testCase "roundtrip: sample hop data" $ do
- let encoded = encodeBlindedHopData sampleHopData
- decoded = decodeBlindedHopData encoded
- decoded @?= Just sampleHopData
-
- , testCase "roundtrip: hop data with next node ID" $ do
- let encoded = encodeBlindedHopData hopDataWithNextNode
- decoded = decodeBlindedHopData encoded
- decoded @?= Just hopDataWithNextNode
-
- , testCase "roundtrip: hop data with padding" $ do
- let hd = emptyHopData
- { bhdPadding = Just (BS.replicate 16 0x00) }
- encoded = encodeBlindedHopData hd
- decoded = decodeBlindedHopData encoded
- decoded @?= Just hd
-
- , testCase "PaymentRelay encoding/decoding" $ do
- let relay = PaymentRelay 40 1000 500
- hd = emptyHopData
- { bhdPaymentRelay = Just relay }
- encoded = encodeBlindedHopData hd
- decoded = decodeBlindedHopData encoded
- case decoded of
- Nothing ->
- assertFailure
- "decodeBlindedHopData returned Nothing"
- Just d -> bhdPaymentRelay d @?= Just relay
-
- , testCase "PaymentConstraints encoding/decoding" $ do
- let constraints = PaymentConstraints 144 1000000
- hd = emptyHopData
- { bhdPaymentConstraints = Just constraints }
- encoded = encodeBlindedHopData hd
- decoded = decodeBlindedHopData encoded
- case decoded of
- Nothing ->
- assertFailure
- "decodeBlindedHopData returned Nothing"
- Just d ->
- bhdPaymentConstraints d @?= Just constraints
-
- , testCase "decode empty bytestring" $ do
- let decoded = decodeBlindedHopData BS.empty
- decoded @?= Just emptyHopData
- ]
-
--- 4. Encryption/Decryption Tests ------------------------------------------
-
-blindingEncryptionTests :: TestTree
-blindingEncryptionTests =
- testGroup "encryption/decryption" [
- testCase "roundtrip: encrypt then decrypt" $ do
- let rho = deriveBlindingRho testSharedSecretBS
- encrypted <- demand "encryptHopData" $
- encryptHopData rho sampleHopData
- decryptHopData rho encrypted @?= Just sampleHopData
-
- , testCase "roundtrip: empty hop data" $ do
- let rho = deriveBlindingRho testSharedSecretBS
- encrypted <- demand "encryptHopData" $
- encryptHopData rho emptyHopData
- decryptHopData rho encrypted @?= Just emptyHopData
-
- , testCase "decryption with wrong key fails" $ do
- let rho1 = deriveBlindingRho testSharedSecretBS
- rho2 = deriveBlindingRho
- (SharedSecret (BS.replicate 32 0xFF))
- encrypted <- demand "encryptHopData" $
- encryptHopData rho1 sampleHopData
- assertBool "decryption should fail or produce garbage"
- (decryptHopData rho2 encrypted /= Just sampleHopData)
-
- , testCase "encrypt is deterministic" $ do
- let rho = deriveBlindingRho testSharedSecretBS
- encrypted1 = encryptHopData rho sampleHopData
- encrypted2 = encryptHopData rho sampleHopData
- encrypted1 @?= encrypted2
-
- , testCase "encrypt fails on a key that is not 32 bytes" $
- encryptHopData (DerivedKey "short") sampleHopData @?= Nothing
+-- construct ------------------------------------------------------------------
+
+construct_tests :: TestTree
+construct_tests = testGroup "construct" [
+ testCase "empty route" $ do
+ sk <- key 0x41
+ assertConstructError EmptyRoute (construct sk [] ad)
+ , testCase "more than 20 hops" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ let hop = Hop (public_key node) (cltv_payload 1)
+ assertConstructError TooManyHops (construct sk (replicate 21 hop) ad)
+ case construct sk (replicate 20 hop) ad of
+ Right (_, sss) -> length sss @?= 20
+ Left e -> assertFailure (show e)
+ , testCase "invalid hop public key" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ bad <- off_curve
+ let good = Hop (public_key node) (cltv_payload 1)
+ assertConstructError (InvalidHopPubKey 1)
+ (construct sk [good, Hop bad (cltv_payload 1), good] ad)
+ , testCase "payloads under 2 bytes" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ let good = Hop (public_key node) (cltv_payload 1)
+ assertConstructError (InvalidHopPayload 1)
+ (construct sk [good, Hop (public_key node) empty_hop_payload] ad)
+ , testCase "unencodable payload" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ ex <- tlvs [BOLT1.TlvRecord 4 "\SOH"]
+ let bad = Hop (public_key node) empty_hop_payload { hp_extra = ex }
+ assertConstructError (InvalidHopPayload 0) (construct sk [bad] ad)
+ , testCase "payloads over 1300 bytes" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ -- a 1265-byte payload exactly fills hop_payloads
+ ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 1261 0)]
+ let full = Hop (public_key node) empty_hop_payload { hp_extra = ex }
+ case construct sk [full] ad of
+ Right _ -> pure ()
+ Left e -> assertFailure (show e)
+ ex' <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 1262 0)]
+ let over = Hop (public_key node) empty_hop_payload { hp_extra = ex' }
+ assertConstructError (PayloadsTooLarge 1301) (construct sk [over] ad)
+ let hops = replicate 2 (Hop (public_key node) (cltv_payload 1))
+ assertConstructError (PayloadsTooLarge 1372)
+ (construct sk (full : hops) ad)
]
-
--- 5. createBlindedPath Tests ----------------------------------------------
-
-blindingCreatePathTests :: TestTree
-blindingCreatePathTests = testGroup "createBlindedPath" [
- testCase "create path with 2 hops" $ do
- let nodes = [(testNodePubKey1, emptyHopData),
- (testNodePubKey2, sampleHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> do
- length (bpBlindedHops path) @?= 2
- let serialized =
- Secp256k1.serialize_point
- (bpBlindingKey path)
- BS.length serialized @?= 33
-
- , testCase "create path with 3 hops" $ do
- let nodes = [ (testNodePubKey1, emptyHopData)
- , (testNodePubKey2, hopDataWithNextNode)
- , (testNodePubKey3, sampleHopData)
- ]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path ->
- length (bpBlindedHops path) @?= 3
-
- , testCase "all blinded node IDs are 33 bytes" $ do
- let nodes = [ (testNodePubKey1, emptyHopData)
- , (testNodePubKey2, emptyHopData)
- , (testNodePubKey3, emptyHopData)
- ]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> do
- let blindedIds =
- map bhBlindedNodeId (bpBlindedHops path)
- mapM_ (\bid -> BS.length bid @?= 33) blindedIds
-
- , testCase "empty path returns EmptyPath error" $ do
- case createBlindedPath testSeed [] of
- Left EmptyPath -> return ()
- Left err ->
- assertFailure $
- "Expected EmptyPath, got: " ++ show err
- Right _ ->
- assertFailure "Expected error, got success"
-
- , testCase "invalid seed returns InvalidSeed error" $ do
- let invalidSeed = BS.pack [1..16]
- nodes = [(testNodePubKey1, emptyHopData)]
- case createBlindedPath invalidSeed nodes of
- Left InvalidSeed -> return ()
- Left err ->
- assertFailure $
- "Expected InvalidSeed, got: " ++ show err
- Right _ ->
- assertFailure "Expected error, got success"
-
- , testCase "createBlindedPath is deterministic" $ do
- let nodes = [(testNodePubKey1, emptyHopData),
- (testNodePubKey2, sampleHopData)]
- result1 = createBlindedPath testSeed nodes
- result2 = createBlindedPath testSeed nodes
- result1 @?= result2
+ where
+ assertConstructError e r = case r of
+ Left e' -> e' @?= e
+ Right _ -> assertFailure ("expected " ++ show e)
+
+-- process --------------------------------------------------------------------
+
+process_tests :: TestTree
+process_tests = testGroup "process" [
+ testCase "rejects versions other than 0" $ do
+ (node, pkt) <- simple_onion
+ expect_process (InvalidVersion 1)
+ (process node pkt { onion_version = 1 } ad Nothing)
+ , testCase "rejects a public key not on the curve" $ do
+ (node, pkt) <- simple_onion
+ bad <- off_curve
+ expect_process InvalidPublicKey
+ (process node pkt { onion_public_key = bad } ad Nothing)
+ , testCase "rejects a wrong HMAC" $ do
+ (node, pkt) <- simple_onion
+ flipped <- demand "flip" $
+ case BS.uncons (un_hop_payloads (onion_hop_payloads pkt)) of
+ Just (h, t) -> hop_payloads (BS.cons (h `xor` 1) t)
+ Nothing -> Nothing
+ expect_process HmacMismatch
+ (process node pkt { onion_hop_payloads = flipped } ad Nothing)
+ mac <- demand "mac" (hmac32 (BS.replicate 32 0))
+ expect_process HmacMismatch
+ (process node pkt { onion_hmac = mac } ad Nothing)
+ , testCase "rejects other associated data" $ do
+ (node, pkt) <- simple_onion
+ expect_process HmacMismatch
+ (process node pkt (BS.replicate 32 0) Nothing)
+ , testCase "rejects other node keys" $ do
+ (_, pkt) <- simple_onion
+ other <- key 0x44
+ expect_process HmacMismatch (process other pkt ad Nothing)
+ , testCase "rejects payload lengths 0 and 1" $ do
+ node <- key 0x42
+ p0 <- raw_onion node (pad1300 "\NUL")
+ expect_process InvalidPayloadLength (process node p0 ad Nothing)
+ p1 <- raw_onion node (pad1300 "\SOH\SOH")
+ expect_process InvalidPayloadLength (process node p1 ad Nothing)
+ , testCase "rejects a malformed length prefix" $ do
+ node <- key 0x42
+ p <- raw_onion node (pad1300 "\253\NUL\DLE")
+ expect_process InvalidPayloadLength (process node p ad Nothing)
+ , testCase "rejects payloads past the end of hop_payloads" $ do
+ node <- key 0x42
+ -- 3-byte prefix, 1265-byte payload and 32-byte HMAC fill it
+ let rec n = BS.concat [ "\SOH\253", BOLT1.encode_u16 n
+ , BS.replicate (fromIntegral n) 0 ]
+ ok <- raw_onion node (pad1300 ("\253\EOT\241" <> rec 1261))
+ _ <- receive (process node ok ad Nothing)
+ over <- raw_onion node (pad1300 ("\253\EOT\242" <> rec 1262))
+ expect_process InvalidPayloadLength (process node over ad Nothing)
+ -- a length reaching into the zero-extended stream
+ far <- raw_onion node (pad1300 ("\253\a\208" <> rec 1261))
+ expect_process InvalidPayloadLength (process node far ad Nothing)
+ huge <- raw_onion node
+ (pad1300 ("\255\128\NUL\NUL\NUL\NUL\NUL\NUL\NUL" <> rec 1))
+ expect_process InvalidPayloadLength (process node huge ad Nothing)
+ , testCase "rejects malformed payloads" $ do
+ node <- key 0x42
+ let bad pl = raw_onion node
+ (pad1300 (BOLT1.encode_bigsize (fromIntegral (BS.length pl))
+ <> pl))
+ p0 <- bad "\EOT\SOH\SOH\STX\SOH\SOH"
+ expect_process
+ (InvalidPayload (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing))
+ (process node p0 ad Nothing)
+ p1 <- bad "\DC4\NUL"
+ expect_process
+ (InvalidPayload (InvalidTlvStream (BOLT1.TlvUnknownEvenType 20)))
+ (process node p1 ad Nothing)
+ p2 <- bad "\STX\STX\NUL\SOH"
+ expect_process (InvalidPayload (InvalidTlvValue 2))
+ (process node p2 ad Nothing)
+ , testCase "the final hop receives" $ do
+ (node, pkt) <- simple_onion
+ info <- receive (process node pkt ad Nothing)
+ rcv_payload info @?= cltv_payload 144
+ rcv_blinded info @?= Nothing
+ , testCase "forwarded packets are well formed" $ do
+ sk <- key 0x41
+ a <- key 0x42
+ b <- key 0x43
+ (pkt, sss) <- right "construct" $ construct sk
+ [Hop (public_key a) (cltv_payload 1), Hop (public_key b)
+ (cltv_payload 2)] ad
+ fwd <- forward (process a pkt ad Nothing)
+ let next = fwd_next_packet fwd
+ onion_version next @?= 0
+ decode_onion_packet (encode_onion_packet next) @?= Right next
+ Just (fwd_shared_secret fwd) @?= safe_head sss
+ rcv <- receive (process b next ad Nothing)
+ rcv_payload rcv @?= cltv_payload 2
+ , testCase "path keys without encrypted_recipient_data" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ seed <- key 0x01
+ path <- right "path" $
+ create_blinded_path seed [(public_key alice, empty_blinded_hop_data)]
+ bid <- blinded_id path 0
+ let pk = bp_first_path_key path
+ -- a path_key, onion encrypted to the blinded id
+ (p0, _) <- right "construct" $
+ construct sk [Hop bid (cltv_payload 1)] ad
+ expect_process UnexpectedPathKey (process alice p0 ad (Just pk))
+ -- a current_path_key
+ let pl = (cltv_payload 1) { hp_current_path_key = Just pk }
+ (p1, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process UnexpectedPathKey (process alice p1 ad Nothing)
+ , testCase "both a path_key and a current_path_key" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ seed <- key 0x01
+ path <- right "path" $
+ create_blinded_path seed [(public_key alice, empty_blinded_hop_data)]
+ bid <- blinded_id path 0
+ enc <- blinded_data path 0
+ let pk = bp_first_path_key path
+ pl = empty_hop_payload { hp_encrypted_data = Just enc
+ , hp_current_path_key = Just pk }
+ (pkt, _) <- right "construct" $ construct sk [Hop bid pl] ad
+ expect_process UnexpectedPathKey (process alice pkt ad (Just pk))
+ , testCase "encrypted_recipient_data without a path key" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ let pl = empty_hop_payload { hp_encrypted_data = Just "data" }
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process MissingPathKey (process alice pkt ad Nothing)
+ , testCase "undecryptable encrypted_recipient_data" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ pk <- hex_point V.rbBobPathKey
+ let pl = empty_hop_payload { hp_encrypted_data = Just
+ (BS.replicate 40 0)
+ , hp_current_path_key = Just pk }
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process InvalidRecipientData (process alice pkt ad Nothing)
+ , testCase "invalid path keys" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ bad <- off_curve
+ let pl = empty_hop_payload { hp_encrypted_data = Just "data"
+ , hp_current_path_key = Just bad }
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process InvalidPathKey (process alice pkt ad Nothing)
+ (pkt', _) <- right "construct" $
+ construct sk [Hop (public_key alice) (cltv_payload 1)] ad
+ expect_process InvalidPathKey (process alice pkt' ad (Just bad))
]
-
--- 6. processBlindedHop Tests ----------------------------------------------
-
-blindingProcessHopTests :: TestTree
-blindingProcessHopTests =
- testGroup "processBlindedHop" [
- testCase "process first hop decrypts correctly" $ do
- let nodes = [(testNodePubKey1, sampleHopData),
- (testNodePubKey2, emptyHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey (bhEncryptedData firstHop) of
- Left err -> assertFailure $
- "processBlindedHop failed: " ++ show err
- Right (decryptedData, _) ->
- decryptedData @?= sampleHopData
- [] -> assertFailure "expected non-empty hops"
-
- , testCase "process hop chain correctly" $ do
- let nodes =
- [ (testNodePubKey1, emptyHopData)
- , (testNodePubKey2, sampleHopData)
- , (testNodePubKey3, hopDataWithNextNode)
- ]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- [hop1, hop2, hop3] -> do
- let pathKey1 = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey1 (bhEncryptedData hop1) of
- Left err -> assertFailure $
- "processBlindedHop hop1 failed: "
- ++ show err
- Right (data1, pathKey2) -> do
- data1 @?= emptyHopData
- case processBlindedHop testNodeSecKey2
- pathKey2
- (bhEncryptedData hop2) of
- Left err -> assertFailure $
- "processBlindedHop hop2 failed: "
- ++ show err
- Right (data2, pathKey3) -> do
- data2 @?= sampleHopData
- case processBlindedHop
- testNodeSecKey3 pathKey3
- (bhEncryptedData hop3) of
- Left err -> assertFailure $
- "processBlindedHop hop3: "
- ++ show err
- Right (data3, _) ->
- data3 @?= hopDataWithNextNode
- _ -> assertFailure "expected 3 blinded hops"
-
- , testCase "process hop with wrong node key fails" $ do
- let nodes = [(testNodePubKey1, sampleHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey2
- pathKey (bhEncryptedData firstHop) of
- Left _ -> return ()
- Right (decryptedData, _) ->
- assertBool "should not decrypt correctly"
- (decryptedData /= sampleHopData)
- [] -> assertFailure "expected non-empty hops"
-
- , testCase "next path key is valid point" $ do
- let nodes = [(testNodePubKey1, emptyHopData),
- (testNodePubKey2, emptyHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey (bhEncryptedData firstHop) of
- Left err -> assertFailure $
- "processBlindedHop failed: " ++ show err
- Right (_, nextPK) -> do
- let serialized =
- Secp256k1.serialize_point nextPK
- BS.length serialized @?= 33
- [] -> assertFailure "expected non-empty hops"
-
- , testCase "next_path_key_override is used" $ do
- let overrideKey =
- Secp256k1.serialize_point testNodePubKey3
- hopDataWithOverride' = emptyHopData
- { bhdNextPathKeyOverride = Just overrideKey }
- nodes = [(testNodePubKey1, hopDataWithOverride'),
- (testNodePubKey2, emptyHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey (bhEncryptedData firstHop) of
- Left err -> assertFailure $
- "processBlindedHop failed: " ++ show err
- Right (decryptedData, nextPK) -> do
- bhdNextPathKeyOverride decryptedData
- @?= Just overrideKey
- nextPK @?= testNodePubKey3
- [] -> assertFailure "expected non-empty hops"
+ where
+ simple_onion = do
+ sk <- key 0x41
+ node <- key 0x42
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key node) (cltv_payload 144)] ad
+ pure (node, pkt)
+
+three :: [a] -> IO (a, a, a)
+three xs = case xs of
+ [a, b, c] -> pure (a, b, c)
+ _ -> assertFailure "expected three elements"
+
+safe_head :: [a] -> Maybe a
+safe_head xs = case xs of
+ x : _ -> Just x
+ [] -> Nothing
+
+safe_index :: [a] -> Int -> Maybe a
+safe_index xs i = safe_head (drop i xs)
+
+blinded_id :: BlindedPath -> Int -> IO BOLT1.Point
+blinded_id p i =
+ demand "blinded hop" (bh_blinded_node_id <$> safe_index (bp_hops p) i)
+
+blinded_data :: BlindedPath -> Int -> IO BS.ByteString
+blinded_data p i =
+ demand "blinded hop" (bh_encrypted_data <$> safe_index (bp_hops p) i)
+
+-- route blinding -------------------------------------------------------------
+
+blinding_tests :: TestTree
+blinding_tests = testGroup "route blinding" [
+ testCase "empty path" $ do
+ seed <- key 0x01
+ create_blinded_path seed [] @?= Left EmptyPath
+ , testCase "invalid node id" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ bad <- off_curve
+ create_blinded_path seed
+ [ (public_key alice, empty_blinded_hop_data)
+ , (bad, empty_blinded_hop_data) ]
+ @?= Left (InvalidNodeId 1)
+ , testCase "unencodable hop data" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ ex <- tlvs [BOLT1.TlvRecord 6 "id"]
+ create_blinded_path seed
+ [(public_key alice, empty_blinded_hop_data { bhd_extra = ex })]
+ @?= Left (InvalidHopData 0 ConflictingTlv)
+ , testCase "decrypt_recipient_data rejects bad input" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ bob <- key 0x43
+ path <- right "path" $
+ create_blinded_path seed [(public_key alice, empty_blinded_hop_data)]
+ enc <- blinded_data path 0
+ let pk = bp_first_path_key path
+ _ <- right "decrypt" (decrypt_recipient_data alice pk enc)
+ decrypt_recipient_data bob pk enc @?= Left InvalidRecipientData
+ decrypt_recipient_data alice pk (BS.take 15 enc) @?=
+ Left InvalidRecipientData
+ decrypt_recipient_data alice pk (BS.drop 1 enc) @?=
+ Left InvalidRecipientData
+ bad <- off_curve
+ decrypt_recipient_data alice bad enc @?= Left InvalidPathKey
+ , testCase "unknown even types in encrypted data are rejected" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ ex <- tlvs [BOLT1.TlvRecord 20 ""]
+ path <- right "path" $ create_blinded_path seed
+ [(public_key alice, empty_blinded_hop_data { bhd_extra = ex })]
+ enc <- blinded_data path 0
+ decrypt_recipient_data alice (bp_first_path_key path) enc @?=
+ Left InvalidRecipientData
+ , testCase "a payment through a blinded route" $ do
+ -- Carol creates a route Alice -> Bob -> Carol; Dave pays through it,
+ -- reaching Alice unblinded with current_path_key.
+ seed <- key 0x01
+ session <- key 0x02
+ alice <- key 0x42
+ bob <- key 0x43
+ carol <- key 0x44
+ s1 <- scid 1 1 1
+ s2 <- scid 2 2 2
+ m <- msat 1
+ let relay = Just (PaymentRelay 40 100 1000)
+ cons = Just (PaymentConstraints 900000 m)
+ alice_data = empty_blinded_hop_data
+ { bhd_short_channel_id = Just s1, bhd_payment_relay = relay
+ , bhd_payment_constraints = cons }
+ bob_data = empty_blinded_hop_data
+ { bhd_short_channel_id = Just s2, bhd_payment_relay = relay
+ , bhd_payment_constraints = cons }
+ carol_data = empty_blinded_hop_data
+ { bhd_path_id = Just "invoice" }
+ path <- right "path" $ create_blinded_path seed
+ [ (public_key alice, alice_data), (public_key bob, bob_data)
+ , (public_key carol, carol_data) ]
+ bp_first_node_id path @?= public_key alice
+ bp_first_path_key path @?= public_key seed
+ (e0, e1, e2) <- three =<< mapM (blinded_data path) [0, 1, 2]
+ (_, b1, b2) <- three =<< mapM (blinded_id path) [0, 1, 2]
+ amt <- msat 5000
+ let intro = empty_hop_payload
+ { hp_encrypted_data = Just e0
+ , hp_current_path_key = Just (bp_first_path_key path) }
+ final = empty_hop_payload
+ { hp_encrypted_data = Just e2, hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 800000
+ , hp_total_amount_msat = Just amt }
+ route = [ Hop (public_key alice) intro
+ , Hop b1 empty_hop_payload { hp_encrypted_data = Just e1 }
+ , Hop b2 final ]
+ (pkt, sss) <- right "construct" (construct session route ad)
+ fa <- forward (process alice pkt ad Nothing)
+ ia <- demand "alice blinded" (fwd_blinded fa)
+ bi_data ia @?= alice_data
+ fb <- forward (process bob (fwd_next_packet fa) ad
+ (Just (bi_next_path_key ia)))
+ ib <- demand "bob blinded" (fwd_blinded fb)
+ bi_data ib @?= bob_data
+ rc <- receive (process carol (fwd_next_packet fb) ad
+ (Just (bi_next_path_key ib)))
+ ic <- demand "carol blinded" (rcv_blinded rc)
+ bi_data ic @?= carol_data
+ rcv_payload rc @?= final
+ [fwd_shared_secret fa, fwd_shared_secret fb, rcv_shared_secret rc]
+ @?= sss
+ -- the wrong path key yields the wrong blinded key
+ expect_process HmacMismatch
+ (process bob (fwd_next_packet fa) ad
+ (Just (bp_first_path_key path)))
]
--- Property tests ------------------------------------------------------------
-
-propertyTests :: TestTree
-propertyTests = testGroup "invariants" [
- testProperty "ShortChannelId encode/decode roundtrip"
- propScidRoundtrip
- , testProperty "HopPayload encode/decode roundtrip"
- propHopPayloadRoundtrip
- , testProperty "fixed-size newtypes validate length"
- propNewtypeValidation
- , testProperty "FailureMessage encode/decode roundtrip"
- propFailureMessageRoundtrip
+-- returning errors -----------------------------------------------------------
+
+error_tests :: TestTree
+error_tests = testGroup "returning errors" [
+ testCase "padding brings failure_len + pad_len to 256" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error ss fm)
+ let ErrorPacket raw = wrap_error ss pkt
+ BS.length raw @?= 32 + 2 + 2 + 2 + 254
+ BS.take 4 (BS.drop 32 raw) @?= "\NUL\STX\x20\x02"
+ BS.take 2 (BS.drop 36 raw) @?= "\NUL\254"
+ , testCase "long failure messages are not padded" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 300 0)]
+ let fm = FailureMessage TemporaryNodeFailure ex
+ ErrorPacket raw <- wrap_error ss <$>
+ right "construct_error" (construct_error ss fm)
+ BS.length raw @?= 32 + 2 + 306 + 2
+ BS.drop (32 + 2 + 306) raw @?= "\NUL\NUL"
+ , testCase "failure messages over 65535 bytes" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 65535 0)]
+ construct_error ss (FailureMessage TemporaryNodeFailure ex)
+ @?= Left FieldTooLong
+ , testCase "attributes the failing hop" $ do
+ sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b)))
+ [1 .. 5]
+ let fm = FailureMessage PermanentChannelFailure no_tlvs
+ forM_ (zip [0 ..] sss) $ \(i, ss) -> do
+ pkt <- right "construct_error" (construct_error ss fm)
+ let back = foldr wrap_error pkt (take i sss)
+ unwrap_error sss back @?= Attributed i fm
+ , testCase "reports the hop of a malformed failure" $ do
+ sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b)))
+ [1 .. 3]
+ ss2 <- demand "ss2" (safe_index sss 2)
+ -- incorrect_cltv_expiry with no data
+ let fm = FailureMessage (UnknownFailure 0x100d "") no_tlvs
+ pkt <- right "construct_error" (construct_error ss2 fm)
+ let back = foldr wrap_error pkt (take 2 sss)
+ unwrap_error sss back @?= MalformedFailure 2
+ , testCase "reports a malformed return packet" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ -- a valid HMAC over a body whose failure_len overruns it
+ let body = "\SOH\NUL\x20\x02"
+ SHA256.MAC um = SHA256.hmac "um" (un_shared_secret ss)
+ SHA256.MAC mac = SHA256.hmac um body
+ pkt = wrap_error ss (ErrorPacket (mac <> body))
+ unwrap_error [ss] pkt @?= MalformedFailure 0
+ , testCase "unknown origin" $ do
+ sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b)))
+ [1 .. 3]
+ other <- demand "ss" (shared_secret (BS.replicate 32 9))
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error other fm)
+ unwrap_error sss pkt @?= UnknownOrigin
+ unwrap_error [] pkt @?= UnknownOrigin
+ unwrap_error sss (ErrorPacket "short") @?= UnknownOrigin
]
-propScidRoundtrip :: Property
-propScidRoundtrip =
- forAll (choose (0, 0xFFFFFF)) $ \bh ->
- forAll (choose (0, 0xFFFFFF)) $ \ti ->
- forAll arbitrary $ \oi ->
- case shortChannelId bh ti oi of
- Nothing -> False
- Just scid ->
- let encoded = encodeShortChannelId scid
- in decodeShortChannelId encoded == Just scid
-
-propHopPayloadRoundtrip :: Property
-propHopPayloadRoundtrip =
- forAll genHopPayload $ \hp ->
- let encoded = encodeHopPayload hp
- in decodeHopPayload encoded == Just hp
-
-genHopPayload :: Gen HopPayload
-genHopPayload = do
- amt <- oneof [pure Nothing, Just <$> arbitrary]
- cltv <- oneof [pure Nothing, Just <$> arbitrary]
- sci <- oneof [pure Nothing, genScid]
- pure HopPayload
- { hpAmtToForward = amt
- , hpOutgoingCltv = cltv
- , hpShortChannelId = sci
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
- }
- where
- genScid :: Gen (Maybe ShortChannelId)
- genScid = do
- bh <- choose (0, 0xFFFFFF)
- ti <- choose (0, 0xFFFFFF)
- oi <- arbitrary
- pure (shortChannelId bh ti oi)
-
-propNewtypeValidation :: NonNegative Int -> Property
-propNewtypeValidation (NonNegative n) = property $
- let len = n `mod` 2000
- bs = BS.replicate len 0x00
- h32 = hmac32 bs
- hp = hopPayloads bs
- ps = paymentSecret bs
- in (case h32 of
- Just _ -> len == 32
- Nothing -> len /= 32)
- &&
- (case hp of
- Just _ -> len == hopPayloadsSize
- Nothing -> len /= hopPayloadsSize)
- &&
- (case ps of
- Just _ -> len == 32
- Nothing -> len /= 32)
-
-propFailureMessageRoundtrip :: Property
-propFailureMessageRoundtrip =
- forAll genFailureMessage $ \fm ->
- let encoded = encodeFailureMessage fm
- in decodeFailureMessage encoded == Just fm
-
-genFailureMessage :: Gen FailureMessage
-genFailureMessage = do
- code <- elements
- [ InvalidRealm
- , TemporaryNodeFailure
- , PermanentNodeFailure
- , RequiredNodeFeatureMissing
- , InvalidOnionVersion
- , InvalidOnionHmac
- , InvalidOnionKey
- , TemporaryChannelFailure
- , PermanentChannelFailure
- , AmountBelowMinimum
- , FeeInsufficient
- , IncorrectCltvExpiry
- , ExpiryTooSoon
- , IncorrectOrUnknownPaymentDetails
- , FinalIncorrectCltvExpiry
- , FinalIncorrectHtlcAmount
- , ChannelDisabled
- , ExpiryTooFar
- , InvalidOnionPayload
- , MppTimeout
- ]
- dat <- genFailureData code
- ntlv <- choose (0, 3 :: Int)
- types <- (nub . sort) <$> vectorOf ntlv arbitrary
- tlvs <- mapM (\t -> do
- len <- choose (0, 20 :: Int)
- TlvRecord t . BS.pack <$> vectorOf len arbitrary) types
- pure (FailureMessage code dat tlvs)
-
--- | Random well-formed data for a failure code.
-genFailureData :: FailureCode -> Gen BS.ByteString
-genFailureData c
- | c `elem` [InvalidOnionVersion, InvalidOnionHmac, InvalidOnionKey] =
- bytes 32
- | c `elem` [TemporaryChannelFailure, ExpiryTooSoon] = update 0
- | c `elem` [AmountBelowMinimum, FeeInsufficient] = update 8
- | c == IncorrectCltvExpiry = update 4
- | c == ChannelDisabled = update 2
- | c == IncorrectOrUnknownPaymentDetails = bytes 12
- | c == FinalIncorrectCltvExpiry = bytes 4
- | c == FinalIncorrectHtlcAmount = bytes 8
- | c == InvalidOnionPayload = do
- typ <- arbitrary
- off <- bytes 2
- pure (encodeBigSize typ <> off)
- | otherwise = pure BS.empty
- where
- bytes n = BS.pack <$> vectorOf n arbitrary
- update n = do
- fields <- bytes n
- len <- choose (0, 300 :: Int)
- cu <- bytes len
- pure $ fields
- <> BS.pack [fromIntegral (len `div` 256), fromIntegral len]
- <> cu
-
--- Spec vectors: onion-test.json --------------------------------------------
-
--- | Shared secrets for the onion-test.json route (identical to those
--- listed in onion-error-test.json).
-onionSharedSecrets :: IO [BS.ByteString]
-onionSharedSecrets = mapM unhex
- [ V.errSharedSecret0, V.errSharedSecret1, V.errSharedSecret2
- , V.errSharedSecret3, V.errSharedSecret4 ]
+-- spec vectors: onion-test.json ----------------------------------------------
--- | (node key, node pubkey, payload without length prefix) per hop.
-onionVectorHops
- :: IO [(BS.ByteString, Secp256k1.Projective, BS.ByteString)]
-onionVectorHops = mapM hop
+onion_hops :: IO [(SecretKey, BOLT1.Point, BS.ByteString)]
+onion_hops = mapM hop
[ (V.onionNodeKey0, V.onionPubKey0, V.onionPayload0)
, (V.onionNodeKey1, V.onionPubKey1, V.onionPayload1)
, (V.onionNodeKey2, V.onionPubKey2, V.onionPayload2)
@@ -1709,585 +870,596 @@ onionVectorHops = mapM hop
, (V.onionNodeKey4, V.onionPubKey4, V.onionPayload4)
]
where
- hop (k, p, pl) = do
- key <- unhex k
- pub <- unhexPoint p
- body <- unhex pl >>= unprefix
- pure (key, pub, body)
-
--- | Next ephemeral key per spec: SHA256(E || ss) * E.
-nextEphemeralKey
- :: Secp256k1.Projective -> BS.ByteString -> Maybe Secp256k1.Projective
-nextEphemeralKey e ss = do
- tweak <- Secp256k1.roll32
- (SHA256.hash (Secp256k1.serialize_point e <> ss))
- Secp256k1.mul e tweak
-
--- | Process an onion hop by hop, checking each hop's payload and
--- shared secret, and that each forwarded packet is a well-formed
--- 1366-byte packet carrying the expected ephemeral key.
-peelOnion
- :: BS.ByteString
- -> [(BS.ByteString, BS.ByteString, BS.ByteString)]
- -- ^ (node key, expected payload, expected shared secret)
- -> Secp256k1.Projective
- -- ^ expected ephemeral key of the packet
- -> OnionPacket
- -> Assertion
-peelOnion _ [] _ _ = assertFailure "no hops"
-peelOnion ad ((key, body, ss) : rest) eph pkt = do
- opVersion pkt @?= versionByte
- opEphemeralKey pkt @?= Secp256k1.serialize_point eph
- case (process key pkt ad, rest) of
- (Left e, _) -> assertFailure ("process failed: " ++ show e)
- (Right (Receive ri), []) -> do
- encodeHopPayload (riPayload ri) @?= body
- riSharedSecret ri @?= SharedSecret ss
- (Right (Forward fi), _ : _) -> do
- encodeHopPayload (fiPayload fi) @?= body
- fiSharedSecret fi @?= SharedSecret ss
- let next = fiNextPacket fi
- bytes = encodeOnionPacket next
- BS.length bytes @?= onionPacketSize
- decodeOnionPacket bytes @?= Just next
- eph' <- demand "next ephemeral key" (nextEphemeralKey eph ss)
- peelOnion ad rest eph' next
- (Right (Receive _), _ : _) ->
- assertFailure "expected Forward, got Receive"
- (Right (Forward _), []) ->
- assertFailure "expected Receive, got Forward"
-
-onionVectorTests :: TestTree
-onionVectorTests = testGroup "onion-test.json" [
- testCase "construct reproduces the spec onion" $ do
- hops <- onionVectorHops
- sk <- unhex V.onionSessionKey
- ad <- unhex V.onionAssocData
+ hop (k, p, pl) = (,,) <$> hex_key k <*> hex_point p
+ <*> (unhex pl >>= unprefix)
+
+-- the shared secrets of the onion-test.json route, as listed in
+-- onion-error-test.json
+route_secrets :: IO [SharedSecret]
+route_secrets = mapM hex_secret
+ [ V.errSharedSecret0, V.errSharedSecret1, V.errSharedSecret2
+ , V.errSharedSecret3, V.errSharedSecret4 ]
+
+onion_vectors :: TestTree
+onion_vectors = testGroup "onion-test.json" [
+ testCase "construct reproduces the onion" $ do
+ hops <- onion_hops
+ sk <- hex_key V.onionSessionKey
+ assoc <- unhex V.onionAssocData
expected <- unhex V.onionPacket
- sss <- onionSharedSecrets
+ sss <- route_secrets
route <- mapM (\(_, pub, body) -> do
- hp <- demand "decodeHopPayload" (decodeHopPayload body)
- encodeHopPayload hp @?= body
+ hp <- right "decode_hop_payload" (decode_hop_payload body)
+ encode_hop_payload hp @?= Right body
pure (Hop pub hp)) hops
- case construct sk route ad of
- Left e -> assertFailure ("construct failed: " ++ show e)
- Right (pkt, secrets) -> do
- encodeOnionPacket pkt @?= expected
- secrets @?= map SharedSecret sss
-
- , testCase "process peels the spec onion at every hop" $ do
- hops <- onionVectorHops
- sk <- unhex V.onionSessionKey
- ad <- unhex V.onionAssocData
- sss <- onionSharedSecrets
- pkt <- unhex V.onionPacket >>=
- demand "decodeOnionPacket" . decodeOnionPacket
- e0 <- demand "session pubkey"
- (Secp256k1.roll32 sk >>= Secp256k1.derive_pub)
- let expect = zipWith (\(k, _, body) ss -> (k, body, ss)) hops sss
- peelOnion ad expect e0 pkt
+ (pkt, secrets) <- right "construct" (construct sk route assoc)
+ encode_onion_packet pkt @?= expected
+ secrets @?= sss
+ , testCase "process peels the onion at every hop" $ do
+ hops <- onion_hops
+ assoc <- unhex V.onionAssocData
+ sss <- route_secrets
+ pkt <- unhex V.onionPacket >>= right "decode" . decode_onion_packet
+ let go [] _ = assertFailure "no hops"
+ go [((k, _, body), ss)] p = do
+ r <- receive (process k p assoc Nothing)
+ encode_hop_payload (rcv_payload r) @?= Right body
+ rcv_shared_secret r @?= ss
+ go (((k, _, body), ss) : rest) p = do
+ f <- forward (process k p assoc Nothing)
+ encode_hop_payload (fwd_payload f) @?= Right body
+ fwd_shared_secret f @?= ss
+ fwd_blinded f @?= Nothing
+ go rest (fwd_next_packet f)
+ go (zip hops sss) pkt
]
--- Multi-hop construct/process ----------------------------------------------
-
--- | Construct an onion over a route of (node key, payload) pairs, then
--- process it at every hop, checking payloads and shared secrets.
-roundtripRoute :: BS.ByteString -> [(BS.ByteString, HopPayload)] -> Bool
-roundtripRoute sk route = case mapM mkHop route of
- Nothing -> False
- Just hops -> case construct sk hops ad of
- Left _ -> False
- Right (pkt, secrets) ->
- length secrets == length route && go (zip route secrets) pkt
- where
- ad = BS.replicate 32 0x42
- mkHop (k, hp) = do
- pub <- Secp256k1.roll32 k >>= Secp256k1.derive_pub
- pure (Hop pub hp)
- go [] _ = False
- go [((k, hp), ss)] pkt = case process k pkt ad of
- Right (Receive ri) -> riPayload ri == hp && riSharedSecret ri == ss
- _ -> False
- go (((k, hp), ss) : rest) pkt = case process k pkt ad of
- Right (Forward fi) ->
- fiPayload fi == hp
- && fiSharedSecret fi == ss
- && BS.length (encodeOnionPacket (fiNextPacket fi))
- == onionPacketSize
- && go rest (fiNextPacket fi)
- _ -> False
-
-multiHopTests :: TestTree
-multiHopTests = testGroup "construct then process" [
- testCase "routes of 1 to 20 hops" $
- mapM_ (\n -> do
- route <- mapM (\i -> do
- scid <- assertScid (700000 + i) i 1
- let hp = HopPayload
- { hpAmtToForward = Just (1000 * fromIntegral i)
- , hpOutgoingCltv = Just (500000 + i)
- , hpShortChannelId = Just scid
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
- }
- pure (BS.replicate 32 (fromIntegral i), hp)) [1 .. n]
- assertBool ("route of " ++ show n ++ " hops")
- (roundtripRoute sessionKey route)) [1 .. 20 :: Word32]
-
- , testProperty "random routes of 1 to 20 hops" $
- forAll (choose (1, 20)) $ \n ->
- forAll genSecKey $ \sk ->
- forAll (vectorOf n genSecKey) $ \keys ->
- forAll (vectorOf n (genRoutePayload n)) $ \pls ->
- roundtripRoute sk (zip keys pls)
- ]
-
--- | A valid 32-byte secret key.
-genSecKey :: Gen BS.ByteString
-genSecKey = (BS.pack <$> vectorOf 32 arbitrary) `suchThat` valid
- where
- valid k = isJust (Secp256k1.roll32 k >>= Secp256k1.derive_pub)
+-- spec vectors: onion-error-test.json ----------------------------------------
--- | A hop payload whose shift size fits n hops in 1300 bytes.
---
--- The fixed fields take at most 26 bytes; an odd TLV of type 65537
--- adds at most 8 bytes of framing plus its value. With a 3-byte
--- length prefix and 32-byte HMAC a hop then shifts at most 69 bytes
--- plus the value length.
-genRoutePayload :: Int -> Gen HopPayload
-genRoutePayload n = do
- amt <- arbitrary
- cltv <- arbitrary
- scid <- oneof [pure Nothing, genScid]
- let budget = hopPayloadsSize `div` n - 69
- extra <- if budget < 0
- then pure []
- else do
- len <- choose (0, budget)
- blob <- BS.pack <$> vectorOf len arbitrary
- pure [TlvRecord 65537 blob]
- pure HopPayload
- { hpAmtToForward = Just amt
- , hpOutgoingCltv = Just cltv
- , hpShortChannelId = scid
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = extra
- }
- where
- genScid :: Gen (Maybe ShortChannelId)
- genScid = do
- bh <- choose (0, 0xFFFFFF)
- ti <- choose (0, 0xFFFFFF)
- oi <- arbitrary
- pure (shortChannelId bh ti oi)
-
--- Spec vectors: onion-error-test.json --------------------------------------
-
--- | Shared secrets for hops 0 to 4, in route order.
-errorSharedSecrets :: IO [SharedSecret]
-errorSharedSecrets = map SharedSecret <$> onionSharedSecrets
-
--- | The failing node's (hop 4) shared secret, and those of the hops
--- that wrap its return packet, from hop 3 back to hop 0.
-errorWrappers :: IO (SharedSecret, [SharedSecret])
-errorWrappers = do
- sss <- errorSharedSecrets
+-- the failing node's shared secret, and those of the hops back to the
+-- origin, from hop 3 to hop 0
+error_wrappers :: IO (SharedSecret, [SharedSecret])
+error_wrappers = do
+ sss <- route_secrets
case reverse sss of
ss4 : rest -> pure (ss4, rest)
- [] -> assertFailure "no shared secrets"
-
-errorVectorTests :: TestTree
-errorVectorTests = testGroup "onion-error-test.json" [
- testCase "ammag and um keys" $ do
- sss <- errorSharedSecrets
- ammags <- mapM unhex
- [ V.errAmmagKey0, V.errAmmagKey1, V.errAmmagKey2
- , V.errAmmagKey3, V.errAmmagKey4 ]
- map deriveAmmag sss @?= map DerivedKey ammags
- (ss4, _) <- errorWrappers
- um4 <- unhex V.errUmKey4
- deriveUm ss4 @?= DerivedKey um4
-
- , testCase "failing node builds the spec return packet" $ do
- (ss4, _) <- errorWrappers
+ [] -> assertFailure "no shared secrets"
+
+error_vectors :: TestTree
+error_vectors = testGroup "onion-error-test.json" [
+ testCase "failure message" $ do
msg <- unhex V.errFailureMessage
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ encode_failure_message fm @?= Right msg
+ decode_failure_message msg @?= Right fm
+ , testCase "the failing node's return packet" $ do
+ (ss4, _) <- error_wrappers
payload <- unhex V.errPayload4
- fm <- demand "decodeFailureMessage" (decodeFailureMessage msg)
- fm @?= FailureMessage TemporaryNodeFailure BS.empty []
- encodeFailureMessage fm @?= msg
- -- removing hop 4's own obfuscation leaves hmac || payload
- ErrorPacket raw <- mkError ss4 fm >>= wrapErr ss4
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error ss4 fm)
+ -- removing hop 4's obfuscation leaves the HMAC and payload
+ let ErrorPacket raw = wrap_error ss4 pkt
BS.drop 32 raw @?= payload
-
- , testCase "wrapping at each hop yields the spec packet" $ do
- (ss4, wrappers) <- errorWrappers
+ , testCase "wrapping at each hop yields the returned packet" $ do
+ (ss4, wrappers) <- error_wrappers
expected <- unhex V.errPacket
- let fm = FailureMessage TemporaryNodeFailure BS.empty []
- initial <- mkError ss4 fm
- final <- foldM (flip wrapErr) initial wrappers
- final @?= ErrorPacket expected
-
- , testCase "origin attributes the spec packet to hop 4" $ do
- sss <- errorSharedSecrets
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error ss4 fm)
+ foldl (flip wrap_error) pkt wrappers @?= ErrorPacket expected
+ , testCase "the origin attributes the packet to hop 4" $ do
+ sss <- route_secrets
pkt <- unhex V.errPacket
- unwrapError sss (ErrorPacket pkt)
- @?= Attributed 4 (FailureMessage TemporaryNodeFailure BS.empty [])
+ unwrap_error sss (ErrorPacket pkt) @?=
+ Attributed 4 (FailureMessage TemporaryNodeFailure no_tlvs)
]
--- Spec vectors: 'Returning Errors' trace -----------------------------------
+-- spec vectors: 'Returning Errors' trace -------------------------------------
--- | incorrect_or_unknown_payment_details with htlc_msat 100, height
--- 800000 and a 300-byte TLV of type 34001.
-traceFailure :: FailureMessage
-traceFailure = FailureMessage IncorrectOrUnknownPaymentDetails
- (BS.pack [0, 0, 0, 0, 0, 0, 0, 100, 0, 0x0c, 0x35, 0x00])
- [TlvRecord 34001 (BS.replicate 300 0x80)]
+trace_failure :: IO FailureMessage
+trace_failure = do
+ m <- msat 100
+ ex <- tlvs [BOLT1.TlvRecord 34001 (BS.replicate 300 0x80)]
+ pure (FailureMessage (IncorrectOrUnknownPaymentDetails m 800000) ex)
-traceVectorTests :: TestTree
-traceVectorTests = testGroup "returning errors trace" [
+trace_vectors :: TestTree
+trace_vectors = testGroup "returning errors trace" [
testCase "failure message encoding" $ do
+ fm <- trace_failure
-- the trace lists failuremsg || pad_len || pad
encoded <- unhex V.traceFailureMessage
- raw <- unhex V.traceRawPacket
- let msg = encodeFailureMessage traceFailure
- BS.take (BS.length msg) encoded @?= msg
- decodeFailureMessage msg @?= Just traceFailure
- failureLen <- u16At 32 raw
- failureLen @?= BS.length msg
- BS.take failureLen (BS.drop 34 raw) @?= msg
-
+ msg <- right "encode" (encode_failure_message fm)
+ BS.length msg @?= 320
+ BS.take 320 encoded @?= msg
+ decode_failure_message msg @?= Right fm
, testCase "each hop's packet matches the trace" $ do
- (ss4, wrappers) <- errorWrappers
+ (ss4, wrappers) <- error_wrappers
raw <- unhex V.traceRawPacket
expected <- mapM unhex
[ V.tracePacket4, V.tracePacket3, V.tracePacket2
, V.tracePacket1, V.tracePacket0 ]
- packets <- demand "wrapError" $ sequence $ drop 1 $
- scanl (\p ss -> p >>= wrapError ss) (Just (ErrorPacket raw))
- (ss4 : wrappers)
+ let packets = drop 1 $
+ scanl (flip wrap_error) (ErrorPacket raw) (ss4 : wrappers)
packets @?= map ErrorPacket expected
-
- , testCase "origin attributes the trace packet to hop 4" $ do
- sss <- errorSharedSecrets
+ , testCase "the origin attributes the packet to hop 4" $ do
+ fm <- trace_failure
+ sss <- route_secrets
pkt <- unhex V.tracePacket0
- unwrapError sss (ErrorPacket pkt) @?= Attributed 4 traceFailure
+ unwrap_error sss (ErrorPacket pkt) @?= Attributed 4 fm
]
--- Spec vectors: route-blinding-test.json -----------------------------------
-
--- | Blinded private key HMAC256("blinded_node_id", ss) * k, where
--- ss = ECDH(k, path_key). The library has no function for this, so
--- it is assembled from exported primitives.
-blindedPrivKey
- :: BS.ByteString -> Secp256k1.Projective -> Maybe BS.ByteString
-blindedPrivKey k pathKey = do
- SharedSecret ss <- computeSharedSecret k pathKey
- let SHA256.MAC tweak = SHA256.hmac "blinded_node_id" ss
- blindSecKey k (BlindingFactor tweak)
-
-rbBobData :: IO BlindedHopData
-rbBobData = do
- scid <- assertScid 0 0 1729
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 26 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 36 150 10000)
- , bhdPaymentConstraints = Just (PaymentConstraints 748005 1500)
- , bhdAllowedFeatures = Just BS.empty
+-- spec vectors: route-blinding-test.json -------------------------------------
+
+empty_features :: Maybe BOLT9.FeatureVector
+empty_features = Just (BOLT9.parse BS.empty)
+
+rb_bob_data :: IO BlindedHopData
+rb_bob_data = do
+ s <- scid 0 0 1729
+ m <- msat 1500
+ ex <- tlvs [BOLT1.TlvRecord 561 "\DC24V"]
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 26 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 36 150 10000)
+ , bhd_payment_constraints = Just (PaymentConstraints 748005 m)
+ , bhd_allowed_features = empty_features
+ , bhd_extra = ex
}
-rbCarolData :: IO BlindedHopData
-rbCarolData = do
- scid <- assertScid 0 0 1105
- override <- unhex V.rbDavePathKey
- pure emptyHopData
- { bhdShortChannelId = Just scid
- , bhdNextPathKeyOverride = Just override
- , bhdPaymentRelay = Just (PaymentRelay 48 100 500)
- , bhdPaymentConstraints = Just (PaymentConstraints 747969 1500)
- , bhdAllowedFeatures = Just BS.empty
+rb_carol_data :: IO BlindedHopData
+rb_carol_data = do
+ s <- scid 0 0 1105
+ m <- msat 1500
+ override <- hex_point V.rbDavePathKey
+ pure empty_blinded_hop_data
+ { bhd_short_channel_id = Just s
+ , bhd_next_path_key_override = Just override
+ , bhd_payment_relay = Just (PaymentRelay 48 100 500)
+ , bhd_payment_constraints = Just (PaymentConstraints 747969 m)
+ , bhd_allowed_features = empty_features
}
-rbDaveData :: IO BlindedHopData
-rbDaveData = do
- scid <- assertScid 0 0 561
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 35 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 144 250 0)
- , bhdPaymentConstraints = Just (PaymentConstraints 747921 1500)
- , bhdAllowedFeatures = Just BS.empty
+rb_dave_data :: IO BlindedHopData
+rb_dave_data = do
+ s <- scid 0 0 561
+ m <- msat 1500
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 35 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 144 250 0)
+ , bhd_payment_constraints = Just (PaymentConstraints 747921 m)
+ , bhd_allowed_features = empty_features
}
-rbEveData :: IO BlindedHopData
-rbEveData = pure emptyHopData
- { bhdPadding = Just (BS.replicate 26 0)
- , bhdPathId = Just (BS.pack [0xde, 0xad, 0xbe, 0xef])
- , bhdPaymentConstraints = Just (PaymentConstraints 747777 1500)
- , bhdAllowedFeatures = Just (BS.cons 0x02 (BS.replicate 14 0))
- }
+rb_eve_data :: IO BlindedHopData
+rb_eve_data = do
+ m <- msat 1500
+ ex <- tlvs [BOLT1.TlvRecord 65535 "\ACK\193"]
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 26 0)
+ , bhd_path_id = Just "\222\173\190\239"
+ , bhd_payment_constraints = Just (PaymentConstraints 747777 m)
+ , bhd_allowed_features =
+ Just (BOLT9.parse (BS.cons 0x02 (BS.replicate 14 0)))
+ , bhd_extra = ex
+ }
--- | A hop of route-blinding-test.json. 'rbUnknown' holds the unknown
--- odd TLVs that the hop's data carries in addition to 'rbData'.
+-- a hop of route-blinding-test.json
data RbHop = RbHop
- { rbData :: !BlindedHopData
- , rbUnknown :: ![TlvRecord]
- , rbNodeId :: !Secp256k1.Projective
- , rbTlvs :: !BS.ByteString
- , rbPathPrivKey :: !BS.ByteString
- , rbPathKey :: !Secp256k1.Projective
- , rbSharedSecret :: !BS.ByteString
- , rbRho :: !BS.ByteString
- , rbEncrypted :: !BS.ByteString
- , rbBlindedNodeId :: !BS.ByteString
- , rbNodeKey :: !BS.ByteString
- , rbBlindedKey :: !BS.ByteString
- , rbNextPathKey :: !Secp256k1.Projective
+ { rb_data :: !BlindedHopData
+ , rb_node_id :: !BOLT1.Point
+ , rb_tlvs :: !BS.ByteString
+ , rb_path_key :: !BOLT1.Point
+ , rb_encrypted :: !BS.ByteString
+ , rb_blinded_id :: !BOLT1.Point
+ , rb_node_key :: !SecretKey
+ , rb_next_path_key :: !BOLT1.Point
}
-rbHops :: IO (RbHop, RbHop, RbHop, RbHop)
-rbHops = do
- bob <- hop rbBobData [TlvRecord 561 (BS.pack [0x12, 0x34, 0x56])]
- ( V.rbBobNodeId, V.rbBobTlvs, V.rbBobPathPrivKey, V.rbBobPathKey
- , V.rbBobSharedSecret, V.rbBobRho, V.rbBobEncryptedData
- , V.rbBobBlindedNodeId )
- (V.rbBobNodeKey, V.rbBobBlindedPrivKey, V.rbBobNextPathKey)
- carol <- hop rbCarolData []
- ( V.rbCarolNodeId, V.rbCarolTlvs, V.rbCarolPathPrivKey
- , V.rbCarolPathKey, V.rbCarolSharedSecret, V.rbCarolRho
- , V.rbCarolEncryptedData, V.rbCarolBlindedNodeId )
- (V.rbCarolNodeKey, V.rbCarolBlindedPrivKey, V.rbCarolNextPathKey)
- dave <- hop rbDaveData []
- ( V.rbDaveNodeId, V.rbDaveTlvs, V.rbDavePathPrivKey, V.rbDavePathKey
- , V.rbDaveSharedSecret, V.rbDaveRho, V.rbDaveEncryptedData
- , V.rbDaveBlindedNodeId )
- (V.rbDaveNodeKey, V.rbDaveBlindedPrivKey, V.rbDaveNextPathKey)
- eve <- hop rbEveData [TlvRecord 65535 (BS.pack [0x06, 0xc1])]
- ( V.rbEveNodeId, V.rbEveTlvs, V.rbEvePathPrivKey, V.rbEvePathKey
- , V.rbEveSharedSecret, V.rbEveRho, V.rbEveEncryptedData
- , V.rbEveBlindedNodeId )
- (V.rbEveNodeKey, V.rbEveBlindedPrivKey, V.rbEveNextPathKey)
- pure (bob, carol, dave, eve)
+rb_hops :: IO [RbHop]
+rb_hops = sequence
+ [ hop rb_bob_data
+ ( V.rbBobNodeId, V.rbBobTlvs, V.rbBobPathKey
+ , V.rbBobEncryptedData, V.rbBobBlindedNodeId )
+ (V.rbBobNodeKey, V.rbBobNextPathKey)
+ , hop rb_carol_data
+ ( V.rbCarolNodeId, V.rbCarolTlvs, V.rbCarolPathKey
+ , V.rbCarolEncryptedData, V.rbCarolBlindedNodeId )
+ (V.rbCarolNodeKey, V.rbCarolNextPathKey)
+ , hop rb_dave_data
+ ( V.rbDaveNodeId, V.rbDaveTlvs, V.rbDavePathKey
+ , V.rbDaveEncryptedData, V.rbDaveBlindedNodeId )
+ (V.rbDaveNodeKey, V.rbDaveNextPathKey)
+ , hop rb_eve_data
+ ( V.rbEveNodeId, V.rbEveTlvs, V.rbEvePathKey
+ , V.rbEveEncryptedData, V.rbEveBlindedNodeId )
+ (V.rbEveNodeKey, V.rbEveNextPathKey)
+ ]
where
- hop mkData unknown (nid, tlvs, ppk, pk, ss, rho, enc, bid)
- (nk, bk, npk) =
- RbHop <$> mkData <*> pure unknown <*> unhexPoint nid
- <*> unhex tlvs <*> unhex ppk <*> unhexPoint pk <*> unhex ss
- <*> unhex rho <*> unhex enc <*> unhex bid <*> unhex nk
- <*> unhex bk <*> unhexPoint npk
-
-routeBlindingTests :: TestTree
-routeBlindingTests = testGroup "route-blinding-test.json" [
- testCase "encrypted_data_tlv encoding" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\h -> do
- -- unknown odd TLVs are the last records in the vectors
- encodeBlindedHopData (rbData h) <> encodeTlvStream (rbUnknown h)
- @?= rbTlvs h
- decodeBlindedHopData (rbTlvs h) @?= Just (rbData h))
- [bob, carol, dave, eve]
-
- , testCase "per-hop shared secret and rho" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\h -> do
- ss <- demand "computeSharedSecret" $
- computeSharedSecret (rbPathPrivKey h) (rbNodeId h)
- ss @?= SharedSecret (rbSharedSecret h)
- deriveBlindingRho ss @?= DerivedKey (rbRho h)
- deriveBlindedNodeId ss (rbNodeId h)
- @?= Just (rbBlindedNodeId h))
- [bob, carol, dave, eve]
-
- , testCase "nextEphemeral yields the next path key pair" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\(h, nxt) -> do
- let ss = SharedSecret (rbSharedSecret h)
- nextEphemeral (rbPathPrivKey h) (rbPathKey h) ss
- @?= Just (rbPathPrivKey nxt, rbPathKey nxt))
- [(bob, carol), (dave, eve)]
-
- , testCase "createBlindedPath (Bob -> Carol)" $ do
- (bob, carol, _, _) <- rbHops
- path <- either (assertFailure . show) pure $
- createBlindedPath (rbPathPrivKey bob)
- [(rbNodeId bob, rbData bob), (rbNodeId carol, rbData carol)]
- bpIntroductionNode path @?= rbNodeId bob
- bpBlindingKey path @?= rbPathKey bob
- case bpBlindedHops path of
- [b, c] -> do
- bhBlindedNodeId b @?= rbBlindedNodeId bob
- bhBlindedNodeId c @?= rbBlindedNodeId carol
- -- Bob's data in the vector carries an unknown TLV (561)
- -- that BlindedHopData cannot represent, so only Carol's
- -- encrypted_data can be reproduced.
- bhEncryptedData c @?= rbEncrypted carol
- _ -> assertFailure "expected 2 blinded hops"
-
- , testCase "createBlindedPath (Dave -> Eve)" $ do
- (_, _, dave, eve) <- rbHops
- path <- either (assertFailure . show) pure $
- createBlindedPath (rbPathPrivKey dave)
- [(rbNodeId dave, rbData dave), (rbNodeId eve, rbData eve)]
- bpIntroductionNode path @?= rbNodeId dave
- bpBlindingKey path @?= rbPathKey dave
- case bpBlindedHops path of
- [d, e] -> do
- bhBlindedNodeId d @?= rbBlindedNodeId dave
- bhBlindedNodeId e @?= rbBlindedNodeId eve
- -- Eve's data carries an unknown TLV (65535); see above.
- bhEncryptedData d @?= rbEncrypted dave
- _ -> assertFailure "expected 2 blinded hops"
-
- , testCase "unblinding at each hop" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\h -> do
- case processBlindedHop (rbNodeKey h) (rbPathKey h)
- (rbEncrypted h) of
- Left e -> assertFailure ("processBlindedHop: " ++ show e)
- Right (dat, npk) -> do
- dat @?= rbData h
- npk @?= rbNextPathKey h
- blindedPrivKey (rbNodeKey h) (rbPathKey h)
- @?= Just (rbBlindedKey h))
- [bob, carol, dave, eve]
+ hop mk (nid, tl, pk, enc, bid) (nk, npk) =
+ RbHop <$> mk <*> hex_point nid <*> unhex tl <*> hex_point pk
+ <*> unhex enc <*> hex_point bid <*> hex_key nk
+ <*> hex_point npk
+
+route_blinding_vectors :: TestTree
+route_blinding_vectors = testGroup "route-blinding-test.json" [
+ testCase "encrypted_data_tlv encodings" $ do
+ hops <- rb_hops
+ forM_ hops $ \h -> do
+ encode_blinded_hop_data (rb_data h) @?= Right (rb_tlvs h)
+ decode_blinded_hop_data (rb_tlvs h) @?= Right (rb_data h)
+ , testCase "create_blinded_path reproduces the route" $ do
+ hops <- rb_hops
+ (bob, carol, dave, eve) <- case hops of
+ [b, c, d, e] -> pure (b, c, d, e)
+ _ -> assertFailure "expected 4 hops"
+ -- Bob creates Bob -> Carol, Eve creates Dave -> Eve
+ bob_seed <- hex_key V.rbBobPathPrivKey
+ dave_seed <- hex_key V.rbDavePathPrivKey
+ let check seed hs = do
+ path <- right "create_blinded_path" $ create_blinded_path seed
+ [ (rb_node_id h, rb_data h) | h <- hs ]
+ case hs of
+ h : _ -> do
+ bp_first_node_id path @?= rb_node_id h
+ bp_first_path_key path @?= rb_path_key h
+ [] -> assertFailure "no hops"
+ bp_hops path @?=
+ [ BlindedHop (rb_blinded_id h) (rb_encrypted h) | h <- hs ]
+ check bob_seed [bob, carol]
+ check dave_seed [dave, eve]
+ , testCase "each hop decrypts its data and next path key" $ do
+ hops <- rb_hops
+ forM_ hops $ \h -> do
+ info <- right "decrypt_recipient_data" $
+ decrypt_recipient_data (rb_node_key h) (rb_path_key h)
+ (rb_encrypted h)
+ bi_data info @?= rb_data h
+ encode_blinded_hop_data (bi_data info) @?= Right (rb_tlvs h)
+ -- Carol's next path key is her next_path_key_override
+ bi_next_path_key info @?= rb_next_path_key h
+ , testCase "each hop decrypts an onion to its blinded id" $ do
+ -- the onion is encrypted to blinded_node_id, so processing it
+ -- requires the blinded private key of the vector
+ hops <- rb_hops
+ session <- key 0x55
+ forM_ hops $ \h -> do
+ let pl = empty_hop_payload
+ { hp_encrypted_data = Just (rb_encrypted h) }
+ (pkt, sss) <- right "construct" $
+ construct session [Hop (rb_blinded_id h) pl] ad
+ r <- receive (process (rb_node_key h) pkt ad (Just (rb_path_key h)))
+ Just (rcv_shared_secret r) @?= safe_head sss
+ fmap bi_next_path_key (rcv_blinded r) @?= Just (rb_next_path_key h)
]
--- Spec vectors: blinded-payment-onion-test.json ----------------------------
-
-bpBobData :: IO BlindedHopData
-bpBobData = do
- scid <- assertScid 0 0 1
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 32 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 50 0 10000)
- , bhdPaymentConstraints = Just (PaymentConstraints 750150 50)
- , bhdAllowedFeatures = Just BS.empty
+-- spec vectors: blinded-payment-onion-test.json ------------------------------
+
+bp_bob_data :: IO BlindedHopData
+bp_bob_data = do
+ s <- scid 0 0 1
+ m <- msat 50
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 32 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 50 0 10000)
+ , bhd_payment_constraints = Just (PaymentConstraints 750150 m)
+ , bhd_allowed_features = empty_features
}
-bpCarolData :: IO BlindedHopData
-bpCarolData = do
- scid <- assertScid 0 0 2
- override <- unhex V.rbDavePathKey
- pure emptyHopData
- { bhdShortChannelId = Just scid
- , bhdNextPathKeyOverride = Just override
- , bhdPaymentRelay = Just (PaymentRelay 75 150 100)
- , bhdPaymentConstraints = Just (PaymentConstraints 750100 50)
- , bhdAllowedFeatures = Just BS.empty
+bp_carol_data :: IO BlindedHopData
+bp_carol_data = do
+ s <- scid 0 0 2
+ m <- msat 50
+ override <- hex_point V.rbDavePathKey
+ pure empty_blinded_hop_data
+ { bhd_short_channel_id = Just s
+ , bhd_next_path_key_override = Just override
+ , bhd_payment_relay = Just (PaymentRelay 75 150 100)
+ , bhd_payment_constraints = Just (PaymentConstraints 750100 m)
+ , bhd_allowed_features = empty_features
}
-bpDaveData :: IO BlindedHopData
-bpDaveData = do
- scid <- assertScid 0 0 3
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 34 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 25 100 0)
- , bhdPaymentConstraints = Just (PaymentConstraints 750025 50)
- , bhdAllowedFeatures = Just BS.empty
+bp_dave_data :: IO BlindedHopData
+bp_dave_data = do
+ s <- scid 0 0 3
+ m <- msat 50
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 34 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 25 100 0)
+ , bhd_payment_constraints = Just (PaymentConstraints 750025 m)
+ , bhd_allowed_features = empty_features
}
-bpEveData :: IO BlindedHopData
-bpEveData = do
- pathId <- unhex "c9cf92f45ade68345bc20ae672e2012f4af487ed4415"
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 28 0)
- , bhdPathId = Just pathId
- , bhdPaymentConstraints = Just (PaymentConstraints 750000 50)
- , bhdAllowedFeatures = Just BS.empty
+bp_eve_data :: IO BlindedHopData
+bp_eve_data = do
+ m <- msat 50
+ path_id <- unhex "c9cf92f45ade68345bc20ae672e2012f4af487ed4415"
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 28 0)
+ , bhd_path_id = Just path_id
+ , bhd_payment_constraints = Just (PaymentConstraints 750000 m)
+ , bhd_allowed_features = empty_features
}
--- | Per hop: (key the onion is encrypted to, onion received, payload
--- without length prefix).
-bpRoute :: IO [(BS.ByteString, Secp256k1.Projective, BS.ByteString,
- BS.ByteString)]
-bpRoute = do
- alice <- unhex V.onionNodeKey0
- bob <- unhex V.rbBobNodeKey
- -- Carol, Dave and Eve decrypt with their blinded private keys
- carol <- unhex V.rbCarolBlindedPrivKey
- dave <- unhex V.rbDaveBlindedPrivKey
- eve <- unhex V.rbEveBlindedPrivKey
- mapM (\(k, pub, onion, pl) -> do
- p <- unhexPoint pub
- o <- unhex onion
- body <- unhex pl >>= unprefix
- pure (k, p, o, body))
- [ (alice, V.bpAlicePubKey, V.bpAliceOnion, V.bpAlicePayload)
- , (bob, V.bpBobPubKey, V.bpBobOnion, V.bpBobPayload)
- , (carol, V.bpCarolPubKey, V.bpCarolOnion, V.bpCarolPayload)
- , (dave, V.bpDavePubKey, V.bpDaveOnion, V.bpDavePayload)
- , (eve, V.bpEvePubKey, V.bpEveOnion, V.bpEvePayload)
+-- per hop: node key, public key the onion is encrypted to, onion
+-- received, payload (without its length prefix)
+bp_route
+ :: IO [(SecretKey, BOLT1.Point, BS.ByteString, BS.ByteString)]
+bp_route = mapM hop
+ [ (V.onionNodeKey0, V.bpAlicePubKey, V.bpAliceOnion, V.bpAlicePayload)
+ , (V.rbBobNodeKey, V.bpBobPubKey, V.bpBobOnion, V.bpBobPayload)
+ , (V.rbCarolNodeKey, V.bpCarolPubKey, V.bpCarolOnion, V.bpCarolPayload)
+ , (V.rbDaveNodeKey, V.bpDavePubKey, V.bpDaveOnion, V.bpDavePayload)
+ , (V.rbEveNodeKey, V.bpEvePubKey, V.bpEveOnion, V.bpEvePayload)
]
-
-blindedPaymentTests :: TestTree
-blindedPaymentTests = testGroup "blinded-payment-onion-test.json" [
- testCase "construct reproduces the spec onion" $ do
- route <- bpRoute
- sk <- unhex V.bpSessionKey
- ad <- unhex V.bpAssocData
+ where
+ hop (k, p, o, pl) = (,,,) <$> hex_key k <*> hex_point p <*> unhex o
+ <*> (unhex pl >>= unprefix)
+
+blinded_payment_vectors :: TestTree
+blinded_payment_vectors = testGroup "blinded-payment-onion-test.json" [
+ testCase "construct reproduces the onion" $ do
+ route <- bp_route
+ sk <- hex_key V.bpSessionKey
+ assoc <- unhex V.bpAssocData
+ expected <- unhex V.bpAliceOnion
hops <- mapM (\(_, pub, _, body) -> do
- hp <- demand "decodeHopPayload" (decodeHopPayload body)
- encodeHopPayload hp @?= body
+ hp <- right "decode_hop_payload" (decode_hop_payload body)
+ encode_hop_payload hp @?= Right body
pure (Hop pub hp)) route
- expected <- unhex V.bpAliceOnion
- case construct sk hops ad of
- Left e -> assertFailure ("construct failed: " ++ show e)
- Right (pkt, _) -> encodeOnionPacket pkt @?= expected
-
- , testCase "each hop forwards the spec onion" $ do
- route <- bpRoute
- ad <- unhex V.bpAssocData
- let go [] = assertFailure "no hops"
- go ((k, _, onion, body) : rest) = do
- pkt <- demand "decodeOnionPacket" (decodeOnionPacket onion)
- case (process k pkt ad, rest) of
- (Left e, _) -> assertFailure ("process failed: " ++ show e)
- (Right (Forward fi), (_, _, next, _) : _) -> do
- encodeHopPayload (fiPayload fi) @?= body
- encodeOnionPacket (fiNextPacket fi) @?= next
- go rest
- (Right (Receive ri), []) ->
- encodeHopPayload (riPayload ri) @?= body
- (Right _, _) -> assertFailure "unexpected result"
- go route
-
- , testCase "blinded hops decrypt their data and next path key" $ do
- bobKey <- unhex V.rbBobNodeKey
- carolKey <- unhex V.rbCarolNodeKey
- daveKey <- unhex V.rbDaveNodeKey
- eveKey <- unhex V.rbEveNodeKey
- firstPathKey <- unhexPoint V.rbBobPathKey
- bobNext <- unhexPoint V.bpBobNextPathKey
- carolNext <- unhexPoint V.bpCarolNextPathKey
- daveNext <- unhexPoint V.bpDaveNextPathKey
- eveNext <- unhexPoint V.bpEveNextPathKey
- bobBody <- unhex V.bpBobPayload >>= unprefix
- bobHp <- demand "decodeHopPayload" (decodeHopPayload bobBody)
- hpCurrentPathKey bobHp @?= Just (Secp256k1.serialize_point firstPathKey)
- let encOf pl = do
- body <- unhex pl >>= unprefix
- hp <- demand "decodeHopPayload" (decodeHopPayload body)
- demand "encrypted_recipient_data" (hpEncryptedData hp)
- bobData <- bpBobData
- carolData <- bpCarolData
- daveData <- bpDaveData
- eveData <- bpEveData
- hops <- sequence
- [ (,,,,) bobKey firstPathKey <$> encOf V.bpBobPayload
- <*> pure bobData <*> pure bobNext
- , (,,,,) carolKey bobNext <$> encOf V.bpCarolPayload
- <*> pure carolData <*> pure carolNext
- , (,,,,) daveKey carolNext <$> encOf V.bpDavePayload
- <*> pure daveData <*> pure daveNext
- , (,,,,) eveKey daveNext <$> encOf V.bpEvePayload
- <*> pure eveData <*> pure eveNext
- ]
- mapM_ (\(k, pk, enc, dat, npk) ->
- processBlindedHop k pk enc @?= Right (dat, npk)) hops
+ (pkt, _) <- right "construct" (construct sk hops assoc)
+ encode_onion_packet pkt @?= expected
+ , testCase "the route's payloads" $ do
+ route <- bp_route
+ first_pk <- hex_point V.rbBobPathKey
+ s <- scid 0 0 10
+ (a0, a1, a2) <- three =<< mapM msat [110125, 100000, 150000]
+ payloads <- mapM (\(_, _, _, body) ->
+ right "decode_hop_payload" (decode_hop_payload body)) route
+ case payloads of
+ [alice, bob, carol, dave, eve] -> do
+ alice @?= empty_hop_payload
+ { hp_short_channel_id = Just s, hp_amt_to_forward = Just a0
+ , hp_outgoing_cltv_value = Just 749150 }
+ hp_current_path_key bob @?= Just first_pk
+ forM_ [bob, carol, dave] $ \hp -> do
+ assertBool "encrypted data" (hp_encrypted_data hp /= Nothing)
+ hp { hp_encrypted_data = Nothing
+ , hp_current_path_key = Nothing } @?= empty_hop_payload
+ eve { hp_encrypted_data = Nothing } @?= empty_hop_payload
+ { hp_amt_to_forward = Just a1, hp_total_amount_msat = Just a2
+ , hp_outgoing_cltv_value = Just 749000 }
+ _ -> assertFailure "expected 5 payloads"
+ , testCase "each hop processes its onion" $ do
+ route <- bp_route
+ assoc <- unhex V.bpAssocData
+ datas <- sequence [bp_bob_data, bp_carol_data, bp_dave_data,
+ bp_eve_data]
+ nexts <- mapM hex_point
+ [ V.bpBobNextPathKey, V.bpCarolNextPathKey, V.bpDaveNextPathKey
+ , V.bpEveNextPathKey ]
+ -- (hop, path_key received, expected blinded info)
+ let expect = zip3 route
+ (Nothing : Nothing : map Just (take 3 nexts))
+ (Nothing : map Just (zipWith BlindedInfo datas nexts))
+ go [] = assertFailure "no hops"
+ go [((k, _, onion, body), mpk, binfo)] = do
+ pkt <- right "decode" (decode_onion_packet onion)
+ r <- receive (process k pkt assoc mpk)
+ encode_hop_payload (rcv_payload r) @?= Right body
+ rcv_blinded r @?= binfo
+ go (((k, _, onion, body), mpk, binfo) : rest) = do
+ pkt <- right "decode" (decode_onion_packet onion)
+ f <- forward (process k pkt assoc mpk)
+ encode_hop_payload (fwd_payload f) @?= Right body
+ fwd_blinded f @?= binfo
+ forM_ (take 1 rest) $ \((_, _, next, _), _, _) ->
+ encode_onion_packet (fwd_next_packet f) @?= next
+ go rest
+ go expect
+ ]
+
+-- properties -----------------------------------------------------------------
+
+properties :: TestTree
+properties = testGroup "properties" [
+ testProperty "onion packets round-trip" $
+ forAll gen_onion $ \pkt ->
+ decode_onion_packet (encode_onion_packet pkt) === Right pkt
+ , testProperty "hop payloads round-trip" $
+ forAll gen_hop_payload $ \hp ->
+ fmap decode_hop_payload (encode_hop_payload hp) === Right (Right hp)
+ , testProperty "blinded hop data round-trips" $
+ forAll gen_blinded_hop_data $ \d ->
+ fmap decode_blinded_hop_data (encode_blinded_hop_data d)
+ === Right (Right d)
+ , testProperty "failure messages round-trip" $
+ forAll gen_failure_message $ \fm ->
+ fmap decode_failure_message (encode_failure_message fm)
+ === Right (Right fm)
+ , testProperty "wrap_error is an involution" $
+ forAll gen_secret $ \ss ->
+ forAll (gen_bytes 0 600) $ \bs ->
+ wrap_error ss (wrap_error ss (ErrorPacket bs)) === ErrorPacket bs
+ , testProperty "errors are attributed to the failing hop" $
+ forAll (choose (1, 20)) $ \n ->
+ forAll (vectorOf n gen_secret) $ \sss ->
+ forAll (choose (0, n - 1)) $ \i ->
+ forAll gen_failure_message $ \fm ->
+ case drop i sss of
+ ss : _ | Right pkt <- construct_error ss fm ->
+ unwrap_error sss (foldr wrap_error pkt (take i sss))
+ === Attributed i fm
+ _ -> property False
+ , testProperty "routes of 1 to 20 hops construct and process" $
+ forAll (choose (1, 20)) $ \n ->
+ forAll gen_key $ \sk ->
+ forAll (vectorOf n gen_key) $ \keys ->
+ forAll (vectorOf n (gen_route_payload n)) $ \pls ->
+ route_roundtrip sk (zip keys pls)
+ ]
+
+-- construct an onion over a route, then process it at every hop
+route_roundtrip :: SecretKey -> [(SecretKey, HopPayload)] -> Property
+route_roundtrip sk route =
+ case construct sk [Hop (public_key k) hp | (k, hp) <- route] ad of
+ Left e -> counterexample (show e) False
+ Right (pkt, sss) -> length sss === length route .&&. go route sss pkt
+ where
+ go [(k, hp)] [ss] pkt = case process k pkt ad Nothing of
+ Right (Receive r) ->
+ rcv_payload r === hp .&&. property (rcv_shared_secret r == ss)
+ other -> counterexample (show other) False
+ go ((k, hp) : rest) (ss : sss) pkt = case process k pkt ad Nothing of
+ Right (Forward f) ->
+ fwd_payload f === hp
+ .&&. property (fwd_shared_secret f == ss)
+ .&&. go rest sss (fwd_next_packet f)
+ other -> counterexample (show other) False
+ go _ _ _ = property False
+
+-- generators -----------------------------------------------------------------
+
+gen_bytes :: Int -> Int -> Gen BS.ByteString
+gen_bytes lo hi = do
+ n <- choose (lo, hi)
+ BS.pack <$> vectorOf n arbitrary
+
+gen_key :: Gen SecretKey
+gen_key = gen_bytes 32 32 `suchThatMap` secret_key
+
+gen_secret :: Gen SharedSecret
+gen_secret = gen_bytes 32 32 `suchThatMap` shared_secret
+
+gen_point :: Gen BOLT1.Point
+gen_point = do
+ prefix <- elements [0x02, 0x03]
+ x <- gen_bytes 32 32
+ pure (BS.cons prefix x) `suchThatMap` BOLT1.point
+
+gen_msat :: Gen BOLT1.MilliSatoshi
+gen_msat = oneof
+ [ choose (0, 0xffff), choose (0, BOLT1.un_milli_satoshi
+ BOLT1.max_milli_satoshi) ]
+ `suchThatMap` BOLT1.milli_satoshi
+
+gen_scid :: Gen BOLT1.ShortChannelId
+gen_scid = BOLT1.ShortChannelId <$> arbitrary
+
+gen_maybe :: Gen a -> Gen (Maybe a)
+gen_maybe g = oneof [pure Nothing, Just <$> g]
+
+-- extra records with odd types not in the given list
+gen_extra :: [Word64] -> Gen BOLT1.TlvStream
+gen_extra known = do
+ n <- choose (0, 3)
+ ts <- vectorOf n (oneof [choose (1, 300), choose (65536, 70000)])
+ recs <- mapM (\t -> BOLT1.TlvRecord t <$> gen_bytes 0 20)
+ [ t | t <- ts, odd t, t `notElem` known ]
+ let uniq = nubBy (\a b -> BOLT1.tlv_type a == BOLT1.tlv_type b) recs
+ pure uniq `suchThatMap` BOLT1.tlv_stream
+
+gen_onion :: Gen OnionPacket
+gen_onion = OnionPacket
+ <$> arbitrary
+ <*> gen_point
+ <*> (gen_bytes 1300 1300 `suchThatMap` hop_payloads)
+ <*> (gen_bytes 32 32 `suchThatMap` hmac32)
+
+gen_hop_payload :: Gen HopPayload
+gen_hop_payload = HopPayload
+ <$> gen_maybe gen_msat
+ <*> gen_maybe arbitrary
+ <*> gen_maybe gen_scid
+ <*> gen_maybe (PaymentData
+ <$> (gen_bytes 32 32 `suchThatMap` payment_secret)
+ <*> gen_msat)
+ <*> gen_maybe (gen_bytes 0 50)
+ <*> gen_maybe gen_point
+ <*> gen_maybe (gen_bytes 0 50)
+ <*> gen_maybe gen_msat
+ <*> gen_extra []
+
+gen_blinded_hop_data :: Gen BlindedHopData
+gen_blinded_hop_data = BlindedHopData
+ <$> gen_maybe (gen_bytes 0 40)
+ <*> gen_maybe gen_scid
+ <*> gen_maybe gen_point
+ <*> gen_maybe (gen_bytes 0 40)
+ <*> gen_maybe gen_point
+ <*> gen_maybe (PaymentRelay <$> arbitrary <*> arbitrary <*> arbitrary)
+ <*> gen_maybe (PaymentConstraints <$> arbitrary <*> gen_msat)
+ <*> gen_maybe (BOLT9.parse <$> gen_bytes 0 8)
+ <*> gen_extra [1]
+
+gen_failure_message :: Gen FailureMessage
+gen_failure_message = do
+ f <- gen_failure
+ ex <- case f of
+ -- these take every byte after the code, or may be ambiguous with a
+ -- TLV stream
+ UnknownFailure _ _ -> pure no_tlvs
+ InvalidOnionPayload Nothing -> pure no_tlvs
+ _ -> gen_extra []
+ pure (FailureMessage f ex)
+
+gen_failure :: Gen Failure
+gen_failure = oneof
+ [ pure TemporaryNodeFailure
+ , pure PermanentNodeFailure
+ , pure RequiredNodeFeatureMissing
+ , InvalidOnionVersion <$> hash
+ , InvalidOnionHmac <$> hash
+ , InvalidOnionKey <$> hash
+ , TemporaryChannelFailure <$> update
+ , pure PermanentChannelFailure
+ , pure RequiredChannelFeatureMissing
+ , pure UnknownNextPeer
+ , AmountBelowMinimum <$> gen_msat <*> update
+ , FeeInsufficient <$> gen_msat <*> update
+ , IncorrectCltvExpiry <$> arbitrary <*> update
+ , ExpiryTooSoon <$> update
+ , IncorrectOrUnknownPaymentDetails <$> gen_msat <*> arbitrary
+ , FinalIncorrectCltvExpiry <$> arbitrary
+ , FinalIncorrectHtlcAmount <$> gen_msat
+ , ChannelDisabled <$> arbitrary <*> update
+ , pure ExpiryTooFar
+ , InvalidOnionPayload <$> gen_maybe ((,) <$> arbitrary <*> arbitrary)
+ , pure MppTimeout
+ , InvalidOnionBlinding <$> hash
+ , UnknownFailure <$> (arbitrary `suchThat` unknown) <*> gen_bytes 0 20
]
+ where
+ hash = gen_bytes 32 32 `suchThatMap` onion_hash
+ update = gen_bytes 0 100
+ unknown c = c `notElem`
+ [ 0x2002, 0x6002, 0x6003, 0xc004, 0xc005, 0xc006, 0x1007, 0x4008
+ , 0x4009, 0x400a, 0x100b, 0x100c, 0x100d, 0x100e, 0x400f, 0x0012
+ , 0x0013, 0x1014, 0x0015, 0x4016, 0x0017, 0xc018 ]
+
+-- a payload whose shift size fits n hops in 1300 bytes
+--
+-- The typed fields take at most 26 bytes; an odd record of type 65537
+-- adds at most 8 bytes of framing plus its value. With a 3-byte length
+-- prefix and 32-byte HMAC a hop then shifts at most 69 bytes plus the
+-- value's length.
+gen_route_payload :: Int -> Gen HopPayload
+gen_route_payload n = do
+ amt <- gen_msat
+ cltv <- arbitrary
+ s <- gen_maybe gen_scid
+ let budget = 1300 `div` n - 69
+ ex <- if budget < 0
+ then pure no_tlvs
+ else do
+ v <- gen_bytes 0 budget
+ pure (BOLT1.TlvRecord 65537 v : [])
+ `suchThatMap` BOLT1.tlv_stream
+ pure empty_hop_payload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just cltv
+ , hp_short_channel_id = s
+ , hp_extra = ex
+ }
