diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,42 @@ # Changelog -- 0.0.1 (2025-01-25) +- 0.1.0 (2026-10-10) + * A substantial rewrite against ppad-bolt1 0.1.0, with breaking + changes throughout: + + * The API is exported from Lightning.Protocol.BOLT2 alone, and uses + snake_case names, with record fields prefixed by their message's + name (e.g. encode_open_channel, open_channel_funding_satoshis). + + * Payload decoders have type ByteString -> Either DecodeError a and + consume their whole input; encoders return Either EncodeError + ByteString only where they can fail. A Message type, with + message_type, encode_message and decode_message, handles complete + messages. + + * Every message has a TLV stream. Known TLV records are typed fields + (channel_type is a ppad-bolt9 feature vector), unknown even records + are rejected, and unknown odd records are kept, so encoding a + decoded message reproduces its bytes. + + * Amounts use ppad-bolt1's bounded Satoshi and MilliSatoshi, except + max_htlc_value_in_flight_msat. Types from ppad-bolt1 and ppad-tx + are no longer re-exported. + + * OnionPacket is renamed OnionRoutingPacket and checks its length; + ScriptPubKey and Witness are bounded at 65535 bytes; FeatureBits, + Initiator and MsgType are removed; OnionHash, AttributionData, + FeeRange and NextFunding are added. + + * Catches up with BOLT #2 as of lightning/bolts 1aadb719: + channel_reestablish's next_funding moves to TLV type 1, and + update_fulfill_htlc (fulfillment_payload), commitment_signed + (funding_txid), tx_add_input and tx_signatures gain TLV streams. + + * Fixes decoding, which accepted unknown even TLV types, didn't check + known TLV values, point prefixes or amounts, and ignored trailing + bytes on some messages; and encoding, which accepted malformed + field values. + +- 0.0.1 (2026-04-18) * Initial release. diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs new file mode 100644 --- /dev/null +++ b/bench/Fixtures.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Fixtures ( + Fixtures(..) + , fixtures + ) where + +import qualified Bitcoin.Prim.Tx as Tx +import qualified Data.ByteString as BS +import qualified Lightning.Protocol.BOLT1 as BOLT1 +import Lightning.Protocol.BOLT2 +import qualified Lightning.Protocol.BOLT9 as BOLT9 + +-- representative messages, with their encoded payloads +data Fixtures = Fixtures + { fx_open_channel :: !OpenChannel + , fx_open_channel_bytes :: !BS.ByteString + , fx_accept_channel2 :: !AcceptChannel2 + , fx_accept_channel2_bytes :: !BS.ByteString + , fx_tx_signatures :: !TxSignatures + , fx_tx_signatures_bytes :: !BS.ByteString + , fx_closing_complete :: !ClosingComplete + , fx_closing_complete_bytes :: !BS.ByteString + , fx_update_add_htlc :: !UpdateAddHtlc + , fx_update_add_htlc_bytes :: !BS.ByteString + , fx_update_add_htlc_wire :: !BS.ByteString + , fx_update_fulfill_htlc :: !UpdateFulfillHtlc + , fx_update_fulfill_htlc_bytes :: !BS.ByteString + , fx_commitment_signed :: !CommitmentSigned + , fx_commitment_signed_bytes :: !BS.ByteString + , fx_commitment_signed_483 :: !CommitmentSigned + , fx_commitment_signed_483_bytes :: !BS.ByteString + , fx_revoke_and_ack :: !RevokeAndAck + , fx_revoke_and_ack_bytes :: !BS.ByteString + , fx_channel_reestablish :: !ChannelReestablish + , fx_channel_reestablish_bytes :: !BS.ByteString + } + +ok :: Either e a -> Maybe a +ok = either (const Nothing) Just + +empty :: BOLT1.TlvStream +empty = BOLT1.empty_tlv_stream + +fixtures :: Maybe Fixtures +fixtures = do + ch <- BOLT1.chain_hash (BS.replicate 32 0x6f) + cid <- BOLT1.channel_id (BS.replicate 32 0xab) + pts <- traverse (\b -> BOLT1.point (BS.cons 0x02 (BS.replicate 32 b))) + [0x11, 0x22, 0x33, 0x44, 0x55, 0x66, 0x77] + sig <- BOLT1.signature (BS.replicate 64 0xa1) + txid <- Tx.mk_txid (BS.replicate 32 0x7e) + spk <- script_pubkey ("\x00\x14" <> BS.replicate 20 0x88) + fund <- BOLT1.satoshi 1000000 + dust <- BOLT1.satoshi 546 + res <- BOLT1.satoshi 10000 + push <- BOLT1.milli_satoshi 0 + hmin <- BOLT1.milli_satoshi 1000 + amt <- BOLT1.milli_satoshi 100000 + fee <- BOLT1.satoshi 500 + ph <- BOLT1.payment_hash (BS.replicate 32 0x9a) + pre <- BOLT1.payment_preimage (BS.replicate 32 0x50) + sec <- BOLT1.per_commitment_secret (BS.replicate 32 0x5e) + onion <- onion_routing_packet (BS.replicate 1366 0x44) + att <- attribution_data (BS.replicate 920 0x0b) + ws <- traverse witness + [ "\x02\x47" <> BS.replicate 71 0x30 <> "\x21" + <> BS.replicate 33 0x02 + , "\x01\x40" <> BS.replicate 64 0x01 ] + ext <- BOLT1.tlv_stream [BOLT1.TlvRecord 43 (BS.replicate 16 0x2a)] + (p1, p2, p3, p4, p5, p6, p7) <- case pts of + [a, b, c, d, e, f, g] -> Just (a, b, c, d, e, f, g) + _ -> Nothing + let ctype = BOLT9.channel_type_features + (BOLT9.ChannelType BOLT9.BasicAnchors False False) + + oc = OpenChannel ch cid fund push dust maxBound res hmin 253 144 483 + p1 p2 p3 p4 p5 p6 1 (Just spk) (Just ctype) empty + ac2 = AcceptChannel2 cid fund dust maxBound hmin 3 144 483 + p1 p2 p3 p4 p5 p6 p7 (Just spk) (Just ctype) True ext + txs = TxSignatures cid txid ws empty + cc = ClosingComplete cid spk spk fee 0 (Just sig) Nothing (Just sig) + empty + add = UpdateAddHtlc cid (HtlcId 42) amt ph 800000 onion (Just p1) + empty + ful = UpdateFulfillHtlc cid (HtlcId 42) pre (Just att) Nothing empty + cs0 = CommitmentSigned cid sig [] (Just txid) empty + cs483 = CommitmentSigned cid sig (replicate 483 sig) (Just txid) + empty + raa = RevokeAndAck cid sec p1 empty + rst = ChannelReestablish cid 5 4 sec p1 (Just (NextFunding txid 1)) + empty + + oc_b <- ok (encode_open_channel oc) + ac2_b <- ok (encode_accept_channel2 ac2) + txs_b <- ok (encode_tx_signatures txs) + cc_b <- ok (encode_closing_complete cc) + add_b <- ok (encode_update_add_htlc add) + add_w <- ok (encode_message (MsgUpdateAddHtlc add)) + ful_b <- ok (encode_update_fulfill_htlc ful) + cs0_b <- ok (encode_commitment_signed cs0) + cs483_b <- ok (encode_commitment_signed cs483) + rst_b <- ok (encode_channel_reestablish rst) + pure Fixtures + { fx_open_channel = oc + , fx_open_channel_bytes = oc_b + , fx_accept_channel2 = ac2 + , fx_accept_channel2_bytes = ac2_b + , fx_tx_signatures = txs + , fx_tx_signatures_bytes = txs_b + , fx_closing_complete = cc + , fx_closing_complete_bytes = cc_b + , fx_update_add_htlc = add + , fx_update_add_htlc_bytes = add_b + , fx_update_add_htlc_wire = add_w + , fx_update_fulfill_htlc = ful + , fx_update_fulfill_htlc_bytes = ful_b + , fx_commitment_signed = cs0 + , fx_commitment_signed_bytes = cs0_b + , fx_commitment_signed_483 = cs483 + , fx_commitment_signed_483_bytes = cs483_b + , fx_revoke_and_ack = raa + , fx_revoke_and_ack_bytes = encode_revoke_and_ack raa + , fx_channel_reestablish = rst + , fx_channel_reestablish_bytes = rst_b + } diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,301 +1,65 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module: Main --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Criterion timing benchmarks for BOLT #2 message codecs. - module Main where import Criterion.Main -import qualified Data.ByteString as BS -import Lightning.Protocol.BOLT1 (TlvStream, unsafeTlvStream) +import Fixtures import Lightning.Protocol.BOLT2 --- Test data construction ------------------------------------------------------ - --- | 32 zero bytes for channel IDs, chain hashes, etc. -zeroBytes32 :: BS.ByteString -zeroBytes32 = BS.replicate 32 0x00 -{-# NOINLINE zeroBytes32 #-} - --- | 33-byte compressed public key (02 prefix + 32 zero bytes). -testPoint :: Point -testPoint = case point (BS.cons 0x02 zeroBytes32) of - Just p -> p - Nothing -> error "testPoint: invalid" -{-# NOINLINE testPoint #-} - --- | 64-byte signature. -testSignature :: Signature -testSignature = case signature (BS.replicate 64 0x01) of - Just s -> s - Nothing -> error "testSignature: invalid" -{-# NOINLINE testSignature #-} - --- | 32-byte channel ID. -testChannelId :: ChannelId -testChannelId = case channelId zeroBytes32 of - Just c -> c - Nothing -> error "testChannelId: invalid" -{-# NOINLINE testChannelId #-} - --- | 32-byte chain hash. -testChainHash :: ChainHash -testChainHash = case chainHash zeroBytes32 of - Just h -> h - Nothing -> error "testChainHash: invalid" -{-# NOINLINE testChainHash #-} - --- | 32-byte txid. -testTxId :: TxId -testTxId = case txId zeroBytes32 of - Just t -> t - Nothing -> error "testTxId: invalid" -{-# NOINLINE testTxId #-} - --- | 32-byte payment hash. -testPaymentHash :: PaymentHash -testPaymentHash = case paymentHash zeroBytes32 of - Just h -> h - Nothing -> error "testPaymentHash: invalid" -{-# NOINLINE testPaymentHash #-} - --- | 1366-byte onion packet. -testOnionPacket :: OnionPacket -testOnionPacket = case onionPacket (BS.replicate 1366 0x00) of - Just o -> o - Nothing -> error "testOnionPacket: invalid" -{-# NOINLINE testOnionPacket #-} - --- | Empty TLV stream. -emptyTlvs :: TlvStream -emptyTlvs = unsafeTlvStream [] -{-# NOINLINE emptyTlvs #-} - --- V1 messages ----------------------------------------------------------------- - --- | Test OpenChannel message. -testOpenChannel :: OpenChannel -testOpenChannel = OpenChannel - { openChannelChainHash = testChainHash - , openChannelTempChannelId = testChannelId - , openChannelFundingSatoshis = Satoshis 1000000 - , openChannelPushMsat = MilliSatoshis 0 - , openChannelDustLimitSatoshis = Satoshis 546 - , openChannelMaxHtlcValueInFlight = MilliSatoshis 1000000000 - , openChannelChannelReserveSat = Satoshis 10000 - , openChannelHtlcMinimumMsat = MilliSatoshis 1000 - , openChannelFeeratePerKw = 250 - , openChannelToSelfDelay = 144 - , openChannelMaxAcceptedHtlcs = 30 - , openChannelFundingPubkey = testPoint - , openChannelRevocationBasepoint = testPoint - , openChannelPaymentBasepoint = testPoint - , openChannelDelayedPaymentBase = testPoint - , openChannelHtlcBasepoint = testPoint - , openChannelFirstPerCommitPoint = testPoint - , openChannelChannelFlags = 0x00 - , openChannelTlvs = emptyTlvs - } -{-# NOINLINE testOpenChannel #-} - --- | Encoded OpenChannel for decode benchmarks. -encodedOpenChannel :: BS.ByteString -encodedOpenChannel = encodeOpenChannel testOpenChannel -{-# NOINLINE encodedOpenChannel #-} - --- V2 messages ----------------------------------------------------------------- - --- | Test OpenChannel2 message. -testOpenChannel2 :: OpenChannel2 -testOpenChannel2 = OpenChannel2 - { openChannel2ChainHash = testChainHash - , openChannel2TempChannelId = testChannelId - , openChannel2FundingFeeratePerkw = 2500 - , openChannel2CommitFeeratePerkw = 250 - , openChannel2FundingSatoshis = Satoshis 1000000 - , openChannel2DustLimitSatoshis = Satoshis 546 - , openChannel2MaxHtlcValueInFlight = MilliSatoshis 1000000000 - , openChannel2HtlcMinimumMsat = MilliSatoshis 1000 - , openChannel2ToSelfDelay = 144 - , openChannel2MaxAcceptedHtlcs = 30 - , openChannel2Locktime = 0 - , openChannel2FundingPubkey = testPoint - , openChannel2RevocationBasepoint = testPoint - , openChannel2PaymentBasepoint = testPoint - , openChannel2DelayedPaymentBase = testPoint - , openChannel2HtlcBasepoint = testPoint - , openChannel2FirstPerCommitPoint = testPoint - , openChannel2SecondPerCommitPoint = testPoint - , openChannel2ChannelFlags = 0x00 - , openChannel2Tlvs = emptyTlvs - } -{-# NOINLINE testOpenChannel2 #-} - --- | Encoded OpenChannel2 for decode benchmarks. -encodedOpenChannel2 :: BS.ByteString -encodedOpenChannel2 = encodeOpenChannel2 testOpenChannel2 -{-# NOINLINE encodedOpenChannel2 #-} - --- | Test witness data (simulated P2WPKH signature + pubkey). -testWitness :: Witness -testWitness = Witness (BS.replicate 107 0xab) -{-# NOINLINE testWitness #-} - --- | TxSignatures with multiple witnesses. -testTxSignatures :: TxSignatures -testTxSignatures = TxSignatures - { txSignaturesChannelId = testChannelId - , txSignaturesTxid = testTxId - , txSignaturesWitnesses = replicate 5 testWitness - } -{-# NOINLINE testTxSignatures #-} - --- | Encoded TxSignatures for decode benchmarks. -encodedTxSignatures :: BS.ByteString -encodedTxSignatures = case encodeTxSignatures testTxSignatures of - Right bs -> bs - Left e -> error $ "encodedTxSignatures: " ++ show e -{-# NOINLINE encodedTxSignatures #-} - --- Close messages -------------------------------------------------------------- - --- | Test ClosingSigned message. -testClosingSigned :: ClosingSigned -testClosingSigned = ClosingSigned - { closingSignedChannelId = testChannelId - , closingSignedFeeSatoshis = Satoshis 1000 - , closingSignedSignature = testSignature - , closingSignedTlvs = emptyTlvs - } -{-# NOINLINE testClosingSigned #-} - --- | Encoded ClosingSigned for decode benchmarks. -encodedClosingSigned :: BS.ByteString -encodedClosingSigned = encodeClosingSigned testClosingSigned -{-# NOINLINE encodedClosingSigned #-} - --- Normal operation messages --------------------------------------------------- - --- | Test UpdateAddHtlc message. -testUpdateAddHtlc :: UpdateAddHtlc -testUpdateAddHtlc = UpdateAddHtlc - { updateAddHtlcChannelId = testChannelId - , updateAddHtlcId = 0 - , updateAddHtlcAmountMsat = MilliSatoshis 10000000 - , updateAddHtlcPaymentHash = testPaymentHash - , updateAddHtlcCltvExpiry = 800000 - , updateAddHtlcOnionPacket = testOnionPacket - , updateAddHtlcTlvs = emptyTlvs - } -{-# NOINLINE testUpdateAddHtlc #-} - --- | Encoded UpdateAddHtlc for decode benchmarks. -encodedUpdateAddHtlc :: BS.ByteString -encodedUpdateAddHtlc = encodeUpdateAddHtlc testUpdateAddHtlc -{-# NOINLINE encodedUpdateAddHtlc #-} - --- | Test CommitmentSigned message with HTLC signatures (10 sigs). -testCommitmentSigned :: CommitmentSigned -testCommitmentSigned = CommitmentSigned - { commitmentSignedChannelId = testChannelId - , commitmentSignedSignature = testSignature - , commitmentSignedHtlcSignatures = replicate 10 testSignature - } -{-# NOINLINE testCommitmentSigned #-} - --- | Encoded CommitmentSigned for decode benchmarks. -encodedCommitmentSigned :: BS.ByteString -encodedCommitmentSigned = case encodeCommitmentSigned testCommitmentSigned of - Right bs -> bs - Left e -> error $ "encodedCommitmentSigned: " ++ show e -{-# NOINLINE encodedCommitmentSigned #-} - --- | Test CommitmentSigned with many HTLC signatures (100 sigs). -testCommitmentSignedLarge :: CommitmentSigned -testCommitmentSignedLarge = CommitmentSigned - { commitmentSignedChannelId = testChannelId - , commitmentSignedSignature = testSignature - , commitmentSignedHtlcSignatures = replicate 100 testSignature - } -{-# NOINLINE testCommitmentSignedLarge #-} - --- | Encoded large CommitmentSigned for decode benchmarks. -encodedCommitmentSignedLarge :: BS.ByteString -encodedCommitmentSignedLarge = - case encodeCommitmentSigned testCommitmentSignedLarge of - Right bs -> bs - Left e -> error $ "encodedCommitmentSignedLarge: " ++ show e -{-# NOINLINE encodedCommitmentSignedLarge #-} - --- | Test CommitmentSigned with max HTLC signatures (483 sigs). -testCommitmentSignedMax :: CommitmentSigned -testCommitmentSignedMax = CommitmentSigned - { commitmentSignedChannelId = testChannelId - , commitmentSignedSignature = testSignature - , commitmentSignedHtlcSignatures = replicate 483 testSignature - } -{-# NOINLINE testCommitmentSignedMax #-} - --- | Encoded max CommitmentSigned for decode benchmarks. -encodedCommitmentSignedMax :: BS.ByteString -encodedCommitmentSignedMax = - case encodeCommitmentSigned testCommitmentSignedMax of - Right bs -> bs - Left e -> error $ "encodedCommitmentSignedMax: " ++ show e -{-# NOINLINE encodedCommitmentSignedMax #-} - --- Benchmark groups ------------------------------------------------------------ - main :: IO () -main = defaultMain - [ bgroup "v1" - [ bgroup "open_channel" - [ bench "encode" $ nf encodeOpenChannel testOpenChannel - , bench "decode" $ nf decodeOpenChannel encodedOpenChannel - ] +main = case fixtures of + Nothing -> fail "invalid fixtures" + Just fx -> defaultMain [ + bgroup "open_channel" [ + bench "encode" $ nf encode_open_channel (fx_open_channel fx) + , bench "decode" $ nf decode_open_channel (fx_open_channel_bytes fx) ] - , bgroup "v2" - [ bgroup "open_channel2" - [ bench "encode" $ nf encodeOpenChannel2 testOpenChannel2 - , bench "decode" $ nf decodeOpenChannel2 encodedOpenChannel2 - ] - , bgroup "tx_signatures" - [ bench "encode" $ nf encodeTxSignatures testTxSignatures - , bench "decode" $ nf decodeTxSignatures encodedTxSignatures - ] + , bgroup "accept_channel2" [ + bench "encode" $ nf encode_accept_channel2 (fx_accept_channel2 fx) + , bench "decode" $ + nf decode_accept_channel2 (fx_accept_channel2_bytes fx) ] - , bgroup "close" - [ bgroup "closing_signed" - [ bench "encode" $ nf encodeClosingSigned testClosingSigned - , bench "decode" $ nf decodeClosingSigned encodedClosingSigned - ] + , bgroup "tx_signatures" [ + bench "encode" $ nf encode_tx_signatures (fx_tx_signatures fx) + , bench "decode" $ nf decode_tx_signatures (fx_tx_signatures_bytes fx) ] - , bgroup "normal" - [ bgroup "update_add_htlc" - [ bench "encode" $ nf encodeUpdateAddHtlc testUpdateAddHtlc - , bench "decode" $ nf decodeUpdateAddHtlc encodedUpdateAddHtlc - ] - , bgroup "commitment_signed" - [ bench "encode" $ nf encodeCommitmentSigned testCommitmentSigned - , bench "decode" $ nf decodeCommitmentSigned encodedCommitmentSigned - ] - , bgroup "commitment_signed_100" - [ bench "encode" $ - nf encodeCommitmentSigned testCommitmentSignedLarge - , bench "decode" $ - nf decodeCommitmentSigned encodedCommitmentSignedLarge - ] - , bgroup "commitment_signed_483" - [ bench "encode" $ - nf encodeCommitmentSigned testCommitmentSignedMax - , bench "decode" $ - nf decodeCommitmentSigned encodedCommitmentSignedMax - ] + , bgroup "closing_complete" [ + bench "encode" $ nf encode_closing_complete (fx_closing_complete fx) + , bench "decode" $ + nf decode_closing_complete (fx_closing_complete_bytes fx) ] - ] + , bgroup "update_add_htlc" [ + bench "encode" $ nf encode_update_add_htlc (fx_update_add_htlc fx) + , bench "decode" $ + nf decode_update_add_htlc (fx_update_add_htlc_bytes fx) + , bench "encode_message" $ + nf encode_message (MsgUpdateAddHtlc (fx_update_add_htlc fx)) + , bench "decode_message" $ + nf decode_message (fx_update_add_htlc_wire fx) + ] + , bgroup "update_fulfill_htlc" [ + bench "encode" $ + nf encode_update_fulfill_htlc (fx_update_fulfill_htlc fx) + , bench "decode" $ + nf decode_update_fulfill_htlc (fx_update_fulfill_htlc_bytes fx) + ] + , bgroup "commitment_signed" [ + bench "encode (0 htlcs)" $ + nf encode_commitment_signed (fx_commitment_signed fx) + , bench "decode (0 htlcs)" $ + nf decode_commitment_signed (fx_commitment_signed_bytes fx) + , bench "encode (483 htlcs)" $ + nf encode_commitment_signed (fx_commitment_signed_483 fx) + , bench "decode (483 htlcs)" $ + nf decode_commitment_signed (fx_commitment_signed_483_bytes fx) + ] + , bgroup "revoke_and_ack" [ + bench "encode" $ nf encode_revoke_and_ack (fx_revoke_and_ack fx) + , bench "decode" $ + nf decode_revoke_and_ack (fx_revoke_and_ack_bytes fx) + ] + , bgroup "channel_reestablish" [ + bench "encode" $ + nf encode_channel_reestablish (fx_channel_reestablish fx) + , bench "decode" $ + nf decode_channel_reestablish (fx_channel_reestablish_bytes fx) + ] + ] diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -1,344 +1,49 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module: Main --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Weigh allocation benchmarks for BOLT #2 message codecs. - module Main where -import qualified Data.ByteString as BS -import Lightning.Protocol.BOLT1 (TlvStream, unsafeTlvStream) +import Fixtures import Lightning.Protocol.BOLT2 import Weigh --- | Wrapper for encoding functions that return Either. -forceEncode :: Either EncodeError BS.ByteString -> BS.ByteString -forceEncode (Right bs) = bs -forceEncode (Left e) = error $ "forceEncode: " ++ show e -{-# INLINE forceEncode #-} - --- Test data construction ------------------------------------------------------ - --- | 32 zero bytes for channel IDs, chain hashes, etc. -zeroBytes32 :: BS.ByteString -zeroBytes32 = BS.replicate 32 0x00 -{-# NOINLINE zeroBytes32 #-} - --- | 33-byte compressed public key (02 prefix + 32 zero bytes). -testPoint :: Point -testPoint = case point (BS.cons 0x02 zeroBytes32) of - Just p -> p - Nothing -> error "testPoint: invalid" -{-# NOINLINE testPoint #-} - --- | 64-byte signature. -testSignature :: Signature -testSignature = case signature (BS.replicate 64 0x01) of - Just s -> s - Nothing -> error "testSignature: invalid" -{-# NOINLINE testSignature #-} - --- | 32-byte channel ID. -testChannelId :: ChannelId -testChannelId = case channelId zeroBytes32 of - Just c -> c - Nothing -> error "testChannelId: invalid" -{-# NOINLINE testChannelId #-} - --- | 32-byte chain hash. -testChainHash :: ChainHash -testChainHash = case chainHash zeroBytes32 of - Just h -> h - Nothing -> error "testChainHash: invalid" -{-# NOINLINE testChainHash #-} - --- | 32-byte txid. -testTxId :: TxId -testTxId = case txId zeroBytes32 of - Just t -> t - Nothing -> error "testTxId: invalid" -{-# NOINLINE testTxId #-} - --- | 32-byte payment hash. -testPaymentHash :: PaymentHash -testPaymentHash = case paymentHash zeroBytes32 of - Just h -> h - Nothing -> error "testPaymentHash: invalid" -{-# NOINLINE testPaymentHash #-} - --- | 1366-byte onion packet. -testOnionPacket :: OnionPacket -testOnionPacket = case onionPacket (BS.replicate 1366 0x00) of - Just o -> o - Nothing -> error "testOnionPacket: invalid" -{-# NOINLINE testOnionPacket #-} - --- | Empty TLV stream. -emptyTlvs :: TlvStream -emptyTlvs = unsafeTlvStream [] -{-# NOINLINE emptyTlvs #-} - --- Message constructors -------------------------------------------------------- - --- | Construct OpenChannel message. -mkOpenChannel :: ChainHash -> ChannelId -> Point -> TlvStream -> OpenChannel -mkOpenChannel !ch !cid !pt !tlvs = OpenChannel - { openChannelChainHash = ch - , openChannelTempChannelId = cid - , openChannelFundingSatoshis = Satoshis 1000000 - , openChannelPushMsat = MilliSatoshis 0 - , openChannelDustLimitSatoshis = Satoshis 546 - , openChannelMaxHtlcValueInFlight = MilliSatoshis 1000000000 - , openChannelChannelReserveSat = Satoshis 10000 - , openChannelHtlcMinimumMsat = MilliSatoshis 1000 - , openChannelFeeratePerKw = 250 - , openChannelToSelfDelay = 144 - , openChannelMaxAcceptedHtlcs = 30 - , openChannelFundingPubkey = pt - , openChannelRevocationBasepoint = pt - , openChannelPaymentBasepoint = pt - , openChannelDelayedPaymentBase = pt - , openChannelHtlcBasepoint = pt - , openChannelFirstPerCommitPoint = pt - , openChannelChannelFlags = 0x00 - , openChannelTlvs = tlvs - } - --- | Construct OpenChannel2 message. -mkOpenChannel2 :: ChainHash -> ChannelId -> Point -> TlvStream -> OpenChannel2 -mkOpenChannel2 !ch !cid !pt !tlvs = OpenChannel2 - { openChannel2ChainHash = ch - , openChannel2TempChannelId = cid - , openChannel2FundingFeeratePerkw = 2500 - , openChannel2CommitFeeratePerkw = 250 - , openChannel2FundingSatoshis = Satoshis 1000000 - , openChannel2DustLimitSatoshis = Satoshis 546 - , openChannel2MaxHtlcValueInFlight = MilliSatoshis 1000000000 - , openChannel2HtlcMinimumMsat = MilliSatoshis 1000 - , openChannel2ToSelfDelay = 144 - , openChannel2MaxAcceptedHtlcs = 30 - , openChannel2Locktime = 0 - , openChannel2FundingPubkey = pt - , openChannel2RevocationBasepoint = pt - , openChannel2PaymentBasepoint = pt - , openChannel2DelayedPaymentBase = pt - , openChannel2HtlcBasepoint = pt - , openChannel2FirstPerCommitPoint = pt - , openChannel2SecondPerCommitPoint = pt - , openChannel2ChannelFlags = 0x00 - , openChannel2Tlvs = tlvs - } - --- | Construct TxSignatures message. -mkTxSignatures :: ChannelId -> TxId -> [Witness] -> TxSignatures -mkTxSignatures !cid !tid !ws = TxSignatures - { txSignaturesChannelId = cid - , txSignaturesTxid = tid - , txSignaturesWitnesses = ws - } - --- | Construct ClosingSigned message. -mkClosingSigned :: ChannelId -> Signature -> TlvStream -> ClosingSigned -mkClosingSigned !cid !sig !tlvs = ClosingSigned - { closingSignedChannelId = cid - , closingSignedFeeSatoshis = Satoshis 1000 - , closingSignedSignature = sig - , closingSignedTlvs = tlvs - } - --- | Construct UpdateAddHtlc message. -mkUpdateAddHtlc - :: ChannelId -> PaymentHash -> OnionPacket -> TlvStream -> UpdateAddHtlc -mkUpdateAddHtlc !cid !ph !onion !tlvs = UpdateAddHtlc - { updateAddHtlcChannelId = cid - , updateAddHtlcId = 0 - , updateAddHtlcAmountMsat = MilliSatoshis 10000000 - , updateAddHtlcPaymentHash = ph - , updateAddHtlcCltvExpiry = 800000 - , updateAddHtlcOnionPacket = onion - , updateAddHtlcTlvs = tlvs - } - --- | Construct CommitmentSigned message. -mkCommitmentSigned :: ChannelId -> Signature -> [Signature] -> CommitmentSigned -mkCommitmentSigned !cid !sig !htlcSigs = CommitmentSigned - { commitmentSignedChannelId = cid - , commitmentSignedSignature = sig - , commitmentSignedHtlcSignatures = htlcSigs - } - --- Pre-constructed messages ---------------------------------------------------- - --- | Test OpenChannel message. -testOpenChannel :: OpenChannel -testOpenChannel = - mkOpenChannel testChainHash testChannelId testPoint emptyTlvs -{-# NOINLINE testOpenChannel #-} - --- | Encoded OpenChannel for decode benchmarks. -encodedOpenChannel :: BS.ByteString -encodedOpenChannel = encodeOpenChannel testOpenChannel -{-# NOINLINE encodedOpenChannel #-} - --- | Test OpenChannel2 message. -testOpenChannel2 :: OpenChannel2 -testOpenChannel2 = - mkOpenChannel2 testChainHash testChannelId testPoint emptyTlvs -{-# NOINLINE testOpenChannel2 #-} - --- | Encoded OpenChannel2 for decode benchmarks. -encodedOpenChannel2 :: BS.ByteString -encodedOpenChannel2 = encodeOpenChannel2 testOpenChannel2 -{-# NOINLINE encodedOpenChannel2 #-} - --- | Test witness data. -testWitness :: Witness -testWitness = Witness (BS.replicate 107 0xab) -{-# NOINLINE testWitness #-} - --- | Multiple witnesses for TxSignatures. -testWitnesses :: [Witness] -testWitnesses = replicate 5 testWitness -{-# NOINLINE testWitnesses #-} - --- | Test TxSignatures message. -testTxSignatures :: TxSignatures -testTxSignatures = mkTxSignatures testChannelId testTxId testWitnesses -{-# NOINLINE testTxSignatures #-} - --- | Encoded TxSignatures for decode benchmarks. -encodedTxSignatures :: BS.ByteString -encodedTxSignatures = case encodeTxSignatures testTxSignatures of - Right bs -> bs - Left e -> error $ "encodedTxSignatures: " ++ show e -{-# NOINLINE encodedTxSignatures #-} - --- | Test ClosingSigned message. -testClosingSigned :: ClosingSigned -testClosingSigned = mkClosingSigned testChannelId testSignature emptyTlvs -{-# NOINLINE testClosingSigned #-} - --- | Encoded ClosingSigned for decode benchmarks. -encodedClosingSigned :: BS.ByteString -encodedClosingSigned = encodeClosingSigned testClosingSigned -{-# NOINLINE encodedClosingSigned #-} - --- | Test UpdateAddHtlc message. -testUpdateAddHtlc :: UpdateAddHtlc -testUpdateAddHtlc = - mkUpdateAddHtlc testChannelId testPaymentHash testOnionPacket emptyTlvs -{-# NOINLINE testUpdateAddHtlc #-} - --- | Encoded UpdateAddHtlc for decode benchmarks. -encodedUpdateAddHtlc :: BS.ByteString -encodedUpdateAddHtlc = encodeUpdateAddHtlc testUpdateAddHtlc -{-# NOINLINE encodedUpdateAddHtlc #-} - --- | HTLC signatures for CommitmentSigned. -testHtlcSigs :: [Signature] -testHtlcSigs = replicate 10 testSignature -{-# NOINLINE testHtlcSigs #-} - --- | Test CommitmentSigned message. -testCommitmentSigned :: CommitmentSigned -testCommitmentSigned = - mkCommitmentSigned testChannelId testSignature testHtlcSigs -{-# NOINLINE testCommitmentSigned #-} - --- | Encoded CommitmentSigned for decode benchmarks. -encodedCommitmentSigned :: BS.ByteString -encodedCommitmentSigned = case encodeCommitmentSigned testCommitmentSigned of - Right bs -> bs - Left e -> error $ "encodedCommitmentSigned: " ++ show e -{-# NOINLINE encodedCommitmentSigned #-} - --- | Large HTLC signatures for CommitmentSigned (100). -testHtlcSigsLarge :: [Signature] -testHtlcSigsLarge = replicate 100 testSignature -{-# NOINLINE testHtlcSigsLarge #-} - --- | Test CommitmentSigned message (100 sigs). -testCommitmentSignedLarge :: CommitmentSigned -testCommitmentSignedLarge = - mkCommitmentSigned testChannelId testSignature testHtlcSigsLarge -{-# NOINLINE testCommitmentSignedLarge #-} - --- | Encoded large CommitmentSigned for decode benchmarks. -encodedCommitmentSignedLarge :: BS.ByteString -encodedCommitmentSignedLarge = - case encodeCommitmentSigned testCommitmentSignedLarge of - Right bs -> bs - Left e -> error $ "encodedCommitmentSignedLarge: " ++ show e -{-# NOINLINE encodedCommitmentSignedLarge #-} - --- | Max HTLC signatures for CommitmentSigned (483). -testHtlcSigsMax :: [Signature] -testHtlcSigsMax = replicate 483 testSignature -{-# NOINLINE testHtlcSigsMax #-} - --- | Test CommitmentSigned message (483 sigs). -testCommitmentSignedMax :: CommitmentSigned -testCommitmentSignedMax = - mkCommitmentSigned testChannelId testSignature testHtlcSigsMax -{-# NOINLINE testCommitmentSignedMax #-} - --- | Encoded max CommitmentSigned for decode benchmarks. -encodedCommitmentSignedMax :: BS.ByteString -encodedCommitmentSignedMax = - case encodeCommitmentSigned testCommitmentSignedMax of - Right bs -> bs - Left e -> error $ "encodedCommitmentSignedMax: " ++ show e -{-# NOINLINE encodedCommitmentSignedMax #-} - --- Weigh benchmarks ------------------------------------------------------------ - main :: IO () -main = mainWith $ do - -- V1 message construction and encoding - wgroup "v1/open_channel" $ do - func "construct" (mkOpenChannel testChainHash testChannelId testPoint) - emptyTlvs - func "encode" encodeOpenChannel testOpenChannel - func "decode" decodeOpenChannel encodedOpenChannel - - -- V2 message construction and encoding - wgroup "v2/open_channel2" $ do - func "construct" (mkOpenChannel2 testChainHash testChannelId testPoint) - emptyTlvs - func "encode" encodeOpenChannel2 testOpenChannel2 - func "decode" decodeOpenChannel2 encodedOpenChannel2 - - wgroup "v2/tx_signatures" $ do - func "construct" (mkTxSignatures testChannelId testTxId) testWitnesses - func "encode" (forceEncode . encodeTxSignatures) testTxSignatures - func "decode" decodeTxSignatures encodedTxSignatures - - -- Close messages - wgroup "close/closing_signed" $ do - func "construct" (mkClosingSigned testChannelId testSignature) emptyTlvs - func "encode" encodeClosingSigned testClosingSigned - func "decode" decodeClosingSigned encodedClosingSigned - - -- Normal operation (hot paths) - wgroup "normal/update_add_htlc" $ do - func "construct" - (mkUpdateAddHtlc testChannelId testPaymentHash testOnionPacket) emptyTlvs - func "encode" encodeUpdateAddHtlc testUpdateAddHtlc - func "decode" decodeUpdateAddHtlc encodedUpdateAddHtlc - - wgroup "normal/commitment_signed" $ do - func "construct" (mkCommitmentSigned testChannelId testSignature) - testHtlcSigs - func "encode" (forceEncode . encodeCommitmentSigned) testCommitmentSigned - func "decode" decodeCommitmentSigned encodedCommitmentSigned - - wgroup "normal/commitment_signed_100" $ do - func "decode" decodeCommitmentSigned encodedCommitmentSignedLarge - - wgroup "normal/commitment_signed_483" $ do - func "decode" decodeCommitmentSigned encodedCommitmentSignedMax +main = case fixtures of + Nothing -> fail "invalid fixtures" + Just fx -> mainWith $ do + func "baseline (weigh overhead)" (+ (1 :: Int)) 1 + wgroup "open_channel" $ do + func "encode" encode_open_channel (fx_open_channel fx) + func "decode" decode_open_channel (fx_open_channel_bytes fx) + wgroup "accept_channel2" $ do + func "encode" encode_accept_channel2 (fx_accept_channel2 fx) + func "decode" decode_accept_channel2 (fx_accept_channel2_bytes fx) + wgroup "tx_signatures" $ do + func "encode" encode_tx_signatures (fx_tx_signatures fx) + func "decode" decode_tx_signatures (fx_tx_signatures_bytes fx) + wgroup "closing_complete" $ do + func "encode" encode_closing_complete (fx_closing_complete fx) + func "decode" decode_closing_complete (fx_closing_complete_bytes fx) + wgroup "update_add_htlc" $ do + func "encode" encode_update_add_htlc (fx_update_add_htlc fx) + func "decode" decode_update_add_htlc (fx_update_add_htlc_bytes fx) + func "encode_message" encode_message + (MsgUpdateAddHtlc (fx_update_add_htlc fx)) + func "decode_message" decode_message (fx_update_add_htlc_wire fx) + wgroup "update_fulfill_htlc" $ do + func "encode" encode_update_fulfill_htlc (fx_update_fulfill_htlc fx) + func "decode" decode_update_fulfill_htlc + (fx_update_fulfill_htlc_bytes fx) + wgroup "commitment_signed" $ do + func "encode (0 htlcs)" encode_commitment_signed + (fx_commitment_signed fx) + func "decode (0 htlcs)" decode_commitment_signed + (fx_commitment_signed_bytes fx) + func "encode (483 htlcs)" encode_commitment_signed + (fx_commitment_signed_483 fx) + func "decode (483 htlcs)" decode_commitment_signed + (fx_commitment_signed_483_bytes fx) + wgroup "revoke_and_ack" $ do + func "encode" encode_revoke_and_ack (fx_revoke_and_ack fx) + func "decode" decode_revoke_and_ack (fx_revoke_and_ack_bytes fx) + wgroup "channel_reestablish" $ do + func "encode" encode_channel_reestablish (fx_channel_reestablish fx) + func "decode" decode_channel_reestablish + (fx_channel_reestablish_bytes fx) diff --git a/lib/Lightning/Protocol/BOLT2.hs b/lib/Lightning/Protocol/BOLT2.hs --- a/lib/Lightning/Protocol/BOLT2.hs +++ b/lib/Lightning/Protocol/BOLT2.hs @@ -6,128 +6,187 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- Peer protocol for the Lightning Network, per --- [BOLT #2](https://github.com/lightning/bolts/blob/master/02-peer-protocol.md). +-- The peer protocol of the Lightning Network, per +-- [BOLT #2](https://github.com/lightning/bolts/blob/master/02-peer-protocol.md): +-- the messages for channel establishment (v1 and v2), interactive +-- transaction construction, quiescence, channel close, normal operation +-- and message retransmission. +-- +-- Fundamental types (channel ids, points, signatures, amounts, TLV +-- streams) come from ppad-bolt1, transaction ids from ppad-tx, and +-- feature vectors from ppad-bolt9. +-- +-- Each message has a payload codec, @encode_\@ and +-- @decode_\@; 'encode_message' and 'decode_message' handle +-- complete messages, including the type. Decoders consume the whole +-- payload: bytes after the fixed fields are the message's TLV stream. +-- Known TLV records are decoded into typed fields, an unknown even +-- record fails the decode, and unknown odd records are kept in the +-- message's @_tlvs@ field, so re-encoding a decoded message reproduces +-- its bytes. +-- +-- The examples below assume: +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.ByteString as BS +-- >>> import qualified Lightning.Protocol.BOLT1 as BOLT1 +-- >>> import Lightning.Protocol.BOLT2 +-- >>> let Just cid = BOLT1.channel_id (BS.replicate 32 0xab) +-- +-- Encode a message, and decode it again: +-- +-- >>> let fee = UpdateFee cid 2500 BOLT1.empty_tlv_stream +-- >>> let Right wire = encode_message (MsgUpdateFee fee) +-- >>> BS.length wire +-- 38 +-- >>> decode_message wire == Right (MsgUpdateFee fee) +-- True +-- +-- Unknown odd TLV records are preserved, and unknown even ones +-- rejected: +-- +-- >>> let payload = encode_update_fee fee +-- >>> fmap update_fee_tlvs (decode_update_fee (payload <> "\x05\x01\x2a")) +-- Right (TlvStream [TlvRecord {tlv_type = 5, tlv_value = "*"}]) +-- >>> decode_update_fee (payload <> "\x04\x01\x2a") +-- Left (DecodeTlvError (TlvUnknownEvenType 4)) module Lightning.Protocol.BOLT2 ( - -- * Core types - -- | Re-exported from "Lightning.Protocol.BOLT2.Types". - module Lightning.Protocol.BOLT2.Types - - -- * Message types - -- | Re-exported from "Lightning.Protocol.BOLT2.Messages". - , module Lightning.Protocol.BOLT2.Messages + -- * Messages + Message(..) + , message_type - -- * Codec functions - -- | Re-exported from "Lightning.Protocol.BOLT2.Codec". - , module Lightning.Protocol.BOLT2.Codec + -- ** Channel establishment v1 + , OpenChannel(..) + , AcceptChannel(..) + , FundingCreated(..) + , FundingSigned(..) + , ChannelReady(..) - -- $messagetypes + -- ** Channel establishment v2 + , OpenChannel2(..) + , AcceptChannel2(..) - -- ** Channel establishment (v1) - -- $v1establishment + -- ** Interactive transaction construction + , TxAddInput(..) + , TxAddOutput(..) + , TxRemoveInput(..) + , TxRemoveOutput(..) + , TxComplete(..) + , TxSignatures(..) + , TxInitRbf(..) + , TxAckRbf(..) + , TxAbort(..) - -- ** Channel establishment (v2) - -- $v2establishment + -- ** Channel quiescence + , Stfu(..) -- ** Channel close - -- $close + , Shutdown(..) + , ClosingComplete(..) + , ClosingSig(..) + , ClosingSigned(..) -- ** Normal operation - -- $normal + , UpdateAddHtlc(..) + , UpdateFulfillHtlc(..) + , UpdateFailHtlc(..) + , UpdateFailMalformedHtlc(..) + , CommitmentSigned(..) + , RevokeAndAck(..) + , UpdateFee(..) - -- ** Message reestablishment - -- $reestablish + -- ** Message retransmission + , ChannelReestablish(..) + + -- * Field types + , HtlcId(..) + , SerialId(..) + , ScriptPubKey + , script_pubkey + , un_script_pubkey + , Witness + , witness + , un_witness + , OnionRoutingPacket + , onion_routing_packet + , un_onion_routing_packet + , OnionHash + , onion_hash + , un_onion_hash + , AttributionData + , attribution_data + , un_attribution_data + , FeeRange(..) + , NextFunding(..) + + -- * Encoding and decoding messages + , encode_message + , decode_message + , EncodeError(..) + , DecodeError(..) + + -- ** Payloads + , encode_open_channel + , decode_open_channel + , encode_accept_channel + , decode_accept_channel + , encode_funding_created + , decode_funding_created + , encode_funding_signed + , decode_funding_signed + , encode_channel_ready + , decode_channel_ready + , encode_open_channel2 + , decode_open_channel2 + , encode_accept_channel2 + , decode_accept_channel2 + , encode_tx_add_input + , decode_tx_add_input + , encode_tx_add_output + , decode_tx_add_output + , encode_tx_remove_input + , decode_tx_remove_input + , encode_tx_remove_output + , decode_tx_remove_output + , encode_tx_complete + , decode_tx_complete + , encode_tx_signatures + , decode_tx_signatures + , encode_tx_init_rbf + , decode_tx_init_rbf + , encode_tx_ack_rbf + , decode_tx_ack_rbf + , encode_tx_abort + , decode_tx_abort + , encode_stfu + , decode_stfu + , encode_shutdown + , decode_shutdown + , encode_closing_complete + , decode_closing_complete + , encode_closing_sig + , decode_closing_sig + , encode_closing_signed + , decode_closing_signed + , encode_update_add_htlc + , decode_update_add_htlc + , encode_update_fulfill_htlc + , decode_update_fulfill_htlc + , encode_update_fail_htlc + , decode_update_fail_htlc + , encode_update_fail_malformed_htlc + , decode_update_fail_malformed_htlc + , encode_commitment_signed + , decode_commitment_signed + , encode_revoke_and_ack + , decode_revoke_and_ack + , encode_update_fee + , decode_update_fee + , encode_channel_reestablish + , decode_channel_reestablish ) where import Lightning.Protocol.BOLT2.Codec import Lightning.Protocol.BOLT2.Messages import Lightning.Protocol.BOLT2.Types - --- $messagetypes --- --- BOLT #2 defines the following message types: --- --- * 2: stfu --- * 32: open_channel --- * 33: accept_channel --- * 34: funding_created --- * 35: funding_signed --- * 36: channel_ready --- * 38: shutdown --- * 39: closing_signed --- * 40: closing_complete --- * 41: closing_sig --- * 64: open_channel2 --- * 65: accept_channel2 --- * 66: tx_add_input --- * 67: tx_add_output --- * 68: tx_remove_input --- * 69: tx_remove_output --- * 70: tx_complete --- * 71: tx_signatures --- * 72: tx_init_rbf --- * 73: tx_ack_rbf --- * 74: tx_abort --- * 128: update_add_htlc --- * 130: update_fulfill_htlc --- * 131: update_fail_htlc --- * 132: commitment_signed --- * 133: revoke_and_ack --- * 134: update_fee --- * 135: update_fail_malformed_htlc --- * 136: channel_reestablish - --- $v1establishment --- --- Channel establishment v1 messages: --- --- * open_channel (32) --- * accept_channel (33) --- * funding_created (34) --- * funding_signed (35) --- * channel_ready (36) - --- $v2establishment --- --- Channel establishment v2 (interactive-tx) messages: --- --- * open_channel2 (64) --- * accept_channel2 (65) --- * tx_add_input (66) --- * tx_add_output (67) --- * tx_remove_input (68) --- * tx_remove_output (69) --- * tx_complete (70) --- * tx_signatures (71) --- * tx_init_rbf (72) --- * tx_ack_rbf (73) --- * tx_abort (74) - --- $close --- --- Channel close messages: --- --- * stfu (2) --- * shutdown (38) --- * closing_signed (39) --- * closing_complete (40) --- * closing_sig (41) - --- $normal --- --- Normal operation messages: --- --- * update_add_htlc (128) --- * update_fulfill_htlc (130) --- * update_fail_htlc (131) --- * commitment_signed (132) --- * revoke_and_ack (133) --- * update_fee (134) --- * update_fail_malformed_htlc (135) - --- $reestablish --- --- Message reestablishment: --- --- * channel_reestablish (136) diff --git a/lib/Lightning/Protocol/BOLT2/Codec.hs b/lib/Lightning/Protocol/BOLT2/Codec.hs --- a/lib/Lightning/Protocol/BOLT2/Codec.hs +++ b/lib/Lightning/Protocol/BOLT2/Codec.hs @@ -1,1347 +1,1388 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - --- | --- Module: Lightning.Protocol.BOLT2.Codec --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Encode/decode functions for BOLT #2 messages. - -module Lightning.Protocol.BOLT2.Codec ( - -- * Error types - EncodeError(..) - , DecodeError(..) - - -- * Channel establishment v1 - , encodeOpenChannel - , decodeOpenChannel - , encodeAcceptChannel - , decodeAcceptChannel - , encodeFundingCreated - , decodeFundingCreated - , encodeFundingSigned - , decodeFundingSigned - , encodeChannelReady - , decodeChannelReady - - -- * Channel establishment v2 (interactive-tx) - , encodeOpenChannel2 - , decodeOpenChannel2 - , encodeAcceptChannel2 - , decodeAcceptChannel2 - , encodeTxAddInput - , decodeTxAddInput - , encodeTxAddOutput - , decodeTxAddOutput - , encodeTxRemoveInput - , decodeTxRemoveInput - , encodeTxRemoveOutput - , decodeTxRemoveOutput - , encodeTxComplete - , decodeTxComplete - , encodeTxSignatures - , decodeTxSignatures - , encodeTxInitRbf - , decodeTxInitRbf - , encodeTxAckRbf - , decodeTxAckRbf - , encodeTxAbort - , decodeTxAbort - - -- * Channel close - , encodeStfu - , decodeStfu - , encodeShutdown - , decodeShutdown - , encodeClosingSigned - , decodeClosingSigned - , encodeClosingComplete - , decodeClosingComplete - , encodeClosingSig - , decodeClosingSig - - -- * Normal operation - , encodeUpdateAddHtlc - , decodeUpdateAddHtlc - , encodeUpdateFulfillHtlc - , decodeUpdateFulfillHtlc - , encodeUpdateFailHtlc - , decodeUpdateFailHtlc - , encodeUpdateFailMalformedHtlc - , decodeUpdateFailMalformedHtlc - , encodeCommitmentSigned - , decodeCommitmentSigned - , encodeRevokeAndAck - , decodeRevokeAndAck - , encodeUpdateFee - , decodeUpdateFee - - -- * Channel reestablishment - , encodeChannelReestablish - , decodeChannelReestablish - ) where - -import Control.DeepSeq (NFData) -import Control.Monad (unless) -import qualified Data.ByteString as BS -import Data.Word (Word8, Word16, Word32) -import GHC.Generics (Generic) -import Lightning.Protocol.BOLT1 - ( TlvStream - , unsafeTlvStream - , TlvError - , encodeU16 - , encodeU32 - , encodeU64 - , decodeU16 - , decodeU32 - , decodeU64 - , encodeTlvStream - , decodeTlvStreamRaw - ) -import Lightning.Protocol.BOLT2.Types -import Lightning.Protocol.BOLT2.Messages - --- Error types ----------------------------------------------------------------- - --- | Encoding errors. -data EncodeError - = EncodeLengthOverflow -- ^ Payload exceeds u16 max (65535 bytes) - deriving stock (Eq, Show, Generic) - -instance NFData EncodeError - --- | Decoding errors. -data DecodeError - = DecodeInsufficientBytes - | DecodeInvalidLength - | DecodeInvalidChannelId - | DecodeInvalidChainHash - | DecodeInvalidSignature - | DecodeInvalidPoint - | DecodeInvalidTxId - | DecodeInvalidPaymentHash - | DecodeInvalidPaymentPreimage - | DecodeInvalidOnionPacket - | DecodeInvalidSecret - | DecodeTlvError !TlvError - deriving stock (Eq, Show, Generic) - -instance NFData DecodeError - --- Helpers --------------------------------------------------------------------- - --- | Decode a single byte. -decodeU8 :: BS.ByteString -> Maybe (Word8, BS.ByteString) -decodeU8 !bs - | BS.null bs = Nothing - | otherwise = Just (BS.index bs 0, BS.drop 1 bs) -{-# INLINE decodeU8 #-} - --- | Decode fixed-size bytes. -decodeBytes :: Int -> BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) -decodeBytes !n !bs - | BS.length bs < n = Nothing - | otherwise = Just (BS.take n bs, BS.drop n bs) -{-# INLINE decodeBytes #-} - --- | Decode a ChannelId (32 bytes). -decodeChannelIdBytes - :: BS.ByteString -> Either DecodeError (ChannelId, BS.ByteString) -decodeChannelIdBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes channelIdLen bs) - cid <- maybe (Left DecodeInvalidChannelId) Right (channelId raw) - Right (cid, rest) -{-# INLINE decodeChannelIdBytes #-} - --- | Decode a ChainHash (32 bytes). -decodeChainHashBytes - :: BS.ByteString -> Either DecodeError (ChainHash, BS.ByteString) -decodeChainHashBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes chainHashLen bs) - ch <- maybe (Left DecodeInvalidChainHash) Right (chainHash raw) - Right (ch, rest) -{-# INLINE decodeChainHashBytes #-} - --- | Decode a Signature (64 bytes). -decodeSignatureBytes - :: BS.ByteString -> Either DecodeError (Signature, BS.ByteString) -decodeSignatureBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes signatureLen bs) - sig <- maybe (Left DecodeInvalidSignature) Right (signature raw) - Right (sig, rest) -{-# INLINE decodeSignatureBytes #-} - --- | Decode a Point (33 bytes). -decodePointBytes - :: BS.ByteString -> Either DecodeError (Point, BS.ByteString) -decodePointBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes pointLen bs) - pt <- maybe (Left DecodeInvalidPoint) Right (point raw) - Right (pt, rest) -{-# INLINE decodePointBytes #-} - --- | Decode a TxId (32 bytes). -decodeTxIdBytes - :: BS.ByteString -> Either DecodeError (TxId, BS.ByteString) -decodeTxIdBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes txIdLen bs) - tid <- maybe (Left DecodeInvalidTxId) Right (txId raw) - Right (tid, rest) -{-# INLINE decodeTxIdBytes #-} - --- | Decode a u16 with error handling. -decodeU16E :: BS.ByteString -> Either DecodeError (Word16, BS.ByteString) -decodeU16E !bs = maybe (Left DecodeInsufficientBytes) Right (decodeU16 bs) -{-# INLINE decodeU16E #-} - --- | Decode a u32 with error handling. -decodeU32E :: BS.ByteString -> Either DecodeError (Word32, BS.ByteString) -decodeU32E !bs = maybe (Left DecodeInsufficientBytes) Right (decodeU32 bs) -{-# INLINE decodeU32E #-} - --- | Decode a u64 as Satoshis. -decodeSatoshis - :: BS.ByteString -> Either DecodeError (Satoshis, BS.ByteString) -decodeSatoshis !bs = do - (val, rest) <- maybe (Left DecodeInsufficientBytes) Right (decodeU64 bs) - Right (Satoshis val, rest) -{-# INLINE decodeSatoshis #-} - --- | Decode a u64 as MilliSatoshis. -decodeMilliSatoshis - :: BS.ByteString -> Either DecodeError (MilliSatoshis, BS.ByteString) -decodeMilliSatoshis !bs = do - (val, rest) <- maybe (Left DecodeInsufficientBytes) Right (decodeU64 bs) - Right (MilliSatoshis val, rest) -{-# INLINE decodeMilliSatoshis #-} - --- | Decode optional TLV stream from remaining bytes. -decodeTlvs :: BS.ByteString -> Either DecodeError TlvStream -decodeTlvs !bs - | BS.null bs = Right (unsafeTlvStream []) - | otherwise = either (Left . DecodeTlvError) Right (decodeTlvStreamRaw bs) -{-# INLINE decodeTlvs #-} - --- | Decode a length-prefixed script (u16 length prefix). -decodeScriptPubKey - :: BS.ByteString -> Either DecodeError (ScriptPubKey, BS.ByteString) -decodeScriptPubKey !bs = do - (len, rest1) <- decodeU16E bs - let !scriptLen = fromIntegral len - unless (BS.length rest1 >= scriptLen) $ Left DecodeInsufficientBytes - let !script = BS.take scriptLen rest1 - !rest2 = BS.drop scriptLen rest1 - Right (scriptPubKey script, rest2) -{-# INLINE decodeScriptPubKey #-} - --- | Decode a PaymentHash (32 bytes). -decodePaymentHashBytes - :: BS.ByteString -> Either DecodeError (PaymentHash, BS.ByteString) -decodePaymentHashBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes paymentHashLen bs) - ph <- maybe (Left DecodeInvalidPaymentHash) Right (paymentHash raw) - Right (ph, rest) -{-# INLINE decodePaymentHashBytes #-} - --- | Decode a PaymentPreimage (32 bytes). -decodePaymentPreimageBytes - :: BS.ByteString -> Either DecodeError (PaymentPreimage, BS.ByteString) -decodePaymentPreimageBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes paymentPreimageLen bs) - pp <- maybe (Left DecodeInvalidPaymentPreimage) Right (paymentPreimage raw) - Right (pp, rest) -{-# INLINE decodePaymentPreimageBytes #-} - --- | Decode an OnionPacket (1366 bytes). -decodeOnionPacketBytes - :: BS.ByteString -> Either DecodeError (OnionPacket, BS.ByteString) -decodeOnionPacketBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes onionPacketLen bs) - op <- maybe (Left DecodeInvalidOnionPacket) Right (onionPacket raw) - Right (op, rest) -{-# INLINE decodeOnionPacketBytes #-} - --- | Decode a Secret (32 bytes). -decodeSecretBytes - :: BS.ByteString -> Either DecodeError (Secret, BS.ByteString) -decodeSecretBytes !bs = do - (raw, rest) <- maybe (Left DecodeInsufficientBytes) Right - (decodeBytes secretLen bs) - sec <- maybe (Left DecodeInvalidSecret) Right (secret raw) - Right (sec, rest) -{-# INLINE decodeSecretBytes #-} - --- | Encode a u16-prefixed byte string with bounds checking. -encodeU16BytesE :: BS.ByteString -> Either EncodeError BS.ByteString -encodeU16BytesE !bs - | BS.length bs > 65535 = Left EncodeLengthOverflow - | otherwise = Right $! encodeU16 (fromIntegral (BS.length bs)) <> bs -{-# INLINE encodeU16BytesE #-} - --- | Check that a list count fits in u16. -checkListCountU16 :: Int -> Either EncodeError Word16 -checkListCountU16 !n - | n > 65535 = Left EncodeLengthOverflow - | otherwise = Right $! fromIntegral n -{-# INLINE checkListCountU16 #-} - --- | Decode a u16-prefixed byte string. -decodeU16Bytes - :: BS.ByteString -> Either DecodeError (BS.ByteString, BS.ByteString) -decodeU16Bytes !bs = do - (len, rest1) <- decodeU16E bs - let !n = fromIntegral len - unless (BS.length rest1 >= n) $ Left DecodeInsufficientBytes - Right (BS.take n rest1, BS.drop n rest1) -{-# INLINE decodeU16Bytes #-} - --- | Decode optional trailing TLV stream. -decodeOptionalTlvs - :: BS.ByteString -> Either DecodeError (TlvStream, BS.ByteString) -decodeOptionalTlvs !bs - | BS.null bs = Right (unsafeTlvStream [], BS.empty) - | otherwise = case decodeTlvStreamRaw bs of - Left e -> Left (DecodeTlvError e) - Right t -> Right (t, BS.empty) -{-# INLINE decodeOptionalTlvs #-} - --- Channel establishment v1 ---------------------------------------------------- - --- | Encode an OpenChannel message (type 32). --- --- Wire format: --- - chain_hash: 32 bytes --- - temporary_channel_id: 32 bytes --- - funding_satoshis: u64 --- - push_msat: u64 --- - dust_limit_satoshis: u64 --- - max_htlc_value_in_flight_msat: u64 --- - channel_reserve_satoshis: u64 --- - htlc_minimum_msat: u64 --- - feerate_per_kw: u32 --- - to_self_delay: u16 --- - max_accepted_htlcs: u16 --- - funding_pubkey: 33 bytes --- - revocation_basepoint: 33 bytes --- - payment_basepoint: 33 bytes --- - delayed_payment_basepoint: 33 bytes --- - htlc_basepoint: 33 bytes --- - first_per_commitment_point: 33 bytes --- - channel_flags: 1 byte --- - tlvs: TLV stream -encodeOpenChannel :: OpenChannel -> BS.ByteString -encodeOpenChannel !msg = mconcat - [ unChainHash (openChannelChainHash msg) - , unChannelId (openChannelTempChannelId msg) - , encodeU64 (unSatoshis (openChannelFundingSatoshis msg)) - , encodeU64 (unMilliSatoshis (openChannelPushMsat msg)) - , encodeU64 (unSatoshis (openChannelDustLimitSatoshis msg)) - , encodeU64 (unMilliSatoshis (openChannelMaxHtlcValueInFlight msg)) - , encodeU64 (unSatoshis (openChannelChannelReserveSat msg)) - , encodeU64 (unMilliSatoshis (openChannelHtlcMinimumMsat msg)) - , encodeU32 (openChannelFeeratePerKw msg) - , encodeU16 (openChannelToSelfDelay msg) - , encodeU16 (openChannelMaxAcceptedHtlcs msg) - , unPoint (openChannelFundingPubkey msg) - , unPoint (openChannelRevocationBasepoint msg) - , unPoint (openChannelPaymentBasepoint msg) - , unPoint (openChannelDelayedPaymentBase msg) - , unPoint (openChannelHtlcBasepoint msg) - , unPoint (openChannelFirstPerCommitPoint msg) - , BS.singleton (openChannelChannelFlags msg) - , encodeTlvStream (openChannelTlvs msg) - ] - --- | Decode an OpenChannel message (type 32). -decodeOpenChannel - :: BS.ByteString -> Either DecodeError (OpenChannel, BS.ByteString) -decodeOpenChannel !bs = do - (chainHash', rest1) <- decodeChainHashBytes bs - (tempChanId, rest2) <- decodeChannelIdBytes rest1 - (fundingSats, rest3) <- decodeSatoshis rest2 - (pushMsat, rest4) <- decodeMilliSatoshis rest3 - (dustLimit, rest5) <- decodeSatoshis rest4 - (maxHtlcVal, rest6) <- decodeMilliSatoshis rest5 - (chanReserve, rest7) <- decodeSatoshis rest6 - (htlcMin, rest8) <- decodeMilliSatoshis rest7 - (feerate, rest9) <- decodeU32E rest8 - (toSelfDelay, rest10) <- decodeU16E rest9 - (maxHtlcs, rest11) <- decodeU16E rest10 - (fundingPk, rest12) <- decodePointBytes rest11 - (revocBase, rest13) <- decodePointBytes rest12 - (paymentBase, rest14) <- decodePointBytes rest13 - (delayedBase, rest15) <- decodePointBytes rest14 - (htlcBase, rest16) <- decodePointBytes rest15 - (firstCommit, rest17) <- decodePointBytes rest16 - (flags, rest18) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU8 rest17) - tlvs <- decodeTlvs rest18 - let !msg = OpenChannel - { openChannelChainHash = chainHash' - , openChannelTempChannelId = tempChanId - , openChannelFundingSatoshis = fundingSats - , openChannelPushMsat = pushMsat - , openChannelDustLimitSatoshis = dustLimit - , openChannelMaxHtlcValueInFlight = maxHtlcVal - , openChannelChannelReserveSat = chanReserve - , openChannelHtlcMinimumMsat = htlcMin - , openChannelFeeratePerKw = feerate - , openChannelToSelfDelay = toSelfDelay - , openChannelMaxAcceptedHtlcs = maxHtlcs - , openChannelFundingPubkey = fundingPk - , openChannelRevocationBasepoint = revocBase - , openChannelPaymentBasepoint = paymentBase - , openChannelDelayedPaymentBase = delayedBase - , openChannelHtlcBasepoint = htlcBase - , openChannelFirstPerCommitPoint = firstCommit - , openChannelChannelFlags = flags - , openChannelTlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode an AcceptChannel message (type 33). --- --- Wire format: --- - temporary_channel_id: 32 bytes --- - dust_limit_satoshis: u64 --- - max_htlc_value_in_flight_msat: u64 --- - channel_reserve_satoshis: u64 --- - htlc_minimum_msat: u64 --- - minimum_depth: u32 --- - to_self_delay: u16 --- - max_accepted_htlcs: u16 --- - funding_pubkey: 33 bytes --- - revocation_basepoint: 33 bytes --- - payment_basepoint: 33 bytes --- - delayed_payment_basepoint: 33 bytes --- - htlc_basepoint: 33 bytes --- - first_per_commitment_point: 33 bytes --- - tlvs: TLV stream -encodeAcceptChannel :: AcceptChannel -> BS.ByteString -encodeAcceptChannel !msg = mconcat - [ unChannelId (acceptChannelTempChannelId msg) - , encodeU64 (unSatoshis (acceptChannelDustLimitSatoshis msg)) - , encodeU64 (unMilliSatoshis (acceptChannelMaxHtlcValueInFlight msg)) - , encodeU64 (unSatoshis (acceptChannelChannelReserveSat msg)) - , encodeU64 (unMilliSatoshis (acceptChannelHtlcMinimumMsat msg)) - , encodeU32 (acceptChannelMinimumDepth msg) - , encodeU16 (acceptChannelToSelfDelay msg) - , encodeU16 (acceptChannelMaxAcceptedHtlcs msg) - , unPoint (acceptChannelFundingPubkey msg) - , unPoint (acceptChannelRevocationBasepoint msg) - , unPoint (acceptChannelPaymentBasepoint msg) - , unPoint (acceptChannelDelayedPaymentBase msg) - , unPoint (acceptChannelHtlcBasepoint msg) - , unPoint (acceptChannelFirstPerCommitPoint msg) - , encodeTlvStream (acceptChannelTlvs msg) - ] - --- | Decode an AcceptChannel message (type 33). -decodeAcceptChannel - :: BS.ByteString -> Either DecodeError (AcceptChannel, BS.ByteString) -decodeAcceptChannel !bs = do - (tempChanId, rest1) <- decodeChannelIdBytes bs - (dustLimit, rest2) <- decodeSatoshis rest1 - (maxHtlcVal, rest3) <- decodeMilliSatoshis rest2 - (chanReserve, rest4) <- decodeSatoshis rest3 - (htlcMin, rest5) <- decodeMilliSatoshis rest4 - (minDepth, rest6) <- decodeU32E rest5 - (toSelfDelay, rest7) <- decodeU16E rest6 - (maxHtlcs, rest8) <- decodeU16E rest7 - (fundingPk, rest9) <- decodePointBytes rest8 - (revocBase, rest10) <- decodePointBytes rest9 - (paymentBase, rest11) <- decodePointBytes rest10 - (delayedBase, rest12) <- decodePointBytes rest11 - (htlcBase, rest13) <- decodePointBytes rest12 - (firstCommit, rest14) <- decodePointBytes rest13 - tlvs <- decodeTlvs rest14 - let !msg = AcceptChannel - { acceptChannelTempChannelId = tempChanId - , acceptChannelDustLimitSatoshis = dustLimit - , acceptChannelMaxHtlcValueInFlight = maxHtlcVal - , acceptChannelChannelReserveSat = chanReserve - , acceptChannelHtlcMinimumMsat = htlcMin - , acceptChannelMinimumDepth = minDepth - , acceptChannelToSelfDelay = toSelfDelay - , acceptChannelMaxAcceptedHtlcs = maxHtlcs - , acceptChannelFundingPubkey = fundingPk - , acceptChannelRevocationBasepoint = revocBase - , acceptChannelPaymentBasepoint = paymentBase - , acceptChannelDelayedPaymentBase = delayedBase - , acceptChannelHtlcBasepoint = htlcBase - , acceptChannelFirstPerCommitPoint = firstCommit - , acceptChannelTlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode a FundingCreated message (type 34). --- --- Wire format: --- - temporary_channel_id: 32 bytes --- - funding_txid: 32 bytes --- - funding_output_index: u16 --- - signature: 64 bytes -encodeFundingCreated :: FundingCreated -> BS.ByteString -encodeFundingCreated !msg = mconcat - [ unChannelId (fundingCreatedTempChannelId msg) - , unTxId (fundingCreatedFundingTxid msg) - , encodeU16 (fundingCreatedFundingOutIdx msg) - , unSignature (fundingCreatedSignature msg) - ] - --- | Decode a FundingCreated message (type 34). -decodeFundingCreated - :: BS.ByteString -> Either DecodeError (FundingCreated, BS.ByteString) -decodeFundingCreated !bs = do - (tempChanId, rest1) <- decodeChannelIdBytes bs - (fundingTxid, rest2) <- decodeTxIdBytes rest1 - (outIdx, rest3) <- decodeU16E rest2 - (sig, rest4) <- decodeSignatureBytes rest3 - let !msg = FundingCreated - { fundingCreatedTempChannelId = tempChanId - , fundingCreatedFundingTxid = fundingTxid - , fundingCreatedFundingOutIdx = outIdx - , fundingCreatedSignature = sig - } - Right (msg, rest4) - --- | Encode a FundingSigned message (type 35). --- --- Wire format: --- - channel_id: 32 bytes --- - signature: 64 bytes -encodeFundingSigned :: FundingSigned -> BS.ByteString -encodeFundingSigned !msg = mconcat - [ unChannelId (fundingSignedChannelId msg) - , unSignature (fundingSignedSignature msg) - ] - --- | Decode a FundingSigned message (type 35). -decodeFundingSigned - :: BS.ByteString -> Either DecodeError (FundingSigned, BS.ByteString) -decodeFundingSigned !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (sig, rest2) <- decodeSignatureBytes rest1 - let !msg = FundingSigned - { fundingSignedChannelId = chanId - , fundingSignedSignature = sig - } - Right (msg, rest2) - --- | Encode a ChannelReady message (type 36). --- --- Wire format: --- - channel_id: 32 bytes --- - second_per_commitment_point: 33 bytes --- - tlvs: TLV stream -encodeChannelReady :: ChannelReady -> BS.ByteString -encodeChannelReady !msg = mconcat - [ unChannelId (channelReadyChannelId msg) - , unPoint (channelReadySecondPerCommitPoint msg) - , encodeTlvStream (channelReadyTlvs msg) - ] - --- | Decode a ChannelReady message (type 36). -decodeChannelReady - :: BS.ByteString -> Either DecodeError (ChannelReady, BS.ByteString) -decodeChannelReady !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (secondCommit, rest2) <- decodePointBytes rest1 - tlvs <- decodeTlvs rest2 - let !msg = ChannelReady - { channelReadyChannelId = chanId - , channelReadySecondPerCommitPoint = secondCommit - , channelReadyTlvs = tlvs - } - Right (msg, BS.empty) - --- Channel close --------------------------------------------------------------- - --- | Encode a Stfu message (type 2). --- --- Wire format: --- - channel_id: 32 bytes --- - initiator: 1 byte -encodeStfu :: Stfu -> BS.ByteString -encodeStfu !msg = mconcat - [ unChannelId (stfuChannelId msg) - , BS.singleton (stfuInitiator msg) - ] - --- | Decode a Stfu message (type 2). -decodeStfu :: BS.ByteString -> Either DecodeError (Stfu, BS.ByteString) -decodeStfu !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (initiator, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU8 rest1) - let !msg = Stfu - { stfuChannelId = chanId - , stfuInitiator = initiator - } - Right (msg, rest2) - --- | Encode a Shutdown message (type 38). --- --- Wire format: --- - channel_id: 32 bytes --- - len: u16 --- - scriptpubkey: len bytes -encodeShutdown :: Shutdown -> Either EncodeError BS.ByteString -encodeShutdown !msg = do - let !script = unScriptPubKey (shutdownScriptPubkey msg) - !scriptLen = BS.length script - if scriptLen > 65535 - then Left EncodeLengthOverflow - else Right $ mconcat - [ unChannelId (shutdownChannelId msg) - , encodeU16 (fromIntegral scriptLen) - , script - ] - --- | Decode a Shutdown message (type 38). -decodeShutdown - :: BS.ByteString -> Either DecodeError (Shutdown, BS.ByteString) -decodeShutdown !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (script, rest2) <- decodeScriptPubKey rest1 - let !msg = Shutdown - { shutdownChannelId = chanId - , shutdownScriptPubkey = script - } - Right (msg, rest2) - --- | Encode a ClosingSigned message (type 39). --- --- Wire format: --- - channel_id: 32 bytes --- - fee_satoshis: u64 --- - signature: 64 bytes --- - tlvs: TLV stream -encodeClosingSigned :: ClosingSigned -> BS.ByteString -encodeClosingSigned !msg = mconcat - [ unChannelId (closingSignedChannelId msg) - , encodeU64 (unSatoshis (closingSignedFeeSatoshis msg)) - , unSignature (closingSignedSignature msg) - , encodeTlvStream (closingSignedTlvs msg) - ] - --- | Decode a ClosingSigned message (type 39). -decodeClosingSigned - :: BS.ByteString -> Either DecodeError (ClosingSigned, BS.ByteString) -decodeClosingSigned !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (feeSats, rest2) <- decodeSatoshis rest1 - (sig, rest3) <- decodeSignatureBytes rest2 - tlvs <- decodeTlvs rest3 - let !msg = ClosingSigned - { closingSignedChannelId = chanId - , closingSignedFeeSatoshis = feeSats - , closingSignedSignature = sig - , closingSignedTlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode a ClosingComplete message (type 40). --- --- Wire format: --- - channel_id: 32 bytes --- - len: u16 (closer script length) --- - closer_script: len bytes --- - len: u16 (closee script length) --- - closee_script: len bytes --- - fee_satoshis: u64 --- - locktime: u32 --- - tlvs: TLV stream -encodeClosingComplete :: ClosingComplete -> Either EncodeError BS.ByteString -encodeClosingComplete !msg = do - let !closerScript = unScriptPubKey (closingCompleteCloserScript msg) - !closeeScript = unScriptPubKey (closingCompleteCloseeScript msg) - !closerLen = BS.length closerScript - !closeeLen = BS.length closeeScript - if closerLen > 65535 || closeeLen > 65535 - then Left EncodeLengthOverflow - else Right $ mconcat - [ unChannelId (closingCompleteChannelId msg) - , encodeU16 (fromIntegral closerLen) - , closerScript - , encodeU16 (fromIntegral closeeLen) - , closeeScript - , encodeU64 (unSatoshis (closingCompleteFeeSatoshis msg)) - , encodeU32 (closingCompleteLocktime msg) - , encodeTlvStream (closingCompleteTlvs msg) - ] - --- | Decode a ClosingComplete message (type 40). -decodeClosingComplete - :: BS.ByteString -> Either DecodeError (ClosingComplete, BS.ByteString) -decodeClosingComplete !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (closerScript, rest2) <- decodeScriptPubKey rest1 - (closeeScript, rest3) <- decodeScriptPubKey rest2 - (feeSats, rest4) <- decodeSatoshis rest3 - (locktime, rest5) <- decodeU32E rest4 - tlvs <- decodeTlvs rest5 - let !msg = ClosingComplete - { closingCompleteChannelId = chanId - , closingCompleteCloserScript = closerScript - , closingCompleteCloseeScript = closeeScript - , closingCompleteFeeSatoshis = feeSats - , closingCompleteLocktime = locktime - , closingCompleteTlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode a ClosingSig message (type 41). --- --- Wire format: --- - channel_id: 32 bytes --- - len: u16 (closer script length) --- - closer_script: len bytes --- - len: u16 (closee script length) --- - closee_script: len bytes --- - fee_satoshis: u64 --- - locktime: u32 --- - tlvs: TLV stream -encodeClosingSig :: ClosingSig -> Either EncodeError BS.ByteString -encodeClosingSig !msg = do - let !closerScript = unScriptPubKey (closingSigCloserScript msg) - !closeeScript = unScriptPubKey (closingSigCloseeScript msg) - !closerLen = BS.length closerScript - !closeeLen = BS.length closeeScript - if closerLen > 65535 || closeeLen > 65535 - then Left EncodeLengthOverflow - else Right $ mconcat - [ unChannelId (closingSigChannelId msg) - , encodeU16 (fromIntegral closerLen) - , closerScript - , encodeU16 (fromIntegral closeeLen) - , closeeScript - , encodeU64 (unSatoshis (closingSigFeeSatoshis msg)) - , encodeU32 (closingSigLocktime msg) - , encodeTlvStream (closingSigTlvs msg) - ] - --- | Decode a ClosingSig message (type 41). -decodeClosingSig - :: BS.ByteString -> Either DecodeError (ClosingSig, BS.ByteString) -decodeClosingSig !bs = do - (chanId, rest1) <- decodeChannelIdBytes bs - (closerScript, rest2) <- decodeScriptPubKey rest1 - (closeeScript, rest3) <- decodeScriptPubKey rest2 - (feeSats, rest4) <- decodeSatoshis rest3 - (locktime, rest5) <- decodeU32E rest4 - tlvs <- decodeTlvs rest5 - let !msg = ClosingSig - { closingSigChannelId = chanId - , closingSigCloserScript = closerScript - , closingSigCloseeScript = closeeScript - , closingSigFeeSatoshis = feeSats - , closingSigLocktime = locktime - , closingSigTlvs = tlvs - } - Right (msg, BS.empty) - --- Channel establishment v2 (interactive-tx) ----------------------------------- - --- | Encode an OpenChannel2 message (type 64). -encodeOpenChannel2 :: OpenChannel2 -> BS.ByteString -encodeOpenChannel2 !msg = mconcat - [ unChainHash (openChannel2ChainHash msg) - , unChannelId (openChannel2TempChannelId msg) - , encodeU32 (openChannel2FundingFeeratePerkw msg) - , encodeU32 (openChannel2CommitFeeratePerkw msg) - , encodeU64 (unSatoshis (openChannel2FundingSatoshis msg)) - , encodeU64 (unSatoshis (openChannel2DustLimitSatoshis msg)) - , encodeU64 (unMilliSatoshis (openChannel2MaxHtlcValueInFlight msg)) - , encodeU64 (unMilliSatoshis (openChannel2HtlcMinimumMsat msg)) - , encodeU16 (openChannel2ToSelfDelay msg) - , encodeU16 (openChannel2MaxAcceptedHtlcs msg) - , encodeU32 (openChannel2Locktime msg) - , unPoint (openChannel2FundingPubkey msg) - , unPoint (openChannel2RevocationBasepoint msg) - , unPoint (openChannel2PaymentBasepoint msg) - , unPoint (openChannel2DelayedPaymentBase msg) - , unPoint (openChannel2HtlcBasepoint msg) - , unPoint (openChannel2FirstPerCommitPoint msg) - , unPoint (openChannel2SecondPerCommitPoint msg) - , BS.singleton (openChannel2ChannelFlags msg) - , encodeTlvStream (openChannel2Tlvs msg) - ] - --- | Decode an OpenChannel2 message (type 64). -decodeOpenChannel2 - :: BS.ByteString -> Either DecodeError (OpenChannel2, BS.ByteString) -decodeOpenChannel2 !bs = do - (ch, rest1) <- decodeChainHashBytes bs - (tempCid, rest2) <- decodeChannelIdBytes rest1 - (fundingFeerate, rest3) <- decodeU32E rest2 - (commitFeerate, rest4) <- decodeU32E rest3 - (fundingSats, rest5) <- decodeSatoshis rest4 - (dustLimit, rest6) <- decodeSatoshis rest5 - (maxHtlcVal, rest7) <- decodeMilliSatoshis rest6 - (htlcMin, rest8) <- decodeMilliSatoshis rest7 - (toSelfDelay, rest9) <- decodeU16E rest8 - (maxHtlcs, rest10) <- decodeU16E rest9 - (locktime, rest11) <- decodeU32E rest10 - (fundingPk, rest12) <- decodePointBytes rest11 - (revBase, rest13) <- decodePointBytes rest12 - (payBase, rest14) <- decodePointBytes rest13 - (delayBase, rest15) <- decodePointBytes rest14 - (htlcBase, rest16) <- decodePointBytes rest15 - (firstPt, rest17) <- decodePointBytes rest16 - (secondPt, rest18) <- decodePointBytes rest17 - (flags, rest19) <- maybe (Left DecodeInsufficientBytes) Right (decodeU8 rest18) - tlvs <- decodeTlvs rest19 - let !msg = OpenChannel2 - { openChannel2ChainHash = ch - , openChannel2TempChannelId = tempCid - , openChannel2FundingFeeratePerkw = fundingFeerate - , openChannel2CommitFeeratePerkw = commitFeerate - , openChannel2FundingSatoshis = fundingSats - , openChannel2DustLimitSatoshis = dustLimit - , openChannel2MaxHtlcValueInFlight = maxHtlcVal - , openChannel2HtlcMinimumMsat = htlcMin - , openChannel2ToSelfDelay = toSelfDelay - , openChannel2MaxAcceptedHtlcs = maxHtlcs - , openChannel2Locktime = locktime - , openChannel2FundingPubkey = fundingPk - , openChannel2RevocationBasepoint = revBase - , openChannel2PaymentBasepoint = payBase - , openChannel2DelayedPaymentBase = delayBase - , openChannel2HtlcBasepoint = htlcBase - , openChannel2FirstPerCommitPoint = firstPt - , openChannel2SecondPerCommitPoint = secondPt - , openChannel2ChannelFlags = flags - , openChannel2Tlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode an AcceptChannel2 message (type 65). -encodeAcceptChannel2 :: AcceptChannel2 -> BS.ByteString -encodeAcceptChannel2 !msg = mconcat - [ unChannelId (acceptChannel2TempChannelId msg) - , encodeU64 (unSatoshis (acceptChannel2FundingSatoshis msg)) - , encodeU64 (unSatoshis (acceptChannel2DustLimitSatoshis msg)) - , encodeU64 (unMilliSatoshis (acceptChannel2MaxHtlcValueInFlight msg)) - , encodeU64 (unMilliSatoshis (acceptChannel2HtlcMinimumMsat msg)) - , encodeU32 (acceptChannel2MinimumDepth msg) - , encodeU16 (acceptChannel2ToSelfDelay msg) - , encodeU16 (acceptChannel2MaxAcceptedHtlcs msg) - , unPoint (acceptChannel2FundingPubkey msg) - , unPoint (acceptChannel2RevocationBasepoint msg) - , unPoint (acceptChannel2PaymentBasepoint msg) - , unPoint (acceptChannel2DelayedPaymentBase msg) - , unPoint (acceptChannel2HtlcBasepoint msg) - , unPoint (acceptChannel2FirstPerCommitPoint msg) - , unPoint (acceptChannel2SecondPerCommitPoint msg) - , encodeTlvStream (acceptChannel2Tlvs msg) - ] - --- | Decode an AcceptChannel2 message (type 65). -decodeAcceptChannel2 - :: BS.ByteString -> Either DecodeError (AcceptChannel2, BS.ByteString) -decodeAcceptChannel2 !bs = do - (tempCid, rest1) <- decodeChannelIdBytes bs - (fundingSats, rest2) <- decodeSatoshis rest1 - (dustLimit, rest3) <- decodeSatoshis rest2 - (maxHtlcVal, rest4) <- decodeMilliSatoshis rest3 - (htlcMin, rest5) <- decodeMilliSatoshis rest4 - (minDepth, rest6) <- decodeU32E rest5 - (toSelfDelay, rest7) <- decodeU16E rest6 - (maxHtlcs, rest8) <- decodeU16E rest7 - (fundingPk, rest9) <- decodePointBytes rest8 - (revBase, rest10) <- decodePointBytes rest9 - (payBase, rest11) <- decodePointBytes rest10 - (delayBase, rest12) <- decodePointBytes rest11 - (htlcBase, rest13) <- decodePointBytes rest12 - (firstPt, rest14) <- decodePointBytes rest13 - (secondPt, rest15) <- decodePointBytes rest14 - tlvs <- decodeTlvs rest15 - let !msg = AcceptChannel2 - { acceptChannel2TempChannelId = tempCid - , acceptChannel2FundingSatoshis = fundingSats - , acceptChannel2DustLimitSatoshis = dustLimit - , acceptChannel2MaxHtlcValueInFlight = maxHtlcVal - , acceptChannel2HtlcMinimumMsat = htlcMin - , acceptChannel2MinimumDepth = minDepth - , acceptChannel2ToSelfDelay = toSelfDelay - , acceptChannel2MaxAcceptedHtlcs = maxHtlcs - , acceptChannel2FundingPubkey = fundingPk - , acceptChannel2RevocationBasepoint = revBase - , acceptChannel2PaymentBasepoint = payBase - , acceptChannel2DelayedPaymentBase = delayBase - , acceptChannel2HtlcBasepoint = htlcBase - , acceptChannel2FirstPerCommitPoint = firstPt - , acceptChannel2SecondPerCommitPoint = secondPt - , acceptChannel2Tlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode a TxAddInput message (type 66). -encodeTxAddInput :: TxAddInput -> Either EncodeError BS.ByteString -encodeTxAddInput !msg = do - prevTxEnc <- encodeU16BytesE (txAddInputPrevTx msg) - Right $! mconcat - [ unChannelId (txAddInputChannelId msg) - , encodeU64 (txAddInputSerialId msg) - , prevTxEnc - , encodeU32 (txAddInputPrevVout msg) - , encodeU32 (txAddInputSequence msg) - ] - --- | Decode a TxAddInput message (type 66). -decodeTxAddInput - :: BS.ByteString -> Either DecodeError (TxAddInput, BS.ByteString) -decodeTxAddInput !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (serialId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (prevTx, rest3) <- decodeU16Bytes rest2 - (prevVout, rest4) <- decodeU32E rest3 - (seqNum, rest5) <- decodeU32E rest4 - let !msg = TxAddInput - { txAddInputChannelId = cid - , txAddInputSerialId = serialId - , txAddInputPrevTx = prevTx - , txAddInputPrevVout = prevVout - , txAddInputSequence = seqNum - } - Right (msg, rest5) - --- | Encode a TxAddOutput message (type 67). -encodeTxAddOutput :: TxAddOutput -> Either EncodeError BS.ByteString -encodeTxAddOutput !msg = do - scriptEnc <- encodeU16BytesE (unScriptPubKey (txAddOutputScript msg)) - Right $! mconcat - [ unChannelId (txAddOutputChannelId msg) - , encodeU64 (txAddOutputSerialId msg) - , encodeU64 (unSatoshis (txAddOutputSats msg)) - , scriptEnc - ] - --- | Decode a TxAddOutput message (type 67). -decodeTxAddOutput - :: BS.ByteString -> Either DecodeError (TxAddOutput, BS.ByteString) -decodeTxAddOutput !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (serialId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (sats, rest3) <- decodeSatoshis rest2 - (scriptBs, rest4) <- decodeU16Bytes rest3 - let !msg = TxAddOutput - { txAddOutputChannelId = cid - , txAddOutputSerialId = serialId - , txAddOutputSats = sats - , txAddOutputScript = scriptPubKey scriptBs - } - Right (msg, rest4) - --- | Encode a TxRemoveInput message (type 68). -encodeTxRemoveInput :: TxRemoveInput -> BS.ByteString -encodeTxRemoveInput !msg = mconcat - [ unChannelId (txRemoveInputChannelId msg) - , encodeU64 (txRemoveInputSerialId msg) - ] - --- | Decode a TxRemoveInput message (type 68). -decodeTxRemoveInput - :: BS.ByteString -> Either DecodeError (TxRemoveInput, BS.ByteString) -decodeTxRemoveInput !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (serialId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - let !msg = TxRemoveInput - { txRemoveInputChannelId = cid - , txRemoveInputSerialId = serialId - } - Right (msg, rest2) - --- | Encode a TxRemoveOutput message (type 69). -encodeTxRemoveOutput :: TxRemoveOutput -> BS.ByteString -encodeTxRemoveOutput !msg = mconcat - [ unChannelId (txRemoveOutputChannelId msg) - , encodeU64 (txRemoveOutputSerialId msg) - ] - --- | Decode a TxRemoveOutput message (type 69). -decodeTxRemoveOutput - :: BS.ByteString -> Either DecodeError (TxRemoveOutput, BS.ByteString) -decodeTxRemoveOutput !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (serialId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - let !msg = TxRemoveOutput - { txRemoveOutputChannelId = cid - , txRemoveOutputSerialId = serialId - } - Right (msg, rest2) - --- | Encode a TxComplete message (type 70). -encodeTxComplete :: TxComplete -> BS.ByteString -encodeTxComplete !msg = unChannelId (txCompleteChannelId msg) - --- | Decode a TxComplete message (type 70). -decodeTxComplete - :: BS.ByteString -> Either DecodeError (TxComplete, BS.ByteString) -decodeTxComplete !bs = do - (cid, rest) <- decodeChannelIdBytes bs - let !msg = TxComplete { txCompleteChannelId = cid } - Right (msg, rest) - --- | Encode a single witness with bounds checking. -encodeWitnessE :: Witness -> Either EncodeError BS.ByteString -encodeWitnessE (Witness !wdata) = encodeU16BytesE wdata - --- | Decode a single witness. -decodeWitness :: BS.ByteString -> Either DecodeError (Witness, BS.ByteString) -decodeWitness !bs = do - (wdata, rest) <- decodeU16Bytes bs - Right (Witness wdata, rest) - --- | Encode a TxSignatures message (type 71). -encodeTxSignatures :: TxSignatures -> Either EncodeError BS.ByteString -encodeTxSignatures !msg = do - let !witnesses = txSignaturesWitnesses msg - numWit <- checkListCountU16 (length witnesses) - encodedWits <- traverse encodeWitnessE witnesses - Right $! mconcat $ - [ unChannelId (txSignaturesChannelId msg) - , unTxId (txSignaturesTxid msg) - , encodeU16 numWit - ] ++ encodedWits - --- | Decode a TxSignatures message (type 71). -decodeTxSignatures - :: BS.ByteString -> Either DecodeError (TxSignatures, BS.ByteString) -decodeTxSignatures !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (tid, rest2) <- decodeTxIdBytes rest1 - (numWit, rest3) <- decodeU16E rest2 - (witnesses, rest4) <- decodeWitnesses (fromIntegral numWit) rest3 - let !msg = TxSignatures - { txSignaturesChannelId = cid - , txSignaturesTxid = tid - , txSignaturesWitnesses = witnesses - } - Right (msg, rest4) - where - decodeWitnesses :: Int -> BS.ByteString - -> Either DecodeError ([Witness], BS.ByteString) - decodeWitnesses 0 !rest = Right ([], rest) - decodeWitnesses !n !rest = do - (w, rest') <- decodeWitness rest - (ws, rest'') <- decodeWitnesses (n - 1) rest' - Right (w : ws, rest'') - --- | Encode a TxInitRbf message (type 72). -encodeTxInitRbf :: TxInitRbf -> BS.ByteString -encodeTxInitRbf !msg = mconcat - [ unChannelId (txInitRbfChannelId msg) - , encodeU32 (txInitRbfLocktime msg) - , encodeU32 (txInitRbfFeerate msg) - , encodeTlvStream (txInitRbfTlvs msg) - ] - --- | Decode a TxInitRbf message (type 72). -decodeTxInitRbf - :: BS.ByteString -> Either DecodeError (TxInitRbf, BS.ByteString) -decodeTxInitRbf !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (locktime, rest2) <- decodeU32E rest1 - (feerate, rest3) <- decodeU32E rest2 - tlvs <- decodeTlvs rest3 - let !msg = TxInitRbf - { txInitRbfChannelId = cid - , txInitRbfLocktime = locktime - , txInitRbfFeerate = feerate - , txInitRbfTlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode a TxAckRbf message (type 73). -encodeTxAckRbf :: TxAckRbf -> BS.ByteString -encodeTxAckRbf !msg = mconcat - [ unChannelId (txAckRbfChannelId msg) - , encodeTlvStream (txAckRbfTlvs msg) - ] - --- | Decode a TxAckRbf message (type 73). -decodeTxAckRbf - :: BS.ByteString -> Either DecodeError (TxAckRbf, BS.ByteString) -decodeTxAckRbf !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - tlvs <- decodeTlvs rest1 - let !msg = TxAckRbf - { txAckRbfChannelId = cid - , txAckRbfTlvs = tlvs - } - Right (msg, BS.empty) - --- | Encode a TxAbort message (type 74). -encodeTxAbort :: TxAbort -> Either EncodeError BS.ByteString -encodeTxAbort !msg = do - dataEnc <- encodeU16BytesE (txAbortData msg) - Right $! mconcat - [ unChannelId (txAbortChannelId msg) - , dataEnc - ] - --- | Decode a TxAbort message (type 74). -decodeTxAbort - :: BS.ByteString -> Either DecodeError (TxAbort, BS.ByteString) -decodeTxAbort !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (dat, rest2) <- decodeU16Bytes rest1 - let !msg = TxAbort - { txAbortChannelId = cid - , txAbortData = dat - } - Right (msg, rest2) - --- Normal operation ------------------------------------------------------------ - --- | Encode an UpdateAddHtlc message (type 128). -encodeUpdateAddHtlc :: UpdateAddHtlc -> BS.ByteString -encodeUpdateAddHtlc !m = mconcat - [ unChannelId (updateAddHtlcChannelId m) - , encodeU64 (updateAddHtlcId m) - , encodeU64 (unMilliSatoshis (updateAddHtlcAmountMsat m)) - , unPaymentHash (updateAddHtlcPaymentHash m) - , encodeU32 (updateAddHtlcCltvExpiry m) - , unOnionPacket (updateAddHtlcOnionPacket m) - , encodeTlvStream (updateAddHtlcTlvs m) - ] -{-# INLINABLE encodeUpdateAddHtlc #-} - --- | Decode an UpdateAddHtlc message (type 128). -decodeUpdateAddHtlc - :: BS.ByteString -> Either DecodeError (UpdateAddHtlc, BS.ByteString) -decodeUpdateAddHtlc !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (htlcId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (amtMsat, rest3) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest2) - (pHash, rest4) <- decodePaymentHashBytes rest3 - (cltvExp, rest5) <- decodeU32E rest4 - (onion, rest6) <- decodeOnionPacketBytes rest5 - (tlvs, rest7) <- decodeOptionalTlvs rest6 - let !msg = UpdateAddHtlc - { updateAddHtlcChannelId = cid - , updateAddHtlcId = htlcId - , updateAddHtlcAmountMsat = MilliSatoshis amtMsat - , updateAddHtlcPaymentHash = pHash - , updateAddHtlcCltvExpiry = cltvExp - , updateAddHtlcOnionPacket = onion - , updateAddHtlcTlvs = tlvs - } - Right (msg, rest7) -{-# INLINABLE decodeUpdateAddHtlc #-} - --- | Encode an UpdateFulfillHtlc message (type 130). -encodeUpdateFulfillHtlc :: UpdateFulfillHtlc -> BS.ByteString -encodeUpdateFulfillHtlc !m = mconcat - [ unChannelId (updateFulfillHtlcChannelId m) - , encodeU64 (updateFulfillHtlcId m) - , unPaymentPreimage (updateFulfillHtlcPaymentPreimage m) - , encodeTlvStream (updateFulfillHtlcTlvs m) - ] - --- | Decode an UpdateFulfillHtlc message (type 130). -decodeUpdateFulfillHtlc - :: BS.ByteString -> Either DecodeError (UpdateFulfillHtlc, BS.ByteString) -decodeUpdateFulfillHtlc !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (htlcId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (preimage, rest3) <- decodePaymentPreimageBytes rest2 - (tlvs, rest4) <- decodeOptionalTlvs rest3 - let !msg = UpdateFulfillHtlc - { updateFulfillHtlcChannelId = cid - , updateFulfillHtlcId = htlcId - , updateFulfillHtlcPaymentPreimage = preimage - , updateFulfillHtlcTlvs = tlvs - } - Right (msg, rest4) - --- | Encode an UpdateFailHtlc message (type 131). -encodeUpdateFailHtlc :: UpdateFailHtlc -> Either EncodeError BS.ByteString -encodeUpdateFailHtlc !m = do - reasonEnc <- encodeU16BytesE (updateFailHtlcReason m) - Right $! mconcat - [ unChannelId (updateFailHtlcChannelId m) - , encodeU64 (updateFailHtlcId m) - , reasonEnc - , encodeTlvStream (updateFailHtlcTlvs m) - ] - --- | Decode an UpdateFailHtlc message (type 131). -decodeUpdateFailHtlc - :: BS.ByteString -> Either DecodeError (UpdateFailHtlc, BS.ByteString) -decodeUpdateFailHtlc !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (htlcId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (reason, rest3) <- decodeU16Bytes rest2 - (tlvs, rest4) <- decodeOptionalTlvs rest3 - let !msg = UpdateFailHtlc - { updateFailHtlcChannelId = cid - , updateFailHtlcId = htlcId - , updateFailHtlcReason = reason - , updateFailHtlcTlvs = tlvs - } - Right (msg, rest4) - --- | Encode an UpdateFailMalformedHtlc message (type 135). -encodeUpdateFailMalformedHtlc :: UpdateFailMalformedHtlc -> BS.ByteString -encodeUpdateFailMalformedHtlc !m = mconcat - [ unChannelId (updateFailMalformedHtlcChannelId m) - , encodeU64 (updateFailMalformedHtlcId m) - , unPaymentHash (updateFailMalformedHtlcSha256Onion m) - , encodeU16 (updateFailMalformedHtlcFailureCode m) - ] - --- | Decode an UpdateFailMalformedHtlc message (type 135). -decodeUpdateFailMalformedHtlc - :: BS.ByteString -> Either DecodeError (UpdateFailMalformedHtlc, BS.ByteString) -decodeUpdateFailMalformedHtlc !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (htlcId, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (sha256Onion, rest3) <- decodePaymentHashBytes rest2 - (failCode, rest4) <- decodeU16E rest3 - let !msg = UpdateFailMalformedHtlc - { updateFailMalformedHtlcChannelId = cid - , updateFailMalformedHtlcId = htlcId - , updateFailMalformedHtlcSha256Onion = sha256Onion - , updateFailMalformedHtlcFailureCode = failCode - } - Right (msg, rest4) - --- | Encode a CommitmentSigned message (type 132). -encodeCommitmentSigned :: CommitmentSigned -> Either EncodeError BS.ByteString -encodeCommitmentSigned !m = do - let !sigs = commitmentSignedHtlcSignatures m - numHtlcs <- checkListCountU16 (length sigs) - Right $! mconcat $ - [ unChannelId (commitmentSignedChannelId m) - , unSignature (commitmentSignedSignature m) - , encodeU16 numHtlcs - ] ++ map unSignature sigs -{-# INLINABLE encodeCommitmentSigned #-} - --- | Decode a CommitmentSigned message (type 132). -decodeCommitmentSigned - :: BS.ByteString -> Either DecodeError (CommitmentSigned, BS.ByteString) -decodeCommitmentSigned !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (sig, rest2) <- decodeSignatureBytes rest1 - (numHtlcs, rest3) <- decodeU16E rest2 - (htlcSigs, rest4) <- decodeSignatures (fromIntegral numHtlcs) rest3 - let !msg = CommitmentSigned - { commitmentSignedChannelId = cid - , commitmentSignedSignature = sig - , commitmentSignedHtlcSignatures = htlcSigs - } - Right (msg, rest4) - where - decodeSignatures :: Int -> BS.ByteString - -> Either DecodeError ([Signature], BS.ByteString) - decodeSignatures !n !input = go n input [] - where - go :: Int -> BS.ByteString -> [Signature] - -> Either DecodeError ([Signature], BS.ByteString) - go 0 !remaining !acc = Right (reverse acc, remaining) - go !count !remaining !acc = do - (s, rest) <- decodeSignatureBytes remaining - go (count - 1) rest (s : acc) -{-# INLINABLE decodeCommitmentSigned #-} - --- | Encode a RevokeAndAck message (type 133). -encodeRevokeAndAck :: RevokeAndAck -> BS.ByteString -encodeRevokeAndAck !m = mconcat - [ unChannelId (revokeAndAckChannelId m) - , unSecret (revokeAndAckPerCommitmentSecret m) - , unPoint (revokeAndAckNextPerCommitPoint m) - ] - --- | Decode a RevokeAndAck message (type 133). -decodeRevokeAndAck - :: BS.ByteString -> Either DecodeError (RevokeAndAck, BS.ByteString) -decodeRevokeAndAck !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (sec, rest2) <- decodeSecretBytes rest1 - (nextPoint, rest3) <- decodePointBytes rest2 - let !msg = RevokeAndAck - { revokeAndAckChannelId = cid - , revokeAndAckPerCommitmentSecret = sec - , revokeAndAckNextPerCommitPoint = nextPoint - } - Right (msg, rest3) - --- | Encode an UpdateFee message (type 134). -encodeUpdateFee :: UpdateFee -> BS.ByteString -encodeUpdateFee !m = mconcat - [ unChannelId (updateFeeChannelId m) - , encodeU32 (updateFeeFeeratePerKw m) - ] - --- | Decode an UpdateFee message (type 134). -decodeUpdateFee - :: BS.ByteString -> Either DecodeError (UpdateFee, BS.ByteString) -decodeUpdateFee !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (feerate, rest2) <- decodeU32E rest1 - let !msg = UpdateFee - { updateFeeChannelId = cid - , updateFeeFeeratePerKw = feerate - } - Right (msg, rest2) - --- Channel reestablishment ----------------------------------------------------- - --- | Encode a ChannelReestablish message (type 136). -encodeChannelReestablish :: ChannelReestablish -> BS.ByteString -encodeChannelReestablish !m = mconcat - [ unChannelId (channelReestablishChannelId m) - , encodeU64 (channelReestablishNextCommitNum m) - , encodeU64 (channelReestablishNextRevocationNum m) - , unSecret (channelReestablishYourLastCommitSecret m) - , unPoint (channelReestablishMyCurrentCommitPoint m) - , encodeTlvStream (channelReestablishTlvs m) - ] - --- | Decode a ChannelReestablish message (type 136). -decodeChannelReestablish - :: BS.ByteString -> Either DecodeError (ChannelReestablish, BS.ByteString) -decodeChannelReestablish !bs = do - (cid, rest1) <- decodeChannelIdBytes bs - (nextCommit, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest1) - (nextRevoke, rest3) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU64 rest2) - (sec, rest4) <- decodeSecretBytes rest3 - (myPoint, rest5) <- decodePointBytes rest4 - (tlvs, rest6) <- decodeOptionalTlvs rest5 - let !msg = ChannelReestablish - { channelReestablishChannelId = cid - , channelReestablishNextCommitNum = nextCommit - , channelReestablishNextRevocationNum = nextRevoke - , channelReestablishYourLastCommitSecret = sec - , channelReestablishMyCurrentCommitPoint = myPoint - , channelReestablishTlvs = tlvs - } - Right (msg, rest6) +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module: Lightning.Protocol.BOLT2.Codec +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Encoding and decoding of BOLT #2 messages. + +module Lightning.Protocol.BOLT2.Codec ( + EncodeError(..) + , DecodeError(..) + + , encode_message + , decode_message + + , encode_open_channel + , decode_open_channel + , encode_accept_channel + , decode_accept_channel + , encode_funding_created + , decode_funding_created + , encode_funding_signed + , decode_funding_signed + , encode_channel_ready + , decode_channel_ready + + , encode_open_channel2 + , decode_open_channel2 + , encode_accept_channel2 + , decode_accept_channel2 + , encode_tx_add_input + , decode_tx_add_input + , encode_tx_add_output + , decode_tx_add_output + , encode_tx_remove_input + , decode_tx_remove_input + , encode_tx_remove_output + , decode_tx_remove_output + , encode_tx_complete + , decode_tx_complete + , encode_tx_signatures + , decode_tx_signatures + , encode_tx_init_rbf + , decode_tx_init_rbf + , encode_tx_ack_rbf + , decode_tx_ack_rbf + , encode_tx_abort + , decode_tx_abort + + , encode_stfu + , decode_stfu + + , encode_shutdown + , decode_shutdown + , encode_closing_complete + , decode_closing_complete + , encode_closing_sig + , decode_closing_sig + , encode_closing_signed + , decode_closing_signed + + , encode_update_add_htlc + , decode_update_add_htlc + , encode_update_fulfill_htlc + , decode_update_fulfill_htlc + , encode_update_fail_htlc + , decode_update_fail_htlc + , encode_update_fail_malformed_htlc + , decode_update_fail_malformed_htlc + , encode_commitment_signed + , decode_commitment_signed + , encode_revoke_and_ack + , decode_revoke_and_ack + , encode_update_fee + , decode_update_fee + + , encode_channel_reestablish + , decode_channel_reestablish + ) where + +import Bitcoin.Prim.Tx (TxId, mk_txid, un_txid) +import Control.DeepSeq (NFData) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BU +import Data.Int (Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Generics (Generic) +import qualified Lightning.Protocol.BOLT1 as BOLT1 +import Lightning.Protocol.BOLT1 + ( ChannelId, Signature, Point, TlvRecord(..), TlvStream, TlvError ) +import qualified Lightning.Protocol.BOLT9 as BOLT9 +import Lightning.Protocol.BOLT2.Messages +import Lightning.Protocol.BOLT2.Types + +-- errors --------------------------------------------------------------------- + +-- | Why a message failed to encode. +data EncodeError + = EncodeLengthOverflow + -- ^ a length-prefixed field or a counted list exceeds 65535 + | EncodeInvalidTlvs + -- ^ a @_tlvs@ field contains a record of a type the message knows + | EncodeMessageTooLarge + -- ^ the message (type and payload) exceeds 65535 bytes + deriving (Eq, Show, Generic) + +instance NFData EncodeError + +-- | Why a message failed to decode. +data DecodeError + = DecodeInsufficientBytes + -- ^ the input ended before a field did + | DecodeInvalidPoint + -- ^ a point lacks a compressed-encoding prefix + | DecodeInvalidAmount + -- ^ an amount exceeds 21 million BTC + | DecodeInvalidInitiator + -- ^ the @initiator@ byte of @stfu@ is neither 0 nor 1 + | DecodeTlvError !TlvError + -- ^ the message's TLV stream is malformed, or has an unknown even + -- type + | DecodeInvalidTlvValue !Word64 + -- ^ a known TLV record (of the given type) has a malformed value + | DecodeUnknownEvenType !Word16 + -- ^ a message type that BOLT #2 doesn't define (even) + | DecodeUnknownOddType !Word16 + -- ^ a message type that BOLT #2 doesn't define (odd) + deriving (Eq, Show, Generic) + +instance NFData DecodeError + +-- parsing -------------------------------------------------------------------- + +newtype Parser a = Parser + { run_parser :: BS.ByteString -> Either DecodeError (a, BS.ByteString) } + +instance Functor Parser where + fmap f (Parser p) = Parser $ \bs -> case p bs of + Left e -> Left e + Right (a, r) -> Right (f a, r) + {-# INLINE fmap #-} + +instance Applicative Parser where + pure a = Parser $ \bs -> Right (a, bs) + {-# INLINE pure #-} + Parser pf <*> Parser pa = Parser $ \bs -> case pf bs of + Left e -> Left e + Right (f, r) -> case pa r of + Left e -> Left e + Right (a, r') -> Right (f a, r') + {-# INLINE (<*>) #-} + +instance Monad Parser where + Parser p >>= k = Parser $ \bs -> case p bs of + Left e -> Left e + Right (a, r) -> run_parser (k a) r + {-# INLINE (>>=) #-} + +-- run a parser whose last step consumes the remaining input +parse :: Parser a -> BS.ByteString -> Either DecodeError a +parse p bs = fmap fst (run_parser p bs) +{-# INLINE parse #-} + +failure :: DecodeError -> Parser a +failure e = Parser $ \_ -> Left e +{-# INLINE failure #-} + +-- lift a bolt1 field decoder, whose only failure is truncation +field :: (BS.ByteString -> Maybe (a, BS.ByteString)) -> Parser a +field f = Parser $ \bs -> case f bs of + Nothing -> Left DecodeInsufficientBytes + Just r -> Right r +{-# INLINE field #-} + +bytes :: Int -> Parser BS.ByteString +bytes n = Parser $ \bs -> + if BS.length bs < n + then Left DecodeInsufficientBytes + else Right (BU.unsafeTake n bs, BU.unsafeDrop n bs) +{-# INLINE bytes #-} + +-- a fixed-size field whose constructor checks only the length +sized :: Int -> (BS.ByteString -> Maybe a) -> Parser a +sized n f = do + b <- bytes n + maybe (failure DecodeInsufficientBytes) pure (f b) +{-# INLINE sized #-} + +u8 :: Parser Word8 +u8 = Parser $ \bs -> case BS.uncons bs of + Nothing -> Left DecodeInsufficientBytes + Just r -> Right r +{-# INLINE u8 #-} + +u16 :: Parser Word16 +u16 = field BOLT1.decode_u16 +{-# INLINE u16 #-} + +u32 :: Parser Word32 +u32 = field BOLT1.decode_u32 +{-# INLINE u32 #-} + +u64 :: Parser Word64 +u64 = field BOLT1.decode_u64 +{-# INLINE u64 #-} + +chain_hash :: Parser BOLT1.ChainHash +chain_hash = field BOLT1.decode_chain_hash +{-# INLINE chain_hash #-} + +channel_id :: Parser ChannelId +channel_id = field BOLT1.decode_channel_id +{-# INLINE channel_id #-} + +signature :: Parser Signature +signature = field BOLT1.decode_signature +{-# INLINE signature #-} + +payment_hash :: Parser BOLT1.PaymentHash +payment_hash = field BOLT1.decode_payment_hash +{-# INLINE payment_hash #-} + +payment_preimage :: Parser BOLT1.PaymentPreimage +payment_preimage = field BOLT1.decode_payment_preimage +{-# INLINE payment_preimage #-} + +per_commitment_secret :: Parser BOLT1.PerCommitmentSecret +per_commitment_secret = field BOLT1.decode_per_commitment_secret +{-# INLINE per_commitment_secret #-} + +point :: Parser Point +point = do + b <- bytes 33 + maybe (failure DecodeInvalidPoint) pure (BOLT1.point b) +{-# INLINE point #-} + +satoshi :: Parser BOLT1.Satoshi +satoshi = do + w <- u64 + maybe (failure DecodeInvalidAmount) pure (BOLT1.satoshi w) +{-# INLINE satoshi #-} + +milli_satoshi :: Parser BOLT1.MilliSatoshi +milli_satoshi = do + w <- u64 + maybe (failure DecodeInvalidAmount) pure (BOLT1.milli_satoshi w) +{-# INLINE milli_satoshi #-} + +txid :: Parser TxId +txid = sized 32 mk_txid +{-# INLINE txid #-} + +htlc_id :: Parser HtlcId +htlc_id = fmap HtlcId u64 +{-# INLINE htlc_id #-} + +serial_id :: Parser SerialId +serial_id = fmap SerialId u64 +{-# INLINE serial_id #-} + +prefixed :: Parser BS.ByteString +prefixed = field BOLT1.decode_u16_prefixed +{-# INLINE prefixed #-} + +script :: Parser ScriptPubKey +script = do + b <- prefixed + maybe (failure DecodeInsufficientBytes) pure (script_pubkey b) +{-# INLINE script #-} + +-- n items, each parsed by p +count :: Int -> Parser a -> Parser [a] +count n0 p = go n0 [] + where + go !n !acc + | n <= 0 = pure (reverse acc) + | otherwise = p >>= \a -> go (n - 1) (a : acc) +{-# INLINE count #-} + +-- the TLV stream occupying the rest of the payload, given the message's +-- known types +tlvs :: [Word64] -> Parser TlvStream +tlvs known = Parser $ \bs -> + case BOLT1.decode_tlv_stream (`elem` known) bs of + Left e -> Left (DecodeTlvError e) + Right s -> Right (s, BS.empty) +{-# INLINE tlvs #-} + +-- the unknown records of a stream +unknown :: [Word64] -> TlvStream -> TlvStream +unknown known = BOLT1.filter_tlv_stream (`notElem` known) +{-# INLINE unknown #-} + +-- the typed value of a known record, if present +record :: Word64 -> (BS.ByteString -> Maybe a) -> TlvStream -> Parser (Maybe a) +record t f s = case BOLT1.lookup_tlv t s of + Nothing -> pure Nothing + Just v -> maybe (failure (DecodeInvalidTlvValue t)) (pure . Just) (f v) +{-# INLINE record #-} + +-- whether a known record with an empty value is present +flag :: Word64 -> TlvStream -> Parser Bool +flag t s = fmap (maybe False (const True)) (record t empty_value s) + where + empty_value v + | BS.null v = Just () + | otherwise = Nothing +{-# INLINE flag #-} + +-- TLV values ----------------------------------------------------------------- + +-- run a field decoder over a whole TLV value +whole :: (BS.ByteString -> Maybe (a, BS.ByteString)) -> BS.ByteString + -> Maybe a +whole f v = case f v of + Just (a, r) | BS.null r -> Just a + _ -> Nothing +{-# INLINE whole #-} + +tlv_point :: BS.ByteString -> Maybe Point +tlv_point v + | BS.length v == 33 = BOLT1.point v + | otherwise = Nothing + +tlv_s64 :: BS.ByteString -> Maybe Int64 +tlv_s64 = whole BOLT1.decode_s64 + +tlv_fee_range :: BS.ByteString -> Maybe FeeRange +tlv_fee_range v = do + (lo, r0) <- BOLT1.decode_satoshi v + hi <- whole BOLT1.decode_satoshi r0 + pure (FeeRange lo hi) + +tlv_next_funding :: BS.ByteString -> Maybe NextFunding +tlv_next_funding v + | BS.length v == 33 = do + t <- mk_txid (BU.unsafeTake 32 v) + pure (NextFunding t (BU.unsafeIndex v 32)) + | otherwise = Nothing + +-- encoding ------------------------------------------------------------------- + +u16_prefixed :: BS.ByteString -> Either EncodeError BS.ByteString +u16_prefixed bs = maybe (Left EncodeLengthOverflow) Right + (BOLT1.encode_u16_prefixed bs) +{-# INLINE u16_prefixed #-} + +-- scripts are bounded, so their prefix can't overflow +script_bytes :: ScriptPubKey -> BS.ByteString +script_bytes s = + let !b = un_script_pubkey s + in BOLT1.encode_u16 (fromIntegral (BS.length b)) <> b +{-# INLINE script_bytes #-} + +count_prefix :: [a] -> Either EncodeError BS.ByteString +count_prefix xs + | n > 65535 = Left EncodeLengthOverflow + | otherwise = Right (BOLT1.encode_u16 (fromIntegral n)) + where + !n = length xs +{-# INLINE count_prefix #-} + +txid_bytes :: TxId -> BS.ByteString +txid_bytes = un_txid +{-# INLINE txid_bytes #-} + +word8 :: Word8 -> BS.ByteString +word8 = BS.singleton +{-# INLINE word8 #-} + +-- encode a message's TLV stream: its typed records plus the unknown +-- ones, which mustn't use a known type +encode_tlvs + :: [Word64] -> [TlvRecord] -> TlvStream -> Either EncodeError BS.ByteString +encode_tlvs known recs extra + | any ((`elem` known) . tlv_type) others = Left EncodeInvalidTlvs + | otherwise = case BOLT1.tlv_stream (recs <> others) of + Nothing -> Left EncodeInvalidTlvs + Just s -> Right (BOLT1.encode_tlv_stream s) + where + others = BOLT1.un_tlv_stream extra +{-# INLINE encode_tlvs #-} + +opt :: Word64 -> (a -> BS.ByteString) -> Maybe a -> [TlvRecord] +opt t f = maybe [] (\a -> [TlvRecord t (f a)]) +{-# INLINE opt #-} + +opt_flag :: Word64 -> Bool -> [TlvRecord] +opt_flag t b = if b then [TlvRecord t BS.empty] else [] +{-# INLINE opt_flag #-} + +fee_range_bytes :: FeeRange -> BS.ByteString +fee_range_bytes (FeeRange lo hi) = + BOLT1.encode_satoshi lo <> BOLT1.encode_satoshi hi + +next_funding_bytes :: NextFunding -> BS.ByteString +next_funding_bytes (NextFunding t f) = txid_bytes t <> word8 f + +-- messages ------------------------------------------------------------------- + +-- | Encode a BOLT #2 message, including its type. Fails if a field +-- can't be encoded or the result exceeds 65535 bytes. +-- +-- >>> let stfu = Stfu cid True BOLT1.empty_tlv_stream +-- >>> fmap BS.length (encode_message (MsgStfu stfu)) +-- Right 35 +encode_message :: Message -> Either EncodeError BS.ByteString +encode_message m = do + payload <- case m of + MsgOpenChannel a -> encode_open_channel a + MsgAcceptChannel a -> encode_accept_channel a + MsgFundingCreated a -> Right (encode_funding_created a) + MsgFundingSigned a -> Right (encode_funding_signed a) + MsgChannelReady a -> encode_channel_ready a + MsgOpenChannel2 a -> encode_open_channel2 a + MsgAcceptChannel2 a -> encode_accept_channel2 a + MsgTxAddInput a -> encode_tx_add_input a + MsgTxAddOutput a -> Right (encode_tx_add_output a) + MsgTxRemoveInput a -> Right (encode_tx_remove_input a) + MsgTxRemoveOutput a -> Right (encode_tx_remove_output a) + MsgTxComplete a -> Right (encode_tx_complete a) + MsgTxSignatures a -> encode_tx_signatures a + MsgTxInitRbf a -> encode_tx_init_rbf a + MsgTxAckRbf a -> encode_tx_ack_rbf a + MsgTxAbort a -> encode_tx_abort a + MsgStfu a -> Right (encode_stfu a) + MsgShutdown a -> Right (encode_shutdown a) + MsgClosingComplete a -> encode_closing_complete a + MsgClosingSig a -> encode_closing_sig a + MsgClosingSigned a -> encode_closing_signed a + MsgUpdateAddHtlc a -> encode_update_add_htlc a + MsgUpdateFulfillHtlc a -> encode_update_fulfill_htlc a + MsgUpdateFailHtlc a -> encode_update_fail_htlc a + MsgUpdateFailMalformedHtlc a -> + Right (encode_update_fail_malformed_htlc a) + MsgCommitmentSigned a -> encode_commitment_signed a + MsgRevokeAndAck a -> Right (encode_revoke_and_ack a) + MsgUpdateFee a -> Right (encode_update_fee a) + MsgChannelReestablish a -> encode_channel_reestablish a + case BOLT1.encode_envelope (message_type m) payload of + Left _ -> Left EncodeMessageTooLarge + Right w -> Right w + +-- | Decode a BOLT #2 message, including its type. +-- +-- A type that BOLT #2 doesn't define (including the splicing +-- messages, which this library doesn't implement) yields +-- 'DecodeUnknownEvenType' or 'DecodeUnknownOddType'. +-- +-- >>> let wire = "\x00\x02" <> BS.replicate 32 0xab <> "\x01" +-- >>> fmap message_type (decode_message wire) +-- Right 2 +-- >>> decode_message "\x00\x50" +-- Left (DecodeUnknownEvenType 80) +decode_message :: BS.ByteString -> Either DecodeError Message +decode_message bs = do + (t, payload) <- case BOLT1.decode_envelope bs of + Left _ -> Left DecodeInsufficientBytes + Right r -> Right r + case t of + 32 -> MsgOpenChannel <$> decode_open_channel payload + 33 -> MsgAcceptChannel <$> decode_accept_channel payload + 34 -> MsgFundingCreated <$> decode_funding_created payload + 35 -> MsgFundingSigned <$> decode_funding_signed payload + 36 -> MsgChannelReady <$> decode_channel_ready payload + 64 -> MsgOpenChannel2 <$> decode_open_channel2 payload + 65 -> MsgAcceptChannel2 <$> decode_accept_channel2 payload + 66 -> MsgTxAddInput <$> decode_tx_add_input payload + 67 -> MsgTxAddOutput <$> decode_tx_add_output payload + 68 -> MsgTxRemoveInput <$> decode_tx_remove_input payload + 69 -> MsgTxRemoveOutput <$> decode_tx_remove_output payload + 70 -> MsgTxComplete <$> decode_tx_complete payload + 71 -> MsgTxSignatures <$> decode_tx_signatures payload + 72 -> MsgTxInitRbf <$> decode_tx_init_rbf payload + 73 -> MsgTxAckRbf <$> decode_tx_ack_rbf payload + 74 -> MsgTxAbort <$> decode_tx_abort payload + 2 -> MsgStfu <$> decode_stfu payload + 38 -> MsgShutdown <$> decode_shutdown payload + 40 -> MsgClosingComplete <$> decode_closing_complete payload + 41 -> MsgClosingSig <$> decode_closing_sig payload + 39 -> MsgClosingSigned <$> decode_closing_signed payload + 128 -> MsgUpdateAddHtlc <$> decode_update_add_htlc payload + 130 -> MsgUpdateFulfillHtlc <$> decode_update_fulfill_htlc payload + 131 -> MsgUpdateFailHtlc <$> decode_update_fail_htlc payload + 135 -> MsgUpdateFailMalformedHtlc <$> + decode_update_fail_malformed_htlc payload + 132 -> MsgCommitmentSigned <$> decode_commitment_signed payload + 133 -> MsgRevokeAndAck <$> decode_revoke_and_ack payload + 134 -> MsgUpdateFee <$> decode_update_fee payload + 136 -> MsgChannelReestablish <$> decode_channel_reestablish payload + _ | even t -> Left (DecodeUnknownEvenType t) + | otherwise -> Left (DecodeUnknownOddType t) + +-- open_channel --------------------------------------------------------------- + +open_channel_known :: [Word64] +open_channel_known = [0, 1] + +-- | Encode an t'OpenChannel' payload. +encode_open_channel :: OpenChannel -> Either EncodeError BS.ByteString +encode_open_channel m = do + ts <- encode_tlvs open_channel_known + ( opt 0 un_script_pubkey (open_channel_upfront_shutdown_script m) + <> opt 1 BOLT9.render (open_channel_channel_type m) ) + (open_channel_tlvs m) + pure $ mconcat [ + BOLT1.un_chain_hash (open_channel_chain_hash m) + , BOLT1.un_channel_id (open_channel_temporary_channel_id m) + , BOLT1.encode_satoshi (open_channel_funding_satoshis m) + , BOLT1.encode_milli_satoshi (open_channel_push_msat m) + , BOLT1.encode_satoshi (open_channel_dust_limit_satoshis m) + , BOLT1.encode_u64 (open_channel_max_htlc_value_in_flight_msat m) + , BOLT1.encode_satoshi (open_channel_channel_reserve_satoshis m) + , BOLT1.encode_milli_satoshi (open_channel_htlc_minimum_msat m) + , BOLT1.encode_u32 (open_channel_feerate_per_kw m) + , BOLT1.encode_u16 (open_channel_to_self_delay m) + , BOLT1.encode_u16 (open_channel_max_accepted_htlcs m) + , BOLT1.un_point (open_channel_funding_pubkey m) + , BOLT1.un_point (open_channel_revocation_basepoint m) + , BOLT1.un_point (open_channel_payment_basepoint m) + , BOLT1.un_point (open_channel_delayed_payment_basepoint m) + , BOLT1.un_point (open_channel_htlc_basepoint m) + , BOLT1.un_point (open_channel_first_per_commitment_point m) + , word8 (open_channel_channel_flags m) + , ts + ] + +-- | Decode an t'OpenChannel' payload. +decode_open_channel :: BS.ByteString -> Either DecodeError OpenChannel +decode_open_channel = parse $ do + ch <- chain_hash + tcid <- channel_id + fund <- satoshi + push <- milli_satoshi + dust <- satoshi + maxv <- u64 + res <- satoshi + hmin <- milli_satoshi + fee <- u32 + delay <- u16 + maxa <- u16 + fpk <- point + rev <- point + pay <- point + del <- point + htlc <- point + pcp <- point + flags <- u8 + s <- tlvs open_channel_known + shut <- record 0 script_pubkey s + ctype <- record 1 (Just . BOLT9.parse) s + pure OpenChannel { + open_channel_chain_hash = ch + , open_channel_temporary_channel_id = tcid + , open_channel_funding_satoshis = fund + , open_channel_push_msat = push + , open_channel_dust_limit_satoshis = dust + , open_channel_max_htlc_value_in_flight_msat = maxv + , open_channel_channel_reserve_satoshis = res + , open_channel_htlc_minimum_msat = hmin + , open_channel_feerate_per_kw = fee + , open_channel_to_self_delay = delay + , open_channel_max_accepted_htlcs = maxa + , open_channel_funding_pubkey = fpk + , open_channel_revocation_basepoint = rev + , open_channel_payment_basepoint = pay + , open_channel_delayed_payment_basepoint = del + , open_channel_htlc_basepoint = htlc + , open_channel_first_per_commitment_point = pcp + , open_channel_channel_flags = flags + , open_channel_upfront_shutdown_script = shut + , open_channel_channel_type = ctype + , open_channel_tlvs = unknown open_channel_known s + } + +-- accept_channel ------------------------------------------------------------- + +accept_channel_known :: [Word64] +accept_channel_known = [0, 1] + +-- | Encode an t'AcceptChannel' payload. +encode_accept_channel :: AcceptChannel -> Either EncodeError BS.ByteString +encode_accept_channel m = do + ts <- encode_tlvs accept_channel_known + ( opt 0 un_script_pubkey (accept_channel_upfront_shutdown_script m) + <> opt 1 BOLT9.render (accept_channel_channel_type m) ) + (accept_channel_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (accept_channel_temporary_channel_id m) + , BOLT1.encode_satoshi (accept_channel_dust_limit_satoshis m) + , BOLT1.encode_u64 (accept_channel_max_htlc_value_in_flight_msat m) + , BOLT1.encode_satoshi (accept_channel_channel_reserve_satoshis m) + , BOLT1.encode_milli_satoshi (accept_channel_htlc_minimum_msat m) + , BOLT1.encode_u32 (accept_channel_minimum_depth m) + , BOLT1.encode_u16 (accept_channel_to_self_delay m) + , BOLT1.encode_u16 (accept_channel_max_accepted_htlcs m) + , BOLT1.un_point (accept_channel_funding_pubkey m) + , BOLT1.un_point (accept_channel_revocation_basepoint m) + , BOLT1.un_point (accept_channel_payment_basepoint m) + , BOLT1.un_point (accept_channel_delayed_payment_basepoint m) + , BOLT1.un_point (accept_channel_htlc_basepoint m) + , BOLT1.un_point (accept_channel_first_per_commitment_point m) + , ts + ] + +-- | Decode an t'AcceptChannel' payload. +decode_accept_channel :: BS.ByteString -> Either DecodeError AcceptChannel +decode_accept_channel = parse $ do + tcid <- channel_id + dust <- satoshi + maxv <- u64 + res <- satoshi + hmin <- milli_satoshi + depth <- u32 + delay <- u16 + maxa <- u16 + fpk <- point + rev <- point + pay <- point + del <- point + htlc <- point + pcp <- point + s <- tlvs accept_channel_known + shut <- record 0 script_pubkey s + ctype <- record 1 (Just . BOLT9.parse) s + pure AcceptChannel { + accept_channel_temporary_channel_id = tcid + , accept_channel_dust_limit_satoshis = dust + , accept_channel_max_htlc_value_in_flight_msat = maxv + , accept_channel_channel_reserve_satoshis = res + , accept_channel_htlc_minimum_msat = hmin + , accept_channel_minimum_depth = depth + , accept_channel_to_self_delay = delay + , accept_channel_max_accepted_htlcs = maxa + , accept_channel_funding_pubkey = fpk + , accept_channel_revocation_basepoint = rev + , accept_channel_payment_basepoint = pay + , accept_channel_delayed_payment_basepoint = del + , accept_channel_htlc_basepoint = htlc + , accept_channel_first_per_commitment_point = pcp + , accept_channel_upfront_shutdown_script = shut + , accept_channel_channel_type = ctype + , accept_channel_tlvs = unknown accept_channel_known s + } + +-- funding_created, funding_signed -------------------------------------------- + +-- | Encode a t'FundingCreated' payload. +encode_funding_created :: FundingCreated -> BS.ByteString +encode_funding_created m = mconcat [ + BOLT1.un_channel_id (funding_created_temporary_channel_id m) + , txid_bytes (funding_created_funding_txid m) + , BOLT1.encode_u16 (funding_created_funding_output_index m) + , BOLT1.un_signature (funding_created_signature m) + , BOLT1.encode_tlv_stream (funding_created_tlvs m) + ] + +-- | Decode a t'FundingCreated' payload. +decode_funding_created :: BS.ByteString -> Either DecodeError FundingCreated +decode_funding_created = parse $ + FundingCreated <$> channel_id <*> txid <*> u16 <*> signature <*> tlvs [] + +-- | Encode a t'FundingSigned' payload. +encode_funding_signed :: FundingSigned -> BS.ByteString +encode_funding_signed m = mconcat [ + BOLT1.un_channel_id (funding_signed_channel_id m) + , BOLT1.un_signature (funding_signed_signature m) + , BOLT1.encode_tlv_stream (funding_signed_tlvs m) + ] + +-- | Decode a t'FundingSigned' payload. +decode_funding_signed :: BS.ByteString -> Either DecodeError FundingSigned +decode_funding_signed = parse $ + FundingSigned <$> channel_id <*> signature <*> tlvs [] + +-- channel_ready -------------------------------------------------------------- + +channel_ready_known :: [Word64] +channel_ready_known = [1] + +-- | Encode a t'ChannelReady' payload. +encode_channel_ready :: ChannelReady -> Either EncodeError BS.ByteString +encode_channel_ready m = do + ts <- encode_tlvs channel_ready_known + (opt 1 BOLT1.encode_short_channel_id (channel_ready_alias m)) + (channel_ready_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (channel_ready_channel_id m) + , BOLT1.un_point (channel_ready_second_per_commitment_point m) + , ts + ] + +-- | Decode a t'ChannelReady' payload. +decode_channel_ready :: BS.ByteString -> Either DecodeError ChannelReady +decode_channel_ready = parse $ do + cid <- channel_id + pcp <- point + s <- tlvs channel_ready_known + alias <- record 1 (whole BOLT1.decode_short_channel_id) s + pure (ChannelReady cid pcp alias (unknown channel_ready_known s)) + +-- open_channel2 -------------------------------------------------------------- + +opening_known :: [Word64] +opening_known = [0, 1, 2] + +-- | Encode an t'OpenChannel2' payload. +encode_open_channel2 :: OpenChannel2 -> Either EncodeError BS.ByteString +encode_open_channel2 m = do + ts <- encode_tlvs opening_known + ( opt 0 un_script_pubkey (open_channel2_upfront_shutdown_script m) + <> opt 1 BOLT9.render (open_channel2_channel_type m) + <> opt_flag 2 (open_channel2_require_confirmed_inputs m) ) + (open_channel2_tlvs m) + pure $ mconcat [ + BOLT1.un_chain_hash (open_channel2_chain_hash m) + , BOLT1.un_channel_id (open_channel2_temporary_channel_id m) + , BOLT1.encode_u32 (open_channel2_funding_feerate_perkw m) + , BOLT1.encode_u32 (open_channel2_commitment_feerate_perkw m) + , BOLT1.encode_satoshi (open_channel2_funding_satoshis m) + , BOLT1.encode_satoshi (open_channel2_dust_limit_satoshis m) + , BOLT1.encode_u64 (open_channel2_max_htlc_value_in_flight_msat m) + , BOLT1.encode_milli_satoshi (open_channel2_htlc_minimum_msat m) + , BOLT1.encode_u16 (open_channel2_to_self_delay m) + , BOLT1.encode_u16 (open_channel2_max_accepted_htlcs m) + , BOLT1.encode_u32 (open_channel2_locktime m) + , BOLT1.un_point (open_channel2_funding_pubkey m) + , BOLT1.un_point (open_channel2_revocation_basepoint m) + , BOLT1.un_point (open_channel2_payment_basepoint m) + , BOLT1.un_point (open_channel2_delayed_payment_basepoint m) + , BOLT1.un_point (open_channel2_htlc_basepoint m) + , BOLT1.un_point (open_channel2_first_per_commitment_point m) + , BOLT1.un_point (open_channel2_second_per_commitment_point m) + , word8 (open_channel2_channel_flags m) + , ts + ] + +-- | Decode an t'OpenChannel2' payload. +decode_open_channel2 :: BS.ByteString -> Either DecodeError OpenChannel2 +decode_open_channel2 = parse $ do + ch <- chain_hash + tcid <- channel_id + ffee <- u32 + cfee <- u32 + fund <- satoshi + dust <- satoshi + maxv <- u64 + hmin <- milli_satoshi + delay <- u16 + maxa <- u16 + lock <- u32 + fpk <- point + rev <- point + pay <- point + del <- point + htlc <- point + pcp1 <- point + pcp2 <- point + flags <- u8 + s <- tlvs opening_known + shut <- record 0 script_pubkey s + ctype <- record 1 (Just . BOLT9.parse) s + conf <- flag 2 s + pure OpenChannel2 { + open_channel2_chain_hash = ch + , open_channel2_temporary_channel_id = tcid + , open_channel2_funding_feerate_perkw = ffee + , open_channel2_commitment_feerate_perkw = cfee + , open_channel2_funding_satoshis = fund + , open_channel2_dust_limit_satoshis = dust + , open_channel2_max_htlc_value_in_flight_msat = maxv + , open_channel2_htlc_minimum_msat = hmin + , open_channel2_to_self_delay = delay + , open_channel2_max_accepted_htlcs = maxa + , open_channel2_locktime = lock + , open_channel2_funding_pubkey = fpk + , open_channel2_revocation_basepoint = rev + , open_channel2_payment_basepoint = pay + , open_channel2_delayed_payment_basepoint = del + , open_channel2_htlc_basepoint = htlc + , open_channel2_first_per_commitment_point = pcp1 + , open_channel2_second_per_commitment_point = pcp2 + , open_channel2_channel_flags = flags + , open_channel2_upfront_shutdown_script = shut + , open_channel2_channel_type = ctype + , open_channel2_require_confirmed_inputs = conf + , open_channel2_tlvs = unknown opening_known s + } + +-- accept_channel2 ------------------------------------------------------------ + +-- | Encode an t'AcceptChannel2' payload. +encode_accept_channel2 :: AcceptChannel2 -> Either EncodeError BS.ByteString +encode_accept_channel2 m = do + ts <- encode_tlvs opening_known + ( opt 0 un_script_pubkey (accept_channel2_upfront_shutdown_script m) + <> opt 1 BOLT9.render (accept_channel2_channel_type m) + <> opt_flag 2 (accept_channel2_require_confirmed_inputs m) ) + (accept_channel2_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (accept_channel2_temporary_channel_id m) + , BOLT1.encode_satoshi (accept_channel2_funding_satoshis m) + , BOLT1.encode_satoshi (accept_channel2_dust_limit_satoshis m) + , BOLT1.encode_u64 (accept_channel2_max_htlc_value_in_flight_msat m) + , BOLT1.encode_milli_satoshi (accept_channel2_htlc_minimum_msat m) + , BOLT1.encode_u32 (accept_channel2_minimum_depth m) + , BOLT1.encode_u16 (accept_channel2_to_self_delay m) + , BOLT1.encode_u16 (accept_channel2_max_accepted_htlcs m) + , BOLT1.un_point (accept_channel2_funding_pubkey m) + , BOLT1.un_point (accept_channel2_revocation_basepoint m) + , BOLT1.un_point (accept_channel2_payment_basepoint m) + , BOLT1.un_point (accept_channel2_delayed_payment_basepoint m) + , BOLT1.un_point (accept_channel2_htlc_basepoint m) + , BOLT1.un_point (accept_channel2_first_per_commitment_point m) + , BOLT1.un_point (accept_channel2_second_per_commitment_point m) + , ts + ] + +-- | Decode an t'AcceptChannel2' payload. +decode_accept_channel2 :: BS.ByteString -> Either DecodeError AcceptChannel2 +decode_accept_channel2 = parse $ do + tcid <- channel_id + fund <- satoshi + dust <- satoshi + maxv <- u64 + hmin <- milli_satoshi + depth <- u32 + delay <- u16 + maxa <- u16 + fpk <- point + rev <- point + pay <- point + del <- point + htlc <- point + pcp1 <- point + pcp2 <- point + s <- tlvs opening_known + shut <- record 0 script_pubkey s + ctype <- record 1 (Just . BOLT9.parse) s + conf <- flag 2 s + pure AcceptChannel2 { + accept_channel2_temporary_channel_id = tcid + , accept_channel2_funding_satoshis = fund + , accept_channel2_dust_limit_satoshis = dust + , accept_channel2_max_htlc_value_in_flight_msat = maxv + , accept_channel2_htlc_minimum_msat = hmin + , accept_channel2_minimum_depth = depth + , accept_channel2_to_self_delay = delay + , accept_channel2_max_accepted_htlcs = maxa + , accept_channel2_funding_pubkey = fpk + , accept_channel2_revocation_basepoint = rev + , accept_channel2_payment_basepoint = pay + , accept_channel2_delayed_payment_basepoint = del + , accept_channel2_htlc_basepoint = htlc + , accept_channel2_first_per_commitment_point = pcp1 + , accept_channel2_second_per_commitment_point = pcp2 + , accept_channel2_upfront_shutdown_script = shut + , accept_channel2_channel_type = ctype + , accept_channel2_require_confirmed_inputs = conf + , accept_channel2_tlvs = unknown opening_known s + } + +-- interactive transaction construction --------------------------------------- + +-- | Encode a t'TxAddInput' payload. Fails if @prevtx@ exceeds 65535 +-- bytes. +encode_tx_add_input :: TxAddInput -> Either EncodeError BS.ByteString +encode_tx_add_input m = do + prev <- u16_prefixed (tx_add_input_prevtx m) + let SerialId sid = tx_add_input_serial_id m + pure $ mconcat [ + BOLT1.un_channel_id (tx_add_input_channel_id m) + , BOLT1.encode_u64 sid + , prev + , BOLT1.encode_u32 (tx_add_input_prevtx_vout m) + , BOLT1.encode_u32 (tx_add_input_sequence m) + , BOLT1.encode_tlv_stream (tx_add_input_tlvs m) + ] + +-- | Decode a t'TxAddInput' payload. +decode_tx_add_input :: BS.ByteString -> Either DecodeError TxAddInput +decode_tx_add_input = parse $ + TxAddInput <$> channel_id <*> serial_id <*> prefixed <*> u32 <*> u32 + <*> tlvs [] + +-- | Encode a t'TxAddOutput' payload. +encode_tx_add_output :: TxAddOutput -> BS.ByteString +encode_tx_add_output m = + let SerialId sid = tx_add_output_serial_id m + in mconcat [ + BOLT1.un_channel_id (tx_add_output_channel_id m) + , BOLT1.encode_u64 sid + , BOLT1.encode_satoshi (tx_add_output_sats m) + , script_bytes (tx_add_output_script m) + , BOLT1.encode_tlv_stream (tx_add_output_tlvs m) + ] + +-- | Decode a t'TxAddOutput' payload. +decode_tx_add_output :: BS.ByteString -> Either DecodeError TxAddOutput +decode_tx_add_output = parse $ + TxAddOutput <$> channel_id <*> serial_id <*> satoshi <*> script + <*> tlvs [] + +-- | Encode a t'TxRemoveInput' payload. +encode_tx_remove_input :: TxRemoveInput -> BS.ByteString +encode_tx_remove_input (TxRemoveInput cid (SerialId sid) ts) = mconcat [ + BOLT1.un_channel_id cid + , BOLT1.encode_u64 sid + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode a t'TxRemoveInput' payload. +decode_tx_remove_input :: BS.ByteString -> Either DecodeError TxRemoveInput +decode_tx_remove_input = parse $ + TxRemoveInput <$> channel_id <*> serial_id <*> tlvs [] + +-- | Encode a t'TxRemoveOutput' payload. +encode_tx_remove_output :: TxRemoveOutput -> BS.ByteString +encode_tx_remove_output (TxRemoveOutput cid (SerialId sid) ts) = mconcat [ + BOLT1.un_channel_id cid + , BOLT1.encode_u64 sid + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode a t'TxRemoveOutput' payload. +decode_tx_remove_output + :: BS.ByteString -> Either DecodeError TxRemoveOutput +decode_tx_remove_output = parse $ + TxRemoveOutput <$> channel_id <*> serial_id <*> tlvs [] + +-- | Encode a t'TxComplete' payload. +encode_tx_complete :: TxComplete -> BS.ByteString +encode_tx_complete (TxComplete cid ts) = + BOLT1.un_channel_id cid <> BOLT1.encode_tlv_stream ts + +-- | Decode a t'TxComplete' payload. +decode_tx_complete :: BS.ByteString -> Either DecodeError TxComplete +decode_tx_complete = parse $ TxComplete <$> channel_id <*> tlvs [] + +-- | Encode a t'TxSignatures' payload. Fails if there are more than 65535 +-- witnesses. +encode_tx_signatures :: TxSignatures -> Either EncodeError BS.ByteString +encode_tx_signatures m = do + let ws = tx_signatures_witnesses m + n <- count_prefix ws + pure $ mconcat [ + BOLT1.un_channel_id (tx_signatures_channel_id m) + , txid_bytes (tx_signatures_txid m) + , n + , mconcat [ BOLT1.encode_u16 (fromIntegral (BS.length w)) <> w + | w <- map un_witness ws ] + , BOLT1.encode_tlv_stream (tx_signatures_tlvs m) + ] + +-- | Decode a t'TxSignatures' payload. +decode_tx_signatures :: BS.ByteString -> Either DecodeError TxSignatures +decode_tx_signatures = parse $ do + cid <- channel_id + t <- txid + n <- u16 + ws <- count (fromIntegral n) wit + TxSignatures cid t ws <$> tlvs [] + where + wit = do + b <- prefixed + maybe (failure DecodeInsufficientBytes) pure (witness b) + +rbf_known :: [Word64] +rbf_known = [0, 2] + +-- | Encode a t'TxInitRbf' payload. +encode_tx_init_rbf :: TxInitRbf -> Either EncodeError BS.ByteString +encode_tx_init_rbf m = do + ts <- encode_tlvs rbf_known + ( opt 0 BOLT1.encode_s64 (tx_init_rbf_funding_output_contribution m) + <> opt_flag 2 (tx_init_rbf_require_confirmed_inputs m) ) + (tx_init_rbf_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (tx_init_rbf_channel_id m) + , BOLT1.encode_u32 (tx_init_rbf_locktime m) + , BOLT1.encode_u32 (tx_init_rbf_feerate m) + , ts + ] + +-- | Decode a t'TxInitRbf' payload. +decode_tx_init_rbf :: BS.ByteString -> Either DecodeError TxInitRbf +decode_tx_init_rbf = parse $ do + cid <- channel_id + lock <- u32 + fee <- u32 + s <- tlvs rbf_known + contrib <- record 0 tlv_s64 s + conf <- flag 2 s + pure (TxInitRbf cid lock fee contrib conf (unknown rbf_known s)) + +-- | Encode a t'TxAckRbf' payload. +encode_tx_ack_rbf :: TxAckRbf -> Either EncodeError BS.ByteString +encode_tx_ack_rbf m = do + ts <- encode_tlvs rbf_known + ( opt 0 BOLT1.encode_s64 (tx_ack_rbf_funding_output_contribution m) + <> opt_flag 2 (tx_ack_rbf_require_confirmed_inputs m) ) + (tx_ack_rbf_tlvs m) + pure (BOLT1.un_channel_id (tx_ack_rbf_channel_id m) <> ts) + +-- | Decode a t'TxAckRbf' payload. +decode_tx_ack_rbf :: BS.ByteString -> Either DecodeError TxAckRbf +decode_tx_ack_rbf = parse $ do + cid <- channel_id + s <- tlvs rbf_known + contrib <- record 0 tlv_s64 s + conf <- flag 2 s + pure (TxAckRbf cid contrib conf (unknown rbf_known s)) + +-- | Encode a t'TxAbort' payload. Fails if @data@ exceeds 65535 bytes. +encode_tx_abort :: TxAbort -> Either EncodeError BS.ByteString +encode_tx_abort (TxAbort cid dat ts) = do + dat' <- u16_prefixed dat + pure (BOLT1.un_channel_id cid <> dat' <> BOLT1.encode_tlv_stream ts) + +-- | Decode a t'TxAbort' payload. +decode_tx_abort :: BS.ByteString -> Either DecodeError TxAbort +decode_tx_abort = parse $ TxAbort <$> channel_id <*> prefixed <*> tlvs [] + +-- stfu ----------------------------------------------------------------------- + +-- | Encode a t'Stfu' payload. +encode_stfu :: Stfu -> BS.ByteString +encode_stfu (Stfu cid ini ts) = mconcat [ + BOLT1.un_channel_id cid + , word8 (if ini then 1 else 0) + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode a t'Stfu' payload. The @initiator@ byte must be 0 or 1. +decode_stfu :: BS.ByteString -> Either DecodeError Stfu +decode_stfu = parse $ do + cid <- channel_id + b <- u8 + ini <- case b of + 0 -> pure False + 1 -> pure True + _ -> failure DecodeInvalidInitiator + Stfu cid ini <$> tlvs [] + +-- shutdown ------------------------------------------------------------------- + +-- | Encode a t'Shutdown' payload. +encode_shutdown :: Shutdown -> BS.ByteString +encode_shutdown (Shutdown cid spk ts) = mconcat [ + BOLT1.un_channel_id cid + , script_bytes spk + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode a t'Shutdown' payload. +decode_shutdown :: BS.ByteString -> Either DecodeError Shutdown +decode_shutdown = parse $ Shutdown <$> channel_id <*> script <*> tlvs [] + +-- closing_complete, closing_sig ---------------------------------------------- + +closing_known :: [Word64] +closing_known = [1, 2, 3] + +closing_records + :: Maybe Signature -> Maybe Signature -> Maybe Signature -> [TlvRecord] +closing_records a b c = + opt 1 BOLT1.un_signature a + <> opt 2 BOLT1.un_signature b + <> opt 3 BOLT1.un_signature c + +-- | Encode a t'ClosingComplete' payload. +encode_closing_complete :: ClosingComplete -> Either EncodeError BS.ByteString +encode_closing_complete m = do + ts <- encode_tlvs closing_known + (closing_records + (closing_complete_closer_output_only m) + (closing_complete_closee_output_only m) + (closing_complete_closer_and_closee_outputs m)) + (closing_complete_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (closing_complete_channel_id m) + , script_bytes (closing_complete_closer_scriptpubkey m) + , script_bytes (closing_complete_closee_scriptpubkey m) + , BOLT1.encode_satoshi (closing_complete_fee_satoshis m) + , BOLT1.encode_u32 (closing_complete_locktime m) + , ts + ] + +-- | Decode a t'ClosingComplete' payload. +decode_closing_complete + :: BS.ByteString -> Either DecodeError ClosingComplete +decode_closing_complete = parse $ do + cid <- channel_id + closer <- script + closee <- script + fee <- satoshi + lock <- u32 + s <- tlvs closing_known + a <- record 1 BOLT1.signature s + b <- record 2 BOLT1.signature s + c <- record 3 BOLT1.signature s + pure (ClosingComplete cid closer closee fee lock a b c + (unknown closing_known s)) + +-- | Encode a t'ClosingSig' payload. +encode_closing_sig :: ClosingSig -> Either EncodeError BS.ByteString +encode_closing_sig m = do + ts <- encode_tlvs closing_known + (closing_records + (closing_sig_closer_output_only m) + (closing_sig_closee_output_only m) + (closing_sig_closer_and_closee_outputs m)) + (closing_sig_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (closing_sig_channel_id m) + , script_bytes (closing_sig_closer_scriptpubkey m) + , script_bytes (closing_sig_closee_scriptpubkey m) + , BOLT1.encode_satoshi (closing_sig_fee_satoshis m) + , BOLT1.encode_u32 (closing_sig_locktime m) + , ts + ] + +-- | Decode a t'ClosingSig' payload. +decode_closing_sig :: BS.ByteString -> Either DecodeError ClosingSig +decode_closing_sig = parse $ do + cid <- channel_id + closer <- script + closee <- script + fee <- satoshi + lock <- u32 + s <- tlvs closing_known + a <- record 1 BOLT1.signature s + b <- record 2 BOLT1.signature s + c <- record 3 BOLT1.signature s + pure (ClosingSig cid closer closee fee lock a b c + (unknown closing_known s)) + +-- closing_signed ------------------------------------------------------------- + +closing_signed_known :: [Word64] +closing_signed_known = [1] + +-- | Encode a t'ClosingSigned' payload. +encode_closing_signed :: ClosingSigned -> Either EncodeError BS.ByteString +encode_closing_signed m = do + ts <- encode_tlvs closing_signed_known + (opt 1 fee_range_bytes (closing_signed_fee_range m)) + (closing_signed_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (closing_signed_channel_id m) + , BOLT1.encode_satoshi (closing_signed_fee_satoshis m) + , BOLT1.un_signature (closing_signed_signature m) + , ts + ] + +-- | Decode a t'ClosingSigned' payload. +decode_closing_signed :: BS.ByteString -> Either DecodeError ClosingSigned +decode_closing_signed = parse $ do + cid <- channel_id + fee <- satoshi + sig <- signature + s <- tlvs closing_signed_known + range <- record 1 tlv_fee_range s + pure (ClosingSigned cid fee sig range (unknown closing_signed_known s)) + +-- update_add_htlc ------------------------------------------------------------ + +update_add_htlc_known :: [Word64] +update_add_htlc_known = [0] + +-- | Encode an t'UpdateAddHtlc' payload. +encode_update_add_htlc :: UpdateAddHtlc -> Either EncodeError BS.ByteString +encode_update_add_htlc m = do + ts <- encode_tlvs update_add_htlc_known + (opt 0 BOLT1.un_point (update_add_htlc_path_key m)) + (update_add_htlc_tlvs m) + let HtlcId hid = update_add_htlc_id m + pure $ mconcat [ + BOLT1.un_channel_id (update_add_htlc_channel_id m) + , BOLT1.encode_u64 hid + , BOLT1.encode_milli_satoshi (update_add_htlc_amount_msat m) + , BOLT1.un_payment_hash (update_add_htlc_payment_hash m) + , BOLT1.encode_u32 (update_add_htlc_cltv_expiry m) + , un_onion_routing_packet (update_add_htlc_onion_routing_packet m) + , ts + ] + +-- | Decode an t'UpdateAddHtlc' payload. +decode_update_add_htlc :: BS.ByteString -> Either DecodeError UpdateAddHtlc +decode_update_add_htlc = parse $ do + cid <- channel_id + hid <- htlc_id + amt <- milli_satoshi + ph <- payment_hash + cltv <- u32 + onion <- sized 1366 onion_routing_packet + s <- tlvs update_add_htlc_known + pk <- record 0 tlv_point s + pure (UpdateAddHtlc cid hid amt ph cltv onion pk + (unknown update_add_htlc_known s)) + +-- update_fulfill_htlc -------------------------------------------------------- + +update_fulfill_htlc_known :: [Word64] +update_fulfill_htlc_known = [1, 3] + +-- | Encode an t'UpdateFulfillHtlc' payload. +encode_update_fulfill_htlc + :: UpdateFulfillHtlc -> Either EncodeError BS.ByteString +encode_update_fulfill_htlc m = do + ts <- encode_tlvs update_fulfill_htlc_known + ( opt 1 un_attribution_data (update_fulfill_htlc_attribution_data m) + <> opt 3 id (update_fulfill_htlc_fulfillment_payload m) ) + (update_fulfill_htlc_tlvs m) + let HtlcId hid = update_fulfill_htlc_id m + pure $ mconcat [ + BOLT1.un_channel_id (update_fulfill_htlc_channel_id m) + , BOLT1.encode_u64 hid + , BOLT1.un_payment_preimage (update_fulfill_htlc_payment_preimage m) + , ts + ] + +-- | Decode an t'UpdateFulfillHtlc' payload. +decode_update_fulfill_htlc + :: BS.ByteString -> Either DecodeError UpdateFulfillHtlc +decode_update_fulfill_htlc = parse $ do + cid <- channel_id + hid <- htlc_id + pre <- payment_preimage + s <- tlvs update_fulfill_htlc_known + att <- record 1 attribution_data s + pay <- record 3 Just s + pure (UpdateFulfillHtlc cid hid pre att pay + (unknown update_fulfill_htlc_known s)) + +-- update_fail_htlc ----------------------------------------------------------- + +update_fail_htlc_known :: [Word64] +update_fail_htlc_known = [1] + +-- | Encode an t'UpdateFailHtlc' payload. Fails if @reason@ exceeds 65535 +-- bytes. +encode_update_fail_htlc :: UpdateFailHtlc -> Either EncodeError BS.ByteString +encode_update_fail_htlc m = do + reason <- u16_prefixed (update_fail_htlc_reason m) + ts <- encode_tlvs update_fail_htlc_known + (opt 1 un_attribution_data (update_fail_htlc_attribution_data m)) + (update_fail_htlc_tlvs m) + let HtlcId hid = update_fail_htlc_id m + pure $ mconcat [ + BOLT1.un_channel_id (update_fail_htlc_channel_id m) + , BOLT1.encode_u64 hid + , reason + , ts + ] + +-- | Decode an t'UpdateFailHtlc' payload. +decode_update_fail_htlc :: BS.ByteString -> Either DecodeError UpdateFailHtlc +decode_update_fail_htlc = parse $ do + cid <- channel_id + hid <- htlc_id + reason <- prefixed + s <- tlvs update_fail_htlc_known + att <- record 1 attribution_data s + pure (UpdateFailHtlc cid hid reason att (unknown update_fail_htlc_known s)) + +-- update_fail_malformed_htlc ------------------------------------------------- + +-- | Encode an t'UpdateFailMalformedHtlc' payload. +encode_update_fail_malformed_htlc :: UpdateFailMalformedHtlc -> BS.ByteString +encode_update_fail_malformed_htlc + (UpdateFailMalformedHtlc cid (HtlcId hid) oh code ts) = mconcat [ + BOLT1.un_channel_id cid + , BOLT1.encode_u64 hid + , un_onion_hash oh + , BOLT1.encode_u16 code + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode an t'UpdateFailMalformedHtlc' payload. +decode_update_fail_malformed_htlc + :: BS.ByteString -> Either DecodeError UpdateFailMalformedHtlc +decode_update_fail_malformed_htlc = parse $ + UpdateFailMalformedHtlc <$> channel_id <*> htlc_id <*> sized 32 onion_hash + <*> u16 <*> tlvs [] + +-- commitment_signed ---------------------------------------------------------- + +commitment_signed_known :: [Word64] +commitment_signed_known = [1] + +-- | Encode a t'CommitmentSigned' payload. Fails if there are more than +-- 65535 HTLC signatures. +encode_commitment_signed + :: CommitmentSigned -> Either EncodeError BS.ByteString +encode_commitment_signed m = do + let sigs = commitment_signed_htlc_signatures m + n <- count_prefix sigs + ts <- encode_tlvs commitment_signed_known + (opt 1 txid_bytes (commitment_signed_funding_txid m)) + (commitment_signed_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (commitment_signed_channel_id m) + , BOLT1.un_signature (commitment_signed_signature m) + , n + , mconcat (map BOLT1.un_signature sigs) + , ts + ] + +-- | Decode a t'CommitmentSigned' payload. +decode_commitment_signed + :: BS.ByteString -> Either DecodeError CommitmentSigned +decode_commitment_signed = parse $ do + cid <- channel_id + sig <- signature + n <- u16 + sigs <- count (fromIntegral n) signature + s <- tlvs commitment_signed_known + fund <- record 1 mk_txid s + pure (CommitmentSigned cid sig sigs fund (unknown commitment_signed_known s)) + +-- revoke_and_ack, update_fee ------------------------------------------------- + +-- | Encode a t'RevokeAndAck' payload. +encode_revoke_and_ack :: RevokeAndAck -> BS.ByteString +encode_revoke_and_ack (RevokeAndAck cid sec pcp ts) = mconcat [ + BOLT1.un_channel_id cid + , BOLT1.un_per_commitment_secret sec + , BOLT1.un_point pcp + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode a t'RevokeAndAck' payload. +decode_revoke_and_ack :: BS.ByteString -> Either DecodeError RevokeAndAck +decode_revoke_and_ack = parse $ + RevokeAndAck <$> channel_id <*> per_commitment_secret <*> point <*> tlvs [] + +-- | Encode an t'UpdateFee' payload. +encode_update_fee :: UpdateFee -> BS.ByteString +encode_update_fee (UpdateFee cid fee ts) = mconcat [ + BOLT1.un_channel_id cid + , BOLT1.encode_u32 fee + , BOLT1.encode_tlv_stream ts + ] + +-- | Decode an t'UpdateFee' payload. +decode_update_fee :: BS.ByteString -> Either DecodeError UpdateFee +decode_update_fee = parse $ UpdateFee <$> channel_id <*> u32 <*> tlvs [] + +-- channel_reestablish -------------------------------------------------------- + +channel_reestablish_known :: [Word64] +channel_reestablish_known = [1] + +-- | Encode a t'ChannelReestablish' payload. +encode_channel_reestablish + :: ChannelReestablish -> Either EncodeError BS.ByteString +encode_channel_reestablish m = do + ts <- encode_tlvs channel_reestablish_known + (opt 1 next_funding_bytes (channel_reestablish_next_funding m)) + (channel_reestablish_tlvs m) + pure $ mconcat [ + BOLT1.un_channel_id (channel_reestablish_channel_id m) + , BOLT1.encode_u64 (channel_reestablish_next_commitment_number m) + , BOLT1.encode_u64 (channel_reestablish_next_revocation_number m) + , BOLT1.un_per_commitment_secret + (channel_reestablish_your_last_per_commitment_secret m) + , BOLT1.un_point (channel_reestablish_my_current_per_commitment_point m) + , ts + ] + +-- | Decode a t'ChannelReestablish' payload. +decode_channel_reestablish + :: BS.ByteString -> Either DecodeError ChannelReestablish +decode_channel_reestablish = parse $ do + cid <- channel_id + nc <- u64 + nr <- u64 + sec <- per_commitment_secret + pcp <- point + s <- tlvs channel_reestablish_known + next <- record 1 tlv_next_funding s + pure (ChannelReestablish cid nc nr sec pcp next + (unknown channel_reestablish_known s)) diff --git a/lib/Lightning/Protocol/BOLT2/Messages.hs b/lib/Lightning/Protocol/BOLT2/Messages.hs --- a/lib/Lightning/Protocol/BOLT2/Messages.hs +++ b/lib/Lightning/Protocol/BOLT2/Messages.hs @@ -1,7 +1,5 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -- | -- Module: Lightning.Protocol.BOLT2.Messages @@ -9,27 +7,18 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- Message types for BOLT #2 peer protocol. --- --- This module defines per-message record types and a top-level Message --- sum type for all BOLT #2 messages. +-- The messages defined by BOLT #2. module Lightning.Protocol.BOLT2.Messages ( - -- * Message type codes - MsgType(..) - , msgTypeWord - - -- * Top-level message type - , Message(..) + Message(..) + , message_type - -- * Channel establishment v1 , OpenChannel(..) , AcceptChannel(..) , FundingCreated(..) , FundingSigned(..) , ChannelReady(..) - -- * Channel establishment v2 , OpenChannel2(..) , AcceptChannel2(..) , TxAddInput(..) @@ -42,14 +31,13 @@ , TxAckRbf(..) , TxAbort(..) - -- * Channel close , Stfu(..) + , Shutdown(..) - , ClosingSigned(..) , ClosingComplete(..) , ClosingSig(..) + , ClosingSigned(..) - -- * Normal operation , UpdateAddHtlc(..) , UpdateFulfillHtlc(..) , UpdateFailHtlc(..) @@ -58,544 +46,556 @@ , RevokeAndAck(..) , UpdateFee(..) - -- * Reestablishment , ChannelReestablish(..) - - -- * Witness data - , Witness(..) ) where +import Bitcoin.Prim.Tx (TxId) import Control.DeepSeq (NFData) import qualified Data.ByteString as BS +import Data.Int (Int64) import Data.Word (Word8, Word16, Word32, Word64) import GHC.Generics (Generic) -import Lightning.Protocol.BOLT1 (TlvStream) +import Lightning.Protocol.BOLT1 + ( ChainHash, ChannelId, Signature, Point, PaymentHash, PaymentPreimage + , PerCommitmentSecret, ShortChannelId, Satoshi, MilliSatoshi, TlvStream ) +import qualified Lightning.Protocol.BOLT9 as BOLT9 import Lightning.Protocol.BOLT2.Types --- Message type codes ---------------------------------------------------------- - --- | BOLT #2 message type codes. -data MsgType - = MsgStfu -- ^ 2 - | MsgOpenChannel -- ^ 32 - | MsgAcceptChannel -- ^ 33 - | MsgFundingCreated -- ^ 34 - | MsgFundingSigned -- ^ 35 - | MsgChannelReady -- ^ 36 - | MsgShutdown -- ^ 38 - | MsgClosingSigned -- ^ 39 - | MsgClosingComplete -- ^ 40 - | MsgClosingSig -- ^ 41 - | MsgOpenChannel2 -- ^ 64 - | MsgAcceptChannel2 -- ^ 65 - | MsgTxAddInput -- ^ 66 - | MsgTxAddOutput -- ^ 67 - | MsgTxRemoveInput -- ^ 68 - | MsgTxRemoveOutput -- ^ 69 - | MsgTxComplete -- ^ 70 - | MsgTxSignatures -- ^ 71 - | MsgTxInitRbf -- ^ 72 - | MsgTxAckRbf -- ^ 73 - | MsgTxAbort -- ^ 74 - | MsgUpdateAddHtlc -- ^ 128 - | MsgUpdateFulfillHtlc -- ^ 130 - | MsgUpdateFailHtlc -- ^ 131 - | MsgCommitmentSigned -- ^ 132 - | MsgRevokeAndAck -- ^ 133 - | MsgUpdateFee -- ^ 134 - | MsgUpdateFailMalformedHtlc -- ^ 135 - | MsgChannelReestablish -- ^ 136 - deriving stock (Eq, Ord, Show, Generic) - -instance NFData MsgType - --- | Get the numeric type code for a message type. -msgTypeWord :: MsgType -> Word16 -msgTypeWord MsgStfu = 2 -msgTypeWord MsgOpenChannel = 32 -msgTypeWord MsgAcceptChannel = 33 -msgTypeWord MsgFundingCreated = 34 -msgTypeWord MsgFundingSigned = 35 -msgTypeWord MsgChannelReady = 36 -msgTypeWord MsgShutdown = 38 -msgTypeWord MsgClosingSigned = 39 -msgTypeWord MsgClosingComplete = 40 -msgTypeWord MsgClosingSig = 41 -msgTypeWord MsgOpenChannel2 = 64 -msgTypeWord MsgAcceptChannel2 = 65 -msgTypeWord MsgTxAddInput = 66 -msgTypeWord MsgTxAddOutput = 67 -msgTypeWord MsgTxRemoveInput = 68 -msgTypeWord MsgTxRemoveOutput = 69 -msgTypeWord MsgTxComplete = 70 -msgTypeWord MsgTxSignatures = 71 -msgTypeWord MsgTxInitRbf = 72 -msgTypeWord MsgTxAckRbf = 73 -msgTypeWord MsgTxAbort = 74 -msgTypeWord MsgUpdateAddHtlc = 128 -msgTypeWord MsgUpdateFulfillHtlc = 130 -msgTypeWord MsgUpdateFailHtlc = 131 -msgTypeWord MsgCommitmentSigned = 132 -msgTypeWord MsgRevokeAndAck = 133 -msgTypeWord MsgUpdateFee = 134 -msgTypeWord MsgUpdateFailMalformedHtlc = 135 -msgTypeWord MsgChannelReestablish = 136 -{-# INLINE msgTypeWord #-} - --- Channel establishment v1 ---------------------------------------------------- +-- channel establishment v1 --------------------------------------------------- --- | The open_channel message (type 32). --- --- Contains information about a node and indicates its desire to set up --- a new channel. +-- | The @open_channel@ message (type 32). data OpenChannel = OpenChannel - { openChannelChainHash :: !ChainHash - , openChannelTempChannelId :: !ChannelId - , openChannelFundingSatoshis :: {-# UNPACK #-} !Satoshis - , openChannelPushMsat :: {-# UNPACK #-} !MilliSatoshis - , openChannelDustLimitSatoshis :: {-# UNPACK #-} !Satoshis - , openChannelMaxHtlcValueInFlight :: {-# UNPACK #-} !MilliSatoshis - , openChannelChannelReserveSat :: {-# UNPACK #-} !Satoshis - , openChannelHtlcMinimumMsat :: {-# UNPACK #-} !MilliSatoshis - , openChannelFeeratePerKw :: {-# UNPACK #-} !Word32 - , openChannelToSelfDelay :: {-# UNPACK #-} !Word16 - , openChannelMaxAcceptedHtlcs :: {-# UNPACK #-} !Word16 - , openChannelFundingPubkey :: !Point - , openChannelRevocationBasepoint :: !Point - , openChannelPaymentBasepoint :: !Point - , openChannelDelayedPaymentBase :: !Point - , openChannelHtlcBasepoint :: !Point - , openChannelFirstPerCommitPoint :: !Point - , openChannelChannelFlags :: {-# UNPACK #-} !Word8 - , openChannelTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { open_channel_chain_hash :: !ChainHash + , open_channel_temporary_channel_id :: !ChannelId + , open_channel_funding_satoshis :: {-# UNPACK #-} !Satoshi + , open_channel_push_msat :: {-# UNPACK #-} !MilliSatoshi + , open_channel_dust_limit_satoshis :: {-# UNPACK #-} !Satoshi + , open_channel_max_htlc_value_in_flight_msat :: {-# UNPACK #-} !Word64 + -- ^ a cap, often @maxBound@, so not a bounded amount + , open_channel_channel_reserve_satoshis :: {-# UNPACK #-} !Satoshi + , open_channel_htlc_minimum_msat :: {-# UNPACK #-} !MilliSatoshi + , open_channel_feerate_per_kw :: {-# UNPACK #-} !Word32 + , open_channel_to_self_delay :: {-# UNPACK #-} !Word16 + , open_channel_max_accepted_htlcs :: {-# UNPACK #-} !Word16 + , open_channel_funding_pubkey :: !Point + , open_channel_revocation_basepoint :: !Point + , open_channel_payment_basepoint :: !Point + , open_channel_delayed_payment_basepoint :: !Point + , open_channel_htlc_basepoint :: !Point + , open_channel_first_per_commitment_point :: !Point + , open_channel_channel_flags :: {-# UNPACK #-} !Word8 + -- ^ bit 0: @announce_channel@ + , open_channel_upfront_shutdown_script :: !(Maybe ScriptPubKey) + -- ^ TLV type 0; an empty script commits to no particular script + , open_channel_channel_type :: !(Maybe BOLT9.FeatureVector) + -- ^ TLV type 1 + , open_channel_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData OpenChannel --- | The accept_channel message (type 33). --- --- Contains information about a node and indicates its acceptance of --- the new channel. +-- | The @accept_channel@ message (type 33). data AcceptChannel = AcceptChannel - { acceptChannelTempChannelId :: !ChannelId - , acceptChannelDustLimitSatoshis :: {-# UNPACK #-} !Satoshis - , acceptChannelMaxHtlcValueInFlight :: {-# UNPACK #-} !MilliSatoshis - , acceptChannelChannelReserveSat :: {-# UNPACK #-} !Satoshis - , acceptChannelHtlcMinimumMsat :: {-# UNPACK #-} !MilliSatoshis - , acceptChannelMinimumDepth :: {-# UNPACK #-} !Word32 - , acceptChannelToSelfDelay :: {-# UNPACK #-} !Word16 - , acceptChannelMaxAcceptedHtlcs :: {-# UNPACK #-} !Word16 - , acceptChannelFundingPubkey :: !Point - , acceptChannelRevocationBasepoint :: !Point - , acceptChannelPaymentBasepoint :: !Point - , acceptChannelDelayedPaymentBase :: !Point - , acceptChannelHtlcBasepoint :: !Point - , acceptChannelFirstPerCommitPoint :: !Point - , acceptChannelTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { accept_channel_temporary_channel_id :: !ChannelId + , accept_channel_dust_limit_satoshis :: {-# UNPACK #-} !Satoshi + , accept_channel_max_htlc_value_in_flight_msat :: {-# UNPACK #-} !Word64 + -- ^ a cap, often @maxBound@, so not a bounded amount + , accept_channel_channel_reserve_satoshis :: {-# UNPACK #-} !Satoshi + , accept_channel_htlc_minimum_msat + :: {-# UNPACK #-} !MilliSatoshi + , accept_channel_minimum_depth :: {-# UNPACK #-} !Word32 + , accept_channel_to_self_delay :: {-# UNPACK #-} !Word16 + , accept_channel_max_accepted_htlcs :: {-# UNPACK #-} !Word16 + , accept_channel_funding_pubkey :: !Point + , accept_channel_revocation_basepoint :: !Point + , accept_channel_payment_basepoint :: !Point + , accept_channel_delayed_payment_basepoint :: !Point + , accept_channel_htlc_basepoint :: !Point + , accept_channel_first_per_commitment_point :: !Point + , accept_channel_upfront_shutdown_script :: !(Maybe ScriptPubKey) + -- ^ TLV type 0; an empty script commits to no particular script + , accept_channel_channel_type + :: !(Maybe BOLT9.FeatureVector) + -- ^ TLV type 1 + , accept_channel_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData AcceptChannel --- | The funding_created message (type 34). --- --- Describes the outpoint which the funder has created for the initial --- commitment transactions. +-- | The @funding_created@ message (type 34). data FundingCreated = FundingCreated - { fundingCreatedTempChannelId :: !ChannelId - , fundingCreatedFundingTxid :: !TxId - , fundingCreatedFundingOutIdx :: {-# UNPACK #-} !Word16 - , fundingCreatedSignature :: !Signature - } deriving stock (Eq, Show, Generic) + { funding_created_temporary_channel_id :: !ChannelId + , funding_created_funding_txid :: !TxId + , funding_created_funding_output_index :: {-# UNPACK #-} !Word16 + , funding_created_signature :: !Signature + , funding_created_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData FundingCreated --- | The funding_signed message (type 35). --- --- Gives the funder the signature for the first commitment transaction. +-- | The @funding_signed@ message (type 35). data FundingSigned = FundingSigned - { fundingSignedChannelId :: !ChannelId - , fundingSignedSignature :: !Signature - } deriving stock (Eq, Show, Generic) + { funding_signed_channel_id :: !ChannelId + , funding_signed_signature :: !Signature + , funding_signed_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData FundingSigned --- | The channel_ready message (type 36). --- --- Indicates that the funding transaction has sufficient confirms for --- channel use. +-- | The @channel_ready@ message (type 36). data ChannelReady = ChannelReady - { channelReadyChannelId :: !ChannelId - , channelReadySecondPerCommitPoint :: !Point - , channelReadyTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { channel_ready_channel_id :: !ChannelId + , channel_ready_second_per_commitment_point :: !Point + , channel_ready_alias :: !(Maybe ShortChannelId) + -- ^ the @short_channel_id@ record (TLV type 1) + , channel_ready_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData ChannelReady --- Channel establishment v2 ---------------------------------------------------- +-- channel establishment v2 --------------------------------------------------- --- | The open_channel2 message (type 64). --- --- Initiates the v2 channel establishment workflow. +-- | The @open_channel2@ message (type 64). data OpenChannel2 = OpenChannel2 - { openChannel2ChainHash :: !ChainHash - , openChannel2TempChannelId :: !ChannelId - , openChannel2FundingFeeratePerkw :: {-# UNPACK #-} !Word32 - , openChannel2CommitFeeratePerkw :: {-# UNPACK #-} !Word32 - , openChannel2FundingSatoshis :: {-# UNPACK #-} !Satoshis - , openChannel2DustLimitSatoshis :: {-# UNPACK #-} !Satoshis - , openChannel2MaxHtlcValueInFlight :: {-# UNPACK #-} !MilliSatoshis - , openChannel2HtlcMinimumMsat :: {-# UNPACK #-} !MilliSatoshis - , openChannel2ToSelfDelay :: {-# UNPACK #-} !Word16 - , openChannel2MaxAcceptedHtlcs :: {-# UNPACK #-} !Word16 - , openChannel2Locktime :: {-# UNPACK #-} !Word32 - , openChannel2FundingPubkey :: !Point - , openChannel2RevocationBasepoint :: !Point - , openChannel2PaymentBasepoint :: !Point - , openChannel2DelayedPaymentBase :: !Point - , openChannel2HtlcBasepoint :: !Point - , openChannel2FirstPerCommitPoint :: !Point - , openChannel2SecondPerCommitPoint :: !Point - , openChannel2ChannelFlags :: {-# UNPACK #-} !Word8 - , openChannel2Tlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { open_channel2_chain_hash :: !ChainHash + , open_channel2_temporary_channel_id :: !ChannelId + , open_channel2_funding_feerate_perkw :: {-# UNPACK #-} !Word32 + , open_channel2_commitment_feerate_perkw :: {-# UNPACK #-} !Word32 + , open_channel2_funding_satoshis :: {-# UNPACK #-} !Satoshi + , open_channel2_dust_limit_satoshis :: {-# UNPACK #-} !Satoshi + , open_channel2_max_htlc_value_in_flight_msat :: {-# UNPACK #-} !Word64 + -- ^ a cap, often @maxBound@, so not a bounded amount + , open_channel2_htlc_minimum_msat + :: {-# UNPACK #-} !MilliSatoshi + , open_channel2_to_self_delay :: {-# UNPACK #-} !Word16 + , open_channel2_max_accepted_htlcs :: {-# UNPACK #-} !Word16 + , open_channel2_locktime :: {-# UNPACK #-} !Word32 + , open_channel2_funding_pubkey :: !Point + , open_channel2_revocation_basepoint :: !Point + , open_channel2_payment_basepoint :: !Point + , open_channel2_delayed_payment_basepoint :: !Point + , open_channel2_htlc_basepoint :: !Point + , open_channel2_first_per_commitment_point :: !Point + , open_channel2_second_per_commitment_point :: !Point + , open_channel2_channel_flags :: {-# UNPACK #-} !Word8 + -- ^ bit 0: @announce_channel@ + , open_channel2_upfront_shutdown_script :: !(Maybe ScriptPubKey) + -- ^ TLV type 0; an empty script commits to no particular script + , open_channel2_channel_type + :: !(Maybe BOLT9.FeatureVector) + -- ^ TLV type 1 + , open_channel2_require_confirmed_inputs :: !Bool + -- ^ TLV type 2 + , open_channel2_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData OpenChannel2 --- | The accept_channel2 message (type 65). --- --- Indicates acceptance of the v2 channel. +-- | The @accept_channel2@ message (type 65). data AcceptChannel2 = AcceptChannel2 - { acceptChannel2TempChannelId :: !ChannelId - , acceptChannel2FundingSatoshis :: {-# UNPACK #-} !Satoshis - , acceptChannel2DustLimitSatoshis :: {-# UNPACK #-} !Satoshis - , acceptChannel2MaxHtlcValueInFlight :: {-# UNPACK #-} !MilliSatoshis - , acceptChannel2HtlcMinimumMsat :: {-# UNPACK #-} !MilliSatoshis - , acceptChannel2MinimumDepth :: {-# UNPACK #-} !Word32 - , acceptChannel2ToSelfDelay :: {-# UNPACK #-} !Word16 - , acceptChannel2MaxAcceptedHtlcs :: {-# UNPACK #-} !Word16 - , acceptChannel2FundingPubkey :: !Point - , acceptChannel2RevocationBasepoint :: !Point - , acceptChannel2PaymentBasepoint :: !Point - , acceptChannel2DelayedPaymentBase :: !Point - , acceptChannel2HtlcBasepoint :: !Point - , acceptChannel2FirstPerCommitPoint :: !Point - , acceptChannel2SecondPerCommitPoint :: !Point - , acceptChannel2Tlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { accept_channel2_temporary_channel_id :: !ChannelId + , accept_channel2_funding_satoshis :: {-# UNPACK #-} !Satoshi + , accept_channel2_dust_limit_satoshis :: {-# UNPACK #-} !Satoshi + , accept_channel2_max_htlc_value_in_flight_msat :: {-# UNPACK #-} !Word64 + -- ^ a cap, often @maxBound@, so not a bounded amount + , accept_channel2_htlc_minimum_msat + :: {-# UNPACK #-} !MilliSatoshi + , accept_channel2_minimum_depth :: {-# UNPACK #-} !Word32 + , accept_channel2_to_self_delay :: {-# UNPACK #-} !Word16 + , accept_channel2_max_accepted_htlcs :: {-# UNPACK #-} !Word16 + , accept_channel2_funding_pubkey :: !Point + , accept_channel2_revocation_basepoint :: !Point + , accept_channel2_payment_basepoint :: !Point + , accept_channel2_delayed_payment_basepoint :: !Point + , accept_channel2_htlc_basepoint :: !Point + , accept_channel2_first_per_commitment_point :: !Point + , accept_channel2_second_per_commitment_point :: !Point + , accept_channel2_upfront_shutdown_script + :: !(Maybe ScriptPubKey) + -- ^ TLV type 0; an empty script commits to no particular script + , accept_channel2_channel_type + :: !(Maybe BOLT9.FeatureVector) + -- ^ TLV type 1 + , accept_channel2_require_confirmed_inputs :: !Bool + -- ^ TLV type 2 + , accept_channel2_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData AcceptChannel2 --- Interactive transaction construction ---------------------------------------- - --- | The tx_add_input message (type 66). --- --- Adds a transaction input to the collaborative transaction. +-- | The @tx_add_input@ message (type 66). data TxAddInput = TxAddInput - { txAddInputChannelId :: !ChannelId - , txAddInputSerialId :: {-# UNPACK #-} !Word64 - , txAddInputPrevTx :: !BS.ByteString - , txAddInputPrevVout :: {-# UNPACK #-} !Word32 - , txAddInputSequence :: {-# UNPACK #-} !Word32 - } deriving stock (Eq, Show, Generic) + { tx_add_input_channel_id :: !ChannelId + , tx_add_input_serial_id :: !SerialId + , tx_add_input_prevtx :: !BS.ByteString + -- ^ the serialized previous transaction + , tx_add_input_prevtx_vout :: {-# UNPACK #-} !Word32 + , tx_add_input_sequence :: {-# UNPACK #-} !Word32 + , tx_add_input_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxAddInput --- | The tx_add_output message (type 67). --- --- Adds a transaction output to the collaborative transaction. +-- | The @tx_add_output@ message (type 67). data TxAddOutput = TxAddOutput - { txAddOutputChannelId :: !ChannelId - , txAddOutputSerialId :: {-# UNPACK #-} !Word64 - , txAddOutputSats :: {-# UNPACK #-} !Satoshis - , txAddOutputScript :: !ScriptPubKey - } deriving stock (Eq, Show, Generic) + { tx_add_output_channel_id :: !ChannelId + , tx_add_output_serial_id :: !SerialId + , tx_add_output_sats :: {-# UNPACK #-} !Satoshi + , tx_add_output_script :: !ScriptPubKey + , tx_add_output_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxAddOutput --- | The tx_remove_input message (type 68). --- --- Removes a previously added input from the collaborative transaction. +-- | The @tx_remove_input@ message (type 68). data TxRemoveInput = TxRemoveInput - { txRemoveInputChannelId :: !ChannelId - , txRemoveInputSerialId :: {-# UNPACK #-} !Word64 - } deriving stock (Eq, Show, Generic) + { tx_remove_input_channel_id :: !ChannelId + , tx_remove_input_serial_id :: !SerialId + , tx_remove_input_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxRemoveInput --- | The tx_remove_output message (type 69). --- --- Removes a previously added output from the collaborative transaction. +-- | The @tx_remove_output@ message (type 69). data TxRemoveOutput = TxRemoveOutput - { txRemoveOutputChannelId :: !ChannelId - , txRemoveOutputSerialId :: {-# UNPACK #-} !Word64 - } deriving stock (Eq, Show, Generic) + { tx_remove_output_channel_id :: !ChannelId + , tx_remove_output_serial_id :: !SerialId + , tx_remove_output_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxRemoveOutput --- | The tx_complete message (type 70). --- --- Signals the conclusion of a peer's transaction contributions. +-- | The @tx_complete@ message (type 70). data TxComplete = TxComplete - { txCompleteChannelId :: !ChannelId - } deriving stock (Eq, Show, Generic) + { tx_complete_channel_id :: !ChannelId + , tx_complete_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxComplete --- | Witness data for tx_signatures. -data Witness = Witness - { witnessData :: !BS.ByteString - } deriving stock (Eq, Show, Generic) - -instance NFData Witness - --- | The tx_signatures message (type 71). --- --- Contains signatures for the collaborative transaction. +-- | The @tx_signatures@ message (type 71). data TxSignatures = TxSignatures - { txSignaturesChannelId :: !ChannelId - , txSignaturesTxid :: !TxId - , txSignaturesWitnesses :: ![Witness] - } deriving stock (Eq, Show, Generic) + { tx_signatures_channel_id :: !ChannelId + , tx_signatures_txid :: !TxId + , tx_signatures_witnesses :: ![Witness] + -- ^ ordered by the @serial_id@ of the inputs they spend + , tx_signatures_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxSignatures --- | The tx_init_rbf message (type 72). --- --- Initiates a replacement of the transaction after it's been completed. +-- | The @tx_init_rbf@ message (type 72). data TxInitRbf = TxInitRbf - { txInitRbfChannelId :: !ChannelId - , txInitRbfLocktime :: {-# UNPACK #-} !Word32 - , txInitRbfFeerate :: {-# UNPACK #-} !Word32 - , txInitRbfTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { tx_init_rbf_channel_id :: !ChannelId + , tx_init_rbf_locktime :: {-# UNPACK #-} !Word32 + , tx_init_rbf_feerate :: {-# UNPACK #-} !Word32 + , tx_init_rbf_funding_output_contribution :: !(Maybe Int64) + -- ^ TLV type 0, in satoshis + , tx_init_rbf_require_confirmed_inputs :: !Bool + -- ^ TLV type 2 + , tx_init_rbf_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxInitRbf --- | The tx_ack_rbf message (type 73). --- --- Acknowledges an RBF attempt. +-- | The @tx_ack_rbf@ message (type 73). data TxAckRbf = TxAckRbf - { txAckRbfChannelId :: !ChannelId - , txAckRbfTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { tx_ack_rbf_channel_id :: !ChannelId + , tx_ack_rbf_funding_output_contribution :: !(Maybe Int64) + -- ^ TLV type 0, in satoshis + , tx_ack_rbf_require_confirmed_inputs :: !Bool + -- ^ TLV type 2 + , tx_ack_rbf_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxAckRbf --- | The tx_abort message (type 74). --- --- Aborts the collaborative transaction negotiation. +-- | The @tx_abort@ message (type 74). data TxAbort = TxAbort - { txAbortChannelId :: !ChannelId - , txAbortData :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { tx_abort_channel_id :: !ChannelId + , tx_abort_data :: !BS.ByteString + , tx_abort_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData TxAbort --- Channel close --------------------------------------------------------------- +-- channel quiescence --------------------------------------------------------- --- | The stfu message (type 2). --- --- Indicates "SomeThing Fundamental is Underway" - used for channel --- quiescence. +-- | The @stfu@ message (type 2). data Stfu = Stfu - { stfuChannelId :: !ChannelId - , stfuInitiator :: {-# UNPACK #-} !Word8 - } deriving stock (Eq, Show, Generic) + { stfu_channel_id :: !ChannelId + , stfu_initiator :: !Bool + -- ^ whether the sender initiated quiescence (sent as 1 or 0) + , stfu_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData Stfu --- | The shutdown message (type 38). --- --- Initiates closing of the channel. +-- channel close -------------------------------------------------------------- + +-- | The @shutdown@ message (type 38). data Shutdown = Shutdown - { shutdownChannelId :: !ChannelId - , shutdownScriptPubkey :: !ScriptPubKey - } deriving stock (Eq, Show, Generic) + { shutdown_channel_id :: !ChannelId + , shutdown_scriptpubkey :: !ScriptPubKey + , shutdown_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData Shutdown --- | The closing_signed message (type 39). --- --- Used in legacy closing negotiation. -data ClosingSigned = ClosingSigned - { closingSignedChannelId :: !ChannelId - , closingSignedFeeSatoshis :: {-# UNPACK #-} !Satoshis - , closingSignedSignature :: !Signature - , closingSignedTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) - -instance NFData ClosingSigned - --- | The closing_complete message (type 40). --- --- Proposes a closing transaction in the new closing protocol. +-- | The @closing_complete@ message (type 40). data ClosingComplete = ClosingComplete - { closingCompleteChannelId :: !ChannelId - , closingCompleteCloserScript :: !ScriptPubKey - , closingCompleteCloseeScript :: !ScriptPubKey - , closingCompleteFeeSatoshis :: {-# UNPACK #-} !Satoshis - , closingCompleteLocktime :: {-# UNPACK #-} !Word32 - , closingCompleteTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { closing_complete_channel_id :: !ChannelId + , closing_complete_closer_scriptpubkey :: !ScriptPubKey + , closing_complete_closee_scriptpubkey :: !ScriptPubKey + , closing_complete_fee_satoshis :: {-# UNPACK #-} !Satoshi + , closing_complete_locktime :: {-# UNPACK #-} !Word32 + , closing_complete_closer_output_only :: !(Maybe Signature) + -- ^ TLV type 1 + , closing_complete_closee_output_only :: !(Maybe Signature) + -- ^ TLV type 2 + , closing_complete_closer_and_closee_outputs :: !(Maybe Signature) + -- ^ TLV type 3 + , closing_complete_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData ClosingComplete --- | The closing_sig message (type 41). --- --- Signs a closing transaction in the new closing protocol. +-- | The @closing_sig@ message (type 41). A valid @closing_sig@ carries +-- exactly one signature, in a field set in the @closing_complete@ it +-- answers; checking that is left to the caller. data ClosingSig = ClosingSig - { closingSigChannelId :: !ChannelId - , closingSigCloserScript :: !ScriptPubKey - , closingSigCloseeScript :: !ScriptPubKey - , closingSigFeeSatoshis :: {-# UNPACK #-} !Satoshis - , closingSigLocktime :: {-# UNPACK #-} !Word32 - , closingSigTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { closing_sig_channel_id :: !ChannelId + , closing_sig_closer_scriptpubkey :: !ScriptPubKey + , closing_sig_closee_scriptpubkey :: !ScriptPubKey + , closing_sig_fee_satoshis :: {-# UNPACK #-} !Satoshi + , closing_sig_locktime :: {-# UNPACK #-} !Word32 + , closing_sig_closer_output_only :: !(Maybe Signature) + -- ^ TLV type 1 + , closing_sig_closee_output_only :: !(Maybe Signature) + -- ^ TLV type 2 + , closing_sig_closer_and_closee_outputs :: !(Maybe Signature) + -- ^ TLV type 3 + , closing_sig_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData ClosingSig --- Normal operation ------------------------------------------------------------ +-- | The legacy @closing_signed@ message (type 39), used when +-- @option_simple_close@ is not negotiated. +data ClosingSigned = ClosingSigned + { closing_signed_channel_id :: !ChannelId + , closing_signed_fee_satoshis :: {-# UNPACK #-} !Satoshi + , closing_signed_signature :: !Signature + , closing_signed_fee_range :: !(Maybe FeeRange) + -- ^ TLV type 1 + , closing_signed_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) --- | The update_add_htlc message (type 128). --- --- Offers an HTLC to the other node, redeemable in return for a payment --- preimage. +instance NFData ClosingSigned + +-- normal operation ----------------------------------------------------------- + +-- | The @update_add_htlc@ message (type 128). data UpdateAddHtlc = UpdateAddHtlc - { updateAddHtlcChannelId :: !ChannelId - , updateAddHtlcId :: {-# UNPACK #-} !Word64 - , updateAddHtlcAmountMsat :: {-# UNPACK #-} !MilliSatoshis - , updateAddHtlcPaymentHash :: !PaymentHash - , updateAddHtlcCltvExpiry :: {-# UNPACK #-} !Word32 - , updateAddHtlcOnionPacket :: !OnionPacket - , updateAddHtlcTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { update_add_htlc_channel_id :: !ChannelId + , update_add_htlc_id :: !HtlcId + , update_add_htlc_amount_msat :: {-# UNPACK #-} !MilliSatoshi + , update_add_htlc_payment_hash :: !PaymentHash + , update_add_htlc_cltv_expiry :: {-# UNPACK #-} !Word32 + , update_add_htlc_onion_routing_packet :: !OnionRoutingPacket + , update_add_htlc_path_key :: !(Maybe Point) + -- ^ the @blinded_path@ record (TLV type 0) + , update_add_htlc_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData UpdateAddHtlc --- | The update_fulfill_htlc message (type 130). --- --- Supplies the preimage to fulfill an HTLC. +-- | The @update_fulfill_htlc@ message (type 130). data UpdateFulfillHtlc = UpdateFulfillHtlc - { updateFulfillHtlcChannelId :: !ChannelId - , updateFulfillHtlcId :: {-# UNPACK #-} !Word64 - , updateFulfillHtlcPaymentPreimage :: !PaymentPreimage - , updateFulfillHtlcTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { update_fulfill_htlc_channel_id :: !ChannelId + , update_fulfill_htlc_id :: !HtlcId + , update_fulfill_htlc_payment_preimage :: !PaymentPreimage + , update_fulfill_htlc_attribution_data :: !(Maybe AttributionData) + -- ^ TLV type 1 + , update_fulfill_htlc_fulfillment_payload :: !(Maybe BS.ByteString) + -- ^ TLV type 3 + , update_fulfill_htlc_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData UpdateFulfillHtlc --- | The update_fail_htlc message (type 131). --- --- Indicates an HTLC has failed. +-- | The @update_fail_htlc@ message (type 131). data UpdateFailHtlc = UpdateFailHtlc - { updateFailHtlcChannelId :: !ChannelId - , updateFailHtlcId :: {-# UNPACK #-} !Word64 - , updateFailHtlcReason :: !BS.ByteString - , updateFailHtlcTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { update_fail_htlc_channel_id :: !ChannelId + , update_fail_htlc_id :: !HtlcId + , update_fail_htlc_reason :: !BS.ByteString + , update_fail_htlc_attribution_data :: !(Maybe AttributionData) + -- ^ TLV type 1 + , update_fail_htlc_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData UpdateFailHtlc --- | The update_fail_malformed_htlc message (type 135). --- --- Indicates an HTLC could not be parsed. +-- | The @update_fail_malformed_htlc@ message (type 135). data UpdateFailMalformedHtlc = UpdateFailMalformedHtlc - { updateFailMalformedHtlcChannelId :: !ChannelId - , updateFailMalformedHtlcId :: {-# UNPACK #-} !Word64 - , updateFailMalformedHtlcSha256Onion :: !PaymentHash - , updateFailMalformedHtlcFailureCode :: {-# UNPACK #-} !Word16 - } deriving stock (Eq, Show, Generic) + { update_fail_malformed_htlc_channel_id :: !ChannelId + , update_fail_malformed_htlc_id :: !HtlcId + , update_fail_malformed_htlc_sha256_of_onion :: !OnionHash + , update_fail_malformed_htlc_failure_code :: {-# UNPACK #-} !Word16 + , update_fail_malformed_htlc_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData UpdateFailMalformedHtlc --- | The commitment_signed message (type 132). --- --- Applies pending changes and provides signatures for the commitment --- transaction. +-- | The @commitment_signed@ message (type 132). data CommitmentSigned = CommitmentSigned - { commitmentSignedChannelId :: !ChannelId - , commitmentSignedSignature :: !Signature - , commitmentSignedHtlcSignatures :: ![Signature] - } deriving stock (Eq, Show, Generic) + { commitment_signed_channel_id :: !ChannelId + , commitment_signed_signature :: !Signature + , commitment_signed_htlc_signatures :: ![Signature] + , commitment_signed_funding_txid :: !(Maybe TxId) + -- ^ TLV type 1 + , commitment_signed_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData CommitmentSigned --- | The revoke_and_ack message (type 133). --- --- Revokes the previous commitment transaction and acknowledges receipt --- of the commitment_signed. +-- | The @revoke_and_ack@ message (type 133). data RevokeAndAck = RevokeAndAck - { revokeAndAckChannelId :: !ChannelId - , revokeAndAckPerCommitmentSecret :: !Secret - , revokeAndAckNextPerCommitPoint :: !Point - } deriving stock (Eq, Show, Generic) + { revoke_and_ack_channel_id :: !ChannelId + , revoke_and_ack_per_commitment_secret :: !PerCommitmentSecret + , revoke_and_ack_next_per_commitment_point :: !Point + , revoke_and_ack_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData RevokeAndAck --- | The update_fee message (type 134). --- --- Updates the fee rate for commitment transactions. +-- | The @update_fee@ message (type 134). data UpdateFee = UpdateFee - { updateFeeChannelId :: !ChannelId - , updateFeeFeeratePerKw :: {-# UNPACK #-} !Word32 - } deriving stock (Eq, Show, Generic) + { update_fee_channel_id :: !ChannelId + , update_fee_feerate_per_kw :: {-# UNPACK #-} !Word32 + , update_fee_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData UpdateFee --- Reestablishment ------------------------------------------------------------- +-- message retransmission ----------------------------------------------------- --- | The channel_reestablish message (type 136). --- --- Used to re-establish a channel after reconnection. +-- | The @channel_reestablish@ message (type 136). data ChannelReestablish = ChannelReestablish - { channelReestablishChannelId :: !ChannelId - , channelReestablishNextCommitNum :: {-# UNPACK #-} !Word64 - , channelReestablishNextRevocationNum :: {-# UNPACK #-} !Word64 - , channelReestablishYourLastCommitSecret :: !Secret - , channelReestablishMyCurrentCommitPoint :: !Point - , channelReestablishTlvs :: !TlvStream - } deriving stock (Eq, Show, Generic) + { channel_reestablish_channel_id :: !ChannelId + , channel_reestablish_next_commitment_number + :: {-# UNPACK #-} !Word64 + , channel_reestablish_next_revocation_number + :: {-# UNPACK #-} !Word64 + , channel_reestablish_your_last_per_commitment_secret + :: !PerCommitmentSecret + , channel_reestablish_my_current_per_commitment_point :: !Point + , channel_reestablish_next_funding + :: !(Maybe NextFunding) + -- ^ TLV type 1 + , channel_reestablish_tlvs :: !TlvStream + -- ^ unknown TLV records + } deriving (Eq, Show, Generic) instance NFData ChannelReestablish --- Top-level message type ------------------------------------------------------ +-- messages ------------------------------------------------------------------- --- | All BOLT #2 messages. +-- | A BOLT #2 message. data Message - -- Channel establishment v1 - = MsgOpenChannelVal !OpenChannel - | MsgAcceptChannelVal !AcceptChannel - | MsgFundingCreatedVal !FundingCreated - | MsgFundingSignedVal !FundingSigned - | MsgChannelReadyVal !ChannelReady - -- Channel establishment v2 - | MsgOpenChannel2Val !OpenChannel2 - | MsgAcceptChannel2Val !AcceptChannel2 - | MsgTxAddInputVal !TxAddInput - | MsgTxAddOutputVal !TxAddOutput - | MsgTxRemoveInputVal !TxRemoveInput - | MsgTxRemoveOutputVal !TxRemoveOutput - | MsgTxCompleteVal !TxComplete - | MsgTxSignaturesVal !TxSignatures - | MsgTxInitRbfVal !TxInitRbf - | MsgTxAckRbfVal !TxAckRbf - | MsgTxAbortVal !TxAbort - -- Channel close - | MsgStfuVal !Stfu - | MsgShutdownVal !Shutdown - | MsgClosingSignedVal !ClosingSigned - | MsgClosingCompleteVal !ClosingComplete - | MsgClosingSigVal !ClosingSig - -- Normal operation - | MsgUpdateAddHtlcVal !UpdateAddHtlc - | MsgUpdateFulfillHtlcVal !UpdateFulfillHtlc - | MsgUpdateFailHtlcVal !UpdateFailHtlc - | MsgUpdateFailMalformedHtlcVal !UpdateFailMalformedHtlc - | MsgCommitmentSignedVal !CommitmentSigned - | MsgRevokeAndAckVal !RevokeAndAck - | MsgUpdateFeeVal !UpdateFee - -- Reestablishment - | MsgChannelReestablishVal !ChannelReestablish - deriving stock (Eq, Show, Generic) + = MsgOpenChannel !OpenChannel + | MsgAcceptChannel !AcceptChannel + | MsgFundingCreated !FundingCreated + | MsgFundingSigned !FundingSigned + | MsgChannelReady !ChannelReady + | MsgOpenChannel2 !OpenChannel2 + | MsgAcceptChannel2 !AcceptChannel2 + | MsgTxAddInput !TxAddInput + | MsgTxAddOutput !TxAddOutput + | MsgTxRemoveInput !TxRemoveInput + | MsgTxRemoveOutput !TxRemoveOutput + | MsgTxComplete !TxComplete + | MsgTxSignatures !TxSignatures + | MsgTxInitRbf !TxInitRbf + | MsgTxAckRbf !TxAckRbf + | MsgTxAbort !TxAbort + | MsgStfu !Stfu + | MsgShutdown !Shutdown + | MsgClosingComplete !ClosingComplete + | MsgClosingSig !ClosingSig + | MsgClosingSigned !ClosingSigned + | MsgUpdateAddHtlc !UpdateAddHtlc + | MsgUpdateFulfillHtlc !UpdateFulfillHtlc + | MsgUpdateFailHtlc !UpdateFailHtlc + | MsgUpdateFailMalformedHtlc !UpdateFailMalformedHtlc + | MsgCommitmentSigned !CommitmentSigned + | MsgRevokeAndAck !RevokeAndAck + | MsgUpdateFee !UpdateFee + | MsgChannelReestablish !ChannelReestablish + deriving (Eq, Show, Generic) instance NFData Message + +-- | The wire type of a 'Message'. +-- +-- >>> message_type (MsgTxComplete (TxComplete cid BOLT1.empty_tlv_stream)) +-- 70 +message_type :: Message -> Word16 +message_type m = case m of + MsgOpenChannel {} -> 32 + MsgAcceptChannel {} -> 33 + MsgFundingCreated {} -> 34 + MsgFundingSigned {} -> 35 + MsgChannelReady {} -> 36 + MsgOpenChannel2 {} -> 64 + MsgAcceptChannel2 {} -> 65 + MsgTxAddInput {} -> 66 + MsgTxAddOutput {} -> 67 + MsgTxRemoveInput {} -> 68 + MsgTxRemoveOutput {} -> 69 + MsgTxComplete {} -> 70 + MsgTxSignatures {} -> 71 + MsgTxInitRbf {} -> 72 + MsgTxAckRbf {} -> 73 + MsgTxAbort {} -> 74 + MsgStfu {} -> 2 + MsgShutdown {} -> 38 + MsgClosingComplete {} -> 40 + MsgClosingSig {} -> 41 + MsgClosingSigned {} -> 39 + MsgUpdateAddHtlc {} -> 128 + MsgUpdateFulfillHtlc {} -> 130 + MsgUpdateFailHtlc {} -> 131 + MsgUpdateFailMalformedHtlc {} -> 135 + MsgCommitmentSigned {} -> 132 + MsgRevokeAndAck {} -> 133 + MsgUpdateFee {} -> 134 + MsgChannelReestablish {} -> 136 diff --git a/lib/Lightning/Protocol/BOLT2/Types.hs b/lib/Lightning/Protocol/BOLT2/Types.hs --- a/lib/Lightning/Protocol/BOLT2/Types.hs +++ b/lib/Lightning/Protocol/BOLT2/Types.hs @@ -1,8 +1,5 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module: Lightning.Protocol.BOLT2.Types @@ -10,492 +7,189 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- Core types for BOLT #2 peer protocol. --- --- This module provides newtypes for identifiers, amounts, hashes, and --- keys used in the Lightning Network peer protocol. +-- Field types specific to BOLT #2. module Lightning.Protocol.BOLT2.Types ( - -- * Identifiers - ChannelId - , channelId - , unChannelId - - -- * Amounts - , Satoshis(..) - , MilliSatoshis(..) - , satoshisToMsat - , msatToSatoshis - - -- * Cryptographic types - , Signature - , signature - , unSignature - , Point - , point - , unPoint - , PaymentHash - , paymentHash - , unPaymentHash - , PaymentPreimage - , paymentPreimage - , unPaymentPreimage - , Secret - , secret - , unSecret - - -- * Transaction types - , TxId - , txId - , unTxId - , Outpoint(..) + HtlcId(..) + , SerialId(..) , ScriptPubKey - , scriptPubKey - , unScriptPubKey - - -- * Chain types - , ChainHash - , chainHash - , unChainHash - , ShortChannelId(..) - , shortChannelId - , scidBlockHeight - , scidTxIndex - , scidOutputIndex - - -- * Protocol types - , FeatureBits - , featureBits - , unFeatureBits - , OnionPacket - , onionPacket - , unOnionPacket - - -- * Constants - , channelIdLen - , signatureLen - , pointLen - , txIdLen - , chainHashLen - , shortChannelIdLen - , paymentHashLen - , paymentPreimageLen - , onionPacketLen - , secretLen + , script_pubkey + , un_script_pubkey + , Witness + , witness + , un_witness + , OnionRoutingPacket + , onion_routing_packet + , un_onion_routing_packet + , OnionHash + , onion_hash + , un_onion_hash + , AttributionData + , attribution_data + , un_attribution_data + , FeeRange(..) + , NextFunding(..) ) where +import Bitcoin.Prim.Tx (TxId) import Control.DeepSeq (NFData) -import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) import qualified Data.ByteString as BS -import Data.Word (Word16, Word32, Word64) +import Data.Word (Word8, Word64) import GHC.Generics (Generic) - --- constants ------------------------------------------------------------------- - --- | Length of a channel_id in bytes (32). -channelIdLen :: Int -channelIdLen = 32 -{-# INLINE channelIdLen #-} - --- | Length of a signature in bytes (64, compact format). -signatureLen :: Int -signatureLen = 64 -{-# INLINE signatureLen #-} - --- | Length of a compressed secp256k1 public key in bytes (33). -pointLen :: Int -pointLen = 33 -{-# INLINE pointLen #-} - --- | Length of a transaction ID in bytes (32). -txIdLen :: Int -txIdLen = 32 -{-# INLINE txIdLen #-} - --- | Length of a chain hash in bytes (32). -chainHashLen :: Int -chainHashLen = 32 -{-# INLINE chainHashLen #-} - --- | Length of a short_channel_id in bytes (8). -shortChannelIdLen :: Int -shortChannelIdLen = 8 -{-# INLINE shortChannelIdLen #-} - --- | Length of a payment hash in bytes (32). -paymentHashLen :: Int -paymentHashLen = 32 -{-# INLINE paymentHashLen #-} - --- | Length of a payment preimage in bytes (32). -paymentPreimageLen :: Int -paymentPreimageLen = 32 -{-# INLINE paymentPreimageLen #-} - --- | Length of an onion routing packet in bytes (1366). -onionPacketLen :: Int -onionPacketLen = 1366 -{-# INLINE onionPacketLen #-} - --- | Length of a per-commitment secret in bytes (32). -secretLen :: Int -secretLen = 32 -{-# INLINE secretLen #-} - --- identifiers ----------------------------------------------------------------- - --- | A 32-byte channel identifier. --- --- Derived from the funding transaction by XORing @funding_txid@ with --- @funding_output_index@ (big-endian, altering the last 2 bytes). --- --- For v2 channels, derived as @SHA256(lesser-revocation-basepoint || --- greater-revocation-basepoint)@. -newtype ChannelId = ChannelId BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData - --- | Construct a 'ChannelId' from a 32-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 32 bytes. --- --- >>> channelId (BS.replicate 32 0x00) --- Just (ChannelId ...) --- >>> channelId (BS.replicate 31 0x00) --- Nothing -channelId :: BS.ByteString -> Maybe ChannelId -channelId !bs - | BS.length bs == channelIdLen = Just $! ChannelId bs - | otherwise = Nothing -{-# INLINABLE channelId #-} - --- | Extract the underlying 'BS.ByteString' from a 'ChannelId'. -unChannelId :: ChannelId -> BS.ByteString -unChannelId (ChannelId bs) = bs -{-# INLINE unChannelId #-} - --- amounts --------------------------------------------------------------------- - --- | Amount in satoshis (1/100,000,000 of a bitcoin). --- --- Stored as a 'Word64'. Maximum valid value is 21,000,000 * 100,000,000 --- = 2,100,000,000,000,000 satoshis. -newtype Satoshis = Satoshis { unSatoshis :: Word64 } - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (NFData, Num, Enum, Real, Integral) - --- | Amount in millisatoshis (1/1000 of a satoshi). --- --- Stored as a 'Word64'. Used for HTLC amounts and channel balances. -newtype MilliSatoshis = MilliSatoshis { unMilliSatoshis :: Word64 } - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (NFData, Num, Enum, Real, Integral) - --- | Convert 'Satoshis' to 'MilliSatoshis'. --- --- >>> satoshisToMsat (Satoshis 1) --- MilliSatoshis 1000 -satoshisToMsat :: Satoshis -> MilliSatoshis -satoshisToMsat (Satoshis !s) = MilliSatoshis $! s * 1000 -{-# INLINE satoshisToMsat #-} - --- | Convert 'MilliSatoshis' to 'Satoshis', rounding down. --- --- >>> msatToSatoshis (MilliSatoshis 1500) --- Satoshis 1 -msatToSatoshis :: MilliSatoshis -> Satoshis -msatToSatoshis (MilliSatoshis !m) = Satoshis $! m `div` 1000 -{-# INLINE msatToSatoshis #-} - --- cryptographic types --------------------------------------------------------- - --- | A 64-byte compact ECDSA signature. --- --- Used for commitment transaction signatures, HTLC signatures, and --- closing transaction signatures. -newtype Signature = Signature BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData - --- | Construct a 'Signature' from a 64-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 64 bytes. -signature :: BS.ByteString -> Maybe Signature -signature !bs - | BS.length bs == signatureLen = Just $! Signature bs - | otherwise = Nothing -{-# INLINABLE signature #-} - --- | Extract the underlying 'BS.ByteString' from a 'Signature'. -unSignature :: Signature -> BS.ByteString -unSignature (Signature bs) = bs -{-# INLINE unSignature #-} - --- | A 33-byte compressed secp256k1 public key. --- --- Used for funding pubkeys, basepoints, and per-commitment points. -newtype Point = Point BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData - --- | Construct a 'Point' from a 33-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 33 bytes. --- --- Note: This only validates the length. Use secp256k1 libraries for --- full point validation. -point :: BS.ByteString -> Maybe Point -point !bs - | BS.length bs == pointLen = Just $! Point bs - | otherwise = Nothing -{-# INLINABLE point #-} - --- | Extract the underlying 'BS.ByteString' from a 'Point'. -unPoint :: Point -> BS.ByteString -unPoint (Point bs) = bs -{-# INLINE unPoint #-} - --- | A 32-byte SHA256 payment hash. --- --- Used to identify HTLCs. The preimage that hashes to this value is --- required to claim the HTLC. -newtype PaymentHash = PaymentHash BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData - --- | Construct a 'PaymentHash' from a 32-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 32 bytes. -paymentHash :: BS.ByteString -> Maybe PaymentHash -paymentHash !bs - | BS.length bs == paymentHashLen = Just $! PaymentHash bs - | otherwise = Nothing -{-# INLINABLE paymentHash #-} - --- | Extract the underlying 'BS.ByteString' from a 'PaymentHash'. -unPaymentHash :: PaymentHash -> BS.ByteString -unPaymentHash (PaymentHash bs) = bs -{-# INLINE unPaymentHash #-} - --- | A 32-byte payment preimage. --- --- The SHA256 hash of this value produces the corresponding 'PaymentHash'. --- Knowledge of the preimage allows claiming an HTLC. -newtype PaymentPreimage = PaymentPreimage BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData - --- | Construct a 'PaymentPreimage' from a 32-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 32 bytes. -paymentPreimage :: BS.ByteString -> Maybe PaymentPreimage -paymentPreimage !bs - | BS.length bs == paymentPreimageLen = Just $! PaymentPreimage bs - | otherwise = Nothing -{-# INLINABLE paymentPreimage #-} +import Lightning.Protocol.BOLT1 (Satoshi) --- | Extract the underlying 'BS.ByteString' from a 'PaymentPreimage'. -unPaymentPreimage :: PaymentPreimage -> BS.ByteString -unPaymentPreimage (PaymentPreimage bs) = bs -{-# INLINE unPaymentPreimage #-} +-- | An HTLC identifier (the @id@ field of the HTLC messages). The +-- offerer numbers its HTLCs from 0, incrementing by 1. +newtype HtlcId = HtlcId Word64 + deriving (Eq, Ord, Show, Generic) --- | A 32-byte per-commitment secret. --- --- Used in revoke_and_ack and channel_reestablish messages to revoke --- old commitment transactions. -newtype Secret = Secret BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData +instance NFData HtlcId --- | Construct a 'Secret' from a 32-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 32 bytes. -secret :: BS.ByteString -> Maybe Secret -secret !bs - | BS.length bs == secretLen = Just $! Secret bs - | otherwise = Nothing -{-# INLINABLE secret #-} +-- | The @serial_id@ of an input or output in interactive transaction +-- construction. The initiator sends even values, the non-initiator +-- odd ones. +newtype SerialId = SerialId Word64 + deriving (Eq, Ord, Show, Generic) --- | Extract the underlying 'BS.ByteString' from a 'Secret'. -unSecret :: Secret -> BS.ByteString -unSecret (Secret bs) = bs -{-# INLINE unSecret #-} +instance NFData SerialId --- transaction types ----------------------------------------------------------- +-- | A scriptPubKey, at most 65535 bytes (the most a u16 length prefix +-- can describe). +newtype ScriptPubKey = ScriptPubKey BS.ByteString + deriving (Eq, Ord, Show, Generic) --- | A 32-byte transaction identifier. --- --- The double-SHA256 hash of a serialized transaction. -newtype TxId = TxId BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData +instance NFData ScriptPubKey --- | Construct a 'TxId' from a 32-byte 'BS.ByteString'. +-- | Construct a t'ScriptPubKey', failing above 65535 bytes. The script +-- itself isn't checked; the forms acceptable in @shutdown@ depend on +-- negotiated features. -- --- Returns 'Nothing' if the input is not exactly 32 bytes. -txId :: BS.ByteString -> Maybe TxId -txId !bs - | BS.length bs == txIdLen = Just $! TxId bs - | otherwise = Nothing -{-# INLINABLE txId #-} - --- | Extract the underlying 'BS.ByteString' from a 'TxId'. -unTxId :: TxId -> BS.ByteString -unTxId (TxId bs) = bs -{-# INLINE unTxId #-} +-- >>> script_pubkey "\x51\x02\x4e\x73" +-- Just (ScriptPubKey "Q\STXNs") +-- >>> script_pubkey (BS.replicate 65536 0x00) +-- Nothing +script_pubkey :: BS.ByteString -> Maybe ScriptPubKey +script_pubkey bs + | BS.length bs <= 65535 = Just (ScriptPubKey bs) + | otherwise = Nothing +{-# INLINE script_pubkey #-} --- | A transaction outpoint (txid + output index). --- --- Identifies a specific output of a transaction. -data Outpoint = Outpoint - { outpointTxId :: {-# UNPACK #-} !TxId - , outpointVout :: {-# UNPACK #-} !Word32 - } - deriving stock (Eq, Ord, Show, Generic) +-- | The bytes of a t'ScriptPubKey'. +un_script_pubkey :: ScriptPubKey -> BS.ByteString +un_script_pubkey (ScriptPubKey bs) = bs +{-# INLINE un_script_pubkey #-} -instance NFData Outpoint +-- | The serialized witness of one input in @tx_signatures@ (encoded as +-- in Bitcoin's wire protocol), at most 65535 bytes. +newtype Witness = Witness BS.ByteString + deriving (Eq, Ord, Show, Generic) --- | A script pubkey (output script). --- --- Variable length; used in shutdown messages, closing transactions, etc. -newtype ScriptPubKey = ScriptPubKey BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData +instance NFData Witness --- | Construct a 'ScriptPubKey' from a 'BS.ByteString'. +-- | Construct a t'Witness', failing above 65535 bytes. The contents +-- aren't checked. -- --- Accepts any length; validation of script structure is left to higher --- layers. -scriptPubKey :: BS.ByteString -> ScriptPubKey -scriptPubKey = ScriptPubKey -{-# INLINE scriptPubKey #-} +-- >>> witness "\x01\x01\x2a" +-- Just (Witness "\SOH\SOH*") +witness :: BS.ByteString -> Maybe Witness +witness bs + | BS.length bs <= 65535 = Just (Witness bs) + | otherwise = Nothing +{-# INLINE witness #-} --- | Extract the underlying 'BS.ByteString' from a 'ScriptPubKey'. -unScriptPubKey :: ScriptPubKey -> BS.ByteString -unScriptPubKey (ScriptPubKey bs) = bs -{-# INLINE unScriptPubKey #-} +-- | The bytes of a t'Witness'. +un_witness :: Witness -> BS.ByteString +un_witness (Witness bs) = bs +{-# INLINE un_witness #-} --- chain types ----------------------------------------------------------------- +-- | The 1366-byte @onion_routing_packet@ of @update_add_htlc@, kept +-- opaque (BOLT #4 defines its structure). +newtype OnionRoutingPacket = OnionRoutingPacket BS.ByteString + deriving (Eq, Ord, Show, Generic) --- | A 32-byte chain hash. --- --- Identifies the blockchain (typically the genesis block hash). --- Used in @open_channel@ to specify which chain the channel will reside on. -newtype ChainHash = ChainHash BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData +instance NFData OnionRoutingPacket --- | Construct a 'ChainHash' from a 32-byte 'BS.ByteString'. +-- | Construct an t'OnionRoutingPacket' from exactly 1366 bytes. -- --- Returns 'Nothing' if the input is not exactly 32 bytes. -chainHash :: BS.ByteString -> Maybe ChainHash -chainHash !bs - | BS.length bs == chainHashLen = Just $! ChainHash bs - | otherwise = Nothing -{-# INLINABLE chainHash #-} +-- >>> let bs = BS.replicate 1366 0x00 +-- >>> fmap un_onion_routing_packet (onion_routing_packet bs) == Just bs +-- True +-- >>> onion_routing_packet (BS.take 1365 bs) +-- Nothing +onion_routing_packet :: BS.ByteString -> Maybe OnionRoutingPacket +onion_routing_packet bs + | BS.length bs == 1366 = Just (OnionRoutingPacket bs) + | otherwise = Nothing +{-# INLINE onion_routing_packet #-} --- | Extract the underlying 'BS.ByteString' from a 'ChainHash'. -unChainHash :: ChainHash -> BS.ByteString -unChainHash (ChainHash bs) = bs -{-# INLINE unChainHash #-} +-- | The bytes of an t'OnionRoutingPacket'. +un_onion_routing_packet :: OnionRoutingPacket -> BS.ByteString +un_onion_routing_packet (OnionRoutingPacket bs) = bs +{-# INLINE un_onion_routing_packet #-} --- | A short channel identifier (8 bytes). --- --- Encodes the block height (3 bytes), transaction index (3 bytes), and --- output index (2 bytes) of the funding transaction output. --- --- This is a compact representation for referencing channels in gossip --- and routing. -data ShortChannelId = ShortChannelId - { scidBytes :: {-# UNPACK #-} !Word64 - } - deriving stock (Eq, Ord, Show, Generic) +-- | The SHA256 hash of an onion routing packet (the @sha256_of_onion@ +-- field of @update_fail_malformed_htlc@). +newtype OnionHash = OnionHash BS.ByteString + deriving (Eq, Ord, Show, Generic) -instance NFData ShortChannelId +instance NFData OnionHash --- | Construct a 'ShortChannelId' from block height, tx index, and --- output index. --- --- Returns 'Nothing' if any component exceeds its maximum value: --- --- * block height: max 16,777,215 (2^24 - 1) --- * tx index: max 16,777,215 (2^24 - 1) --- * output index: max 65,535 (2^16 - 1) +-- | Construct an t'OnionHash' from exactly 32 bytes. -- --- >>> shortChannelId 800000 1234 0 --- Just (ShortChannelId ...) -shortChannelId - :: Word32 -- ^ Block height (24 bits max) - -> Word32 -- ^ Transaction index (24 bits max) - -> Word16 -- ^ Output index - -> Maybe ShortChannelId -shortChannelId !blockHeight !txIndex !outputIndex - | blockHeight > 0xFFFFFF = Nothing - | txIndex > 0xFFFFFF = Nothing - | otherwise = Just $! ShortChannelId scid - where - !scid = (fromIntegral blockHeight `unsafeShiftL` 40) - .|. (fromIntegral txIndex `unsafeShiftL` 16) - .|. fromIntegral outputIndex -{-# INLINABLE shortChannelId #-} - --- | Extract the block height from a 'ShortChannelId'. -scidBlockHeight :: ShortChannelId -> Word32 -scidBlockHeight (ShortChannelId !w) = - fromIntegral $! (w `unsafeShiftR` 40) .&. 0xFFFFFF -{-# INLINE scidBlockHeight #-} +-- >>> onion_hash (BS.replicate 31 0x00) +-- Nothing +onion_hash :: BS.ByteString -> Maybe OnionHash +onion_hash bs + | BS.length bs == 32 = Just (OnionHash bs) + | otherwise = Nothing +{-# INLINE onion_hash #-} --- | Extract the transaction index from a 'ShortChannelId'. -scidTxIndex :: ShortChannelId -> Word32 -scidTxIndex (ShortChannelId !w) = - fromIntegral $! (w `unsafeShiftR` 16) .&. 0xFFFFFF -{-# INLINE scidTxIndex #-} +-- | The bytes of an t'OnionHash'. +un_onion_hash :: OnionHash -> BS.ByteString +un_onion_hash (OnionHash bs) = bs +{-# INLINE un_onion_hash #-} --- | Extract the output index from a 'ShortChannelId'. -scidOutputIndex :: ShortChannelId -> Word16 -scidOutputIndex (ShortChannelId !w) = fromIntegral $! w .&. 0xFFFF -{-# INLINE scidOutputIndex #-} +-- | The 920-byte @attribution_data@ of @update_fulfill_htlc@ and +-- @update_fail_htlc@: twenty u32 HTLC hold times followed by 210 +-- four-byte truncated HMACs. Kept opaque (BOLT #4 defines its use). +newtype AttributionData = AttributionData BS.ByteString + deriving (Eq, Ord, Show, Generic) --- protocol types -------------------------------------------------------------- +instance NFData AttributionData --- | Feature bits (variable length). +-- | Construct an t'AttributionData' from exactly 920 bytes. -- --- Encodes supported/required features. Even bits indicate required --- features; odd bits indicate optional features. -newtype FeatureBits = FeatureBits BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData +-- >>> let bs = BS.replicate 920 0x00 +-- >>> fmap un_attribution_data (attribution_data bs) == Just bs +-- True +-- >>> attribution_data (BS.drop 1 bs) +-- Nothing +attribution_data :: BS.ByteString -> Maybe AttributionData +attribution_data bs + | BS.length bs == 920 = Just (AttributionData bs) + | otherwise = Nothing +{-# INLINE attribution_data #-} --- | Construct 'FeatureBits' from a 'BS.ByteString'. --- --- Accepts any length; feature bit parsing is left to higher layers. -featureBits :: BS.ByteString -> FeatureBits -featureBits = FeatureBits -{-# INLINE featureBits #-} +-- | The bytes of an t'AttributionData'. +un_attribution_data :: AttributionData -> BS.ByteString +un_attribution_data (AttributionData bs) = bs +{-# INLINE un_attribution_data #-} --- | Extract the underlying 'BS.ByteString' from 'FeatureBits'. -unFeatureBits :: FeatureBits -> BS.ByteString -unFeatureBits (FeatureBits bs) = bs -{-# INLINE unFeatureBits #-} +-- | The @fee_range@ of @closing_signed@: the fees the sender is +-- prepared to pay for the closing transaction. +data FeeRange = FeeRange + { fee_range_min_fee_satoshis :: {-# UNPACK #-} !Satoshi + , fee_range_max_fee_satoshis :: {-# UNPACK #-} !Satoshi + } deriving (Eq, Show, Generic) --- | A 1366-byte onion routing packet. --- --- Contains encrypted routing information for HTLC forwarding, as --- specified in BOLT #4. -newtype OnionPacket = OnionPacket BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - deriving newtype NFData +instance NFData FeeRange --- | Construct an 'OnionPacket' from a 1366-byte 'BS.ByteString'. --- --- Returns 'Nothing' if the input is not exactly 1366 bytes. -onionPacket :: BS.ByteString -> Maybe OnionPacket -onionPacket !bs - | BS.length bs == onionPacketLen = Just $! OnionPacket bs - | otherwise = Nothing -{-# INLINABLE onionPacket #-} +-- | The @next_funding@ record of @channel_reestablish@: an interactive +-- funding transaction whose signatures are still being exchanged. +data NextFunding = NextFunding + { next_funding_txid :: !TxId + , next_funding_retransmit_flags :: {-# UNPACK #-} !Word8 + -- ^ bit 0: the sender wants @commitment_signed@ retransmitted + } deriving (Eq, Show, Generic) --- | Extract the underlying 'BS.ByteString' from an 'OnionPacket'. -unOnionPacket :: OnionPacket -> BS.ByteString -unOnionPacket (OnionPacket bs) = bs -{-# INLINE unOnionPacket #-} +instance NFData NextFunding diff --git a/ppad-bolt2.cabal b/ppad-bolt2.cabal --- a/ppad-bolt2.cabal +++ b/ppad-bolt2.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-bolt2 -version: 0.0.1 +version: 0.1.0 synopsis: Peer protocol per BOLT #2 license: MIT license-file: LICENSE @@ -8,7 +8,7 @@ maintainer: jared@ppad.tech category: Cryptography build-type: Simple -tested-with: GHC == 9.10.3 +tested-with: GHC == { 9.10.3 } extra-doc-files: CHANGELOG description: Peer protocol, per @@ -25,6 +25,7 @@ -Wall exposed-modules: Lightning.Protocol.BOLT2 + other-modules: Lightning.Protocol.BOLT2.Codec Lightning.Protocol.BOLT2.Messages Lightning.Protocol.BOLT2.Types @@ -32,7 +33,9 @@ base >= 4.9 && < 5 , bytestring >= 0.9 && < 0.13 , deepseq >= 1.4 && < 1.6 - , ppad-bolt1 >= 0.0.1 && < 0.1 + , ppad-bolt1 >= 0.1 && < 0.2 + , ppad-bolt9 >= 0.1 && < 0.2 + , ppad-tx >= 0.2 && < 0.3 test-suite bolt2-tests type: exitcode-stdio-1.0 @@ -41,7 +44,7 @@ main-is: Main.hs ghc-options: - -rtsopts -Wall -O2 + -rtsopts -Wall build-depends: base @@ -49,6 +52,8 @@ , ppad-base16 , ppad-bolt1 , ppad-bolt2 + , ppad-bolt9 + , ppad-tx , tasty , tasty-hunit , tasty-quickcheck @@ -58,31 +63,35 @@ default-language: Haskell2010 hs-source-dirs: bench main-is: Main.hs + other-modules: Fixtures ghc-options: - -rtsopts -O2 -Wall -fno-warn-orphans + -rtsopts -O2 -Wall build-depends: base , bytestring , criterion - , deepseq , ppad-bolt1 , ppad-bolt2 + , ppad-bolt9 + , ppad-tx benchmark bolt2-weigh type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: bench main-is: Weight.hs + other-modules: Fixtures ghc-options: - -rtsopts -O2 -Wall -fno-warn-orphans + -rtsopts -O2 -Wall build-depends: base , bytestring - , deepseq , ppad-bolt1 , ppad-bolt2 + , ppad-bolt9 + , ppad-tx , weigh diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,1291 +2,1307 @@ module Main where -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as B16 -import Data.Maybe (fromJust) -import Data.Word (Word8, Word16, Word32, Word64) -import Lightning.Protocol.BOLT1 (TlvStream, unsafeTlvStream) -import Lightning.Protocol.BOLT2 -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -main :: IO () -main = defaultMain $ testGroup "ppad-bolt2" [ - v1_establishment_tests - , v2_establishment_tests - , close_tests - , normal_operation_tests - , reestablish_tests - , error_tests - , property_tests - ] - --- Test data helpers ----------------------------------------------------------- - --- | Create a valid ChannelId (32 bytes). -testChannelId :: ChannelId -testChannelId = fromJust $ channelId (BS.replicate 32 0xab) - --- | Create a valid ChainHash (32 bytes). -testChainHash :: ChainHash -testChainHash = fromJust $ chainHash (BS.replicate 32 0x01) - --- | Create a valid Point (33 bytes). -testPoint :: Point -testPoint = fromJust $ point (BS.pack $ 0x02 : replicate 32 0xff) - --- | Create a second valid Point (33 bytes). -testPoint2 :: Point -testPoint2 = fromJust $ point (BS.pack $ 0x03 : replicate 32 0xee) - --- | Create a valid Signature (64 bytes). -testSignature :: Signature -testSignature = fromJust $ signature (BS.replicate 64 0xcc) - --- | Create a valid TxId (32 bytes). -testTxId :: TxId -testTxId = fromJust $ txId (BS.replicate 32 0xdd) - --- | Create a valid PaymentHash (32 bytes). -testPaymentHash :: PaymentHash -testPaymentHash = fromJust $ paymentHash (BS.replicate 32 0xaa) - --- | Create a valid PaymentPreimage (32 bytes). -testPaymentPreimage :: PaymentPreimage -testPaymentPreimage = fromJust $ paymentPreimage (BS.replicate 32 0xbb) - --- | Create a valid OnionPacket (1366 bytes). -testOnionPacket :: OnionPacket -testOnionPacket = fromJust $ onionPacket (BS.replicate 1366 0x00) - --- | Create a valid Secret (32 bytes). -testSecret :: Secret -testSecret = fromJust $ secret (BS.replicate 32 0x11) - --- | Empty TLV stream for messages. -emptyTlvs :: TlvStream -emptyTlvs = unsafeTlvStream [] - --- V1 Channel Establishment Tests ---------------------------------------------- - -v1_establishment_tests :: TestTree -v1_establishment_tests = testGroup "V1 Channel Establishment" [ - testGroup "OpenChannel" [ - testCase "encode/decode roundtrip" $ do - let msg = OpenChannel - { openChannelChainHash = testChainHash - , openChannelTempChannelId = testChannelId - , openChannelFundingSatoshis = Satoshis 1000000 - , openChannelPushMsat = MilliSatoshis 500000 - , openChannelDustLimitSatoshis = Satoshis 546 - , openChannelMaxHtlcValueInFlight = MilliSatoshis 100000000 - , openChannelChannelReserveSat = Satoshis 10000 - , openChannelHtlcMinimumMsat = MilliSatoshis 1000 - , openChannelFeeratePerKw = 2500 - , openChannelToSelfDelay = 144 - , openChannelMaxAcceptedHtlcs = 483 - , openChannelFundingPubkey = testPoint - , openChannelRevocationBasepoint = testPoint - , openChannelPaymentBasepoint = testPoint - , openChannelDelayedPaymentBase = testPoint - , openChannelHtlcBasepoint = testPoint - , openChannelFirstPerCommitPoint = testPoint - , openChannelChannelFlags = 0x01 - , openChannelTlvs = emptyTlvs - } - encoded = encodeOpenChannel msg - case decodeOpenChannel encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "AcceptChannel" [ - testCase "encode/decode roundtrip" $ do - let msg = AcceptChannel - { acceptChannelTempChannelId = testChannelId - , acceptChannelDustLimitSatoshis = Satoshis 546 - , acceptChannelMaxHtlcValueInFlight = MilliSatoshis 100000000 - , acceptChannelChannelReserveSat = Satoshis 10000 - , acceptChannelHtlcMinimumMsat = MilliSatoshis 1000 - , acceptChannelMinimumDepth = 3 - , acceptChannelToSelfDelay = 144 - , acceptChannelMaxAcceptedHtlcs = 483 - , acceptChannelFundingPubkey = testPoint - , acceptChannelRevocationBasepoint = testPoint - , acceptChannelPaymentBasepoint = testPoint - , acceptChannelDelayedPaymentBase = testPoint - , acceptChannelHtlcBasepoint = testPoint - , acceptChannelFirstPerCommitPoint = testPoint - , acceptChannelTlvs = emptyTlvs - } - encoded = encodeAcceptChannel msg - case decodeAcceptChannel encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "FundingCreated" [ - testCase "encode/decode roundtrip" $ do - let msg = FundingCreated - { fundingCreatedTempChannelId = testChannelId - , fundingCreatedFundingTxid = testTxId - , fundingCreatedFundingOutIdx = 0 - , fundingCreatedSignature = testSignature - } - encoded = encodeFundingCreated msg - case decodeFundingCreated encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "roundtrip with non-zero output index" $ do - let msg = FundingCreated - { fundingCreatedTempChannelId = testChannelId - , fundingCreatedFundingTxid = testTxId - , fundingCreatedFundingOutIdx = 42 - , fundingCreatedSignature = testSignature - } - encoded = encodeFundingCreated msg - case decodeFundingCreated encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "FundingSigned" [ - testCase "encode/decode roundtrip" $ do - let msg = FundingSigned - { fundingSignedChannelId = testChannelId - , fundingSignedSignature = testSignature - } - encoded = encodeFundingSigned msg - case decodeFundingSigned encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "ChannelReady" [ - testCase "encode/decode roundtrip" $ do - let msg = ChannelReady - { channelReadyChannelId = testChannelId - , channelReadySecondPerCommitPoint = testPoint - , channelReadyTlvs = emptyTlvs - } - encoded = encodeChannelReady msg - case decodeChannelReady encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - ] - --- V2 Channel Establishment (Interactive-tx) Tests ---------------------------- - -v2_establishment_tests :: TestTree -v2_establishment_tests = testGroup "V2 Channel Establishment" [ - testGroup "OpenChannel2" [ - testCase "encode/decode roundtrip" $ do - let msg = OpenChannel2 - { openChannel2ChainHash = testChainHash - , openChannel2TempChannelId = testChannelId - , openChannel2FundingFeeratePerkw = 2500 - , openChannel2CommitFeeratePerkw = 2000 - , openChannel2FundingSatoshis = Satoshis 1000000 - , openChannel2DustLimitSatoshis = Satoshis 546 - , openChannel2MaxHtlcValueInFlight = MilliSatoshis 100000000 - , openChannel2HtlcMinimumMsat = MilliSatoshis 1000 - , openChannel2ToSelfDelay = 144 - , openChannel2MaxAcceptedHtlcs = 483 - , openChannel2Locktime = 0 - , openChannel2FundingPubkey = testPoint - , openChannel2RevocationBasepoint = testPoint - , openChannel2PaymentBasepoint = testPoint - , openChannel2DelayedPaymentBase = testPoint - , openChannel2HtlcBasepoint = testPoint - , openChannel2FirstPerCommitPoint = testPoint - , openChannel2SecondPerCommitPoint = testPoint2 - , openChannel2ChannelFlags = 0x00 - , openChannel2Tlvs = emptyTlvs - } - encoded = encodeOpenChannel2 msg - case decodeOpenChannel2 encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "AcceptChannel2" [ - testCase "encode/decode roundtrip" $ do - let msg = AcceptChannel2 - { acceptChannel2TempChannelId = testChannelId - , acceptChannel2FundingSatoshis = Satoshis 500000 - , acceptChannel2DustLimitSatoshis = Satoshis 546 - , acceptChannel2MaxHtlcValueInFlight = MilliSatoshis 100000000 - , acceptChannel2HtlcMinimumMsat = MilliSatoshis 1000 - , acceptChannel2MinimumDepth = 3 - , acceptChannel2ToSelfDelay = 144 - , acceptChannel2MaxAcceptedHtlcs = 483 - , acceptChannel2FundingPubkey = testPoint - , acceptChannel2RevocationBasepoint = testPoint - , acceptChannel2PaymentBasepoint = testPoint - , acceptChannel2DelayedPaymentBase = testPoint - , acceptChannel2HtlcBasepoint = testPoint - , acceptChannel2FirstPerCommitPoint = testPoint - , acceptChannel2SecondPerCommitPoint = testPoint2 - , acceptChannel2Tlvs = emptyTlvs - } - encoded = encodeAcceptChannel2 msg - case decodeAcceptChannel2 encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxAddInput" [ - testCase "encode/decode roundtrip" $ do - let msg = TxAddInput - { txAddInputChannelId = testChannelId - , txAddInputSerialId = 12345 - , txAddInputPrevTx = BS.pack [0x01, 0x02, 0x03, 0x04] - , txAddInputPrevVout = 0 - , txAddInputSequence = 0xfffffffe - } - case encodeTxAddInput msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxAddInput encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "roundtrip with empty prevTx" $ do - let msg = TxAddInput - { txAddInputChannelId = testChannelId - , txAddInputSerialId = 0 - , txAddInputPrevTx = BS.empty - , txAddInputPrevVout = 0 - , txAddInputSequence = 0 - } - case encodeTxAddInput msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxAddInput encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxAddOutput" [ - testCase "encode/decode roundtrip" $ do - let msg = TxAddOutput - { txAddOutputChannelId = testChannelId - , txAddOutputSerialId = 54321 - , txAddOutputSats = Satoshis 100000 - , txAddOutputScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xaa) - } - case encodeTxAddOutput msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxAddOutput encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxRemoveInput" [ - testCase "encode/decode roundtrip" $ do - let msg = TxRemoveInput - { txRemoveInputChannelId = testChannelId - , txRemoveInputSerialId = 12345 - } - encoded = encodeTxRemoveInput msg - case decodeTxRemoveInput encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxRemoveOutput" [ - testCase "encode/decode roundtrip" $ do - let msg = TxRemoveOutput - { txRemoveOutputChannelId = testChannelId - , txRemoveOutputSerialId = 54321 - } - encoded = encodeTxRemoveOutput msg - case decodeTxRemoveOutput encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxComplete" [ - testCase "encode/decode roundtrip" $ do - let msg = TxComplete { txCompleteChannelId = testChannelId } - encoded = encodeTxComplete msg - case decodeTxComplete encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxSignatures" [ - testCase "encode/decode with no witnesses" $ do - let msg = TxSignatures - { txSignaturesChannelId = testChannelId - , txSignaturesTxid = testTxId - , txSignaturesWitnesses = [] - } - case encodeTxSignatures msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxSignatures encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "encode/decode with multiple witnesses" $ do - let w1 = Witness (BS.pack [0x30, 0x44] <> BS.replicate 68 0xaa) - w2 = Witness (BS.pack [0x02] <> BS.replicate 32 0xbb) - msg = TxSignatures - { txSignaturesChannelId = testChannelId - , txSignaturesTxid = testTxId - , txSignaturesWitnesses = [w1, w2] - } - case encodeTxSignatures msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxSignatures encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxInitRbf" [ - testCase "encode/decode roundtrip" $ do - let msg = TxInitRbf - { txInitRbfChannelId = testChannelId - , txInitRbfLocktime = 800000 - , txInitRbfFeerate = 3000 - , txInitRbfTlvs = emptyTlvs - } - encoded = encodeTxInitRbf msg - case decodeTxInitRbf encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxAckRbf" [ - testCase "encode/decode roundtrip" $ do - let msg = TxAckRbf - { txAckRbfChannelId = testChannelId - , txAckRbfTlvs = emptyTlvs - } - encoded = encodeTxAckRbf msg - case decodeTxAckRbf encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "TxAbort" [ - testCase "encode/decode roundtrip" $ do - let msg = TxAbort - { txAbortChannelId = testChannelId - , txAbortData = "transaction abort reason" - } - case encodeTxAbort msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxAbort encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "roundtrip with empty data" $ do - let msg = TxAbort - { txAbortChannelId = testChannelId - , txAbortData = BS.empty - } - case encodeTxAbort msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeTxAbort encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - ] - --- Channel Close Tests --------------------------------------------------------- - -close_tests :: TestTree -close_tests = testGroup "Channel Close" [ - testGroup "Stfu" [ - testCase "encode/decode initiator=1" $ do - let msg = Stfu - { stfuChannelId = testChannelId - , stfuInitiator = 1 - } - encoded = encodeStfu msg - case decodeStfu encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "encode/decode initiator=0" $ do - let msg = Stfu - { stfuChannelId = testChannelId - , stfuInitiator = 0 - } - encoded = encodeStfu msg - case decodeStfu encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "Shutdown" [ - testCase "encode/decode with P2WPKH script" $ do - let script = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xaa) - msg = Shutdown - { shutdownChannelId = testChannelId - , shutdownScriptPubkey = script - } - case encodeShutdown msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeShutdown encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "encode/decode with P2WSH script" $ do - let script = scriptPubKey (BS.pack [0x00, 0x20] <> - BS.replicate 32 0xbb) - msg = Shutdown - { shutdownChannelId = testChannelId - , shutdownScriptPubkey = script - } - case encodeShutdown msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeShutdown encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "ClosingSigned" [ - testCase "encode/decode roundtrip" $ do - let msg = ClosingSigned - { closingSignedChannelId = testChannelId - , closingSignedFeeSatoshis = Satoshis 1000 - , closingSignedSignature = testSignature - , closingSignedTlvs = emptyTlvs - } - encoded = encodeClosingSigned msg - case decodeClosingSigned encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "ClosingComplete" [ - testCase "encode/decode roundtrip" $ do - let closerScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xcc) - closeeScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xdd) - msg = ClosingComplete - { closingCompleteChannelId = testChannelId - , closingCompleteCloserScript = closerScript - , closingCompleteCloseeScript = closeeScript - , closingCompleteFeeSatoshis = Satoshis 500 - , closingCompleteLocktime = 0 - , closingCompleteTlvs = emptyTlvs - } - case encodeClosingComplete msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeClosingComplete encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "ClosingSig" [ - testCase "encode/decode roundtrip" $ do - let closerScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xee) - closeeScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xff) - msg = ClosingSig - { closingSigChannelId = testChannelId - , closingSigCloserScript = closerScript - , closingSigCloseeScript = closeeScript - , closingSigFeeSatoshis = Satoshis 500 - , closingSigLocktime = 100 - , closingSigTlvs = emptyTlvs - } - case encodeClosingSig msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeClosingSig encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - ] - --- Normal Operation Tests ------------------------------------------------------ - -normal_operation_tests :: TestTree -normal_operation_tests = testGroup "Normal Operation" [ - testGroup "UpdateAddHtlc" [ - testCase "encode/decode roundtrip" $ do - let msg = UpdateAddHtlc - { updateAddHtlcChannelId = testChannelId - , updateAddHtlcId = 0 - , updateAddHtlcAmountMsat = MilliSatoshis 10000000 - , updateAddHtlcPaymentHash = testPaymentHash - , updateAddHtlcCltvExpiry = 800144 - , updateAddHtlcOnionPacket = testOnionPacket - , updateAddHtlcTlvs = emptyTlvs - } - encoded = encodeUpdateAddHtlc msg - case decodeUpdateAddHtlc encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "UpdateFulfillHtlc" [ - testCase "encode/decode roundtrip" $ do - let msg = UpdateFulfillHtlc - { updateFulfillHtlcChannelId = testChannelId - , updateFulfillHtlcId = 42 - , updateFulfillHtlcPaymentPreimage = testPaymentPreimage - , updateFulfillHtlcTlvs = emptyTlvs - } - encoded = encodeUpdateFulfillHtlc msg - case decodeUpdateFulfillHtlc encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "UpdateFailHtlc" [ - testCase "encode/decode roundtrip" $ do - let msg = UpdateFailHtlc - { updateFailHtlcChannelId = testChannelId - , updateFailHtlcId = 42 - , updateFailHtlcReason = BS.replicate 32 0xaa - , updateFailHtlcTlvs = emptyTlvs - } - case encodeUpdateFailHtlc msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeUpdateFailHtlc encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "roundtrip with empty reason" $ do - let msg = UpdateFailHtlc - { updateFailHtlcChannelId = testChannelId - , updateFailHtlcId = 0 - , updateFailHtlcReason = BS.empty - , updateFailHtlcTlvs = emptyTlvs - } - case encodeUpdateFailHtlc msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeUpdateFailHtlc encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "UpdateFailMalformedHtlc" [ - testCase "encode/decode roundtrip" $ do - let msg = UpdateFailMalformedHtlc - { updateFailMalformedHtlcChannelId = testChannelId - , updateFailMalformedHtlcId = 42 - , updateFailMalformedHtlcSha256Onion = testPaymentHash - , updateFailMalformedHtlcFailureCode = 0x8002 - } - encoded = encodeUpdateFailMalformedHtlc msg - case decodeUpdateFailMalformedHtlc encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "CommitmentSigned" [ - testCase "encode/decode with no HTLC signatures" $ do - let msg = CommitmentSigned - { commitmentSignedChannelId = testChannelId - , commitmentSignedSignature = testSignature - , commitmentSignedHtlcSignatures = [] - } - case encodeCommitmentSigned msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeCommitmentSigned encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "encode/decode with HTLC signatures" $ do - let sig2 = fromJust $ signature (BS.replicate 64 0xdd) - sig3 = fromJust $ signature (BS.replicate 64 0xee) - msg = CommitmentSigned - { commitmentSignedChannelId = testChannelId - , commitmentSignedSignature = testSignature - , commitmentSignedHtlcSignatures = [sig2, sig3] - } - case encodeCommitmentSigned msg of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeCommitmentSigned encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "RevokeAndAck" [ - testCase "encode/decode roundtrip" $ do - let msg = RevokeAndAck - { revokeAndAckChannelId = testChannelId - , revokeAndAckPerCommitmentSecret = testSecret - , revokeAndAckNextPerCommitPoint = testPoint - } - encoded = encodeRevokeAndAck msg - case decodeRevokeAndAck encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - , testGroup "UpdateFee" [ - testCase "encode/decode roundtrip" $ do - let msg = UpdateFee - { updateFeeChannelId = testChannelId - , updateFeeFeeratePerKw = 5000 - } - encoded = encodeUpdateFee msg - case decodeUpdateFee encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - ] - --- Reestablish Tests ----------------------------------------------------------- - -reestablish_tests :: TestTree -reestablish_tests = testGroup "Channel Reestablish" [ - testCase "encode/decode roundtrip" $ do - let sec = fromJust $ secret (BS.replicate 32 0x22) - msg = ChannelReestablish - { channelReestablishChannelId = testChannelId - , channelReestablishNextCommitNum = 5 - , channelReestablishNextRevocationNum = 4 - , channelReestablishYourLastCommitSecret = sec - , channelReestablishMyCurrentCommitPoint = testPoint - , channelReestablishTlvs = emptyTlvs - } - encoded = encodeChannelReestablish msg - case decodeChannelReestablish encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - , testCase "roundtrip with zero counters" $ do - let sec = fromJust $ secret (BS.replicate 32 0x00) - msg = ChannelReestablish - { channelReestablishChannelId = testChannelId - , channelReestablishNextCommitNum = 1 - , channelReestablishNextRevocationNum = 0 - , channelReestablishYourLastCommitSecret = sec - , channelReestablishMyCurrentCommitPoint = testPoint - , channelReestablishTlvs = emptyTlvs - } - encoded = encodeChannelReestablish msg - case decodeChannelReestablish encoded of - Right (decoded, _) -> decoded @?= msg - Left e -> assertFailure $ "decode failed: " ++ show e - ] - --- Error Condition Tests ------------------------------------------------------- - -error_tests :: TestTree -error_tests = testGroup "Error Conditions" [ - testGroup "Insufficient Bytes" [ - testCase "decodeOpenChannel empty" $ do - case decodeOpenChannel BS.empty of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeOpenChannel too short" $ do - case decodeOpenChannel (BS.replicate 100 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeAcceptChannel too short" $ do - case decodeAcceptChannel (BS.replicate 10 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeFundingCreated too short" $ do - case decodeFundingCreated (BS.replicate 50 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeFundingSigned too short" $ do - case decodeFundingSigned (BS.replicate 30 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeChannelReady too short" $ do - case decodeChannelReady (BS.replicate 32 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeStfu too short" $ do - case decodeStfu (BS.replicate 31 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeShutdown too short" $ do - case decodeShutdown (BS.replicate 32 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeUpdateAddHtlc too short" $ do - case decodeUpdateAddHtlc (BS.replicate 100 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeCommitmentSigned too short" $ do - case decodeCommitmentSigned (BS.replicate 90 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeRevokeAndAck too short" $ do - case decodeRevokeAndAck (BS.replicate 60 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeTxSignatures too short" $ do - case decodeTxSignatures (BS.replicate 60 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - ] - , testGroup "EncodeError - Length Overflow" [ - testCase "encodeShutdown with oversized script" $ do - let script = scriptPubKey (BS.replicate 70000 0x00) - msg = Shutdown - { shutdownChannelId = testChannelId - , shutdownScriptPubkey = script - } - case encodeShutdown msg of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encodeClosingComplete with oversized closer script" $ do - let oversizedScript = scriptPubKey (BS.replicate 70000 0x00) - normalScript = scriptPubKey (BS.replicate 22 0x00) - msg = ClosingComplete - { closingCompleteChannelId = testChannelId - , closingCompleteCloserScript = oversizedScript - , closingCompleteCloseeScript = normalScript - , closingCompleteFeeSatoshis = Satoshis 500 - , closingCompleteLocktime = 0 - , closingCompleteTlvs = emptyTlvs - } - case encodeClosingComplete msg of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encodeClosingComplete with oversized closee script" $ do - let normalScript = scriptPubKey (BS.replicate 22 0x00) - oversizedScript = scriptPubKey (BS.replicate 70000 0x00) - msg = ClosingComplete - { closingCompleteChannelId = testChannelId - , closingCompleteCloserScript = normalScript - , closingCompleteCloseeScript = oversizedScript - , closingCompleteFeeSatoshis = Satoshis 500 - , closingCompleteLocktime = 0 - , closingCompleteTlvs = emptyTlvs - } - case encodeClosingComplete msg of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encodeClosingSig with oversized script" $ do - let oversizedScript = scriptPubKey (BS.replicate 70000 0x00) - normalScript = scriptPubKey (BS.replicate 22 0x00) - msg = ClosingSig - { closingSigChannelId = testChannelId - , closingSigCloserScript = oversizedScript - , closingSigCloseeScript = normalScript - , closingSigFeeSatoshis = Satoshis 500 - , closingSigLocktime = 0 - , closingSigTlvs = emptyTlvs - } - case encodeClosingSig msg of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - ] - , testGroup "Invalid Field Length" [ - testCase "decodeShutdown with invalid script length" $ do - -- channel_id (32 bytes) + script length (2 bytes) claiming more - let encoded = BS.replicate 32 0xab <> - BS.pack [0xff, 0xff] <> -- claims 65535 bytes - BS.replicate 10 0x00 -- only 10 bytes - case decodeShutdown encoded of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeTxAddInput with invalid prevTx length" $ do - -- channel_id (32) + serial_id (8) + len (2) claiming more - let encoded = BS.replicate 32 0xab <> - BS.replicate 8 0x00 <> - BS.pack [0xff, 0xff] <> -- claims 65535 bytes - BS.replicate 10 0x00 -- only 10 bytes - case decodeTxAddInput encoded of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "decodeUpdateFailHtlc with invalid reason length" $ do - -- channel_id (32) + htlc_id (8) + len (2) claiming more - let encoded = BS.replicate 32 0xab <> - BS.replicate 8 0x00 <> - BS.pack [0xff, 0xff] <> -- claims 65535 bytes - BS.replicate 10 0x00 -- only 10 bytes - case decodeUpdateFailHtlc encoded of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - ] - ] - --- Property Tests -------------------------------------------------------------- - -property_tests :: TestTree -property_tests = testGroup "Properties" [ - testProperty "OpenChannel roundtrip" propOpenChannelRoundtrip - , testProperty "AcceptChannel roundtrip" propAcceptChannelRoundtrip - , testProperty "FundingCreated roundtrip" propFundingCreatedRoundtrip - , testProperty "FundingSigned roundtrip" propFundingSignedRoundtrip - , testProperty "ChannelReady roundtrip" propChannelReadyRoundtrip - , testProperty "OpenChannel2 roundtrip" propOpenChannel2Roundtrip - , testProperty "AcceptChannel2 roundtrip" propAcceptChannel2Roundtrip - , testProperty "TxAddInput roundtrip" propTxAddInputRoundtrip - , testProperty "TxAddOutput roundtrip" propTxAddOutputRoundtrip - , testProperty "TxRemoveInput roundtrip" propTxRemoveInputRoundtrip - , testProperty "TxRemoveOutput roundtrip" propTxRemoveOutputRoundtrip - , testProperty "TxComplete roundtrip" propTxCompleteRoundtrip - , testProperty "TxSignatures roundtrip" propTxSignaturesRoundtrip - , testProperty "TxInitRbf roundtrip" propTxInitRbfRoundtrip - , testProperty "TxAckRbf roundtrip" propTxAckRbfRoundtrip - , testProperty "TxAbort roundtrip" propTxAbortRoundtrip - , testProperty "Stfu roundtrip" propStfuRoundtrip - , testProperty "Shutdown roundtrip" propShutdownRoundtrip - , testProperty "ClosingSigned roundtrip" propClosingSignedRoundtrip - , testProperty "ClosingComplete roundtrip" propClosingCompleteRoundtrip - , testProperty "ClosingSig roundtrip" propClosingSigRoundtrip - , testProperty "UpdateAddHtlc roundtrip" propUpdateAddHtlcRoundtrip - , testProperty "UpdateFulfillHtlc roundtrip" propUpdateFulfillHtlcRoundtrip - , testProperty "UpdateFailHtlc roundtrip" propUpdateFailHtlcRoundtrip - , testProperty "UpdateFailMalformedHtlc roundtrip" - propUpdateFailMalformedHtlcRoundtrip - , testProperty "CommitmentSigned roundtrip" propCommitmentSignedRoundtrip - , testProperty "RevokeAndAck roundtrip" propRevokeAndAckRoundtrip - , testProperty "UpdateFee roundtrip" propUpdateFeeRoundtrip - , testProperty "ChannelReestablish roundtrip" propChannelReestablishRoundtrip - ] - --- Property: OpenChannel roundtrip -propOpenChannelRoundtrip :: Property -propOpenChannelRoundtrip = property $ do - let msg = OpenChannel - { openChannelChainHash = testChainHash - , openChannelTempChannelId = testChannelId - , openChannelFundingSatoshis = Satoshis 1000000 - , openChannelPushMsat = MilliSatoshis 500000 - , openChannelDustLimitSatoshis = Satoshis 546 - , openChannelMaxHtlcValueInFlight = MilliSatoshis 100000000 - , openChannelChannelReserveSat = Satoshis 10000 - , openChannelHtlcMinimumMsat = MilliSatoshis 1000 - , openChannelFeeratePerKw = 2500 - , openChannelToSelfDelay = 144 - , openChannelMaxAcceptedHtlcs = 483 - , openChannelFundingPubkey = testPoint - , openChannelRevocationBasepoint = testPoint - , openChannelPaymentBasepoint = testPoint - , openChannelDelayedPaymentBase = testPoint - , openChannelHtlcBasepoint = testPoint - , openChannelFirstPerCommitPoint = testPoint - , openChannelChannelFlags = 0x01 - , openChannelTlvs = emptyTlvs - } - encoded = encodeOpenChannel msg - case decodeOpenChannel encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: AcceptChannel roundtrip -propAcceptChannelRoundtrip :: Property -propAcceptChannelRoundtrip = property $ do - let msg = AcceptChannel - { acceptChannelTempChannelId = testChannelId - , acceptChannelDustLimitSatoshis = Satoshis 546 - , acceptChannelMaxHtlcValueInFlight = MilliSatoshis 100000000 - , acceptChannelChannelReserveSat = Satoshis 10000 - , acceptChannelHtlcMinimumMsat = MilliSatoshis 1000 - , acceptChannelMinimumDepth = 3 - , acceptChannelToSelfDelay = 144 - , acceptChannelMaxAcceptedHtlcs = 483 - , acceptChannelFundingPubkey = testPoint - , acceptChannelRevocationBasepoint = testPoint - , acceptChannelPaymentBasepoint = testPoint - , acceptChannelDelayedPaymentBase = testPoint - , acceptChannelHtlcBasepoint = testPoint - , acceptChannelFirstPerCommitPoint = testPoint - , acceptChannelTlvs = emptyTlvs - } - encoded = encodeAcceptChannel msg - case decodeAcceptChannel encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: FundingCreated roundtrip -propFundingCreatedRoundtrip :: Word16 -> Property -propFundingCreatedRoundtrip outIdx = property $ do - let msg = FundingCreated - { fundingCreatedTempChannelId = testChannelId - , fundingCreatedFundingTxid = testTxId - , fundingCreatedFundingOutIdx = outIdx - , fundingCreatedSignature = testSignature - } - encoded = encodeFundingCreated msg - case decodeFundingCreated encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: FundingSigned roundtrip -propFundingSignedRoundtrip :: Property -propFundingSignedRoundtrip = property $ do - let msg = FundingSigned - { fundingSignedChannelId = testChannelId - , fundingSignedSignature = testSignature - } - encoded = encodeFundingSigned msg - case decodeFundingSigned encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: ChannelReady roundtrip -propChannelReadyRoundtrip :: Property -propChannelReadyRoundtrip = property $ do - let msg = ChannelReady - { channelReadyChannelId = testChannelId - , channelReadySecondPerCommitPoint = testPoint - , channelReadyTlvs = emptyTlvs - } - encoded = encodeChannelReady msg - case decodeChannelReady encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: OpenChannel2 roundtrip -propOpenChannel2Roundtrip :: Property -propOpenChannel2Roundtrip = property $ do - let msg = OpenChannel2 - { openChannel2ChainHash = testChainHash - , openChannel2TempChannelId = testChannelId - , openChannel2FundingFeeratePerkw = 2500 - , openChannel2CommitFeeratePerkw = 2000 - , openChannel2FundingSatoshis = Satoshis 1000000 - , openChannel2DustLimitSatoshis = Satoshis 546 - , openChannel2MaxHtlcValueInFlight = MilliSatoshis 100000000 - , openChannel2HtlcMinimumMsat = MilliSatoshis 1000 - , openChannel2ToSelfDelay = 144 - , openChannel2MaxAcceptedHtlcs = 483 - , openChannel2Locktime = 0 - , openChannel2FundingPubkey = testPoint - , openChannel2RevocationBasepoint = testPoint - , openChannel2PaymentBasepoint = testPoint - , openChannel2DelayedPaymentBase = testPoint - , openChannel2HtlcBasepoint = testPoint - , openChannel2FirstPerCommitPoint = testPoint - , openChannel2SecondPerCommitPoint = testPoint2 - , openChannel2ChannelFlags = 0x00 - , openChannel2Tlvs = emptyTlvs - } - encoded = encodeOpenChannel2 msg - case decodeOpenChannel2 encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: AcceptChannel2 roundtrip -propAcceptChannel2Roundtrip :: Property -propAcceptChannel2Roundtrip = property $ do - let msg = AcceptChannel2 - { acceptChannel2TempChannelId = testChannelId - , acceptChannel2FundingSatoshis = Satoshis 500000 - , acceptChannel2DustLimitSatoshis = Satoshis 546 - , acceptChannel2MaxHtlcValueInFlight = MilliSatoshis 100000000 - , acceptChannel2HtlcMinimumMsat = MilliSatoshis 1000 - , acceptChannel2MinimumDepth = 3 - , acceptChannel2ToSelfDelay = 144 - , acceptChannel2MaxAcceptedHtlcs = 483 - , acceptChannel2FundingPubkey = testPoint - , acceptChannel2RevocationBasepoint = testPoint - , acceptChannel2PaymentBasepoint = testPoint - , acceptChannel2DelayedPaymentBase = testPoint - , acceptChannel2HtlcBasepoint = testPoint - , acceptChannel2FirstPerCommitPoint = testPoint - , acceptChannel2SecondPerCommitPoint = testPoint2 - , acceptChannel2Tlvs = emptyTlvs - } - encoded = encodeAcceptChannel2 msg - case decodeAcceptChannel2 encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxAddInput roundtrip with varying data -propTxAddInputRoundtrip :: [Word8] -> Word32 -> Word32 -> Property -propTxAddInputRoundtrip prevTxBytes vout seqNum = property $ do - let prevTx = BS.pack (take 1000 prevTxBytes) -- limit size - msg = TxAddInput - { txAddInputChannelId = testChannelId - , txAddInputSerialId = 12345 - , txAddInputPrevTx = prevTx - , txAddInputPrevVout = vout - , txAddInputSequence = seqNum - } - case encodeTxAddInput msg of - Left _ -> False - Right encoded -> case decodeTxAddInput encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxAddOutput roundtrip -propTxAddOutputRoundtrip :: Word64 -> [Word8] -> Property -propTxAddOutputRoundtrip sats scriptBytes = property $ do - let script = scriptPubKey (BS.pack (take 100 scriptBytes)) - msg = TxAddOutput - { txAddOutputChannelId = testChannelId - , txAddOutputSerialId = 54321 - , txAddOutputSats = Satoshis sats - , txAddOutputScript = script - } - case encodeTxAddOutput msg of - Left _ -> False - Right encoded -> case decodeTxAddOutput encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxRemoveInput roundtrip -propTxRemoveInputRoundtrip :: Word64 -> Property -propTxRemoveInputRoundtrip serialId = property $ do - let msg = TxRemoveInput - { txRemoveInputChannelId = testChannelId - , txRemoveInputSerialId = serialId - } - encoded = encodeTxRemoveInput msg - case decodeTxRemoveInput encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxRemoveOutput roundtrip -propTxRemoveOutputRoundtrip :: Word64 -> Property -propTxRemoveOutputRoundtrip serialId = property $ do - let msg = TxRemoveOutput - { txRemoveOutputChannelId = testChannelId - , txRemoveOutputSerialId = serialId - } - encoded = encodeTxRemoveOutput msg - case decodeTxRemoveOutput encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxComplete roundtrip -propTxCompleteRoundtrip :: Property -propTxCompleteRoundtrip = property $ do - let msg = TxComplete { txCompleteChannelId = testChannelId } - encoded = encodeTxComplete msg - case decodeTxComplete encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxSignatures roundtrip with varying witnesses -propTxSignaturesRoundtrip :: [[Word8]] -> Property -propTxSignaturesRoundtrip witnessList = property $ do - let wits = map (Witness . BS.pack . take 200) (take 10 witnessList) - msg = TxSignatures - { txSignaturesChannelId = testChannelId - , txSignaturesTxid = testTxId - , txSignaturesWitnesses = wits - } - case encodeTxSignatures msg of - Left _ -> False - Right encoded -> case decodeTxSignatures encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxInitRbf roundtrip -propTxInitRbfRoundtrip :: Word32 -> Word32 -> Property -propTxInitRbfRoundtrip locktime feerate = property $ do - let msg = TxInitRbf - { txInitRbfChannelId = testChannelId - , txInitRbfLocktime = locktime - , txInitRbfFeerate = feerate - , txInitRbfTlvs = emptyTlvs - } - encoded = encodeTxInitRbf msg - case decodeTxInitRbf encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxAckRbf roundtrip -propTxAckRbfRoundtrip :: Property -propTxAckRbfRoundtrip = property $ do - let msg = TxAckRbf - { txAckRbfChannelId = testChannelId - , txAckRbfTlvs = emptyTlvs - } - encoded = encodeTxAckRbf msg - case decodeTxAckRbf encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: TxAbort roundtrip -propTxAbortRoundtrip :: [Word8] -> Property -propTxAbortRoundtrip dataBytes = property $ do - let abortData = BS.pack (take 1000 dataBytes) - msg = TxAbort - { txAbortChannelId = testChannelId - , txAbortData = abortData - } - case encodeTxAbort msg of - Left _ -> False - Right encoded -> case decodeTxAbort encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: Stfu roundtrip -propStfuRoundtrip :: Word8 -> Property -propStfuRoundtrip initiator = property $ do - let msg = Stfu - { stfuChannelId = testChannelId - , stfuInitiator = initiator - } - encoded = encodeStfu msg - case decodeStfu encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: Shutdown roundtrip -propShutdownRoundtrip :: [Word8] -> Property -propShutdownRoundtrip scriptBytes = property $ do - let script = scriptPubKey (BS.pack (take 100 scriptBytes)) - msg = Shutdown - { shutdownChannelId = testChannelId - , shutdownScriptPubkey = script - } - case encodeShutdown msg of - Left _ -> False - Right encoded -> case decodeShutdown encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: ClosingSigned roundtrip -propClosingSignedRoundtrip :: Word64 -> Property -propClosingSignedRoundtrip feeSats = property $ do - let msg = ClosingSigned - { closingSignedChannelId = testChannelId - , closingSignedFeeSatoshis = Satoshis feeSats - , closingSignedSignature = testSignature - , closingSignedTlvs = emptyTlvs - } - encoded = encodeClosingSigned msg - case decodeClosingSigned encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: ClosingComplete roundtrip -propClosingCompleteRoundtrip :: Word64 -> Word32 -> Property -propClosingCompleteRoundtrip feeSats locktime = property $ do - let closerScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xcc) - closeeScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xdd) - msg = ClosingComplete - { closingCompleteChannelId = testChannelId - , closingCompleteCloserScript = closerScript - , closingCompleteCloseeScript = closeeScript - , closingCompleteFeeSatoshis = Satoshis feeSats - , closingCompleteLocktime = locktime - , closingCompleteTlvs = emptyTlvs - } - case encodeClosingComplete msg of - Left _ -> False - Right encoded -> case decodeClosingComplete encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: ClosingSig roundtrip -propClosingSigRoundtrip :: Word64 -> Word32 -> Property -propClosingSigRoundtrip feeSats locktime = property $ do - let closerScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xee) - closeeScript = scriptPubKey (BS.pack [0x00, 0x14] <> - BS.replicate 20 0xff) - msg = ClosingSig - { closingSigChannelId = testChannelId - , closingSigCloserScript = closerScript - , closingSigCloseeScript = closeeScript - , closingSigFeeSatoshis = Satoshis feeSats - , closingSigLocktime = locktime - , closingSigTlvs = emptyTlvs - } - case encodeClosingSig msg of - Left _ -> False - Right encoded -> case decodeClosingSig encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: UpdateAddHtlc roundtrip -propUpdateAddHtlcRoundtrip :: Word64 -> Word64 -> Word32 -> Property -propUpdateAddHtlcRoundtrip htlcId amountMsat cltvExpiry = property $ do - let msg = UpdateAddHtlc - { updateAddHtlcChannelId = testChannelId - , updateAddHtlcId = htlcId - , updateAddHtlcAmountMsat = MilliSatoshis amountMsat - , updateAddHtlcPaymentHash = testPaymentHash - , updateAddHtlcCltvExpiry = cltvExpiry - , updateAddHtlcOnionPacket = testOnionPacket - , updateAddHtlcTlvs = emptyTlvs - } - encoded = encodeUpdateAddHtlc msg - case decodeUpdateAddHtlc encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: UpdateFulfillHtlc roundtrip -propUpdateFulfillHtlcRoundtrip :: Word64 -> Property -propUpdateFulfillHtlcRoundtrip htlcId = property $ do - let msg = UpdateFulfillHtlc - { updateFulfillHtlcChannelId = testChannelId - , updateFulfillHtlcId = htlcId - , updateFulfillHtlcPaymentPreimage = testPaymentPreimage - , updateFulfillHtlcTlvs = emptyTlvs - } - encoded = encodeUpdateFulfillHtlc msg - case decodeUpdateFulfillHtlc encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: UpdateFailHtlc roundtrip -propUpdateFailHtlcRoundtrip :: Word64 -> [Word8] -> Property -propUpdateFailHtlcRoundtrip htlcId reasonBytes = property $ do - let failReason = BS.pack (take 1000 reasonBytes) - msg = UpdateFailHtlc - { updateFailHtlcChannelId = testChannelId - , updateFailHtlcId = htlcId - , updateFailHtlcReason = failReason - , updateFailHtlcTlvs = emptyTlvs - } - case encodeUpdateFailHtlc msg of - Left _ -> False - Right encoded -> case decodeUpdateFailHtlc encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: UpdateFailMalformedHtlc roundtrip -propUpdateFailMalformedHtlcRoundtrip :: Word64 -> Word16 -> Property -propUpdateFailMalformedHtlcRoundtrip htlcId failCode = property $ do - let msg = UpdateFailMalformedHtlc - { updateFailMalformedHtlcChannelId = testChannelId - , updateFailMalformedHtlcId = htlcId - , updateFailMalformedHtlcSha256Onion = testPaymentHash - , updateFailMalformedHtlcFailureCode = failCode - } - encoded = encodeUpdateFailMalformedHtlc msg - case decodeUpdateFailMalformedHtlc encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: CommitmentSigned roundtrip with varying HTLC count -propCommitmentSignedRoundtrip :: NonNegative Int -> Property -propCommitmentSignedRoundtrip (NonNegative n) = property $ do - let numHtlcs = n `mod` 10 -- limit to 10 HTLCs for test speed - htlcSigs = replicate numHtlcs testSignature - msg = CommitmentSigned - { commitmentSignedChannelId = testChannelId - , commitmentSignedSignature = testSignature - , commitmentSignedHtlcSignatures = htlcSigs - } - case encodeCommitmentSigned msg of - Left _ -> False - Right encoded -> case decodeCommitmentSigned encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: RevokeAndAck roundtrip -propRevokeAndAckRoundtrip :: Property -propRevokeAndAckRoundtrip = property $ do - let msg = RevokeAndAck - { revokeAndAckChannelId = testChannelId - , revokeAndAckPerCommitmentSecret = testSecret - , revokeAndAckNextPerCommitPoint = testPoint - } - encoded = encodeRevokeAndAck msg - case decodeRevokeAndAck encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: UpdateFee roundtrip -propUpdateFeeRoundtrip :: Word32 -> Property -propUpdateFeeRoundtrip feerate = property $ do - let msg = UpdateFee - { updateFeeChannelId = testChannelId - , updateFeeFeeratePerKw = feerate - } - encoded = encodeUpdateFee msg - case decodeUpdateFee encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Property: ChannelReestablish roundtrip -propChannelReestablishRoundtrip :: Word64 -> Word64 -> Property -propChannelReestablishRoundtrip nextCommit nextRevoke = property $ do - let sec = fromJust $ secret (BS.replicate 32 0x22) - msg = ChannelReestablish - { channelReestablishChannelId = testChannelId - , channelReestablishNextCommitNum = nextCommit - , channelReestablishNextRevocationNum = nextRevoke - , channelReestablishYourLastCommitSecret = sec - , channelReestablishMyCurrentCommitPoint = testPoint - , channelReestablishTlvs = emptyTlvs - } - encoded = encodeChannelReestablish msg - case decodeChannelReestablish encoded of - Right (decoded, _) -> decoded == msg - Left _ -> False - --- Helpers --------------------------------------------------------------------- - --- | Decode hex string. Returns Nothing on invalid hex. -unhex :: BS.ByteString -> Maybe BS.ByteString -unhex = B16.decode +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' + ]