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