Blinding.hs (14747B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE OverloadedStrings #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT4.Blinding 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Route blinding for BOLT4 onion routing. 12 13 module Lightning.Protocol.BOLT4.Blinding ( 14 -- * Types 15 BlindedPath(..) 16 , BlindedHop(..) 17 , BlindedHopData(..) 18 , PaymentRelay(..) 19 , PaymentConstraints(..) 20 , BlindingError(..) 21 22 -- * Path creation 23 , createBlindedPath 24 25 -- * Hop processing 26 , processBlindedHop 27 28 -- * Key derivation (exported for testing) 29 , deriveBlindingRho 30 , deriveBlindedNodeId 31 , nextEphemeral 32 33 -- * TLV encoding (exported for testing) 34 , encodeBlindedHopData 35 , decodeBlindedHopData 36 37 -- * Encryption (exported for testing) 38 , encryptHopData 39 , decryptHopData 40 ) where 41 42 import qualified Crypto.AEAD.ChaCha20Poly1305 as AEAD 43 import qualified Crypto.Curve.Secp256k1 as Secp256k1 44 import qualified Crypto.Hash.SHA256 as SHA256 45 import qualified Data.ByteString as BS 46 import qualified Data.ByteString.Builder as B 47 import Data.Word (Word16, Word32, Word64) 48 import qualified Numeric.Montgomery.Secp256k1.Scalar as S 49 import Lightning.Protocol.BOLT4.Codec 50 ( encodeShortChannelId, decodeShortChannelId 51 , encodeTlvStream, decodeTlvStream 52 , toStrict, word16BE, word32BE 53 , encodeWord64TU, decodeWord64TU 54 , encodeWord32TU, decodeWord32TU 55 ) 56 import Lightning.Protocol.BOLT4.Prim (SharedSecret(..), DerivedKey(..)) 57 import Lightning.Protocol.BOLT4.Types (ShortChannelId(..), TlvRecord(..)) 58 59 -- Types --------------------------------------------------------------------- 60 61 -- | A blinded route provided by recipient. 62 data BlindedPath = BlindedPath 63 { bpIntroductionNode :: !Secp256k1.Projective -- ^ First node (unblinded) 64 , bpBlindingKey :: !Secp256k1.Projective -- ^ E_0, initial ephemeral 65 , bpBlindedHops :: ![BlindedHop] 66 } deriving (Eq, Show) 67 68 -- | A single hop in a blinded path. 69 data BlindedHop = BlindedHop 70 { bhBlindedNodeId :: !BS.ByteString -- ^ 33 bytes, blinded pubkey 71 , bhEncryptedData :: !BS.ByteString -- ^ Encrypted routing data 72 } deriving (Eq, Show) 73 74 -- | Data encrypted for each blinded hop (before encryption). 75 data BlindedHopData = BlindedHopData 76 { bhdPadding :: !(Maybe BS.ByteString) -- ^ TLV 1 77 , bhdShortChannelId :: !(Maybe ShortChannelId) -- ^ TLV 2 78 , bhdNextNodeId :: !(Maybe BS.ByteString) -- ^ TLV 4, 33-byte pubkey 79 , bhdPathId :: !(Maybe BS.ByteString) -- ^ TLV 6 80 , bhdNextPathKeyOverride :: !(Maybe BS.ByteString) -- ^ TLV 8 81 , bhdPaymentRelay :: !(Maybe PaymentRelay) -- ^ TLV 10 82 , bhdPaymentConstraints :: !(Maybe PaymentConstraints) -- ^ TLV 12 83 , bhdAllowedFeatures :: !(Maybe BS.ByteString) -- ^ TLV 14 84 } deriving (Eq, Show) 85 86 -- | Payment relay parameters (TLV 10). 87 data PaymentRelay = PaymentRelay 88 { prCltvExpiryDelta :: {-# UNPACK #-} !Word16 89 , prFeeProportional :: {-# UNPACK #-} !Word32 -- ^ Fee in millionths 90 , prFeeBaseMsat :: {-# UNPACK #-} !Word32 91 } deriving (Eq, Show) 92 93 -- | Payment constraints (TLV 12). 94 data PaymentConstraints = PaymentConstraints 95 { pcMaxCltvExpiry :: {-# UNPACK #-} !Word32 96 , pcHtlcMinimumMsat :: {-# UNPACK #-} !Word64 97 } deriving (Eq, Show) 98 99 -- | Errors during blinding operations. 100 data BlindingError 101 = InvalidSeed 102 | EmptyPath 103 | InvalidNodeKey Int 104 | DecryptionFailed 105 | InvalidPathKey 106 deriving (Eq, Show) 107 108 -- Key derivation ------------------------------------------------------------ 109 110 -- | Derive rho key for encrypting hop data. 111 -- 112 -- @rho = HMAC-SHA256(key="rho", data=shared_secret)@ 113 deriveBlindingRho :: SharedSecret -> DerivedKey 114 deriveBlindingRho (SharedSecret !ss) = 115 let SHA256.MAC !result = SHA256.hmac "rho" ss 116 in DerivedKey result 117 {-# INLINE deriveBlindingRho #-} 118 119 -- | Derive blinded node ID from shared secret and node pubkey. 120 -- 121 -- @B_i = HMAC256("blinded_node_id", ss_i) * N_i@ 122 deriveBlindedNodeId 123 :: SharedSecret 124 -> Secp256k1.Projective 125 -> Maybe BS.ByteString 126 deriveBlindedNodeId (SharedSecret !ss) !nodePub = do 127 let SHA256.MAC !hmacResult = SHA256.hmac "blinded_node_id" ss 128 sk <- Secp256k1.roll32 hmacResult 129 blindedPub <- Secp256k1.mul nodePub sk 130 pure $! Secp256k1.serialize_point blindedPub 131 {-# INLINE deriveBlindedNodeId #-} 132 133 -- | Compute next ephemeral key pair. 134 -- 135 -- @e_{i+1} = SHA256(E_i || ss_i) * e_i@ 136 -- @E_{i+1} = SHA256(E_i || ss_i) * E_i@ 137 nextEphemeral 138 :: BS.ByteString -- ^ e_i (32-byte secret key) 139 -> Secp256k1.Projective -- ^ E_i 140 -> SharedSecret -- ^ ss_i 141 -> Maybe (BS.ByteString, Secp256k1.Projective) -- ^ (e_{i+1}, E_{i+1}) 142 nextEphemeral !secKey !pubKey (SharedSecret !ss) = do 143 let !pubBytes = Secp256k1.serialize_point pubKey 144 !blindingFactor = SHA256.hash (pubBytes <> ss) 145 bfInt <- Secp256k1.roll32 blindingFactor 146 -- Compute e_{i+1} = e_i * blindingFactor (mod q) 147 let !newSecKey = mulSecKey secKey blindingFactor 148 -- Compute E_{i+1} = E_i * blindingFactor 149 newPubKey <- Secp256k1.mul pubKey bfInt 150 pure (newSecKey, newPubKey) 151 {-# INLINE nextEphemeral #-} 152 153 -- | Compute blinding factor for next path key (public key only). 154 nextPathKey 155 :: Secp256k1.Projective -- ^ E_i 156 -> SharedSecret -- ^ ss_i 157 -> Maybe Secp256k1.Projective -- ^ E_{i+1} 158 nextPathKey !pubKey (SharedSecret !ss) = do 159 let !pubBytes = Secp256k1.serialize_point pubKey 160 !blindingFactor = SHA256.hash (pubBytes <> ss) 161 bfInt <- Secp256k1.roll32 blindingFactor 162 Secp256k1.mul pubKey bfInt 163 {-# INLINE nextPathKey #-} 164 165 -- Encryption/Decryption ----------------------------------------------------- 166 167 -- | Encrypt hop data with ChaCha20-Poly1305. 168 -- 169 -- Uses rho key and 12-byte zero nonce, empty AAD. 170 encryptHopData :: DerivedKey -> BlindedHopData -> BS.ByteString 171 encryptHopData (DerivedKey !rho) !hopData = 172 let !plaintext = encodeBlindedHopData hopData 173 !nonce = BS.replicate 12 0 174 in case AEAD.encrypt BS.empty rho nonce plaintext of 175 Left e -> error $ "encryptHopData: unexpected AEAD error: " ++ show e 176 Right (!ciphertext, !mac) -> ciphertext <> mac 177 {-# INLINE encryptHopData #-} 178 179 -- | Decrypt hop data with ChaCha20-Poly1305. 180 decryptHopData :: DerivedKey -> BS.ByteString -> Maybe BlindedHopData 181 decryptHopData (DerivedKey !rho) !encData 182 | BS.length encData < 16 = Nothing 183 | otherwise = do 184 let !ciphertext = BS.take (BS.length encData - 16) encData 185 !mac = BS.drop (BS.length encData - 16) encData 186 !nonce = BS.replicate 12 0 187 case AEAD.decrypt BS.empty rho nonce (ciphertext, mac) of 188 Left _ -> Nothing 189 Right !plaintext -> decodeBlindedHopData plaintext 190 {-# INLINE decryptHopData #-} 191 192 -- TLV Encoding/Decoding ----------------------------------------------------- 193 194 -- | Encode BlindedHopData to TLV stream. 195 encodeBlindedHopData :: BlindedHopData -> BS.ByteString 196 encodeBlindedHopData !bhd = encodeTlvStream (buildTlvs bhd) 197 where 198 buildTlvs :: BlindedHopData -> [TlvRecord] 199 buildTlvs (BlindedHopData pad sci nid pid pko pr pc af) = 200 let pad' = maybe [] (\p -> [TlvRecord 1 p]) pad 201 sci' = maybe [] (\s -> [TlvRecord 2 (encodeShortChannelId s)]) sci 202 nid' = maybe [] (\n -> [TlvRecord 4 n]) nid 203 pid' = maybe [] (\p -> [TlvRecord 6 p]) pid 204 pko' = maybe [] (\k -> [TlvRecord 8 k]) pko 205 pr' = maybe [] (\r -> [TlvRecord 10 (encodePaymentRelay r)]) pr 206 pc' = maybe [] (\c -> [TlvRecord 12 (encodePaymentConstraints c)]) pc 207 af' = maybe [] (\f -> [TlvRecord 14 f]) af 208 in pad' ++ sci' ++ nid' ++ pid' ++ pko' ++ pr' ++ pc' ++ af' 209 {-# INLINE encodeBlindedHopData #-} 210 211 -- | Decode TLV stream to BlindedHopData. 212 decodeBlindedHopData :: BS.ByteString -> Maybe BlindedHopData 213 decodeBlindedHopData !bs = do 214 tlvs <- decodeTlvStream bs 215 parseBlindedHopData tlvs 216 217 parseBlindedHopData :: [TlvRecord] -> Maybe BlindedHopData 218 parseBlindedHopData = go emptyHopData 219 where 220 emptyHopData :: BlindedHopData 221 emptyHopData = BlindedHopData 222 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 223 224 go :: BlindedHopData -> [TlvRecord] -> Maybe BlindedHopData 225 go !bhd [] = Just bhd 226 go !bhd (TlvRecord typ val : rest) = case typ of 227 1 -> go bhd { bhdPadding = Just val } rest 228 2 -> do 229 sci <- decodeShortChannelId val 230 go bhd { bhdShortChannelId = Just sci } rest 231 4 -> go bhd { bhdNextNodeId = Just val } rest 232 6 -> go bhd { bhdPathId = Just val } rest 233 8 -> go bhd { bhdNextPathKeyOverride = Just val } rest 234 10 -> do 235 pr <- decodePaymentRelay val 236 go bhd { bhdPaymentRelay = Just pr } rest 237 12 -> do 238 pc <- decodePaymentConstraints val 239 go bhd { bhdPaymentConstraints = Just pc } rest 240 14 -> go bhd { bhdAllowedFeatures = Just val } rest 241 _ -> go bhd rest -- Skip unknown TLVs 242 243 -- PaymentRelay encoding/decoding -------------------------------------------- 244 245 -- | Encode PaymentRelay. 246 -- 247 -- Format: 2-byte cltv_delta BE, 4-byte fee_prop BE, tu32 fee_base 248 encodePaymentRelay :: PaymentRelay -> BS.ByteString 249 encodePaymentRelay (PaymentRelay !cltv !feeProp !feeBase) = toStrict $ 250 B.word16BE cltv <> 251 B.word32BE feeProp <> 252 B.byteString (encodeWord32TU feeBase) 253 {-# INLINE encodePaymentRelay #-} 254 255 -- | Decode PaymentRelay. 256 decodePaymentRelay :: BS.ByteString -> Maybe PaymentRelay 257 decodePaymentRelay !bs 258 | BS.length bs < 6 = Nothing 259 | otherwise = do 260 let !cltv = word16BE (BS.take 2 bs) 261 !feeProp = word32BE (BS.take 4 (BS.drop 2 bs)) 262 !feeBaseBytes = BS.drop 6 bs 263 feeBase <- decodeWord32TU feeBaseBytes 264 Just (PaymentRelay cltv feeProp feeBase) 265 {-# INLINE decodePaymentRelay #-} 266 267 -- PaymentConstraints encoding/decoding -------------------------------------- 268 269 -- | Encode PaymentConstraints. 270 -- 271 -- Format: 4-byte max_cltv BE, tu64 htlc_min 272 encodePaymentConstraints :: PaymentConstraints -> BS.ByteString 273 encodePaymentConstraints (PaymentConstraints !maxCltv !htlcMin) = toStrict $ 274 B.word32BE maxCltv <> 275 B.byteString (encodeWord64TU htlcMin) 276 {-# INLINE encodePaymentConstraints #-} 277 278 -- | Decode PaymentConstraints. 279 decodePaymentConstraints :: BS.ByteString -> Maybe PaymentConstraints 280 decodePaymentConstraints !bs 281 | BS.length bs < 4 = Nothing 282 | otherwise = do 283 let !maxCltv = word32BE (BS.take 4 bs) 284 !htlcMinBytes = BS.drop 4 bs 285 htlcMin <- decodeWord64TU htlcMinBytes 286 Just (PaymentConstraints maxCltv htlcMin) 287 {-# INLINE decodePaymentConstraints #-} 288 289 -- Shared secret computation ------------------------------------------------- 290 291 -- | Compute shared secret from ECDH. 292 computeSharedSecret 293 :: BS.ByteString -- ^ 32-byte secret key 294 -> Secp256k1.Projective -- ^ Public key 295 -> Maybe SharedSecret 296 computeSharedSecret !secBs !pub = do 297 sec <- Secp256k1.roll32 secBs 298 ecdhPoint <- Secp256k1.mul pub sec 299 let !compressed = Secp256k1.serialize_point ecdhPoint 300 !ss = SHA256.hash compressed 301 pure $! SharedSecret ss 302 {-# INLINE computeSharedSecret #-} 303 304 -- Path creation ------------------------------------------------------------- 305 306 -- | Create a blinded path from a seed and list of nodes with their data. 307 createBlindedPath 308 :: BS.ByteString -- ^ 32-byte random seed for ephemeral key 309 -> [(Secp256k1.Projective, BlindedHopData)] -- ^ Nodes with their data 310 -> Either BlindingError BlindedPath 311 createBlindedPath !seed !nodes 312 | BS.length seed /= 32 = Left InvalidSeed 313 | otherwise = case nodes of 314 [] -> Left EmptyPath 315 ((introNode, _) : _) -> do 316 -- (e_0, E_0) = keypair from seed 317 e0 <- maybe (Left InvalidSeed) Right (Secp256k1.roll32 seed) 318 e0Pub <- maybe (Left InvalidSeed) Right 319 (Secp256k1.mul Secp256k1._CURVE_G e0) 320 -- Process all hops 321 hops <- processHops seed e0Pub nodes 0 322 Right (BlindedPath introNode e0Pub hops) 323 324 processHops 325 :: BS.ByteString -- ^ Current e_i 326 -> Secp256k1.Projective -- ^ Current E_i 327 -> [(Secp256k1.Projective, BlindedHopData)] 328 -> Int -- ^ Index for error reporting 329 -> Either BlindingError [BlindedHop] 330 processHops _ _ [] _ = Right [] 331 processHops !eKey !ePub ((nodePub, hopData) : rest) !idx = do 332 -- ss_i = SHA256(ECDH(e_i, N_i)) 333 ss <- maybe (Left (InvalidNodeKey idx)) Right 334 (computeSharedSecret eKey nodePub) 335 -- rho_i = deriveBlindingRho(ss_i) 336 let !rho = deriveBlindingRho ss 337 -- B_i = deriveBlindedNodeId(ss_i, N_i) 338 blindedId <- maybe (Left (InvalidNodeKey idx)) Right 339 (deriveBlindedNodeId ss nodePub) 340 -- encrypted_i = encryptHopData(rho_i, data_i) 341 let !encData = encryptHopData rho hopData 342 !hop = BlindedHop blindedId encData 343 -- (e_{i+1}, E_{i+1}) = nextEphemeral(e_i, E_i, ss_i) 344 (nextE, nextEPub) <- maybe (Left (InvalidNodeKey idx)) Right 345 (nextEphemeral eKey ePub ss) 346 -- Process remaining hops 347 restHops <- processHops nextE nextEPub rest (idx + 1) 348 Right (hop : restHops) 349 350 -- Hop processing ------------------------------------------------------------ 351 352 -- | Process a blinded hop, returning decrypted data and next path key. 353 processBlindedHop 354 :: BS.ByteString -- ^ Node's 32-byte private key 355 -> Secp256k1.Projective -- ^ E_i, current path key (blinding point) 356 -> BS.ByteString -- ^ encrypted_data from onion payload 357 -> Either BlindingError (BlindedHopData, Secp256k1.Projective) 358 processBlindedHop !nodeSecKey !pathKey !encData = do 359 -- ss = SHA256(ECDH(node_seckey, path_key)) 360 ss <- maybe (Left InvalidPathKey) Right 361 (computeSharedSecret nodeSecKey pathKey) 362 -- rho = deriveBlindingRho(ss) 363 let !rho = deriveBlindingRho ss 364 -- hop_data = decryptHopData(rho, encrypted_data) 365 hopData <- maybe (Left DecryptionFailed) Right 366 (decryptHopData rho encData) 367 -- Compute next path key 368 nextKey <- case bhdNextPathKeyOverride hopData of 369 Just override -> do 370 -- Parse override as compressed point 371 maybe (Left InvalidPathKey) Right (Secp256k1.parse_point override) 372 Nothing -> do 373 -- E_next = SHA256(path_key || ss) * path_key 374 maybe (Left InvalidPathKey) Right (nextPathKey pathKey ss) 375 Right (hopData, nextKey) 376 377 -- Scalar multiplication ----------------------------------------------------- 378 379 -- | Multiply two 32-byte scalars mod curve order q. 380 -- 381 -- Uses Montgomery multiplication from ppad-fixed for efficiency. 382 mulSecKey :: BS.ByteString -> BS.ByteString -> BS.ByteString 383 mulSecKey !a !b = 384 let !aW = Secp256k1.unsafe_roll32 a 385 !bW = Secp256k1.unsafe_roll32 b 386 !aM = S.to aW 387 !bM = S.to bW 388 !resultM = S.mul aM bM 389 !resultW = S.retr resultM 390 in Secp256k1.unroll32 resultW 391 {-# INLINE mulSecKey #-}