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