commit cd8aa074cac8d4144a1e30868fe639de29d8ae35
parent 6f3327fe2856fded5511e8f8db21a44361d4c8c5
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 25 Jan 2026 15:39:03 +0400
ppad-bolt4: implement packet construction (IMPL3)
Add Construct module for BOLT4 onion packet construction:
- Hop type for route specification
- construct function for creating onion packets
- Shared secret computation with ephemeral key blinding
- Filler generation for constant-size packets
- Payload wrapping with ChaCha20 obfuscation
Includes test vectors from BOLT4 specification.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
Diffstat:
3 files changed, 365 insertions(+), 0 deletions(-)
diff --git a/lib/Lightning/Protocol/BOLT4/Construct.hs b/lib/Lightning/Protocol/BOLT4/Construct.hs
@@ -0,0 +1,212 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Lightning.Protocol.BOLT4.Construct
+-- Copyright: (c) 2025 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- Onion packet construction for BOLT4.
+
+module Lightning.Protocol.BOLT4.Construct (
+ -- * Types
+ Hop(..)
+ , Error(..)
+
+ -- * Packet construction
+ , construct
+ ) where
+
+import Data.Bits (xor)
+import qualified Crypto.Curve.Secp256k1 as Secp256k1
+import qualified Data.ByteString as BS
+import Lightning.Protocol.BOLT4.Codec
+import Lightning.Protocol.BOLT4.Prim
+import Lightning.Protocol.BOLT4.Types
+
+-- | Route information for a single hop.
+data Hop = Hop
+ { hopPubKey :: !Secp256k1.Projective -- ^ node's public key
+ , hopPayload :: !HopPayload -- ^ routing data for this hop
+ } deriving (Eq, Show)
+
+-- | Errors during packet construction.
+data Error
+ = InvalidSessionKey
+ | EmptyRoute
+ | TooManyHops
+ | PayloadTooLarge !Int
+ | InvalidHopPubKey !Int
+ deriving (Eq, Show)
+
+-- | Maximum number of hops in a route.
+maxHops :: Int
+maxHops = 20
+{-# INLINE maxHops #-}
+
+-- | Construct an onion packet for a payment route.
+--
+-- Takes a session key (32 bytes random), list of hops, and associated
+-- data (typically payment_hash).
+--
+-- Returns the onion packet and list of shared secrets (for error
+-- attribution).
+construct
+ :: BS.ByteString -- ^ 32-byte session key (random)
+ -> [Hop] -- ^ route (first hop to final destination)
+ -> BS.ByteString -- ^ associated data
+ -> Either Error (OnionPacket, [SharedSecret])
+construct !sessionKey !hops !assocData
+ | BS.length sessionKey /= 32 = Left InvalidSessionKey
+ | null hops = Left EmptyRoute
+ | length hops > maxHops = Left TooManyHops
+ | otherwise = do
+ -- Initialize ephemeral keypair from session key
+ ephSec <- maybe (Left InvalidSessionKey) Right
+ (Secp256k1.roll32 sessionKey)
+ ephPub <- maybe (Left InvalidSessionKey) Right
+ (Secp256k1.derive_pub ephSec)
+
+ -- Compute shared secrets and blinding factors for all hops
+ let hopPubKeys = map hopPubKey hops
+ (secrets, _) <- computeAllSecrets sessionKey ephPub hopPubKeys
+
+ -- Validate payload sizes
+ let payloadBytes = map (encodeHopPayload . hopPayload) hops
+ payloadSizes = map payloadShiftSize payloadBytes
+ totalSize = sum payloadSizes
+ if totalSize > hopPayloadsSize
+ then Left (PayloadTooLarge totalSize)
+ else do
+ -- Generate filler using secrets for all but final hop
+ let numHops = length hops
+ secretsExceptFinal = take (numHops - 1) secrets
+ sizesExceptFinal = take (numHops - 1) payloadSizes
+ filler = generateFiller secretsExceptFinal sizesExceptFinal
+
+ -- Initialize hop_payloads with deterministic padding
+ let DerivedKey padKey = derivePad (SharedSecret sessionKey)
+ initialPayloads = generateStream (DerivedKey padKey)
+ hopPayloadsSize
+
+ -- Wrap payloads in reverse order (final hop first)
+ let (finalPayloads, finalHmac) = wrapAllHops
+ secrets payloadBytes filler assocData initialPayloads
+
+ -- Build the final packet
+ let ephPubBytes = Secp256k1.serialize_point ephPub
+ packet = OnionPacket
+ { opVersion = versionByte
+ , opEphemeralKey = ephPubBytes
+ , opHopPayloads = finalPayloads
+ , opHmac = finalHmac
+ }
+
+ Right (packet, secrets)
+
+-- | Compute the total shift size for a payload.
+payloadShiftSize :: BS.ByteString -> Int
+payloadShiftSize !payload =
+ let !len = BS.length payload
+ !bsLen = bigSizeLen (fromIntegral len)
+ in bsLen + len + hmacSize
+{-# INLINE payloadShiftSize #-}
+
+-- | Compute shared secrets for all hops.
+computeAllSecrets
+ :: BS.ByteString
+ -> Secp256k1.Projective
+ -> [Secp256k1.Projective]
+ -> Either Error ([SharedSecret], Secp256k1.Projective)
+computeAllSecrets !initSec !initPub = go initSec initPub 0 []
+ where
+ go !_ephSec !ephPub !_ !acc [] = Right (reverse acc, ephPub)
+ go !ephSec !ephPub !idx !acc (hopPub:rest) = do
+ ss <- maybe (Left (InvalidHopPubKey idx)) Right
+ (computeSharedSecret ephSec hopPub)
+ let !bf = computeBlindingFactor ephPub ss
+ newEphSec <- maybe (Left (InvalidHopPubKey idx)) Right
+ (blindSecKey ephSec bf)
+ newEphPub <- maybe (Left (InvalidHopPubKey idx)) Right
+ (blindPubKey ephPub bf)
+ go newEphSec newEphPub (idx + 1) (ss : acc) rest
+
+-- | Generate filler bytes.
+generateFiller :: [SharedSecret] -> [Int] -> BS.ByteString
+generateFiller !secrets !sizes = go BS.empty secrets sizes
+ where
+ go !filler [] [] = filler
+ go !filler (ss:sss) (sz:szs) =
+ let !extended = filler <> BS.replicate sz 0
+ !rhoKey = deriveRho ss
+ !stream = generateStream rhoKey (2 * hopPayloadsSize)
+ !streamOffset = hopPayloadsSize
+ !streamPart = BS.take (BS.length extended)
+ (BS.drop streamOffset stream)
+ !newFiller = xorBytes extended streamPart
+ in go newFiller sss szs
+ go !filler _ _ = filler
+{-# INLINE generateFiller #-}
+
+-- | Wrap all hops in reverse order.
+wrapAllHops
+ :: [SharedSecret]
+ -> [BS.ByteString]
+ -> BS.ByteString
+ -> BS.ByteString
+ -> BS.ByteString
+ -> (BS.ByteString, BS.ByteString)
+wrapAllHops !secrets !payloads !filler !assocData !initPayloads =
+ let !paired = reverse (zip secrets payloads)
+ !numHops = length paired
+ !initHmac = BS.replicate hmacSize 0
+ in go numHops initPayloads initHmac paired
+ where
+ go !_ !hopPayloads !hmac [] = (hopPayloads, hmac)
+ go !remaining !hopPayloads !hmac ((ss, payload):rest) =
+ let !isLastHop = remaining == length (reverse (zip secrets payloads))
+ (!newPayloads, !newHmac) = wrapHop ss payload hmac hopPayloads
+ assocData filler isLastHop
+ in go (remaining - 1) newPayloads newHmac rest
+
+-- | Wrap a single hop's payload.
+wrapHop
+ :: SharedSecret
+ -> BS.ByteString
+ -> BS.ByteString
+ -> BS.ByteString
+ -> BS.ByteString
+ -> BS.ByteString
+ -> Bool
+ -> (BS.ByteString, BS.ByteString)
+wrapHop !ss !payload !hmac !hopPayloads !assocData !filler !isFinalHop =
+ let !payloadLen = BS.length payload
+ !lenBytes = encodeBigSize (fromIntegral payloadLen)
+ !shiftSize = BS.length lenBytes + payloadLen + hmacSize
+ !shifted = BS.take (hopPayloadsSize - shiftSize) hopPayloads
+ !prepended = lenBytes <> payload <> hmac <> shifted
+ !rhoKey = deriveRho ss
+ !stream = generateStream rhoKey hopPayloadsSize
+ !obfuscated = xorBytes prepended stream
+ !withFiller = if isFinalHop && not (BS.null filler)
+ then applyFiller obfuscated filler
+ else obfuscated
+ !muKey = deriveMu ss
+ !newHmac = computeHmac muKey withFiller assocData
+ in (withFiller, newHmac)
+{-# INLINE wrapHop #-}
+
+-- | Apply filler to the tail of hop_payloads.
+applyFiller :: BS.ByteString -> BS.ByteString -> BS.ByteString
+applyFiller !hopPayloads !filler =
+ let !fillerLen = BS.length filler
+ !prefix = BS.take (hopPayloadsSize - fillerLen) hopPayloads
+ in prefix <> filler
+{-# INLINE applyFiller #-}
+
+-- | XOR two ByteStrings.
+xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString
+xorBytes !a !b = BS.pack $ BS.zipWith xor a b
+{-# INLINE xorBytes #-}
diff --git a/ppad-bolt4.cabal b/ppad-bolt4.cabal
@@ -25,6 +25,7 @@ library
exposed-modules:
Lightning.Protocol.BOLT4
Lightning.Protocol.BOLT4.Codec
+ Lightning.Protocol.BOLT4.Construct
Lightning.Protocol.BOLT4.Prim
Lightning.Protocol.BOLT4.Types
build-depends:
diff --git a/test/Main.hs b/test/Main.hs
@@ -6,6 +6,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Crypto.Curve.Secp256k1 as Secp256k1
import Lightning.Protocol.BOLT4.Codec
+import Lightning.Protocol.BOLT4.Construct
import Lightning.Protocol.BOLT4.Prim
import Lightning.Protocol.BOLT4.Types
import Test.Tasty
@@ -30,6 +31,9 @@ main = defaultMain $ testGroup "ppad-bolt4" [
, testGroup "OnionPacket" [
onionPacketTests
]
+ , testGroup "Construct" [
+ constructTests
+ ]
]
-- BigSize tests ------------------------------------------------------------
@@ -321,3 +325,151 @@ testHmacOperations = testGroup "HMAC operations" [
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 (in route order)
+hop1SharedSecretHex :: BS.ByteString
+hop1SharedSecretHex =
+ "a6519e98832a0b179f62123b3567c106db99ee37bef036e783263602f3488fae"
+
+hop2SharedSecretHex :: BS.ByteString
+hop2SharedSecretHex =
+ "3a6b412548762f0dbccce5c7ae7bb8147d1caf9b5471c34120b30bc9c04891cc"
+
+hop3SharedSecretHex :: BS.ByteString
+hop3SharedSecretHex =
+ "21e13c2d7cfe7e18836df50872466117a295783ab8aab0e7ecc8c725503ad02d"
+
+hop4SharedSecretHex :: BS.ByteString
+hop4SharedSecretHex =
+ "b5756b9b542727dbafc6765a49488b023a725d631af688fc031217e90770c328"
+
+constructTests :: TestTree
+constructTests = testGroup "packet construction" [
+ testConstructErrorCases
+ , testSharedSecretComputation
+ , testPacketStructure
+ , testSingleHop
+ ]
+
+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
+ let Just pub = Secp256k1.parse_point (fromHex hop0PubKeyHex)
+ 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"
+ ]
+
+testSharedSecretComputation :: TestTree
+testSharedSecretComputation =
+ testCase "computes correct shared secrets (BOLT4 spec)" $ do
+ let Just pub0 = Secp256k1.parse_point (fromHex hop0PubKeyHex)
+ Just pub1 = Secp256k1.parse_point (fromHex hop1PubKeyHex)
+ Just pub2 = Secp256k1.parse_point (fromHex hop2PubKeyHex)
+ Just pub3 = Secp256k1.parse_point (fromHex hop3PubKeyHex)
+ Just pub4 = Secp256k1.parse_point (fromHex hop4PubKeyHex)
+ emptyPayload = HopPayload Nothing Nothing Nothing Nothing
+ Nothing Nothing []
+ hops = [ Hop pub0 emptyPayload
+ , Hop pub1 emptyPayload
+ , Hop pub2 emptyPayload
+ , Hop pub3 emptyPayload
+ , Hop pub4 emptyPayload
+ ]
+ result = construct sessionKey hops ""
+ case result of
+ Left err -> assertFailure $ "construct failed: " ++ show err
+ Right (_, secrets) -> do
+ length secrets @?= 5
+ let [SharedSecret ss0, SharedSecret ss1, SharedSecret ss2,
+ SharedSecret ss3, SharedSecret ss4] = secrets
+ ss0 @?= fromHex hop0SharedSecretHex
+ ss1 @?= fromHex hop1SharedSecretHex
+ ss2 @?= fromHex hop2SharedSecretHex
+ ss3 @?= fromHex hop3SharedSecretHex
+ ss4 @?= fromHex hop4SharedSecretHex
+
+testPacketStructure :: TestTree
+testPacketStructure = testCase "produces valid packet structure" $ do
+ let Just pub0 = Secp256k1.parse_point (fromHex hop0PubKeyHex)
+ Just pub1 = Secp256k1.parse_point (fromHex hop1PubKeyHex)
+ emptyPayload = HopPayload Nothing Nothing Nothing Nothing
+ Nothing Nothing []
+ hops = [Hop pub0 emptyPayload, Hop pub1 emptyPayload]
+ 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 (opHopPayloads packet) @?= hopPayloadsSize
+ BS.length (opHmac packet) @?= hmacSize
+ -- The ephemeral key should be the public key derived from session key
+ let Just sk = Secp256k1.roll32 sessionKey
+ Just expectedPub = Secp256k1.derive_pub sk
+ expectedPubBytes = Secp256k1.serialize_point expectedPub
+ opEphemeralKey packet @?= expectedPubBytes
+
+testSingleHop :: TestTree
+testSingleHop = testCase "constructs single-hop packet" $ do
+ let Just pub0 = Secp256k1.parse_point (fromHex hop0PubKeyHex)
+ 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
+ let Just decoded = decodeOnionPacket encoded
+ decoded @?= packet
