commit 03232f36d797c377d8cd3ebbf9370c0a7e7ae0e8
parent 36fceee777eeeff95f642d81d0b64f204017e13e
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 13:22:19 +0400
test: cover every BOLT #1 appendix vector
Appendix A (BigSize, including short and no reads), Appendix B (the n1
and n2 namespaces, built from the public primitives), Appendix C
(init extensions) and Appendix D (per-width signed integers), plus
negative tests for each rejection rule and round-trip properties for
the codecs and every message.
Diffstat:
| A | test/Main.hs | | | 548 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 548 insertions(+), 0 deletions(-)
diff --git a/test/Main.hs b/test/Main.hs
@@ -0,0 +1,548 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Char8 as B8
+import Data.Int (Int64)
+import qualified Data.List as L
+import Data.Maybe (fromMaybe, isJust, isNothing)
+import Data.Word (Word16, Word32, Word64)
+import Lightning.Protocol.BOLT1
+import qualified Lightning.Protocol.BOLT9 as BOLT9
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+
+main :: IO ()
+main = defaultMain $ testGroup "ppad-bolt1" [
+ appendix_a
+ , appendix_b
+ , appendix_c
+ , appendix_d
+ , primitives
+ , tlv
+ , messages
+ , properties
+ ]
+
+-- helpers --------------------------------------------------------------------
+
+-- run an assertion on decoded hex (spaces and a 0x prefix are allowed),
+-- failing the test if the literal isn't valid hex
+with_hex :: String -> (BS.ByteString -> Assertion) -> Assertion
+with_hex s k = case B16.decode (B8.pack (strip s)) of
+ Nothing -> assertFailure ("invalid hex literal: " ++ s)
+ Just bs -> k bs
+ where
+ strip = filter (/= ' ') . drop0x
+ drop0x ('0':'x':r) = r
+ drop0x r = r
+
+is_left :: Either a b -> Bool
+is_left = either (const True) (const False)
+
+empty_fv :: BOLT9.FeatureVector
+empty_fv = BOLT9.parse ""
+
+-- Appendix A: BigSize --------------------------------------------------------
+
+appendix_a :: TestTree
+appendix_a = testGroup "Appendix A (BigSize)" [
+ testGroup "decoding" (map dec ok_vectors)
+ , testGroup "encoding" (map enc ok_vectors)
+ , testGroup "decoding failures" (map bad bad_vectors)
+ ]
+ where
+ dec (v, h) = testCase ("decode " ++ h) $ with_hex h $ \bs ->
+ decode_bigsize bs @?= Just (v, "")
+ enc (v, h) = testCase ("encode " ++ show v) $ with_hex h $ \bs ->
+ encode_bigsize v @?= bs
+ bad h = testCase ("reject " ++ show h) $ with_hex h $ \bs ->
+ decode_bigsize bs @?= Nothing
+
+ ok_vectors :: [(Word64, String)]
+ ok_vectors = [
+ (0, "00"), (252, "fc"), (253, "fd00fd"), (65535, "fdffff")
+ , (65536, "fe00010000"), (4294967295, "feffffffff")
+ , (4294967296, "ff0000000100000000")
+ , (18446744073709551615, "ffffffffffffffffff")
+ ]
+
+ -- non-canonical encodings, short reads and no reads
+ bad_vectors = [
+ "fd00fc", "fe0000ffff", "ff00000000ffffffff"
+ , "fd00", "feffff", "ffffffffff"
+ , "", "fd", "fe", "ff"
+ ]
+
+-- Appendix B: TLV ------------------------------------------------------------
+
+-- the n1 and n2 test namespaces, decoded with bolt1's primitives
+
+data N1 = N1Tlv1 !Word64
+ | N1Tlv2 !ShortChannelId
+ | N1Tlv3 !Point !Word64 !Word64
+ | N1Tlv4 !Word16
+ deriving (Eq, Show)
+
+decode_n1 :: BS.ByteString -> Either String [N1]
+decode_n1 bs = do
+ s <- either (Left . show) Right (decode_tlv_stream (`elem` n1_types) bs)
+ sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` n1_types ]
+ where
+ n1_types = [1, 2, 3, 254]
+ one (TlvRecord 1 v) = maybe (Left "tlv1") (Right . N1Tlv1)
+ (decode_tu64 v)
+ one (TlvRecord 2 v) = case decode_short_channel_id v of
+ Just (c, "") -> Right (N1Tlv2 c)
+ _ -> Left "tlv2"
+ one (TlvRecord 3 v) = maybe (Left "tlv3") Right $ do
+ (p, r0) <- decode_point v
+ (a, r1) <- decode_u64 r0
+ (b, r2) <- decode_u64 r1
+ if BS.null r2 then pure (N1Tlv3 p a b) else Nothing
+ one (TlvRecord 254 v) = case decode_u16 v of
+ Just (c, "") -> Right (N1Tlv4 c)
+ _ -> Left "tlv4"
+ one _ = Left "unreachable"
+
+decode_n2 :: BS.ByteString -> Either String [(Word64, Word64)]
+decode_n2 bs = do
+ s <- either (Left . show) Right (decode_tlv_stream (`elem` [0, 11]) bs)
+ sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` [0, 11] ]
+ where
+ one (TlvRecord 0 v) = maybe (Left "tlv1") (Right . (,) 0) (decode_tu64 v)
+ one (TlvRecord 11 v) =
+ maybe (Left "tlv2") (Right . (,) 11 . fromIntegral) (decode_tu32 v)
+ one _ = Left "unreachable"
+
+appendix_b :: TestTree
+appendix_b = testGroup "Appendix B (TLV)" [
+ testGroup "failures in any namespace" [
+ testCase h $ with_hex h $ \bs -> do
+ assertBool "n1" (is_left (decode_n1 bs))
+ assertBool "n2" (is_left (decode_n2 bs))
+ | h <- any_fail ]
+ , testGroup "n1 failures" [
+ testCase h $ with_hex h $ \bs -> assertBool "n1" (is_left (decode_n1 bs))
+ | h <- n1_fail ]
+ , testGroup "n2 failures" [
+ testCase h $ with_hex h $ \bs -> assertBool "n2" (is_left (decode_n2 bs))
+ | h <- n2_fail ]
+ , testGroup "ignored successes" [
+ testCase h $ with_hex h $ \bs -> do
+ decode_n1 bs @?= Right []
+ decode_n2 bs @?= Right []
+ | h <- any_ok ]
+ , testGroup "n1 successes" [
+ testCase h $ with_hex h $ \bs -> decode_n1 bs @?= Right [v]
+ | (h, v) <- n1_ok ]
+ , testCase "n1 tlv3" $ with_hex n1_tlv3 $ \bs ->
+ with_hex node_id $ \pk -> case point pk of
+ Nothing -> assertFailure "bad node_id"
+ Just p -> decode_n1 bs @?= Right [N1Tlv3 p 1 2]
+ , testCase "unknown even types fail when no types are known" $
+ mapM_ (\h -> with_hex h $ \bs ->
+ assertBool h (is_left (decode_tlv_stream (const False) bs)))
+ ["12 00", "fd0102 00", "fe01000002 00", "ff0100000000000002 00"]
+ , testCase "appending a higher-numbered valid stream succeeds" $
+ with_hex "01 01 01" $ \a -> with_hex "fd00fe 02 0226" $ \b ->
+ decode_n1 (a <> b) @?= Right [N1Tlv1 1, N1Tlv4 550]
+ , testCase "appending an invalid stream fails" $
+ with_hex "01 01 01" $ \a -> mapM_ (\h -> with_hex h $ \b ->
+ assertBool h (is_left (decode_n1 (a <> b)))) any_fail
+ ]
+ where
+ any_fail = [
+ "0xfd", "0xfd01", "0xfd0001 00", "0xfd0101", "0x0f fd", "0x0f fd26"
+ , "0x0f fd2602", "0x0f fd0001 00", "0x0f fd0201 " ++ replicate 1024 '0'
+ , "0x12 00", "0xfd0102 00", "0xfe01000002 00"
+ , "0xff0100000000000002 00"
+ ]
+ n1_fail = [
+ "0x01 09 ffffffffffffffffff", "0x01 01 00", "0x01 02 0001"
+ , "0x01 03 000100", "0x01 04 00010000", "0x01 05 0001000000"
+ , "0x01 06 000100000000", "0x01 07 00010000000000"
+ , "0x01 08 0001000000000000", "0x02 07 01010101010101"
+ , "0x02 09 010101010101010101"
+ , "0x03 21 " ++ node_id
+ , "0x03 29 " ++ node_id ++ "0000000000000001"
+ , "0x03 30 " ++ node_id ++ "000000000000000100000000000001"
+ , "0x03 31 04" ++ drop 2 node_id
+ ++ "00000000000000010000000000000002"
+ , "0x03 32 " ++ node_id ++ "0000000000000001000000000000000001"
+ , "0xfd00fe 00", "0xfd00fe 01 01", "0xfd00fe 03 010101", "0x00 00"
+ , "0x02 08 0000000000000226 01 01 2a"
+ , "0x02 08 0000000000000231 02 08 0000000000000451"
+ , "0x1f 00 0f 01 2a", "0x1f 00 1f 01 2a"
+ ]
+ n2_fail = ["0xffffffffffffffffff 00 00 00"]
+ any_ok = [
+ "0x", "0x21 00", "0xfd0201 00", "0xfd00fd 00", "0xfd00ff 00"
+ , "0xfe02000001 00", "0xff0200000000000001 00"
+ ]
+ n1_ok = [
+ ("0x01 00", N1Tlv1 0), ("0x01 01 01", N1Tlv1 1)
+ , ("0x01 02 0100", N1Tlv1 256), ("0x01 03 010000", N1Tlv1 65536)
+ , ("0x01 04 01000000", N1Tlv1 16777216)
+ , ("0x01 05 0100000000", N1Tlv1 4294967296)
+ , ("0x01 06 010000000000", N1Tlv1 1099511627776)
+ , ("0x01 07 01000000000000", N1Tlv1 281474976710656)
+ , ("0x01 08 0100000000000000", N1Tlv1 72057594037927936)
+ , ("0x02 08 0000000000000226", N1Tlv2 (ShortChannelId 0x226))
+ , ("0xfd00fe 02 0226", N1Tlv4 550)
+ ]
+ node_id =
+ "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"
+ n1_tlv3 = "0x03 31 " ++ node_id ++ "00000000000000010000000000000002"
+
+-- Appendix C: message extension ----------------------------------------------
+
+appendix_c :: TestTree
+appendix_c = testGroup "Appendix C (message extension)" [
+ testCase "no extension" $ with_hex "001000000000" $ \bs ->
+ case decode_message bs of
+ Right (MsgInit i) -> do
+ init_networks i @?= Nothing
+ init_tlvs i @?= empty_tlv_stream
+ other -> assertFailure (show other)
+ , testCase "two unknown odd records are kept" $
+ with_hex "001000000000c9012acb0104" $ \bs ->
+ case decode_message bs of
+ Right m@(MsgInit i) -> do
+ map tlv_type (un_tlv_stream (init_tlvs i)) @?= [0xc9, 0xcb]
+ encode_message m @?= Right bs
+ other -> assertFailure (show other)
+ , testCase "truncated extension" $ with_hex "00100000000001" $ \bs ->
+ decode_message bs @?= Left (DecodeTlvError TlvTruncated)
+ , testCase "unknown even record" $ with_hex "001000000000ca012a" $ \bs ->
+ decode_message bs @?= Left (DecodeTlvError (TlvUnknownEvenType 0xca))
+ , testCase "duplicate record" $ with_hex "001000000000c90101c90102" $ \bs ->
+ decode_message bs @?= Left (DecodeTlvError TlvNotStrictlyIncreasing)
+ ]
+
+-- Appendix D: signed integers ------------------------------------------------
+
+appendix_d :: TestTree
+appendix_d = testGroup "Appendix D (signed integers)" [
+ testCase (show v) $ with_hex h $ \bs -> case BS.length bs of
+ 1 -> do
+ encode_s8 (fromIntegral v) @?= bs
+ decode_s8 bs @?= Just (fromIntegral v, "")
+ 2 -> do
+ encode_s16 (fromIntegral v) @?= bs
+ decode_s16 bs @?= Just (fromIntegral v, "")
+ 4 -> do
+ encode_s32 (fromIntegral v) @?= bs
+ decode_s32 bs @?= Just (fromIntegral v, "")
+ 8 -> do
+ encode_s64 v @?= bs
+ decode_s64 bs @?= Just (v, "")
+ _ -> assertFailure "bad vector width"
+ | (v, h) <- vectors ]
+ where
+ vectors :: [(Int64, String)]
+ vectors = [
+ (0, "00"), (42, "2a"), (-42, "d6"), (127, "7f"), (-128, "80")
+ , (128, "0080"), (-129, "ff7f"), (15000, "3a98"), (-15000, "c568")
+ , (32767, "7fff"), (-32768, "8000"), (32768, "00008000")
+ , (-32769, "ffff7fff"), (21000000, "01406f40")
+ , (-21000000, "febf90c0"), (2147483647, "7fffffff")
+ , (-2147483648, "80000000"), (2147483648, "0000000080000000")
+ , (-2147483649, "ffffffff7fffffff"), (500000000000, "000000746a528800")
+ , (-500000000000, "ffffff8b95ad7800")
+ , (9223372036854775807, "7fffffffffffffff")
+ , (-9223372036854775808, "8000000000000000")
+ ]
+
+-- primitives -----------------------------------------------------------------
+
+primitives :: TestTree
+primitives = testGroup "Primitives" [
+ testCase "u16/u32/u64 known answers" $ do
+ encode_u16 0x0102 @?= "\x01\x02"
+ encode_u32 0x01020304 @?= "\x01\x02\x03\x04"
+ encode_u64 0x0102030405060708 @?= "\x01\x02\x03\x04\x05\x06\x07\x08"
+ decode_u32 "\x01\x02\x03\x04rest" @?= Just (0x01020304, "rest")
+ , testCase "short reads fail" $ do
+ decode_u16 "\x01" @?= Nothing
+ decode_u32 "\x01\x02\x03" @?= Nothing
+ decode_u64 "\x01\x02\x03\x04\x05\x06\x07" @?= Nothing
+ decode_s8 "" @?= Nothing
+ , testCase "truncated integers" $ do
+ encode_tu64 0 @?= ""
+ encode_tu64 1 @?= "\x01"
+ encode_tu32 0x010000 @?= "\x01\x00\x00"
+ decode_tu16 "" @?= Just 0
+ decode_tu16 "\x00\x01" @?= Nothing
+ decode_tu16 "\x01\x00\x00" @?= Nothing
+ decode_tu32 "\x01\x00\x00\x00\x00" @?= Nothing
+ decode_tu64 "\x01\x00\x00\x00\x00\x00\x00\x00\x00" @?= Nothing
+ , testCase "length-prefixed bytes" $ do
+ encode_u16_prefixed "abc" @?= Just "\x00\x03\&abc"
+ encode_u16_prefixed (BS.replicate 65536 0) @?= Nothing
+ decode_u16_prefixed "\x00\x03\&abcde" @?= Just ("abc", "de")
+ decode_u16_prefixed "\x00\x03\&ab" @?= Nothing
+ , testCase "fixed-size types check their lengths" $ do
+ assertBool "chain_hash" (isNothing (chain_hash (BS.replicate 31 0)))
+ assertBool "channel_id" (isNothing (channel_id (BS.replicate 33 0)))
+ assertBool "signature" (isNothing (signature (BS.replicate 65 0)))
+ assertBool "payment_hash" (isNothing (payment_hash ""))
+ assertBool "preimage" (isNothing (payment_preimage ""))
+ assertBool "secret" (isNothing (per_commitment_secret ""))
+ , testCase "point prefix" $ do
+ assertBool "02" (isJust (point (BS.cons 0x02 (BS.replicate 32 1))))
+ assertBool "03" (isJust (point (BS.cons 0x03 (BS.replicate 32 1))))
+ assertBool "04" (isNothing (point (BS.cons 0x04 (BS.replicate 32 1))))
+ assertBool "len" (isNothing (point (BS.cons 0x02 (BS.replicate 31 1))))
+ , testCase "short_channel_id" $ case short_channel_id 539268 845 1 of
+ Nothing -> assertFailure "valid scid rejected"
+ Just c -> do
+ scid_block_height c @?= 539268
+ scid_tx_index c @?= 845
+ scid_output_index c @?= 1
+ encode_short_channel_id c @?= "\x08\x3a\x84\x00\x03\x4d\x00\x01"
+ , testCase "short_channel_id rejects 25-bit components" $ do
+ short_channel_id 0x1000000 0 0 @?= Nothing
+ short_channel_id 0 0x1000000 0 @?= Nothing
+ , testCase "amount bounds" $ do
+ fmap un_satoshi (satoshi 0x000775f05a074000) @?= Just 0x000775f05a074000
+ satoshi 0x000775f05a074001 @?= Nothing
+ fmap un_milli_satoshi (milli_satoshi 0x1d24b2dfac520000)
+ @?= Just 0x1d24b2dfac520000
+ milli_satoshi 0x1d24b2dfac520001 @?= Nothing
+ sat_to_msat max_satoshi @?= max_milli_satoshi
+ decode_satoshi (encode_u64 0x000775f05a074001) @?= Nothing
+ decode_milli_satoshi (encode_u64 maxBound) @?= Nothing
+ , testCase "checked arithmetic" $ do
+ add_sat max_satoshi max_satoshi @?= Nothing
+ (do a <- satoshi 1; b <- satoshi 2; sub_sat a b) @?= Nothing
+ (do a <- satoshi 2; b <- satoshi 1; sub_sat a b) @?= satoshi 1
+ (do a <- milli_satoshi 1; b <- milli_satoshi 2; sub_msat a b)
+ @?= Nothing
+ add_msat max_milli_satoshi max_milli_satoshi @?= Nothing
+ , testCase "secrets don't show" $
+ case payment_preimage (BS.replicate 32 7) of
+ Nothing -> assertFailure "valid preimage rejected"
+ Just p -> do
+ show p @?= "PaymentPreimage <redacted>"
+ show (Just p) @?= "Just (PaymentPreimage <redacted>)"
+ , testCase "secret equality" $ do
+ let a = payment_preimage (BS.replicate 32 7)
+ b = payment_preimage (BS.replicate 31 7 <> "\x08")
+ assertBool "equal" (a == a)
+ assertBool "unequal" (a /= b)
+ ]
+
+-- TLV ------------------------------------------------------------------------
+
+tlv :: TestTree
+tlv = testGroup "TLV" [
+ testCase "tlv_stream sorts" $
+ fmap (map tlv_type . un_tlv_stream)
+ (tlv_stream [TlvRecord 5 "", TlvRecord 1 "", TlvRecord 3 ""])
+ @?= Just [1, 3, 5]
+ , testCase "tlv_stream rejects duplicates" $
+ tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing
+ , testCase "lookup_tlv" $ do
+ (lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"])
+ @?= Just "b"
+ (lookup_tlv 2 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"])
+ @?= Nothing
+ , testCase "huge lengths are rejected, not wrapped" $
+ mapM_ (\h -> with_hex h $ \bs ->
+ decode_tlv_stream (const True) bs @?= Left TlvTruncated)
+ [ "01ffffffffffffffffff", "01ff800000000000000067"
+ , "01ffffffffffffffffff6701aa" ]
+ , testCase "truncation vs non-minimal" $ do
+ decode_tlv_stream (const True) "\xfd" @?= Left TlvTruncated
+ decode_tlv_stream (const True) "\xfd\x00\x01\x00"
+ @?= Left TlvNonMinimalBigSize
+ , testCase "unknown odd records are kept" $
+ fmap (map tlv_type . un_tlv_stream)
+ (decode_tlv_stream (const False) "\x01\x00\x03\x01\x2a")
+ @?= Right [1, 3]
+ ]
+
+-- messages -------------------------------------------------------------------
+
+messages :: TestTree
+messages = testGroup "Messages" [
+ testCase "pong known answer" $
+ encode_message (MsgPong (Pong "\x00\x00" empty_tlv_stream))
+ @?= Right "\x00\x13\x00\x02\x00\x00"
+ , testCase "ping known answer" $
+ encode_message (MsgPing (Ping 4 "" empty_tlv_stream))
+ @?= Right "\x00\x12\x00\x04\x00\x00"
+ , testCase "error known answer" $
+ encode_message (MsgError (Error all_channels "x" empty_tlv_stream))
+ @?= Right ("\x00\x11" <> BS.replicate 32 0 <> "\x00\x01x")
+ , testCase "init with networks and remote_addr" $
+ case chain_hash (BS.replicate 32 0x6f) of
+ Nothing -> assertFailure "valid chain hash rejected"
+ Just ch -> do
+ let addr = "\x01\x7f\x00\x00\x01\x26\x07"
+ i = Init empty_fv (BOLT9.parse "\x02") (Just [ch])
+ (Just addr) empty_tlv_stream
+ wire = "\x00\x10\x00\x00\x00\x01\x02"
+ <> "\x01\x20" <> un_chain_hash ch <> "\x03\x07" <> addr
+ encode_message (MsgInit i) @?= Right wire
+ decode_message wire @?= Right (MsgInit i)
+ , testCase "init networks must be a multiple of 32 bytes" $
+ decode_init "\x00\x00\x00\x00\x01\x01\x00"
+ @?= Left (DecodeInvalidTlvValue 1)
+ , testCase "init rejects tlvs clashing with typed fields" $
+ case tlv_stream [TlvRecord 3 "x"] of
+ Nothing -> assertFailure "valid stream rejected"
+ Just s -> encode_init (Init empty_fv empty_fv Nothing (Just "y") s)
+ @?= Left EncodeInvalidTlvs
+ , testCase "unknown message types" $ do
+ decode_message "\x00\x20" @?= Left (DecodeUnknownEvenType 32)
+ decode_message "\x80\x01" @?= Left (DecodeUnknownOddType 32769)
+ decode_message "\x00" @?= Left DecodeInsufficientBytes
+ , testCase "truncated payloads" $ do
+ decode_init "\x00" @?= Left DecodeInsufficientBytes
+ decode_init "\x00\x01" @?= Left DecodeInsufficientBytes
+ decode_error (BS.replicate 31 0) @?= Left DecodeInsufficientBytes
+ decode_warning (BS.replicate 33 0) @?= Left DecodeInsufficientBytes
+ decode_ping "\x00\x04\x00\x02\x00" @?= Left DecodeInsufficientBytes
+ decode_pong "\x00\x02\x00" @?= Left DecodeInsufficientBytes
+ decode_peer_storage "\x00\x01" @?= Left DecodeInsufficientBytes
+ decode_peer_storage_retrieval "\x00" @?= Left DecodeInsufficientBytes
+ , testCase "invalid extensions" $ do
+ decode_pong "\x00\x00\x02\x00" @?= Left
+ (DecodeTlvError (TlvUnknownEvenType 2))
+ decode_ping "\x00\x00\x00\x00\x01" @?= Left (DecodeTlvError TlvTruncated)
+ , testCase "message size limit" $ do
+ encode_envelope 7 (BS.replicate 65533 0) @?=
+ Right (encode_u16 7 <> BS.replicate 65533 0)
+ encode_envelope 7 (BS.replicate 65534 0) @?= Left EncodeMessageTooLarge
+ encode_message (MsgPeerStorage (PeerStorage (BS.replicate 65532 0)
+ empty_tlv_stream)) @?= Left EncodeMessageTooLarge
+ encode_pong (Pong (BS.replicate 65536 0) empty_tlv_stream)
+ @?= Left EncodeLengthOverflow
+ , testCase "ping_response" $ do
+ ping_response (Ping 3 "ab" empty_tlv_stream)
+ @?= Just (Pong "\x00\x00\x00" empty_tlv_stream)
+ ping_response (Ping 65531 "" empty_tlv_stream) @?=
+ Just (Pong (BS.replicate 65531 0) empty_tlv_stream)
+ ping_response (Ping 65532 "" empty_tlv_stream) @?= Nothing
+ ]
+
+-- properties -----------------------------------------------------------------
+
+newtype Bytes = Bytes BS.ByteString
+ deriving Show
+
+instance Arbitrary Bytes where
+ arbitrary = Bytes . BS.pack <$> (choose (0, 64) >>= vector)
+
+-- streams of unknown odd records
+newtype OddTlvs = OddTlvs TlvStream
+ deriving Show
+
+instance Arbitrary OddTlvs where
+ arbitrary = do
+ ts <- L.nub . map (\t -> 2 * (t `div` 2) + 1)
+ <$> listOf (arbitrary :: Gen Word64)
+ vs <- vectorOf (length ts) arbitrary
+ pure . OddTlvs . fromMaybe empty_tlv_stream $
+ tlv_stream [ TlvRecord t v | (t, Bytes v) <- zip ts vs ]
+
+newtype Bytes32 = Bytes32 BS.ByteString
+ deriving Show
+
+instance Arbitrary Bytes32 where
+ arbitrary = Bytes32 . BS.pack <$> vector 32
+
+newtype Msg = Msg Message
+ deriving Show
+
+instance Arbitrary Msg where
+ arbitrary = Msg <$> oneof [
+ do Bytes a <- arbitrary
+ Bytes b <- arbitrary
+ nets <- oneof [pure Nothing, Just <$> listOf chain]
+ addr <- oneof [pure Nothing, (\(Bytes x) -> Just x) <$> arbitrary]
+ OddTlvs s <- arbitrary
+ let s' = filter_tlv_stream (\t -> t /= 1 && t /= 3) s
+ pure (MsgInit (Init (BOLT9.parse a) (BOLT9.parse b) nets addr s'))
+ , do c <- cid
+ Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgError (Error c d s))
+ , do c <- cid
+ Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgWarning (Warning c d s))
+ , do n <- arbitrary
+ Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPing (Ping n d s))
+ , do Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPong (Pong d s))
+ , do Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPeerStorage (PeerStorage d s))
+ , do Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPeerStorageRetrieval (PeerStorageRetrieval d s))
+ ]
+ where
+ chain = do
+ Bytes32 b <- arbitrary
+ maybe chain pure (chain_hash b)
+ cid = do
+ Bytes32 b <- arbitrary
+ pure (fromMaybe all_channels (channel_id b))
+
+properties :: TestTree
+properties = testGroup "Properties" [
+ testProperty "bigsize round-trips" $ \w ->
+ decode_bigsize (encode_bigsize w) === Just (w, "")
+ , testProperty "tu16 round-trips" $ \w ->
+ decode_tu16 (encode_tu16 w) === Just w
+ , testProperty "tu32 round-trips" $ \w ->
+ decode_tu32 (encode_tu32 w) === Just w
+ , testProperty "tu64 round-trips" $ \w ->
+ decode_tu64 (encode_tu64 w) === Just w
+ , testProperty "u16 round-trips" $ \w ->
+ decode_u16 (encode_u16 w) === Just (w, "")
+ , testProperty "u32 round-trips" $ \w ->
+ decode_u32 (encode_u32 w) === Just (w, "")
+ , testProperty "u64 round-trips" $ \w ->
+ decode_u64 (encode_u64 w) === Just (w, "")
+ , testProperty "s64 round-trips" $ \w ->
+ decode_s64 (encode_s64 w) === Just (w, "")
+ , testProperty "scid components round-trip" $ \h t o ->
+ let h' = h `mod` 0x1000000 :: Word32
+ t' = t `mod` 0x1000000 :: Word32
+ in fmap (\c -> (scid_block_height c, scid_tx_index c,
+ scid_output_index c)) (short_channel_id h' t' o)
+ === Just (h', t', o)
+ , testProperty "sat -> msat -> sat is the identity" $
+ forAll (choose (0, 0x000775f05a074000)) $ \w ->
+ fmap (msat_to_sat . sat_to_msat) (satoshi w) === satoshi w
+ , testProperty "add then sub is the identity" $
+ forAll (choose (0, 0x000775f05a074000)) $ \a ->
+ forAll (choose (0, 0x000775f05a074000 - a)) $ \b ->
+ (do x <- satoshi a
+ y <- satoshi b
+ z <- add_sat x y
+ sub_sat z y) === satoshi a
+ , testProperty "tlv streams round-trip" $ \(OddTlvs s) ->
+ decode_tlv_stream (const False) (encode_tlv_stream s) === Right s
+ , testProperty "messages round-trip" $ \(Msg m) ->
+ case encode_message m of
+ Left e -> counterexample (show e) False
+ Right bs -> decode_message bs === Right m
+ , testProperty "re-encoding reproduces the wire bytes" $ \(Msg m) ->
+ case encode_message m of
+ Left e -> counterexample (show e) False
+ Right bs -> case decode_message bs of
+ Left e -> counterexample (show e) False
+ Right m' -> encode_message m' === Right bs
+ ]
