Main.hs (52583B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import Data.Bits ((.&.), (.|.), shiftR, xor) 6 import qualified Data.ByteString as BS 7 import qualified Data.ByteString.Base16 as B16 8 import Data.Word (Word8, Word16, Word32, Word64) 9 import Lightning.Protocol.BOLT1 10 ( ChainHash, Point, ShortChannelId(..), Signature, TlvError(..) 11 , TlvRecord(..), TlvStream ) 12 import qualified Lightning.Protocol.BOLT1 as BOLT1 13 import Lightning.Protocol.BOLT7 14 import qualified Lightning.Protocol.BOLT9 as BOLT9 15 import Test.Tasty 16 import Test.Tasty.HUnit 17 import Test.Tasty.QuickCheck hiding ((.&.)) 18 import Vectors 19 20 main :: IO () 21 main = defaultMain $ testGroup "ppad-bolt7" [ 22 field_tests 23 , spec_vector_tests 24 , mainnet_tests 25 , node_announcement_tests 26 , channel_update_tests 27 , query_tests 28 , other_message_tests 29 , encode_error_tests 30 , dispatch_tests 31 , validation_tests 32 , checksum_tests 33 , property_tests 34 ] 35 36 -- helpers -------------------------------------------------------------------- 37 38 must :: String -> Maybe a -> IO a 39 must what = maybe (assertFailure ("unexpected Nothing: " ++ what)) pure 40 41 expectRight :: Show e => String -> Either e a -> IO a 42 expectRight what = 43 either (\e -> assertFailure (what ++ " failed: " ++ show e)) pure 44 45 hex :: BS.ByteString -> IO BS.ByteString 46 hex h = must ("hex " ++ show h) (B16.decode h) 47 48 -- total helpers for pure contexts (properties) 49 chain_hash_of :: Word8 -> Maybe ChainHash 50 chain_hash_of w = BOLT1.chain_hash (BS.replicate 32 w) 51 52 big_endian :: Int -> Word64 -> BS.ByteString 53 big_endian n w = 54 BS.pack [ fromIntegral (w `shiftR` (8 * i)) | i <- [n - 1, n - 2 .. 0] ] 55 56 u16be :: Int -> BS.ByteString 57 u16be = big_endian 2 . fromIntegral 58 59 -- replace the byte at an offset (no-op past the end) 60 set_byte :: Int -> Word8 -> BS.ByteString -> BS.ByteString 61 set_byte i w bs 62 | i < 0 || i >= BS.length bs = bs 63 | otherwise = BS.take i bs <> BS.singleton w <> BS.drop (i + 1) bs 64 65 -- | Fixture values, built with the smart constructors. 66 data Fx = Fx 67 { fx_chain :: ChainHash 68 , fx_sig :: Signature 69 , fx_node_1 :: Point 70 , fx_node_2 :: Point 71 , fx_cid :: BOLT1.ChannelId 72 , fx_scid :: ShortChannelId 73 , fx_alias :: Alias 74 , fx_scids :: [ShortChannelId] 75 } 76 77 fixtures :: IO Fx 78 fixtures = do 79 ch <- must "chain_hash" (chain_hash_of 0x01) 80 sg <- must "signature" (BOLT1.signature (BS.replicate 64 0xee)) 81 n1 <- must "point" (BOLT1.point (BS.cons 0x02 (BS.replicate 32 0xbb))) 82 n2 <- must "point" (BOLT1.point (BS.cons 0x03 (BS.replicate 32 0xaa))) 83 ci <- must "channel_id" (BOLT1.channel_id (BS.replicate 32 0xcd)) 84 sc <- must "short_channel_id" (BOLT1.short_channel_id 539268 845 1) 85 al <- must "alias" (alias (BS.replicate 32 0)) 86 ss <- must "short_channel_ids" $ traverse 87 (\(b, t, o) -> BOLT1.short_channel_id b t o) 88 [(100000, 1, 0), (200000, 2, 1), (300000, 3, 2)] 89 pure Fx 90 { fx_chain = ch 91 , fx_sig = sg 92 , fx_node_1 = n1 93 , fx_node_2 = n2 94 , fx_cid = ci 95 , fx_scid = sc 96 , fx_alias = al 97 , fx_scids = ss 98 } 99 100 msat :: Word64 -> IO BOLT1.MilliSatoshi 101 msat = must "milli_satoshi" . BOLT1.milli_satoshi 102 103 update_fixture :: Fx -> IO ChannelUpdate 104 update_fixture fx = do 105 hmin <- msat 1000 106 hmax <- msat 1000000000 107 pure ChannelUpdate 108 { cu_signature = fx_sig fx 109 , cu_chain_hash = fx_chain fx 110 , cu_short_channel_id = fx_scid fx 111 , cu_timestamp = 1234567890 112 , cu_message_flags = message_flags Forward 113 , cu_channel_flags = channel_flags NodeOne Enabled 114 , cu_cltv_expiry_delta = 144 115 , cu_htlc_minimum_msat = hmin 116 , cu_fee_base_msat = 1000 117 , cu_fee_proportional_millionths = 100 118 , cu_htlc_maximum_msat = hmax 119 , cu_tlvs = BOLT1.empty_tlv_stream 120 } 121 122 announcement_fixture :: Fx -> ChannelAnnouncement 123 announcement_fixture fx = ChannelAnnouncement 124 { ca_node_signature_1 = fx_sig fx 125 , ca_node_signature_2 = fx_sig fx 126 , ca_bitcoin_signature_1 = fx_sig fx 127 , ca_bitcoin_signature_2 = fx_sig fx 128 , ca_features = BOLT9.empty 129 , ca_chain_hash = fx_chain fx 130 , ca_short_channel_id = fx_scid fx 131 , ca_node_id_1 = fx_node_1 fx 132 , ca_node_id_2 = fx_node_2 fx 133 , ca_bitcoin_key_1 = fx_node_1 fx 134 , ca_bitcoin_key_2 = fx_node_2 fx 135 , ca_tlvs = BOLT1.empty_tlv_stream 136 } 137 138 node_fixture :: Fx -> [Address] -> NodeAnnouncement 139 node_fixture fx addrs = NodeAnnouncement 140 { na_signature = fx_sig fx 141 , na_features = BOLT9.empty 142 , na_timestamp = 1234567890 143 , na_node_id = fx_node_2 fx 144 , na_rgb_color = RgbColor 0xff 0x00 0x00 145 , na_alias = fx_alias fx 146 , na_addresses = addrs 147 , na_unknown_addresses = BS.empty 148 , na_tlvs = BOLT1.empty_tlv_stream 149 } 150 151 tlvs_of :: [TlvRecord] -> IO TlvStream 152 tlvs_of = must "tlv_stream" . BOLT1.tlv_stream 153 154 -- field types ---------------------------------------------------------------- 155 156 field_tests :: TestTree 157 field_tests = testGroup "field types" [ 158 testCase "format_short_channel_id" $ do 159 let fmt b t o = 160 fmap format_short_channel_id (BOLT1.short_channel_id b t o) 161 fmt 539268 845 1 @?= Just "539268x845x1" 162 fmt 0 0 0 @?= Just "0x0x0" 163 fmt 0xffffff 0xffffff 0xffff @?= Just "16777215x16777215x65535" 164 , testCase "message_flags" $ do 165 message_flags Forward @?= MessageFlags 0x01 166 message_flags DontForward @?= MessageFlags 0x03 167 map (message_flags_forwarding . MessageFlags) [0, 1, 2, 3, 0xfd] 168 @?= [Forward, Forward, DontForward, DontForward, Forward] 169 map (has_must_be_one . MessageFlags) [0, 1, 2, 0xfe] 170 @?= [False, True, False, False] 171 , testCase "channel_flags" $ do 172 [ channel_flags d s | d <- [NodeOne, NodeTwo], s <- [Enabled, Disabled] ] 173 @?= map ChannelFlags [0, 2, 1, 3] 174 map (channel_flags_direction . ChannelFlags) [0x04, 0x05, 0xfe] 175 @?= [NodeOne, NodeTwo, NodeOne] 176 map (channel_flags_status . ChannelFlags) [0x04, 0x06, 0xfd] 177 @?= [Enabled, Disabled, Enabled] 178 , testCase "query_flags" $ do 179 query_flags [] @?= QueryFlags 0 180 query_flags [minBound .. maxBound] @?= QueryFlags 31 181 query_flags [WantNodeAnnouncement2, WantChannelUpdate1] @?= QueryFlags 18 182 map (`has_query_flag` QueryFlags 0x25) [minBound .. maxBound] 183 @?= [True, False, True, False, False] 184 , testCase "query_option" $ do 185 query_option [WantChecksums] @?= QueryOption 2 186 map (`has_query_option` QueryOption 0x05) [minBound .. maxBound] 187 @?= [True, False] 188 , testCase "fixed-size constructors check lengths" $ do 189 let lens mk = [ mk (BS.replicate n 0) /= Nothing | n <- [0 .. 40] ] 190 only n = [ k == n | k <- [0 .. 40 :: Int] ] 191 lens alias @?= only 32 192 lens ipv4_addr @?= only 4 193 lens ipv6_addr @?= only 16 194 lens tor_v2_addr @?= only 12 195 lens tor_v3_addr @?= only 35 196 , testCase "hostname" $ do 197 fmap un_hostname (hostname "ln.example.com") @?= Just "ln.example.com" 198 fmap un_hostname (hostname "") @?= Just "" 199 fmap (BS.length . un_hostname) (hostname (BS.replicate 255 0x61)) 200 @?= Just 255 201 hostname (BS.replicate 256 0x61) @?= Nothing 202 let ascii h = fmap is_ascii_hostname (hostname h) 203 ascii "xn--caf-dma" @?= Just True 204 ascii "caf\233" @?= Just False 205 ascii "\0\255" @?= Just False 206 ascii "" @?= Just False 207 , testCase "usable_addresses" $ do 208 v4 <- must "ipv4" (ipv4_addr "\127\0\0\1") 209 v6 <- must "ipv6" (ipv6_addr (BS.replicate 16 1)) 210 t2 <- must "tor v2" (tor_v2_addr (BS.replicate 12 0xaa)) 211 t3 <- must "tor v3" (tor_v3_addr (BS.replicate 35 0xbb)) 212 h1 <- must "hostname" (hostname "a.example.com") 213 h2 <- must "hostname" (hostname "b.example.com") 214 bad <- must "hostname" (hostname "caf\233") 215 usable_addresses 216 [ AddrIPv4 v4 9735, AddrTorV2 t2, AddrIPv6 v6 0, AddrTorV3 t3 9735 217 , AddrDNS h1 9735, AddrDNS h2 9735, AddrIPv6 v6 9735 ] 218 @?= [ AddrIPv4 v4 9735, AddrTorV3 t3 9735, AddrDNS h1 9735 219 , AddrIPv6 v6 9735 ] 220 -- a hostname that is ignored still counts as the first 221 usable_addresses [AddrDNS bad 9735, AddrDNS h1 9735] @?= [] 222 usable_addresses [AddrDNS h1 0, AddrDNS h2 9735] @?= [] 223 ] 224 225 -- extended-queries.json ------------------------------------------------------ 226 227 -- the vectors' chain hash (regtest) 228 regtest :: IO ChainHash 229 regtest = hex 230 "0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206" 231 >>= must "chain_hash" . BOLT1.chain_hash 232 233 scids :: [(Word32, Word32, Word16)] -> IO [ShortChannelId] 234 scids = must "short_channel_id" 235 . traverse (\(b, t, o) -> BOLT1.short_channel_id b t o) 236 237 -- decode a vector, compare with the expected message, and re-encode the 238 -- expected message 239 known_answer :: BS.ByteString -> Message -> Assertion 240 known_answer h expected = do 241 wire <- hex h 242 (t, payload) <- expectRight "decode_envelope" (BOLT1.decode_envelope wire) 243 decode_message t payload @?= Right expected 244 message_type expected @?= t 245 encode_message expected @?= Right payload 246 247 rejected :: BS.ByteString -> DecodeError -> Assertion 248 rejected h err = do 249 wire <- hex h 250 (t, payload) <- expectRight "decode_envelope" (BOLT1.decode_envelope wire) 251 decode_message t payload @?= Left err 252 253 spec_vector_tests :: TestTree 254 spec_vector_tests = testGroup "bolt07/extended-queries.json" $ 255 case query_vectors of 256 [v0, v1, v2, v3, v4, v5, v6, v7, v8, v9] -> [ 257 testCase "0: query_channel_range" $ do 258 ch <- regtest 259 known_answer v0 $ MsgQueryChannelRange 260 (QueryChannelRange ch 100000 1500 Nothing BOLT1.empty_tlv_stream) 261 , testCase "1: query_channel_range with query_option" $ do 262 ch <- regtest 263 known_answer v1 $ MsgQueryChannelRange $ QueryChannelRange ch 264 35000 100 (Just (query_option [WantTimestamps, WantChecksums])) 265 BOLT1.empty_tlv_stream 266 , testCase "2: reply_channel_range" $ do 267 ch <- regtest 268 ss <- scids [(0, 0, 142), (0, 0, 15465), (0, 69, 42692)] 269 known_answer v2 $ MsgReplyChannelRange 270 (ReplyChannelRange ch 756230 1500 True ss Nothing Nothing 271 BOLT1.empty_tlv_stream) 272 , testCase "3: reply_channel_range, zlib (rejected)" $ 273 rejected v3 (DecodeUnknownEncoding 1) 274 , testCase "4: reply_channel_range with timestamps and checksums" $ do 275 ch <- regtest 276 ss <- scids [(0, 0, 12355), (0, 7, 30934), (0, 70, 57793)] 277 known_answer v4 $ MsgReplyChannelRange $ 278 ReplyChannelRange ch 122334 1500 True ss 279 (Just [ ChannelUpdateTimestamps 164545 948165 280 , ChannelUpdateTimestamps 489645 4786864 281 , ChannelUpdateTimestamps 46456 9788415 ]) 282 (Just [ ChannelUpdateChecksums 1111 2222 283 , ChannelUpdateChecksums 3333 4444 284 , ChannelUpdateChecksums 5555 6666 ]) 285 BOLT1.empty_tlv_stream 286 , testCase "5: reply_channel_range, zlib (rejected)" $ 287 rejected v5 (DecodeUnknownEncoding 1) 288 , testCase "6: query_short_channel_ids" $ do 289 ch <- regtest 290 ss <- scids [(0, 0, 142), (0, 0, 15465), (0, 69, 42692)] 291 known_answer v6 $ MsgQueryShortChannelIds 292 (QueryShortChannelIds ch ss Nothing BOLT1.empty_tlv_stream) 293 , testCase "7: query_short_channel_ids, zlib (rejected)" $ 294 rejected v7 (DecodeUnknownEncoding 1) 295 , testCase "8: query_short_channel_ids, zlib query_flags (rejected)" $ 296 rejected v8 (DecodeUnknownEncoding 1) 297 , testCase "9: query_short_channel_ids, zlib (rejected)" $ 298 rejected v9 (DecodeUnknownEncoding 1) 299 ] 300 _ -> [testCase "vector count" (assertFailure "expected 10 vectors")] 301 302 -- mainnet gossip ------------------------------------------------------------- 303 304 decoded_announcements :: IO [(BS.ByteString, ChannelAnnouncement)] 305 decoded_announcements = traverse go mainnet_announcements 306 where 307 go v = do 308 p <- hex (av_payload v) 309 a <- expectRight "decode_channel_announcement" 310 (decode_channel_announcement p) 311 pure (p, a) 312 313 -- the key of the node that signed an update 314 signer :: ChannelAnnouncement -> ChannelUpdate -> Point 315 signer a u = case channel_flags_direction (cu_channel_flags u) of 316 NodeOne -> ca_node_id_1 a 317 NodeTwo -> ca_node_id_2 a 318 319 other :: ChannelAnnouncement -> ChannelUpdate -> Point 320 other a u = case channel_flags_direction (cu_channel_flags u) of 321 NodeOne -> ca_node_id_2 a 322 NodeTwo -> ca_node_id_1 a 323 324 mainnet_tests :: TestTree 325 mainnet_tests = testGroup "mainnet gossip" [ 326 testCase "channel_announcements: decode, re-encode, hash, verify" $ do 327 anns <- decoded_announcements 328 length anns @?= 6 329 mapM_ (\(v, (p, a)) -> do 330 encode_channel_announcement a @?= Right p 331 d <- hex (av_digest v) 332 channel_announcement_hash a @?= Right d 333 assertBool "signatures verify" (verify_channel_announcement a) 334 validate_channel_announcement a @?= Right ()) 335 (zip mainnet_announcements anns) 336 , testCase "channel_announcement fields" $ do 337 anns <- decoded_announcements 338 (_, a) <- must "first announcement" (safe_head anns) 339 mainnet <- hex 340 "6fe28c0ab6f1b372c1a6a246ae63f74f931e8365e15a089c68d6190000000000" 341 n1 <- hex 342 "02bb5e47ee26aca1654ce092d9d06eac15d953210c737f2220e2d7e54c4f108677" 343 n2 <- hex 344 "030b828fd1e42549fbc2f1d0960ec3663362c41777d3d87fe1b8e1d4bf063abcaa" 345 format_short_channel_id (ca_short_channel_id a) @?= "850052x2992x1" 346 BOLT1.un_chain_hash (ca_chain_hash a) @?= mainnet 347 BOLT9.render (ca_features a) @?= BS.empty 348 BOLT1.un_point (ca_node_id_1 a) @?= n1 349 BOLT1.un_point (ca_node_id_2 a) @?= n2 350 BOLT1.un_tlv_stream (ca_tlvs a) @?= [] 351 , testCase "channel_announcement: tampering breaks verification" $ do 352 anns <- decoded_announcements 353 (p, a) <- must "first announcement" (safe_head anns) 354 -- change the short channel id (signed) 355 let p' = set_byte 295 0xff p 356 a' <- expectRight "decode" (decode_channel_announcement p') 357 assertBool "tampered" (not (verify_channel_announcement a')) 358 let swapped = a { ca_node_signature_1 = ca_node_signature_2 a 359 , ca_node_signature_2 = ca_node_signature_1 a } 360 assertBool "swapped" (not (verify_channel_announcement swapped)) 361 , testCase "channel_updates: decode, re-encode, hash, checksum, verify" $ do 362 anns <- decoded_announcements 363 length mainnet_updates @?= 13 364 mapM_ (\v -> do 365 p <- hex (uv_payload v) 366 u <- expectRight "decode_channel_update" (decode_channel_update p) 367 (_, a) <- must "announcement" (safe_index anns (uv_ann v)) 368 cu_short_channel_id u @?= ca_short_channel_id a 369 encode_channel_update u @?= p 370 d <- hex (uv_digest v) 371 channel_update_hash u @?= d 372 channel_update_checksum u @?= uv_checksum v 373 assertBool "verifies under its signer" 374 (verify_channel_update (signer a u) u) 375 assertBool "fails under the other node" 376 (not (verify_channel_update (other a u) u))) 377 mainnet_updates 378 , testCase "channel_update fields (136 bytes)" $ do 379 u <- update_vector 1 380 BS.length (encode_channel_update u) @?= 136 381 format_short_channel_id (cu_short_channel_id u) @?= "850052x2992x1" 382 cu_timestamp u @?= 1776493010 383 cu_message_flags u @?= MessageFlags 0x01 384 cu_channel_flags u @?= channel_flags NodeTwo Disabled 385 cu_cltv_expiry_delta u @?= 80 386 BOLT1.un_milli_satoshi (cu_htlc_minimum_msat u) @?= 1000 387 cu_fee_base_msat u @?= 1000 388 cu_fee_proportional_millionths u @?= 800 389 BOLT1.un_milli_satoshi (cu_htlc_maximum_msat u) @?= 2970000000 390 BOLT1.un_tlv_stream (cu_tlvs u) @?= [] 391 , testCase "channel_update fields (148 bytes, inbound-fee extension)" $ do 392 u <- update_vector 0 393 ext <- hex "00000000ffffffed" 394 cu_timestamp u @?= 1779047542 395 cu_channel_flags u @?= channel_flags NodeOne Enabled 396 cu_cltv_expiry_delta u @?= 100 397 cu_fee_base_msat u @?= 0 398 cu_fee_proportional_millionths u @?= 5000 399 BOLT1.un_milli_satoshi (cu_htlc_maximum_msat u) @?= 2970000000 400 BOLT1.un_tlv_stream (cu_tlvs u) @?= [TlvRecord 55555 ext] 401 , testCase "a real update with htlc_minimum_msat > htlc_maximum_msat" $ do 402 u <- update_vector 8 403 validate_channel_update u @?= Left ValidateHtlcAmounts 404 , testCase "dropping the extension breaks verification" $ do 405 anns <- decoded_announcements 406 (_, a) <- must "announcement" (safe_head anns) 407 u <- update_vector 0 408 let u' = u { cu_tlvs = BOLT1.empty_tlv_stream } 409 assertBool "with" (verify_channel_update (signer a u) u) 410 assertBool "without" (not (verify_channel_update (signer a u) u')) 411 ] 412 where 413 update_vector i = do 414 v <- must "update vector" (safe_index mainnet_updates i) 415 p <- hex (uv_payload v) 416 expectRight "decode_channel_update" (decode_channel_update p) 417 418 safe_head :: [a] -> Maybe a 419 safe_head (x : _) = Just x 420 safe_head [] = Nothing 421 422 safe_index :: [a] -> Int -> Maybe a 423 safe_index xs i 424 | i < 0 = Nothing 425 | otherwise = safe_head (drop i xs) 426 427 -- node_announcement ---------------------------------------------------------- 428 429 -- a node_announcement payload carrying the given address bytes 430 node_wire :: Fx -> BS.ByteString -> BS.ByteString 431 node_wire fx addrs = mconcat 432 [ BS.replicate 64 0xee -- signature 433 , u16be 0 -- flen 434 , BS.pack [0x49, 0x96, 0x02, 0xd2] -- timestamp 435 , BOLT1.un_point (fx_node_2 fx) 436 , BS.pack [0xff, 0x00, 0x00] 437 , BS.replicate 32 0 438 , u16be (BS.length addrs) 439 , addrs 440 ] 441 442 -- address descriptors (port 9735) 443 desc_v4, desc_v6, desc_tor_v2, desc_tor_v3 :: BS.ByteString 444 desc_v4 = BS.pack [1, 127, 0, 0, 1, 0x26, 0x07] 445 desc_v6 = BS.pack (2 : replicate 15 0 ++ [1, 0x26, 0x07]) 446 desc_tor_v2 = BS.cons 3 (BS.replicate 12 0xaa) 447 desc_tor_v3 = BS.cons 4 (BS.replicate 35 0xbb) <> u16be 9735 448 449 desc_dns :: BS.ByteString -> BS.ByteString 450 desc_dns h = BS.pack [5, fromIntegral (BS.length h)] <> h <> u16be 9735 451 452 -- decode the addresses of a node_announcement built by node_wire, and 453 -- check that it re-encodes exactly 454 addrs_of 455 :: Fx -> BS.ByteString -> IO (Either DecodeError ([Address], BS.ByteString)) 456 addrs_of fx bytes = do 457 let wire = node_wire fx bytes 458 case decode_node_announcement wire of 459 Left e -> pure (Left e) 460 Right n -> do 461 encode_node_announcement n @?= Right wire 462 pure (Right (na_addresses n, na_unknown_addresses n)) 463 464 node_announcement_tests :: TestTree 465 node_announcement_tests = testGroup "node_announcement" [ 466 testCase "signed vector: fields, re-encoding, hash, verification" $ do 467 let (h, dh) = node_announcement_vector 468 p <- hex h 469 d <- hex dh 470 n <- expectRight "decode" (decode_node_announcement p) 471 fs <- hex "08000000000002aaa2" 472 nid <- hex 473 "0324653eac434488002cc06bbfb7f10fe18991e35f9fe4302dbea6d2353dc0ab1c" 474 v4 <- must "ipv4" (ipv4_addr "\127\0\0\1") 475 v6 <- must "ipv6" (ipv6_addr (BS.replicate 15 0 <> "\1")) 476 t2 <- must "tor v2" (tor_v2_addr (BS.replicate 12 0xaa)) 477 t3 <- must "tor v3" (tor_v3_addr (BS.replicate 35 0xbb)) 478 dns <- must "hostname" (hostname "ln.example.com") 479 BOLT9.render (na_features n) @?= fs 480 na_timestamp n @?= 1700000000 481 BOLT1.un_point (na_node_id n) @?= nid 482 na_rgb_color n @?= RgbColor 0x31 0x41 0x59 483 BS.takeWhile (/= 0) (un_alias (na_alias n)) @?= "ppad-bolt7" 484 na_addresses n @?= 485 [ AddrIPv4 v4 9735, AddrIPv6 v6 9735, AddrTorV2 t2 486 , AddrTorV3 t3 9735, AddrDNS dns 9735 ] 487 na_unknown_addresses n @?= "\x06\x01\x02\x03" 488 BOLT1.un_tlv_stream (na_tlvs n) @?= [TlvRecord 101 "ext"] 489 encode_node_announcement n @?= Right p 490 node_announcement_hash n @?= Right d 491 assertBool "verifies" (verify_node_announcement n) 492 assertBool "tampered" 493 (not (verify_node_announcement n { na_timestamp = 1700000001 })) 494 usable_addresses (na_addresses n) @?= 495 [ AddrIPv4 v4 9735, AddrIPv6 v6 9735, AddrTorV3 t3 9735 496 , AddrDNS dns 9735 ] 497 validate_node_announcement n @?= Right () 498 , testCase "keeps deprecated Tor v2 descriptors" $ do 499 fx <- fixtures 500 r <- addrs_of fx (desc_v4 <> desc_tor_v2 <> desc_v6 <> desc_tor_v3) 501 fmap (map kind . fst) r @?= Right [1, 3, 2, 4] 502 , testCase "stops at the first unknown type, keeping the rest" $ do 503 fx <- fixtures 504 let rest = BS.pack [6, 1, 2, 3] <> desc_v6 505 r <- addrs_of fx (desc_v4 <> rest) 506 fmap (\(as, u) -> (map kind as, u)) r @?= Right ([1], rest) 507 , testCase "stops at a type-0 descriptor" $ do 508 fx <- fixtures 509 let bytes = BS.singleton 0 <> desc_v4 510 r <- addrs_of fx bytes 511 fmap (\(as, u) -> (map kind as, u)) r @?= Right ([], bytes) 512 , testCase "keeps descriptors with port 0" $ do 513 fx <- fixtures 514 v4 <- must "ipv4" (ipv4_addr "\127\0\0\1") 515 r <- addrs_of fx (BS.pack [1, 127, 0, 0, 1, 0, 0]) 516 r @?= Right ([AddrIPv4 v4 0], BS.empty) 517 , testCase "keeps empty and non-ASCII hostnames" $ do 518 fx <- fixtures 519 r <- addrs_of fx (desc_dns "" <> desc_dns "\xff\&ab") 520 fmap (map (\a -> case a of 521 AddrDNS h _ -> un_hostname h 522 _ -> "?") . fst) r 523 @?= Right ["", "\xff\&ab"] 524 , testCase "rejects a truncated descriptor of a known type" $ do 525 fx <- fixtures 526 let truncated bytes = decode_node_announcement (node_wire fx bytes) 527 @?= Left DecodeInsufficientBytes 528 truncated (BS.pack [1, 127, 0, 0]) 529 truncated (BS.pack [2, 0, 0]) 530 truncated (BS.pack [3, 1, 2, 3]) 531 truncated (BS.cons 4 (BS.replicate 36 0)) 532 truncated (BS.pack [5, 4, 0x61]) 533 , testCase "rejects a node_id without a compressed prefix" $ do 534 fx <- fixtures 535 let wire = set_byte 70 0x04 (node_wire fx BS.empty) 536 decode_node_announcement wire @?= Left DecodeInvalidPoint 537 , testCase "na_unknown_addresses must not begin with a known type" $ do 538 fx <- fixtures 539 let with u = encode_node_announcement 540 (node_fixture fx []) { na_unknown_addresses = u } 541 mapM_ (\t -> with (BS.pack [t, 0]) @?= Left EncodeInvalidAddresses) 542 [1 .. 5] 543 assertBool "type 0" (either (const False) (const True) 544 (with (BS.pack [0, 1]))) 545 assertBool "type 6" (either (const False) (const True) 546 (with (BS.pack [6, 1]))) 547 , testCase "extension with an unknown even type is rejected" $ do 548 fx <- fixtures 549 decode_node_announcement (node_wire fx BS.empty <> "\x02\x00") 550 @?= Left (DecodeTlvError (TlvUnknownEvenType 2)) 551 ] 552 where 553 kind :: Address -> Int 554 kind a = case a of 555 AddrIPv4 _ _ -> 1 556 AddrIPv6 _ _ -> 2 557 AddrTorV2 _ -> 3 558 AddrTorV3 _ _ -> 4 559 AddrDNS _ _ -> 5 560 561 -- channel_update ------------------------------------------------------------- 562 563 channel_update_tests :: TestTree 564 channel_update_tests = testGroup "channel_update" [ 565 testCase "encoder writes the flags and htlc_maximum_msat" $ do 566 u <- fixtures >>= update_fixture 567 let wire = encode_channel_update u 568 BS.length wire @?= 136 569 BS.indexMaybe wire 108 @?= Just 0x01 570 BS.indexMaybe wire 109 @?= Just 0x00 571 BS.drop 128 wire @?= BS.pack [0, 0, 0, 0, 0x3b, 0x9a, 0xca, 0] 572 , testCase "dont_forward" $ do 573 u <- fixtures >>= update_fixture 574 let wire = encode_channel_update 575 u { cu_message_flags = message_flags DontForward } 576 BS.indexMaybe wire 108 @?= Just 0x03 577 d <- expectRight "decode" (decode_channel_update wire) 578 message_flags_forwarding (cu_message_flags d) @?= DontForward 579 , testCase "keeps a clear must_be_one bit" $ do 580 u <- fixtures >>= update_fixture 581 let wire = set_byte 108 0x00 (encode_channel_update u) 582 d <- expectRight "decode" (decode_channel_update wire) 583 d @?= u { cu_message_flags = MessageFlags 0 } 584 encode_channel_update d @?= wire 585 , testCase "keeps unassigned flag bits" $ do 586 u <- fixtures >>= update_fixture 587 let wire = set_byte 109 0xfd 588 (set_byte 108 0xfc (encode_channel_update u)) 589 d <- expectRight "decode" (decode_channel_update wire) 590 cu_message_flags d @?= MessageFlags 0xfc 591 cu_channel_flags d @?= ChannelFlags 0xfd 592 channel_flags_direction (cu_channel_flags d) @?= NodeTwo 593 channel_flags_status (cu_channel_flags d) @?= Enabled 594 encode_channel_update d @?= wire 595 , testCase "keeps extension records" $ do 596 u <- fixtures >>= update_fixture 597 ext <- tlvs_of [TlvRecord 55555 "\0\0\0\0\xff\xff\xff\xed"] 598 let wire = encode_channel_update u { cu_tlvs = ext } 599 BS.length wire @?= 148 600 decode_channel_update wire @?= Right u { cu_tlvs = ext } 601 , testCase "rejects a missing htlc_maximum_msat" $ do 602 u <- fixtures >>= update_fixture 603 decode_channel_update (BS.take 128 (encode_channel_update u)) 604 @?= Left DecodeInsufficientBytes 605 , testCase "rejects amounts above 21M BTC" $ do 606 u <- fixtures >>= update_fixture 607 let wire = encode_channel_update u 608 over = big_endian 8 0x1d24b2dfac520001 609 at off = BS.take off wire <> over <> BS.drop (off + 8) wire 610 decode_channel_update (at 112) @?= Left DecodeInvalidAmount 611 decode_channel_update (at 128) @?= Left DecodeInvalidAmount 612 max_msat <- msat 0x1d24b2dfac520000 613 fmap cu_htlc_maximum_msat (decode_channel_update 614 (BS.take 128 wire <> big_endian 8 0x1d24b2dfac520000)) 615 @?= Right max_msat 616 , testCase "rejects a malformed extension" $ do 617 u <- fixtures >>= update_fixture 618 let wire = encode_channel_update u 619 decode_channel_update (wire <> "\x02\x00") 620 @?= Left (DecodeTlvError (TlvUnknownEvenType 2)) 621 decode_channel_update (wire <> "\x01\x05\xaa") 622 @?= Left (DecodeTlvError TlvTruncated) 623 decode_channel_update (wire <> "\xfd\x00\x01\x00") 624 @?= Left (DecodeTlvError TlvNonMinimalBigSize) 625 , testCase "rejects truncated input" $ 626 decode_channel_update (BS.replicate 50 0) 627 @?= Left DecodeInsufficientBytes 628 ] 629 630 -- queries -------------------------------------------------------------------- 631 632 -- payload builders 633 qsci_wire :: Fx -> BS.ByteString -> BS.ByteString -> BS.ByteString 634 qsci_wire fx ids tlvs = 635 BOLT1.un_chain_hash (fx_chain fx) <> u16be (BS.length ids) <> ids <> tlvs 636 637 qcr_wire :: Fx -> BS.ByteString -> BS.ByteString 638 qcr_wire fx tlvs = mconcat 639 [ BOLT1.un_chain_hash (fx_chain fx) 640 , big_endian 4 600000 641 , big_endian 4 10000 642 , tlvs 643 ] 644 645 rcr_wire :: Fx -> Word8 -> BS.ByteString -> BS.ByteString -> BS.ByteString 646 rcr_wire fx sync ids tlvs = mconcat 647 [ BOLT1.un_chain_hash (fx_chain fx) 648 , big_endian 4 600000 649 , big_endian 4 10000 650 , BS.singleton sync 651 , u16be (BS.length ids) 652 , ids 653 , tlvs 654 ] 655 656 -- encoded_short_ids for some short channel ids 657 encoded_ids :: [ShortChannelId] -> BS.ByteString 658 encoded_ids ss = BS.cons 0 (foldMap BOLT1.encode_short_channel_id ss) 659 660 -- TLV stream rules for a query decoder, given its known types and the 661 -- unknown records it keeps 662 tlv_stream_tests 663 :: String 664 -> BS.ByteString 665 -> (Fx -> BS.ByteString -> Either DecodeError [TlvRecord]) 666 -> TestTree 667 tlv_stream_tests name known dec = testGroup name [ 668 testCase "empty stream" $ do 669 fx <- fixtures 670 dec fx BS.empty @?= Right [] 671 , testCase "keeps unknown odd types" $ do 672 fx <- fixtures 673 dec fx (BS.pack [5, 1, 0x2a, 7, 0]) @?= 674 Right [TlvRecord 5 "\x2a", TlvRecord 7 ""] 675 , testCase "rejects unknown even types" $ do 676 fx <- fixtures 677 dec fx (BS.pack [2, 0]) @?= Left (DecodeTlvError (TlvUnknownEvenType 2)) 678 , testCase "rejects a length past the end" $ do 679 fx <- fixtures 680 dec fx (BS.pack [5, 5, 0xaa]) @?= Left (DecodeTlvError TlvTruncated) 681 , testCase "rejects repeated types" $ do 682 fx <- fixtures 683 dec fx (BS.pack [5, 0, 5, 0]) 684 @?= Left (DecodeTlvError TlvNotStrictlyIncreasing) 685 , testCase "rejects a non-minimal BigSize" $ do 686 fx <- fixtures 687 dec fx (BS.pack [0xfd, 0x00, 0x05, 0x00]) 688 @?= Left (DecodeTlvError TlvNonMinimalBigSize) 689 , testCase "known records are typed, not kept as unknown" $ do 690 fx <- fixtures 691 dec fx known @?= Right [] 692 dec fx (known <> BS.pack [5, 0]) @?= Right [TlvRecord 5 ""] 693 ] 694 695 query_tests :: TestTree 696 query_tests = testGroup "queries" [ 697 tlv_stream_tests "query_short_channel_ids TLVs" (BS.pack [1, 2, 0, 0]) 698 $ \fx tlvs -> 699 fmap (BOLT1.un_tlv_stream . qsci_tlvs) 700 (decode_query_short_channel_ids 701 (qsci_wire fx (encoded_ids [fx_scid fx]) tlvs)) 702 , tlv_stream_tests "query_channel_range TLVs" (BS.pack [1, 1, 3]) 703 $ \fx tlvs -> 704 fmap (BOLT1.un_tlv_stream . qcr_tlvs) 705 (decode_query_channel_range (qcr_wire fx tlvs)) 706 , tlv_stream_tests "reply_channel_range TLVs" 707 (BS.pack ([1, 9] ++ replicate 9 0 ++ [3, 8] ++ replicate 8 0)) 708 $ \fx tlvs -> 709 fmap (BOLT1.un_tlv_stream . rcr_tlvs) 710 (decode_reply_channel_range 711 (rcr_wire fx 1 (encoded_ids [fx_scid fx]) tlvs)) 712 , testGroup "query_short_channel_ids" [ 713 testCase "query_flags" $ do 714 fx <- fixtures 715 let ss = take 2 (fx_scids fx) 716 wire = qsci_wire fx (encoded_ids ss) 717 (BS.pack [1, 3, 0, 0x01, 0x1f]) 718 m = QueryShortChannelIds (fx_chain fx) ss 719 (Just [QueryFlags 1, QueryFlags 31]) BOLT1.empty_tlv_stream 720 decode_query_short_channel_ids wire @?= Right m 721 encode_query_short_channel_ids m @?= Right wire 722 , testCase "query_flags beyond one byte" $ do 723 fx <- fixtures 724 let ss = take 1 (fx_scids fx) 725 wire = qsci_wire fx (encoded_ids ss) 726 (BS.pack [1, 4, 0, 0xfd, 0x01, 0x00]) 727 fmap qsci_query_flags (decode_query_short_channel_ids wire) 728 @?= Right (Just [QueryFlags 256]) 729 , testCase "rejects a query flag count mismatch" $ do 730 fx <- fixtures 731 let ss = take 2 (fx_scids fx) 732 wire = qsci_wire fx (encoded_ids ss) (BS.pack [1, 2, 0, 0x01]) 733 decode_query_short_channel_ids wire @?= Left DecodeCountMismatch 734 , testCase "rejects malformed query_flags" $ do 735 fx <- fixtures 736 let with tlv = decode_query_short_channel_ids 737 (qsci_wire fx (encoded_ids [fx_scid fx]) tlv) 738 with (BS.pack [1, 0]) @?= Left (DecodeInvalidTlvValue 1) 739 with (BS.pack [1, 4, 0, 0xfd, 0x00, 0x01]) 740 @?= Left (DecodeInvalidTlvValue 1) 741 with (BS.pack [1, 2, 0, 0xfd]) @?= Left (DecodeInvalidTlvValue 1) 742 with (BS.pack [1, 2, 1, 0x01]) @?= Left (DecodeUnknownEncoding 1) 743 , testCase "rejects malformed encoded_short_ids" $ do 744 fx <- fixtures 745 let with ids = decode_query_short_channel_ids (qsci_wire fx ids "") 746 with BS.empty @?= Left DecodeInvalidShortChannelIds 747 with (BS.cons 0 (BS.replicate 7 0)) 748 @?= Left DecodeInvalidShortChannelIds 749 with (BS.cons 0 (BS.replicate 9 0)) 750 @?= Left DecodeInvalidShortChannelIds 751 with (BS.cons 1 (BS.replicate 8 0)) @?= Left (DecodeUnknownEncoding 1) 752 with (BS.cons 2 (BS.replicate 8 0)) @?= Left (DecodeUnknownEncoding 2) 753 , testCase "an empty list still carries its encoding type" $ do 754 fx <- fixtures 755 let m = QueryShortChannelIds (fx_chain fx) [] Nothing 756 BOLT1.empty_tlv_stream 757 wire = qsci_wire fx (BS.singleton 0) "" 758 encode_query_short_channel_ids m @?= Right wire 759 decode_query_short_channel_ids wire @?= Right m 760 ] 761 , testGroup "query_channel_range" [ 762 testCase "query_option" $ do 763 fx <- fixtures 764 let wire = qcr_wire fx (BS.pack [1, 3, 0xfd, 0x01, 0x00]) 765 fmap qcr_query_option (decode_query_channel_range wire) 766 @?= Right (Just (QueryOption 256)) 767 , testCase "rejects malformed query_option" $ do 768 fx <- fixtures 769 let with tlv = decode_query_channel_range (qcr_wire fx tlv) 770 with (BS.pack [1, 0]) @?= Left (DecodeInvalidTlvValue 1) 771 with (BS.pack [1, 2, 3, 0]) @?= Left (DecodeInvalidTlvValue 1) 772 with (BS.pack [1, 3, 0xfd, 0x00, 0x03]) 773 @?= Left (DecodeInvalidTlvValue 1) 774 , testCase "rejects truncated input" $ do 775 fx <- fixtures 776 decode_query_channel_range (BS.take 39 (qcr_wire fx "")) 777 @?= Left DecodeInsufficientBytes 778 ] 779 , testGroup "reply_channel_range" [ 780 testCase "rejects malformed timestamps" $ do 781 fx <- fixtures 782 let ss = take 2 (fx_scids fx) 783 with tlv = decode_reply_channel_range 784 (rcr_wire fx 1 (encoded_ids ss) tlv) 785 with (BS.pack [1, 0]) @?= Left (DecodeInvalidTlvValue 1) 786 with (BS.pack [1, 9, 1] <> BS.replicate 8 0) 787 @?= Left (DecodeUnknownEncoding 1) 788 with (BS.pack [1, 9, 0] <> BS.replicate 8 0) 789 @?= Left DecodeCountMismatch 790 with (BS.pack [1, 13, 0] <> BS.replicate 12 0) 791 @?= Left (DecodeInvalidTlvValue 1) 792 , testCase "rejects malformed checksums" $ do 793 fx <- fixtures 794 let ss = take 2 (fx_scids fx) 795 with tlv = decode_reply_channel_range 796 (rcr_wire fx 1 (encoded_ids ss) tlv) 797 with (BS.pack [3, 8] <> BS.replicate 8 0) @?= Left DecodeCountMismatch 798 with (BS.pack [3, 12] <> BS.replicate 12 0) 799 @?= Left (DecodeInvalidTlvValue 3) 800 fmap rcr_checksums (with (BS.pack [3, 16] <> BS.replicate 16 0)) 801 @?= Right (Just (replicate 2 (ChannelUpdateChecksums 0 0))) 802 , testCase "rejects a sync_complete other than 0 or 1" $ do 803 fx <- fixtures 804 let with s = fmap rcr_sync_complete (decode_reply_channel_range 805 (rcr_wire fx s (encoded_ids []) "")) 806 with 0 @?= Right False 807 with 1 @?= Right True 808 with 2 @?= Left DecodeInvalidBool 809 , testCase "rejects malformed encoded_short_ids" $ do 810 fx <- fixtures 811 let with ids = decode_reply_channel_range (rcr_wire fx 1 ids "") 812 with BS.empty @?= Left DecodeInvalidShortChannelIds 813 with (BS.cons 0 (BS.replicate 12 0)) 814 @?= Left DecodeInvalidShortChannelIds 815 with (BS.cons 1 (BS.replicate 8 0)) @?= Left (DecodeUnknownEncoding 1) 816 ] 817 ] 818 819 -- other messages ------------------------------------------------------------- 820 821 other_message_tests :: TestTree 822 other_message_tests = testGroup "other messages" [ 823 testCase "reply_short_channel_ids_end" $ do 824 fx <- fixtures 825 let ch = BOLT1.un_chain_hash (fx_chain fx) 826 ext <- tlvs_of [TlvRecord 9 "x"] 827 decode_reply_short_channel_ids_end (ch <> "\x01") 828 @?= Right (ReplyShortChannelIdsEnd (fx_chain fx) True 829 BOLT1.empty_tlv_stream) 830 decode_reply_short_channel_ids_end (ch <> "\x00\x09\x01x") 831 @?= Right (ReplyShortChannelIdsEnd (fx_chain fx) False ext) 832 decode_reply_short_channel_ids_end (ch <> "\x02") 833 @?= Left DecodeInvalidBool 834 decode_reply_short_channel_ids_end ch @?= Left DecodeInsufficientBytes 835 , testCase "announcement_signatures" $ do 836 fx <- fixtures 837 ext <- tlvs_of [TlvRecord 1 "a"] 838 let m = AnnouncementSignatures (fx_cid fx) (fx_scid fx) (fx_sig fx) 839 (fx_sig fx) ext 840 wire = encode_announcement_signatures m 841 BS.length wire @?= 32 + 8 + 64 + 64 + 3 842 decode_announcement_signatures wire @?= Right m 843 decode_announcement_signatures (BS.take 167 wire) 844 @?= Left DecodeInsufficientBytes 845 -- type 1 is odd, so it may appear in an extension; 2 may not 846 decode_announcement_signatures (BS.take 168 wire <> "\x02\x00") 847 @?= Left (DecodeTlvError (TlvUnknownEvenType 2)) 848 , testCase "gossip_timestamp_filter" $ do 849 fx <- fixtures 850 let m = GossipTimestampFilter (fx_chain fx) 1609459200 86400 851 BOLT1.empty_tlv_stream 852 wire = encode_gossip_timestamp_filter m 853 BS.drop 32 wire @?= BS.pack [0x5f, 0xee, 0x66, 0x00, 0, 1, 0x51, 0x80] 854 decode_gossip_timestamp_filter wire @?= Right m 855 decode_gossip_timestamp_filter (BS.take 39 wire) 856 @?= Left DecodeInsufficientBytes 857 , testCase "channel_announcement rejects bad points" $ do 858 fx <- fixtures 859 wire <- expectRight "encode" 860 (encode_channel_announcement (announcement_fixture fx)) 861 -- node_id_1 starts after the signatures, features, chain hash 862 -- and short channel id 863 decode_channel_announcement (set_byte 298 0x04 wire) 864 @?= Left DecodeInvalidPoint 865 decode_channel_announcement (BS.take 429 wire) 866 @?= Left DecodeInsufficientBytes 867 ] 868 869 -- encoding errors ------------------------------------------------------------ 870 871 encode_error_tests :: TestTree 872 encode_error_tests = testGroup "encoding errors" [ 873 testCase "channel_announcement features" $ do 874 fx <- fixtures 875 let feats n = (announcement_fixture fx) 876 { ca_features = BOLT9.parse (BS.replicate n 1) } 877 encode_channel_announcement (feats 65536) @?= Left EncodeLengthOverflow 878 wire <- expectRight "encode" (encode_channel_announcement (feats 65535)) 879 decode_channel_announcement wire @?= Right (feats 65535) 880 , testCase "node_announcement features and addresses" $ do 881 fx <- fixtures 882 v4 <- must "ipv4" (ipv4_addr "\127\0\0\1") 883 let base = node_fixture fx [] 884 encode_node_announcement base 885 { na_features = BOLT9.parse (BS.replicate 65536 1) } 886 @?= Left EncodeLengthOverflow 887 -- 10923 IPv4 descriptors take 65538 bytes 888 let v4s n = node_fixture fx (replicate n (AddrIPv4 v4 1)) 889 encode_node_announcement (v4s 10923) @?= Left EncodeLengthOverflow 890 wire <- expectRight "encode" (encode_node_announcement (v4s 9362)) 891 fmap (length . na_addresses) (decode_node_announcement wire) 892 @?= Right 9362 893 , testCase "short channel id lists" $ do 894 fx <- fixtures 895 let ids n = map ShortChannelId [1 .. n] 896 q n = QueryShortChannelIds (fx_chain fx) (ids n) Nothing 897 BOLT1.empty_tlv_stream 898 r n = ReplyChannelRange (fx_chain fx) 0 1 True (ids n) Nothing 899 Nothing BOLT1.empty_tlv_stream 900 encode_query_short_channel_ids (q 8192) @?= Left EncodeLengthOverflow 901 encode_reply_channel_range (r 8192) @?= Left EncodeLengthOverflow 902 wire <- expectRight "encode" (encode_query_short_channel_ids (q 8191)) 903 decode_query_short_channel_ids wire @?= Right (q 8191) 904 , testCase "count mismatches" $ do 905 fx <- fixtures 906 let ss = fx_scids fx 907 q = QueryShortChannelIds (fx_chain fx) ss (Just [QueryFlags 1]) 908 BOLT1.empty_tlv_stream 909 r = ReplyChannelRange (fx_chain fx) 0 1 True ss Nothing Nothing 910 BOLT1.empty_tlv_stream 911 encode_query_short_channel_ids q @?= Left EncodeCountMismatch 912 encode_reply_channel_range r 913 { rcr_timestamps = Just [ChannelUpdateTimestamps 1 2] } 914 @?= Left EncodeCountMismatch 915 encode_reply_channel_range r 916 { rcr_checksums = Just (replicate 4 (ChannelUpdateChecksums 1 2)) } 917 @?= Left EncodeCountMismatch 918 , testCase "extra records must not use known types" $ do 919 fx <- fixtures 920 t1 <- tlvs_of [TlvRecord 1 "\0"] 921 t3 <- tlvs_of [TlvRecord 3 ""] 922 t5 <- tlvs_of [TlvRecord 5 ""] 923 let q = QueryShortChannelIds (fx_chain fx) [] Nothing 924 c = QueryChannelRange (fx_chain fx) 0 1 Nothing 925 r = ReplyChannelRange (fx_chain fx) 0 1 True [] Nothing Nothing 926 encode_query_short_channel_ids (q t1) @?= Left EncodeInvalidTlvs 927 encode_query_channel_range (c t1) @?= Left EncodeInvalidTlvs 928 encode_reply_channel_range (r t1) @?= Left EncodeInvalidTlvs 929 encode_reply_channel_range (r t3) @?= Left EncodeInvalidTlvs 930 wire <- expectRight "encode" (encode_reply_channel_range (r t5)) 931 decode_reply_channel_range wire @?= Right (r t5) 932 ] 933 934 -- dispatch ------------------------------------------------------------------- 935 936 dispatch_tests :: TestTree 937 dispatch_tests = testGroup "dispatch" [ 938 testCase "unknown message types" $ 939 mapM_ (\t -> decode_message t "" @?= Left (DecodeUnknownType t)) 940 [0, 16, 255, 260, 266, 32768] 941 , testCase "message types" $ do 942 fx <- fixtures 943 u <- update_fixture fx 944 let e = BOLT1.empty_tlv_stream 945 ms = [ MsgChannelAnnouncement (announcement_fixture fx) 946 , MsgNodeAnnouncement (node_fixture fx []) 947 , MsgChannelUpdate u 948 , MsgAnnouncementSignatures (AnnouncementSignatures 949 (fx_cid fx) (fx_scid fx) (fx_sig fx) (fx_sig fx) e) 950 , MsgQueryShortChannelIds 951 (QueryShortChannelIds (fx_chain fx) [] Nothing e) 952 , MsgReplyShortChannelIdsEnd 953 (ReplyShortChannelIdsEnd (fx_chain fx) True e) 954 , MsgQueryChannelRange 955 (QueryChannelRange (fx_chain fx) 0 1 Nothing e) 956 , MsgReplyChannelRange (ReplyChannelRange 957 (fx_chain fx) 0 1 True [] Nothing Nothing e) 958 , MsgGossipTimestampFilter 959 (GossipTimestampFilter (fx_chain fx) 0 1 e) 960 ] 961 map message_type ms @?= [256, 257, 258, 259, 261, 262, 263, 264, 265] 962 mapM_ (\m -> do 963 p <- expectRight "encode" (encode_message m) 964 decode_message (message_type m) p @?= Right m) 965 ms 966 ] 967 968 -- validation ----------------------------------------------------------------- 969 970 validation_tests :: TestTree 971 validation_tests = testGroup "validation" [ 972 testCase "channel_announcement node id order" $ do 973 fx <- fixtures 974 let a = announcement_fixture fx 975 validate_channel_announcement a @?= Right () 976 validate_channel_announcement 977 a { ca_node_id_1 = fx_node_2 fx, ca_node_id_2 = fx_node_1 fx } 978 @?= Left ValidateNodeIdOrdering 979 validate_channel_announcement a { ca_node_id_2 = fx_node_1 fx } 980 @?= Left ValidateNodeIdOrdering 981 , testCase "node_announcement DNS hostnames" $ do 982 fx <- fixtures 983 v4 <- must "ipv4" (ipv4_addr "\127\0\0\1") 984 h1 <- must "hostname" (hostname "a.example.com") 985 h2 <- must "hostname" (hostname "b.example.com") 986 validate_node_announcement 987 (node_fixture fx [AddrIPv4 v4 1, AddrDNS h1 1]) 988 @?= Right () 989 validate_node_announcement (node_fixture fx [AddrDNS h1 1, AddrDNS h2 1]) 990 @?= Left ValidateMultipleDns 991 , testCase "channel_update htlc amounts" $ do 992 fx <- fixtures 993 u <- update_fixture fx 994 big <- msat 2000000000 995 validate_channel_update u @?= Right () 996 validate_channel_update 997 u { cu_htlc_minimum_msat = cu_htlc_maximum_msat u } @?= Right () 998 validate_channel_update u { cu_htlc_minimum_msat = big } 999 @?= Left ValidateHtlcAmounts 1000 , testCase "query_channel_range block range" $ do 1001 fx <- fixtures 1002 let q f n = validate_query_channel_range 1003 (QueryChannelRange (fx_chain fx) f n Nothing 1004 BOLT1.empty_tlv_stream) 1005 q 600000 10000 @?= Right () 1006 q 600000 0 @?= Left ValidateZeroBlocks 1007 q maxBound 1 @?= Right () 1008 q maxBound 2 @?= Left ValidateBlockOverflow 1009 q 0 maxBound @?= Right () 1010 q 1 maxBound @?= Right () 1011 q 2 maxBound @?= Left ValidateBlockOverflow 1012 , testCase "short channel ids ascend" $ do 1013 fx <- fixtures 1014 let ss = fx_scids fx 1015 e = BOLT1.empty_tlv_stream 1016 r xs = validate_reply_channel_range 1017 (ReplyChannelRange (fx_chain fx) 0 1 True xs Nothing Nothing e) 1018 q xs = validate_query_short_channel_ids 1019 (QueryShortChannelIds (fx_chain fx) xs Nothing e) 1020 r ss @?= Right () 1021 r [] @?= Right () 1022 r (reverse ss) @?= Left ValidateScidNotAscending 1023 r (take 1 ss <> take 1 ss) @?= Left ValidateScidNotAscending 1024 q ss @?= Right () 1025 q (reverse ss) @?= Left ValidateScidNotAscending 1026 ] 1027 1028 -- checksums ------------------------------------------------------------------ 1029 1030 -- an independent, table-driven CRC-32C 1031 crc32c_ref :: BS.ByteString -> Word32 1032 crc32c_ref = xor 0xffffffff . BS.foldl' step 0xffffffff 1033 where 1034 step c b = (c `shiftR` 8) 1035 `xor` table (fromIntegral ((c `xor` fromIntegral b) .&. 0xff)) 1036 table :: Word32 -> Word32 1037 table n = go (8 :: Int) n 1038 where 1039 go 0 x = x 1040 go k x 1041 | x .&. 1 == 1 = go (k - 1) ((x `shiftR` 1) `xor` 0x82f63b78) 1042 | otherwise = go (k - 1) (x `shiftR` 1) 1043 1044 -- the checksum per BOLT #7: the update without signature and timestamp 1045 checksum_ref :: BS.ByteString -> Word32 1046 checksum_ref wire = 1047 crc32c_ref (BS.take 40 (BS.drop 64 wire) <> BS.drop 108 wire) 1048 1049 checksum_tests :: TestTree 1050 checksum_tests = testGroup "checksums" [ 1051 testCase "reference CRC-32C matches RFC 3720 vectors" $ do 1052 crc32c_ref "123456789" @?= 0xe3069283 1053 crc32c_ref (BS.replicate 32 0x00) @?= 0x8a9136aa 1054 crc32c_ref (BS.replicate 32 0xff) @?= 0x62a8ab43 1055 crc32c_ref (BS.pack [0 .. 31]) @?= 0x46dd794e 1056 crc32c_ref (BS.pack [31, 30 .. 0]) @?= 0x113fdb5c 1057 , testCase "checksum ignores signature and timestamp" $ do 1058 fx <- fixtures 1059 u <- update_fixture fx 1060 sig <- must "signature" (BOLT1.signature (BS.replicate 64 0x11)) 1061 channel_update_checksum u { cu_signature = sig, cu_timestamp = 1 } 1062 @?= channel_update_checksum u 1063 assertBool "covers the fees" 1064 (channel_update_checksum u { cu_fee_base_msat = 1001 } 1065 /= channel_update_checksum u) 1066 , testProperty "checksum matches the reference" $ 1067 forAll gen_channel_update $ \u -> 1068 channel_update_checksum u === checksum_ref (encode_channel_update u) 1069 ] 1070 1071 -- properties ----------------------------------------------------------------- 1072 1073 property_tests :: TestTree 1074 property_tests = testGroup "properties" [ 1075 testProperty "real gossip re-encodes exactly" $ 1076 forAll (elements samples) $ \(t, h) -> 1077 case B16.decode h of 1078 Nothing -> counterexample "bad hex" False 1079 Just p -> fmap encode_message (decode_message t p) 1080 === Right (Right p) 1081 , testProperty "mutated real gossip re-encodes exactly, if it decodes" $ 1082 forAll (elements samples) $ \(t, h) -> 1083 forAll arbitrary $ \(NonNegative i, w) -> 1084 case B16.decode h of 1085 Nothing -> counterexample "bad hex" False 1086 Just p -> 1087 let p' = set_byte (i `mod` BS.length p) w p 1088 in case decode_message t p' of 1089 Left _ -> property True 1090 Right m -> encode_message m === Right p' 1091 , testProperty "messages round-trip" $ 1092 forAll gen_message $ \m -> case encode_message m of 1093 Left e -> counterexample (show e) False 1094 Right p -> decode_message (message_type m) p === Right m 1095 , testProperty "channel_flags accessors" $ \w -> 1096 let f = ChannelFlags w 1097 in channel_flags (channel_flags_direction f) (channel_flags_status f) 1098 === ChannelFlags (w .&. 0x03) 1099 , testProperty "message_flags accessors" $ \w -> 1100 let f = MessageFlags w 1101 in message_flags (message_flags_forwarding f) 1102 === MessageFlags (w .&. 0x02 .|. 0x01) 1103 , testProperty "query_flags sets exactly its bits" $ 1104 forAll (sublistOf [minBound .. maxBound]) $ \fs -> 1105 map (`has_query_flag` query_flags fs) [minBound .. maxBound] 1106 === map (`elem` fs) [minBound .. maxBound] 1107 , testProperty "query_option sets exactly its bits" $ 1108 forAll (sublistOf [minBound .. maxBound]) $ \fs -> 1109 map (`has_query_option` query_option fs) [minBound .. maxBound] 1110 === map (`elem` fs) [minBound .. maxBound] 1111 ] 1112 1113 -- (type, hex payload) of every embedded real or signed message 1114 samples :: [(Word16, BS.ByteString)] 1115 samples = 1116 [ (256, av_payload v) | v <- mainnet_announcements ] 1117 <> [ (258, uv_payload v) | v <- mainnet_updates ] 1118 <> [ (257, fst node_announcement_vector) ] 1119 1120 -- generators ----------------------------------------------------------------- 1121 1122 gen_bytes :: Int -> Gen BS.ByteString 1123 gen_bytes n = BS.pack <$> vectorOf n arbitrary 1124 1125 gen_var_bytes :: Int -> Gen BS.ByteString 1126 gen_var_bytes m = choose (0, m) >>= gen_bytes 1127 1128 gen_chain_hash :: Gen ChainHash 1129 gen_chain_hash = gen_bytes 32 `suchThatMap` BOLT1.chain_hash 1130 1131 gen_signature :: Gen Signature 1132 gen_signature = gen_bytes 64 `suchThatMap` BOLT1.signature 1133 1134 gen_point :: Gen Point 1135 gen_point = do 1136 h <- elements [0x02, 0x03] 1137 b <- gen_bytes 32 1138 pure (BS.cons h b) `suchThatMap` BOLT1.point 1139 1140 gen_scid :: Gen ShortChannelId 1141 gen_scid = ShortChannelId <$> arbitrary 1142 1143 gen_msat :: Gen BOLT1.MilliSatoshi 1144 gen_msat = choose (0, 0x1d24b2dfac520000) `suchThatMap` BOLT1.milli_satoshi 1145 1146 gen_features :: Gen BOLT9.FeatureVector 1147 gen_features = BOLT9.parse <$> gen_var_bytes 8 1148 1149 -- TLV records of distinct odd types at or above the given minimum 1150 gen_tlvs :: Word64 -> Gen TlvStream 1151 gen_tlvs lo = do 1152 n <- choose (0, 3) 1153 ts <- vectorOf n (choose (lo `div` 2, 40000)) 1154 rs <- traverse (\t -> TlvRecord (2 * t + 1) <$> gen_var_bytes 10) ts 1155 pure rs `suchThatMap` BOLT1.tlv_stream 1156 1157 gen_address :: Gen Address 1158 gen_address = oneof 1159 [ AddrIPv4 <$> (gen_bytes 4 `suchThatMap` ipv4_addr) <*> arbitrary 1160 , AddrIPv6 <$> (gen_bytes 16 `suchThatMap` ipv6_addr) <*> arbitrary 1161 , AddrTorV2 <$> (gen_bytes 12 `suchThatMap` tor_v2_addr) 1162 , AddrTorV3 <$> (gen_bytes 35 `suchThatMap` tor_v3_addr) <*> arbitrary 1163 , AddrDNS <$> (gen_var_bytes 40 `suchThatMap` hostname) <*> arbitrary 1164 ] 1165 1166 gen_unknown_addresses :: Gen BS.ByteString 1167 gen_unknown_addresses = oneof 1168 [ pure BS.empty 1169 , BS.cons <$> elements (0 : [6 .. 255]) <*> gen_var_bytes 10 1170 ] 1171 1172 gen_channel_announcement :: Gen ChannelAnnouncement 1173 gen_channel_announcement = ChannelAnnouncement 1174 <$> gen_signature <*> gen_signature <*> gen_signature <*> gen_signature 1175 <*> gen_features <*> gen_chain_hash <*> gen_scid 1176 <*> gen_point <*> gen_point <*> gen_point <*> gen_point 1177 <*> gen_tlvs 0 1178 1179 gen_node_announcement :: Gen NodeAnnouncement 1180 gen_node_announcement = NodeAnnouncement 1181 <$> gen_signature <*> gen_features <*> arbitrary <*> gen_point 1182 <*> (RgbColor <$> arbitrary <*> arbitrary <*> arbitrary) 1183 <*> (gen_bytes 32 `suchThatMap` alias) 1184 <*> listOf gen_address <*> gen_unknown_addresses <*> gen_tlvs 0 1185 1186 gen_channel_update :: Gen ChannelUpdate 1187 gen_channel_update = ChannelUpdate 1188 <$> gen_signature <*> gen_chain_hash <*> gen_scid <*> arbitrary 1189 <*> (MessageFlags <$> arbitrary) <*> (ChannelFlags <$> arbitrary) 1190 <*> arbitrary <*> gen_msat <*> arbitrary <*> arbitrary <*> gen_msat 1191 <*> gen_tlvs 0 1192 1193 -- a list of short channel ids and, maybe, one entry for each 1194 gen_scids_with :: Gen a -> Gen ([ShortChannelId], Maybe [a]) 1195 gen_scids_with g = do 1196 ss <- listOf gen_scid 1197 xs <- oneof [pure Nothing, Just <$> vectorOf (length ss) g] 1198 pure (ss, xs) 1199 1200 gen_message :: Gen Message 1201 gen_message = oneof 1202 [ MsgChannelAnnouncement <$> gen_channel_announcement 1203 , MsgNodeAnnouncement <$> gen_node_announcement 1204 , MsgChannelUpdate <$> gen_channel_update 1205 , MsgAnnouncementSignatures <$> (AnnouncementSignatures 1206 <$> (gen_bytes 32 `suchThatMap` BOLT1.channel_id) <*> gen_scid 1207 <*> gen_signature <*> gen_signature <*> gen_tlvs 0) 1208 , MsgQueryShortChannelIds <$> do 1209 (ss, fs) <- gen_scids_with (QueryFlags <$> arbitrary) 1210 QueryShortChannelIds <$> gen_chain_hash <*> pure ss <*> pure fs 1211 <*> gen_tlvs 3 1212 , MsgReplyShortChannelIdsEnd <$> (ReplyShortChannelIdsEnd 1213 <$> gen_chain_hash <*> arbitrary <*> gen_tlvs 0) 1214 , MsgQueryChannelRange <$> (QueryChannelRange 1215 <$> gen_chain_hash <*> arbitrary <*> arbitrary 1216 <*> oneof [pure Nothing, Just . QueryOption <$> arbitrary] 1217 <*> gen_tlvs 3) 1218 , MsgReplyChannelRange <$> do 1219 (ss, ts) <- gen_scids_with 1220 (ChannelUpdateTimestamps <$> arbitrary <*> arbitrary) 1221 cs <- oneof [pure Nothing, Just <$> vectorOf (length ss) 1222 (ChannelUpdateChecksums <$> arbitrary <*> arbitrary)] 1223 ReplyChannelRange <$> gen_chain_hash <*> arbitrary <*> arbitrary 1224 <*> arbitrary <*> pure ss <*> pure ts <*> pure cs <*> gen_tlvs 5 1225 , MsgGossipTimestampFilter <$> (GossipTimestampFilter 1226 <$> gen_chain_hash <*> arbitrary <*> arbitrary <*> gen_tlvs 0) 1227 ]