Main.hs (50625B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import qualified Bitcoin.Prim.Tx as Tx 6 import qualified Data.ByteString as BS 7 import qualified Data.ByteString.Base16 as B16 8 import qualified Data.ByteString.Char8 as B8 9 import Data.Int (Int64) 10 import Data.Word (Word8, Word64) 11 import qualified Lightning.Protocol.BOLT1 as BOLT1 12 import Lightning.Protocol.BOLT1 (TlvRecord(..), TlvError(..)) 13 import Lightning.Protocol.BOLT2 14 import qualified Lightning.Protocol.BOLT9 as BOLT9 15 import Test.Tasty 16 import Test.Tasty.HUnit 17 import Test.Tasty.QuickCheck hiding (witness) 18 19 main :: IO () 20 main = defaultMain $ testGroup "ppad-bolt2" [ 21 known_answers 22 , tlv_handling 23 , decoding_failures 24 , encoding_failures 25 , field_types 26 , properties 27 ] 28 29 -- helpers -------------------------------------------------------------------- 30 31 rep :: Int -> String -> String 32 rep n = concat . replicate n 33 34 hx :: String -> Maybe BS.ByteString 35 hx = B16.decode . B8.pack 36 37 -- decode a hex literal, failing the test if it isn't valid hex 38 unhex :: String -> IO BS.ByteString 39 unhex s = maybe (assertFailure ("invalid hex literal: " ++ s)) pure (hx s) 40 41 -- unwrap a fixture, failing the test if it couldn't be constructed 42 just :: String -> Maybe a -> IO a 43 just what = maybe (assertFailure ("invalid fixture: " ++ what)) pure 44 45 empty :: BOLT1.TlvStream 46 empty = BOLT1.empty_tlv_stream 47 48 -- the unknown TLV records of a message 49 message_tlvs :: Message -> BOLT1.TlvStream 50 message_tlvs m = case m of 51 MsgOpenChannel a -> open_channel_tlvs a 52 MsgAcceptChannel a -> accept_channel_tlvs a 53 MsgFundingCreated a -> funding_created_tlvs a 54 MsgFundingSigned a -> funding_signed_tlvs a 55 MsgChannelReady a -> channel_ready_tlvs a 56 MsgOpenChannel2 a -> open_channel2_tlvs a 57 MsgAcceptChannel2 a -> accept_channel2_tlvs a 58 MsgTxAddInput a -> tx_add_input_tlvs a 59 MsgTxAddOutput a -> tx_add_output_tlvs a 60 MsgTxRemoveInput a -> tx_remove_input_tlvs a 61 MsgTxRemoveOutput a -> tx_remove_output_tlvs a 62 MsgTxComplete a -> tx_complete_tlvs a 63 MsgTxSignatures a -> tx_signatures_tlvs a 64 MsgTxInitRbf a -> tx_init_rbf_tlvs a 65 MsgTxAckRbf a -> tx_ack_rbf_tlvs a 66 MsgTxAbort a -> tx_abort_tlvs a 67 MsgStfu a -> stfu_tlvs a 68 MsgShutdown a -> shutdown_tlvs a 69 MsgClosingComplete a -> closing_complete_tlvs a 70 MsgClosingSig a -> closing_sig_tlvs a 71 MsgClosingSigned a -> closing_signed_tlvs a 72 MsgUpdateAddHtlc a -> update_add_htlc_tlvs a 73 MsgUpdateFulfillHtlc a -> update_fulfill_htlc_tlvs a 74 MsgUpdateFailHtlc a -> update_fail_htlc_tlvs a 75 MsgUpdateFailMalformedHtlc a -> update_fail_malformed_htlc_tlvs a 76 MsgCommitmentSigned a -> commitment_signed_tlvs a 77 MsgRevokeAndAck a -> revoke_and_ack_tlvs a 78 MsgUpdateFee a -> update_fee_tlvs a 79 MsgChannelReestablish a -> channel_reestablish_tlvs a 80 81 -- field values --------------------------------------------------------------- 82 83 -- the bitcoin genesis block hash, in internal byte order 84 chain_h :: String 85 chain_h = "6fe28c0ab6f1b372c1a6a246ae63f74f931e8365e15a089c68d6190000000000" 86 87 cid_h, tcid_h, txid_h, secret_h, preimage_h, phash_h :: String 88 cid_h = rep 32 "ab" 89 tcid_h = rep 32 "cd" 90 txid_h = rep 32 "7e" 91 secret_h = rep 32 "5e" 92 preimage_h = rep 32 "50" 93 phash_h = rep 32 "9a" 94 95 p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h :: String 96 p1_h = "02" ++ rep 32 "11" 97 p2_h = "03" ++ rep 32 "22" 98 p3_h = "02" ++ rep 32 "33" 99 p4_h = "03" ++ rep 32 "44" 100 p5_h = "02" ++ rep 32 "55" 101 p6_h = "03" ++ rep 32 "66" 102 p7_h = "02" ++ rep 32 "77" 103 104 sig1_h, sig2_h, sig3_h :: String 105 sig1_h = rep 64 "a1" 106 sig2_h = rep 64 "b2" 107 sig3_h = rep 64 "c3" 108 109 -- version, ephemeral key, hop payloads, hmac 110 onion_h :: String 111 onion_h = "00" ++ p3_h ++ rep 1300 "44" ++ rep 32 "55" 112 113 -- twenty hold times of 100, then 210 truncated hmacs 114 attribution_h :: String 115 attribution_h = rep 20 "00000064" ++ rep 210 "0badf00d" 116 117 p2wpkh_h, p2wsh_h, p2tr_h :: String 118 p2wpkh_h = "0014" ++ rep 20 "88" 119 p2wsh_h = "0020" ++ rep 32 "99" 120 p2tr_h = "5120" ++ rep 32 "ee" 121 122 -- the sha256 of the empty string 123 onion_hash_h :: String 124 onion_hash_h = 125 "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 126 127 f_chain :: Maybe BOLT1.ChainHash 128 f_chain = BOLT1.chain_hash =<< hx chain_h 129 130 f_cid, f_tcid :: Maybe BOLT1.ChannelId 131 f_cid = BOLT1.channel_id =<< hx cid_h 132 f_tcid = BOLT1.channel_id =<< hx tcid_h 133 134 f_point :: String -> Maybe BOLT1.Point 135 f_point h = BOLT1.point =<< hx h 136 137 f_sig :: String -> Maybe BOLT1.Signature 138 f_sig h = BOLT1.signature =<< hx h 139 140 f_txid :: Maybe Tx.TxId 141 f_txid = Tx.mk_txid =<< hx txid_h 142 143 f_secret :: Maybe BOLT1.PerCommitmentSecret 144 f_secret = BOLT1.per_commitment_secret =<< hx secret_h 145 146 f_script :: String -> Maybe ScriptPubKey 147 f_script h = script_pubkey =<< hx h 148 149 f_attribution :: Maybe AttributionData 150 f_attribution = attribution_data =<< hx attribution_h 151 152 anchors :: BOLT9.FeatureVector 153 anchors = BOLT9.channel_type_features 154 (BOLT9.ChannelType BOLT9.BasicAnchors False False) 155 156 sat :: Word64 -> Maybe BOLT1.Satoshi 157 sat = BOLT1.satoshi 158 159 msat :: Word64 -> Maybe BOLT1.MilliSatoshi 160 msat = BOLT1.milli_satoshi 161 162 -- message layouts ------------------------------------------------------------ 163 164 -- A message's layout: its type and fixed fields (hex, assembled by hand 165 -- from the spec) and its known TLV types, each with a valid value and 166 -- some malformed ones. 167 data Layout = Layout 168 { lay_name :: String 169 , lay_type :: String 170 , lay_fixed :: [String] 171 , lay_known :: [(Word64, String, [String])] 172 } 173 174 open_channel_lay :: Layout 175 open_channel_lay = Layout "open_channel" "0020" [ 176 chain_h 177 , tcid_h 178 , "00000000000f4240" -- funding_satoshis: 1000000 179 , "00000000000003e8" -- push_msat: 1000 180 , "0000000000000222" -- dust_limit_satoshis: 546 181 , "ffffffffffffffff" -- max_htlc_value_in_flight_msat: u64 max 182 , "0000000000002710" -- channel_reserve_satoshis: 10000 183 , "0000000000000001" -- htlc_minimum_msat: 1 184 , "000000fd" -- feerate_per_kw: 253 185 , "0090" -- to_self_delay: 144 186 , "01e3" -- max_accepted_htlcs: 483 187 , p1_h, p2_h, p3_h, p4_h, p5_h, p6_h 188 , "01" -- channel_flags 189 ] [ (0, p2wpkh_h, []), (1, "401000", []) ] 190 191 accept_channel_lay :: Layout 192 accept_channel_lay = Layout "accept_channel" "0021" [ 193 tcid_h 194 , "0000000000000222" -- dust_limit_satoshis: 546 195 , "0000000005f5e100" -- max_htlc_value_in_flight_msat: 100000000 196 , "0000000000002710" -- channel_reserve_satoshis: 10000 197 , "00000000000003e8" -- htlc_minimum_msat: 1000 198 , "00000003" -- minimum_depth: 3 199 , "0090" -- to_self_delay: 144 200 , "01e3" -- max_accepted_htlcs: 483 201 , p1_h, p2_h, p3_h, p4_h, p5_h, p6_h 202 ] [ (0, "", []), (1, "401000", []) ] 203 204 funding_created_lay :: Layout 205 funding_created_lay = Layout "funding_created" "0022" [ 206 tcid_h 207 , txid_h 208 , "0001" -- funding_output_index: 1 209 , sig1_h 210 ] [] 211 212 funding_signed_lay :: Layout 213 funding_signed_lay = Layout "funding_signed" "0023" [ cid_h, sig1_h ] [] 214 215 channel_ready_lay :: Layout 216 channel_ready_lay = Layout "channel_ready" "0024" [ cid_h, p1_h ] 217 [ (1, "083a8400034d0001", ["083a8400034d00", "083a8400034d000100"]) ] 218 219 open_channel2_lay :: Layout 220 open_channel2_lay = Layout "open_channel2" "0040" [ 221 chain_h 222 , tcid_h 223 , "00000fa0" -- funding_feerate_perkw: 4000 224 , "000000fd" -- commitment_feerate_perkw: 253 225 , "0000000000030d40" -- funding_satoshis: 200000 226 , "0000000000000162" -- dust_limit_satoshis: 354 227 , "ffffffffffffffff" -- max_htlc_value_in_flight_msat: u64 max 228 , "0000000000000001" -- htlc_minimum_msat: 1 229 , "0090" -- to_self_delay: 144 230 , "01e3" -- max_accepted_htlcs: 483 231 , "000c3500" -- locktime: 800000 232 , p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h 233 , "00" -- channel_flags 234 ] [ (0, p2wpkh_h, []), (1, "401000", []), (2, "", ["00", "01"]) ] 235 236 accept_channel2_lay :: Layout 237 accept_channel2_lay = Layout "accept_channel2" "0041" [ 238 tcid_h 239 , "0000000000000000" -- funding_satoshis: 0 240 , "0000000000000162" -- dust_limit_satoshis: 354 241 , "0000000005f5e100" -- max_htlc_value_in_flight_msat: 100000000 242 , "00000000000003e8" -- htlc_minimum_msat: 1000 243 , "00000006" -- minimum_depth: 6 244 , "0090" -- to_self_delay: 144 245 , "001e" -- max_accepted_htlcs: 30 246 , p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h 247 ] [ (0, p2wsh_h, []), (1, "401000", []), (2, "", ["00"]) ] 248 249 tx_add_input_lay :: Layout 250 tx_add_input_lay = Layout "tx_add_input" "0042" [ 251 cid_h 252 , "0000000000000002" -- serial_id: 2 253 , "0005", "0102030405" -- prevtx 254 , "00000001" -- prevtx_vout: 1 255 , "fffffffd" -- sequence 256 ] [] 257 258 tx_add_output_lay :: Layout 259 tx_add_output_lay = Layout "tx_add_output" "0043" [ 260 cid_h 261 , "0000000000000004" -- serial_id: 4 262 , "0000000000030d40" -- sats: 200000 263 , "0022", p2wsh_h -- script 264 ] [] 265 266 tx_remove_input_lay :: Layout 267 tx_remove_input_lay = Layout "tx_remove_input" "0044" 268 [ cid_h, "0000000000000002" ] [] 269 270 tx_remove_output_lay :: Layout 271 tx_remove_output_lay = Layout "tx_remove_output" "0045" 272 [ cid_h, "0000000000000005" ] [] 273 274 tx_complete_lay :: Layout 275 tx_complete_lay = Layout "tx_complete" "0046" [ cid_h ] [] 276 277 tx_signatures_lay :: Layout 278 tx_signatures_lay = Layout "tx_signatures" "0047" [ 279 cid_h 280 , txid_h 281 , "0002" -- num_witnesses 282 , "0006", "0202aaaa01bb" -- two stack items 283 , "0003", "0101cc" -- one stack item 284 ] [] 285 286 tx_init_rbf_lay :: Layout 287 tx_init_rbf_lay = Layout "tx_init_rbf" "0048" [ 288 cid_h 289 , "000c3500" -- locktime: 800000 290 , "00001046" -- feerate: 4166 291 ] [ (0, "0000000000030d40", ["00030d40", "000000000000030d40"]) 292 , (2, "", ["00"]) ] 293 294 tx_ack_rbf_lay :: Layout 295 tx_ack_rbf_lay = Layout "tx_ack_rbf" "0049" [ cid_h ] 296 [ (0, "fffffffffffe7960", ["ff"]), (2, "", ["2a2a"]) ] 297 298 tx_abort_lay :: Layout 299 tx_abort_lay = Layout "tx_abort" "004a" [ 300 cid_h 301 , "000c", "6661696c656420636865636b" -- "failed check" 302 ] [] 303 304 stfu_lay :: Layout 305 stfu_lay = Layout "stfu" "0002" [ cid_h, "01" ] [] 306 307 shutdown_lay :: Layout 308 shutdown_lay = Layout "shutdown" "0026" [ cid_h, "0016", p2wpkh_h ] [] 309 310 closing_complete_lay :: Layout 311 closing_complete_lay = Layout "closing_complete" "0028" [ 312 cid_h 313 , "0016", p2wpkh_h -- closer_scriptpubkey 314 , "0022", p2tr_h -- closee_scriptpubkey 315 , "00000000000001f4" -- fee_satoshis: 500 316 , "00000000" -- locktime: 0 317 ] [ (t, sig1_h, [rep 63 "a1", rep 65 "a1"]) | t <- [1, 2, 3] ] 318 319 closing_sig_lay :: Layout 320 closing_sig_lay = Layout "closing_sig" "0029" [ 321 cid_h 322 , "0016", p2wpkh_h -- closer_scriptpubkey 323 , "0022", p2tr_h -- closee_scriptpubkey 324 , "00000000000001f4" -- fee_satoshis: 500 325 , "000c3500" -- locktime: 800000 326 ] [ (t, sig3_h, [rep 63 "c3", ""]) | t <- [1, 2, 3] ] 327 328 closing_signed_lay :: Layout 329 closing_signed_lay = Layout "closing_signed" "0027" [ 330 cid_h 331 , "00000000000001f4" -- fee_satoshis: 500 332 , sig1_h 333 ] [ (1, "000000000000006400000000000003e8", [ 334 "000000000000006400000000000003" 335 , "000000000000006400000000000003e800" 336 , "0000000000000064ffffffffffffffff" -- max fee above 21M BTC 337 ]) ] 338 339 update_add_htlc_lay :: Layout 340 update_add_htlc_lay = Layout "update_add_htlc" "0080" [ 341 cid_h 342 , "0000000000000000" -- id: 0 343 , "00000000000186a0" -- amount_msat: 100000 344 , phash_h 345 , "000c3550" -- cltv_expiry: 800080 346 , onion_h 347 ] [ (0, p2_h, [ rep 32 "22", p2_h ++ "00", "04" ++ rep 32 "22" ]) ] 348 349 update_fulfill_htlc_lay :: Layout 350 update_fulfill_htlc_lay = Layout "update_fulfill_htlc" "0082" [ 351 cid_h 352 , "0000000000000007" -- id: 7 353 , preimage_h 354 ] [ (1, attribution_h, [ drop 2 attribution_h, attribution_h ++ "00" ]) 355 , (3, "deadbeef", []) ] 356 357 update_fail_htlc_lay :: Layout 358 update_fail_htlc_lay = Layout "update_fail_htlc" "0083" [ 359 cid_h 360 , "0000000000000007" -- id: 7 361 , "0004", "01020304" -- reason 362 ] [ (1, attribution_h, [ "" ]) ] 363 364 update_fail_malformed_htlc_lay :: Layout 365 update_fail_malformed_htlc_lay = 366 Layout "update_fail_malformed_htlc" "0087" [ 367 cid_h 368 , "0000000000000003" -- id: 3 369 , onion_hash_h 370 , "c005" -- failure_code: BADONION | PERM | 5 371 ] [] 372 373 commitment_signed_lay :: Layout 374 commitment_signed_lay = Layout "commitment_signed" "0084" [ 375 cid_h 376 , sig1_h 377 , "0002" -- num_htlcs 378 , sig2_h, sig3_h 379 ] [ (1, txid_h, [ rep 31 "7e", rep 33 "7e" ]) ] 380 381 revoke_and_ack_lay :: Layout 382 revoke_and_ack_lay = Layout "revoke_and_ack" "0085" 383 [ cid_h, secret_h, p1_h ] [] 384 385 update_fee_lay :: Layout 386 update_fee_lay = Layout "update_fee" "0086" 387 [ cid_h, "000009c4" ] [] -- feerate_per_kw: 2500 388 389 channel_reestablish_lay :: Layout 390 channel_reestablish_lay = Layout "channel_reestablish" "0088" [ 391 cid_h 392 , "0000000000000005" -- next_commitment_number: 5 393 , "0000000000000004" -- next_revocation_number: 4 394 , secret_h 395 , p1_h 396 ] [ (1, txid_h ++ "01", [ txid_h, txid_h ++ "0100" ]) ] 397 398 layouts :: [Layout] 399 layouts = [ 400 open_channel_lay, accept_channel_lay, funding_created_lay 401 , funding_signed_lay, channel_ready_lay, open_channel2_lay 402 , accept_channel2_lay, tx_add_input_lay, tx_add_output_lay 403 , tx_remove_input_lay, tx_remove_output_lay, tx_complete_lay 404 , tx_signatures_lay, tx_init_rbf_lay, tx_ack_rbf_lay, tx_abort_lay 405 , stfu_lay, shutdown_lay, closing_complete_lay, closing_sig_lay 406 , closing_signed_lay, update_add_htlc_lay, update_fulfill_htlc_lay 407 , update_fail_htlc_lay, update_fail_malformed_htlc_lay 408 , commitment_signed_lay, revoke_and_ack_lay, update_fee_lay 409 , channel_reestablish_lay 410 ] 411 412 -- a TLV record, in hex (for types below 253 and values below 65536 413 -- bytes) 414 tlv_h :: Word64 -> String -> String 415 tlv_h t v = hex2 t ++ len ++ v 416 where 417 n = fromIntegral (length v `div` 2) :: Word64 418 len | n < 253 = hex2 n 419 | otherwise = "fd" ++ hex2 (n `div` 256) ++ hex2 (n `mod` 256) 420 421 -- a byte, in hex 422 hex2 :: Word64 -> String 423 hex2 w = [digit (w `div` 16), digit (w `mod` 16)] 424 where 425 digit d = maybe '?' id (lookup d (zip [0 ..] "0123456789abcdef")) 426 427 -- known answers -------------------------------------------------------------- 428 429 -- Check a message against wire bytes assembled by hand: its payload 430 -- decodes to the expected value and re-encodes to the same bytes, and 431 -- likewise for the full message. 432 kat 433 :: (Eq a, Show a) 434 => String 435 -> Layout 436 -> [String] -- TLV records, hex 437 -> (BS.ByteString -> Either DecodeError a) 438 -> (a -> Either EncodeError BS.ByteString) 439 -> (a -> Message) 440 -> Maybe a 441 -> TestTree 442 kat name lay recs dec enc wrap expected = testCase name $ do 443 payload <- unhex (concat (lay_fixed lay ++ recs)) 444 wire <- unhex (lay_type lay ++ concat (lay_fixed lay ++ recs)) 445 m <- just name expected 446 dec payload @?= Right m 447 enc m @?= Right payload 448 decode_message wire @?= Right (wrap m) 449 encode_message (wrap m) @?= Right wire 450 451 known_answers :: TestTree 452 known_answers = testGroup "known answers" [ 453 kat "open_channel" open_channel_lay 454 [ tlv_h 0 p2wpkh_h, tlv_h 1 "401000" ] 455 decode_open_channel encode_open_channel MsgOpenChannel $ do 456 ch <- f_chain 457 tcid <- f_tcid 458 fund <- sat 1000000 459 push <- msat 1000 460 dust <- sat 546 461 res <- sat 10000 462 hmin <- msat 1 463 [a, b, c, d, e, f] <- traverse f_point 464 [p1_h, p2_h, p3_h, p4_h, p5_h, p6_h] 465 spk <- f_script p2wpkh_h 466 pure (OpenChannel ch tcid fund push dust maxBound res hmin 253 144 467 483 a b c d e f 1 (Just spk) (Just anchors) empty) 468 469 , kat "open_channel (no TLVs)" open_channel_lay [] 470 decode_open_channel encode_open_channel MsgOpenChannel $ do 471 ch <- f_chain 472 tcid <- f_tcid 473 fund <- sat 1000000 474 push <- msat 1000 475 dust <- sat 546 476 res <- sat 10000 477 hmin <- msat 1 478 [a, b, c, d, e, f] <- traverse f_point 479 [p1_h, p2_h, p3_h, p4_h, p5_h, p6_h] 480 pure (OpenChannel ch tcid fund push dust maxBound res hmin 253 144 481 483 a b c d e f 1 Nothing Nothing empty) 482 483 , kat "accept_channel" accept_channel_lay 484 [ tlv_h 0 "", tlv_h 1 "401000" ] 485 decode_accept_channel encode_accept_channel MsgAcceptChannel $ do 486 tcid <- f_tcid 487 dust <- sat 546 488 res <- sat 10000 489 hmin <- msat 1000 490 [a, b, c, d, e, f] <- traverse f_point 491 [p1_h, p2_h, p3_h, p4_h, p5_h, p6_h] 492 spk <- script_pubkey "" 493 pure (AcceptChannel tcid dust 100000000 res hmin 3 144 483 494 a b c d e f (Just spk) (Just anchors) empty) 495 496 , kat "funding_created" funding_created_lay [] 497 decode_funding_created (Right . encode_funding_created) 498 MsgFundingCreated $ do 499 tcid <- f_tcid 500 t <- f_txid 501 s <- f_sig sig1_h 502 pure (FundingCreated tcid t 1 s empty) 503 504 , kat "funding_signed" funding_signed_lay [] 505 decode_funding_signed (Right . encode_funding_signed) 506 MsgFundingSigned $ do 507 cid <- f_cid 508 s <- f_sig sig1_h 509 pure (FundingSigned cid s empty) 510 511 , kat "channel_ready" channel_ready_lay 512 [ tlv_h 1 "083a8400034d0001" ] 513 decode_channel_ready encode_channel_ready MsgChannelReady $ do 514 cid <- f_cid 515 pcp <- f_point p1_h 516 alias <- BOLT1.short_channel_id 539268 845 1 517 pure (ChannelReady cid pcp (Just alias) empty) 518 519 , kat "open_channel2" open_channel2_lay 520 [ tlv_h 0 p2wpkh_h, tlv_h 1 "401000", tlv_h 2 "" ] 521 decode_open_channel2 encode_open_channel2 MsgOpenChannel2 $ do 522 ch <- f_chain 523 tcid <- f_tcid 524 fund <- sat 200000 525 dust <- sat 354 526 hmin <- msat 1 527 [a, b, c, d, e, f, g] <- traverse f_point 528 [p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h] 529 spk <- f_script p2wpkh_h 530 pure (OpenChannel2 ch tcid 4000 253 fund dust maxBound hmin 144 483 531 800000 a b c d e f g 0 (Just spk) (Just anchors) True 532 empty) 533 534 , kat "accept_channel2" accept_channel2_lay 535 [ tlv_h 0 p2wsh_h, tlv_h 1 "401000", tlv_h 2 "" ] 536 decode_accept_channel2 encode_accept_channel2 MsgAcceptChannel2 $ do 537 tcid <- f_tcid 538 fund <- sat 0 539 dust <- sat 354 540 hmin <- msat 1000 541 [a, b, c, d, e, f, g] <- traverse f_point 542 [p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h] 543 spk <- f_script p2wsh_h 544 pure (AcceptChannel2 tcid fund dust 100000000 hmin 6 144 30 545 a b c d e f g (Just spk) (Just anchors) True empty) 546 547 , kat "tx_add_input" tx_add_input_lay [] 548 decode_tx_add_input encode_tx_add_input MsgTxAddInput $ do 549 cid <- f_cid 550 pure (TxAddInput cid (SerialId 2) "\x01\x02\x03\x04\x05" 1 551 0xfffffffd empty) 552 553 , kat "tx_add_output" tx_add_output_lay [] 554 decode_tx_add_output (Right . encode_tx_add_output) 555 MsgTxAddOutput $ do 556 cid <- f_cid 557 amt <- sat 200000 558 spk <- f_script p2wsh_h 559 pure (TxAddOutput cid (SerialId 4) amt spk empty) 560 561 , kat "tx_remove_input" tx_remove_input_lay [] 562 decode_tx_remove_input (Right . encode_tx_remove_input) 563 MsgTxRemoveInput $ do 564 cid <- f_cid 565 pure (TxRemoveInput cid (SerialId 2) empty) 566 567 , kat "tx_remove_output" tx_remove_output_lay [] 568 decode_tx_remove_output (Right . encode_tx_remove_output) 569 MsgTxRemoveOutput $ do 570 cid <- f_cid 571 pure (TxRemoveOutput cid (SerialId 5) empty) 572 573 , kat "tx_complete" tx_complete_lay [] 574 decode_tx_complete (Right . encode_tx_complete) MsgTxComplete $ do 575 cid <- f_cid 576 pure (TxComplete cid empty) 577 578 , kat "tx_signatures" tx_signatures_lay [] 579 decode_tx_signatures encode_tx_signatures MsgTxSignatures $ do 580 cid <- f_cid 581 t <- f_txid 582 w1 <- witness "\x02\x02\xaa\xaa\x01\xbb" 583 w2 <- witness "\x01\x01\xcc" 584 pure (TxSignatures cid t [w1, w2] empty) 585 586 , kat "tx_init_rbf" tx_init_rbf_lay 587 [ tlv_h 0 "0000000000030d40", tlv_h 2 "" ] 588 decode_tx_init_rbf encode_tx_init_rbf MsgTxInitRbf $ do 589 cid <- f_cid 590 pure (TxInitRbf cid 800000 4166 (Just 200000) True empty) 591 592 , kat "tx_ack_rbf" tx_ack_rbf_lay 593 [ tlv_h 0 "fffffffffffe7960", tlv_h 2 "" ] 594 decode_tx_ack_rbf encode_tx_ack_rbf MsgTxAckRbf $ do 595 cid <- f_cid 596 pure (TxAckRbf cid (Just (-100000)) True empty) 597 598 , kat "tx_abort" tx_abort_lay [] 599 decode_tx_abort encode_tx_abort MsgTxAbort $ do 600 cid <- f_cid 601 pure (TxAbort cid "failed check" empty) 602 603 , kat "stfu" stfu_lay [] 604 decode_stfu (Right . encode_stfu) MsgStfu $ do 605 cid <- f_cid 606 pure (Stfu cid True empty) 607 608 , kat "shutdown" shutdown_lay [] 609 decode_shutdown (Right . encode_shutdown) MsgShutdown $ do 610 cid <- f_cid 611 spk <- f_script p2wpkh_h 612 pure (Shutdown cid spk empty) 613 614 , kat "closing_complete" closing_complete_lay 615 [ tlv_h 1 sig1_h, tlv_h 3 sig2_h ] 616 decode_closing_complete encode_closing_complete 617 MsgClosingComplete $ do 618 cid <- f_cid 619 closer <- f_script p2wpkh_h 620 closee <- f_script p2tr_h 621 fee <- sat 500 622 s1 <- f_sig sig1_h 623 s2 <- f_sig sig2_h 624 pure (ClosingComplete cid closer closee fee 0 (Just s1) Nothing 625 (Just s2) empty) 626 627 , kat "closing_complete (closee output only)" closing_complete_lay 628 [ tlv_h 2 sig1_h ] 629 decode_closing_complete encode_closing_complete 630 MsgClosingComplete $ do 631 cid <- f_cid 632 closer <- f_script p2wpkh_h 633 closee <- f_script p2tr_h 634 fee <- sat 500 635 s1 <- f_sig sig1_h 636 pure (ClosingComplete cid closer closee fee 0 Nothing (Just s1) 637 Nothing empty) 638 639 , kat "closing_sig" closing_sig_lay [ tlv_h 3 sig3_h ] 640 decode_closing_sig encode_closing_sig MsgClosingSig $ do 641 cid <- f_cid 642 closer <- f_script p2wpkh_h 643 closee <- f_script p2tr_h 644 fee <- sat 500 645 s3 <- f_sig sig3_h 646 pure (ClosingSig cid closer closee fee 800000 Nothing Nothing 647 (Just s3) empty) 648 649 , kat "closing_signed" closing_signed_lay 650 [ tlv_h 1 "000000000000006400000000000003e8" ] 651 decode_closing_signed encode_closing_signed MsgClosingSigned $ do 652 cid <- f_cid 653 fee <- sat 500 654 s <- f_sig sig1_h 655 lo <- sat 100 656 hi <- sat 1000 657 pure (ClosingSigned cid fee s (Just (FeeRange lo hi)) empty) 658 659 , kat "update_add_htlc" update_add_htlc_lay [ tlv_h 0 p2_h ] 660 decode_update_add_htlc encode_update_add_htlc MsgUpdateAddHtlc $ do 661 cid <- f_cid 662 amt <- msat 100000 663 ph <- BOLT1.payment_hash =<< hx phash_h 664 onion <- onion_routing_packet =<< hx onion_h 665 pk <- f_point p2_h 666 pure (UpdateAddHtlc cid (HtlcId 0) amt ph 800080 onion (Just pk) 667 empty) 668 669 , kat "update_fulfill_htlc" update_fulfill_htlc_lay 670 [ tlv_h 1 attribution_h, tlv_h 3 "deadbeef" ] 671 decode_update_fulfill_htlc encode_update_fulfill_htlc 672 MsgUpdateFulfillHtlc $ do 673 cid <- f_cid 674 pre <- BOLT1.payment_preimage =<< hx preimage_h 675 att <- f_attribution 676 pure (UpdateFulfillHtlc cid (HtlcId 7) pre (Just att) 677 (Just "\xde\xad\xbe\xef") empty) 678 679 , kat "update_fail_htlc" update_fail_htlc_lay [ tlv_h 1 attribution_h ] 680 decode_update_fail_htlc encode_update_fail_htlc MsgUpdateFailHtlc $ do 681 cid <- f_cid 682 att <- f_attribution 683 pure (UpdateFailHtlc cid (HtlcId 7) "\x01\x02\x03\x04" (Just att) 684 empty) 685 686 , kat "update_fail_malformed_htlc" update_fail_malformed_htlc_lay [] 687 decode_update_fail_malformed_htlc 688 (Right . encode_update_fail_malformed_htlc) 689 MsgUpdateFailMalformedHtlc $ do 690 cid <- f_cid 691 oh <- onion_hash =<< hx onion_hash_h 692 pure (UpdateFailMalformedHtlc cid (HtlcId 3) oh 0xc005 empty) 693 694 , kat "commitment_signed" commitment_signed_lay [ tlv_h 1 txid_h ] 695 decode_commitment_signed encode_commitment_signed 696 MsgCommitmentSigned $ do 697 cid <- f_cid 698 sigs <- traverse f_sig [sig1_h, sig2_h, sig3_h] 699 t <- f_txid 700 case sigs of 701 (s : hs) -> pure (CommitmentSigned cid s hs (Just t) empty) 702 [] -> Nothing 703 704 , kat "revoke_and_ack" revoke_and_ack_lay [] 705 decode_revoke_and_ack (Right . encode_revoke_and_ack) 706 MsgRevokeAndAck $ do 707 cid <- f_cid 708 sec <- f_secret 709 pcp <- f_point p1_h 710 pure (RevokeAndAck cid sec pcp empty) 711 712 , kat "update_fee" update_fee_lay [] 713 decode_update_fee (Right . encode_update_fee) MsgUpdateFee $ do 714 cid <- f_cid 715 pure (UpdateFee cid 2500 empty) 716 717 , kat "channel_reestablish" channel_reestablish_lay 718 [ tlv_h 1 (txid_h ++ "01") ] 719 decode_channel_reestablish encode_channel_reestablish 720 MsgChannelReestablish $ do 721 cid <- f_cid 722 sec <- f_secret 723 pcp <- f_point p1_h 724 t <- f_txid 725 pure (ChannelReestablish cid 5 4 sec pcp (Just (NextFunding t 1)) 726 empty) 727 ] 728 729 -- TLV handling --------------------------------------------------------------- 730 731 -- decode a message (type, fixed fields and TLV records in hex), check 732 -- its unknown records, and check that it re-encodes exactly 733 reencodes :: Layout -> [String] -> [TlvRecord] -> Assertion 734 reencodes lay recs extra = do 735 wire <- unhex (lay_type lay ++ concat (lay_fixed lay ++ recs)) 736 case decode_message wire of 737 Left e -> assertFailure ("decode failed: " ++ show e) 738 Right m -> do 739 BOLT1.un_tlv_stream (message_tlvs m) @?= extra 740 encode_message m @?= Right wire 741 742 rejects :: Layout -> [String] -> DecodeError -> Assertion 743 rejects lay recs err = do 744 wire <- unhex (lay_type lay ++ concat (lay_fixed lay ++ recs)) 745 decode_message wire @?= Left err 746 747 -- the smallest even type a message doesn't know 748 first_unknown_even :: Layout -> Word64 749 first_unknown_even lay = case filter (`notElem` known) [0, 2 ..] of 750 (t:_) -> t 751 [] -> 0 752 where 753 known = [ t | (t, _, _) <- lay_known lay ] 754 755 tlv_cases :: Layout -> TestTree 756 tlv_cases lay = testGroup (lay_name lay) $ [ 757 testCase "unknown odd records are preserved" $ 758 reencodes lay (valid ++ [tlv_h 43 "2a", tlv_h 201 ""]) 759 [TlvRecord 43 "\x2a", TlvRecord 201 ""] 760 , testCase "unknown even records are rejected" $ do 761 let t = first_unknown_even lay 762 rejects lay [tlv_h t ""] (DecodeTlvError (TlvUnknownEvenType t)) 763 rejects lay (valid ++ [tlv_h 42 "00"]) 764 (DecodeTlvError (TlvUnknownEvenType 42)) 765 , testCase "unordered records are rejected" $ 766 rejects lay [tlv_h 45 "", tlv_h 43 ""] 767 (DecodeTlvError TlvNotStrictlyIncreasing) 768 , testCase "a huge record length is rejected" $ do 769 -- the length 2^64 - 1 must not wrap 770 rejects lay ["2bffffffffffffffffff2b"] (DecodeTlvError TlvTruncated) 771 ] ++ [ 772 testCase ("type " ++ show t ++ " is typed") $ reencodes lay [tlv_h t v] [] 773 | (t, v, _) <- lay_known lay 774 ] ++ [ 775 testCase ("malformed type " ++ show t ++ " is rejected") $ 776 mapM_ (\b -> rejects lay [tlv_h t b] (DecodeInvalidTlvValue t)) bad 777 | (t, _, bad) <- lay_known lay, not (null bad) 778 ] 779 where 780 valid = [ tlv_h t v | (t, v, _) <- lay_known lay ] 781 782 tlv_handling :: TestTree 783 tlv_handling = testGroup "TLV handling" $ map tlv_cases layouts ++ [ 784 testGroup "splicing records" [ 785 testCase "tx_add_input shared_input_txid is rejected" $ 786 rejects tx_add_input_lay [tlv_h 0 txid_h] 787 (DecodeTlvError (TlvUnknownEvenType 0)) 788 , testCase "tx_signatures shared_input_signature is rejected" $ 789 rejects tx_signatures_lay [tlv_h 0 sig1_h] 790 (DecodeTlvError (TlvUnknownEvenType 0)) 791 , testCase "channel_reestablish my_current_funding_locked is kept" $ do 792 v <- unhex (txid_h ++ "01") 793 reencodes channel_reestablish_lay 794 [tlv_h 1 (txid_h ++ "00"), tlv_h 5 (txid_h ++ "01")] 795 [TlvRecord 5 v] 796 ] 797 , testCase "a non-minimal type is rejected" $ 798 rejects update_fee_lay ["fd002b00"] 799 (DecodeTlvError TlvNonMinimalBigSize) 800 , testCase "a repeated type is rejected" $ 801 rejects update_fee_lay [tlv_h 43 "", tlv_h 43 ""] 802 (DecodeTlvError TlvNotStrictlyIncreasing) 803 , testCase "trailing bytes that aren't a TLV record are rejected" $ do 804 rejects update_fee_lay ["fd"] (DecodeTlvError TlvTruncated) 805 rejects update_fee_lay ["2b"] (DecodeTlvError TlvTruncated) 806 rejects update_fee_lay ["2b02aa"] (DecodeTlvError TlvTruncated) 807 , testCase "an empty upfront_shutdown_script is kept" $ do 808 wire <- unhex (concat (lay_fixed open_channel_lay ++ [tlv_h 0 ""])) 809 fmap open_channel_upfront_shutdown_script (decode_open_channel wire) 810 @?= Right (script_pubkey "") 811 , testCase "an oversized upfront_shutdown_script is rejected" $ do 812 fixed <- unhex (concat (lay_fixed open_channel_lay)) 813 let big = BS.replicate 65536 0x00 814 rec = "\x00\xfe\x00\x01\x00\x00" <> big 815 decode_open_channel (fixed <> rec) @?= Left (DecodeInvalidTlvValue 0) 816 , testCase "channel_type bytes are kept as received" $ do 817 wire <- unhex (concat (lay_fixed open_channel_lay 818 ++ [tlv_h 1 "00401000"])) 819 case decode_open_channel wire of 820 Left e -> assertFailure (show e) 821 Right m -> do 822 fmap BOLT9.render (open_channel_channel_type m) 823 @?= Just "\x00\x40\x10\x00" 824 (BOLT9.channel_type =<< open_channel_channel_type m) 825 @?= Just (BOLT9.ChannelType BOLT9.BasicAnchors False False) 826 encode_open_channel m @?= Right wire 827 ] 828 829 -- decoding failures ---------------------------------------------------------- 830 831 decoding_failures :: TestTree 832 decoding_failures = testGroup "decoding failures" [ 833 testGroup "truncated payloads" [ 834 testCase (lay_name lay) $ do 835 wire <- unhex (lay_type lay ++ concat (lay_fixed lay)) 836 decode_message (BS.take (BS.length wire - 1) wire) 837 @?= Left DecodeInsufficientBytes 838 decode_message (BS.take 2 wire) @?= Left DecodeInsufficientBytes 839 | lay <- layouts ] 840 , testCase "a message without a type" $ do 841 decode_message "" @?= Left DecodeInsufficientBytes 842 decode_message "\x00" @?= Left DecodeInsufficientBytes 843 , testCase "message types BOLT #2 doesn't define" $ do 844 decode_message "\x00\x50" @?= Left (DecodeUnknownEvenType 80) 845 decode_message "\x00\x51" @?= Left (DecodeUnknownOddType 81) 846 decode_message "\x00\x4d" @?= Left (DecodeUnknownOddType 77) 847 decode_message "\x00\x7f" @?= Left (DecodeUnknownOddType 127) 848 decode_message "\x00\x10\x00\x00\x00\x00" 849 @?= Left (DecodeUnknownEvenType 16) 850 , testCase "an invalid point" $ do 851 let bad = "04" ++ rep 32 "11" 852 wire <- unhex (concat (open_channel_fields 11 bad)) 853 decode_open_channel wire @?= Left DecodeInvalidPoint 854 wire' <- unhex (cid_h ++ secret_h ++ bad) 855 decode_revoke_and_ack wire' @?= Left DecodeInvalidPoint 856 , testCase "amounts above 21M BTC" $ do 857 -- funding_satoshis of 21M BTC, then one satoshi more 858 ok <- unhex (concat (open_channel_fields 2 "000775f05a074000")) 859 bad <- unhex (concat (open_channel_fields 2 "000775f05a074001")) 860 assertBool "21M BTC" (either (const False) (const True) 861 (decode_open_channel ok)) 862 decode_open_channel bad @?= Left DecodeInvalidAmount 863 htlc <- unhex (cid_h ++ "0000000000000000" ++ "1d24b2dfac520001" 864 ++ phash_h ++ "000c3550" ++ onion_h) 865 decode_update_add_htlc htlc @?= Left DecodeInvalidAmount 866 out <- unhex (cid_h ++ "0000000000000004" ++ "ffffffffffffffff" 867 ++ "0000") 868 decode_tx_add_output out @?= Left DecodeInvalidAmount 869 , testCase "stfu initiator byte" $ do 870 off <- unhex (cid_h ++ "00") 871 fmap stfu_initiator (decode_stfu off) @?= Right False 872 bad <- unhex (cid_h ++ "02") 873 decode_stfu bad @?= Left DecodeInvalidInitiator 874 , testCase "a list longer than its payload" $ do 875 wire <- unhex (cid_h ++ sig1_h ++ "0003" ++ sig2_h ++ sig3_h) 876 decode_commitment_signed wire @?= Left DecodeInsufficientBytes 877 wire' <- unhex (cid_h ++ txid_h ++ "0001" ++ "0004" ++ "0101") 878 decode_tx_signatures wire' @?= Left DecodeInsufficientBytes 879 , testCase "a short onion_routing_packet" $ do 880 wire <- unhex (concat (take 5 (lay_fixed update_add_htlc_lay)) 881 ++ drop 2 onion_h) 882 decode_update_add_htlc wire @?= Left DecodeInsufficientBytes 883 ] 884 where 885 -- open_channel's fixed fields with field i replaced 886 open_channel_fields :: Int -> String -> [String] 887 open_channel_fields i v = 888 let fs = lay_fixed open_channel_lay 889 in take i fs ++ [v] ++ drop (i + 1) fs 890 891 -- encoding failures ---------------------------------------------------------- 892 893 encoding_failures :: TestTree 894 encoding_failures = testGroup "encoding failures" [ 895 testCase "u16 length prefixes" $ do 896 cid <- just "cid" f_cid 897 let big = BS.replicate 65536 0x00 898 max_ok = BS.replicate 65535 0x00 899 encode_tx_add_input (TxAddInput cid (SerialId 0) big 0 0 empty) 900 @?= Left EncodeLengthOverflow 901 assertBool "65535-byte prevtx" $ either (const False) (const True) 902 (encode_tx_add_input (TxAddInput cid (SerialId 0) max_ok 0 0 empty)) 903 encode_tx_abort (TxAbort cid big empty) @?= Left EncodeLengthOverflow 904 encode_update_fail_htlc 905 (UpdateFailHtlc cid (HtlcId 0) big Nothing empty) 906 @?= Left EncodeLengthOverflow 907 , testCase "u16 counts" $ do 908 cid <- just "cid" f_cid 909 s <- just "sig" (f_sig sig1_h) 910 t <- just "txid" f_txid 911 w <- just "witness" (witness "\x00") 912 encode_commitment_signed 913 (CommitmentSigned cid s (replicate 65536 s) Nothing empty) 914 @?= Left EncodeLengthOverflow 915 encode_tx_signatures (TxSignatures cid t (replicate 65536 w) empty) 916 @?= Left EncodeLengthOverflow 917 , testCase "_tlvs fields can't hold known types" $ do 918 cid <- just "cid" f_cid 919 pcp <- just "point" (f_point p1_h) 920 s <- just "sig" (f_sig sig1_h) 921 spk <- just "script" (f_script p2wpkh_h) 922 fee <- just "fee" (sat 500) 923 one <- just "tlvs" (BOLT1.tlv_stream [TlvRecord 1 "\x00"]) 924 two <- just "tlvs" (BOLT1.tlv_stream [TlvRecord 2 ""]) 925 odd' <- just "tlvs" (BOLT1.tlv_stream [TlvRecord 43 ""]) 926 encode_channel_ready (ChannelReady cid pcp Nothing one) 927 @?= Left EncodeInvalidTlvs 928 encode_closing_complete 929 (ClosingComplete cid spk spk fee 0 (Just s) Nothing Nothing two) 930 @?= Left EncodeInvalidTlvs 931 encode_tx_ack_rbf (TxAckRbf cid Nothing False two) 932 @?= Left EncodeInvalidTlvs 933 assertBool "unknown odd records encode" $ 934 either (const False) (const True) 935 (encode_channel_ready (ChannelReady cid pcp Nothing odd')) 936 , testCase "the message size limit" $ do 937 cid <- just "cid" f_cid 938 -- a 65533-byte payload fits; one more byte doesn't 939 let at n = TxAbort cid (BS.replicate n 0x00) empty 940 fmap BS.length (encode_message (MsgTxAbort (at 65499))) 941 @?= Right 65535 942 encode_message (MsgTxAbort (at 65500)) @?= Left EncodeMessageTooLarge 943 fmap BS.length (encode_tx_abort (at 65500)) @?= Right 65534 944 ] 945 946 -- field types ---------------------------------------------------------------- 947 948 field_types :: TestTree 949 field_types = testGroup "field types" [ 950 testCase "script_pubkey" $ do 951 fmap un_script_pubkey (script_pubkey (BS.replicate 65535 0x51)) 952 @?= Just (BS.replicate 65535 0x51) 953 script_pubkey (BS.replicate 65536 0x51) @?= Nothing 954 , testCase "witness" $ do 955 fmap un_witness (witness "") @?= Just "" 956 witness (BS.replicate 65536 0x00) @?= Nothing 957 , testCase "onion_routing_packet" $ do 958 let bs = BS.replicate 1366 0x00 959 fmap un_onion_routing_packet (onion_routing_packet bs) @?= Just bs 960 onion_routing_packet (BS.take 1365 bs) @?= Nothing 961 onion_routing_packet (BS.cons 0x00 bs) @?= Nothing 962 , testCase "onion_hash" $ do 963 fmap un_onion_hash (onion_hash (BS.replicate 32 0x01)) 964 @?= Just (BS.replicate 32 0x01) 965 onion_hash (BS.replicate 33 0x01) @?= Nothing 966 , testCase "attribution_data" $ do 967 let bs = BS.replicate 920 0x00 968 fmap un_attribution_data (attribution_data bs) @?= Just bs 969 attribution_data (BS.take 919 bs) @?= Nothing 970 , testCase "message types" $ do 971 cid <- just "cid" f_cid 972 message_type (MsgStfu (Stfu cid False empty)) @?= 2 973 message_type (MsgUpdateFee (UpdateFee cid 0 empty)) @?= 134 974 ] 975 976 -- generators ----------------------------------------------------------------- 977 978 gen_bytes :: Int -> Gen BS.ByteString 979 gen_bytes n = BS.pack <$> vectorOf n arbitrary 980 981 gen_var_bytes :: Int -> Gen BS.ByteString 982 gen_var_bytes hi = choose (0, hi) >>= gen_bytes 983 984 gen_cid :: Gen BOLT1.ChannelId 985 gen_cid = gen_bytes 32 `suchThatMap` BOLT1.channel_id 986 987 gen_chain :: Gen BOLT1.ChainHash 988 gen_chain = gen_bytes 32 `suchThatMap` BOLT1.chain_hash 989 990 gen_point :: Gen BOLT1.Point 991 gen_point = do 992 p <- elements [0x02, 0x03] 993 (BS.cons p <$> gen_bytes 32) `suchThatMap` BOLT1.point 994 995 gen_sig :: Gen BOLT1.Signature 996 gen_sig = gen_bytes 64 `suchThatMap` BOLT1.signature 997 998 gen_txid :: Gen Tx.TxId 999 gen_txid = gen_bytes 32 `suchThatMap` Tx.mk_txid 1000 1001 gen_secret :: Gen BOLT1.PerCommitmentSecret 1002 gen_secret = gen_bytes 32 `suchThatMap` BOLT1.per_commitment_secret 1003 1004 gen_sat :: Gen BOLT1.Satoshi 1005 gen_sat = choose (0, 2100000000000000) `suchThatMap` BOLT1.satoshi 1006 1007 gen_msat :: Gen BOLT1.MilliSatoshi 1008 gen_msat = choose (0, 2100000000000000000) `suchThatMap` BOLT1.milli_satoshi 1009 1010 gen_script :: Gen ScriptPubKey 1011 gen_script = gen_var_bytes 40 `suchThatMap` script_pubkey 1012 1013 gen_fv :: Gen BOLT9.FeatureVector 1014 gen_fv = BOLT9.parse <$> gen_var_bytes 8 1015 1016 gen_maybe :: Gen a -> Gen (Maybe a) 1017 gen_maybe g = oneof [pure Nothing, Just <$> g] 1018 1019 -- unknown odd records, avoiding a message's known types 1020 gen_tlvs :: [Word64] -> Gen BOLT1.TlvStream 1021 gen_tlvs known = do 1022 ts <- sublistOf (filter (`notElem` known) candidates) 1023 rs <- traverse (\t -> TlvRecord t <$> gen_var_bytes 12) ts 1024 pure (maybe empty id (BOLT1.tlv_stream rs)) 1025 where 1026 candidates = [1, 3, 5, 7, 43, 201, 253, 65537, 4294967297] 1027 1028 gen_open_channel :: Gen OpenChannel 1029 gen_open_channel = OpenChannel <$> gen_chain <*> gen_cid <*> gen_sat 1030 <*> gen_msat <*> gen_sat <*> arbitrary <*> gen_sat <*> gen_msat 1031 <*> arbitrary <*> arbitrary <*> arbitrary <*> gen_point <*> gen_point 1032 <*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> arbitrary 1033 <*> gen_maybe gen_script <*> gen_maybe gen_fv <*> gen_tlvs [0, 1] 1034 1035 gen_accept_channel :: Gen AcceptChannel 1036 gen_accept_channel = AcceptChannel <$> gen_cid <*> gen_sat <*> arbitrary 1037 <*> gen_sat <*> gen_msat <*> arbitrary <*> arbitrary <*> arbitrary 1038 <*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> gen_point 1039 <*> gen_point <*> gen_maybe gen_script <*> gen_maybe gen_fv 1040 <*> gen_tlvs [0, 1] 1041 1042 gen_funding_created :: Gen FundingCreated 1043 gen_funding_created = FundingCreated <$> gen_cid <*> gen_txid <*> arbitrary 1044 <*> gen_sig <*> gen_tlvs [] 1045 1046 gen_funding_signed :: Gen FundingSigned 1047 gen_funding_signed = FundingSigned <$> gen_cid <*> gen_sig <*> gen_tlvs [] 1048 1049 gen_channel_ready :: Gen ChannelReady 1050 gen_channel_ready = ChannelReady <$> gen_cid <*> gen_point 1051 <*> gen_maybe (BOLT1.ShortChannelId <$> arbitrary) <*> gen_tlvs [1] 1052 1053 gen_open_channel2 :: Gen OpenChannel2 1054 gen_open_channel2 = OpenChannel2 <$> gen_chain <*> gen_cid <*> arbitrary 1055 <*> arbitrary <*> gen_sat <*> gen_sat <*> arbitrary <*> gen_msat 1056 <*> arbitrary <*> arbitrary <*> arbitrary <*> gen_point <*> gen_point 1057 <*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> gen_point 1058 <*> arbitrary <*> gen_maybe gen_script <*> gen_maybe gen_fv 1059 <*> arbitrary <*> gen_tlvs [0, 1, 2] 1060 1061 gen_accept_channel2 :: Gen AcceptChannel2 1062 gen_accept_channel2 = AcceptChannel2 <$> gen_cid <*> gen_sat <*> gen_sat 1063 <*> arbitrary <*> gen_msat <*> arbitrary <*> arbitrary <*> arbitrary 1064 <*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> gen_point 1065 <*> gen_point <*> gen_point <*> gen_maybe gen_script 1066 <*> gen_maybe gen_fv <*> arbitrary <*> gen_tlvs [0, 1, 2] 1067 1068 gen_tx_add_input :: Gen TxAddInput 1069 gen_tx_add_input = TxAddInput <$> gen_cid <*> (SerialId <$> arbitrary) 1070 <*> gen_var_bytes 64 <*> arbitrary <*> arbitrary <*> gen_tlvs [] 1071 1072 gen_tx_add_output :: Gen TxAddOutput 1073 gen_tx_add_output = TxAddOutput <$> gen_cid <*> (SerialId <$> arbitrary) 1074 <*> gen_sat <*> gen_script <*> gen_tlvs [] 1075 1076 gen_tx_remove_input :: Gen TxRemoveInput 1077 gen_tx_remove_input = TxRemoveInput <$> gen_cid <*> (SerialId <$> arbitrary) 1078 <*> gen_tlvs [] 1079 1080 gen_tx_remove_output :: Gen TxRemoveOutput 1081 gen_tx_remove_output = TxRemoveOutput <$> gen_cid 1082 <*> (SerialId <$> arbitrary) <*> gen_tlvs [] 1083 1084 gen_tx_complete :: Gen TxComplete 1085 gen_tx_complete = TxComplete <$> gen_cid <*> gen_tlvs [] 1086 1087 gen_tx_signatures :: Gen TxSignatures 1088 gen_tx_signatures = TxSignatures <$> gen_cid <*> gen_txid 1089 <*> listOf (gen_var_bytes 32 `suchThatMap` witness) <*> gen_tlvs [] 1090 1091 gen_tx_init_rbf :: Gen TxInitRbf 1092 gen_tx_init_rbf = TxInitRbf <$> gen_cid <*> arbitrary <*> arbitrary 1093 <*> gen_maybe (arbitrary :: Gen Int64) <*> arbitrary <*> gen_tlvs [0, 2] 1094 1095 gen_tx_ack_rbf :: Gen TxAckRbf 1096 gen_tx_ack_rbf = TxAckRbf <$> gen_cid <*> gen_maybe arbitrary <*> arbitrary 1097 <*> gen_tlvs [0, 2] 1098 1099 gen_tx_abort :: Gen TxAbort 1100 gen_tx_abort = TxAbort <$> gen_cid <*> gen_var_bytes 64 <*> gen_tlvs [] 1101 1102 gen_stfu :: Gen Stfu 1103 gen_stfu = Stfu <$> gen_cid <*> arbitrary <*> gen_tlvs [] 1104 1105 gen_shutdown :: Gen Shutdown 1106 gen_shutdown = Shutdown <$> gen_cid <*> gen_script <*> gen_tlvs [] 1107 1108 gen_closing_complete :: Gen ClosingComplete 1109 gen_closing_complete = ClosingComplete <$> gen_cid <*> gen_script 1110 <*> gen_script <*> gen_sat <*> arbitrary <*> gen_maybe gen_sig 1111 <*> gen_maybe gen_sig <*> gen_maybe gen_sig <*> gen_tlvs [1, 2, 3] 1112 1113 gen_closing_sig :: Gen ClosingSig 1114 gen_closing_sig = ClosingSig <$> gen_cid <*> gen_script <*> gen_script 1115 <*> gen_sat <*> arbitrary <*> gen_maybe gen_sig <*> gen_maybe gen_sig 1116 <*> gen_maybe gen_sig <*> gen_tlvs [1, 2, 3] 1117 1118 gen_closing_signed :: Gen ClosingSigned 1119 gen_closing_signed = ClosingSigned <$> gen_cid <*> gen_sat <*> gen_sig 1120 <*> gen_maybe (FeeRange <$> gen_sat <*> gen_sat) <*> gen_tlvs [1] 1121 1122 gen_update_add_htlc :: Gen UpdateAddHtlc 1123 gen_update_add_htlc = UpdateAddHtlc <$> gen_cid <*> (HtlcId <$> arbitrary) 1124 <*> gen_msat 1125 <*> (gen_bytes 32 `suchThatMap` BOLT1.payment_hash) 1126 <*> arbitrary 1127 <*> (gen_bytes 1366 `suchThatMap` onion_routing_packet) 1128 <*> gen_maybe gen_point <*> gen_tlvs [0] 1129 1130 gen_update_fulfill_htlc :: Gen UpdateFulfillHtlc 1131 gen_update_fulfill_htlc = UpdateFulfillHtlc <$> gen_cid 1132 <*> (HtlcId <$> arbitrary) 1133 <*> (gen_bytes 32 `suchThatMap` BOLT1.payment_preimage) 1134 <*> gen_maybe (gen_bytes 920 `suchThatMap` attribution_data) 1135 <*> gen_maybe (gen_var_bytes 64) <*> gen_tlvs [1, 3] 1136 1137 gen_update_fail_htlc :: Gen UpdateFailHtlc 1138 gen_update_fail_htlc = UpdateFailHtlc <$> gen_cid <*> (HtlcId <$> arbitrary) 1139 <*> gen_var_bytes 300 1140 <*> gen_maybe (gen_bytes 920 `suchThatMap` attribution_data) 1141 <*> gen_tlvs [1] 1142 1143 gen_update_fail_malformed_htlc :: Gen UpdateFailMalformedHtlc 1144 gen_update_fail_malformed_htlc = UpdateFailMalformedHtlc <$> gen_cid 1145 <*> (HtlcId <$> arbitrary) 1146 <*> (gen_bytes 32 `suchThatMap` onion_hash) 1147 <*> arbitrary <*> gen_tlvs [] 1148 1149 gen_commitment_signed :: Gen CommitmentSigned 1150 gen_commitment_signed = CommitmentSigned <$> gen_cid <*> gen_sig 1151 <*> listOf gen_sig <*> gen_maybe gen_txid <*> gen_tlvs [1] 1152 1153 gen_revoke_and_ack :: Gen RevokeAndAck 1154 gen_revoke_and_ack = RevokeAndAck <$> gen_cid <*> gen_secret <*> gen_point 1155 <*> gen_tlvs [] 1156 1157 gen_update_fee :: Gen UpdateFee 1158 gen_update_fee = UpdateFee <$> gen_cid <*> arbitrary <*> gen_tlvs [] 1159 1160 gen_channel_reestablish :: Gen ChannelReestablish 1161 gen_channel_reestablish = ChannelReestablish <$> gen_cid <*> arbitrary 1162 <*> arbitrary <*> gen_secret <*> gen_point 1163 <*> gen_maybe (NextFunding <$> gen_txid <*> arbitrary) <*> gen_tlvs [1] 1164 1165 gen_message :: Gen Message 1166 gen_message = oneof [ 1167 MsgOpenChannel <$> gen_open_channel 1168 , MsgAcceptChannel <$> gen_accept_channel 1169 , MsgFundingCreated <$> gen_funding_created 1170 , MsgFundingSigned <$> gen_funding_signed 1171 , MsgChannelReady <$> gen_channel_ready 1172 , MsgOpenChannel2 <$> gen_open_channel2 1173 , MsgAcceptChannel2 <$> gen_accept_channel2 1174 , MsgTxAddInput <$> gen_tx_add_input 1175 , MsgTxAddOutput <$> gen_tx_add_output 1176 , MsgTxRemoveInput <$> gen_tx_remove_input 1177 , MsgTxRemoveOutput <$> gen_tx_remove_output 1178 , MsgTxComplete <$> gen_tx_complete 1179 , MsgTxSignatures <$> gen_tx_signatures 1180 , MsgTxInitRbf <$> gen_tx_init_rbf 1181 , MsgTxAckRbf <$> gen_tx_ack_rbf 1182 , MsgTxAbort <$> gen_tx_abort 1183 , MsgStfu <$> gen_stfu 1184 , MsgShutdown <$> gen_shutdown 1185 , MsgClosingComplete <$> gen_closing_complete 1186 , MsgClosingSig <$> gen_closing_sig 1187 , MsgClosingSigned <$> gen_closing_signed 1188 , MsgUpdateAddHtlc <$> gen_update_add_htlc 1189 , MsgUpdateFulfillHtlc <$> gen_update_fulfill_htlc 1190 , MsgUpdateFailHtlc <$> gen_update_fail_htlc 1191 , MsgUpdateFailMalformedHtlc <$> gen_update_fail_malformed_htlc 1192 , MsgCommitmentSigned <$> gen_commitment_signed 1193 , MsgRevokeAndAck <$> gen_revoke_and_ack 1194 , MsgUpdateFee <$> gen_update_fee 1195 , MsgChannelReestablish <$> gen_channel_reestablish 1196 ] 1197 1198 -- properties ----------------------------------------------------------------- 1199 1200 -- decoding an encoded payload gives back the value 1201 roundtrip 1202 :: (Eq a, Show a) 1203 => String 1204 -> Gen a 1205 -> (a -> Either EncodeError BS.ByteString) 1206 -> (BS.ByteString -> Either DecodeError a) 1207 -> TestTree 1208 roundtrip name gen enc dec = testProperty name $ forAll gen $ \m -> 1209 case enc m of 1210 Left e -> counterexample ("encode failed: " ++ show e) False 1211 Right w -> dec w === Right m 1212 1213 -- byte strings derived from a valid encoding 1214 data Edit = Replace !Int !Word8 | Truncate !Int | Append !BS.ByteString 1215 deriving Show 1216 1217 gen_edit :: Gen Edit 1218 gen_edit = oneof [ 1219 Replace <$> arbitrary <*> arbitrary 1220 , Truncate <$> arbitrary 1221 , Append <$> gen_var_bytes 8 1222 ] 1223 1224 apply_edit :: Edit -> BS.ByteString -> BS.ByteString 1225 apply_edit e bs = case e of 1226 Replace i b 1227 | BS.null bs -> bs 1228 | otherwise -> 1229 let j = i `mod` BS.length bs 1230 in BS.take j bs <> BS.singleton b <> BS.drop (j + 1) bs 1231 Truncate i 1232 | BS.null bs -> bs 1233 | otherwise -> BS.take (i `mod` BS.length bs) bs 1234 Append x -> bs <> x 1235 1236 properties :: TestTree 1237 properties = testGroup "properties" [ 1238 testGroup "payloads round-trip" [ 1239 roundtrip "open_channel" gen_open_channel 1240 encode_open_channel decode_open_channel 1241 , roundtrip "accept_channel" gen_accept_channel 1242 encode_accept_channel decode_accept_channel 1243 , roundtrip "funding_created" gen_funding_created 1244 (Right . encode_funding_created) decode_funding_created 1245 , roundtrip "funding_signed" gen_funding_signed 1246 (Right . encode_funding_signed) decode_funding_signed 1247 , roundtrip "channel_ready" gen_channel_ready 1248 encode_channel_ready decode_channel_ready 1249 , roundtrip "open_channel2" gen_open_channel2 1250 encode_open_channel2 decode_open_channel2 1251 , roundtrip "accept_channel2" gen_accept_channel2 1252 encode_accept_channel2 decode_accept_channel2 1253 , roundtrip "tx_add_input" gen_tx_add_input 1254 encode_tx_add_input decode_tx_add_input 1255 , roundtrip "tx_add_output" gen_tx_add_output 1256 (Right . encode_tx_add_output) decode_tx_add_output 1257 , roundtrip "tx_remove_input" gen_tx_remove_input 1258 (Right . encode_tx_remove_input) decode_tx_remove_input 1259 , roundtrip "tx_remove_output" gen_tx_remove_output 1260 (Right . encode_tx_remove_output) decode_tx_remove_output 1261 , roundtrip "tx_complete" gen_tx_complete 1262 (Right . encode_tx_complete) decode_tx_complete 1263 , roundtrip "tx_signatures" gen_tx_signatures 1264 encode_tx_signatures decode_tx_signatures 1265 , roundtrip "tx_init_rbf" gen_tx_init_rbf 1266 encode_tx_init_rbf decode_tx_init_rbf 1267 , roundtrip "tx_ack_rbf" gen_tx_ack_rbf 1268 encode_tx_ack_rbf decode_tx_ack_rbf 1269 , roundtrip "tx_abort" gen_tx_abort encode_tx_abort decode_tx_abort 1270 , roundtrip "stfu" gen_stfu (Right . encode_stfu) decode_stfu 1271 , roundtrip "shutdown" gen_shutdown 1272 (Right . encode_shutdown) decode_shutdown 1273 , roundtrip "closing_complete" gen_closing_complete 1274 encode_closing_complete decode_closing_complete 1275 , roundtrip "closing_sig" gen_closing_sig 1276 encode_closing_sig decode_closing_sig 1277 , roundtrip "closing_signed" gen_closing_signed 1278 encode_closing_signed decode_closing_signed 1279 , roundtrip "update_add_htlc" gen_update_add_htlc 1280 encode_update_add_htlc decode_update_add_htlc 1281 , roundtrip "update_fulfill_htlc" gen_update_fulfill_htlc 1282 encode_update_fulfill_htlc decode_update_fulfill_htlc 1283 , roundtrip "update_fail_htlc" gen_update_fail_htlc 1284 encode_update_fail_htlc decode_update_fail_htlc 1285 , roundtrip "update_fail_malformed_htlc" gen_update_fail_malformed_htlc 1286 (Right . encode_update_fail_malformed_htlc) 1287 decode_update_fail_malformed_htlc 1288 , roundtrip "commitment_signed" gen_commitment_signed 1289 encode_commitment_signed decode_commitment_signed 1290 , roundtrip "revoke_and_ack" gen_revoke_and_ack 1291 (Right . encode_revoke_and_ack) decode_revoke_and_ack 1292 , roundtrip "update_fee" gen_update_fee 1293 (Right . encode_update_fee) decode_update_fee 1294 , roundtrip "channel_reestablish" gen_channel_reestablish 1295 encode_channel_reestablish decode_channel_reestablish 1296 ] 1297 , roundtrip "messages round-trip" gen_message encode_message decode_message 1298 , testProperty "decoded messages re-encode exactly" $ 1299 withMaxSuccess 2000 $ 1300 forAll gen_message $ \m -> forAll gen_edit $ \e -> 1301 case encode_message m of 1302 Left err -> counterexample ("encode failed: " ++ show err) False 1303 Right w -> 1304 let w' = apply_edit e w 1305 in case decode_message w' of 1306 Left _ -> property True 1307 Right m' -> encode_message m' === Right w' 1308 ]