bolt1

Base Lightning protocol, per BOLT #1 (docs.ppad.tech/bolt1).
git clone git://git.ppad.tech/bolt1.git
Log | Files | Refs | README | LICENSE

Codec.hs (9900B)

      1 {-# OPTIONS_HADDOCK hide #-}
      2 {-# LANGUAGE BangPatterns #-}
      3 {-# LANGUAGE DeriveGeneric #-}
      4 
      5 -- |
      6 -- Module: Lightning.Protocol.BOLT1.Codec
      7 -- Copyright: (c) 2025 Jared Tobin
      8 -- License: MIT
      9 -- Maintainer: Jared Tobin <jared@ppad.tech>
     10 --
     11 -- Encoding and decoding of BOLT #1 messages.
     12 
     13 module Lightning.Protocol.BOLT1.Codec (
     14     EncodeError(..)
     15   , DecodeError(..)
     16 
     17   , encode_envelope
     18   , decode_envelope
     19 
     20   , encode_message
     21   , decode_message
     22 
     23   , encode_init
     24   , decode_init
     25   , encode_error
     26   , decode_error
     27   , encode_warning
     28   , decode_warning
     29   , encode_ping
     30   , decode_ping
     31   , encode_pong
     32   , decode_pong
     33   , encode_peer_storage
     34   , decode_peer_storage
     35   , encode_peer_storage_retrieval
     36   , decode_peer_storage_retrieval
     37 
     38   , ping_response
     39   ) where
     40 
     41 import Control.DeepSeq (NFData)
     42 import qualified Data.ByteString as BS
     43 import Data.Word (Word16, Word64)
     44 import GHC.Generics (Generic)
     45 import Lightning.Protocol.BOLT1.Message
     46 import Lightning.Protocol.BOLT1.Prim
     47 import Lightning.Protocol.BOLT1.TLV
     48 import qualified Lightning.Protocol.BOLT9 as BOLT9
     49 
     50 -- | Why a message failed to encode.
     51 data EncodeError
     52   = EncodeLengthOverflow
     53     -- ^ a length-prefixed field exceeds 65535 bytes
     54   | EncodeMessageTooLarge
     55     -- ^ the message (type and payload) exceeds 65535 bytes
     56   | EncodeInvalidTlvs
     57     -- ^ a record in a @_tlvs@ field duplicates a typed field
     58   deriving (Eq, Show, Generic)
     59 
     60 instance NFData EncodeError
     61 
     62 -- | Why a message failed to decode.
     63 data DecodeError
     64   = DecodeInsufficientBytes
     65     -- ^ the input ended before a field did
     66   | DecodeTlvError !TlvError
     67     -- ^ the message's TLV stream is malformed
     68   | DecodeInvalidTlvValue !Word64
     69     -- ^ a known TLV record (of the given type) has a malformed value
     70   | DecodeUnknownEvenType !Word16
     71     -- ^ an unknown even message type; the connection must be closed
     72   | DecodeUnknownOddType !Word16
     73     -- ^ an unknown odd message type; the message must be ignored
     74   deriving (Eq, Show, Generic)
     75 
     76 instance NFData DecodeError
     77 
     78 -- framing --------------------------------------------------------------------
     79 
     80 -- | Prefix a payload with its message type. Fails if the result
     81 --   exceeds the 65535-byte message limit.
     82 --
     83 --   >>> encode_envelope 19 "\NUL\NUL"
     84 --   Right "\NUL\DC3\NUL\NUL"
     85 encode_envelope :: Word16 -> BS.ByteString -> Either EncodeError BS.ByteString
     86 encode_envelope t payload
     87   | BS.length payload > 65533 = Left EncodeMessageTooLarge
     88   | otherwise                 = Right (encode_u16 t <> payload)
     89 
     90 -- | Split a message into its type and payload.
     91 --
     92 --   >>> decode_envelope "\NUL\DC3\NUL\NUL"
     93 --   Right (19,"\NUL\NUL")
     94 decode_envelope :: BS.ByteString -> Either DecodeError (Word16, BS.ByteString)
     95 decode_envelope bs = case decode_u16 bs of
     96   Just r  -> Right r
     97   Nothing -> Left DecodeInsufficientBytes
     98 
     99 -- | Encode a BOLT #1 message, including its type.
    100 --
    101 --   >>> encode_message (MsgPong (Pong "" empty_tlv_stream))
    102 --   Right "\NUL\DC3\NUL\NUL"
    103 encode_message :: Message -> Either EncodeError BS.ByteString
    104 encode_message m = do
    105   payload <- case m of
    106     MsgInit a                 -> encode_init a
    107     MsgError a                -> encode_error a
    108     MsgWarning a              -> encode_warning a
    109     MsgPing a                 -> encode_ping a
    110     MsgPong a                 -> encode_pong a
    111     MsgPeerStorage a          -> encode_peer_storage a
    112     MsgPeerStorageRetrieval a -> encode_peer_storage_retrieval a
    113   encode_envelope (message_type m) payload
    114 
    115 -- | Decode a BOLT #1 message, including its type.
    116 --
    117 --   A type that BOLT #1 doesn't define yields 'DecodeUnknownEvenType'
    118 --   or 'DecodeUnknownOddType'; callers dispatching messages from other
    119 --   BOLTs should use 'decode_envelope' first.
    120 --
    121 --   >>> decode_message "\NUL\DC3\NUL\NUL"
    122 --   Right (MsgPong (Pong {pong_ignored = "", pong_tlvs = TlvStream []}))
    123 --   >>> decode_message "\NUL\DC4\NUL\NUL"
    124 --   Left (DecodeUnknownEvenType 20)
    125 decode_message :: BS.ByteString -> Either DecodeError Message
    126 decode_message bs = do
    127   (t, payload) <- decode_envelope bs
    128   case t of
    129     16 -> MsgInit <$> decode_init payload
    130     17 -> MsgError <$> decode_error payload
    131     1  -> MsgWarning <$> decode_warning payload
    132     18 -> MsgPing <$> decode_ping payload
    133     19 -> MsgPong <$> decode_pong payload
    134     7  -> MsgPeerStorage <$> decode_peer_storage payload
    135     9  -> MsgPeerStorageRetrieval <$> decode_peer_storage_retrieval payload
    136     _ | even t    -> Left (DecodeUnknownEvenType t)
    137       | otherwise -> Left (DecodeUnknownOddType t)
    138 
    139 -- helpers --------------------------------------------------------------------
    140 
    141 prefixed :: BS.ByteString -> Either EncodeError BS.ByteString
    142 prefixed bs = maybe (Left EncodeLengthOverflow) Right (encode_u16_prefixed bs)
    143 
    144 need :: Maybe a -> Either DecodeError a
    145 need = maybe (Left DecodeInsufficientBytes) Right
    146 {-# INLINE need #-}
    147 
    148 -- an extension stream in which no types are known
    149 extension :: BS.ByteString -> Either DecodeError TlvStream
    150 extension bs = either (Left . DecodeTlvError) Right
    151   (decode_tlv_stream (const False) bs)
    152 
    153 -- init -----------------------------------------------------------------------
    154 
    155 -- | Encode an 'Init' payload.
    156 encode_init :: Init -> Either EncodeError BS.ByteString
    157 encode_init (Init gf f nets addr tlvs) = do
    158   gf' <- prefixed (BOLT9.render gf)
    159   f'  <- prefixed (BOLT9.render f)
    160   let known = maybe [] (\cs -> [TlvRecord 1 (mconcat (map un_chain_hash cs))])
    161                 nets
    162            <> maybe [] (\a -> [TlvRecord 3 a]) addr
    163   stream <- maybe (Left EncodeInvalidTlvs) Right
    164               (tlv_stream (known <> un_tlv_stream tlvs))
    165   pure (gf' <> f' <> encode_tlv_stream stream)
    166 
    167 -- | Decode an 'Init' payload.
    168 decode_init :: BS.ByteString -> Either DecodeError Init
    169 decode_init bs = do
    170   (gf, r0) <- need (decode_u16_prefixed bs)
    171   (f, r1)  <- need (decode_u16_prefixed r0)
    172   stream   <- either (Left . DecodeTlvError) Right
    173                 (decode_tlv_stream (\t -> t == 1 || t == 3) r1)
    174   nets <- traverse networks (lookup_tlv 1 stream)
    175   pure Init
    176     { init_global_features = BOLT9.parse gf
    177     , init_features        = BOLT9.parse f
    178     , init_networks        = nets
    179     , init_remote_addr     = lookup_tlv 3 stream
    180     , init_tlvs            = filter_tlv_stream (\t -> t /= 1 && t /= 3) stream
    181     }
    182   where
    183     networks v
    184       | BS.length v `rem` 32 /= 0 = Left (DecodeInvalidTlvValue 1)
    185       | otherwise = Right (chunks v)
    186     chunks !v = case decode_chain_hash v of
    187       Just (h, rest) -> h : chunks rest
    188       Nothing        -> []
    189 
    190 -- error, warning -------------------------------------------------------------
    191 
    192 -- | Encode an 'Error' payload.
    193 encode_error :: Error -> Either EncodeError BS.ByteString
    194 encode_error (Error cid dat tlvs) = do
    195   dat' <- prefixed dat
    196   pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs)
    197 
    198 -- | Decode an 'Error' payload.
    199 decode_error :: BS.ByteString -> Either DecodeError Error
    200 decode_error bs = do
    201   (cid, r0) <- need (decode_channel_id bs)
    202   (dat, r1) <- need (decode_u16_prefixed r0)
    203   Error cid dat <$> extension r1
    204 
    205 -- | Encode a 'Warning' payload.
    206 encode_warning :: Warning -> Either EncodeError BS.ByteString
    207 encode_warning (Warning cid dat tlvs) = do
    208   dat' <- prefixed dat
    209   pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs)
    210 
    211 -- | Decode a 'Warning' payload.
    212 decode_warning :: BS.ByteString -> Either DecodeError Warning
    213 decode_warning bs = do
    214   (cid, r0) <- need (decode_channel_id bs)
    215   (dat, r1) <- need (decode_u16_prefixed r0)
    216   Warning cid dat <$> extension r1
    217 
    218 -- ping, pong -----------------------------------------------------------------
    219 
    220 -- | Encode a 'Ping' payload.
    221 encode_ping :: Ping -> Either EncodeError BS.ByteString
    222 encode_ping (Ping n ign tlvs) = do
    223   ign' <- prefixed ign
    224   pure (encode_u16 n <> ign' <> encode_tlv_stream tlvs)
    225 
    226 -- | Decode a 'Ping' payload.
    227 decode_ping :: BS.ByteString -> Either DecodeError Ping
    228 decode_ping bs = do
    229   (n, r0)   <- need (decode_u16 bs)
    230   (ign, r1) <- need (decode_u16_prefixed r0)
    231   Ping n ign <$> extension r1
    232 
    233 -- | Encode a 'Pong' payload.
    234 encode_pong :: Pong -> Either EncodeError BS.ByteString
    235 encode_pong (Pong ign tlvs) = do
    236   ign' <- prefixed ign
    237   pure (ign' <> encode_tlv_stream tlvs)
    238 
    239 -- | Decode a 'Pong' payload.
    240 decode_pong :: BS.ByteString -> Either DecodeError Pong
    241 decode_pong bs = do
    242   (ign, r0) <- need (decode_u16_prefixed bs)
    243   Pong ign <$> extension r0
    244 
    245 -- | The 'Pong' a node must send in reply to a 'Ping', if any. Per
    246 --   BOLT #1, a ping requesting 65532 or more bytes is ignored.
    247 --
    248 --   >>> ping_response (Ping 4 "" empty_tlv_stream)
    249 --   Just (Pong {pong_ignored = "\NUL\NUL\NUL\NUL", pong_tlvs = TlvStream []})
    250 --   >>> ping_response (Ping 65532 "" empty_tlv_stream)
    251 --   Nothing
    252 ping_response :: Ping -> Maybe Pong
    253 ping_response (Ping n _ _)
    254   | n >= 65532 = Nothing
    255   | otherwise  =
    256       Just (Pong (BS.replicate (fromIntegral n) 0x00) empty_tlv_stream)
    257 
    258 -- peer storage ---------------------------------------------------------------
    259 
    260 -- | Encode a 'PeerStorage' payload.
    261 encode_peer_storage :: PeerStorage -> Either EncodeError BS.ByteString
    262 encode_peer_storage (PeerStorage blob tlvs) = do
    263   blob' <- prefixed blob
    264   pure (blob' <> encode_tlv_stream tlvs)
    265 
    266 -- | Decode a 'PeerStorage' payload.
    267 decode_peer_storage :: BS.ByteString -> Either DecodeError PeerStorage
    268 decode_peer_storage bs = do
    269   (blob, r0) <- need (decode_u16_prefixed bs)
    270   PeerStorage blob <$> extension r0
    271 
    272 -- | Encode a 'PeerStorageRetrieval' payload.
    273 encode_peer_storage_retrieval
    274   :: PeerStorageRetrieval -> Either EncodeError BS.ByteString
    275 encode_peer_storage_retrieval (PeerStorageRetrieval blob tlvs) = do
    276   blob' <- prefixed blob
    277   pure (blob' <> encode_tlv_stream tlvs)
    278 
    279 -- | Decode a 'PeerStorageRetrieval' payload.
    280 decode_peer_storage_retrieval
    281   :: BS.ByteString -> Either DecodeError PeerStorageRetrieval
    282 decode_peer_storage_retrieval bs = do
    283   (blob, r0) <- need (decode_u16_prefixed bs)
    284   PeerStorageRetrieval blob <$> extension r0