Codec.hs (13543B)
1 {-# OPTIONS_HADDOCK hide #-} 2 3 -- | 4 -- Module: Lightning.Protocol.BOLT4.Codec 5 -- Copyright: (c) 2025 Jared Tobin 6 -- License: MIT 7 -- Maintainer: Jared Tobin <jared@ppad.tech> 8 -- 9 -- Encodings of the BOLT #4 types. 10 11 module Lightning.Protocol.BOLT4.Codec ( 12 encode_onion_packet 13 , decode_onion_packet 14 , encode_hop_payload 15 , decode_hop_payload 16 , encode_blinded_hop_data 17 , decode_blinded_hop_data 18 , encode_failure_message 19 , decode_failure_message 20 ) where 21 22 import Data.Bifunctor (first) 23 import qualified Data.ByteString as BS 24 import Data.Maybe (catMaybes) 25 import Data.Word (Word16, Word64) 26 import qualified Lightning.Protocol.BOLT1 as BOLT1 27 import Lightning.Protocol.BOLT4.Types 28 import qualified Lightning.Protocol.BOLT9 as BOLT9 29 30 -- onion packets -------------------------------------------------------------- 31 32 -- | Encode an t'OnionPacket' (1366 bytes). 33 -- 34 -- >>> let Just pk = BOLT1.point (BS.cons 0x02 (BS.replicate 32 0x01)) 35 -- >>> let Just hp = hop_payloads (BS.replicate 1300 0) 36 -- >>> let Just mac = hmac32 (BS.replicate 32 0) 37 -- >>> BS.length (encode_onion_packet (OnionPacket 0 pk hp mac)) 38 -- 1366 39 encode_onion_packet :: OnionPacket -> BS.ByteString 40 encode_onion_packet (OnionPacket v k hp mac) = BS.concat 41 [BS.singleton v, BOLT1.un_point k, un_hop_payloads hp, un_hmac32 mac] 42 43 -- | Decode an t'OnionPacket' from exactly 1366 bytes. The public key must 44 -- carry a compressed-encoding prefix; the version byte is not checked 45 -- (see 'Lightning.Protocol.BOLT4.process'). 46 -- 47 -- >>> decode_onion_packet (BS.replicate 1365 0) 48 -- Left InvalidLength 49 decode_onion_packet :: BS.ByteString -> Either DecodeError OnionPacket 50 decode_onion_packet bs = case BS.uncons bs of 51 Just (v, rest) | BS.length bs == 1366 -> do 52 let (k, r0) = BS.splitAt 33 rest 53 (hp, mac) = BS.splitAt 1300 r0 54 pk <- maybe (Left InvalidPoint) Right (BOLT1.point k) 55 pure (OnionPacket v pk (HopPayloads hp) (Hmac32 mac)) 56 _ -> Left InvalidLength 57 58 -- TLV helpers ---------------------------------------------------------------- 59 60 -- encode typed records with extra ones, none of which may have a known 61 -- type 62 encode_tlvs 63 :: [Word64] 64 -> [BOLT1.TlvRecord] 65 -> BOLT1.TlvStream 66 -> Either EncodeError BS.ByteString 67 encode_tlvs known typed extra 68 | any ((`elem` known) . BOLT1.tlv_type) ex = Left ConflictingTlv 69 | otherwise = case BOLT1.tlv_stream (typed ++ ex) of 70 Nothing -> Left ConflictingTlv 71 Just s -> Right (BOLT1.encode_tlv_stream s) 72 where 73 ex = BOLT1.un_tlv_stream extra 74 75 record :: Word64 -> (a -> BS.ByteString) -> Maybe a -> Maybe BOLT1.TlvRecord 76 record t f = fmap (BOLT1.TlvRecord t . f) 77 78 -- decode a TLV stream with the given known types 79 decode_tlvs :: [Word64] -> BS.ByteString -> Either DecodeError BOLT1.TlvStream 80 decode_tlvs known = 81 first InvalidTlvStream . BOLT1.decode_tlv_stream (`elem` known) 82 83 -- parse the value of a record, if present 84 field 85 :: Word64 86 -> (BS.ByteString -> Maybe a) 87 -> BOLT1.TlvStream 88 -> Either DecodeError (Maybe a) 89 field t p s = case BOLT1.lookup_tlv t s of 90 Nothing -> Right Nothing 91 Just v -> maybe (Left (InvalidTlvValue t)) (Right . Just) (p v) 92 93 -- the unknown records of a stream 94 extra_tlvs :: [Word64] -> BOLT1.TlvStream -> BOLT1.TlvStream 95 extra_tlvs known = BOLT1.filter_tlv_stream (`notElem` known) 96 97 -- a decoder that must consume its whole input 98 whole 99 :: (BS.ByteString -> Maybe (a, BS.ByteString)) 100 -> BS.ByteString 101 -> Maybe a 102 whole d bs = case d bs of 103 Just (a, r) | BS.null r -> Just a 104 _ -> Nothing 105 106 encode_tu_msat :: BOLT1.MilliSatoshi -> BS.ByteString 107 encode_tu_msat = BOLT1.encode_tu64 . BOLT1.un_milli_satoshi 108 109 decode_tu_msat :: BS.ByteString -> Maybe BOLT1.MilliSatoshi 110 decode_tu_msat v = BOLT1.decode_tu64 v >>= BOLT1.milli_satoshi 111 112 -- hop payloads --------------------------------------------------------------- 113 114 hop_payload_types :: [Word64] 115 hop_payload_types = [2, 4, 6, 8, 10, 12, 16, 18] 116 117 -- | Encode a t'HopPayload' as a @payload@ TLV stream (without its length 118 -- prefix). Fails if 'hp_extra' has a record of a known type. 119 -- 120 -- >>> let hp = empty_hop_payload { hp_outgoing_cltv_value = Just 144 } 121 -- >>> encode_hop_payload hp 122 -- Right "\EOT\SOH\144" 123 encode_hop_payload :: HopPayload -> Either EncodeError BS.ByteString 124 encode_hop_payload hp = encode_tlvs hop_payload_types typed (hp_extra hp) 125 where 126 typed = catMaybes 127 [ record 2 encode_tu_msat (hp_amt_to_forward hp) 128 , record 4 BOLT1.encode_tu32 (hp_outgoing_cltv_value hp) 129 , record 6 BOLT1.encode_short_channel_id (hp_short_channel_id hp) 130 , record 8 encode_payment_data (hp_payment_data hp) 131 , record 10 id (hp_encrypted_data hp) 132 , record 12 BOLT1.un_point (hp_current_path_key hp) 133 , record 16 id (hp_payment_metadata hp) 134 , record 18 encode_tu_msat (hp_total_amount_msat hp) 135 ] 136 137 -- | Decode a @payload@ TLV stream (without its length prefix). Fails on 138 -- a malformed stream, an unknown even type, or a malformed known 139 -- record. 140 -- 141 -- >>> fmap hp_outgoing_cltv_value (decode_hop_payload "\EOT\SOH\144") 142 -- Right (Just 144) 143 -- >>> decode_hop_payload "\DC4\NUL" 144 -- Left (InvalidTlvStream (TlvUnknownEvenType 20)) 145 decode_hop_payload :: BS.ByteString -> Either DecodeError HopPayload 146 decode_hop_payload bs = do 147 s <- decode_tlvs hop_payload_types bs 148 HopPayload 149 <$> field 2 decode_tu_msat s 150 <*> field 4 BOLT1.decode_tu32 s 151 <*> field 6 (whole BOLT1.decode_short_channel_id) s 152 <*> field 8 decode_payment_data s 153 <*> field 10 Just s 154 <*> field 12 BOLT1.point s 155 <*> field 16 Just s 156 <*> field 18 decode_tu_msat s 157 <*> pure (extra_tlvs hop_payload_types s) 158 159 encode_payment_data :: PaymentData -> BS.ByteString 160 encode_payment_data (PaymentData s t) = un_payment_secret s <> encode_tu_msat t 161 162 decode_payment_data :: BS.ByteString -> Maybe PaymentData 163 decode_payment_data v = do 164 let (s, t) = BS.splitAt 32 v 165 PaymentData <$> payment_secret s <*> decode_tu_msat t 166 167 -- blinded hop data ----------------------------------------------------------- 168 169 blinded_hop_data_types :: [Word64] 170 blinded_hop_data_types = [1, 2, 4, 6, 8, 10, 12, 14] 171 172 -- | Encode t'BlindedHopData' as an @encrypted_data_tlv@ stream. Fails if 173 -- 'bhd_extra' has a record of a known type. 174 encode_blinded_hop_data :: BlindedHopData -> Either EncodeError BS.ByteString 175 encode_blinded_hop_data d = 176 encode_tlvs blinded_hop_data_types typed (bhd_extra d) 177 where 178 typed = catMaybes 179 [ record 1 id (bhd_padding d) 180 , record 2 BOLT1.encode_short_channel_id (bhd_short_channel_id d) 181 , record 4 BOLT1.un_point (bhd_next_node_id d) 182 , record 6 id (bhd_path_id d) 183 , record 8 BOLT1.un_point (bhd_next_path_key_override d) 184 , record 10 encode_payment_relay (bhd_payment_relay d) 185 , record 12 encode_payment_constraints (bhd_payment_constraints d) 186 , record 14 BOLT9.render (bhd_allowed_features d) 187 ] 188 189 -- | Decode an @encrypted_data_tlv@ stream. Fails on a malformed stream, 190 -- an unknown even type, or a malformed known record. 191 -- 192 -- >>> fmap bhd_path_id (decode_blinded_hop_data "\ACK\apath id") 193 -- Right (Just "path id") 194 decode_blinded_hop_data :: BS.ByteString -> Either DecodeError BlindedHopData 195 decode_blinded_hop_data bs = do 196 s <- decode_tlvs blinded_hop_data_types bs 197 BlindedHopData 198 <$> field 1 Just s 199 <*> field 2 (whole BOLT1.decode_short_channel_id) s 200 <*> field 4 BOLT1.point s 201 <*> field 6 Just s 202 <*> field 8 BOLT1.point s 203 <*> field 10 decode_payment_relay s 204 <*> field 12 decode_payment_constraints s 205 <*> field 14 (Just . BOLT9.parse) s 206 <*> pure (extra_tlvs blinded_hop_data_types s) 207 208 encode_payment_relay :: PaymentRelay -> BS.ByteString 209 encode_payment_relay (PaymentRelay c p b) = 210 BOLT1.encode_u16 c <> BOLT1.encode_u32 p <> BOLT1.encode_tu32 b 211 212 decode_payment_relay :: BS.ByteString -> Maybe PaymentRelay 213 decode_payment_relay v = do 214 (c, r0) <- BOLT1.decode_u16 v 215 (p, r1) <- BOLT1.decode_u32 r0 216 PaymentRelay c p <$> BOLT1.decode_tu32 r1 217 218 encode_payment_constraints :: PaymentConstraints -> BS.ByteString 219 encode_payment_constraints (PaymentConstraints c m) = 220 BOLT1.encode_u32 c <> encode_tu_msat m 221 222 decode_payment_constraints :: BS.ByteString -> Maybe PaymentConstraints 223 decode_payment_constraints v = do 224 (c, r) <- BOLT1.decode_u32 v 225 PaymentConstraints c <$> decode_tu_msat r 226 227 -- failure messages ----------------------------------------------------------- 228 229 -- | Encode a t'FailureMessage': the failure code, its data and the TLV 230 -- stream. Fails if a @channel_update@ exceeds 65535 bytes. 231 -- 232 -- >>> let tlvs = BOLT1.empty_tlv_stream 233 -- >>> encode_failure_message (FailureMessage TemporaryNodeFailure tlvs) 234 -- Right " \STX" 235 encode_failure_message :: FailureMessage -> Either EncodeError BS.ByteString 236 encode_failure_message (FailureMessage f tlvs) = do 237 body <- encode_failure f 238 pure (BOLT1.encode_u16 (failure_code f) <> body 239 <> BOLT1.encode_tlv_stream tlvs) 240 241 encode_failure :: Failure -> Either EncodeError BS.ByteString 242 encode_failure f = case f of 243 TemporaryNodeFailure -> Right mempty 244 PermanentNodeFailure -> Right mempty 245 RequiredNodeFeatureMissing -> Right mempty 246 InvalidOnionVersion h -> Right (un_onion_hash h) 247 InvalidOnionHmac h -> Right (un_onion_hash h) 248 InvalidOnionKey h -> Right (un_onion_hash h) 249 TemporaryChannelFailure u -> update u 250 PermanentChannelFailure -> Right mempty 251 RequiredChannelFeatureMissing -> Right mempty 252 UnknownNextPeer -> Right mempty 253 AmountBelowMinimum m u -> (msat m <>) <$> update u 254 FeeInsufficient m u -> (msat m <>) <$> update u 255 IncorrectCltvExpiry c u -> (BOLT1.encode_u32 c <>) <$> update u 256 ExpiryTooSoon u -> update u 257 IncorrectOrUnknownPaymentDetails m h -> Right (msat m <> BOLT1.encode_u32 h) 258 FinalIncorrectCltvExpiry c -> Right (BOLT1.encode_u32 c) 259 FinalIncorrectHtlcAmount m -> Right (msat m) 260 ChannelDisabled d u -> (BOLT1.encode_u16 d <>) <$> update u 261 ExpiryTooFar -> Right mempty 262 InvalidOnionPayload Nothing -> Right mempty 263 InvalidOnionPayload (Just (t, o)) -> 264 Right (BOLT1.encode_bigsize t <> BOLT1.encode_u16 o) 265 MppTimeout -> Right mempty 266 InvalidOnionBlinding h -> Right (un_onion_hash h) 267 UnknownFailure _ d -> Right d 268 where 269 msat = BOLT1.encode_milli_satoshi 270 update = maybe (Left FieldTooLong) Right . BOLT1.encode_u16_prefixed 271 272 -- | Decode a failure message. 273 -- 274 -- Per BOLT #4, bytes following a failure's data are ignored unless 275 -- they form a valid TLV stream (which, as no failure TLV types are 276 -- defined, may hold only odd types). The data of an unknown failure 277 -- code is every byte following it. 278 -- 279 -- >>> fmap fm_failure (decode_failure_message " \STX") 280 -- Right TemporaryNodeFailure 281 -- >>> decode_failure_message "\DLE\r" 282 -- Left (InvalidFailureData 4109) 283 decode_failure_message :: BS.ByteString -> Either DecodeError FailureMessage 284 decode_failure_message bs = case BOLT1.decode_u16 bs of 285 Nothing -> Left InvalidLength 286 Just (c, rest) -> case decode_failure c rest of 287 Nothing -> Left (InvalidFailureData c) 288 Just (f, extra) -> 289 let tlvs = either (const BOLT1.empty_tlv_stream) id 290 (BOLT1.decode_tlv_stream (const False) extra) 291 in Right (FailureMessage f tlvs) 292 293 decode_failure :: Word16 -> BS.ByteString -> Maybe (Failure, BS.ByteString) 294 decode_failure c bs = case c of 295 0x2002 -> plain TemporaryNodeFailure 296 0x6002 -> plain PermanentNodeFailure 297 0x6003 -> plain RequiredNodeFeatureMissing 298 0xc004 -> hashed InvalidOnionVersion 299 0xc005 -> hashed InvalidOnionHmac 300 0xc006 -> hashed InvalidOnionKey 301 0x1007 -> do 302 (u, r) <- update bs 303 pure (TemporaryChannelFailure u, r) 304 0x4008 -> plain PermanentChannelFailure 305 0x4009 -> plain RequiredChannelFeatureMissing 306 0x400a -> plain UnknownNextPeer 307 0x100b -> do 308 (m, r0) <- BOLT1.decode_milli_satoshi bs 309 (u, r1) <- update r0 310 pure (AmountBelowMinimum m u, r1) 311 0x100c -> do 312 (m, r0) <- BOLT1.decode_milli_satoshi bs 313 (u, r1) <- update r0 314 pure (FeeInsufficient m u, r1) 315 0x100d -> do 316 (e, r0) <- BOLT1.decode_u32 bs 317 (u, r1) <- update r0 318 pure (IncorrectCltvExpiry e u, r1) 319 0x100e -> do 320 (u, r) <- update bs 321 pure (ExpiryTooSoon u, r) 322 0x400f -> do 323 (m, r0) <- BOLT1.decode_milli_satoshi bs 324 (h, r1) <- BOLT1.decode_u32 r0 325 pure (IncorrectOrUnknownPaymentDetails m h, r1) 326 0x0012 -> do 327 (e, r) <- BOLT1.decode_u32 bs 328 pure (FinalIncorrectCltvExpiry e, r) 329 0x0013 -> do 330 (m, r) <- BOLT1.decode_milli_satoshi bs 331 pure (FinalIncorrectHtlcAmount m, r) 332 0x1014 -> do 333 (d, r0) <- BOLT1.decode_u16 bs 334 (u, r1) <- update r0 335 pure (ChannelDisabled d u, r1) 336 0x0015 -> plain ExpiryTooFar 337 0x4016 -> Just $ case BOLT1.decode_bigsize bs of 338 Just (t, r0) | Just (o, r1) <- BOLT1.decode_u16 r0 -> 339 (InvalidOnionPayload (Just (t, o)), r1) 340 _ -> (InvalidOnionPayload Nothing, bs) 341 0x0017 -> plain MppTimeout 342 0xc018 -> hashed InvalidOnionBlinding 343 _ -> Just (UnknownFailure c bs, BS.empty) 344 where 345 plain f = Just (f, bs) 346 hashed g 347 | BS.length bs < 32 = Nothing 348 | otherwise = 349 let (h, r) = BS.splitAt 32 bs 350 in Just (g (OnionHash h), r) 351 update = BOLT1.decode_u16_prefixed