Main.hs (31375B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import qualified Data.ByteString as BS 6 import qualified Data.ByteString.Base16 as B16 7 import Lightning.Protocol.BOLT1 8 import Test.Tasty 9 import Test.Tasty.HUnit 10 import Test.Tasty.QuickCheck 11 12 main :: IO () 13 main = defaultMain $ testGroup "ppad-bolt1" [ 14 bigsize_tests 15 , primitive_tests 16 , signed_tests 17 , truncated_tests 18 , minsigned_tests 19 , tlv_tests 20 , message_tests 21 , envelope_tests 22 , extension_tests 23 , bounds_tests 24 , property_tests 25 ] 26 27 -- BigSize test vectors from BOLT #1 Appendix A ------------------------------- 28 29 bigsize_tests :: TestTree 30 bigsize_tests = testGroup "BigSize (Appendix A)" [ 31 testCase "zero" $ 32 encodeBigSize 0 @?= unhex "00" 33 , testCase "one byte high (252)" $ 34 encodeBigSize 252 @?= unhex "fc" 35 , testCase "two byte low (253)" $ 36 encodeBigSize 253 @?= unhex "fd00fd" 37 , testCase "two byte high (65535)" $ 38 encodeBigSize 65535 @?= unhex "fdffff" 39 , testCase "four byte low (65536)" $ 40 encodeBigSize 65536 @?= unhex "fe00010000" 41 , testCase "four byte high (4294967295)" $ 42 encodeBigSize 4294967295 @?= unhex "feffffffff" 43 , testCase "eight byte low (4294967296)" $ 44 encodeBigSize 4294967296 @?= unhex "ff0000000100000000" 45 , testCase "eight byte high (max u64)" $ 46 encodeBigSize 18446744073709551615 @?= unhex "ffffffffffffffffff" 47 , testCase "decode zero" $ 48 decodeBigSize (unhex "00") @?= Just (0, "") 49 , testCase "decode 252" $ 50 decodeBigSize (unhex "fc") @?= Just (252, "") 51 , testCase "decode 253" $ 52 decodeBigSize (unhex "fd00fd") @?= Just (253, "") 53 , testCase "decode 65535" $ 54 decodeBigSize (unhex "fdffff") @?= Just (65535, "") 55 , testCase "decode 65536" $ 56 decodeBigSize (unhex "fe00010000") @?= Just (65536, "") 57 , testCase "decode 4294967295" $ 58 decodeBigSize (unhex "feffffffff") @?= Just (4294967295, "") 59 , testCase "decode 4294967296" $ 60 decodeBigSize (unhex "ff0000000100000000") @?= Just (4294967296, "") 61 , testCase "decode max u64" $ 62 decodeBigSize (unhex "ffffffffffffffffff") @?= 63 Just (18446744073709551615, "") 64 , testCase "non-minimal 2-byte fails" $ 65 decodeBigSize (unhex "fd00fc") @?= Nothing 66 , testCase "non-minimal 4-byte fails" $ 67 decodeBigSize (unhex "fe0000ffff") @?= Nothing 68 , testCase "non-minimal 8-byte fails" $ 69 decodeBigSize (unhex "ff00000000ffffffff") @?= Nothing 70 ] 71 72 -- Primitive encode/decode tests ----------------------------------------------- 73 74 primitive_tests :: TestTree 75 primitive_tests = testGroup "Primitives" [ 76 testCase "encodeU16 0x0102" $ 77 encodeU16 0x0102 @?= BS.pack [0x01, 0x02] 78 , testCase "decodeU16 0x0102" $ 79 decodeU16 (BS.pack [0x01, 0x02]) @?= Just (0x0102, "") 80 , testCase "encodeU32 0x01020304" $ 81 encodeU32 0x01020304 @?= BS.pack [0x01, 0x02, 0x03, 0x04] 82 , testCase "decodeU32 0x01020304" $ 83 decodeU32 (BS.pack [0x01, 0x02, 0x03, 0x04]) @?= Just (0x01020304, "") 84 , testCase "encodeU64" $ 85 encodeU64 0x0102030405060708 @?= 86 BS.pack [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08] 87 , testCase "decodeU64" $ 88 decodeU64 (BS.pack [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08]) @?= 89 Just (0x0102030405060708, "") 90 , testCase "decodeU16 insufficient" $ 91 decodeU16 (BS.pack [0x01]) @?= Nothing 92 , testCase "decodeU32 insufficient" $ 93 decodeU32 (BS.pack [0x01, 0x02]) @?= Nothing 94 , testCase "decodeU64 insufficient" $ 95 decodeU64 (BS.pack [0x01, 0x02, 0x03, 0x04]) @?= Nothing 96 ] 97 98 -- Signed integer tests --------------------------------------------------------- 99 100 signed_tests :: TestTree 101 signed_tests = testGroup "Signed integers" [ 102 testCase "encodeS8 42" $ 103 encodeS8 42 @?= BS.pack [0x2a] 104 , testCase "encodeS8 -42" $ 105 encodeS8 (-42) @?= BS.pack [0xd6] 106 , testCase "encodeS8 127" $ 107 encodeS8 127 @?= BS.pack [0x7f] 108 , testCase "encodeS8 -128" $ 109 encodeS8 (-128) @?= BS.pack [0x80] 110 , testCase "decodeS8 42" $ 111 decodeS8 (BS.pack [0x2a]) @?= Just (42, "") 112 , testCase "decodeS8 -42" $ 113 decodeS8 (BS.pack [0xd6]) @?= Just (-42, "") 114 , testCase "encodeS16 -1" $ 115 encodeS16 (-1) @?= BS.pack [0xff, 0xff] 116 , testCase "encodeS16 32767" $ 117 encodeS16 32767 @?= BS.pack [0x7f, 0xff] 118 , testCase "encodeS16 -32768" $ 119 encodeS16 (-32768) @?= BS.pack [0x80, 0x00] 120 , testCase "decodeS16 -1" $ 121 decodeS16 (BS.pack [0xff, 0xff]) @?= Just (-1, "") 122 , testCase "encodeS32 -1" $ 123 encodeS32 (-1) @?= BS.pack [0xff, 0xff, 0xff, 0xff] 124 , testCase "encodeS32 2147483647" $ 125 encodeS32 2147483647 @?= BS.pack [0x7f, 0xff, 0xff, 0xff] 126 , testCase "encodeS32 -2147483648" $ 127 encodeS32 (-2147483648) @?= BS.pack [0x80, 0x00, 0x00, 0x00] 128 , testCase "decodeS32 -1" $ 129 decodeS32 (BS.pack [0xff, 0xff, 0xff, 0xff]) @?= Just (-1, "") 130 , testCase "encodeS64 -1" $ 131 encodeS64 (-1) @?= 132 BS.pack [0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff] 133 , testCase "decodeS64 -1" $ 134 decodeS64 (BS.pack [0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) @?= 135 Just (-1, "") 136 ] 137 138 -- Truncated unsigned integer tests --------------------------------------------- 139 140 truncated_tests :: TestTree 141 truncated_tests = testGroup "Truncated unsigned integers" [ 142 testCase "encodeTu16 0" $ 143 encodeTu16 0 @?= "" 144 , testCase "encodeTu16 1" $ 145 encodeTu16 1 @?= BS.pack [0x01] 146 , testCase "encodeTu16 255" $ 147 encodeTu16 255 @?= BS.pack [0xff] 148 , testCase "encodeTu16 256" $ 149 encodeTu16 256 @?= BS.pack [0x01, 0x00] 150 , testCase "encodeTu16 65535" $ 151 encodeTu16 65535 @?= BS.pack [0xff, 0xff] 152 , testCase "decodeTu16 0 bytes" $ 153 decodeTu16 0 "" @?= Just (0, "") 154 , testCase "decodeTu16 1 byte" $ 155 decodeTu16 1 (BS.pack [0x01]) @?= Just (1, "") 156 , testCase "decodeTu16 2 bytes" $ 157 decodeTu16 2 (BS.pack [0x01, 0x00]) @?= Just (256, "") 158 , testCase "decodeTu16 non-minimal fails" $ 159 decodeTu16 2 (BS.pack [0x00, 0x01]) @?= Nothing 160 , testCase "encodeTu32 0" $ 161 encodeTu32 0 @?= "" 162 , testCase "encodeTu32 1" $ 163 encodeTu32 1 @?= BS.pack [0x01] 164 , testCase "encodeTu32 0x010000" $ 165 encodeTu32 0x010000 @?= BS.pack [0x01, 0x00, 0x00] 166 , testCase "encodeTu32 0x01000000" $ 167 encodeTu32 0x01000000 @?= BS.pack [0x01, 0x00, 0x00, 0x00] 168 , testCase "decodeTu32 0 bytes" $ 169 decodeTu32 0 "" @?= Just (0, "") 170 , testCase "decodeTu32 3 bytes" $ 171 decodeTu32 3 (BS.pack [0x01, 0x00, 0x00]) @?= Just (0x010000, "") 172 , testCase "decodeTu32 non-minimal fails" $ 173 decodeTu32 3 (BS.pack [0x00, 0x01, 0x00]) @?= Nothing 174 , testCase "encodeTu64 0" $ 175 encodeTu64 0 @?= "" 176 , testCase "encodeTu64 0x0100000000" $ 177 encodeTu64 0x0100000000 @?= BS.pack [0x01, 0x00, 0x00, 0x00, 0x00] 178 , testCase "decodeTu64 5 bytes" $ 179 decodeTu64 5 (BS.pack [0x01, 0x00, 0x00, 0x00, 0x00]) @?= 180 Just (0x0100000000, "") 181 , testCase "decodeTu64 non-minimal fails" $ 182 decodeTu64 5 (BS.pack [0x00, 0x01, 0x00, 0x00, 0x00]) @?= Nothing 183 ] 184 185 -- Minimal signed integer tests (Appendix D) ------------------------------------ 186 187 minsigned_tests :: TestTree 188 minsigned_tests = testGroup "Minimal signed (Appendix D)" [ 189 -- Test vectors from BOLT #1 Appendix D 190 testCase "encode 0" $ 191 encodeMinSigned 0 @?= unhex "00" 192 , testCase "encode 42" $ 193 encodeMinSigned 42 @?= unhex "2a" 194 , testCase "encode -42" $ 195 encodeMinSigned (-42) @?= unhex "d6" 196 , testCase "encode 127" $ 197 encodeMinSigned 127 @?= unhex "7f" 198 , testCase "encode -128" $ 199 encodeMinSigned (-128) @?= unhex "80" 200 , testCase "encode 128" $ 201 encodeMinSigned 128 @?= unhex "0080" 202 , testCase "encode -129" $ 203 encodeMinSigned (-129) @?= unhex "ff7f" 204 , testCase "encode 15000" $ 205 encodeMinSigned 15000 @?= unhex "3a98" 206 , testCase "encode -15000" $ 207 encodeMinSigned (-15000) @?= unhex "c568" 208 , testCase "encode 32767" $ 209 encodeMinSigned 32767 @?= unhex "7fff" 210 , testCase "encode -32768" $ 211 encodeMinSigned (-32768) @?= unhex "8000" 212 , testCase "encode 32768" $ 213 encodeMinSigned 32768 @?= unhex "00008000" 214 , testCase "encode -32769" $ 215 encodeMinSigned (-32769) @?= unhex "ffff7fff" 216 , testCase "encode 21000000" $ 217 encodeMinSigned 21000000 @?= unhex "01406f40" 218 , testCase "encode -21000000" $ 219 encodeMinSigned (-21000000) @?= unhex "febf90c0" 220 , testCase "encode 2147483647" $ 221 encodeMinSigned 2147483647 @?= unhex "7fffffff" 222 , testCase "encode -2147483648" $ 223 encodeMinSigned (-2147483648) @?= unhex "80000000" 224 , testCase "encode 2147483648" $ 225 encodeMinSigned 2147483648 @?= unhex "0000000080000000" 226 , testCase "encode -2147483649" $ 227 encodeMinSigned (-2147483649) @?= unhex "ffffffff7fffffff" 228 , testCase "encode 500000000000" $ 229 encodeMinSigned 500000000000 @?= unhex "000000746a528800" 230 , testCase "encode -500000000000" $ 231 encodeMinSigned (-500000000000) @?= unhex "ffffff8b95ad7800" 232 , testCase "encode max int64" $ 233 encodeMinSigned 9223372036854775807 @?= unhex "7fffffffffffffff" 234 , testCase "encode min int64" $ 235 encodeMinSigned (-9223372036854775808) @?= unhex "8000000000000000" 236 -- Decode tests 237 , testCase "decode 1-byte 42" $ 238 decodeMinSigned 1 (unhex "2a") @?= Just (42, "") 239 , testCase "decode 1-byte -42" $ 240 decodeMinSigned 1 (unhex "d6") @?= Just (-42, "") 241 , testCase "decode 2-byte 128" $ 242 decodeMinSigned 2 (unhex "0080") @?= Just (128, "") 243 , testCase "decode 2-byte -129" $ 244 decodeMinSigned 2 (unhex "ff7f") @?= Just (-129, "") 245 , testCase "decode 4-byte 32768" $ 246 decodeMinSigned 4 (unhex "00008000") @?= Just (32768, "") 247 , testCase "decode 8-byte 2147483648" $ 248 decodeMinSigned 8 (unhex "0000000080000000") @?= Just (2147483648, "") 249 -- Minimality rejection 250 , testCase "decode 2-byte for 1-byte value fails" $ 251 decodeMinSigned 2 (unhex "0042") @?= Nothing -- 42 fits in 1 byte 252 , testCase "decode 4-byte for 2-byte value fails" $ 253 decodeMinSigned 4 (unhex "00000080") @?= Nothing -- 128 fits in 2 bytes 254 , testCase "decode 8-byte for 4-byte value fails" $ 255 decodeMinSigned 8 (unhex "0000000000008000") @?= Nothing -- 32768 fits in 4 256 ] 257 258 -- TLV tests ------------------------------------------------------------------- 259 260 tlv_tests :: TestTree 261 tlv_tests = testGroup "TLV" [ 262 testGroup "tlvStream smart constructor" [ 263 testCase "empty list succeeds" $ 264 tlvStream [] @?= Just (unsafeTlvStream []) 265 , testCase "single record succeeds" $ 266 tlvStream [TlvRecord 1 "a"] @?= Just (unsafeTlvStream [TlvRecord 1 "a"]) 267 , testCase "strictly increasing succeeds" $ 268 tlvStream [TlvRecord 1 "a", TlvRecord 3 "b", TlvRecord 5 "c"] @?= 269 Just (unsafeTlvStream [TlvRecord 1 "a", TlvRecord 3 "b", 270 TlvRecord 5 "c"]) 271 , testCase "non-increasing fails" $ 272 tlvStream [TlvRecord 5 "a", TlvRecord 3 "b"] @?= Nothing 273 , testCase "duplicate types fails" $ 274 tlvStream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing 275 , testCase "equal adjacent types fails" $ 276 tlvStream [TlvRecord 1 "a", TlvRecord 2 "b", TlvRecord 2 "c"] @?= 277 Nothing 278 ] 279 , testCase "empty stream" $ 280 decodeTlvStream "" @?= Right (unsafeTlvStream []) 281 , testCase "single record type 1" $ do 282 let bs = mconcat [ 283 encodeBigSize 1 -- type 284 , encodeBigSize 32 -- length 285 , BS.replicate 32 0x00 -- value (chain hash) 286 ] 287 case decodeTlvStream bs of 288 Right stream -> case unTlvStream stream of 289 [r] -> do 290 tlvType r @?= 1 291 BS.length (tlvValue r) @?= 32 292 _ -> assertFailure "expected single record" 293 Left e -> assertFailure $ "unexpected error: " ++ show e 294 , testCase "strictly increasing types" $ do 295 let bs = mconcat [ 296 encodeBigSize 1, encodeBigSize 0 297 , encodeBigSize 3, encodeBigSize 4, "test" 298 ] 299 case decodeTlvStream bs of 300 Right stream -> length (unTlvStream stream) @?= 2 301 Left e -> assertFailure $ "unexpected error: " ++ show e 302 , testCase "non-increasing types fails" $ do 303 let bs = mconcat [ 304 encodeBigSize 3, encodeBigSize 0 305 , encodeBigSize 1, encodeBigSize 0 306 ] 307 case decodeTlvStream bs of 308 Left TlvNotStrictlyIncreasing -> pure () 309 other -> assertFailure $ "expected TlvNotStrictlyIncreasing: " ++ 310 show other 311 , testCase "duplicate types fails" $ do 312 let bs = mconcat [ 313 encodeBigSize 1, encodeBigSize 0 314 , encodeBigSize 1, encodeBigSize 0 315 ] 316 case decodeTlvStream bs of 317 Left TlvNotStrictlyIncreasing -> pure () 318 other -> assertFailure $ "expected TlvNotStrictlyIncreasing: " ++ 319 show other 320 , testCase "unknown even type fails" $ do 321 let bs = mconcat [encodeBigSize 2, encodeBigSize 0] 322 case decodeTlvStream bs of 323 Left (TlvUnknownEvenType 2) -> pure () 324 other -> assertFailure $ "expected TlvUnknownEvenType: " ++ show other 325 , testCase "unknown odd type skipped" $ do 326 let bs = mconcat [ 327 encodeBigSize 5, encodeBigSize 2, "hi" 328 , encodeBigSize 7, encodeBigSize 0 329 ] 330 case decodeTlvStream bs of 331 Right stream | null (unTlvStream stream) -> pure () -- both skipped 332 other -> assertFailure $ "expected empty stream: " ++ show other 333 , testCase "length exceeds bounds fails" $ do 334 let bs = mconcat [encodeBigSize 1, encodeBigSize 100, "short"] 335 case decodeTlvStream bs of 336 Left TlvLengthExceedsBounds -> pure () 337 other -> assertFailure $ "expected TlvLengthExceedsBounds: " ++ 338 show other 339 , testCase "decodeTlvStreamWith custom predicate" $ do 340 -- Use a predicate that only knows type 5 341 let isKnown t = t == 5 342 bs = mconcat [ 343 encodeBigSize 5, encodeBigSize 2, "hi" 344 ] 345 case decodeTlvStreamWith isKnown bs of 346 Right stream -> case unTlvStream stream of 347 [r] -> tlvType r @?= 5 348 _ -> assertFailure "expected single record" 349 Left e -> assertFailure $ "unexpected error: " ++ show e 350 , testCase "decodeTlvStreamRaw returns all records" $ do 351 let bs = mconcat [ 352 encodeBigSize 2, encodeBigSize 1, "a" -- even type 353 , encodeBigSize 5, encodeBigSize 1, "b" -- odd type 354 ] 355 case decodeTlvStreamRaw bs of 356 Right stream -> length (unTlvStream stream) @?= 2 357 Left e -> assertFailure $ "unexpected error: " ++ show e 358 ] 359 360 -- Message encode/decode tests ------------------------------------------------- 361 362 message_tests :: TestTree 363 message_tests = testGroup "Messages" [ 364 testGroup "Init" [ 365 testCase "encode/decode minimal init" $ do 366 let msg = Init "" "" [] 367 case encodeMessage (MsgInitVal msg) of 368 Left e -> assertFailure $ "encode failed: " ++ show e 369 Right encoded -> case decodeMessage MsgInit encoded of 370 Right (MsgInitVal decoded, _) -> decoded @?= msg 371 other -> assertFailure $ "unexpected: " ++ show other 372 , testCase "encode/decode init with features" $ do 373 let msg = Init (BS.pack [0x01]) (BS.pack [0x02, 0x0a]) [] 374 case encodeMessage (MsgInitVal msg) of 375 Left e -> assertFailure $ "encode failed: " ++ show e 376 Right encoded -> case decodeMessage MsgInit encoded of 377 Right (MsgInitVal decoded, _) -> decoded @?= msg 378 other -> assertFailure $ "unexpected: " ++ show other 379 , testCase "encode/decode init with networks TLV" $ do 380 let ch = unsafeChainHash (BS.replicate 32 0xab) 381 msg = Init "" "" [InitNetworks [ch]] 382 case encodeMessage (MsgInitVal msg) of 383 Left e -> assertFailure $ "encode failed: " ++ show e 384 Right encoded -> case decodeMessage MsgInit encoded of 385 Right (MsgInitVal decoded, _) -> decoded @?= msg 386 other -> assertFailure $ "unexpected: " ++ show other 387 ] 388 , testGroup "Error" [ 389 testCase "encode/decode error" $ do 390 let cid = unsafeChannelId (BS.replicate 32 0xff) 391 msg = Error cid "something went wrong" 392 case encodeMessage (MsgErrorVal msg) of 393 Left e -> assertFailure $ "encode failed: " ++ show e 394 Right encoded -> case decodeMessage MsgError encoded of 395 Right (MsgErrorVal decoded, _) -> decoded @?= msg 396 other -> assertFailure $ "unexpected: " ++ show other 397 , testCase "error insufficient channel_id" $ do 398 case decodeMessage MsgError (BS.replicate 31 0x00) of 399 Left DecodeInsufficientBytes -> pure () 400 other -> assertFailure $ "expected insufficient: " ++ show other 401 ] 402 , testGroup "Warning" [ 403 testCase "encode/decode warning" $ do 404 let cid = unsafeChannelId (BS.replicate 32 0x00) 405 msg = Warning cid "be careful" 406 case encodeMessage (MsgWarningVal msg) of 407 Left e -> assertFailure $ "encode failed: " ++ show e 408 Right encoded -> case decodeMessage MsgWarning encoded of 409 Right (MsgWarningVal decoded, _) -> decoded @?= msg 410 other -> assertFailure $ "unexpected: " ++ show other 411 ] 412 , testGroup "Ping" [ 413 testCase "encode/decode ping" $ do 414 let msg = Ping 100 (BS.replicate 10 0x00) 415 case encodeMessage (MsgPingVal msg) of 416 Left e -> assertFailure $ "encode failed: " ++ show e 417 Right encoded -> case decodeMessage MsgPing encoded of 418 Right (MsgPingVal decoded, _) -> decoded @?= msg 419 other -> assertFailure $ "unexpected: " ++ show other 420 , testCase "ping with zero ignored" $ do 421 let msg = Ping 50 "" 422 case encodeMessage (MsgPingVal msg) of 423 Left e -> assertFailure $ "encode failed: " ++ show e 424 Right encoded -> case decodeMessage MsgPing encoded of 425 Right (MsgPingVal decoded, _) -> decoded @?= msg 426 other -> assertFailure $ "unexpected: " ++ show other 427 ] 428 , testGroup "Pong" [ 429 testCase "encode/decode pong" $ do 430 let msg = Pong (BS.replicate 100 0x00) 431 case encodeMessage (MsgPongVal msg) of 432 Left e -> assertFailure $ "encode failed: " ++ show e 433 Right encoded -> case decodeMessage MsgPong encoded of 434 Right (MsgPongVal decoded, _) -> decoded @?= msg 435 other -> assertFailure $ "unexpected: " ++ show other 436 ] 437 , testGroup "PeerStorage" [ 438 testCase "encode/decode peer_storage" $ do 439 let msg = PeerStorage "encrypted blob data" 440 case encodeMessage (MsgPeerStorageVal msg) of 441 Left e -> assertFailure $ "encode failed: " ++ show e 442 Right encoded -> case decodeMessage MsgPeerStorage encoded of 443 Right (MsgPeerStorageVal decoded, _) -> decoded @?= msg 444 other -> assertFailure $ "unexpected: " ++ show other 445 ] 446 , testGroup "PeerStorageRetrieval" [ 447 testCase "encode/decode peer_storage_retrieval" $ do 448 let msg = PeerStorageRetrieval "retrieved blob" 449 case encodeMessage (MsgPeerStorageRetrievalVal msg) of 450 Left e -> assertFailure $ "encode failed: " ++ show e 451 Right encoded -> case decodeMessage MsgPeerStorageRet encoded of 452 Right (MsgPeerStorageRetrievalVal decoded, _) -> decoded @?= msg 453 other -> assertFailure $ "unexpected: " ++ show other 454 ] 455 , testGroup "Unknown types" [ 456 testCase "decodeMessage unknown even type" $ do 457 case decodeMessage (MsgUnknown 100) "payload" of 458 Left (DecodeUnknownEvenType 100) -> pure () 459 other -> assertFailure $ "expected unknown even: " ++ show other 460 , testCase "decodeMessage unknown odd type" $ do 461 case decodeMessage (MsgUnknown 101) "payload" of 462 Left (DecodeUnknownOddType 101) -> pure () 463 other -> assertFailure $ "expected unknown odd: " ++ show other 464 ] 465 ] 466 467 -- Envelope tests -------------------------------------------------------------- 468 469 envelope_tests :: TestTree 470 envelope_tests = testGroup "Envelope" [ 471 testCase "encode/decode init envelope" $ do 472 let msg = MsgInitVal (Init "" "" []) 473 case encodeEnvelope msg Nothing of 474 Left e -> assertFailure $ "encode failed: " ++ show e 475 Right encoded -> case decodeEnvelope encoded of 476 Right (Just decoded, _) -> decoded @?= msg 477 other -> assertFailure $ "unexpected: " ++ show other 478 , testCase "encode/decode ping envelope" $ do 479 let msg = MsgPingVal (Ping 10 "") 480 case encodeEnvelope msg Nothing of 481 Left e -> assertFailure $ "encode failed: " ++ show e 482 Right encoded -> case decodeEnvelope encoded of 483 Right (Just decoded, _) -> decoded @?= msg 484 other -> assertFailure $ "unexpected: " ++ show other 485 , testCase "unknown even type fails" $ do 486 let bs = encodeU16 100 <> "payload" -- 100 is even, unknown 487 case decodeEnvelope bs of 488 Left (DecodeUnknownEvenType 100) -> pure () 489 other -> assertFailure $ "expected unknown even: " ++ show other 490 , testCase "unknown odd type ignored" $ do 491 let bs = encodeU16 101 <> "payload" -- 101 is odd, unknown 492 case decodeEnvelope bs of 493 Right (Nothing, Nothing) -> pure () -- ignored 494 other -> assertFailure $ "expected (Nothing, Nothing): " ++ show other 495 , testCase "insufficient bytes for type" $ do 496 case decodeEnvelope (BS.pack [0x00]) of 497 Left DecodeInsufficientBytes -> pure () 498 other -> assertFailure $ "expected insufficient: " ++ show other 499 , testCase "message type codes" $ do 500 msgTypeWord MsgInit @?= 16 501 msgTypeWord MsgError @?= 17 502 msgTypeWord MsgPing @?= 18 503 msgTypeWord MsgPong @?= 19 504 msgTypeWord MsgWarning @?= 1 505 msgTypeWord MsgPeerStorage @?= 7 506 msgTypeWord MsgPeerStorageRet @?= 9 507 ] 508 509 -- Extension TLV tests --------------------------------------------------------- 510 511 extension_tests :: TestTree 512 extension_tests = testGroup "Extension TLV" [ 513 testCase "encode envelope with extension (odd type)" $ do 514 let msg = MsgPingVal (Ping 10 "") 515 ext = unsafeTlvStream [TlvRecord 101 "extension data"] -- odd type 516 case encodeEnvelope msg (Just ext) of 517 Left e -> assertFailure $ "encode failed: " ++ show e 518 Right encoded -> do 519 -- Should contain message + extension 520 assertBool "encoded should be longer" (BS.length encoded > 6) 521 , testCase "decode envelope with odd extension - skipped per BOLT#1" $ do 522 -- Per BOLT #1: unknown odd types are ignored (skipped) 523 let msg = MsgPingVal (Ping 10 "") 524 ext = unsafeTlvStream [TlvRecord 101 "ext"] -- odd type 525 case encodeEnvelope msg (Just ext) of 526 Left e -> assertFailure $ "encode failed: " ++ show e 527 Right encoded -> case decodeEnvelope encoded of 528 Right (Just decoded, Just stream) 529 | null (unTlvStream stream) -> do 530 -- Extension is empty because unknown odd types are skipped 531 decoded @?= msg 532 other -> assertFailure $ "unexpected: " ++ show other 533 , testCase "decode envelope with unknown even extension fails" $ do 534 -- Per BOLT #1: unknown even types must cause failure 535 let pingPayload = mconcat [encodeU16 10, encodeU16 0] -- numPong=10, len=0 536 extTlv = mconcat [encodeBigSize 100, encodeBigSize 3, "abc"] -- even! 537 envelope = encodeU16 18 <> pingPayload <> extTlv -- type 18 = ping 538 case decodeEnvelope envelope of 539 Left (DecodeInvalidExtension (TlvUnknownEvenType 100)) -> pure () 540 other -> assertFailure $ "expected unknown even error: " ++ show other 541 , testCase "decode envelope with invalid extension fails" $ do 542 -- Ping + invalid TLV (non-strictly-increasing) 543 let pingPayload = mconcat [encodeU16 10, encodeU16 0] 544 badTlv = mconcat [ 545 encodeBigSize 101, encodeBigSize 1, "a" -- odd types for this test 546 , encodeBigSize 51, encodeBigSize 1, "b" -- 51 < 101, invalid 547 ] 548 envelope = encodeU16 18 <> pingPayload <> badTlv 549 case decodeEnvelope envelope of 550 Left (DecodeInvalidExtension TlvNotStrictlyIncreasing) -> pure () 551 other -> assertFailure $ "expected invalid extension: " ++ show other 552 , testCase "unknown even in extension fails even with odd types present" $ do 553 -- Mixed odd and even - should fail on the even type 554 let pingPayload = mconcat [encodeU16 10, encodeU16 0] 555 extTlv = mconcat [ 556 encodeBigSize 101, encodeBigSize 1, "a" -- odd, would be skipped 557 , encodeBigSize 200, encodeBigSize 1, "b" -- even, must fail 558 ] 559 envelope = encodeU16 18 <> pingPayload <> extTlv 560 case decodeEnvelope envelope of 561 Left (DecodeInvalidExtension (TlvUnknownEvenType 200)) -> pure () 562 other -> assertFailure $ "expected unknown even error: " ++ show other 563 ] 564 565 -- Bounds checking tests ------------------------------------------------------- 566 567 bounds_tests :: TestTree 568 bounds_tests = testGroup "Bounds checking" [ 569 testCase "encode ping with oversized ignored fails" $ do 570 let msg = Ping 10 (BS.replicate 70000 0x00) -- > 65535 571 case encodeMessage (MsgPingVal msg) of 572 Left EncodeLengthOverflow -> pure () 573 other -> assertFailure $ "expected overflow: " ++ show other 574 , testCase "encode pong with oversized ignored fails" $ do 575 let msg = Pong (BS.replicate 70000 0x00) 576 case encodeMessage (MsgPongVal msg) of 577 Left EncodeLengthOverflow -> pure () 578 other -> assertFailure $ "expected overflow: " ++ show other 579 , testCase "encode error with oversized data fails" $ do 580 let cid = unsafeChannelId (BS.replicate 32 0x00) 581 msg = Error cid (BS.replicate 70000 0x00) 582 case encodeMessage (MsgErrorVal msg) of 583 Left EncodeLengthOverflow -> pure () 584 other -> assertFailure $ "expected overflow: " ++ show other 585 , testCase "encode init with oversized features fails" $ do 586 let msg = Init "" (BS.replicate 70000 0x00) [] 587 case encodeMessage (MsgInitVal msg) of 588 Left EncodeLengthOverflow -> pure () 589 other -> assertFailure $ "expected overflow: " ++ show other 590 , testCase "encode peer_storage with oversized blob fails" $ do 591 let msg = PeerStorage (BS.replicate 70000 0x00) 592 case encodeMessage (MsgPeerStorageVal msg) of 593 Left EncodeLengthOverflow -> pure () 594 other -> assertFailure $ "expected overflow: " ++ show other 595 , testCase "encode envelope exceeding 65535 bytes fails" $ do 596 -- Create a message that fits in encodeMessage but combined with 597 -- extension exceeds 65535 bytes total 598 let msg = MsgPongVal (Pong (BS.replicate 60000 0x00)) 599 ext = unsafeTlvStream [TlvRecord 101 (BS.replicate 10000 0x00)] 600 case encodeEnvelope msg (Just ext) of 601 Left EncodeMessageTooLarge -> pure () 602 other -> assertFailure $ "expected message too large: " ++ show other 603 ] 604 605 -- Property tests -------------------------------------------------------------- 606 607 property_tests :: TestTree 608 property_tests = testGroup "Properties" [ 609 testProperty "BigSize roundtrip" $ \(NonNegative n) -> 610 case decodeBigSize (encodeBigSize n) of 611 Just (m, rest) -> m == n && BS.null rest 612 Nothing -> False 613 , testProperty "U16 roundtrip" $ \w -> 614 decodeU16 (encodeU16 w) == Just (w, "") 615 , testProperty "U32 roundtrip" $ \w -> 616 decodeU32 (encodeU32 w) == Just (w, "") 617 , testProperty "U64 roundtrip" $ \w -> 618 decodeU64 (encodeU64 w) == Just (w, "") 619 , testProperty "Ping roundtrip" $ \(NonNegative num) bs -> 620 let ignored = BS.pack (take 1000 bs) -- limit size 621 msg = Ping (fromIntegral (num `mod` 65536 :: Integer)) ignored 622 in case encodeMessage (MsgPingVal msg) of 623 Left _ -> False 624 Right encoded -> case decodeMessage MsgPing encoded of 625 Right (MsgPingVal decoded, rest) -> 626 decoded == msg && BS.null rest 627 _ -> False 628 , testProperty "Pong roundtrip" $ \bs -> 629 let ignored = BS.pack (take 1000 bs) 630 msg = Pong ignored 631 in case encodeMessage (MsgPongVal msg) of 632 Left _ -> False 633 Right encoded -> case decodeMessage MsgPong encoded of 634 Right (MsgPongVal decoded, rest) -> 635 decoded == msg && BS.null rest 636 _ -> False 637 , testProperty "PeerStorage roundtrip" $ \bs -> 638 let blob = BS.pack (take 1000 bs) 639 msg = PeerStorage blob 640 in case encodeMessage (MsgPeerStorageVal msg) of 641 Left _ -> False 642 Right encoded -> case decodeMessage MsgPeerStorage encoded of 643 Right (MsgPeerStorageVal decoded, rest) -> 644 decoded == msg && BS.null rest 645 _ -> False 646 , testProperty "Error roundtrip" $ \bs -> 647 let cid = unsafeChannelId (BS.replicate 32 0x00) 648 dat = BS.pack (take 1000 bs) 649 msg = Error cid dat 650 in case encodeMessage (MsgErrorVal msg) of 651 Left _ -> False 652 Right encoded -> case decodeMessage MsgError encoded of 653 Right (MsgErrorVal decoded, rest) -> 654 decoded == msg && BS.null rest 655 _ -> False 656 , testProperty "Envelope with odd extension (skipped per BOLT#1)" $ \bs -> 657 -- Unknown odd types in extensions are skipped per BOLT #1 658 let msg = MsgPingVal (Ping 42 "") 659 extData = BS.pack (take 100 bs) 660 ext = unsafeTlvStream [TlvRecord 101 extData] -- odd type, skipped 661 in case encodeEnvelope msg (Just ext) of 662 Left _ -> False 663 Right encoded -> case decodeEnvelope encoded of 664 -- Extension should be empty (odd types skipped) 665 Right (Just decoded, Just stream) -> 666 null (unTlvStream stream) && decoded == msg 667 _ -> False 668 ] 669 670 -- Helpers --------------------------------------------------------------------- 671 672 -- | Construct a 'ChannelId' from a known-valid 32-byte 'BS.ByteString'. 673 -- 674 -- Uses 'error' for invalid input since all channel IDs in tests are 675 -- known-valid compile-time constants. 676 unsafeChannelId :: BS.ByteString -> ChannelId 677 unsafeChannelId bs = case channelId bs of 678 Just cid -> cid 679 Nothing -> error $ "unsafeChannelId: invalid length: " ++ show (BS.length bs) 680 681 -- | Decode hex string (test-only helper). 682 -- 683 -- Uses 'error' for invalid hex since all hex literals in tests are 684 -- known-valid compile-time constants. This is acceptable in test code 685 -- where the failure would indicate a bug in the test itself. 686 unhex :: BS.ByteString -> BS.ByteString 687 unhex bs = case B16.decode bs of 688 Just r -> r 689 Nothing -> error $ "unhex: invalid hex literal: " ++ show bs 690 691 -- | Construct a ChainHash from a bytestring (test-only helper). 692 -- 693 -- Uses 'error' for invalid input since all chain hashes in tests are 694 -- known-valid 32-byte constants. This is acceptable in test code where 695 -- the failure would indicate a bug in the test itself. 696 unsafeChainHash :: BS.ByteString -> ChainHash 697 unsafeChainHash bs = case chainHash bs of 698 Just c -> c 699 Nothing -> error $ "unsafeChainHash: not 32 bytes: " ++ show (BS.length bs)