Main.hs (23150B)
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 qualified Data.ByteString.Char8 as B8 8 import Data.Int (Int64) 9 import qualified Data.List as L 10 import Data.Maybe (fromMaybe, isJust, isNothing) 11 import Data.Word (Word16, Word32, Word64) 12 import Lightning.Protocol.BOLT1 13 import qualified Lightning.Protocol.BOLT9 as BOLT9 14 import Test.Tasty 15 import Test.Tasty.HUnit 16 import Test.Tasty.QuickCheck 17 18 main :: IO () 19 main = defaultMain $ testGroup "ppad-bolt1" [ 20 appendix_a 21 , appendix_b 22 , appendix_c 23 , appendix_d 24 , primitives 25 , tlv 26 , messages 27 , properties 28 ] 29 30 -- helpers -------------------------------------------------------------------- 31 32 -- run an assertion on decoded hex (spaces and a 0x prefix are allowed), 33 -- failing the test if the literal isn't valid hex 34 with_hex :: String -> (BS.ByteString -> Assertion) -> Assertion 35 with_hex s k = case B16.decode (B8.pack (strip s)) of 36 Nothing -> assertFailure ("invalid hex literal: " ++ s) 37 Just bs -> k bs 38 where 39 strip = filter (/= ' ') . drop0x 40 drop0x ('0':'x':r) = r 41 drop0x r = r 42 43 is_left :: Either a b -> Bool 44 is_left = either (const True) (const False) 45 46 empty_fv :: BOLT9.FeatureVector 47 empty_fv = BOLT9.parse "" 48 49 -- Appendix A: BigSize -------------------------------------------------------- 50 51 appendix_a :: TestTree 52 appendix_a = testGroup "Appendix A (BigSize)" [ 53 testGroup "decoding" (map dec ok_vectors) 54 , testGroup "encoding" (map enc ok_vectors) 55 , testGroup "decoding failures" (map bad bad_vectors) 56 ] 57 where 58 dec (v, h) = testCase ("decode " ++ h) $ with_hex h $ \bs -> 59 decode_bigsize bs @?= Just (v, "") 60 enc (v, h) = testCase ("encode " ++ show v) $ with_hex h $ \bs -> 61 encode_bigsize v @?= bs 62 bad h = testCase ("reject " ++ show h) $ with_hex h $ \bs -> 63 decode_bigsize bs @?= Nothing 64 65 ok_vectors :: [(Word64, String)] 66 ok_vectors = [ 67 (0, "00"), (252, "fc"), (253, "fd00fd"), (65535, "fdffff") 68 , (65536, "fe00010000"), (4294967295, "feffffffff") 69 , (4294967296, "ff0000000100000000") 70 , (18446744073709551615, "ffffffffffffffffff") 71 ] 72 73 -- non-canonical encodings, short reads and no reads 74 bad_vectors = [ 75 "fd00fc", "fe0000ffff", "ff00000000ffffffff" 76 , "fd00", "feffff", "ffffffffff" 77 , "", "fd", "fe", "ff" 78 ] 79 80 -- Appendix B: TLV ------------------------------------------------------------ 81 82 -- the n1 and n2 test namespaces, decoded with bolt1's primitives 83 84 data N1 = N1Tlv1 !Word64 85 | N1Tlv2 !ShortChannelId 86 | N1Tlv3 !Point !Word64 !Word64 87 | N1Tlv4 !Word16 88 deriving (Eq, Show) 89 90 decode_n1 :: BS.ByteString -> Either String [N1] 91 decode_n1 bs = do 92 s <- either (Left . show) Right (decode_tlv_stream (`elem` n1_types) bs) 93 sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` n1_types ] 94 where 95 n1_types = [1, 2, 3, 254] 96 one (TlvRecord 1 v) = maybe (Left "tlv1") (Right . N1Tlv1) 97 (decode_tu64 v) 98 one (TlvRecord 2 v) = case decode_short_channel_id v of 99 Just (c, "") -> Right (N1Tlv2 c) 100 _ -> Left "tlv2" 101 one (TlvRecord 3 v) = maybe (Left "tlv3") Right $ do 102 (p, r0) <- decode_point v 103 (a, r1) <- decode_u64 r0 104 (b, r2) <- decode_u64 r1 105 if BS.null r2 then pure (N1Tlv3 p a b) else Nothing 106 one (TlvRecord 254 v) = case decode_u16 v of 107 Just (c, "") -> Right (N1Tlv4 c) 108 _ -> Left "tlv4" 109 one _ = Left "unreachable" 110 111 decode_n2 :: BS.ByteString -> Either String [(Word64, Word64)] 112 decode_n2 bs = do 113 s <- either (Left . show) Right (decode_tlv_stream (`elem` [0, 11]) bs) 114 sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` [0, 11] ] 115 where 116 one (TlvRecord 0 v) = maybe (Left "tlv1") (Right . (,) 0) (decode_tu64 v) 117 one (TlvRecord 11 v) = 118 maybe (Left "tlv2") (Right . (,) 11 . fromIntegral) (decode_tu32 v) 119 one _ = Left "unreachable" 120 121 appendix_b :: TestTree 122 appendix_b = testGroup "Appendix B (TLV)" [ 123 testGroup "failures in any namespace" [ 124 testCase h $ with_hex h $ \bs -> do 125 assertBool "n1" (is_left (decode_n1 bs)) 126 assertBool "n2" (is_left (decode_n2 bs)) 127 | h <- any_fail ] 128 , testGroup "n1 failures" [ 129 testCase h $ with_hex h $ \bs -> assertBool "n1" (is_left (decode_n1 bs)) 130 | h <- n1_fail ] 131 , testGroup "n2 failures" [ 132 testCase h $ with_hex h $ \bs -> assertBool "n2" (is_left (decode_n2 bs)) 133 | h <- n2_fail ] 134 , testGroup "ignored successes" [ 135 testCase h $ with_hex h $ \bs -> do 136 decode_n1 bs @?= Right [] 137 decode_n2 bs @?= Right [] 138 | h <- any_ok ] 139 , testGroup "n1 successes" [ 140 testCase h $ with_hex h $ \bs -> decode_n1 bs @?= Right [v] 141 | (h, v) <- n1_ok ] 142 , testCase "n1 tlv3" $ with_hex n1_tlv3 $ \bs -> 143 with_hex node_id $ \pk -> case point pk of 144 Nothing -> assertFailure "bad node_id" 145 Just p -> decode_n1 bs @?= Right [N1Tlv3 p 1 2] 146 , testCase "unknown even types fail when no types are known" $ 147 mapM_ (\h -> with_hex h $ \bs -> 148 assertBool h (is_left (decode_tlv_stream (const False) bs))) 149 ["12 00", "fd0102 00", "fe01000002 00", "ff0100000000000002 00"] 150 , testCase "appending a higher-numbered valid stream succeeds" $ 151 with_hex "01 01 01" $ \a -> with_hex "fd00fe 02 0226" $ \b -> 152 decode_n1 (a <> b) @?= Right [N1Tlv1 1, N1Tlv4 550] 153 , testCase "appending an invalid stream fails" $ 154 with_hex "01 01 01" $ \a -> mapM_ (\h -> with_hex h $ \b -> 155 assertBool h (is_left (decode_n1 (a <> b)))) any_fail 156 ] 157 where 158 any_fail = [ 159 "0xfd", "0xfd01", "0xfd0001 00", "0xfd0101", "0x0f fd", "0x0f fd26" 160 , "0x0f fd2602", "0x0f fd0001 00", "0x0f fd0201 " ++ replicate 1024 '0' 161 , "0x12 00", "0xfd0102 00", "0xfe01000002 00" 162 , "0xff0100000000000002 00" 163 ] 164 n1_fail = [ 165 "0x01 09 ffffffffffffffffff", "0x01 01 00", "0x01 02 0001" 166 , "0x01 03 000100", "0x01 04 00010000", "0x01 05 0001000000" 167 , "0x01 06 000100000000", "0x01 07 00010000000000" 168 , "0x01 08 0001000000000000", "0x02 07 01010101010101" 169 , "0x02 09 010101010101010101" 170 , "0x03 21 " ++ node_id 171 , "0x03 29 " ++ node_id ++ "0000000000000001" 172 , "0x03 30 " ++ node_id ++ "000000000000000100000000000001" 173 , "0x03 31 04" ++ drop 2 node_id 174 ++ "00000000000000010000000000000002" 175 , "0x03 32 " ++ node_id ++ "0000000000000001000000000000000001" 176 , "0xfd00fe 00", "0xfd00fe 01 01", "0xfd00fe 03 010101", "0x00 00" 177 , "0x02 08 0000000000000226 01 01 2a" 178 , "0x02 08 0000000000000231 02 08 0000000000000451" 179 , "0x1f 00 0f 01 2a", "0x1f 00 1f 01 2a" 180 ] 181 n2_fail = ["0xffffffffffffffffff 00 00 00"] 182 any_ok = [ 183 "0x", "0x21 00", "0xfd0201 00", "0xfd00fd 00", "0xfd00ff 00" 184 , "0xfe02000001 00", "0xff0200000000000001 00" 185 ] 186 n1_ok = [ 187 ("0x01 00", N1Tlv1 0), ("0x01 01 01", N1Tlv1 1) 188 , ("0x01 02 0100", N1Tlv1 256), ("0x01 03 010000", N1Tlv1 65536) 189 , ("0x01 04 01000000", N1Tlv1 16777216) 190 , ("0x01 05 0100000000", N1Tlv1 4294967296) 191 , ("0x01 06 010000000000", N1Tlv1 1099511627776) 192 , ("0x01 07 01000000000000", N1Tlv1 281474976710656) 193 , ("0x01 08 0100000000000000", N1Tlv1 72057594037927936) 194 , ("0x02 08 0000000000000226", N1Tlv2 (ShortChannelId 0x226)) 195 , ("0xfd00fe 02 0226", N1Tlv4 550) 196 ] 197 node_id = 198 "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb" 199 n1_tlv3 = "0x03 31 " ++ node_id ++ "00000000000000010000000000000002" 200 201 -- Appendix C: message extension ---------------------------------------------- 202 203 appendix_c :: TestTree 204 appendix_c = testGroup "Appendix C (message extension)" [ 205 testCase "no extension" $ with_hex "001000000000" $ \bs -> 206 case decode_message bs of 207 Right (MsgInit i) -> do 208 init_networks i @?= Nothing 209 init_tlvs i @?= empty_tlv_stream 210 other -> assertFailure (show other) 211 , testCase "two unknown odd records are kept" $ 212 with_hex "001000000000c9012acb0104" $ \bs -> 213 case decode_message bs of 214 Right m@(MsgInit i) -> do 215 map tlv_type (un_tlv_stream (init_tlvs i)) @?= [0xc9, 0xcb] 216 encode_message m @?= Right bs 217 other -> assertFailure (show other) 218 , testCase "truncated extension" $ with_hex "00100000000001" $ \bs -> 219 decode_message bs @?= Left (DecodeTlvError TlvTruncated) 220 , testCase "unknown even record" $ with_hex "001000000000ca012a" $ \bs -> 221 decode_message bs @?= Left (DecodeTlvError (TlvUnknownEvenType 0xca)) 222 , testCase "duplicate record" $ with_hex "001000000000c90101c90102" $ \bs -> 223 decode_message bs @?= Left (DecodeTlvError TlvNotStrictlyIncreasing) 224 ] 225 226 -- Appendix D: signed integers ------------------------------------------------ 227 228 appendix_d :: TestTree 229 appendix_d = testGroup "Appendix D (signed integers)" [ 230 testCase (show v) $ with_hex h $ \bs -> case BS.length bs of 231 1 -> do 232 encode_s8 (fromIntegral v) @?= bs 233 decode_s8 bs @?= Just (fromIntegral v, "") 234 2 -> do 235 encode_s16 (fromIntegral v) @?= bs 236 decode_s16 bs @?= Just (fromIntegral v, "") 237 4 -> do 238 encode_s32 (fromIntegral v) @?= bs 239 decode_s32 bs @?= Just (fromIntegral v, "") 240 8 -> do 241 encode_s64 v @?= bs 242 decode_s64 bs @?= Just (v, "") 243 _ -> assertFailure "bad vector width" 244 | (v, h) <- vectors ] 245 where 246 vectors :: [(Int64, String)] 247 vectors = [ 248 (0, "00"), (42, "2a"), (-42, "d6"), (127, "7f"), (-128, "80") 249 , (128, "0080"), (-129, "ff7f"), (15000, "3a98"), (-15000, "c568") 250 , (32767, "7fff"), (-32768, "8000"), (32768, "00008000") 251 , (-32769, "ffff7fff"), (21000000, "01406f40") 252 , (-21000000, "febf90c0"), (2147483647, "7fffffff") 253 , (-2147483648, "80000000"), (2147483648, "0000000080000000") 254 , (-2147483649, "ffffffff7fffffff"), (500000000000, "000000746a528800") 255 , (-500000000000, "ffffff8b95ad7800") 256 , (9223372036854775807, "7fffffffffffffff") 257 , (-9223372036854775808, "8000000000000000") 258 ] 259 260 -- primitives ----------------------------------------------------------------- 261 262 primitives :: TestTree 263 primitives = testGroup "Primitives" [ 264 testCase "u16/u32/u64 known answers" $ do 265 encode_u16 0x0102 @?= "\x01\x02" 266 encode_u32 0x01020304 @?= "\x01\x02\x03\x04" 267 encode_u64 0x0102030405060708 @?= "\x01\x02\x03\x04\x05\x06\x07\x08" 268 decode_u32 "\x01\x02\x03\x04rest" @?= Just (0x01020304, "rest") 269 , testCase "short reads fail" $ do 270 decode_u16 "\x01" @?= Nothing 271 decode_u32 "\x01\x02\x03" @?= Nothing 272 decode_u64 "\x01\x02\x03\x04\x05\x06\x07" @?= Nothing 273 decode_s8 "" @?= Nothing 274 , testCase "truncated integers" $ do 275 encode_tu64 0 @?= "" 276 encode_tu64 1 @?= "\x01" 277 encode_tu32 0x010000 @?= "\x01\x00\x00" 278 decode_tu16 "" @?= Just 0 279 decode_tu16 "\x00\x01" @?= Nothing 280 decode_tu16 "\x01\x00\x00" @?= Nothing 281 decode_tu32 "\x01\x00\x00\x00\x00" @?= Nothing 282 decode_tu64 "\x01\x00\x00\x00\x00\x00\x00\x00\x00" @?= Nothing 283 , testCase "length-prefixed bytes" $ do 284 encode_u16_prefixed "abc" @?= Just "\x00\x03\&abc" 285 encode_u16_prefixed (BS.replicate 65536 0) @?= Nothing 286 decode_u16_prefixed "\x00\x03\&abcde" @?= Just ("abc", "de") 287 decode_u16_prefixed "\x00\x03\&ab" @?= Nothing 288 , testCase "fixed-size types check their lengths" $ do 289 assertBool "chain_hash" (isNothing (chain_hash (BS.replicate 31 0))) 290 assertBool "channel_id" (isNothing (channel_id (BS.replicate 33 0))) 291 assertBool "signature" (isNothing (signature (BS.replicate 65 0))) 292 assertBool "payment_hash" (isNothing (payment_hash "")) 293 assertBool "preimage" (isNothing (payment_preimage "")) 294 assertBool "secret" (isNothing (per_commitment_secret "")) 295 , testCase "point prefix" $ do 296 assertBool "02" (isJust (point (BS.cons 0x02 (BS.replicate 32 1)))) 297 assertBool "03" (isJust (point (BS.cons 0x03 (BS.replicate 32 1)))) 298 assertBool "04" (isNothing (point (BS.cons 0x04 (BS.replicate 32 1)))) 299 assertBool "len" (isNothing (point (BS.cons 0x02 (BS.replicate 31 1)))) 300 , testCase "short_channel_id" $ case short_channel_id 539268 845 1 of 301 Nothing -> assertFailure "valid scid rejected" 302 Just c -> do 303 scid_block_height c @?= 539268 304 scid_tx_index c @?= 845 305 scid_output_index c @?= 1 306 encode_short_channel_id c @?= "\x08\x3a\x84\x00\x03\x4d\x00\x01" 307 , testCase "short_channel_id rejects 25-bit components" $ do 308 short_channel_id 0x1000000 0 0 @?= Nothing 309 short_channel_id 0 0x1000000 0 @?= Nothing 310 , testCase "amount bounds" $ do 311 fmap un_satoshi (satoshi 0x000775f05a074000) @?= Just 0x000775f05a074000 312 satoshi 0x000775f05a074001 @?= Nothing 313 fmap un_milli_satoshi (milli_satoshi 0x1d24b2dfac520000) 314 @?= Just 0x1d24b2dfac520000 315 milli_satoshi 0x1d24b2dfac520001 @?= Nothing 316 sat_to_msat max_satoshi @?= max_milli_satoshi 317 decode_satoshi (encode_u64 0x000775f05a074001) @?= Nothing 318 decode_milli_satoshi (encode_u64 maxBound) @?= Nothing 319 , testCase "checked arithmetic" $ do 320 add_sat max_satoshi max_satoshi @?= Nothing 321 (do a <- satoshi 1; b <- satoshi 2; sub_sat a b) @?= Nothing 322 (do a <- satoshi 2; b <- satoshi 1; sub_sat a b) @?= satoshi 1 323 (do a <- milli_satoshi 1; b <- milli_satoshi 2; sub_msat a b) 324 @?= Nothing 325 add_msat max_milli_satoshi max_milli_satoshi @?= Nothing 326 , testCase "secrets don't show" $ 327 case payment_preimage (BS.replicate 32 7) of 328 Nothing -> assertFailure "valid preimage rejected" 329 Just p -> do 330 show p @?= "PaymentPreimage <redacted>" 331 show (Just p) @?= "Just (PaymentPreimage <redacted>)" 332 , testCase "secret equality" $ do 333 let a = payment_preimage (BS.replicate 32 7) 334 b = payment_preimage (BS.replicate 31 7 <> "\x08") 335 assertBool "equal" (a == a) 336 assertBool "unequal" (a /= b) 337 ] 338 339 -- TLV ------------------------------------------------------------------------ 340 341 tlv :: TestTree 342 tlv = testGroup "TLV" [ 343 testCase "tlv_stream sorts" $ 344 fmap (map tlv_type . un_tlv_stream) 345 (tlv_stream [TlvRecord 5 "", TlvRecord 1 "", TlvRecord 3 ""]) 346 @?= Just [1, 3, 5] 347 , testCase "tlv_stream rejects duplicates" $ 348 tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing 349 , testCase "lookup_tlv" $ do 350 (lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"]) 351 @?= Just "b" 352 (lookup_tlv 2 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"]) 353 @?= Nothing 354 , testCase "huge lengths are rejected, not wrapped" $ 355 mapM_ (\h -> with_hex h $ \bs -> 356 decode_tlv_stream (const True) bs @?= Left TlvTruncated) 357 [ "01ffffffffffffffffff", "01ff800000000000000067" 358 , "01ffffffffffffffffff6701aa" ] 359 , testCase "truncation vs non-minimal" $ do 360 decode_tlv_stream (const True) "\xfd" @?= Left TlvTruncated 361 decode_tlv_stream (const True) "\xfd\x00\x01\x00" 362 @?= Left TlvNonMinimalBigSize 363 , testCase "unknown odd records are kept" $ 364 fmap (map tlv_type . un_tlv_stream) 365 (decode_tlv_stream (const False) "\x01\x00\x03\x01\x2a") 366 @?= Right [1, 3] 367 ] 368 369 -- messages ------------------------------------------------------------------- 370 371 messages :: TestTree 372 messages = testGroup "Messages" [ 373 testCase "pong known answer" $ 374 encode_message (MsgPong (Pong "\x00\x00" empty_tlv_stream)) 375 @?= Right "\x00\x13\x00\x02\x00\x00" 376 , testCase "ping known answer" $ 377 encode_message (MsgPing (Ping 4 "" empty_tlv_stream)) 378 @?= Right "\x00\x12\x00\x04\x00\x00" 379 , testCase "error known answer" $ 380 encode_message (MsgError (Error all_channels "x" empty_tlv_stream)) 381 @?= Right ("\x00\x11" <> BS.replicate 32 0 <> "\x00\x01x") 382 , testCase "init with networks and remote_addr" $ 383 case chain_hash (BS.replicate 32 0x6f) of 384 Nothing -> assertFailure "valid chain hash rejected" 385 Just ch -> do 386 let addr = "\x01\x7f\x00\x00\x01\x26\x07" 387 i = Init empty_fv (BOLT9.parse "\x02") (Just [ch]) 388 (Just addr) empty_tlv_stream 389 wire = "\x00\x10\x00\x00\x00\x01\x02" 390 <> "\x01\x20" <> un_chain_hash ch <> "\x03\x07" <> addr 391 encode_message (MsgInit i) @?= Right wire 392 decode_message wire @?= Right (MsgInit i) 393 , testCase "init networks must be a multiple of 32 bytes" $ 394 decode_init "\x00\x00\x00\x00\x01\x01\x00" 395 @?= Left (DecodeInvalidTlvValue 1) 396 , testCase "init rejects tlvs clashing with typed fields" $ 397 case tlv_stream [TlvRecord 3 "x"] of 398 Nothing -> assertFailure "valid stream rejected" 399 Just s -> encode_init (Init empty_fv empty_fv Nothing (Just "y") s) 400 @?= Left EncodeInvalidTlvs 401 , testCase "unknown message types" $ do 402 decode_message "\x00\x20" @?= Left (DecodeUnknownEvenType 32) 403 decode_message "\x80\x01" @?= Left (DecodeUnknownOddType 32769) 404 decode_message "\x00" @?= Left DecodeInsufficientBytes 405 , testCase "truncated payloads" $ do 406 decode_init "\x00" @?= Left DecodeInsufficientBytes 407 decode_init "\x00\x01" @?= Left DecodeInsufficientBytes 408 decode_error (BS.replicate 31 0) @?= Left DecodeInsufficientBytes 409 decode_warning (BS.replicate 33 0) @?= Left DecodeInsufficientBytes 410 decode_ping "\x00\x04\x00\x02\x00" @?= Left DecodeInsufficientBytes 411 decode_pong "\x00\x02\x00" @?= Left DecodeInsufficientBytes 412 decode_peer_storage "\x00\x01" @?= Left DecodeInsufficientBytes 413 decode_peer_storage_retrieval "\x00" @?= Left DecodeInsufficientBytes 414 , testCase "invalid extensions" $ do 415 decode_pong "\x00\x00\x02\x00" @?= Left 416 (DecodeTlvError (TlvUnknownEvenType 2)) 417 decode_ping "\x00\x00\x00\x00\x01" @?= Left (DecodeTlvError TlvTruncated) 418 , testCase "message size limit" $ do 419 encode_envelope 7 (BS.replicate 65533 0) @?= 420 Right (encode_u16 7 <> BS.replicate 65533 0) 421 encode_envelope 7 (BS.replicate 65534 0) @?= Left EncodeMessageTooLarge 422 encode_message (MsgPeerStorage (PeerStorage (BS.replicate 65532 0) 423 empty_tlv_stream)) @?= Left EncodeMessageTooLarge 424 encode_pong (Pong (BS.replicate 65536 0) empty_tlv_stream) 425 @?= Left EncodeLengthOverflow 426 , testCase "ping_response" $ do 427 ping_response (Ping 3 "ab" empty_tlv_stream) 428 @?= Just (Pong "\x00\x00\x00" empty_tlv_stream) 429 ping_response (Ping 65531 "" empty_tlv_stream) @?= 430 Just (Pong (BS.replicate 65531 0) empty_tlv_stream) 431 ping_response (Ping 65532 "" empty_tlv_stream) @?= Nothing 432 ] 433 434 -- properties ----------------------------------------------------------------- 435 436 newtype Bytes = Bytes BS.ByteString 437 deriving Show 438 439 instance Arbitrary Bytes where 440 arbitrary = Bytes . BS.pack <$> (choose (0, 64) >>= vector) 441 442 -- streams of unknown odd records 443 newtype OddTlvs = OddTlvs TlvStream 444 deriving Show 445 446 instance Arbitrary OddTlvs where 447 arbitrary = do 448 ts <- L.nub . map (\t -> 2 * (t `div` 2) + 1) 449 <$> listOf (arbitrary :: Gen Word64) 450 vs <- vectorOf (length ts) arbitrary 451 pure . OddTlvs . fromMaybe empty_tlv_stream $ 452 tlv_stream [ TlvRecord t v | (t, Bytes v) <- zip ts vs ] 453 454 newtype Bytes32 = Bytes32 BS.ByteString 455 deriving Show 456 457 instance Arbitrary Bytes32 where 458 arbitrary = Bytes32 . BS.pack <$> vector 32 459 460 newtype Msg = Msg Message 461 deriving Show 462 463 instance Arbitrary Msg where 464 arbitrary = Msg <$> oneof [ 465 do Bytes a <- arbitrary 466 Bytes b <- arbitrary 467 nets <- oneof [pure Nothing, Just <$> listOf chain] 468 addr <- oneof [pure Nothing, (\(Bytes x) -> Just x) <$> arbitrary] 469 OddTlvs s <- arbitrary 470 let s' = filter_tlv_stream (\t -> t /= 1 && t /= 3) s 471 pure (MsgInit (Init (BOLT9.parse a) (BOLT9.parse b) nets addr s')) 472 , do c <- cid 473 Bytes d <- arbitrary 474 OddTlvs s <- arbitrary 475 pure (MsgError (Error c d s)) 476 , do c <- cid 477 Bytes d <- arbitrary 478 OddTlvs s <- arbitrary 479 pure (MsgWarning (Warning c d s)) 480 , do n <- arbitrary 481 Bytes d <- arbitrary 482 OddTlvs s <- arbitrary 483 pure (MsgPing (Ping n d s)) 484 , do Bytes d <- arbitrary 485 OddTlvs s <- arbitrary 486 pure (MsgPong (Pong d s)) 487 , do Bytes d <- arbitrary 488 OddTlvs s <- arbitrary 489 pure (MsgPeerStorage (PeerStorage d s)) 490 , do Bytes d <- arbitrary 491 OddTlvs s <- arbitrary 492 pure (MsgPeerStorageRetrieval (PeerStorageRetrieval d s)) 493 ] 494 where 495 chain = do 496 Bytes32 b <- arbitrary 497 maybe chain pure (chain_hash b) 498 cid = do 499 Bytes32 b <- arbitrary 500 pure (fromMaybe all_channels (channel_id b)) 501 502 properties :: TestTree 503 properties = testGroup "Properties" [ 504 testProperty "bigsize round-trips" $ \w -> 505 decode_bigsize (encode_bigsize w) === Just (w, "") 506 , testProperty "tu16 round-trips" $ \w -> 507 decode_tu16 (encode_tu16 w) === Just w 508 , testProperty "tu32 round-trips" $ \w -> 509 decode_tu32 (encode_tu32 w) === Just w 510 , testProperty "tu64 round-trips" $ \w -> 511 decode_tu64 (encode_tu64 w) === Just w 512 , testProperty "u16 round-trips" $ \w -> 513 decode_u16 (encode_u16 w) === Just (w, "") 514 , testProperty "u32 round-trips" $ \w -> 515 decode_u32 (encode_u32 w) === Just (w, "") 516 , testProperty "u64 round-trips" $ \w -> 517 decode_u64 (encode_u64 w) === Just (w, "") 518 , testProperty "s64 round-trips" $ \w -> 519 decode_s64 (encode_s64 w) === Just (w, "") 520 , testProperty "scid components round-trip" $ \h t o -> 521 let h' = h `mod` 0x1000000 :: Word32 522 t' = t `mod` 0x1000000 :: Word32 523 in fmap (\c -> (scid_block_height c, scid_tx_index c, 524 scid_output_index c)) (short_channel_id h' t' o) 525 === Just (h', t', o) 526 , testProperty "sat -> msat -> sat is the identity" $ 527 forAll (choose (0, 0x000775f05a074000)) $ \w -> 528 fmap (msat_to_sat . sat_to_msat) (satoshi w) === satoshi w 529 , testProperty "add then sub is the identity" $ 530 forAll (choose (0, 0x000775f05a074000)) $ \a -> 531 forAll (choose (0, 0x000775f05a074000 - a)) $ \b -> 532 (do x <- satoshi a 533 y <- satoshi b 534 z <- add_sat x y 535 sub_sat z y) === satoshi a 536 , testProperty "tlv streams round-trip" $ \(OddTlvs s) -> 537 decode_tlv_stream (const False) (encode_tlv_stream s) === Right s 538 , testProperty "messages round-trip" $ \(Msg m) -> 539 case encode_message m of 540 Left e -> counterexample (show e) False 541 Right bs -> decode_message bs === Right m 542 , testProperty "re-encoding reproduces the wire bytes" $ \(Msg m) -> 543 case encode_message m of 544 Left e -> counterexample (show e) False 545 Right bs -> case decode_message bs of 546 Left e -> counterexample (show e) False 547 Right m' -> encode_message m' === Right bs 548 ]