Construct.hs (7593B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE OverloadedStrings #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT4.Construct 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Onion packet construction for BOLT4. 12 13 module Lightning.Protocol.BOLT4.Construct ( 14 -- * Types 15 Hop(..) 16 , Error(..) 17 18 -- * Packet construction 19 , construct 20 ) where 21 22 import Data.Bits (xor) 23 import qualified Crypto.Curve.Secp256k1 as Secp256k1 24 import qualified Data.ByteString as BS 25 import Lightning.Protocol.BOLT4.Codec 26 import Lightning.Protocol.BOLT4.Prim 27 import Lightning.Protocol.BOLT4.Types 28 29 -- | Route information for a single hop. 30 data Hop = Hop 31 { hopPubKey :: !Secp256k1.Projective -- ^ node's public key 32 , hopPayload :: !HopPayload -- ^ routing data for this hop 33 } deriving (Eq, Show) 34 35 -- | Errors during packet construction. 36 data Error 37 = InvalidSessionKey 38 | EmptyRoute 39 | TooManyHops 40 | PayloadTooLarge !Int 41 | InvalidHopPubKey !Int 42 deriving (Eq, Show) 43 44 -- | Maximum number of hops in a route. 45 maxHops :: Int 46 maxHops = 20 47 {-# INLINE maxHops #-} 48 49 -- | Construct an onion packet for a payment route. 50 -- 51 -- Takes a session key (32 bytes random), list of hops, and associated 52 -- data (typically payment_hash). 53 -- 54 -- Returns the onion packet and list of shared secrets (for error 55 -- attribution). 56 construct 57 :: BS.ByteString -- ^ 32-byte session key (random) 58 -> [Hop] -- ^ route (first hop to final destination) 59 -> BS.ByteString -- ^ associated data 60 -> Either Error (OnionPacket, [SharedSecret]) 61 construct !sessionKey !hops !assocData 62 | BS.length sessionKey /= 32 = Left InvalidSessionKey 63 | null hops = Left EmptyRoute 64 | length hops > maxHops = Left TooManyHops 65 | otherwise = do 66 -- Initialize ephemeral keypair from session key 67 ephSec <- maybe (Left InvalidSessionKey) Right 68 (Secp256k1.roll32 sessionKey) 69 ephPub <- maybe (Left InvalidSessionKey) Right 70 (Secp256k1.derive_pub ephSec) 71 72 -- Compute shared secrets and blinding factors for all hops 73 let hopPubKeys = map hopPubKey hops 74 (secrets, _) <- computeAllSecrets sessionKey ephPub hopPubKeys 75 76 -- Validate payload sizes 77 let payloadBytes = map (encodeHopPayload . hopPayload) hops 78 payloadSizes = map payloadShiftSize payloadBytes 79 totalSize = sum payloadSizes 80 if totalSize > hopPayloadsSize 81 then Left (PayloadTooLarge totalSize) 82 else do 83 -- Generate filler using secrets for all but final hop 84 let numHops = length hops 85 secretsExceptFinal = take (numHops - 1) secrets 86 sizesExceptFinal = take (numHops - 1) payloadSizes 87 filler = generateFiller secretsExceptFinal sizesExceptFinal 88 89 -- Initialize hop_payloads with deterministic padding 90 let DerivedKey padKey = derivePad (SharedSecret sessionKey) 91 initialPayloads = generateStream (DerivedKey padKey) 92 hopPayloadsSize 93 94 -- Wrap payloads in reverse order (final hop first) 95 let (finalPayloads, finalHmac) = wrapAllHops 96 secrets payloadBytes filler assocData initialPayloads 97 98 -- Build the final packet 99 let ephPubBytes = Secp256k1.serialize_point ephPub 100 packet = OnionPacket 101 { opVersion = versionByte 102 , opEphemeralKey = ephPubBytes 103 , opHopPayloads = finalPayloads 104 , opHmac = finalHmac 105 } 106 107 Right (packet, secrets) 108 109 -- | Compute the total shift size for a payload. 110 payloadShiftSize :: BS.ByteString -> Int 111 payloadShiftSize !payload = 112 let !len = BS.length payload 113 !bsLen = bigSizeLen (fromIntegral len) 114 in bsLen + len + hmacSize 115 {-# INLINE payloadShiftSize #-} 116 117 -- | Compute shared secrets for all hops. 118 computeAllSecrets 119 :: BS.ByteString 120 -> Secp256k1.Projective 121 -> [Secp256k1.Projective] 122 -> Either Error ([SharedSecret], Secp256k1.Projective) 123 computeAllSecrets !initSec !initPub = go initSec initPub 0 [] 124 where 125 go !_ephSec !ephPub !_ !acc [] = Right (reverse acc, ephPub) 126 go !ephSec !ephPub !idx !acc (hopPub:rest) = do 127 ss <- maybe (Left (InvalidHopPubKey idx)) Right 128 (computeSharedSecret ephSec hopPub) 129 let !bf = computeBlindingFactor ephPub ss 130 newEphSec <- maybe (Left (InvalidHopPubKey idx)) Right 131 (blindSecKey ephSec bf) 132 newEphPub <- maybe (Left (InvalidHopPubKey idx)) Right 133 (blindPubKey ephPub bf) 134 go newEphSec newEphPub (idx + 1) (ss : acc) rest 135 136 -- | Generate filler bytes. 137 generateFiller :: [SharedSecret] -> [Int] -> BS.ByteString 138 generateFiller !secrets !sizes = go BS.empty secrets sizes 139 where 140 go !filler [] [] = filler 141 go !filler (ss:sss) (sz:szs) = 142 let !extended = filler <> BS.replicate sz 0 143 !rhoKey = deriveRho ss 144 !stream = generateStream rhoKey (2 * hopPayloadsSize) 145 !streamOffset = hopPayloadsSize 146 !streamPart = BS.take (BS.length extended) 147 (BS.drop streamOffset stream) 148 !newFiller = xorBytes extended streamPart 149 in go newFiller sss szs 150 go !filler _ _ = filler 151 {-# INLINE generateFiller #-} 152 153 -- | Wrap all hops in reverse order. 154 wrapAllHops 155 :: [SharedSecret] 156 -> [BS.ByteString] 157 -> BS.ByteString 158 -> BS.ByteString 159 -> BS.ByteString 160 -> (BS.ByteString, BS.ByteString) 161 wrapAllHops !secrets !payloads !filler !assocData !initPayloads = 162 let !paired = reverse (zip secrets payloads) 163 !numHops = length paired 164 !initHmac = BS.replicate hmacSize 0 165 in go numHops initPayloads initHmac paired 166 where 167 go !_ !hopPayloads !hmac [] = (hopPayloads, hmac) 168 go !remaining !hopPayloads !hmac ((ss, payload):rest) = 169 let !isLastHop = remaining == length (reverse (zip secrets payloads)) 170 (!newPayloads, !newHmac) = wrapHop ss payload hmac hopPayloads 171 assocData filler isLastHop 172 in go (remaining - 1) newPayloads newHmac rest 173 174 -- | Wrap a single hop's payload. 175 wrapHop 176 :: SharedSecret 177 -> BS.ByteString 178 -> BS.ByteString 179 -> BS.ByteString 180 -> BS.ByteString 181 -> BS.ByteString 182 -> Bool 183 -> (BS.ByteString, BS.ByteString) 184 wrapHop !ss !payload !hmac !hopPayloads !assocData !filler !isFinalHop = 185 let !payloadLen = BS.length payload 186 !lenBytes = encodeBigSize (fromIntegral payloadLen) 187 !shiftSize = BS.length lenBytes + payloadLen + hmacSize 188 !shifted = BS.take (hopPayloadsSize - shiftSize) hopPayloads 189 !prepended = lenBytes <> payload <> hmac <> shifted 190 !rhoKey = deriveRho ss 191 !stream = generateStream rhoKey hopPayloadsSize 192 !obfuscated = xorBytes prepended stream 193 !withFiller = if isFinalHop && not (BS.null filler) 194 then applyFiller obfuscated filler 195 else obfuscated 196 !muKey = deriveMu ss 197 !newHmac = computeHmac muKey withFiller assocData 198 in (withFiller, newHmac) 199 {-# INLINE wrapHop #-} 200 201 -- | Apply filler to the tail of hop_payloads. 202 applyFiller :: BS.ByteString -> BS.ByteString -> BS.ByteString 203 applyFiller !hopPayloads !filler = 204 let !fillerLen = BS.length filler 205 !prefix = BS.take (hopPayloadsSize - fillerLen) hopPayloads 206 in prefix <> filler 207 {-# INLINE applyFiller #-} 208 209 -- | XOR two ByteStrings. 210 xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString 211 xorBytes !a !b = BS.pack $ BS.zipWith xor a b 212 {-# INLINE xorBytes #-}