Error.hs (7632B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE OverloadedStrings #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT4.Error 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Error packet construction and unwrapping for BOLT4 onion routing. 12 -- 13 -- Failing nodes construct error packets that are wrapped at each 14 -- intermediate hop on the return path. The origin node unwraps 15 -- layers to attribute the error to a specific hop. 16 17 module Lightning.Protocol.BOLT4.Error ( 18 -- * Types 19 ErrorPacket(..) 20 , AttributionResult(..) 21 , minErrorPacketSize 22 23 -- * Error construction (failing node) 24 , constructError 25 26 -- * Error forwarding (intermediate node) 27 , wrapError 28 29 -- * Error unwrapping (origin node) 30 , unwrapError 31 ) where 32 33 import Data.Bits (xor) 34 import qualified Data.ByteString as BS 35 import qualified Data.ByteString.Builder as B 36 import qualified Data.ByteString.Lazy as BL 37 import qualified Crypto.Hash.SHA256 as SHA256 38 import Data.Word (Word8, Word16) 39 import Lightning.Protocol.BOLT4.Codec (encodeFailureMessage, decodeFailureMessage) 40 import Lightning.Protocol.BOLT4.Prim 41 import Lightning.Protocol.BOLT4.Types (FailureMessage) 42 43 -- | Wrapped error packet ready for return to origin. 44 newtype ErrorPacket = ErrorPacket BS.ByteString 45 deriving (Eq, Show) 46 47 -- | Result of error attribution. 48 data AttributionResult 49 = Attributed {-# UNPACK #-} !Int !FailureMessage 50 -- ^ (hop index, failure) 51 | UnknownOrigin !BS.ByteString 52 -- ^ Could not attribute to any hop 53 deriving (Eq, Show) 54 55 -- | Minimum error packet size (256 bytes per spec). 56 minErrorPacketSize :: Int 57 minErrorPacketSize = 256 58 {-# INLINE minErrorPacketSize #-} 59 60 -- Error construction --------------------------------------------------------- 61 62 -- | Construct an error packet at a failing node. 63 -- 64 -- Takes the shared secret (from processing) and failure message, 65 -- and wraps it for return to origin. 66 constructError 67 :: SharedSecret -- ^ from packet processing 68 -> FailureMessage -- ^ failure details 69 -> ErrorPacket 70 constructError !ss !failure = 71 let !um = deriveUm ss 72 !ammag = deriveAmmag ss 73 !inner = buildErrorMessage um failure 74 !obfuscated = obfuscateError ammag inner 75 in ErrorPacket obfuscated 76 {-# INLINE constructError #-} 77 78 -- | Wrap an existing error packet for forwarding back. 79 -- 80 -- Each intermediate node wraps the error with its own layer. 81 wrapError 82 :: SharedSecret -- ^ this node's shared secret 83 -> ErrorPacket -- ^ error from downstream 84 -> ErrorPacket 85 wrapError !ss (ErrorPacket !packet) = 86 let !ammag = deriveAmmag ss 87 !wrapped = obfuscateError ammag packet 88 in ErrorPacket wrapped 89 {-# INLINE wrapError #-} 90 91 -- Error unwrapping ----------------------------------------------------------- 92 93 -- | Attempt to attribute an error to a specific hop. 94 -- 95 -- Takes the shared secrets from original packet construction 96 -- (in order from first hop to final) and the error packet. 97 -- 98 -- Tries each hop's keys until HMAC verifies, revealing origin. 99 unwrapError 100 :: [SharedSecret] -- ^ secrets from construction, in route order 101 -> ErrorPacket -- ^ received error 102 -> AttributionResult 103 unwrapError secrets (ErrorPacket !initialPacket) = go 0 initialPacket secrets 104 where 105 go :: Int -> BS.ByteString -> [SharedSecret] -> AttributionResult 106 go !_ !packet [] = UnknownOrigin packet 107 go !idx !packet (ss:rest) = 108 let !ammag = deriveAmmag ss 109 !um = deriveUm ss 110 !deobfuscated = deobfuscateError ammag packet 111 in if verifyErrorHmac um deobfuscated 112 then case parseErrorMessage (BS.drop 32 deobfuscated) of 113 Just msg -> Attributed idx msg 114 Nothing -> UnknownOrigin deobfuscated 115 else go (idx + 1) deobfuscated rest 116 117 -- Internal functions --------------------------------------------------------- 118 119 -- | Build the inner error message structure. 120 -- 121 -- Format: HMAC (32) || len (2) || message || pad_len (2) || padding 122 -- Total must be >= 256 bytes. 123 buildErrorMessage 124 :: DerivedKey -- ^ um key 125 -> FailureMessage -- ^ failure to encode 126 -> BS.ByteString -- ^ complete message with HMAC 127 buildErrorMessage (DerivedKey !umKey) !failure = 128 let !encoded = encodeFailureMessage failure 129 !msgLen = BS.length encoded 130 -- Total payload: len(2) + msg + pad_len(2) + padding = 256 - 32 = 224 131 -- padding = 224 - 2 - msgLen - 2 = 220 - msgLen 132 !padLen = max 0 (minErrorPacketSize - 32 - 2 - msgLen - 2) 133 !padding = BS.replicate padLen 0 134 -- Build: len || message || pad_len || padding 135 !payload = toStrict $ 136 B.word16BE (fromIntegral msgLen) <> 137 B.byteString encoded <> 138 B.word16BE (fromIntegral padLen) <> 139 B.byteString padding 140 -- HMAC over the payload 141 SHA256.MAC !hmac = SHA256.hmac umKey payload 142 in hmac <> payload 143 {-# INLINE buildErrorMessage #-} 144 145 -- | Obfuscate error packet with ammag stream. 146 -- 147 -- XORs the entire packet with pseudo-random stream. 148 obfuscateError 149 :: DerivedKey -- ^ ammag key 150 -> BS.ByteString -- ^ error packet 151 -> BS.ByteString -- ^ obfuscated packet 152 obfuscateError !ammag !packet = 153 let !stream = generateStream ammag (BS.length packet) 154 in xorBytes packet stream 155 {-# INLINE obfuscateError #-} 156 157 -- | Remove one layer of obfuscation from error packet. 158 -- 159 -- XOR is its own inverse, so same as obfuscation. 160 deobfuscateError 161 :: DerivedKey -- ^ ammag key 162 -> BS.ByteString -- ^ obfuscated packet 163 -> BS.ByteString -- ^ deobfuscated packet 164 deobfuscateError = obfuscateError 165 {-# INLINE deobfuscateError #-} 166 167 -- | Verify error HMAC after deobfuscation. 168 verifyErrorHmac 169 :: DerivedKey -- ^ um key 170 -> BS.ByteString -- ^ deobfuscated packet (HMAC || rest) 171 -> Bool 172 verifyErrorHmac (DerivedKey !umKey) !packet 173 | BS.length packet < 32 = False 174 | otherwise = 175 let !receivedHmac = BS.take 32 packet 176 !payload = BS.drop 32 packet 177 SHA256.MAC !computedHmac = SHA256.hmac umKey payload 178 in constantTimeEq receivedHmac computedHmac 179 {-# INLINE verifyErrorHmac #-} 180 181 -- | Parse error message from deobfuscated packet (after HMAC). 182 parseErrorMessage 183 :: BS.ByteString -- ^ packet after HMAC (len || msg || pad_len || pad) 184 -> Maybe FailureMessage 185 parseErrorMessage !bs 186 | BS.length bs < 4 = Nothing 187 | otherwise = 188 let !msgLen = fromIntegral (word16BE (BS.take 2 bs)) 189 in if BS.length bs < 2 + msgLen 190 then Nothing 191 else decodeFailureMessage (BS.take msgLen (BS.drop 2 bs)) 192 {-# INLINE parseErrorMessage #-} 193 194 -- Helper functions ----------------------------------------------------------- 195 196 -- | XOR two ByteStrings of equal length. 197 xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString 198 xorBytes !a !b = BS.pack $ BS.zipWith xor a b 199 {-# INLINE xorBytes #-} 200 201 -- | Constant-time equality comparison. 202 constantTimeEq :: BS.ByteString -> BS.ByteString -> Bool 203 constantTimeEq !a !b 204 | BS.length a /= BS.length b = False 205 | otherwise = go 0 (BS.zip a b) 206 where 207 go :: Word8 -> [(Word8, Word8)] -> Bool 208 go !acc [] = acc == 0 209 go !acc ((x, y):rest) = go (acc `xor` (x `xor` y)) rest 210 {-# INLINE constantTimeEq #-} 211 212 -- | Decode big-endian Word16. 213 word16BE :: BS.ByteString -> Word16 214 word16BE !bs = 215 let !b0 = fromIntegral (BS.index bs 0) :: Word16 216 !b1 = fromIntegral (BS.index bs 1) :: Word16 217 in (b0 * 256) + b1 218 {-# INLINE word16BE #-} 219 220 -- | Convert Builder to strict ByteString. 221 toStrict :: B.Builder -> BS.ByteString 222 toStrict = BL.toStrict . B.toLazyByteString 223 {-# INLINE toStrict #-}