Process.hs (7476B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DeriveGeneric #-} 4 {-# LANGUAGE OverloadedStrings #-} 5 6 -- | 7 -- Module: Lightning.Protocol.BOLT4.Process 8 -- Copyright: (c) 2025 Jared Tobin 9 -- License: MIT 10 -- Maintainer: Jared Tobin <jared@ppad.tech> 11 -- 12 -- Onion packet processing for BOLT4. 13 14 module Lightning.Protocol.BOLT4.Process ( 15 -- * Processing 16 process 17 18 -- * Rejection reasons 19 , RejectReason(..) 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 Data.Word (Word8) 26 import GHC.Generics (Generic) 27 import Lightning.Protocol.BOLT4.Codec 28 import Lightning.Protocol.BOLT4.Internal 29 import Lightning.Protocol.BOLT4.Prim 30 import Lightning.Protocol.BOLT4.Types 31 32 -- | Reasons for rejecting a packet. 33 data RejectReason 34 = InvalidVersion !Word8 -- ^ Version byte is not 0x00 35 | InvalidEphemeralKey -- ^ Malformed public key 36 | HmacMismatch -- ^ HMAC verification failed 37 | InvalidPayload !String -- ^ Malformed hop payload 38 deriving (Eq, Show, Generic) 39 40 -- | Process an incoming onion packet. 41 -- 42 -- Takes the receiving node's private key, the incoming packet, and 43 -- associated data (typically the payment hash). 44 -- 45 -- Returns either a rejection reason or the processing result 46 -- (forward to next hop or receive at final destination). 47 process 48 :: BS.ByteString -- ^ 32-byte secret key of this node 49 -> OnionPacket -- ^ incoming onion packet 50 -> BS.ByteString -- ^ associated data (payment hash) 51 -> Either RejectReason ProcessResult 52 process !secKey !packet !assocData = do 53 -- Step 1: Validate version 54 validateVersion packet 55 56 -- Step 2: Parse ephemeral public key 57 ephemeral <- parseEphemeralKey packet 58 59 -- Step 3: Compute shared secret 60 ss <- case computeSharedSecret secKey ephemeral of 61 Nothing -> Left InvalidEphemeralKey 62 Just s -> Right s 63 64 -- Step 4: Derive keys 65 let !muKey = deriveMu ss 66 !rhoKey = deriveRho ss 67 68 -- Step 5: Verify HMAC 69 if not (verifyPacketHmac muKey packet assocData) 70 then Left HmacMismatch 71 else pure () 72 73 -- Step 6: Decrypt hop payloads 74 let !decrypted = decryptPayloads rhoKey 75 (unHopPayloads (opHopPayloads packet)) 76 77 -- Step 7: Extract payload 78 (payloadBytes, nextHmac, remaining) <- 79 extractPayload decrypted 80 81 -- Step 8: Parse payload TLV 82 hp <- case decodeHopPayload payloadBytes of 83 Nothing -> Left (InvalidPayload "failed to decode TLV") 84 Just h -> Right h 85 86 -- Step 9: Check if final hop 87 if isFinalHop nextHmac 88 then Right $! Receive $! ReceiveInfo 89 { riPayload = hp 90 , riSharedSecret = ss 91 } 92 else do 93 -- Step 10: Prepare forward packet 94 nextPacket <- case prepareForward 95 ephemeral ss remaining nextHmac of 96 Nothing -> Left InvalidEphemeralKey 97 Just np -> Right np 98 99 Right $! Forward $! ForwardInfo 100 { fiNextPacket = nextPacket 101 , fiPayload = hp 102 , fiSharedSecret = ss 103 } 104 105 -- | Validate packet version is 0x00. 106 validateVersion :: OnionPacket -> Either RejectReason () 107 validateVersion !packet 108 | opVersion packet == versionByte = Right () 109 | otherwise = Left (InvalidVersion (opVersion packet)) 110 {-# INLINE validateVersion #-} 111 112 -- | Parse and validate ephemeral public key from packet. 113 parseEphemeralKey 114 :: OnionPacket 115 -> Either RejectReason Secp256k1.Projective 116 parseEphemeralKey !packet = 117 case Secp256k1.parse_point (opEphemeralKey packet) of 118 Nothing -> Left InvalidEphemeralKey 119 Just pub -> Right pub 120 {-# INLINE parseEphemeralKey #-} 121 122 -- | Decrypt hop payloads by XORing with rho stream. 123 -- 124 -- Generates a stream of 2*1300 bytes and XORs with hop_payloads 125 -- extended with 1300 zero bytes. 126 decryptPayloads 127 :: DerivedKey -- ^ rho key 128 -> BS.ByteString -- ^ hop_payloads (1300 bytes) 129 -> BS.ByteString -- ^ decrypted (2600 bytes, first 1300 useful) 130 decryptPayloads !rhoKey !payloads = 131 let !streamLen = 2 * hopPayloadsSize -- 2600 bytes 132 !stream = generateStream rhoKey streamLen 133 -- Extend payloads with zeros for the shift operation 134 !extended = payloads <> BS.replicate hopPayloadsSize 0 135 in xorBytes stream extended 136 {-# INLINE decryptPayloads #-} 137 138 -- | XOR two bytestrings of equal length. 139 xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString 140 xorBytes !a !b = BS.pack (BS.zipWith xor a b) 141 {-# INLINE xorBytes #-} 142 143 -- | Extract payload from decrypted buffer. 144 -- 145 -- Parses BigSize length prefix, extracts payload bytes and 146 -- next HMAC. 147 extractPayload 148 :: BS.ByteString 149 -> Either RejectReason 150 (BS.ByteString, BS.ByteString, BS.ByteString) 151 -- ^ (payload_bytes, next_hmac, remaining_hop_payloads) 152 extractPayload !decrypted = do 153 -- Parse length prefix 154 (len, afterLen) <- case decodeBigSize decrypted of 155 Nothing -> Left (InvalidPayload "invalid length prefix") 156 Just (l, r) -> Right (fromIntegral l :: Int, r) 157 158 -- Validate length 159 if len > BS.length afterLen 160 then Left (InvalidPayload "payload length exceeds buffer") 161 else if len == 0 162 then Left (InvalidPayload "zero-length payload") 163 else pure () 164 165 -- Extract payload bytes 166 let !payloadBytes = BS.take len afterLen 167 !afterPayload = BS.drop len afterLen 168 169 -- Extract next HMAC (32 bytes) 170 if BS.length afterPayload < hmacSize 171 then Left (InvalidPayload "insufficient bytes for HMAC") 172 else do 173 let !nextHmac = BS.take hmacSize afterPayload 174 -- Remaining payloads: skip the HMAC, take first 175 -- 1300 bytes. Already "shifted" by payload extraction 176 !remaining = BS.drop hmacSize afterPayload 177 178 Right (payloadBytes, nextHmac, remaining) 179 180 -- | Verify packet HMAC. 181 -- 182 -- Computes HMAC over (hop_payloads || associated_data) using 183 -- mu key and compares with packet's HMAC using constant-time 184 -- comparison. 185 verifyPacketHmac 186 :: DerivedKey -- ^ mu key 187 -> OnionPacket -- ^ packet with HMAC to verify 188 -> BS.ByteString -- ^ associated data 189 -> Bool 190 verifyPacketHmac !muKey !packet !assocData = 191 let !computed = computeHmac muKey 192 (unHopPayloads (opHopPayloads packet)) 193 assocData 194 in verifyHmac (unHmac32 (opHmac packet)) computed 195 {-# INLINE verifyPacketHmac #-} 196 197 -- | Prepare packet for forwarding to next hop. 198 -- 199 -- Computes blinded ephemeral key and constructs next 200 -- OnionPacket. 201 prepareForward 202 :: Secp256k1.Projective -- ^ current ephemeral key 203 -> SharedSecret -- ^ shared secret (for blinding) 204 -> BS.ByteString -- ^ remaining hop_payloads 205 -> BS.ByteString -- ^ next HMAC 206 -> Maybe OnionPacket 207 prepareForward !ephemeral !ss !remaining !nextHmac = do 208 -- Compute blinding factor and blind ephemeral key 209 let !bf = computeBlindingFactor ephemeral ss 210 newEphemeral <- blindPubKey ephemeral bf 211 212 -- Serialize new ephemeral key 213 let !newEphBytes = Secp256k1.serialize_point newEphemeral 214 215 -- Truncate remaining to exactly 1300 bytes 216 let !newPayloads = BS.take hopPayloadsSize remaining 217 218 -- Construct next packet 219 pure $! OnionPacket 220 { opVersion = versionByte 221 , opEphemeralKey = newEphBytes 222 , opHopPayloads = unsafeHopPayloads newPayloads 223 , opHmac = unsafeHmac32 nextHmac 224 } 225 226 -- | Check if this is the final hop. 227 -- 228 -- Final hop is indicated by next_hmac being all zeros. 229 isFinalHop :: BS.ByteString -> Bool 230 isFinalHop !hm = hm == BS.replicate hmacSize 0 231 {-# INLINE isFinalHop #-}