Codec.hs (13027B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DeriveGeneric #-} 4 {-# LANGUAGE DerivingStrategies #-} 5 {-# LANGUAGE LambdaCase #-} 6 7 -- | 8 -- Module: Lightning.Protocol.BOLT1.Codec 9 -- Copyright: (c) 2025 Jared Tobin 10 -- License: MIT 11 -- Maintainer: Jared Tobin <jared@ppad.tech> 12 -- 13 -- Message encoding and decoding for BOLT #1. 14 15 module Lightning.Protocol.BOLT1.Codec ( 16 -- * Encoding errors 17 EncodeError(..) 18 19 -- * Message encoding 20 , encodeInit 21 , encodeError 22 , encodeWarning 23 , encodePing 24 , encodePong 25 , encodePeerStorage 26 , encodePeerStorageRetrieval 27 , encodeMessage 28 , encodeEnvelope 29 30 -- * Decoding errors 31 , DecodeError(..) 32 33 -- * Message decoding 34 , decodeInit 35 , decodeError 36 , decodeWarning 37 , decodePing 38 , decodePong 39 , decodePeerStorage 40 , decodePeerStorageRetrieval 41 , decodeMessage 42 , decodeEnvelope 43 , decodeEnvelopeWith 44 ) where 45 46 import Control.DeepSeq (NFData) 47 import Control.Monad (when, unless) 48 import qualified Data.ByteString as BS 49 import Data.Word (Word16, Word64) 50 import GHC.Generics (Generic) 51 import Lightning.Protocol.BOLT1.Prim 52 import Lightning.Protocol.BOLT1.TLV 53 import Lightning.Protocol.BOLT1.Message 54 55 -- Encoding errors ------------------------------------------------------------- 56 57 -- | Encoding errors. 58 data EncodeError 59 = EncodeLengthOverflow -- ^ Field length exceeds u16 max (65535 bytes) 60 | EncodeMessageTooLarge -- ^ Total message size exceeds 65535 bytes 61 deriving stock (Eq, Show, Generic) 62 63 instance NFData EncodeError 64 65 -- Message encoding ------------------------------------------------------------ 66 67 -- | Encode an Init message payload. 68 encodeInit :: Init -> Either EncodeError BS.ByteString 69 encodeInit (Init gf feat tlvs) = do 70 gfLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength gf) 71 featLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength feat) 72 Right $ mconcat 73 [ gfLen 74 , gf 75 , featLen 76 , feat 77 , encodeTlvStream (encodeInitTlvs tlvs) 78 ] 79 80 -- | Encode an Error message payload. 81 encodeError :: Error -> Either EncodeError BS.ByteString 82 encodeError (Error cid dat) = do 83 datLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength dat) 84 Right $ mconcat [unChannelId cid, datLen, dat] 85 86 -- | Encode a Warning message payload. 87 encodeWarning :: Warning -> Either EncodeError BS.ByteString 88 encodeWarning (Warning cid dat) = do 89 datLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength dat) 90 Right $ mconcat [unChannelId cid, datLen, dat] 91 92 -- | Encode a Ping message payload. 93 encodePing :: Ping -> Either EncodeError BS.ByteString 94 encodePing (Ping numPong ignored) = do 95 ignoredLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength ignored) 96 Right $ mconcat [encodeU16 numPong, ignoredLen, ignored] 97 98 -- | Encode a Pong message payload. 99 encodePong :: Pong -> Either EncodeError BS.ByteString 100 encodePong (Pong ignored) = do 101 ignoredLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength ignored) 102 Right $ mconcat [ignoredLen, ignored] 103 104 -- | Encode a PeerStorage message payload. 105 encodePeerStorage :: PeerStorage -> Either EncodeError BS.ByteString 106 encodePeerStorage (PeerStorage blob) = do 107 blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob) 108 Right $ mconcat [blobLen, blob] 109 110 -- | Encode a PeerStorageRetrieval message payload. 111 encodePeerStorageRetrieval 112 :: PeerStorageRetrieval -> Either EncodeError BS.ByteString 113 encodePeerStorageRetrieval (PeerStorageRetrieval blob) = do 114 blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob) 115 Right $ mconcat [blobLen, blob] 116 117 -- | Encode a message to its payload bytes. 118 -- 119 -- Checks that the payload does not exceed 65533 bytes (the maximum 120 -- possible given the 2-byte type field and 65535-byte message limit). 121 encodeMessage :: Message -> Either EncodeError BS.ByteString 122 encodeMessage msg = do 123 payload <- case msg of 124 MsgInitVal m -> encodeInit m 125 MsgErrorVal m -> encodeError m 126 MsgWarningVal m -> encodeWarning m 127 MsgPingVal m -> encodePing m 128 MsgPongVal m -> encodePong m 129 MsgPeerStorageVal m -> encodePeerStorage m 130 MsgPeerStorageRetrievalVal m -> encodePeerStorageRetrieval m 131 -- Payload must leave room for 2-byte type (max 65533 bytes) 132 when (BS.length payload > 65533) $ 133 Left EncodeMessageTooLarge 134 Right payload 135 136 -- | Encode a message as a complete envelope (type + payload + extension). 137 -- 138 -- Per BOLT #1, the total message size must not exceed 65535 bytes. 139 encodeEnvelope :: Message -> Maybe TlvStream -> Either EncodeError BS.ByteString 140 encodeEnvelope msg mext = do 141 payload <- encodeMessage msg 142 let !typeBytes = encodeU16 (msgTypeWord (messageType msg)) 143 !extBytes = maybe BS.empty encodeTlvStream mext 144 !result = mconcat [typeBytes, payload, extBytes] 145 -- Per BOLT #1: message size must fit in 2 bytes (max 65535) 146 when (BS.length result > 65535) $ 147 Left EncodeMessageTooLarge 148 Right result 149 150 -- Decoding errors ------------------------------------------------------------- 151 152 -- | Decoding errors. 153 data DecodeError 154 = DecodeInsufficientBytes 155 | DecodeInvalidLength 156 | DecodeUnknownEvenType !Word16 157 | DecodeUnknownOddType !Word16 158 | DecodeTlvError !TlvError 159 | DecodeInvalidChannelId 160 | DecodeInvalidExtension !TlvError 161 deriving stock (Eq, Show, Generic) 162 163 instance NFData DecodeError 164 165 -- Message decoding ------------------------------------------------------------ 166 167 -- | Decode an Init message from payload bytes. 168 -- 169 -- Returns the decoded message and any remaining bytes. 170 decodeInit :: BS.ByteString -> Either DecodeError (Init, BS.ByteString) 171 decodeInit !bs = do 172 (gfLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right 173 (decodeU16 bs) 174 unless (BS.length rest1 >= fromIntegral gfLen) $ 175 Left DecodeInsufficientBytes 176 let !gf = BS.take (fromIntegral gfLen) rest1 177 !rest2 = BS.drop (fromIntegral gfLen) rest1 178 (fLen, rest3) <- maybe (Left DecodeInsufficientBytes) Right 179 (decodeU16 rest2) 180 unless (BS.length rest3 >= fromIntegral fLen) $ 181 Left DecodeInsufficientBytes 182 let !feat = BS.take (fromIntegral fLen) rest3 183 !rest4 = BS.drop (fromIntegral fLen) rest3 184 -- Parse optional TLV stream (consumes all remaining bytes for init) 185 tlvs <- if BS.null rest4 186 then Right (unsafeTlvStream []) 187 else either (Left . DecodeTlvError) Right (decodeTlvStream rest4) 188 initTlvList <- either (Left . DecodeTlvError) Right 189 (parseInitTlvs tlvs) 190 -- Init consumes all bytes (TLVs are part of init, not extensions) 191 Right (Init gf feat initTlvList, BS.empty) 192 193 -- | Decode an Error message from payload bytes. 194 decodeError :: BS.ByteString -> Either DecodeError (Error, BS.ByteString) 195 decodeError !bs = do 196 unless (BS.length bs >= 32) $ Left DecodeInsufficientBytes 197 let !cidBytes = BS.take 32 bs 198 !rest1 = BS.drop 32 bs 199 cid <- maybe (Left DecodeInvalidChannelId) Right (channelId cidBytes) 200 (dLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right 201 (decodeU16 rest1) 202 unless (BS.length rest2 >= fromIntegral dLen) $ 203 Left DecodeInsufficientBytes 204 let !dat = BS.take (fromIntegral dLen) rest2 205 !rest3 = BS.drop (fromIntegral dLen) rest2 206 Right (Error cid dat, rest3) 207 208 -- | Decode a Warning message from payload bytes. 209 decodeWarning :: BS.ByteString -> Either DecodeError (Warning, BS.ByteString) 210 decodeWarning !bs = do 211 unless (BS.length bs >= 32) $ Left DecodeInsufficientBytes 212 let !cidBytes = BS.take 32 bs 213 !rest1 = BS.drop 32 bs 214 cid <- maybe (Left DecodeInvalidChannelId) Right (channelId cidBytes) 215 (dLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right 216 (decodeU16 rest1) 217 unless (BS.length rest2 >= fromIntegral dLen) $ 218 Left DecodeInsufficientBytes 219 let !dat = BS.take (fromIntegral dLen) rest2 220 !rest3 = BS.drop (fromIntegral dLen) rest2 221 Right (Warning cid dat, rest3) 222 223 -- | Decode a Ping message from payload bytes. 224 decodePing :: BS.ByteString -> Either DecodeError (Ping, BS.ByteString) 225 decodePing !bs = do 226 (numPong, rest1) <- maybe (Left DecodeInsufficientBytes) Right 227 (decodeU16 bs) 228 (bLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right 229 (decodeU16 rest1) 230 unless (BS.length rest2 >= fromIntegral bLen) $ 231 Left DecodeInsufficientBytes 232 let !ignored = BS.take (fromIntegral bLen) rest2 233 !rest3 = BS.drop (fromIntegral bLen) rest2 234 Right (Ping numPong ignored, rest3) 235 236 -- | Decode a Pong message from payload bytes. 237 decodePong :: BS.ByteString -> Either DecodeError (Pong, BS.ByteString) 238 decodePong !bs = do 239 (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right 240 (decodeU16 bs) 241 unless (BS.length rest1 >= fromIntegral bLen) $ 242 Left DecodeInsufficientBytes 243 let !ignored = BS.take (fromIntegral bLen) rest1 244 !rest2 = BS.drop (fromIntegral bLen) rest1 245 Right (Pong ignored, rest2) 246 247 -- | Decode a PeerStorage message from payload bytes. 248 decodePeerStorage 249 :: BS.ByteString -> Either DecodeError (PeerStorage, BS.ByteString) 250 decodePeerStorage !bs = do 251 (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right 252 (decodeU16 bs) 253 unless (BS.length rest1 >= fromIntegral bLen) $ 254 Left DecodeInsufficientBytes 255 let !blob = BS.take (fromIntegral bLen) rest1 256 !rest2 = BS.drop (fromIntegral bLen) rest1 257 Right (PeerStorage blob, rest2) 258 259 -- | Decode a PeerStorageRetrieval message from payload bytes. 260 decodePeerStorageRetrieval 261 :: BS.ByteString 262 -> Either DecodeError (PeerStorageRetrieval, BS.ByteString) 263 decodePeerStorageRetrieval !bs = do 264 (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right 265 (decodeU16 bs) 266 unless (BS.length rest1 >= fromIntegral bLen) $ 267 Left DecodeInsufficientBytes 268 let !blob = BS.take (fromIntegral bLen) rest1 269 !rest2 = BS.drop (fromIntegral bLen) rest1 270 Right (PeerStorageRetrieval blob, rest2) 271 272 -- | Decode a message from its type and payload. 273 -- 274 -- Returns the decoded message and any remaining bytes (for extensions). 275 -- For unknown types, returns an appropriate error. 276 decodeMessage 277 :: MsgType -> BS.ByteString -> Either DecodeError (Message, BS.ByteString) 278 decodeMessage MsgInit bs = do 279 (m, rest) <- decodeInit bs 280 Right (MsgInitVal m, rest) 281 decodeMessage MsgError bs = do 282 (m, rest) <- decodeError bs 283 Right (MsgErrorVal m, rest) 284 decodeMessage MsgWarning bs = do 285 (m, rest) <- decodeWarning bs 286 Right (MsgWarningVal m, rest) 287 decodeMessage MsgPing bs = do 288 (m, rest) <- decodePing bs 289 Right (MsgPingVal m, rest) 290 decodeMessage MsgPong bs = do 291 (m, rest) <- decodePong bs 292 Right (MsgPongVal m, rest) 293 decodeMessage MsgPeerStorage bs = do 294 (m, rest) <- decodePeerStorage bs 295 Right (MsgPeerStorageVal m, rest) 296 decodeMessage MsgPeerStorageRet bs = do 297 (m, rest) <- decodePeerStorageRetrieval bs 298 Right (MsgPeerStorageRetrievalVal m, rest) 299 decodeMessage (MsgUnknown w) _ 300 | even w = Left (DecodeUnknownEvenType w) 301 | otherwise = Left (DecodeUnknownOddType w) 302 303 -- | Decode a complete envelope (type + payload + optional extension). 304 -- 305 -- Per BOLT #1: 306 -- - Unknown odd message types are ignored (returns Nothing for message) 307 -- - Unknown even message types cause connection close (returns error) 308 -- - Invalid extension TLV causes connection close (returns error) 309 -- 310 -- This uses the default policy of treating all extension TLV types as 311 -- unknown. Use 'decodeEnvelopeWith' for configurable extension handling. 312 -- 313 -- Returns the decoded message (if known) and any extension TLVs. 314 decodeEnvelope 315 :: BS.ByteString 316 -> Either DecodeError (Maybe Message, Maybe TlvStream) 317 decodeEnvelope = decodeEnvelopeWith (const False) 318 319 -- | Decode a complete envelope with configurable extension TLV handling. 320 -- 321 -- The predicate determines which extension TLV types are "known" and 322 -- should be preserved. Unknown even types cause failure; unknown odd 323 -- types are skipped. 324 -- 325 -- Use @decodeEnvelopeWith (const False)@ to reject all even extension 326 -- types (the default behavior of 'decodeEnvelope'). 327 -- 328 -- Use @decodeEnvelopeWith (const True)@ to accept all extension types. 329 decodeEnvelopeWith 330 :: (Word64 -> Bool) -- ^ Predicate: is this extension TLV type known? 331 -> BS.ByteString 332 -> Either DecodeError (Maybe Message, Maybe TlvStream) 333 decodeEnvelopeWith isKnownExt !bs = do 334 (typeWord, rest1) <- maybe (Left DecodeInsufficientBytes) Right 335 (decodeU16 bs) 336 let !msgType = parseMsgType typeWord 337 case msgType of 338 MsgUnknown w 339 | even w -> Left (DecodeUnknownEvenType w) 340 | otherwise -> Right (Nothing, Nothing) -- Ignore unknown odd types 341 _ -> do 342 (msg, rest2) <- decodeMessage msgType rest1 343 -- Parse any remaining bytes as extension TLV 344 ext <- if BS.null rest2 345 then Right Nothing 346 else case decodeTlvStreamWith isKnownExt rest2 of 347 Left e -> Left (DecodeInvalidExtension e) 348 Right s -> Right (Just s) 349 Right (Just msg, ext)