Codec.hs (13369B)
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, shiftR, (.&.)) 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) = toStrict $ 163 B.word8 ver <> 164 B.byteString eph <> 165 B.byteString payloads <> 166 B.byteString mac 167 {-# INLINE encodeOnionPacket #-} 168 169 -- | Parse OnionPacket from 1366 bytes. 170 decodeOnionPacket :: BS.ByteString -> Maybe OnionPacket 171 decodeOnionPacket !bs 172 | BS.length bs /= onionPacketSize = Nothing 173 | otherwise = 174 let !ver = BS.index bs 0 175 !eph = BS.take pubkeySize (BS.drop 1 bs) 176 !payloads = BS.take hopPayloadsSize (BS.drop (1 + pubkeySize) bs) 177 !mac = BS.drop (1 + pubkeySize + hopPayloadsSize) bs 178 in Just (OnionPacket ver eph payloads mac) 179 {-# INLINE decodeOnionPacket #-} 180 181 -- | Encode HopPayload to bytes (without length prefix). 182 encodeHopPayload :: HopPayload -> BS.ByteString 183 encodeHopPayload !hp = encodeTlvStream (buildTlvs hp) 184 where 185 buildTlvs :: HopPayload -> [TlvRecord] 186 buildTlvs (HopPayload amt cltv sci pd ed cpk unk) = 187 let amt' = maybe [] (\a -> [TlvRecord 2 (encodeWord64TU a)]) amt 188 cltv' = maybe [] (\c -> [TlvRecord 4 (encodeWord32TU c)]) cltv 189 sci' = maybe [] (\s -> [TlvRecord 6 (encodeShortChannelId s)]) sci 190 pd' = maybe [] (\p -> [TlvRecord 8 (encodePaymentData p)]) pd 191 ed' = maybe [] (\e -> [TlvRecord 10 e]) ed 192 cpk' = maybe [] (\k -> [TlvRecord 12 k]) cpk 193 in amt' ++ cltv' ++ sci' ++ pd' ++ ed' ++ cpk' ++ unk 194 195 -- | Decode HopPayload from bytes. 196 decodeHopPayload :: BS.ByteString -> Maybe HopPayload 197 decodeHopPayload !bs = do 198 tlvs <- decodeTlvStream bs 199 parseHopPayload tlvs 200 201 parseHopPayload :: [TlvRecord] -> Maybe HopPayload 202 parseHopPayload = go emptyHop 203 where 204 emptyHop :: HopPayload 205 emptyHop = HopPayload Nothing Nothing Nothing Nothing Nothing Nothing [] 206 207 go :: HopPayload -> [TlvRecord] -> Maybe HopPayload 208 go !hp [] = Just hp { hpUnknownTlvs = reverse (hpUnknownTlvs hp) } 209 go !hp (TlvRecord typ val : rest) = case typ of 210 2 -> do 211 amt <- decodeWord64TU val 212 go hp { hpAmtToForward = Just amt } rest 213 4 -> do 214 cltv <- decodeWord32TU val 215 go hp { hpOutgoingCltv = Just cltv } rest 216 6 -> do 217 sci <- decodeShortChannelId val 218 go hp { hpShortChannelId = Just sci } rest 219 8 -> do 220 pd <- decodePaymentData val 221 go hp { hpPaymentData = Just pd } rest 222 10 -> go hp { hpEncryptedData = Just val } rest 223 12 -> go hp { hpCurrentPathKey = Just val } rest 224 _ -> go hp { hpUnknownTlvs = TlvRecord typ val : hpUnknownTlvs hp } rest 225 226 -- ShortChannelId ----------------------------------------------------------- 227 228 -- | Encode ShortChannelId to 8 bytes. 229 -- Format: 3 bytes block || 3 bytes tx || 2 bytes output (all BE) 230 encodeShortChannelId :: ShortChannelId -> BS.ByteString 231 encodeShortChannelId (ShortChannelId !blk !tx !out) = toStrict $ 232 -- Block height: 3 bytes 233 B.word8 (fromIntegral (blk `shiftR` 16) .&. 0xFF) <> 234 B.word8 (fromIntegral (blk `shiftR` 8) .&. 0xFF) <> 235 B.word8 (fromIntegral blk .&. 0xFF) <> 236 -- Tx index: 3 bytes 237 B.word8 (fromIntegral (tx `shiftR` 16) .&. 0xFF) <> 238 B.word8 (fromIntegral (tx `shiftR` 8) .&. 0xFF) <> 239 B.word8 (fromIntegral tx .&. 0xFF) <> 240 -- Output index: 2 bytes 241 B.word16BE out 242 {-# INLINE encodeShortChannelId #-} 243 244 -- | Decode ShortChannelId from 8 bytes. 245 decodeShortChannelId :: BS.ByteString -> Maybe ShortChannelId 246 decodeShortChannelId !bs 247 | BS.length bs /= 8 = Nothing 248 | otherwise = 249 let !b0 = fromIntegral (BS.index bs 0) :: Word32 250 !b1 = fromIntegral (BS.index bs 1) :: Word32 251 !b2 = fromIntegral (BS.index bs 2) :: Word32 252 !blk = (b0 `shiftL` 16) + (b1 `shiftL` 8) + b2 253 !t0 = fromIntegral (BS.index bs 3) :: Word32 254 !t1 = fromIntegral (BS.index bs 4) :: Word32 255 !t2 = fromIntegral (BS.index bs 5) :: Word32 256 !tx = (t0 `shiftL` 16) + (t1 `shiftL` 8) + t2 257 !o0 = fromIntegral (BS.index bs 6) :: Word16 258 !o1 = fromIntegral (BS.index bs 7) :: Word16 259 !out = (o0 `shiftL` 8) + o1 260 in Just (ShortChannelId blk tx out) 261 {-# INLINE decodeShortChannelId #-} 262 263 -- Failure messages --------------------------------------------------------- 264 265 -- | Encode failure message. 266 encodeFailureMessage :: FailureMessage -> BS.ByteString 267 encodeFailureMessage (FailureMessage (FailureCode !code) !dat !tlvs) = 268 toStrict $ 269 B.word16BE code <> 270 B.word16BE (fromIntegral (BS.length dat)) <> 271 B.byteString dat <> 272 B.byteString (encodeTlvStream tlvs) 273 {-# INLINE encodeFailureMessage #-} 274 275 -- | Decode failure message. 276 decodeFailureMessage :: BS.ByteString -> Maybe FailureMessage 277 decodeFailureMessage !bs = do 278 if BS.length bs < 4 then Nothing else do 279 let !code = word16BE (BS.take 2 bs) 280 !dlen = fromIntegral (word16BE (BS.take 2 (BS.drop 2 bs))) 281 if BS.length bs < 4 + dlen then Nothing else do 282 let !dat = BS.take dlen (BS.drop 4 bs) 283 !tlvBytes = BS.drop (4 + dlen) bs 284 tlvs <- if BS.null tlvBytes 285 then Just [] 286 else decodeTlvStream tlvBytes 287 Just (FailureMessage (FailureCode code) dat tlvs) 288 289 -- Helper functions --------------------------------------------------------- 290 291 -- | Convert Builder to strict ByteString. 292 toStrict :: B.Builder -> BS.ByteString 293 toStrict = BL.toStrict . B.toLazyByteString 294 {-# INLINE toStrict #-} 295 296 -- | Decode big-endian Word16. 297 word16BE :: BS.ByteString -> Word16 298 word16BE !bs = 299 let !b0 = fromIntegral (BS.index bs 0) :: Word16 300 !b1 = fromIntegral (BS.index bs 1) :: Word16 301 in (b0 `shiftL` 8) + b1 302 {-# INLINE word16BE #-} 303 304 -- | Decode big-endian Word32. 305 word32BE :: BS.ByteString -> Word32 306 word32BE !bs = 307 let !b0 = fromIntegral (BS.index bs 0) :: Word32 308 !b1 = fromIntegral (BS.index bs 1) :: Word32 309 !b2 = fromIntegral (BS.index bs 2) :: Word32 310 !b3 = fromIntegral (BS.index bs 3) :: Word32 311 in (b0 `shiftL` 24) + (b1 `shiftL` 16) + (b2 `shiftL` 8) + b3 312 {-# INLINE word32BE #-} 313 314 -- | Decode big-endian Word64. 315 word64BE :: BS.ByteString -> Word64 316 word64BE !bs = 317 let !b0 = fromIntegral (BS.index bs 0) :: Word64 318 !b1 = fromIntegral (BS.index bs 1) :: Word64 319 !b2 = fromIntegral (BS.index bs 2) :: Word64 320 !b3 = fromIntegral (BS.index bs 3) :: Word64 321 !b4 = fromIntegral (BS.index bs 4) :: Word64 322 !b5 = fromIntegral (BS.index bs 5) :: Word64 323 !b6 = fromIntegral (BS.index bs 6) :: Word64 324 !b7 = fromIntegral (BS.index bs 7) :: Word64 325 in (b0 `shiftL` 56) + (b1 `shiftL` 48) + (b2 `shiftL` 40) + 326 (b3 `shiftL` 32) + (b4 `shiftL` 24) + (b5 `shiftL` 16) + 327 (b6 `shiftL` 8) + b7 328 {-# INLINE word64BE #-} 329 330 -- | Encode Word64 as truncated unsigned (minimal bytes). 331 encodeWord64TU :: Word64 -> BS.ByteString 332 encodeWord64TU !n 333 | n == 0 = BS.empty 334 | otherwise = BS.dropWhile (== 0) (toStrict (B.word64BE n)) 335 {-# INLINE encodeWord64TU #-} 336 337 -- | Decode truncated unsigned to Word64. 338 decodeWord64TU :: BS.ByteString -> Maybe Word64 339 decodeWord64TU !bs 340 | BS.null bs = Just 0 341 | BS.length bs > 8 = Nothing 342 | not (BS.null bs) && BS.index bs 0 == 0 = Nothing -- Non-canonical 343 | otherwise = Just (go 0 bs) 344 where 345 go :: Word64 -> BS.ByteString -> Word64 346 go !acc !b = case BS.uncons b of 347 Nothing -> acc 348 Just (x, rest) -> go ((acc `shiftL` 8) + fromIntegral x) rest 349 {-# INLINE decodeWord64TU #-} 350 351 -- | Encode Word32 as truncated unsigned. 352 encodeWord32TU :: Word32 -> BS.ByteString 353 encodeWord32TU !n 354 | n == 0 = BS.empty 355 | otherwise = BS.dropWhile (== 0) (toStrict (B.word32BE n)) 356 {-# INLINE encodeWord32TU #-} 357 358 -- | Decode truncated unsigned to Word32. 359 decodeWord32TU :: BS.ByteString -> Maybe Word32 360 decodeWord32TU !bs 361 | BS.null bs = Just 0 362 | BS.length bs > 4 = Nothing 363 | not (BS.null bs) && BS.index bs 0 == 0 = Nothing -- Non-canonical 364 | otherwise = Just (go 0 bs) 365 where 366 go :: Word32 -> BS.ByteString -> Word32 367 go !acc !b = case BS.uncons b of 368 Nothing -> acc 369 Just (x, rest) -> go ((acc `shiftL` 8) + fromIntegral x) rest 370 {-# INLINE decodeWord32TU #-} 371 372 -- | Encode PaymentData. 373 encodePaymentData :: PaymentData -> BS.ByteString 374 encodePaymentData (PaymentData !secret !total) = 375 secret <> encodeWord64TU total 376 {-# INLINE encodePaymentData #-} 377 378 -- | Decode PaymentData. 379 decodePaymentData :: BS.ByteString -> Maybe PaymentData 380 decodePaymentData !bs 381 | BS.length bs < 32 = Nothing 382 | otherwise = do 383 let !secret = BS.take 32 bs 384 !rest = BS.drop 32 bs 385 total <- decodeWord64TU rest 386 Just (PaymentData secret total) 387 {-# INLINE decodePaymentData #-}