Codec.hs (12940B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE OverloadedStrings #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT4.Codec 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Serialization and deserialization for BOLT4 types. 12 13 module Lightning.Protocol.BOLT4.Codec ( 14 -- * BigSize encoding 15 encodeBigSize 16 , decodeBigSize 17 , bigSizeLen 18 19 -- * TLV encoding 20 , encodeTlv 21 , decodeTlv 22 , decodeTlvStream 23 , encodeTlvStream 24 25 -- * Packet serialization 26 , encodeOnionPacket 27 , decodeOnionPacket 28 , encodeHopPayload 29 , decodeHopPayload 30 31 -- * ShortChannelId 32 , encodeShortChannelId 33 , decodeShortChannelId 34 35 -- * Failure messages 36 , encodeFailureMessage 37 , decodeFailureMessage 38 39 -- * Internal helpers (for Blinding) 40 , toStrict 41 , word16BE 42 , word32BE 43 , encodeWord64TU 44 , decodeWord64TU 45 , encodeWord32TU 46 , decodeWord32TU 47 ) where 48 49 import Data.Bits (shiftL) 50 import qualified Data.ByteString as BS 51 import qualified Data.ByteString.Builder as B 52 import qualified Data.ByteString.Lazy as BL 53 import Data.Word (Word16, Word32, Word64) 54 import Lightning.Protocol.BOLT4.Types 55 56 -- BigSize encoding --------------------------------------------------------- 57 58 -- | Encode integer as BigSize. 59 -- 60 -- * 0-0xFC: 1 byte 61 -- * 0xFD-0xFFFF: 0xFD ++ 2 bytes BE 62 -- * 0x10000-0xFFFFFFFF: 0xFE ++ 4 bytes BE 63 -- * larger: 0xFF ++ 8 bytes BE 64 encodeBigSize :: Word64 -> BS.ByteString 65 encodeBigSize !n 66 | n < 0xFD = BS.singleton (fromIntegral n) 67 | n <= 0xFFFF = toStrict $ 68 B.word8 0xFD <> B.word16BE (fromIntegral n) 69 | n <= 0xFFFFFFFF = toStrict $ 70 B.word8 0xFE <> B.word32BE (fromIntegral n) 71 | otherwise = toStrict $ 72 B.word8 0xFF <> B.word64BE n 73 {-# INLINE encodeBigSize #-} 74 75 -- | Decode BigSize, returning (value, remaining bytes). 76 decodeBigSize :: BS.ByteString -> Maybe (Word64, BS.ByteString) 77 decodeBigSize !bs = case BS.uncons bs of 78 Nothing -> Nothing 79 Just (b, rest) 80 | b < 0xFD -> Just (fromIntegral b, rest) 81 | b == 0xFD -> do 82 (hi, r1) <- BS.uncons rest 83 (lo, r2) <- BS.uncons r1 84 let !val = fromIntegral hi `shiftL` 8 + fromIntegral lo 85 -- Canonical: must be >= 0xFD 86 if val < 0xFD then Nothing else Just (val, r2) 87 | b == 0xFE -> do 88 if BS.length rest < 4 then Nothing else do 89 let !bytes = BS.take 4 rest 90 !r = BS.drop 4 rest 91 !val = word32BE bytes 92 -- Canonical: must be > 0xFFFF 93 if val <= 0xFFFF then Nothing else Just (fromIntegral val, r) 94 | otherwise -> do -- b == 0xFF 95 if BS.length rest < 8 then Nothing else do 96 let !bytes = BS.take 8 rest 97 !r = BS.drop 8 rest 98 !val = word64BE bytes 99 -- Canonical: must be > 0xFFFFFFFF 100 if val <= 0xFFFFFFFF then Nothing else Just (val, r) 101 {-# INLINE decodeBigSize #-} 102 103 -- | Get encoded size of a BigSize value without encoding. 104 bigSizeLen :: Word64 -> Int 105 bigSizeLen !n 106 | n < 0xFD = 1 107 | n <= 0xFFFF = 3 108 | n <= 0xFFFFFFFF = 5 109 | otherwise = 9 110 {-# INLINE bigSizeLen #-} 111 112 -- TLV encoding ------------------------------------------------------------- 113 114 -- | Encode a TLV record. 115 encodeTlv :: TlvRecord -> BS.ByteString 116 encodeTlv (TlvRecord !typ !val) = toStrict $ 117 B.byteString (encodeBigSize typ) <> 118 B.byteString (encodeBigSize (fromIntegral (BS.length val))) <> 119 B.byteString val 120 {-# INLINE encodeTlv #-} 121 122 -- | Decode a single TLV record. 123 decodeTlv :: BS.ByteString -> Maybe (TlvRecord, BS.ByteString) 124 decodeTlv !bs = do 125 (typ, r1) <- decodeBigSize bs 126 (len, r2) <- decodeBigSize r1 127 let !len' = fromIntegral len 128 if BS.length r2 < len' 129 then Nothing 130 else do 131 let !val = BS.take len' r2 132 !rest = BS.drop len' r2 133 Just (TlvRecord typ val, rest) 134 {-# INLINE decodeTlv #-} 135 136 -- | Decode a TLV stream (sequence of records). 137 -- Validates strictly increasing type order. 138 decodeTlvStream :: BS.ByteString -> Maybe [TlvRecord] 139 decodeTlvStream = go Nothing 140 where 141 go :: Maybe Word64 -> BS.ByteString -> Maybe [TlvRecord] 142 go _ !bs | BS.null bs = Just [] 143 go !mPrev !bs = do 144 (rec@(TlvRecord typ _), rest) <- decodeTlv bs 145 -- Check strictly increasing order 146 case mPrev of 147 Just prev | typ <= prev -> Nothing 148 _ -> do 149 recs <- go (Just typ) rest 150 Just (rec : recs) 151 152 -- | Encode a TLV stream from records. 153 -- Records must be sorted by type, no duplicates. 154 encodeTlvStream :: [TlvRecord] -> BS.ByteString 155 encodeTlvStream !recs = toStrict $ foldMap (B.byteString . encodeTlv) recs 156 {-# INLINE encodeTlvStream #-} 157 158 -- Packet serialization ----------------------------------------------------- 159 160 -- | Serialize OnionPacket to 1366 bytes. 161 encodeOnionPacket :: OnionPacket -> BS.ByteString 162 encodeOnionPacket (OnionPacket !ver !eph !payloads !mac) = 163 toStrict $ 164 B.word8 ver <> 165 B.byteString eph <> 166 B.byteString (unHopPayloads payloads) <> 167 B.byteString (unHmac32 mac) 168 {-# INLINE encodeOnionPacket #-} 169 170 -- | Parse OnionPacket from 1366 bytes. 171 decodeOnionPacket :: BS.ByteString -> Maybe OnionPacket 172 decodeOnionPacket !bs 173 | BS.length bs /= onionPacketSize = Nothing 174 | otherwise = do 175 let !ver = BS.index bs 0 176 !eph = BS.take pubkeySize (BS.drop 1 bs) 177 !payloadsRaw = BS.take hopPayloadsSize 178 (BS.drop (1 + pubkeySize) bs) 179 !macRaw = BS.drop 180 (1 + pubkeySize + hopPayloadsSize) bs 181 hp <- hopPayloads payloadsRaw 182 hm <- hmac32 macRaw 183 Just (OnionPacket ver eph hp hm) 184 {-# INLINE decodeOnionPacket #-} 185 186 -- | Encode HopPayload to bytes (without length prefix). 187 encodeHopPayload :: HopPayload -> BS.ByteString 188 encodeHopPayload !hp = encodeTlvStream (buildTlvs hp) 189 where 190 buildTlvs :: HopPayload -> [TlvRecord] 191 buildTlvs (HopPayload amt cltv sci pd ed cpk unk) = 192 let amt' = maybe [] (\a -> [TlvRecord 2 (encodeWord64TU a)]) amt 193 cltv' = maybe [] (\c -> [TlvRecord 4 (encodeWord32TU c)]) cltv 194 sci' = maybe [] (\s -> [TlvRecord 6 (encodeShortChannelId s)]) sci 195 pd' = maybe [] (\p -> [TlvRecord 8 (encodePaymentData p)]) pd 196 ed' = maybe [] (\e -> [TlvRecord 10 e]) ed 197 cpk' = maybe [] (\k -> [TlvRecord 12 k]) cpk 198 in amt' ++ cltv' ++ sci' ++ pd' ++ ed' ++ cpk' ++ unk 199 200 -- | Decode HopPayload from bytes. 201 decodeHopPayload :: BS.ByteString -> Maybe HopPayload 202 decodeHopPayload !bs = do 203 tlvs <- decodeTlvStream bs 204 parseHopPayload tlvs 205 206 parseHopPayload :: [TlvRecord] -> Maybe HopPayload 207 parseHopPayload = go emptyHop 208 where 209 emptyHop :: HopPayload 210 emptyHop = HopPayload Nothing Nothing Nothing Nothing Nothing Nothing [] 211 212 go :: HopPayload -> [TlvRecord] -> Maybe HopPayload 213 go !hp [] = Just hp { hpUnknownTlvs = reverse (hpUnknownTlvs hp) } 214 go !hp (TlvRecord typ val : rest) = case typ of 215 2 -> do 216 amt <- decodeWord64TU val 217 go hp { hpAmtToForward = Just amt } rest 218 4 -> do 219 cltv <- decodeWord32TU val 220 go hp { hpOutgoingCltv = Just cltv } rest 221 6 -> do 222 sci <- decodeShortChannelId val 223 go hp { hpShortChannelId = Just sci } rest 224 8 -> do 225 pd <- decodePaymentData val 226 go hp { hpPaymentData = Just pd } rest 227 10 -> go hp { hpEncryptedData = Just val } rest 228 12 -> go hp { hpCurrentPathKey = Just val } rest 229 _ -> go hp { hpUnknownTlvs = TlvRecord typ val : hpUnknownTlvs hp } rest 230 231 -- ShortChannelId ----------------------------------------------------------- 232 233 -- | Encode ShortChannelId to 8 bytes big-endian. 234 encodeShortChannelId :: ShortChannelId -> BS.ByteString 235 encodeShortChannelId !sci = toStrict (B.word64BE (scidWord64 sci)) 236 {-# INLINE encodeShortChannelId #-} 237 238 -- | Decode ShortChannelId from 8 bytes big-endian. 239 decodeShortChannelId :: BS.ByteString -> Maybe ShortChannelId 240 decodeShortChannelId !bs 241 | BS.length bs /= 8 = Nothing 242 | otherwise = 243 let !w = (fromIntegral (BS.index bs 0) `shiftL` 56) 244 + (fromIntegral (BS.index bs 1) `shiftL` 48) 245 + (fromIntegral (BS.index bs 2) `shiftL` 40) 246 + (fromIntegral (BS.index bs 3) `shiftL` 32) 247 + (fromIntegral (BS.index bs 4) `shiftL` 24) 248 + (fromIntegral (BS.index bs 5) `shiftL` 16) 249 + (fromIntegral (BS.index bs 6) `shiftL` 8) 250 + fromIntegral (BS.index bs 7) :: Word64 251 in Just (ShortChannelId w) 252 {-# INLINE decodeShortChannelId #-} 253 254 -- Failure messages --------------------------------------------------------- 255 256 -- | Encode failure message. 257 encodeFailureMessage :: FailureMessage -> BS.ByteString 258 encodeFailureMessage (FailureMessage (FailureCode !code) !dat !tlvs) = 259 toStrict $ 260 B.word16BE code <> 261 B.word16BE (fromIntegral (BS.length dat)) <> 262 B.byteString dat <> 263 B.byteString (encodeTlvStream tlvs) 264 {-# INLINE encodeFailureMessage #-} 265 266 -- | Decode failure message. 267 decodeFailureMessage :: BS.ByteString -> Maybe FailureMessage 268 decodeFailureMessage !bs = do 269 if BS.length bs < 4 then Nothing else do 270 let !code = word16BE (BS.take 2 bs) 271 !dlen = fromIntegral (word16BE (BS.take 2 (BS.drop 2 bs))) 272 if BS.length bs < 4 + dlen then Nothing else do 273 let !dat = BS.take dlen (BS.drop 4 bs) 274 !tlvBytes = BS.drop (4 + dlen) bs 275 tlvs <- if BS.null tlvBytes 276 then Just [] 277 else decodeTlvStream tlvBytes 278 Just (FailureMessage (FailureCode code) dat tlvs) 279 280 -- Helper functions --------------------------------------------------------- 281 282 -- | Convert Builder to strict ByteString. 283 toStrict :: B.Builder -> BS.ByteString 284 toStrict = BL.toStrict . B.toLazyByteString 285 {-# INLINE toStrict #-} 286 287 -- | Decode big-endian Word16. 288 word16BE :: BS.ByteString -> Word16 289 word16BE !bs = 290 let !b0 = fromIntegral (BS.index bs 0) :: Word16 291 !b1 = fromIntegral (BS.index bs 1) :: Word16 292 in (b0 `shiftL` 8) + b1 293 {-# INLINE word16BE #-} 294 295 -- | Decode big-endian Word32. 296 word32BE :: BS.ByteString -> Word32 297 word32BE !bs = 298 let !b0 = fromIntegral (BS.index bs 0) :: Word32 299 !b1 = fromIntegral (BS.index bs 1) :: Word32 300 !b2 = fromIntegral (BS.index bs 2) :: Word32 301 !b3 = fromIntegral (BS.index bs 3) :: Word32 302 in (b0 `shiftL` 24) + (b1 `shiftL` 16) + (b2 `shiftL` 8) + b3 303 {-# INLINE word32BE #-} 304 305 -- | Decode big-endian Word64. 306 word64BE :: BS.ByteString -> Word64 307 word64BE !bs = 308 let !b0 = fromIntegral (BS.index bs 0) :: Word64 309 !b1 = fromIntegral (BS.index bs 1) :: Word64 310 !b2 = fromIntegral (BS.index bs 2) :: Word64 311 !b3 = fromIntegral (BS.index bs 3) :: Word64 312 !b4 = fromIntegral (BS.index bs 4) :: Word64 313 !b5 = fromIntegral (BS.index bs 5) :: Word64 314 !b6 = fromIntegral (BS.index bs 6) :: Word64 315 !b7 = fromIntegral (BS.index bs 7) :: Word64 316 in (b0 `shiftL` 56) + (b1 `shiftL` 48) + (b2 `shiftL` 40) + 317 (b3 `shiftL` 32) + (b4 `shiftL` 24) + (b5 `shiftL` 16) + 318 (b6 `shiftL` 8) + b7 319 {-# INLINE word64BE #-} 320 321 -- | Encode Word64 as truncated unsigned (minimal bytes). 322 encodeWord64TU :: Word64 -> BS.ByteString 323 encodeWord64TU !n 324 | n == 0 = BS.empty 325 | otherwise = BS.dropWhile (== 0) (toStrict (B.word64BE n)) 326 {-# INLINE encodeWord64TU #-} 327 328 -- | Decode truncated unsigned to Word64. 329 decodeWord64TU :: BS.ByteString -> Maybe Word64 330 decodeWord64TU !bs 331 | BS.null bs = Just 0 332 | BS.length bs > 8 = Nothing 333 | not (BS.null bs) && BS.index bs 0 == 0 = Nothing -- Non-canonical 334 | otherwise = Just (go 0 bs) 335 where 336 go :: Word64 -> BS.ByteString -> Word64 337 go !acc !b = case BS.uncons b of 338 Nothing -> acc 339 Just (x, rest) -> go ((acc `shiftL` 8) + fromIntegral x) rest 340 {-# INLINE decodeWord64TU #-} 341 342 -- | Encode Word32 as truncated unsigned. 343 encodeWord32TU :: Word32 -> BS.ByteString 344 encodeWord32TU !n 345 | n == 0 = BS.empty 346 | otherwise = BS.dropWhile (== 0) (toStrict (B.word32BE n)) 347 {-# INLINE encodeWord32TU #-} 348 349 -- | Decode truncated unsigned to Word32. 350 decodeWord32TU :: BS.ByteString -> Maybe Word32 351 decodeWord32TU !bs 352 | BS.null bs = Just 0 353 | BS.length bs > 4 = Nothing 354 | not (BS.null bs) && BS.index bs 0 == 0 = Nothing -- Non-canonical 355 | otherwise = Just (go 0 bs) 356 where 357 go :: Word32 -> BS.ByteString -> Word32 358 go !acc !b = case BS.uncons b of 359 Nothing -> acc 360 Just (x, rest) -> go ((acc `shiftL` 8) + fromIntegral x) rest 361 {-# INLINE decodeWord32TU #-} 362 363 -- | Encode PaymentData. 364 encodePaymentData :: PaymentData -> BS.ByteString 365 encodePaymentData (PaymentData !secret !total) = 366 unPaymentSecret secret <> encodeWord64TU total 367 {-# INLINE encodePaymentData #-} 368 369 -- | Decode PaymentData. 370 decodePaymentData :: BS.ByteString -> Maybe PaymentData 371 decodePaymentData !bs 372 | BS.length bs < 32 = Nothing 373 | otherwise = do 374 ps <- paymentSecret (BS.take 32 bs) 375 let !rest = BS.drop 32 bs 376 total <- decodeWord64TU rest 377 Just (PaymentData ps total) 378 {-# INLINE decodePaymentData #-}