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