{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified Bitcoin.Prim.Tx as Tx
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 Data.Word (Word8, Word64)
import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT1 (TlvRecord(..), TlvError(..))
import Lightning.Protocol.BOLT2
import qualified Lightning.Protocol.BOLT9 as BOLT9
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck hiding (witness)
main :: IO ()
main = defaultMain $ testGroup "ppad-bolt2" [
known_answers
, tlv_handling
, decoding_failures
, encoding_failures
, field_types
, properties
]
-- helpers --------------------------------------------------------------------
rep :: Int -> String -> String
rep n = concat . replicate n
hx :: String -> Maybe BS.ByteString
hx = B16.decode . B8.pack
-- decode a hex literal, failing the test if it isn't valid hex
unhex :: String -> IO BS.ByteString
unhex s = maybe (assertFailure ("invalid hex literal: " ++ s)) pure (hx s)
-- unwrap a fixture, failing the test if it couldn't be constructed
just :: String -> Maybe a -> IO a
just what = maybe (assertFailure ("invalid fixture: " ++ what)) pure
empty :: BOLT1.TlvStream
empty = BOLT1.empty_tlv_stream
-- the unknown TLV records of a message
message_tlvs :: Message -> BOLT1.TlvStream
message_tlvs m = case m of
MsgOpenChannel a -> open_channel_tlvs a
MsgAcceptChannel a -> accept_channel_tlvs a
MsgFundingCreated a -> funding_created_tlvs a
MsgFundingSigned a -> funding_signed_tlvs a
MsgChannelReady a -> channel_ready_tlvs a
MsgOpenChannel2 a -> open_channel2_tlvs a
MsgAcceptChannel2 a -> accept_channel2_tlvs a
MsgTxAddInput a -> tx_add_input_tlvs a
MsgTxAddOutput a -> tx_add_output_tlvs a
MsgTxRemoveInput a -> tx_remove_input_tlvs a
MsgTxRemoveOutput a -> tx_remove_output_tlvs a
MsgTxComplete a -> tx_complete_tlvs a
MsgTxSignatures a -> tx_signatures_tlvs a
MsgTxInitRbf a -> tx_init_rbf_tlvs a
MsgTxAckRbf a -> tx_ack_rbf_tlvs a
MsgTxAbort a -> tx_abort_tlvs a
MsgStfu a -> stfu_tlvs a
MsgShutdown a -> shutdown_tlvs a
MsgClosingComplete a -> closing_complete_tlvs a
MsgClosingSig a -> closing_sig_tlvs a
MsgClosingSigned a -> closing_signed_tlvs a
MsgUpdateAddHtlc a -> update_add_htlc_tlvs a
MsgUpdateFulfillHtlc a -> update_fulfill_htlc_tlvs a
MsgUpdateFailHtlc a -> update_fail_htlc_tlvs a
MsgUpdateFailMalformedHtlc a -> update_fail_malformed_htlc_tlvs a
MsgCommitmentSigned a -> commitment_signed_tlvs a
MsgRevokeAndAck a -> revoke_and_ack_tlvs a
MsgUpdateFee a -> update_fee_tlvs a
MsgChannelReestablish a -> channel_reestablish_tlvs a
-- field values ---------------------------------------------------------------
-- the bitcoin genesis block hash, in internal byte order
chain_h :: String
chain_h = "6fe28c0ab6f1b372c1a6a246ae63f74f931e8365e15a089c68d6190000000000"
cid_h, tcid_h, txid_h, secret_h, preimage_h, phash_h :: String
cid_h = rep 32 "ab"
tcid_h = rep 32 "cd"
txid_h = rep 32 "7e"
secret_h = rep 32 "5e"
preimage_h = rep 32 "50"
phash_h = rep 32 "9a"
p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h :: String
p1_h = "02" ++ rep 32 "11"
p2_h = "03" ++ rep 32 "22"
p3_h = "02" ++ rep 32 "33"
p4_h = "03" ++ rep 32 "44"
p5_h = "02" ++ rep 32 "55"
p6_h = "03" ++ rep 32 "66"
p7_h = "02" ++ rep 32 "77"
sig1_h, sig2_h, sig3_h :: String
sig1_h = rep 64 "a1"
sig2_h = rep 64 "b2"
sig3_h = rep 64 "c3"
-- version, ephemeral key, hop payloads, hmac
onion_h :: String
onion_h = "00" ++ p3_h ++ rep 1300 "44" ++ rep 32 "55"
-- twenty hold times of 100, then 210 truncated hmacs
attribution_h :: String
attribution_h = rep 20 "00000064" ++ rep 210 "0badf00d"
p2wpkh_h, p2wsh_h, p2tr_h :: String
p2wpkh_h = "0014" ++ rep 20 "88"
p2wsh_h = "0020" ++ rep 32 "99"
p2tr_h = "5120" ++ rep 32 "ee"
-- the sha256 of the empty string
onion_hash_h :: String
onion_hash_h =
"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
f_chain :: Maybe BOLT1.ChainHash
f_chain = BOLT1.chain_hash =<< hx chain_h
f_cid, f_tcid :: Maybe BOLT1.ChannelId
f_cid = BOLT1.channel_id =<< hx cid_h
f_tcid = BOLT1.channel_id =<< hx tcid_h
f_point :: String -> Maybe BOLT1.Point
f_point h = BOLT1.point =<< hx h
f_sig :: String -> Maybe BOLT1.Signature
f_sig h = BOLT1.signature =<< hx h
f_txid :: Maybe Tx.TxId
f_txid = Tx.mk_txid =<< hx txid_h
f_secret :: Maybe BOLT1.PerCommitmentSecret
f_secret = BOLT1.per_commitment_secret =<< hx secret_h
f_script :: String -> Maybe ScriptPubKey
f_script h = script_pubkey =<< hx h
f_attribution :: Maybe AttributionData
f_attribution = attribution_data =<< hx attribution_h
anchors :: BOLT9.FeatureVector
anchors = BOLT9.channel_type_features
(BOLT9.ChannelType BOLT9.BasicAnchors False False)
sat :: Word64 -> Maybe BOLT1.Satoshi
sat = BOLT1.satoshi
msat :: Word64 -> Maybe BOLT1.MilliSatoshi
msat = BOLT1.milli_satoshi
-- message layouts ------------------------------------------------------------
-- A message's layout: its type and fixed fields (hex, assembled by hand
-- from the spec) and its known TLV types, each with a valid value and
-- some malformed ones.
data Layout = Layout
{ lay_name :: String
, lay_type :: String
, lay_fixed :: [String]
, lay_known :: [(Word64, String, [String])]
}
open_channel_lay :: Layout
open_channel_lay = Layout "open_channel" "0020" [
chain_h
, tcid_h
, "00000000000f4240" -- funding_satoshis: 1000000
, "00000000000003e8" -- push_msat: 1000
, "0000000000000222" -- dust_limit_satoshis: 546
, "ffffffffffffffff" -- max_htlc_value_in_flight_msat: u64 max
, "0000000000002710" -- channel_reserve_satoshis: 10000
, "0000000000000001" -- htlc_minimum_msat: 1
, "000000fd" -- feerate_per_kw: 253
, "0090" -- to_self_delay: 144
, "01e3" -- max_accepted_htlcs: 483
, p1_h, p2_h, p3_h, p4_h, p5_h, p6_h
, "01" -- channel_flags
] [ (0, p2wpkh_h, []), (1, "401000", []) ]
accept_channel_lay :: Layout
accept_channel_lay = Layout "accept_channel" "0021" [
tcid_h
, "0000000000000222" -- dust_limit_satoshis: 546
, "0000000005f5e100" -- max_htlc_value_in_flight_msat: 100000000
, "0000000000002710" -- channel_reserve_satoshis: 10000
, "00000000000003e8" -- htlc_minimum_msat: 1000
, "00000003" -- minimum_depth: 3
, "0090" -- to_self_delay: 144
, "01e3" -- max_accepted_htlcs: 483
, p1_h, p2_h, p3_h, p4_h, p5_h, p6_h
] [ (0, "", []), (1, "401000", []) ]
funding_created_lay :: Layout
funding_created_lay = Layout "funding_created" "0022" [
tcid_h
, txid_h
, "0001" -- funding_output_index: 1
, sig1_h
] []
funding_signed_lay :: Layout
funding_signed_lay = Layout "funding_signed" "0023" [ cid_h, sig1_h ] []
channel_ready_lay :: Layout
channel_ready_lay = Layout "channel_ready" "0024" [ cid_h, p1_h ]
[ (1, "083a8400034d0001", ["083a8400034d00", "083a8400034d000100"]) ]
open_channel2_lay :: Layout
open_channel2_lay = Layout "open_channel2" "0040" [
chain_h
, tcid_h
, "00000fa0" -- funding_feerate_perkw: 4000
, "000000fd" -- commitment_feerate_perkw: 253
, "0000000000030d40" -- funding_satoshis: 200000
, "0000000000000162" -- dust_limit_satoshis: 354
, "ffffffffffffffff" -- max_htlc_value_in_flight_msat: u64 max
, "0000000000000001" -- htlc_minimum_msat: 1
, "0090" -- to_self_delay: 144
, "01e3" -- max_accepted_htlcs: 483
, "000c3500" -- locktime: 800000
, p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h
, "00" -- channel_flags
] [ (0, p2wpkh_h, []), (1, "401000", []), (2, "", ["00", "01"]) ]
accept_channel2_lay :: Layout
accept_channel2_lay = Layout "accept_channel2" "0041" [
tcid_h
, "0000000000000000" -- funding_satoshis: 0
, "0000000000000162" -- dust_limit_satoshis: 354
, "0000000005f5e100" -- max_htlc_value_in_flight_msat: 100000000
, "00000000000003e8" -- htlc_minimum_msat: 1000
, "00000006" -- minimum_depth: 6
, "0090" -- to_self_delay: 144
, "001e" -- max_accepted_htlcs: 30
, p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h
] [ (0, p2wsh_h, []), (1, "401000", []), (2, "", ["00"]) ]
tx_add_input_lay :: Layout
tx_add_input_lay = Layout "tx_add_input" "0042" [
cid_h
, "0000000000000002" -- serial_id: 2
, "0005", "0102030405" -- prevtx
, "00000001" -- prevtx_vout: 1
, "fffffffd" -- sequence
] []
tx_add_output_lay :: Layout
tx_add_output_lay = Layout "tx_add_output" "0043" [
cid_h
, "0000000000000004" -- serial_id: 4
, "0000000000030d40" -- sats: 200000
, "0022", p2wsh_h -- script
] []
tx_remove_input_lay :: Layout
tx_remove_input_lay = Layout "tx_remove_input" "0044"
[ cid_h, "0000000000000002" ] []
tx_remove_output_lay :: Layout
tx_remove_output_lay = Layout "tx_remove_output" "0045"
[ cid_h, "0000000000000005" ] []
tx_complete_lay :: Layout
tx_complete_lay = Layout "tx_complete" "0046" [ cid_h ] []
tx_signatures_lay :: Layout
tx_signatures_lay = Layout "tx_signatures" "0047" [
cid_h
, txid_h
, "0002" -- num_witnesses
, "0006", "0202aaaa01bb" -- two stack items
, "0003", "0101cc" -- one stack item
] []
tx_init_rbf_lay :: Layout
tx_init_rbf_lay = Layout "tx_init_rbf" "0048" [
cid_h
, "000c3500" -- locktime: 800000
, "00001046" -- feerate: 4166
] [ (0, "0000000000030d40", ["00030d40", "000000000000030d40"])
, (2, "", ["00"]) ]
tx_ack_rbf_lay :: Layout
tx_ack_rbf_lay = Layout "tx_ack_rbf" "0049" [ cid_h ]
[ (0, "fffffffffffe7960", ["ff"]), (2, "", ["2a2a"]) ]
tx_abort_lay :: Layout
tx_abort_lay = Layout "tx_abort" "004a" [
cid_h
, "000c", "6661696c656420636865636b" -- "failed check"
] []
stfu_lay :: Layout
stfu_lay = Layout "stfu" "0002" [ cid_h, "01" ] []
shutdown_lay :: Layout
shutdown_lay = Layout "shutdown" "0026" [ cid_h, "0016", p2wpkh_h ] []
closing_complete_lay :: Layout
closing_complete_lay = Layout "closing_complete" "0028" [
cid_h
, "0016", p2wpkh_h -- closer_scriptpubkey
, "0022", p2tr_h -- closee_scriptpubkey
, "00000000000001f4" -- fee_satoshis: 500
, "00000000" -- locktime: 0
] [ (t, sig1_h, [rep 63 "a1", rep 65 "a1"]) | t <- [1, 2, 3] ]
closing_sig_lay :: Layout
closing_sig_lay = Layout "closing_sig" "0029" [
cid_h
, "0016", p2wpkh_h -- closer_scriptpubkey
, "0022", p2tr_h -- closee_scriptpubkey
, "00000000000001f4" -- fee_satoshis: 500
, "000c3500" -- locktime: 800000
] [ (t, sig3_h, [rep 63 "c3", ""]) | t <- [1, 2, 3] ]
closing_signed_lay :: Layout
closing_signed_lay = Layout "closing_signed" "0027" [
cid_h
, "00000000000001f4" -- fee_satoshis: 500
, sig1_h
] [ (1, "000000000000006400000000000003e8", [
"000000000000006400000000000003"
, "000000000000006400000000000003e800"
, "0000000000000064ffffffffffffffff" -- max fee above 21M BTC
]) ]
update_add_htlc_lay :: Layout
update_add_htlc_lay = Layout "update_add_htlc" "0080" [
cid_h
, "0000000000000000" -- id: 0
, "00000000000186a0" -- amount_msat: 100000
, phash_h
, "000c3550" -- cltv_expiry: 800080
, onion_h
] [ (0, p2_h, [ rep 32 "22", p2_h ++ "00", "04" ++ rep 32 "22" ]) ]
update_fulfill_htlc_lay :: Layout
update_fulfill_htlc_lay = Layout "update_fulfill_htlc" "0082" [
cid_h
, "0000000000000007" -- id: 7
, preimage_h
] [ (1, attribution_h, [ drop 2 attribution_h, attribution_h ++ "00" ])
, (3, "deadbeef", []) ]
update_fail_htlc_lay :: Layout
update_fail_htlc_lay = Layout "update_fail_htlc" "0083" [
cid_h
, "0000000000000007" -- id: 7
, "0004", "01020304" -- reason
] [ (1, attribution_h, [ "" ]) ]
update_fail_malformed_htlc_lay :: Layout
update_fail_malformed_htlc_lay =
Layout "update_fail_malformed_htlc" "0087" [
cid_h
, "0000000000000003" -- id: 3
, onion_hash_h
, "c005" -- failure_code: BADONION | PERM | 5
] []
commitment_signed_lay :: Layout
commitment_signed_lay = Layout "commitment_signed" "0084" [
cid_h
, sig1_h
, "0002" -- num_htlcs
, sig2_h, sig3_h
] [ (1, txid_h, [ rep 31 "7e", rep 33 "7e" ]) ]
revoke_and_ack_lay :: Layout
revoke_and_ack_lay = Layout "revoke_and_ack" "0085"
[ cid_h, secret_h, p1_h ] []
update_fee_lay :: Layout
update_fee_lay = Layout "update_fee" "0086"
[ cid_h, "000009c4" ] [] -- feerate_per_kw: 2500
channel_reestablish_lay :: Layout
channel_reestablish_lay = Layout "channel_reestablish" "0088" [
cid_h
, "0000000000000005" -- next_commitment_number: 5
, "0000000000000004" -- next_revocation_number: 4
, secret_h
, p1_h
] [ (1, txid_h ++ "01", [ txid_h, txid_h ++ "0100" ]) ]
layouts :: [Layout]
layouts = [
open_channel_lay, accept_channel_lay, funding_created_lay
, funding_signed_lay, channel_ready_lay, open_channel2_lay
, accept_channel2_lay, tx_add_input_lay, tx_add_output_lay
, tx_remove_input_lay, tx_remove_output_lay, tx_complete_lay
, tx_signatures_lay, tx_init_rbf_lay, tx_ack_rbf_lay, tx_abort_lay
, stfu_lay, shutdown_lay, closing_complete_lay, closing_sig_lay
, closing_signed_lay, update_add_htlc_lay, update_fulfill_htlc_lay
, update_fail_htlc_lay, update_fail_malformed_htlc_lay
, commitment_signed_lay, revoke_and_ack_lay, update_fee_lay
, channel_reestablish_lay
]
-- a TLV record, in hex (for types below 253 and values below 65536
-- bytes)
tlv_h :: Word64 -> String -> String
tlv_h t v = hex2 t ++ len ++ v
where
n = fromIntegral (length v `div` 2) :: Word64
len | n < 253 = hex2 n
| otherwise = "fd" ++ hex2 (n `div` 256) ++ hex2 (n `mod` 256)
-- a byte, in hex
hex2 :: Word64 -> String
hex2 w = [digit (w `div` 16), digit (w `mod` 16)]
where
digit d = maybe '?' id (lookup d (zip [0 ..] "0123456789abcdef"))
-- known answers --------------------------------------------------------------
-- Check a message against wire bytes assembled by hand: its payload
-- decodes to the expected value and re-encodes to the same bytes, and
-- likewise for the full message.
kat
:: (Eq a, Show a)
=> String
-> Layout
-> [String] -- TLV records, hex
-> (BS.ByteString -> Either DecodeError a)
-> (a -> Either EncodeError BS.ByteString)
-> (a -> Message)
-> Maybe a
-> TestTree
kat name lay recs dec enc wrap expected = testCase name $ do
payload <- unhex (concat (lay_fixed lay ++ recs))
wire <- unhex (lay_type lay ++ concat (lay_fixed lay ++ recs))
m <- just name expected
dec payload @?= Right m
enc m @?= Right payload
decode_message wire @?= Right (wrap m)
encode_message (wrap m) @?= Right wire
known_answers :: TestTree
known_answers = testGroup "known answers" [
kat "open_channel" open_channel_lay
[ tlv_h 0 p2wpkh_h, tlv_h 1 "401000" ]
decode_open_channel encode_open_channel MsgOpenChannel $ do
ch <- f_chain
tcid <- f_tcid
fund <- sat 1000000
push <- msat 1000
dust <- sat 546
res <- sat 10000
hmin <- msat 1
[a, b, c, d, e, f] <- traverse f_point
[p1_h, p2_h, p3_h, p4_h, p5_h, p6_h]
spk <- f_script p2wpkh_h
pure (OpenChannel ch tcid fund push dust maxBound res hmin 253 144
483 a b c d e f 1 (Just spk) (Just anchors) empty)
, kat "open_channel (no TLVs)" open_channel_lay []
decode_open_channel encode_open_channel MsgOpenChannel $ do
ch <- f_chain
tcid <- f_tcid
fund <- sat 1000000
push <- msat 1000
dust <- sat 546
res <- sat 10000
hmin <- msat 1
[a, b, c, d, e, f] <- traverse f_point
[p1_h, p2_h, p3_h, p4_h, p5_h, p6_h]
pure (OpenChannel ch tcid fund push dust maxBound res hmin 253 144
483 a b c d e f 1 Nothing Nothing empty)
, kat "accept_channel" accept_channel_lay
[ tlv_h 0 "", tlv_h 1 "401000" ]
decode_accept_channel encode_accept_channel MsgAcceptChannel $ do
tcid <- f_tcid
dust <- sat 546
res <- sat 10000
hmin <- msat 1000
[a, b, c, d, e, f] <- traverse f_point
[p1_h, p2_h, p3_h, p4_h, p5_h, p6_h]
spk <- script_pubkey ""
pure (AcceptChannel tcid dust 100000000 res hmin 3 144 483
a b c d e f (Just spk) (Just anchors) empty)
, kat "funding_created" funding_created_lay []
decode_funding_created (Right . encode_funding_created)
MsgFundingCreated $ do
tcid <- f_tcid
t <- f_txid
s <- f_sig sig1_h
pure (FundingCreated tcid t 1 s empty)
, kat "funding_signed" funding_signed_lay []
decode_funding_signed (Right . encode_funding_signed)
MsgFundingSigned $ do
cid <- f_cid
s <- f_sig sig1_h
pure (FundingSigned cid s empty)
, kat "channel_ready" channel_ready_lay
[ tlv_h 1 "083a8400034d0001" ]
decode_channel_ready encode_channel_ready MsgChannelReady $ do
cid <- f_cid
pcp <- f_point p1_h
alias <- BOLT1.short_channel_id 539268 845 1
pure (ChannelReady cid pcp (Just alias) empty)
, kat "open_channel2" open_channel2_lay
[ tlv_h 0 p2wpkh_h, tlv_h 1 "401000", tlv_h 2 "" ]
decode_open_channel2 encode_open_channel2 MsgOpenChannel2 $ do
ch <- f_chain
tcid <- f_tcid
fund <- sat 200000
dust <- sat 354
hmin <- msat 1
[a, b, c, d, e, f, g] <- traverse f_point
[p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h]
spk <- f_script p2wpkh_h
pure (OpenChannel2 ch tcid 4000 253 fund dust maxBound hmin 144 483
800000 a b c d e f g 0 (Just spk) (Just anchors) True
empty)
, kat "accept_channel2" accept_channel2_lay
[ tlv_h 0 p2wsh_h, tlv_h 1 "401000", tlv_h 2 "" ]
decode_accept_channel2 encode_accept_channel2 MsgAcceptChannel2 $ do
tcid <- f_tcid
fund <- sat 0
dust <- sat 354
hmin <- msat 1000
[a, b, c, d, e, f, g] <- traverse f_point
[p1_h, p2_h, p3_h, p4_h, p5_h, p6_h, p7_h]
spk <- f_script p2wsh_h
pure (AcceptChannel2 tcid fund dust 100000000 hmin 6 144 30
a b c d e f g (Just spk) (Just anchors) True empty)
, kat "tx_add_input" tx_add_input_lay []
decode_tx_add_input encode_tx_add_input MsgTxAddInput $ do
cid <- f_cid
pure (TxAddInput cid (SerialId 2) "\x01\x02\x03\x04\x05" 1
0xfffffffd empty)
, kat "tx_add_output" tx_add_output_lay []
decode_tx_add_output (Right . encode_tx_add_output)
MsgTxAddOutput $ do
cid <- f_cid
amt <- sat 200000
spk <- f_script p2wsh_h
pure (TxAddOutput cid (SerialId 4) amt spk empty)
, kat "tx_remove_input" tx_remove_input_lay []
decode_tx_remove_input (Right . encode_tx_remove_input)
MsgTxRemoveInput $ do
cid <- f_cid
pure (TxRemoveInput cid (SerialId 2) empty)
, kat "tx_remove_output" tx_remove_output_lay []
decode_tx_remove_output (Right . encode_tx_remove_output)
MsgTxRemoveOutput $ do
cid <- f_cid
pure (TxRemoveOutput cid (SerialId 5) empty)
, kat "tx_complete" tx_complete_lay []
decode_tx_complete (Right . encode_tx_complete) MsgTxComplete $ do
cid <- f_cid
pure (TxComplete cid empty)
, kat "tx_signatures" tx_signatures_lay []
decode_tx_signatures encode_tx_signatures MsgTxSignatures $ do
cid <- f_cid
t <- f_txid
w1 <- witness "\x02\x02\xaa\xaa\x01\xbb"
w2 <- witness "\x01\x01\xcc"
pure (TxSignatures cid t [w1, w2] empty)
, kat "tx_init_rbf" tx_init_rbf_lay
[ tlv_h 0 "0000000000030d40", tlv_h 2 "" ]
decode_tx_init_rbf encode_tx_init_rbf MsgTxInitRbf $ do
cid <- f_cid
pure (TxInitRbf cid 800000 4166 (Just 200000) True empty)
, kat "tx_ack_rbf" tx_ack_rbf_lay
[ tlv_h 0 "fffffffffffe7960", tlv_h 2 "" ]
decode_tx_ack_rbf encode_tx_ack_rbf MsgTxAckRbf $ do
cid <- f_cid
pure (TxAckRbf cid (Just (-100000)) True empty)
, kat "tx_abort" tx_abort_lay []
decode_tx_abort encode_tx_abort MsgTxAbort $ do
cid <- f_cid
pure (TxAbort cid "failed check" empty)
, kat "stfu" stfu_lay []
decode_stfu (Right . encode_stfu) MsgStfu $ do
cid <- f_cid
pure (Stfu cid True empty)
, kat "shutdown" shutdown_lay []
decode_shutdown (Right . encode_shutdown) MsgShutdown $ do
cid <- f_cid
spk <- f_script p2wpkh_h
pure (Shutdown cid spk empty)
, kat "closing_complete" closing_complete_lay
[ tlv_h 1 sig1_h, tlv_h 3 sig2_h ]
decode_closing_complete encode_closing_complete
MsgClosingComplete $ do
cid <- f_cid
closer <- f_script p2wpkh_h
closee <- f_script p2tr_h
fee <- sat 500
s1 <- f_sig sig1_h
s2 <- f_sig sig2_h
pure (ClosingComplete cid closer closee fee 0 (Just s1) Nothing
(Just s2) empty)
, kat "closing_complete (closee output only)" closing_complete_lay
[ tlv_h 2 sig1_h ]
decode_closing_complete encode_closing_complete
MsgClosingComplete $ do
cid <- f_cid
closer <- f_script p2wpkh_h
closee <- f_script p2tr_h
fee <- sat 500
s1 <- f_sig sig1_h
pure (ClosingComplete cid closer closee fee 0 Nothing (Just s1)
Nothing empty)
, kat "closing_sig" closing_sig_lay [ tlv_h 3 sig3_h ]
decode_closing_sig encode_closing_sig MsgClosingSig $ do
cid <- f_cid
closer <- f_script p2wpkh_h
closee <- f_script p2tr_h
fee <- sat 500
s3 <- f_sig sig3_h
pure (ClosingSig cid closer closee fee 800000 Nothing Nothing
(Just s3) empty)
, kat "closing_signed" closing_signed_lay
[ tlv_h 1 "000000000000006400000000000003e8" ]
decode_closing_signed encode_closing_signed MsgClosingSigned $ do
cid <- f_cid
fee <- sat 500
s <- f_sig sig1_h
lo <- sat 100
hi <- sat 1000
pure (ClosingSigned cid fee s (Just (FeeRange lo hi)) empty)
, kat "update_add_htlc" update_add_htlc_lay [ tlv_h 0 p2_h ]
decode_update_add_htlc encode_update_add_htlc MsgUpdateAddHtlc $ do
cid <- f_cid
amt <- msat 100000
ph <- BOLT1.payment_hash =<< hx phash_h
onion <- onion_routing_packet =<< hx onion_h
pk <- f_point p2_h
pure (UpdateAddHtlc cid (HtlcId 0) amt ph 800080 onion (Just pk)
empty)
, kat "update_fulfill_htlc" update_fulfill_htlc_lay
[ tlv_h 1 attribution_h, tlv_h 3 "deadbeef" ]
decode_update_fulfill_htlc encode_update_fulfill_htlc
MsgUpdateFulfillHtlc $ do
cid <- f_cid
pre <- BOLT1.payment_preimage =<< hx preimage_h
att <- f_attribution
pure (UpdateFulfillHtlc cid (HtlcId 7) pre (Just att)
(Just "\xde\xad\xbe\xef") empty)
, kat "update_fail_htlc" update_fail_htlc_lay [ tlv_h 1 attribution_h ]
decode_update_fail_htlc encode_update_fail_htlc MsgUpdateFailHtlc $ do
cid <- f_cid
att <- f_attribution
pure (UpdateFailHtlc cid (HtlcId 7) "\x01\x02\x03\x04" (Just att)
empty)
, kat "update_fail_malformed_htlc" update_fail_malformed_htlc_lay []
decode_update_fail_malformed_htlc
(Right . encode_update_fail_malformed_htlc)
MsgUpdateFailMalformedHtlc $ do
cid <- f_cid
oh <- onion_hash =<< hx onion_hash_h
pure (UpdateFailMalformedHtlc cid (HtlcId 3) oh 0xc005 empty)
, kat "commitment_signed" commitment_signed_lay [ tlv_h 1 txid_h ]
decode_commitment_signed encode_commitment_signed
MsgCommitmentSigned $ do
cid <- f_cid
sigs <- traverse f_sig [sig1_h, sig2_h, sig3_h]
t <- f_txid
case sigs of
(s : hs) -> pure (CommitmentSigned cid s hs (Just t) empty)
[] -> Nothing
, kat "revoke_and_ack" revoke_and_ack_lay []
decode_revoke_and_ack (Right . encode_revoke_and_ack)
MsgRevokeAndAck $ do
cid <- f_cid
sec <- f_secret
pcp <- f_point p1_h
pure (RevokeAndAck cid sec pcp empty)
, kat "update_fee" update_fee_lay []
decode_update_fee (Right . encode_update_fee) MsgUpdateFee $ do
cid <- f_cid
pure (UpdateFee cid 2500 empty)
, kat "channel_reestablish" channel_reestablish_lay
[ tlv_h 1 (txid_h ++ "01") ]
decode_channel_reestablish encode_channel_reestablish
MsgChannelReestablish $ do
cid <- f_cid
sec <- f_secret
pcp <- f_point p1_h
t <- f_txid
pure (ChannelReestablish cid 5 4 sec pcp (Just (NextFunding t 1))
empty)
]
-- TLV handling ---------------------------------------------------------------
-- decode a message (type, fixed fields and TLV records in hex), check
-- its unknown records, and check that it re-encodes exactly
reencodes :: Layout -> [String] -> [TlvRecord] -> Assertion
reencodes lay recs extra = do
wire <- unhex (lay_type lay ++ concat (lay_fixed lay ++ recs))
case decode_message wire of
Left e -> assertFailure ("decode failed: " ++ show e)
Right m -> do
BOLT1.un_tlv_stream (message_tlvs m) @?= extra
encode_message m @?= Right wire
rejects :: Layout -> [String] -> DecodeError -> Assertion
rejects lay recs err = do
wire <- unhex (lay_type lay ++ concat (lay_fixed lay ++ recs))
decode_message wire @?= Left err
-- the smallest even type a message doesn't know
first_unknown_even :: Layout -> Word64
first_unknown_even lay = case filter (`notElem` known) [0, 2 ..] of
(t:_) -> t
[] -> 0
where
known = [ t | (t, _, _) <- lay_known lay ]
tlv_cases :: Layout -> TestTree
tlv_cases lay = testGroup (lay_name lay) $ [
testCase "unknown odd records are preserved" $
reencodes lay (valid ++ [tlv_h 43 "2a", tlv_h 201 ""])
[TlvRecord 43 "\x2a", TlvRecord 201 ""]
, testCase "unknown even records are rejected" $ do
let t = first_unknown_even lay
rejects lay [tlv_h t ""] (DecodeTlvError (TlvUnknownEvenType t))
rejects lay (valid ++ [tlv_h 42 "00"])
(DecodeTlvError (TlvUnknownEvenType 42))
, testCase "unordered records are rejected" $
rejects lay [tlv_h 45 "", tlv_h 43 ""]
(DecodeTlvError TlvNotStrictlyIncreasing)
, testCase "a huge record length is rejected" $ do
-- the length 2^64 - 1 must not wrap
rejects lay ["2bffffffffffffffffff2b"] (DecodeTlvError TlvTruncated)
] ++ [
testCase ("type " ++ show t ++ " is typed") $ reencodes lay [tlv_h t v] []
| (t, v, _) <- lay_known lay
] ++ [
testCase ("malformed type " ++ show t ++ " is rejected") $
mapM_ (\b -> rejects lay [tlv_h t b] (DecodeInvalidTlvValue t)) bad
| (t, _, bad) <- lay_known lay, not (null bad)
]
where
valid = [ tlv_h t v | (t, v, _) <- lay_known lay ]
tlv_handling :: TestTree
tlv_handling = testGroup "TLV handling" $ map tlv_cases layouts ++ [
testGroup "splicing records" [
testCase "tx_add_input shared_input_txid is rejected" $
rejects tx_add_input_lay [tlv_h 0 txid_h]
(DecodeTlvError (TlvUnknownEvenType 0))
, testCase "tx_signatures shared_input_signature is rejected" $
rejects tx_signatures_lay [tlv_h 0 sig1_h]
(DecodeTlvError (TlvUnknownEvenType 0))
, testCase "channel_reestablish my_current_funding_locked is kept" $ do
v <- unhex (txid_h ++ "01")
reencodes channel_reestablish_lay
[tlv_h 1 (txid_h ++ "00"), tlv_h 5 (txid_h ++ "01")]
[TlvRecord 5 v]
]
, testCase "a non-minimal type is rejected" $
rejects update_fee_lay ["fd002b00"]
(DecodeTlvError TlvNonMinimalBigSize)
, testCase "a repeated type is rejected" $
rejects update_fee_lay [tlv_h 43 "", tlv_h 43 ""]
(DecodeTlvError TlvNotStrictlyIncreasing)
, testCase "trailing bytes that aren't a TLV record are rejected" $ do
rejects update_fee_lay ["fd"] (DecodeTlvError TlvTruncated)
rejects update_fee_lay ["2b"] (DecodeTlvError TlvTruncated)
rejects update_fee_lay ["2b02aa"] (DecodeTlvError TlvTruncated)
, testCase "an empty upfront_shutdown_script is kept" $ do
wire <- unhex (concat (lay_fixed open_channel_lay ++ [tlv_h 0 ""]))
fmap open_channel_upfront_shutdown_script (decode_open_channel wire)
@?= Right (script_pubkey "")
, testCase "an oversized upfront_shutdown_script is rejected" $ do
fixed <- unhex (concat (lay_fixed open_channel_lay))
let big = BS.replicate 65536 0x00
rec = "\x00\xfe\x00\x01\x00\x00" <> big
decode_open_channel (fixed <> rec) @?= Left (DecodeInvalidTlvValue 0)
, testCase "channel_type bytes are kept as received" $ do
wire <- unhex (concat (lay_fixed open_channel_lay
++ [tlv_h 1 "00401000"]))
case decode_open_channel wire of
Left e -> assertFailure (show e)
Right m -> do
fmap BOLT9.render (open_channel_channel_type m)
@?= Just "\x00\x40\x10\x00"
(BOLT9.channel_type =<< open_channel_channel_type m)
@?= Just (BOLT9.ChannelType BOLT9.BasicAnchors False False)
encode_open_channel m @?= Right wire
]
-- decoding failures ----------------------------------------------------------
decoding_failures :: TestTree
decoding_failures = testGroup "decoding failures" [
testGroup "truncated payloads" [
testCase (lay_name lay) $ do
wire <- unhex (lay_type lay ++ concat (lay_fixed lay))
decode_message (BS.take (BS.length wire - 1) wire)
@?= Left DecodeInsufficientBytes
decode_message (BS.take 2 wire) @?= Left DecodeInsufficientBytes
| lay <- layouts ]
, testCase "a message without a type" $ do
decode_message "" @?= Left DecodeInsufficientBytes
decode_message "\x00" @?= Left DecodeInsufficientBytes
, testCase "message types BOLT #2 doesn't define" $ do
decode_message "\x00\x50" @?= Left (DecodeUnknownEvenType 80)
decode_message "\x00\x51" @?= Left (DecodeUnknownOddType 81)
decode_message "\x00\x4d" @?= Left (DecodeUnknownOddType 77)
decode_message "\x00\x7f" @?= Left (DecodeUnknownOddType 127)
decode_message "\x00\x10\x00\x00\x00\x00"
@?= Left (DecodeUnknownEvenType 16)
, testCase "an invalid point" $ do
let bad = "04" ++ rep 32 "11"
wire <- unhex (concat (open_channel_fields 11 bad))
decode_open_channel wire @?= Left DecodeInvalidPoint
wire' <- unhex (cid_h ++ secret_h ++ bad)
decode_revoke_and_ack wire' @?= Left DecodeInvalidPoint
, testCase "amounts above 21M BTC" $ do
-- funding_satoshis of 21M BTC, then one satoshi more
ok <- unhex (concat (open_channel_fields 2 "000775f05a074000"))
bad <- unhex (concat (open_channel_fields 2 "000775f05a074001"))
assertBool "21M BTC" (either (const False) (const True)
(decode_open_channel ok))
decode_open_channel bad @?= Left DecodeInvalidAmount
htlc <- unhex (cid_h ++ "0000000000000000" ++ "1d24b2dfac520001"
++ phash_h ++ "000c3550" ++ onion_h)
decode_update_add_htlc htlc @?= Left DecodeInvalidAmount
out <- unhex (cid_h ++ "0000000000000004" ++ "ffffffffffffffff"
++ "0000")
decode_tx_add_output out @?= Left DecodeInvalidAmount
, testCase "stfu initiator byte" $ do
off <- unhex (cid_h ++ "00")
fmap stfu_initiator (decode_stfu off) @?= Right False
bad <- unhex (cid_h ++ "02")
decode_stfu bad @?= Left DecodeInvalidInitiator
, testCase "a list longer than its payload" $ do
wire <- unhex (cid_h ++ sig1_h ++ "0003" ++ sig2_h ++ sig3_h)
decode_commitment_signed wire @?= Left DecodeInsufficientBytes
wire' <- unhex (cid_h ++ txid_h ++ "0001" ++ "0004" ++ "0101")
decode_tx_signatures wire' @?= Left DecodeInsufficientBytes
, testCase "a short onion_routing_packet" $ do
wire <- unhex (concat (take 5 (lay_fixed update_add_htlc_lay))
++ drop 2 onion_h)
decode_update_add_htlc wire @?= Left DecodeInsufficientBytes
]
where
-- open_channel's fixed fields with field i replaced
open_channel_fields :: Int -> String -> [String]
open_channel_fields i v =
let fs = lay_fixed open_channel_lay
in take i fs ++ [v] ++ drop (i + 1) fs
-- encoding failures ----------------------------------------------------------
encoding_failures :: TestTree
encoding_failures = testGroup "encoding failures" [
testCase "u16 length prefixes" $ do
cid <- just "cid" f_cid
let big = BS.replicate 65536 0x00
max_ok = BS.replicate 65535 0x00
encode_tx_add_input (TxAddInput cid (SerialId 0) big 0 0 empty)
@?= Left EncodeLengthOverflow
assertBool "65535-byte prevtx" $ either (const False) (const True)
(encode_tx_add_input (TxAddInput cid (SerialId 0) max_ok 0 0 empty))
encode_tx_abort (TxAbort cid big empty) @?= Left EncodeLengthOverflow
encode_update_fail_htlc
(UpdateFailHtlc cid (HtlcId 0) big Nothing empty)
@?= Left EncodeLengthOverflow
, testCase "u16 counts" $ do
cid <- just "cid" f_cid
s <- just "sig" (f_sig sig1_h)
t <- just "txid" f_txid
w <- just "witness" (witness "\x00")
encode_commitment_signed
(CommitmentSigned cid s (replicate 65536 s) Nothing empty)
@?= Left EncodeLengthOverflow
encode_tx_signatures (TxSignatures cid t (replicate 65536 w) empty)
@?= Left EncodeLengthOverflow
, testCase "_tlvs fields can't hold known types" $ do
cid <- just "cid" f_cid
pcp <- just "point" (f_point p1_h)
s <- just "sig" (f_sig sig1_h)
spk <- just "script" (f_script p2wpkh_h)
fee <- just "fee" (sat 500)
one <- just "tlvs" (BOLT1.tlv_stream [TlvRecord 1 "\x00"])
two <- just "tlvs" (BOLT1.tlv_stream [TlvRecord 2 ""])
odd' <- just "tlvs" (BOLT1.tlv_stream [TlvRecord 43 ""])
encode_channel_ready (ChannelReady cid pcp Nothing one)
@?= Left EncodeInvalidTlvs
encode_closing_complete
(ClosingComplete cid spk spk fee 0 (Just s) Nothing Nothing two)
@?= Left EncodeInvalidTlvs
encode_tx_ack_rbf (TxAckRbf cid Nothing False two)
@?= Left EncodeInvalidTlvs
assertBool "unknown odd records encode" $
either (const False) (const True)
(encode_channel_ready (ChannelReady cid pcp Nothing odd'))
, testCase "the message size limit" $ do
cid <- just "cid" f_cid
-- a 65533-byte payload fits; one more byte doesn't
let at n = TxAbort cid (BS.replicate n 0x00) empty
fmap BS.length (encode_message (MsgTxAbort (at 65499)))
@?= Right 65535
encode_message (MsgTxAbort (at 65500)) @?= Left EncodeMessageTooLarge
fmap BS.length (encode_tx_abort (at 65500)) @?= Right 65534
]
-- field types ----------------------------------------------------------------
field_types :: TestTree
field_types = testGroup "field types" [
testCase "script_pubkey" $ do
fmap un_script_pubkey (script_pubkey (BS.replicate 65535 0x51))
@?= Just (BS.replicate 65535 0x51)
script_pubkey (BS.replicate 65536 0x51) @?= Nothing
, testCase "witness" $ do
fmap un_witness (witness "") @?= Just ""
witness (BS.replicate 65536 0x00) @?= Nothing
, testCase "onion_routing_packet" $ do
let bs = BS.replicate 1366 0x00
fmap un_onion_routing_packet (onion_routing_packet bs) @?= Just bs
onion_routing_packet (BS.take 1365 bs) @?= Nothing
onion_routing_packet (BS.cons 0x00 bs) @?= Nothing
, testCase "onion_hash" $ do
fmap un_onion_hash (onion_hash (BS.replicate 32 0x01))
@?= Just (BS.replicate 32 0x01)
onion_hash (BS.replicate 33 0x01) @?= Nothing
, testCase "attribution_data" $ do
let bs = BS.replicate 920 0x00
fmap un_attribution_data (attribution_data bs) @?= Just bs
attribution_data (BS.take 919 bs) @?= Nothing
, testCase "message types" $ do
cid <- just "cid" f_cid
message_type (MsgStfu (Stfu cid False empty)) @?= 2
message_type (MsgUpdateFee (UpdateFee cid 0 empty)) @?= 134
]
-- generators -----------------------------------------------------------------
gen_bytes :: Int -> Gen BS.ByteString
gen_bytes n = BS.pack <$> vectorOf n arbitrary
gen_var_bytes :: Int -> Gen BS.ByteString
gen_var_bytes hi = choose (0, hi) >>= gen_bytes
gen_cid :: Gen BOLT1.ChannelId
gen_cid = gen_bytes 32 `suchThatMap` BOLT1.channel_id
gen_chain :: Gen BOLT1.ChainHash
gen_chain = gen_bytes 32 `suchThatMap` BOLT1.chain_hash
gen_point :: Gen BOLT1.Point
gen_point = do
p <- elements [0x02, 0x03]
(BS.cons p <$> gen_bytes 32) `suchThatMap` BOLT1.point
gen_sig :: Gen BOLT1.Signature
gen_sig = gen_bytes 64 `suchThatMap` BOLT1.signature
gen_txid :: Gen Tx.TxId
gen_txid = gen_bytes 32 `suchThatMap` Tx.mk_txid
gen_secret :: Gen BOLT1.PerCommitmentSecret
gen_secret = gen_bytes 32 `suchThatMap` BOLT1.per_commitment_secret
gen_sat :: Gen BOLT1.Satoshi
gen_sat = choose (0, 2100000000000000) `suchThatMap` BOLT1.satoshi
gen_msat :: Gen BOLT1.MilliSatoshi
gen_msat = choose (0, 2100000000000000000) `suchThatMap` BOLT1.milli_satoshi
gen_script :: Gen ScriptPubKey
gen_script = gen_var_bytes 40 `suchThatMap` script_pubkey
gen_fv :: Gen BOLT9.FeatureVector
gen_fv = BOLT9.parse <$> gen_var_bytes 8
gen_maybe :: Gen a -> Gen (Maybe a)
gen_maybe g = oneof [pure Nothing, Just <$> g]
-- unknown odd records, avoiding a message's known types
gen_tlvs :: [Word64] -> Gen BOLT1.TlvStream
gen_tlvs known = do
ts <- sublistOf (filter (`notElem` known) candidates)
rs <- traverse (\t -> TlvRecord t <$> gen_var_bytes 12) ts
pure (maybe empty id (BOLT1.tlv_stream rs))
where
candidates = [1, 3, 5, 7, 43, 201, 253, 65537, 4294967297]
gen_open_channel :: Gen OpenChannel
gen_open_channel = OpenChannel <$> gen_chain <*> gen_cid <*> gen_sat
<*> gen_msat <*> gen_sat <*> arbitrary <*> gen_sat <*> gen_msat
<*> arbitrary <*> arbitrary <*> arbitrary <*> gen_point <*> gen_point
<*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> arbitrary
<*> gen_maybe gen_script <*> gen_maybe gen_fv <*> gen_tlvs [0, 1]
gen_accept_channel :: Gen AcceptChannel
gen_accept_channel = AcceptChannel <$> gen_cid <*> gen_sat <*> arbitrary
<*> gen_sat <*> gen_msat <*> arbitrary <*> arbitrary <*> arbitrary
<*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> gen_point
<*> gen_point <*> gen_maybe gen_script <*> gen_maybe gen_fv
<*> gen_tlvs [0, 1]
gen_funding_created :: Gen FundingCreated
gen_funding_created = FundingCreated <$> gen_cid <*> gen_txid <*> arbitrary
<*> gen_sig <*> gen_tlvs []
gen_funding_signed :: Gen FundingSigned
gen_funding_signed = FundingSigned <$> gen_cid <*> gen_sig <*> gen_tlvs []
gen_channel_ready :: Gen ChannelReady
gen_channel_ready = ChannelReady <$> gen_cid <*> gen_point
<*> gen_maybe (BOLT1.ShortChannelId <$> arbitrary) <*> gen_tlvs [1]
gen_open_channel2 :: Gen OpenChannel2
gen_open_channel2 = OpenChannel2 <$> gen_chain <*> gen_cid <*> arbitrary
<*> arbitrary <*> gen_sat <*> gen_sat <*> arbitrary <*> gen_msat
<*> arbitrary <*> arbitrary <*> arbitrary <*> gen_point <*> gen_point
<*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> gen_point
<*> arbitrary <*> gen_maybe gen_script <*> gen_maybe gen_fv
<*> arbitrary <*> gen_tlvs [0, 1, 2]
gen_accept_channel2 :: Gen AcceptChannel2
gen_accept_channel2 = AcceptChannel2 <$> gen_cid <*> gen_sat <*> gen_sat
<*> arbitrary <*> gen_msat <*> arbitrary <*> arbitrary <*> arbitrary
<*> gen_point <*> gen_point <*> gen_point <*> gen_point <*> gen_point
<*> gen_point <*> gen_point <*> gen_maybe gen_script
<*> gen_maybe gen_fv <*> arbitrary <*> gen_tlvs [0, 1, 2]
gen_tx_add_input :: Gen TxAddInput
gen_tx_add_input = TxAddInput <$> gen_cid <*> (SerialId <$> arbitrary)
<*> gen_var_bytes 64 <*> arbitrary <*> arbitrary <*> gen_tlvs []
gen_tx_add_output :: Gen TxAddOutput
gen_tx_add_output = TxAddOutput <$> gen_cid <*> (SerialId <$> arbitrary)
<*> gen_sat <*> gen_script <*> gen_tlvs []
gen_tx_remove_input :: Gen TxRemoveInput
gen_tx_remove_input = TxRemoveInput <$> gen_cid <*> (SerialId <$> arbitrary)
<*> gen_tlvs []
gen_tx_remove_output :: Gen TxRemoveOutput
gen_tx_remove_output = TxRemoveOutput <$> gen_cid
<*> (SerialId <$> arbitrary) <*> gen_tlvs []
gen_tx_complete :: Gen TxComplete
gen_tx_complete = TxComplete <$> gen_cid <*> gen_tlvs []
gen_tx_signatures :: Gen TxSignatures
gen_tx_signatures = TxSignatures <$> gen_cid <*> gen_txid
<*> listOf (gen_var_bytes 32 `suchThatMap` witness) <*> gen_tlvs []
gen_tx_init_rbf :: Gen TxInitRbf
gen_tx_init_rbf = TxInitRbf <$> gen_cid <*> arbitrary <*> arbitrary
<*> gen_maybe (arbitrary :: Gen Int64) <*> arbitrary <*> gen_tlvs [0, 2]
gen_tx_ack_rbf :: Gen TxAckRbf
gen_tx_ack_rbf = TxAckRbf <$> gen_cid <*> gen_maybe arbitrary <*> arbitrary
<*> gen_tlvs [0, 2]
gen_tx_abort :: Gen TxAbort
gen_tx_abort = TxAbort <$> gen_cid <*> gen_var_bytes 64 <*> gen_tlvs []
gen_stfu :: Gen Stfu
gen_stfu = Stfu <$> gen_cid <*> arbitrary <*> gen_tlvs []
gen_shutdown :: Gen Shutdown
gen_shutdown = Shutdown <$> gen_cid <*> gen_script <*> gen_tlvs []
gen_closing_complete :: Gen ClosingComplete
gen_closing_complete = ClosingComplete <$> gen_cid <*> gen_script
<*> gen_script <*> gen_sat <*> arbitrary <*> gen_maybe gen_sig
<*> gen_maybe gen_sig <*> gen_maybe gen_sig <*> gen_tlvs [1, 2, 3]
gen_closing_sig :: Gen ClosingSig
gen_closing_sig = ClosingSig <$> gen_cid <*> gen_script <*> gen_script
<*> gen_sat <*> arbitrary <*> gen_maybe gen_sig <*> gen_maybe gen_sig
<*> gen_maybe gen_sig <*> gen_tlvs [1, 2, 3]
gen_closing_signed :: Gen ClosingSigned
gen_closing_signed = ClosingSigned <$> gen_cid <*> gen_sat <*> gen_sig
<*> gen_maybe (FeeRange <$> gen_sat <*> gen_sat) <*> gen_tlvs [1]
gen_update_add_htlc :: Gen UpdateAddHtlc
gen_update_add_htlc = UpdateAddHtlc <$> gen_cid <*> (HtlcId <$> arbitrary)
<*> gen_msat
<*> (gen_bytes 32 `suchThatMap` BOLT1.payment_hash)
<*> arbitrary
<*> (gen_bytes 1366 `suchThatMap` onion_routing_packet)
<*> gen_maybe gen_point <*> gen_tlvs [0]
gen_update_fulfill_htlc :: Gen UpdateFulfillHtlc
gen_update_fulfill_htlc = UpdateFulfillHtlc <$> gen_cid
<*> (HtlcId <$> arbitrary)
<*> (gen_bytes 32 `suchThatMap` BOLT1.payment_preimage)
<*> gen_maybe (gen_bytes 920 `suchThatMap` attribution_data)
<*> gen_maybe (gen_var_bytes 64) <*> gen_tlvs [1, 3]
gen_update_fail_htlc :: Gen UpdateFailHtlc
gen_update_fail_htlc = UpdateFailHtlc <$> gen_cid <*> (HtlcId <$> arbitrary)
<*> gen_var_bytes 300
<*> gen_maybe (gen_bytes 920 `suchThatMap` attribution_data)
<*> gen_tlvs [1]
gen_update_fail_malformed_htlc :: Gen UpdateFailMalformedHtlc
gen_update_fail_malformed_htlc = UpdateFailMalformedHtlc <$> gen_cid
<*> (HtlcId <$> arbitrary)
<*> (gen_bytes 32 `suchThatMap` onion_hash)
<*> arbitrary <*> gen_tlvs []
gen_commitment_signed :: Gen CommitmentSigned
gen_commitment_signed = CommitmentSigned <$> gen_cid <*> gen_sig
<*> listOf gen_sig <*> gen_maybe gen_txid <*> gen_tlvs [1]
gen_revoke_and_ack :: Gen RevokeAndAck
gen_revoke_and_ack = RevokeAndAck <$> gen_cid <*> gen_secret <*> gen_point
<*> gen_tlvs []
gen_update_fee :: Gen UpdateFee
gen_update_fee = UpdateFee <$> gen_cid <*> arbitrary <*> gen_tlvs []
gen_channel_reestablish :: Gen ChannelReestablish
gen_channel_reestablish = ChannelReestablish <$> gen_cid <*> arbitrary
<*> arbitrary <*> gen_secret <*> gen_point
<*> gen_maybe (NextFunding <$> gen_txid <*> arbitrary) <*> gen_tlvs [1]
gen_message :: Gen Message
gen_message = oneof [
MsgOpenChannel <$> gen_open_channel
, MsgAcceptChannel <$> gen_accept_channel
, MsgFundingCreated <$> gen_funding_created
, MsgFundingSigned <$> gen_funding_signed
, MsgChannelReady <$> gen_channel_ready
, MsgOpenChannel2 <$> gen_open_channel2
, MsgAcceptChannel2 <$> gen_accept_channel2
, MsgTxAddInput <$> gen_tx_add_input
, MsgTxAddOutput <$> gen_tx_add_output
, MsgTxRemoveInput <$> gen_tx_remove_input
, MsgTxRemoveOutput <$> gen_tx_remove_output
, MsgTxComplete <$> gen_tx_complete
, MsgTxSignatures <$> gen_tx_signatures
, MsgTxInitRbf <$> gen_tx_init_rbf
, MsgTxAckRbf <$> gen_tx_ack_rbf
, MsgTxAbort <$> gen_tx_abort
, MsgStfu <$> gen_stfu
, MsgShutdown <$> gen_shutdown
, MsgClosingComplete <$> gen_closing_complete
, MsgClosingSig <$> gen_closing_sig
, MsgClosingSigned <$> gen_closing_signed
, MsgUpdateAddHtlc <$> gen_update_add_htlc
, MsgUpdateFulfillHtlc <$> gen_update_fulfill_htlc
, MsgUpdateFailHtlc <$> gen_update_fail_htlc
, MsgUpdateFailMalformedHtlc <$> gen_update_fail_malformed_htlc
, MsgCommitmentSigned <$> gen_commitment_signed
, MsgRevokeAndAck <$> gen_revoke_and_ack
, MsgUpdateFee <$> gen_update_fee
, MsgChannelReestablish <$> gen_channel_reestablish
]
-- properties -----------------------------------------------------------------
-- decoding an encoded payload gives back the value
roundtrip
:: (Eq a, Show a)
=> String
-> Gen a
-> (a -> Either EncodeError BS.ByteString)
-> (BS.ByteString -> Either DecodeError a)
-> TestTree
roundtrip name gen enc dec = testProperty name $ forAll gen $ \m ->
case enc m of
Left e -> counterexample ("encode failed: " ++ show e) False
Right w -> dec w === Right m
-- byte strings derived from a valid encoding
data Edit = Replace !Int !Word8 | Truncate !Int | Append !BS.ByteString
deriving Show
gen_edit :: Gen Edit
gen_edit = oneof [
Replace <$> arbitrary <*> arbitrary
, Truncate <$> arbitrary
, Append <$> gen_var_bytes 8
]
apply_edit :: Edit -> BS.ByteString -> BS.ByteString
apply_edit e bs = case e of
Replace i b
| BS.null bs -> bs
| otherwise ->
let j = i `mod` BS.length bs
in BS.take j bs <> BS.singleton b <> BS.drop (j + 1) bs
Truncate i
| BS.null bs -> bs
| otherwise -> BS.take (i `mod` BS.length bs) bs
Append x -> bs <> x
properties :: TestTree
properties = testGroup "properties" [
testGroup "payloads round-trip" [
roundtrip "open_channel" gen_open_channel
encode_open_channel decode_open_channel
, roundtrip "accept_channel" gen_accept_channel
encode_accept_channel decode_accept_channel
, roundtrip "funding_created" gen_funding_created
(Right . encode_funding_created) decode_funding_created
, roundtrip "funding_signed" gen_funding_signed
(Right . encode_funding_signed) decode_funding_signed
, roundtrip "channel_ready" gen_channel_ready
encode_channel_ready decode_channel_ready
, roundtrip "open_channel2" gen_open_channel2
encode_open_channel2 decode_open_channel2
, roundtrip "accept_channel2" gen_accept_channel2
encode_accept_channel2 decode_accept_channel2
, roundtrip "tx_add_input" gen_tx_add_input
encode_tx_add_input decode_tx_add_input
, roundtrip "tx_add_output" gen_tx_add_output
(Right . encode_tx_add_output) decode_tx_add_output
, roundtrip "tx_remove_input" gen_tx_remove_input
(Right . encode_tx_remove_input) decode_tx_remove_input
, roundtrip "tx_remove_output" gen_tx_remove_output
(Right . encode_tx_remove_output) decode_tx_remove_output
, roundtrip "tx_complete" gen_tx_complete
(Right . encode_tx_complete) decode_tx_complete
, roundtrip "tx_signatures" gen_tx_signatures
encode_tx_signatures decode_tx_signatures
, roundtrip "tx_init_rbf" gen_tx_init_rbf
encode_tx_init_rbf decode_tx_init_rbf
, roundtrip "tx_ack_rbf" gen_tx_ack_rbf
encode_tx_ack_rbf decode_tx_ack_rbf
, roundtrip "tx_abort" gen_tx_abort encode_tx_abort decode_tx_abort
, roundtrip "stfu" gen_stfu (Right . encode_stfu) decode_stfu
, roundtrip "shutdown" gen_shutdown
(Right . encode_shutdown) decode_shutdown
, roundtrip "closing_complete" gen_closing_complete
encode_closing_complete decode_closing_complete
, roundtrip "closing_sig" gen_closing_sig
encode_closing_sig decode_closing_sig
, roundtrip "closing_signed" gen_closing_signed
encode_closing_signed decode_closing_signed
, roundtrip "update_add_htlc" gen_update_add_htlc
encode_update_add_htlc decode_update_add_htlc
, roundtrip "update_fulfill_htlc" gen_update_fulfill_htlc
encode_update_fulfill_htlc decode_update_fulfill_htlc
, roundtrip "update_fail_htlc" gen_update_fail_htlc
encode_update_fail_htlc decode_update_fail_htlc
, roundtrip "update_fail_malformed_htlc" gen_update_fail_malformed_htlc
(Right . encode_update_fail_malformed_htlc)
decode_update_fail_malformed_htlc
, roundtrip "commitment_signed" gen_commitment_signed
encode_commitment_signed decode_commitment_signed
, roundtrip "revoke_and_ack" gen_revoke_and_ack
(Right . encode_revoke_and_ack) decode_revoke_and_ack
, roundtrip "update_fee" gen_update_fee
(Right . encode_update_fee) decode_update_fee
, roundtrip "channel_reestablish" gen_channel_reestablish
encode_channel_reestablish decode_channel_reestablish
]
, roundtrip "messages round-trip" gen_message encode_message decode_message
, testProperty "decoded messages re-encode exactly" $
withMaxSuccess 2000 $
forAll gen_message $ \m -> forAll gen_edit $ \e ->
case encode_message m of
Left err -> counterexample ("encode failed: " ++ show err) False
Right w ->
let w' = apply_edit e w
in case decode_message w' of
Left _ -> property True
Right m' -> encode_message m' === Right w'
]