diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,34 @@ # Changelog -- 0.0.1 (2025-01-25) +- 0.1.0 (2026-10-10) + * A substantial rewrite, with breaking changes throughout: + + * The API is exported from Lightning.Protocol.BOLT1 alone, and uses + snake_case names (e.g. encode_message, channel_id, un_channel_id). + + * Fundamental types are abstract, constructed only via validating + smart constructors. Points must carry a compressed-encoding + prefix. Satoshi and MilliSatoshi are bounded at 21M BTC and + provide checked arithmetic instead of Num. + + * Every message decoder consumes its whole payload and preserves + unknown odd TLV records, so encoding a decoded message reproduces + its wire bytes. Init has typed networks and remote_addr fields, + and uses ppad-bolt9 feature vectors. + + * A single TLV decoder takes the set of known types, rejects + unknown even types, and keeps unknown odd ones. + + * Removed the Envelope type, the minimal signed integer codecs and + the Internal module; added ping_response and fixed-size field + codecs. + + * Fixes TLV decoding, which accepted lengths of 2^63 or more as + empty values. + + * Fixed-width encoders no longer allocate kilobytes per call. + + * Tests now cover every BOLT #1 appendix vector. + +- 0.0.1 (2026-04-18) * Initial release. diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs --- a/bench/Fixtures.hs +++ b/bench/Fixtures.hs @@ -1,433 +1,50 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} --- | --- Module: Fixtures --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Test fixtures for BOLT #1 benchmarks. - module Fixtures where import qualified Data.ByteString as BS -import Data.Maybe (fromJust) +import Data.Maybe (fromMaybe) import Lightning.Protocol.BOLT1 - --- Sample ByteStrings ----------------------------------------------------- - --- | 64-byte sample data. -bytes64 :: BS.ByteString -bytes64 = BS.replicate 64 0xAB -{-# NOINLINE bytes64 #-} - --- | 1KB sample data. -bytes1k :: BS.ByteString -bytes1k = BS.replicate 1024 0xCD -{-# NOINLINE bytes1k #-} - --- | 16KB sample data. -bytes16k :: BS.ByteString -bytes16k = BS.replicate 16384 0xEF -{-# NOINLINE bytes16k #-} - --- Sample chain hashes (32 bytes each) ------------------------------------ - --- | Bitcoin mainnet genesis block hash (reversed, as used in LN). -mainnetChainHash :: ChainHash -mainnetChainHash = fromJust $ chainHash $ BS.pack - [ 0x6f, 0xe2, 0x8c, 0x0a, 0xb6, 0xf1, 0xb3, 0x72 - , 0xc1, 0xa6, 0xa2, 0x46, 0xae, 0x63, 0xf7, 0x4f - , 0x93, 0x1e, 0x83, 0x65, 0xe1, 0x5a, 0x08, 0x9c - , 0x68, 0xd6, 0x19, 0x00, 0x00, 0x00, 0x00, 0x00 - ] -{-# NOINLINE mainnetChainHash #-} - --- | Bitcoin testnet genesis block hash (reversed, as used in LN). -testnetChainHash :: ChainHash -testnetChainHash = fromJust $ chainHash $ BS.pack - [ 0x43, 0x49, 0x7f, 0xd7, 0xf8, 0x26, 0x95, 0x71 - , 0x08, 0xf4, 0xa3, 0x0f, 0xd9, 0xce, 0xc3, 0xae - , 0xba, 0x79, 0x97, 0x20, 0x84, 0xe9, 0x0e, 0xad - , 0x01, 0xea, 0x33, 0x09, 0x00, 0x00, 0x00, 0x00 - ] -{-# NOINLINE testnetChainHash #-} - --- Sample channel IDs (32 bytes each) ------------------------------------- +import qualified Lightning.Protocol.BOLT9 as BOLT9 --- | Sample channel ID (non-zero). -sampleChannelId :: ChannelId -sampleChannelId = fromJust $ channelId $ BS.pack - [ 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08 - , 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10 - , 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18 - , 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20 - ] -{-# NOINLINE sampleChannelId #-} +{-# NOINLINE tlvs #-} +tlvs :: TlvStream +tlvs = fromMaybe empty_tlv_stream $ + tlv_stream [ TlvRecord t (BS.replicate 32 0x2a) | t <- [1, 3 .. 41] ] --- Sample Init messages --------------------------------------------------- +{-# NOINLINE tlvs_bytes #-} +tlvs_bytes :: BS.ByteString +tlvs_bytes = encode_tlv_stream tlvs --- | Minimal Init message (empty features, no TLVs). -minimalInit :: Init -minimalInit = Init - { initGlobalFeatures = BS.empty - , initFeatures = BS.empty - , initTlvs = [] +{-# NOINLINE init_msg #-} +init_msg :: Message +init_msg = MsgInit Init { + init_global_features = BOLT9.parse "" + , init_features = BOLT9.parse "\x02\xaa\x52\x69\xa1" + , init_networks = fmap pure (chain_hash (BS.replicate 32 0x6f)) + , init_remote_addr = Just "\x01\x7f\x00\x00\x01\x26\x07" + , init_tlvs = empty_tlv_stream } -{-# NOINLINE minimalInit #-} --- | Init with feature bits set. -initWithFeatures :: Init -initWithFeatures = Init - { initGlobalFeatures = BS.pack [0x00, 0x01] -- 2 bytes - , initFeatures = BS.pack [0x02, 0xa2] -- data_loss_protect, etc. - , initTlvs = [] - } -{-# NOINLINE initWithFeatures #-} - --- | Init with TLV extensions. -initWithTlvs :: Init -initWithTlvs = Init - { initGlobalFeatures = BS.empty - , initFeatures = BS.pack [0x02, 0xa2] - , initTlvs = [InitNetworks [mainnetChainHash]] - } -{-# NOINLINE initWithTlvs #-} - --- | Init with multiple chain hashes. -initWithMultipleChains :: Init -initWithMultipleChains = Init - { initGlobalFeatures = BS.empty - , initFeatures = BS.pack [0x02, 0xa2] - , initTlvs = [InitNetworks [mainnetChainHash, testnetChainHash]] - } -{-# NOINLINE initWithMultipleChains #-} - --- | Full Init with features and remote_addr TLV. -fullInit :: Init -fullInit = Init - { initGlobalFeatures = BS.pack [0x00, 0x01] - , initFeatures = BS.pack [0x02, 0xa2, 0x01] - , initTlvs = - [ InitNetworks [mainnetChainHash] - , InitRemoteAddr (BS.pack [0x01, 0x7f, 0x00, 0x00, 0x01, 0x27, 0x10]) - ] - } -{-# NOINLINE fullInit #-} - --- Sample Error messages -------------------------------------------------- - --- | Minimal Error message (connection-level, empty data). -minimalError :: Error -minimalError = Error - { errorChannelId = allChannels - , errorData = BS.empty - } -{-# NOINLINE minimalError #-} - --- | Error with channel ID and message. -errorWithData :: Error -errorWithData = Error - { errorChannelId = sampleChannelId - , errorData = "funding transaction failed" - } -{-# NOINLINE errorWithData #-} - --- | Error with longer data. -errorWithLongData :: Error -errorWithLongData = Error - { errorChannelId = sampleChannelId - , errorData = bytes1k - } -{-# NOINLINE errorWithLongData #-} - --- Sample Warning messages ------------------------------------------------ - --- | Minimal Warning message. -minimalWarning :: Warning -minimalWarning = Warning - { warningChannelId = allChannels - , warningData = BS.empty - } -{-# NOINLINE minimalWarning #-} - --- | Warning with message. -warningWithData :: Warning -warningWithData = Warning - { warningChannelId = sampleChannelId - , warningData = "channel fee too low" - } -{-# NOINLINE warningWithData #-} - --- Sample Ping messages --------------------------------------------------- - --- | Minimal Ping (no padding, no response requested). -minimalPing :: Ping -minimalPing = Ping - { pingNumPongBytes = 0 - , pingIgnored = BS.empty - } -{-# NOINLINE minimalPing #-} - --- | Ping with response requested but no padding. -pingWithResponse :: Ping -pingWithResponse = Ping - { pingNumPongBytes = 64 - , pingIgnored = BS.empty - } -{-# NOINLINE pingWithResponse #-} - --- | Ping with padding (64 bytes). -pingWithPadding :: Ping -pingWithPadding = Ping - { pingNumPongBytes = 64 - , pingIgnored = bytes64 - } -{-# NOINLINE pingWithPadding #-} - --- | Ping with large padding (1KB). -pingWithLargePadding :: Ping -pingWithLargePadding = Ping - { pingNumPongBytes = 128 - , pingIgnored = bytes1k - } -{-# NOINLINE pingWithLargePadding #-} - --- Sample Pong messages --------------------------------------------------- - --- | Minimal Pong (no ignored bytes). -minimalPong :: Pong -minimalPong = Pong - { pongIgnored = BS.empty - } -{-# NOINLINE minimalPong #-} - --- | Pong with padding (64 bytes). -pongWithPadding :: Pong -pongWithPadding = Pong - { pongIgnored = bytes64 - } -{-# NOINLINE pongWithPadding #-} - --- | Pong with large padding (1KB). -pongWithLargePadding :: Pong -pongWithLargePadding = Pong - { pongIgnored = bytes1k - } -{-# NOINLINE pongWithLargePadding #-} - --- Sample PeerStorage messages -------------------------------------------- - --- | Minimal PeerStorage (empty blob). -minimalPeerStorage :: PeerStorage -minimalPeerStorage = PeerStorage - { peerStorageBlob = BS.empty - } -{-# NOINLINE minimalPeerStorage #-} - --- | PeerStorage with 1KB blob. -peerStorageSmall :: PeerStorage -peerStorageSmall = PeerStorage - { peerStorageBlob = bytes1k - } -{-# NOINLINE peerStorageSmall #-} - --- | PeerStorage with 16KB blob. -peerStorageLarge :: PeerStorage -peerStorageLarge = PeerStorage - { peerStorageBlob = bytes16k - } -{-# NOINLINE peerStorageLarge #-} - --- Sample PeerStorageRetrieval messages ----------------------------------- - --- | Minimal PeerStorageRetrieval (empty blob). -minimalPeerStorageRetrieval :: PeerStorageRetrieval -minimalPeerStorageRetrieval = PeerStorageRetrieval - { peerStorageRetrievalBlob = BS.empty - } -{-# NOINLINE minimalPeerStorageRetrieval #-} - --- | PeerStorageRetrieval with 1KB blob. -peerStorageRetrievalSmall :: PeerStorageRetrieval -peerStorageRetrievalSmall = PeerStorageRetrieval - { peerStorageRetrievalBlob = bytes1k - } -{-# NOINLINE peerStorageRetrievalSmall #-} - --- | PeerStorageRetrieval with 16KB blob. -peerStorageRetrievalLarge :: PeerStorageRetrieval -peerStorageRetrievalLarge = PeerStorageRetrieval - { peerStorageRetrievalBlob = bytes16k - } -{-# NOINLINE peerStorageRetrievalLarge #-} - --- Sample TLV streams ----------------------------------------------------- - --- | Empty TLV stream. -emptyTlvStream :: TlvStream -emptyTlvStream = unsafeTlvStream [] -{-# NOINLINE emptyTlvStream #-} - --- | TLV stream with 1 record. -smallTlvStream :: TlvStream -smallTlvStream = unsafeTlvStream - [ TlvRecord 1 (BS.replicate 32 0x01) - ] -{-# NOINLINE smallTlvStream #-} - --- | TLV stream with 5 records. -mediumTlvStream :: TlvStream -mediumTlvStream = unsafeTlvStream - [ TlvRecord 1 (BS.replicate 8 0x01) - , TlvRecord 3 (BS.replicate 16 0x03) - , TlvRecord 5 (BS.replicate 32 0x05) - , TlvRecord 7 (BS.replicate 64 0x07) - , TlvRecord 9 (BS.replicate 128 0x09) - ] -{-# NOINLINE mediumTlvStream #-} - --- | TLV stream with 20 records. -largeTlvStream :: TlvStream -largeTlvStream = unsafeTlvStream - [ TlvRecord 1 (BS.replicate 8 0x01) - , TlvRecord 3 (BS.replicate 16 0x02) - , TlvRecord 5 (BS.replicate 8 0x03) - , TlvRecord 7 (BS.replicate 16 0x04) - , TlvRecord 9 (BS.replicate 8 0x05) - , TlvRecord 11 (BS.replicate 16 0x06) - , TlvRecord 13 (BS.replicate 8 0x07) - , TlvRecord 15 (BS.replicate 16 0x08) - , TlvRecord 17 (BS.replicate 8 0x09) - , TlvRecord 19 (BS.replicate 16 0x0a) - , TlvRecord 21 (BS.replicate 8 0x0b) - , TlvRecord 23 (BS.replicate 16 0x0c) - , TlvRecord 25 (BS.replicate 8 0x0d) - , TlvRecord 27 (BS.replicate 16 0x0e) - , TlvRecord 29 (BS.replicate 8 0x0f) - , TlvRecord 31 (BS.replicate 16 0x10) - , TlvRecord 33 (BS.replicate 8 0x11) - , TlvRecord 35 (BS.replicate 16 0x12) - , TlvRecord 37 (BS.replicate 8 0x13) - , TlvRecord 39 (BS.replicate 16 0x14) - ] -{-# NOINLINE largeTlvStream #-} - --- Encoded message bytes (for decode benchmarks) -------------------------- - --- Helper to encode or fail. -encodeOrFail :: Either EncodeError BS.ByteString -> BS.ByteString -encodeOrFail (Right bs) = bs -encodeOrFail (Left _) = error "encodeOrFail: encoding failed" - --- | Encoded minimal Init. -encodedMinimalInit :: BS.ByteString -encodedMinimalInit = encodeOrFail $ encodeEnvelope (MsgInitVal minimalInit) Nothing -{-# NOINLINE encodedMinimalInit #-} - --- | Encoded Init with TLVs. -encodedInitWithTlvs :: BS.ByteString -encodedInitWithTlvs = encodeOrFail $ encodeEnvelope (MsgInitVal initWithTlvs) Nothing -{-# NOINLINE encodedInitWithTlvs #-} - --- | Encoded full Init. -encodedFullInit :: BS.ByteString -encodedFullInit = encodeOrFail $ encodeEnvelope (MsgInitVal fullInit) Nothing -{-# NOINLINE encodedFullInit #-} - --- | Encoded minimal Error. -encodedMinimalError :: BS.ByteString -encodedMinimalError = encodeOrFail $ encodeEnvelope (MsgErrorVal minimalError) Nothing -{-# NOINLINE encodedMinimalError #-} - --- | Encoded Error with data. -encodedErrorWithData :: BS.ByteString -encodedErrorWithData = encodeOrFail $ encodeEnvelope (MsgErrorVal errorWithData) Nothing -{-# NOINLINE encodedErrorWithData #-} - --- | Encoded minimal Warning. -encodedMinimalWarning :: BS.ByteString -encodedMinimalWarning = encodeOrFail $ - encodeEnvelope (MsgWarningVal minimalWarning) Nothing -{-# NOINLINE encodedMinimalWarning #-} - --- | Encoded Warning with data. -encodedWarningWithData :: BS.ByteString -encodedWarningWithData = encodeOrFail $ - encodeEnvelope (MsgWarningVal warningWithData) Nothing -{-# NOINLINE encodedWarningWithData #-} - --- | Encoded minimal Ping. -encodedMinimalPing :: BS.ByteString -encodedMinimalPing = encodeOrFail $ encodeEnvelope (MsgPingVal minimalPing) Nothing -{-# NOINLINE encodedMinimalPing #-} - --- | Encoded Ping with padding. -encodedPingWithPadding :: BS.ByteString -encodedPingWithPadding = encodeOrFail $ - encodeEnvelope (MsgPingVal pingWithPadding) Nothing -{-# NOINLINE encodedPingWithPadding #-} - --- | Encoded Ping with large padding. -encodedPingWithLargePadding :: BS.ByteString -encodedPingWithLargePadding = encodeOrFail $ - encodeEnvelope (MsgPingVal pingWithLargePadding) Nothing -{-# NOINLINE encodedPingWithLargePadding #-} - --- | Encoded minimal Pong. -encodedMinimalPong :: BS.ByteString -encodedMinimalPong = encodeOrFail $ encodeEnvelope (MsgPongVal minimalPong) Nothing -{-# NOINLINE encodedMinimalPong #-} - --- | Encoded Pong with padding. -encodedPongWithPadding :: BS.ByteString -encodedPongWithPadding = encodeOrFail $ - encodeEnvelope (MsgPongVal pongWithPadding) Nothing -{-# NOINLINE encodedPongWithPadding #-} - --- | Encoded minimal PeerStorage. -encodedMinimalPeerStorage :: BS.ByteString -encodedMinimalPeerStorage = encodeOrFail $ - encodeEnvelope (MsgPeerStorageVal minimalPeerStorage) Nothing -{-# NOINLINE encodedMinimalPeerStorage #-} - --- | Encoded PeerStorage with 1KB blob. -encodedPeerStorageSmall :: BS.ByteString -encodedPeerStorageSmall = encodeOrFail $ - encodeEnvelope (MsgPeerStorageVal peerStorageSmall) Nothing -{-# NOINLINE encodedPeerStorageSmall #-} - --- | Encoded minimal PeerStorageRetrieval. -encodedMinimalPeerStorageRetrieval :: BS.ByteString -encodedMinimalPeerStorageRetrieval = encodeOrFail $ - encodeEnvelope (MsgPeerStorageRetrievalVal minimalPeerStorageRetrieval) Nothing -{-# NOINLINE encodedMinimalPeerStorageRetrieval #-} - --- | Encoded PeerStorageRetrieval with 1KB blob. -encodedPeerStorageRetrievalSmall :: BS.ByteString -encodedPeerStorageRetrievalSmall = encodeOrFail $ - encodeEnvelope (MsgPeerStorageRetrievalVal peerStorageRetrievalSmall) Nothing -{-# NOINLINE encodedPeerStorageRetrievalSmall #-} +{-# NOINLINE ping_msg #-} +ping_msg :: Message +ping_msg = MsgPing (Ping 128 (BS.replicate 64 0) empty_tlv_stream) --- Encoded TLV streams (for decode benchmarks) ---------------------------- +{-# NOINLINE error_msg #-} +error_msg :: Message +error_msg = MsgError (Error all_channels (BS.replicate 128 0x61) tlvs) --- | Encoded empty TLV stream. -encodedEmptyTlvStream :: BS.ByteString -encodedEmptyTlvStream = encodeTlvStream emptyTlvStream -{-# NOINLINE encodedEmptyTlvStream #-} +wire :: Message -> BS.ByteString +wire m = either (const BS.empty) id (encode_message m) --- | Encoded small TLV stream (1 record). -encodedSmallTlvStream :: BS.ByteString -encodedSmallTlvStream = encodeTlvStream smallTlvStream -{-# NOINLINE encodedSmallTlvStream #-} +{-# NOINLINE init_bytes #-} +init_bytes :: BS.ByteString +init_bytes = wire init_msg --- | Encoded medium TLV stream (5 records). -encodedMediumTlvStream :: BS.ByteString -encodedMediumTlvStream = encodeTlvStream mediumTlvStream -{-# NOINLINE encodedMediumTlvStream #-} +{-# NOINLINE ping_bytes #-} +ping_bytes :: BS.ByteString +ping_bytes = wire ping_msg --- | Encoded large TLV stream (20 records). -encodedLargeTlvStream :: BS.ByteString -encodedLargeTlvStream = encodeTlvStream largeTlvStream -{-# NOINLINE encodedLargeTlvStream #-} +{-# NOINLINE error_bytes #-} +error_bytes :: BS.ByteString +error_bytes = wire error_msg diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,526 +1,33 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Criterion.Main -import qualified Data.ByteString as BS -import Data.Word (Word16, Word32, Word64) -import Data.Int (Int8, Int16, Int32, Int64) +import Fixtures import Lightning.Protocol.BOLT1 -import Lightning.Protocol.BOLT1.Codec -import Lightning.Protocol.BOLT1.TLV (encodeInitTlvs, encodeTlvRecord, parseInitTlvs) --- Fixtures -------------------------------------------------------------------- - --- Prevent constant folding by marking fixtures as NOINLINE. - -{-# NOINLINE u16Val #-} -u16Val :: Word16 -u16Val = 0x1234 - -{-# NOINLINE u32Val #-} -u32Val :: Word32 -u32Val = 0x12345678 - -{-# NOINLINE u64Val #-} -u64Val :: Word64 -u64Val = 0x123456789ABCDEF0 - -{-# NOINLINE s8Val #-} -s8Val :: Int8 -s8Val = -42 - -{-# NOINLINE s16Val #-} -s16Val :: Int16 -s16Val = -1234 - -{-# NOINLINE s32Val #-} -s32Val :: Int32 -s32Val = -12345678 - -{-# NOINLINE s64Val #-} -s64Val :: Int64 -s64Val = -123456789012345 - --- Truncated values - -{-# NOINLINE tu16Zero #-} -tu16Zero :: Word16 -tu16Zero = 0 - -{-# NOINLINE tu16Small #-} -tu16Small :: Word16 -tu16Small = 0x42 - -{-# NOINLINE tu16Max #-} -tu16Max :: Word16 -tu16Max = 0xFFFF - -{-# NOINLINE tu32Zero #-} -tu32Zero :: Word32 -tu32Zero = 0 - -{-# NOINLINE tu32Small #-} -tu32Small :: Word32 -tu32Small = 0x42 - -{-# NOINLINE tu32Max #-} -tu32Max :: Word32 -tu32Max = 0xFFFFFFFF - -{-# NOINLINE tu64Zero #-} -tu64Zero :: Word64 -tu64Zero = 0 - -{-# NOINLINE tu64Small #-} -tu64Small :: Word64 -tu64Small = 0x42 - -{-# NOINLINE tu64Max #-} -tu64Max :: Word64 -tu64Max = 0xFFFFFFFFFFFFFFFF - --- MinSigned values - -{-# NOINLINE ms0 #-} -ms0 :: Int64 -ms0 = 0 - -{-# NOINLINE ms127 #-} -ms127 :: Int64 -ms127 = 127 - -{-# NOINLINE ms128 #-} -ms128 :: Int64 -ms128 = 128 - -{-# NOINLINE msNeg128 #-} -msNeg128 :: Int64 -msNeg128 = -128 - -{-# NOINLINE msNeg129 #-} -msNeg129 :: Int64 -msNeg129 = -129 - --- BigSize values - -{-# NOINLINE bs0 #-} -bs0 :: Word64 -bs0 = 0 - -{-# NOINLINE bs252 #-} -bs252 :: Word64 -bs252 = 252 - -{-# NOINLINE bs253 #-} -bs253 :: Word64 -bs253 = 253 - -{-# NOINLINE bs65535 #-} -bs65535 :: Word64 -bs65535 = 65535 - -{-# NOINLINE bs65536 #-} -bs65536 :: Word64 -bs65536 = 65536 - -{-# NOINLINE bsLarge #-} -bsLarge :: Word64 -bsLarge = 0x100000000 - --- Encoded bytes for decode benchmarks - -{-# NOINLINE encodedU16 #-} -encodedU16 :: BS.ByteString -encodedU16 = encodeU16 u16Val - -{-# NOINLINE encodedU32 #-} -encodedU32 :: BS.ByteString -encodedU32 = encodeU32 u32Val - -{-# NOINLINE encodedU64 #-} -encodedU64 :: BS.ByteString -encodedU64 = encodeU64 u64Val - -{-# NOINLINE encodedS8 #-} -encodedS8 :: BS.ByteString -encodedS8 = encodeS8 s8Val - -{-# NOINLINE encodedS16 #-} -encodedS16 :: BS.ByteString -encodedS16 = encodeS16 s16Val - -{-# NOINLINE encodedS32 #-} -encodedS32 :: BS.ByteString -encodedS32 = encodeS32 s32Val - -{-# NOINLINE encodedS64 #-} -encodedS64 :: BS.ByteString -encodedS64 = encodeS64 s64Val - -{-# NOINLINE encodedTu16Small #-} -encodedTu16Small :: BS.ByteString -encodedTu16Small = encodeTu16 tu16Small - -{-# NOINLINE encodedTu32Small #-} -encodedTu32Small :: BS.ByteString -encodedTu32Small = encodeTu32 tu32Small - -{-# NOINLINE encodedTu64Small #-} -encodedTu64Small :: BS.ByteString -encodedTu64Small = encodeTu64 tu64Small - -{-# NOINLINE encodedMs127 #-} -encodedMs127 :: BS.ByteString -encodedMs127 = encodeMinSigned ms127 - -{-# NOINLINE encodedMsNeg129 #-} -encodedMsNeg129 :: BS.ByteString -encodedMsNeg129 = encodeMinSigned msNeg129 - -{-# NOINLINE encodedBs0 #-} -encodedBs0 :: BS.ByteString -encodedBs0 = encodeBigSize bs0 - -{-# NOINLINE encodedBs253 #-} -encodedBs253 :: BS.ByteString -encodedBs253 = encodeBigSize bs253 - -{-# NOINLINE encodedBs65536 #-} -encodedBs65536 :: BS.ByteString -encodedBs65536 = encodeBigSize bs65536 - -{-# NOINLINE encodedBsLarge #-} -encodedBsLarge :: BS.ByteString -encodedBsLarge = encodeBigSize bsLarge - --- TLV fixtures - -{-# NOINLINE tlvRec1 #-} -tlvRec1 :: TlvRecord -tlvRec1 = TlvRecord 1 "test" - -{-# NOINLINE tlvRec3 #-} -tlvRec3 :: TlvRecord -tlvRec3 = TlvRecord 3 "addr" - -{-# NOINLINE tlvRec5 #-} -tlvRec5 :: TlvRecord -tlvRec5 = TlvRecord 5 "value" - -{-# NOINLINE tlvStream1 #-} -tlvStream1 :: TlvStream -tlvStream1 = unsafeTlvStream [tlvRec1] - -{-# NOINLINE tlvStream5 #-} -tlvStream5 :: TlvStream -tlvStream5 = unsafeTlvStream - [ TlvRecord 1 "one" - , TlvRecord 3 "three" - , TlvRecord 5 "five" - , TlvRecord 7 "seven" - , TlvRecord 9 "nine" - ] - -{-# NOINLINE tlvStream20 #-} -tlvStream20 :: TlvStream -tlvStream20 = unsafeTlvStream - [ TlvRecord (2*i + 1) (BS.replicate 10 (fromIntegral i)) - | i <- [0..19] - ] - -{-# NOINLINE encodedTlvStream1 #-} -encodedTlvStream1 :: BS.ByteString -encodedTlvStream1 = encodeTlvStream tlvStream1 - -{-# NOINLINE encodedTlvStream5 #-} -encodedTlvStream5 :: BS.ByteString -encodedTlvStream5 = encodeTlvStream tlvStream5 - -{-# NOINLINE encodedTlvStream20 #-} -encodedTlvStream20 :: BS.ByteString -encodedTlvStream20 = encodeTlvStream tlvStream20 - --- Init TLV fixtures - -{-# NOINLINE chainHash1 #-} -chainHash1 :: ChainHash -chainHash1 = case chainHash (BS.replicate 32 0x01) of - Just ch -> ch - Nothing -> error "impossible" - -{-# NOINLINE initTlvNetworks #-} -initTlvNetworks :: [InitTlv] -initTlvNetworks = [InitNetworks [chainHash1]] - -{-# NOINLINE initTlvRemoteAddr #-} -initTlvRemoteAddr :: [InitTlv] -initTlvRemoteAddr = [InitRemoteAddr "127.0.0.1"] - -{-# NOINLINE encodedInitTlvs #-} -encodedInitTlvs :: BS.ByteString -encodedInitTlvs = encodeTlvStream (encodeInitTlvs initTlvNetworks) - --- Message fixtures - -{-# NOINLINE initMinimal #-} -initMinimal :: Init -initMinimal = Init BS.empty BS.empty [] - -{-# NOINLINE initWithTlvs #-} -initWithTlvs :: Init -initWithTlvs = Init (BS.pack [0x00, 0x01]) (BS.pack [0x02, 0x03]) initTlvNetworks - -{-# NOINLINE errorMinimal #-} -errorMinimal :: Error -errorMinimal = Error allChannels BS.empty - -{-# NOINLINE errorWithData #-} -errorWithData :: Error -errorWithData = Error allChannels "Connection reset by peer" - -{-# NOINLINE warningMsg #-} -warningMsg :: Warning -warningMsg = Warning allChannels "Low disk space" - -{-# NOINLINE pingMinimal #-} -pingMinimal :: Ping -pingMinimal = Ping 64 BS.empty - -{-# NOINLINE pingWithPadding #-} -pingWithPadding :: Ping -pingWithPadding = Ping 64 (BS.replicate 64 0x00) - -{-# NOINLINE pongMsg #-} -pongMsg :: Pong -pongMsg = Pong (BS.replicate 64 0x00) - -{-# NOINLINE peerStorageMsg #-} -peerStorageMsg :: PeerStorage -peerStorageMsg = PeerStorage (BS.replicate 100 0xAB) - -{-# NOINLINE peerStorageRetMsg #-} -peerStorageRetMsg :: PeerStorageRetrieval -peerStorageRetMsg = PeerStorageRetrieval (BS.replicate 100 0xCD) - --- Encoded messages for decode benchmarks - -{-# NOINLINE encodedInitMinimal #-} -encodedInitMinimal :: BS.ByteString -encodedInitMinimal = case encodeInit initMinimal of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedInitWithTlvs #-} -encodedInitWithTlvs :: BS.ByteString -encodedInitWithTlvs = case encodeInit initWithTlvs of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedErrorMinimal #-} -encodedErrorMinimal :: BS.ByteString -encodedErrorMinimal = case encodeError errorMinimal of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedErrorWithData #-} -encodedErrorWithData :: BS.ByteString -encodedErrorWithData = case encodeError errorWithData of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedWarning #-} -encodedWarning :: BS.ByteString -encodedWarning = case encodeWarning warningMsg of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedPingMinimal #-} -encodedPingMinimal :: BS.ByteString -encodedPingMinimal = case encodePing pingMinimal of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedPingWithPadding #-} -encodedPingWithPadding :: BS.ByteString -encodedPingWithPadding = case encodePing pingWithPadding of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedPong #-} -encodedPong :: BS.ByteString -encodedPong = case encodePong pongMsg of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedPeerStorage #-} -encodedPeerStorage :: BS.ByteString -encodedPeerStorage = case encodePeerStorage peerStorageMsg of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedPeerStorageRet #-} -encodedPeerStorageRet :: BS.ByteString -encodedPeerStorageRet = case encodePeerStorageRetrieval peerStorageRetMsg of - Right bs -> bs - Left _ -> error "impossible" - --- Envelope fixtures - -{-# NOINLINE msgInit #-} -msgInit :: Message -msgInit = MsgInitVal initMinimal - -{-# NOINLINE msgPing #-} -msgPing :: Message -msgPing = MsgPingVal pingMinimal - -{-# NOINLINE encodedEnvelopeNoExt #-} -encodedEnvelopeNoExt :: BS.ByteString -encodedEnvelopeNoExt = case encodeEnvelope msgPing Nothing of - Right bs -> bs - Left _ -> error "impossible" - -{-# NOINLINE encodedEnvelopeWithExt #-} -encodedEnvelopeWithExt :: BS.ByteString -encodedEnvelopeWithExt = case encodeEnvelope msgPing (Just tlvStream5) of - Right bs -> bs - Left _ -> error "impossible" - --- Main ------------------------------------------------------------------------ - main :: IO () -main = defaultMain - [ bgroup "prim/encode" - [ bench "encodeU16" $ whnf encodeU16 u16Val - , bench "encodeU32" $ whnf encodeU32 u32Val - , bench "encodeU64" $ whnf encodeU64 u64Val - , bench "encodeS8" $ whnf encodeS8 s8Val - , bench "encodeS16" $ whnf encodeS16 s16Val - , bench "encodeS32" $ whnf encodeS32 s32Val - , bench "encodeS64" $ whnf encodeS64 s64Val - , bench "encodeTu16/0" $ whnf encodeTu16 tu16Zero - , bench "encodeTu16/small" $ whnf encodeTu16 tu16Small - , bench "encodeTu16/max" $ whnf encodeTu16 tu16Max - , bench "encodeTu32/0" $ whnf encodeTu32 tu32Zero - , bench "encodeTu32/small" $ whnf encodeTu32 tu32Small - , bench "encodeTu32/max" $ whnf encodeTu32 tu32Max - , bench "encodeTu64/0" $ whnf encodeTu64 tu64Zero - , bench "encodeTu64/small" $ whnf encodeTu64 tu64Small - , bench "encodeTu64/max" $ whnf encodeTu64 tu64Max - , bench "encodeMinSigned/0" $ whnf encodeMinSigned ms0 - , bench "encodeMinSigned/127" $ whnf encodeMinSigned ms127 - , bench "encodeMinSigned/128" $ whnf encodeMinSigned ms128 - , bench "encodeMinSigned/-128" $ whnf encodeMinSigned msNeg128 - , bench "encodeMinSigned/-129" $ whnf encodeMinSigned msNeg129 - , bench "encodeBigSize/0" $ whnf encodeBigSize bs0 - , bench "encodeBigSize/252" $ whnf encodeBigSize bs252 - , bench "encodeBigSize/253" $ whnf encodeBigSize bs253 - , bench "encodeBigSize/65535" $ whnf encodeBigSize bs65535 - , bench "encodeBigSize/65536" $ whnf encodeBigSize bs65536 - , bench "encodeBigSize/large" $ whnf encodeBigSize bsLarge - ] - - , bgroup "prim/decode" - [ bench "decodeU16" $ nf decodeU16 encodedU16 - , bench "decodeU32" $ nf decodeU32 encodedU32 - , bench "decodeU64" $ nf decodeU64 encodedU64 - , bench "decodeS8" $ nf decodeS8 encodedS8 - , bench "decodeS16" $ nf decodeS16 encodedS16 - , bench "decodeS32" $ nf decodeS32 encodedS32 - , bench "decodeS64" $ nf decodeS64 encodedS64 - , bench "decodeTu16" $ nf (decodeTu16 1) encodedTu16Small - , bench "decodeTu32" $ nf (decodeTu32 1) encodedTu32Small - , bench "decodeTu64" $ nf (decodeTu64 1) encodedTu64Small - , bench "decodeMinSigned/1" $ nf (decodeMinSigned 1) encodedMs127 - , bench "decodeMinSigned/2" $ nf (decodeMinSigned 2) encodedMsNeg129 - , bench "decodeBigSize/0" $ nf decodeBigSize encodedBs0 - , bench "decodeBigSize/253" $ nf decodeBigSize encodedBs253 - , bench "decodeBigSize/65536" $ nf decodeBigSize encodedBs65536 - , bench "decodeBigSize/large" $ nf decodeBigSize encodedBsLarge - ] - - , bgroup "tlv/encode" - [ bench "encodeTlvRecord" $ whnf encodeTlvRecord tlvRec1 - , bench "encodeTlvStream/1" $ whnf encodeTlvStream tlvStream1 - , bench "encodeTlvStream/5" $ whnf encodeTlvStream tlvStream5 - , bench "encodeTlvStream/20" $ whnf encodeTlvStream tlvStream20 - , bench "encodeInitTlvs" $ nf encodeInitTlvs initTlvNetworks - ] - - , bgroup "tlv/decode" - [ bench "decodeTlvStreamRaw/1" $ nf decodeTlvStreamRaw encodedTlvStream1 - , bench "decodeTlvStreamRaw/5" $ nf decodeTlvStreamRaw encodedTlvStream5 - , bench "decodeTlvStreamRaw/20" $ nf decodeTlvStreamRaw encodedTlvStream20 - , bench "decodeTlvStream" $ nf decodeTlvStream encodedInitTlvs - , bench "decodeTlvStreamWith" $ - nf (decodeTlvStreamWith (const True)) encodedTlvStream5 - , bench "parseInitTlvs" $ - nf parseInitTlvs (encodeInitTlvs initTlvNetworks) - ] - - , bgroup "message/encode" - [ bench "encodeInit/minimal" $ nf encodeInit initMinimal - , bench "encodeInit/with-tlvs" $ nf encodeInit initWithTlvs - , bench "encodeError/minimal" $ nf encodeError errorMinimal - , bench "encodeError/with-data" $ nf encodeError errorWithData - , bench "encodeWarning" $ nf encodeWarning warningMsg - , bench "encodePing/minimal" $ nf encodePing pingMinimal - , bench "encodePing/with-padding" $ nf encodePing pingWithPadding - , bench "encodePong" $ nf encodePong pongMsg - , bench "encodePeerStorage" $ nf encodePeerStorage peerStorageMsg - , bench "encodePeerStorageRetrieval" $ - nf encodePeerStorageRetrieval peerStorageRetMsg - ] - - , bgroup "message/decode" - [ bench "decodeInit/minimal" $ nf decodeInit encodedInitMinimal - , bench "decodeInit/with-tlvs" $ nf decodeInit encodedInitWithTlvs - , bench "decodeError/minimal" $ nf decodeError encodedErrorMinimal - , bench "decodeError/with-data" $ nf decodeError encodedErrorWithData - , bench "decodeWarning" $ nf decodeWarning encodedWarning - , bench "decodePing/minimal" $ nf decodePing encodedPingMinimal - , bench "decodePing/with-padding" $ nf decodePing encodedPingWithPadding - , bench "decodePong" $ nf decodePong encodedPong - , bench "decodePeerStorage" $ nf decodePeerStorage encodedPeerStorage - , bench "decodePeerStorageRetrieval" $ - nf decodePeerStorageRetrieval encodedPeerStorageRet - ] - - , bgroup "envelope" - [ bench "encodeEnvelope/no-ext" $ nf (encodeEnvelope msgPing) Nothing - , bench "encodeEnvelope/with-ext" $ - nf (encodeEnvelope msgPing) (Just tlvStream5) - , bench "decodeEnvelope/no-ext" $ nf decodeEnvelope encodedEnvelopeNoExt - , bench "decodeEnvelope/with-ext" $ - nf decodeEnvelope encodedEnvelopeWithExt - , bench "decodeEnvelopeWith" $ - nf (decodeEnvelopeWith (const True)) encodedEnvelopeWithExt - ] - - , bgroup "roundtrip" - [ bench "init/minimal" $ nf (decodeInit . forceRight . encodeInit) - initMinimal - , bench "init/with-tlvs" $ nf (decodeInit . forceRight . encodeInit) - initWithTlvs - , bench "error" $ nf (decodeError . forceRight . encodeError) errorWithData - , bench "warning" $ nf (decodeWarning . forceRight . encodeWarning) - warningMsg - , bench "ping" $ nf (decodePing . forceRight . encodePing) pingWithPadding - , bench "pong" $ nf (decodePong . forceRight . encodePong) pongMsg - , bench "peer-storage" $ - nf (decodePeerStorage . forceRight . encodePeerStorage) peerStorageMsg - , bench "peer-storage-retrieval" $ - nf (decodePeerStorageRetrieval . forceRight . encodePeerStorageRetrieval) - peerStorageRetMsg - , bench "envelope" $ nf - (decodeEnvelope . forceRight . encodeEnvelope msgPing) (Just tlvStream5) - ] +main = defaultMain [ + bgroup "primitives" [ + bench "encode_u64" $ nf encode_u64 0x0102030405060708 + , bench "decode_u64" $ nf decode_u64 "\x01\x02\x03\x04\x05\x06\x07\x08" + , bench "encode_tu64" $ nf encode_tu64 0x010203 + , bench "decode_tu64" $ nf decode_tu64 "\x01\x02\x03" + , bench "encode_bigsize (9 bytes)" $ nf encode_bigsize 0x100000000 + , bench "decode_bigsize (9 bytes)" $ + nf decode_bigsize "\xff\x00\x00\x00\x01\x00\x00\x00\x00" + ] + , bgroup "tlv" [ + bench "encode_tlv_stream (21 records)" $ nf encode_tlv_stream tlvs + , bench "decode_tlv_stream (21 records)" $ + nf (decode_tlv_stream (const False)) tlvs_bytes + ] + , bgroup "messages" [ + bench "encode init" $ nf encode_message init_msg + , bench "decode init" $ nf decode_message init_bytes + , bench "encode ping" $ nf encode_message ping_msg + , bench "decode ping" $ nf decode_message ping_bytes + , bench "encode error (with tlvs)" $ nf encode_message error_msg + , bench "decode error (with tlvs)" $ nf decode_message error_bytes + ] ] - --- Helper for roundtrip benchmarks -forceRight :: Either a b -> b -forceRight (Right b) = b -forceRight (Left _) = error "forceRight: Left" -{-# INLINE forceRight #-} diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -1,347 +1,28 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import qualified Data.ByteString as BS -import Data.Word (Word16, Word32, Word64) -import Data.Int (Int8, Int16, Int32, Int64) +import Fixtures import Lightning.Protocol.BOLT1 -import Lightning.Protocol.BOLT1.Codec -import Lightning.Protocol.BOLT1.TLV (encodeTlvRecord) import Weigh --- Fixtures -------------------------------------------------------------------- - --- Prevent constant folding with NOINLINE - -{-# NOINLINE w16Val #-} -w16Val :: Word16 -w16Val = 0x1234 - -{-# NOINLINE w32Val #-} -w32Val :: Word32 -w32Val = 0x12345678 - -{-# NOINLINE w64Val #-} -w64Val :: Word64 -w64Val = 0x0102030405060708 - -{-# NOINLINE s8Val #-} -s8Val :: Int8 -s8Val = -42 - -{-# NOINLINE s16Val #-} -s16Val :: Int16 -s16Val = -1000 - -{-# NOINLINE s32Val #-} -s32Val :: Int32 -s32Val = -100000 - -{-# NOINLINE s64Val #-} -s64Val :: Int64 -s64Val = -10000000000 - -{-# NOINLINE tu16Small #-} -tu16Small :: Word16 -tu16Small = 0x7f - -{-# NOINLINE tu16Full #-} -tu16Full :: Word16 -tu16Full = 0xffff - -{-# NOINLINE tu32Small #-} -tu32Small :: Word32 -tu32Small = 0x42 - -{-# NOINLINE tu32Full #-} -tu32Full :: Word32 -tu32Full = 0xffffffff - -{-# NOINLINE tu64Small #-} -tu64Small :: Word64 -tu64Small = 0x10 - -{-# NOINLINE tu64Full #-} -tu64Full :: Word64 -tu64Full = 0xffffffffffffffff - -{-# NOINLINE bigSizeSmall #-} -bigSizeSmall :: Word64 -bigSizeSmall = 0xfc - -{-# NOINLINE bigSizeMedium #-} -bigSizeMedium :: Word64 -bigSizeMedium = 0x1000 - -{-# NOINLINE bigSizeLarge #-} -bigSizeLarge :: Word64 -bigSizeLarge = 0x100000000 - --- Pre-encoded bytes for decoder benchmarks - -{-# NOINLINE u16Bytes #-} -u16Bytes :: BS.ByteString -u16Bytes = encodeU16 w16Val - -{-# NOINLINE u32Bytes #-} -u32Bytes :: BS.ByteString -u32Bytes = encodeU32 w32Val - -{-# NOINLINE u64Bytes #-} -u64Bytes :: BS.ByteString -u64Bytes = encodeU64 w64Val - -{-# NOINLINE s8Bytes #-} -s8Bytes :: BS.ByteString -s8Bytes = encodeS8 s8Val - -{-# NOINLINE s16Bytes #-} -s16Bytes :: BS.ByteString -s16Bytes = encodeS16 s16Val - -{-# NOINLINE s32Bytes #-} -s32Bytes :: BS.ByteString -s32Bytes = encodeS32 s32Val - -{-# NOINLINE s64Bytes #-} -s64Bytes :: BS.ByteString -s64Bytes = encodeS64 s64Val - -{-# NOINLINE bigSizeBytes #-} -bigSizeBytes :: BS.ByteString -bigSizeBytes = encodeBigSize bigSizeLarge - --- TLV fixtures - -{-# NOINLINE tlvRecord1 #-} -tlvRecord1 :: TlvRecord -tlvRecord1 = TlvRecord 1 "test-value" - -{-# NOINLINE tlvStream1 #-} -tlvStream1 :: TlvStream -tlvStream1 = unsafeTlvStream [tlvRecord1] - -{-# NOINLINE tlvStream5 #-} -tlvStream5 :: TlvStream -tlvStream5 = unsafeTlvStream - [ TlvRecord 1 "value1" - , TlvRecord 3 "value3" - , TlvRecord 5 "value5" - , TlvRecord 7 "value7" - , TlvRecord 9 "value9" - ] - -{-# NOINLINE tlvStream20 #-} -tlvStream20 :: TlvStream -tlvStream20 = unsafeTlvStream - [ TlvRecord (2 * i + 1) (BS.replicate 10 (fromIntegral i)) - | i <- [0..19] - ] - -{-# NOINLINE tlvStreamBytes1 #-} -tlvStreamBytes1 :: BS.ByteString -tlvStreamBytes1 = encodeTlvStream tlvStream1 - -{-# NOINLINE tlvStreamBytes5 #-} -tlvStreamBytes5 :: BS.ByteString -tlvStreamBytes5 = encodeTlvStream tlvStream5 - -{-# NOINLINE tlvStreamBytes20 #-} -tlvStreamBytes20 :: BS.ByteString -tlvStreamBytes20 = encodeTlvStream tlvStream20 - --- Message fixtures - -{-# NOINLINE minimalInit #-} -minimalInit :: Init -minimalInit = Init BS.empty BS.empty [] - -{-# NOINLINE initWithFeatures #-} -initWithFeatures :: Init -initWithFeatures = Init "\x00\x08" "\x00\x0a\x8a" [] - -{-# NOINLINE initWithTlvs #-} -initWithTlvs :: Init -initWithTlvs = Init BS.empty "\x00\x01" [InitRemoteAddr "127.0.0.1"] - -{-# NOINLINE errorMsg #-} -errorMsg :: Error -errorMsg = Error allChannels "something bad happened" - -{-# NOINLINE warningMsg #-} -warningMsg :: Warning -warningMsg = Warning allChannels "something concerning" - -{-# NOINLINE pingMinimal #-} -pingMinimal :: Ping -pingMinimal = Ping 4 BS.empty - -{-# NOINLINE pingWithPadding #-} -pingWithPadding :: Ping -pingWithPadding = Ping 4 (BS.replicate 64 0x00) - -{-# NOINLINE pongMsg #-} -pongMsg :: Pong -pongMsg = Pong (BS.replicate 4 0x00) - -{-# NOINLINE peerStorageMsg #-} -peerStorageMsg :: PeerStorage -peerStorageMsg = PeerStorage (BS.replicate 100 0xab) - -{-# NOINLINE peerStorageRetrievalMsg #-} -peerStorageRetrievalMsg :: PeerStorageRetrieval -peerStorageRetrievalMsg = PeerStorageRetrieval (BS.replicate 50 0xcd) - --- Pre-encoded message bytes for decoder benchmarks - -{-# NOINLINE initMinimalBytes #-} -initMinimalBytes :: BS.ByteString -initMinimalBytes = either (const BS.empty) id (encodeInit minimalInit) - -{-# NOINLINE initWithTlvsBytes #-} -initWithTlvsBytes :: BS.ByteString -initWithTlvsBytes = either (const BS.empty) id (encodeInit initWithTlvs) - -{-# NOINLINE errorBytes #-} -errorBytes :: BS.ByteString -errorBytes = either (const BS.empty) id (encodeError errorMsg) - -{-# NOINLINE warningBytes #-} -warningBytes :: BS.ByteString -warningBytes = either (const BS.empty) id (encodeWarning warningMsg) - -{-# NOINLINE pingMinimalBytes #-} -pingMinimalBytes :: BS.ByteString -pingMinimalBytes = either (const BS.empty) id (encodePing pingMinimal) - -{-# NOINLINE pingWithPaddingBytes #-} -pingWithPaddingBytes :: BS.ByteString -pingWithPaddingBytes = either (const BS.empty) id (encodePing pingWithPadding) - -{-# NOINLINE pongBytes #-} -pongBytes :: BS.ByteString -pongBytes = either (const BS.empty) id (encodePong pongMsg) - -{-# NOINLINE peerStorageBytes #-} -peerStorageBytes :: BS.ByteString -peerStorageBytes = either (const BS.empty) id (encodePeerStorage peerStorageMsg) - -{-# NOINLINE peerStorageRetrievalBytes #-} -peerStorageRetrievalBytes :: BS.ByteString -peerStorageRetrievalBytes = - either (const BS.empty) id (encodePeerStorageRetrieval peerStorageRetrievalMsg) - --- Envelope fixtures - -{-# NOINLINE initMessage #-} -initMessage :: Message -initMessage = MsgInitVal minimalInit - -{-# NOINLINE pingMessage #-} -pingMessage :: Message -pingMessage = MsgPingVal pingMinimal - -{-# NOINLINE envelopeBytes #-} -envelopeBytes :: BS.ByteString -envelopeBytes = either (const BS.empty) id (encodeEnvelope initMessage Nothing) - --- Main ------------------------------------------------------------------------ - main :: IO () main = mainWith $ do - setColumns [Case, Allocated, GCs, Max] - - -- Primitive encoders -------------------------------------------------------- - - wgroup "Primitive Encoders" $ do - func "encodeU16" encodeU16 w16Val - func "encodeU32" encodeU32 w32Val - func "encodeU64" encodeU64 w64Val - func "encodeS8" encodeS8 s8Val - func "encodeS16" encodeS16 s16Val - func "encodeS32" encodeS32 s32Val - func "encodeS64" encodeS64 s64Val - - wgroup "Truncated Unsigned Encoders" $ do - func "encodeTu16/small" encodeTu16 tu16Small - func "encodeTu16/full" encodeTu16 tu16Full - func "encodeTu32/small" encodeTu32 tu32Small - func "encodeTu32/full" encodeTu32 tu32Full - func "encodeTu64/small" encodeTu64 tu64Small - func "encodeTu64/full" encodeTu64 tu64Full - - wgroup "Minimal Signed Encoder" $ do - func "encodeMinSigned/1-byte" encodeMinSigned (0 :: Int64) - func "encodeMinSigned/2-byte" encodeMinSigned (1000 :: Int64) - func "encodeMinSigned/4-byte" encodeMinSigned (100000 :: Int64) - func "encodeMinSigned/8-byte" encodeMinSigned s64Val - - wgroup "BigSize Encoder" $ do - func "encodeBigSize/1-byte" encodeBigSize bigSizeSmall - func "encodeBigSize/3-byte" encodeBigSize bigSizeMedium - func "encodeBigSize/9-byte" encodeBigSize bigSizeLarge - - -- Primitive decoders -------------------------------------------------------- - - wgroup "Primitive Decoders" $ do - func "decodeU16" decodeU16 u16Bytes - func "decodeU32" decodeU32 u32Bytes - func "decodeU64" decodeU64 u64Bytes - func "decodeS8" decodeS8 s8Bytes - func "decodeS16" decodeS16 s16Bytes - func "decodeS32" decodeS32 s32Bytes - func "decodeS64" decodeS64 s64Bytes - func "decodeBigSize" decodeBigSize bigSizeBytes - - -- TLV operations ------------------------------------------------------------ - - wgroup "TLV Encoding" $ do - func "encodeTlvRecord" encodeTlvRecord tlvRecord1 - func "encodeTlvStream/1-record" encodeTlvStream tlvStream1 - func "encodeTlvStream/5-records" encodeTlvStream tlvStream5 - func "encodeTlvStream/20-records" encodeTlvStream tlvStream20 - - wgroup "TLV Decoding" $ do - func "decodeTlvStreamRaw/1-record" decodeTlvStreamRaw tlvStreamBytes1 - func "decodeTlvStreamRaw/5-records" decodeTlvStreamRaw tlvStreamBytes5 - func "decodeTlvStreamRaw/20-records" decodeTlvStreamRaw tlvStreamBytes20 - func "decodeTlvStream/1-record" decodeTlvStream tlvStreamBytes1 - func "decodeTlvStream/5-records" decodeTlvStream tlvStreamBytes5 - - -- Message encoders ---------------------------------------------------------- - - wgroup "Message Encoders" $ do - func "encodeInit/minimal" encodeInit minimalInit - func "encodeInit/with-features" encodeInit initWithFeatures - func "encodeInit/with-tlvs" encodeInit initWithTlvs - func "encodeError" encodeError errorMsg - func "encodeWarning" encodeWarning warningMsg - func "encodePing/minimal" encodePing pingMinimal - func "encodePing/with-padding" encodePing pingWithPadding - func "encodePong" encodePong pongMsg - func "encodePeerStorage" encodePeerStorage peerStorageMsg - func "encodePeerStorageRetrieval" encodePeerStorageRetrieval - peerStorageRetrievalMsg - - -- Message decoders ---------------------------------------------------------- - - wgroup "Message Decoders" $ do - func "decodeInit/minimal" decodeInit initMinimalBytes - func "decodeInit/with-tlvs" decodeInit initWithTlvsBytes - func "decodeError" decodeError errorBytes - func "decodeWarning" decodeWarning warningBytes - func "decodePing/minimal" decodePing pingMinimalBytes - func "decodePing/with-padding" decodePing pingWithPaddingBytes - func "decodePong" decodePong pongBytes - func "decodePeerStorage" decodePeerStorage peerStorageBytes - func "decodePeerStorageRetrieval" decodePeerStorageRetrieval - peerStorageRetrievalBytes - - -- Envelope operations ------------------------------------------------------- - - wgroup "Envelope Operations" $ do - func "encodeEnvelope/init" (flip encodeEnvelope Nothing) initMessage - func "encodeEnvelope/ping" (flip encodeEnvelope Nothing) pingMessage - func "decodeEnvelope" decodeEnvelope envelopeBytes + wgroup "primitives" $ do + func "baseline (weigh overhead)" (+ (1 :: Int)) 1 + func "encode_u16" encode_u16 0x0102 + func "encode_u64" encode_u64 0x0102030405060708 + func "decode_u64" decode_u64 "\x01\x02\x03\x04\x05\x06\x07\x08" + func "encode_tu64" encode_tu64 0x010203 + func "encode_bigsize (9 bytes)" encode_bigsize 0x100000000 + wgroup "tlv" $ do + func "encode_tlv_stream (21 records)" encode_tlv_stream tlvs + func "decode_tlv_stream (21 records)" + (decode_tlv_stream (const False)) tlvs_bytes + wgroup "messages" $ do + func "encode init" encode_message init_msg + func "decode init" decode_message init_bytes + func "encode ping" encode_message ping_msg + func "decode ping" decode_message ping_bytes + func "encode error (with tlvs)" encode_message error_msg + func "decode error (with tlvs)" decode_message error_bytes diff --git a/lib/Lightning/Protocol/BOLT1.hs b/lib/Lightning/Protocol/BOLT1.hs --- a/lib/Lightning/Protocol/BOLT1.hs +++ b/lib/Lightning/Protocol/BOLT1.hs @@ -6,96 +6,152 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- Base protocol for the Lightning Network, per --- [BOLT #1](https://github.com/lightning/bolts/blob/master/01-messaging.md). +-- The base protocol of the Lightning Network, per +-- [BOLT #1](https://github.com/lightning/bolts/blob/master/01-messaging.md): +-- fundamental types and their encodings, the TLV format, and the +-- @init@, @error@, @warning@, @ping@, @pong@, @peer_storage@ and +-- @peer_storage_retrieval@ messages. +-- +-- The fundamental types and TLV machinery here are shared by the other +-- ppad BOLT libraries. module Lightning.Protocol.BOLT1 ( - -- * Message types + -- * Messages Message(..) - , MsgType(..) - , msgTypeWord - - -- * Channel identifiers - , ChannelId - , channelId - , allChannels - - -- ** Setup messages + , message_type , Init(..) , Error(..) , Warning(..) - - -- ** Control messages , Ping(..) , Pong(..) - - -- ** Peer storage + , ping_response , PeerStorage(..) , PeerStorageRetrieval(..) + -- * Encoding and decoding messages + , encode_message + , decode_message + , encode_envelope + , decode_envelope + , EncodeError(..) + , DecodeError(..) + + -- ** Payloads + , encode_init + , decode_init + , encode_error + , decode_error + , encode_warning + , decode_warning + , encode_ping + , decode_ping + , encode_pong + , decode_pong + , encode_peer_storage + , decode_peer_storage + , encode_peer_storage_retrieval + , decode_peer_storage_retrieval + -- * TLV , TlvRecord(..) , TlvStream - , unTlvStream - , tlvStream - , unsafeTlvStream + , tlv_stream + , un_tlv_stream + , empty_tlv_stream + , lookup_tlv + , filter_tlv_stream + , encode_tlv_stream + , decode_tlv_stream , TlvError(..) - , encodeTlvStream - , decodeTlvStream - , decodeTlvStreamWith - , decodeTlvStreamRaw - -- ** Init TLVs - , InitTlv(..) + -- * Fundamental types , ChainHash - , chainHash - , unChainHash - - -- * Message envelope - , Envelope(..) - - -- * Encoding - , EncodeError(..) - , encodeMessage - , encodeEnvelope - - -- * Decoding - , DecodeError(..) - , decodeMessage - , decodeEnvelope - , decodeEnvelopeWith + , chain_hash + , un_chain_hash + , ChannelId + , channel_id + , un_channel_id + , all_channels + , Signature + , signature + , un_signature + , Point + , point + , un_point + , PaymentHash + , payment_hash + , un_payment_hash + , PaymentPreimage + , payment_preimage + , un_payment_preimage + , PerCommitmentSecret + , per_commitment_secret + , un_per_commitment_secret + , ShortChannelId(..) + , short_channel_id + , scid_block_height + , scid_tx_index + , scid_output_index - -- * Primitive encoding - , encodeU16 - , encodeU32 - , encodeU64 - , encodeS8 - , encodeS16 - , encodeS32 - , encodeS64 - , encodeTu16 - , encodeTu32 - , encodeTu64 - , encodeMinSigned - , encodeBigSize + -- ** Amounts + , Satoshi + , satoshi + , un_satoshi + , max_satoshi + , MilliSatoshi + , milli_satoshi + , un_milli_satoshi + , max_milli_satoshi + , sat_to_msat + , msat_to_sat + , add_sat + , sub_sat + , add_msat + , sub_msat - -- * Primitive decoding - , decodeU16 - , decodeU32 - , decodeU64 - , decodeS8 - , decodeS16 - , decodeS32 - , decodeS64 - , decodeTu16 - , decodeTu32 - , decodeTu64 - , decodeMinSigned - , decodeBigSize + -- * Primitive encodings + -- | Decoders return the decoded value and the remaining input, except + -- for the truncated integers, which occupy their whole input. + , encode_u16 + , encode_u32 + , encode_u64 + , decode_u16 + , decode_u32 + , decode_u64 + , encode_s8 + , encode_s16 + , encode_s32 + , encode_s64 + , decode_s8 + , decode_s16 + , decode_s32 + , decode_s64 + , encode_tu16 + , encode_tu32 + , encode_tu64 + , decode_tu16 + , decode_tu32 + , decode_tu64 + , encode_bigsize + , decode_bigsize + , encode_u16_prefixed + , decode_u16_prefixed + , decode_chain_hash + , decode_channel_id + , decode_signature + , decode_point + , decode_payment_hash + , decode_payment_preimage + , decode_per_commitment_secret + , encode_short_channel_id + , decode_short_channel_id + , encode_satoshi + , decode_satoshi + , encode_milli_satoshi + , decode_milli_satoshi ) where --- Re-export from sub-modules +import Lightning.Protocol.BOLT1.Codec +import Lightning.Protocol.BOLT1.Message import Lightning.Protocol.BOLT1.Prim import Lightning.Protocol.BOLT1.TLV -import Lightning.Protocol.BOLT1.Message -import Lightning.Protocol.BOLT1.Codec diff --git a/lib/Lightning/Protocol/BOLT1/Codec.hs b/lib/Lightning/Protocol/BOLT1/Codec.hs --- a/lib/Lightning/Protocol/BOLT1/Codec.hs +++ b/lib/Lightning/Protocol/BOLT1/Codec.hs @@ -1,8 +1,6 @@ -{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -- | -- Module: Lightning.Protocol.BOLT1.Codec @@ -10,340 +8,277 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- Message encoding and decoding for BOLT #1. +-- Encoding and decoding of BOLT #1 messages. module Lightning.Protocol.BOLT1.Codec ( - -- * Encoding errors EncodeError(..) + , DecodeError(..) - -- * Message encoding - , encodeInit - , encodeError - , encodeWarning - , encodePing - , encodePong - , encodePeerStorage - , encodePeerStorageRetrieval - , encodeMessage - , encodeEnvelope + , encode_envelope + , decode_envelope - -- * Decoding errors - , DecodeError(..) + , encode_message + , decode_message - -- * Message decoding - , decodeInit - , decodeError - , decodeWarning - , decodePing - , decodePong - , decodePeerStorage - , decodePeerStorageRetrieval - , decodeMessage - , decodeEnvelope - , decodeEnvelopeWith + , encode_init + , decode_init + , encode_error + , decode_error + , encode_warning + , decode_warning + , encode_ping + , decode_ping + , encode_pong + , decode_pong + , encode_peer_storage + , decode_peer_storage + , encode_peer_storage_retrieval + , decode_peer_storage_retrieval + + , ping_response ) where import Control.DeepSeq (NFData) -import Control.Monad (when, unless) import qualified Data.ByteString as BS import Data.Word (Word16, Word64) import GHC.Generics (Generic) +import Lightning.Protocol.BOLT1.Message import Lightning.Protocol.BOLT1.Prim import Lightning.Protocol.BOLT1.TLV -import Lightning.Protocol.BOLT1.Message - --- Encoding errors ------------------------------------------------------------- +import qualified Lightning.Protocol.BOLT9 as BOLT9 --- | Encoding errors. +-- | Why a message failed to encode. data EncodeError - = EncodeLengthOverflow -- ^ Field length exceeds u16 max (65535 bytes) - | EncodeMessageTooLarge -- ^ Total message size exceeds 65535 bytes - deriving stock (Eq, Show, Generic) + = EncodeLengthOverflow + -- ^ a length-prefixed field exceeds 65535 bytes + | EncodeMessageTooLarge + -- ^ the message (type and payload) exceeds 65535 bytes + | EncodeInvalidTlvs + -- ^ a record in a @_tlvs@ field duplicates a typed field + deriving (Eq, Show, Generic) instance NFData EncodeError --- Message encoding ------------------------------------------------------------ +-- | Why a message failed to decode. +data DecodeError + = DecodeInsufficientBytes + -- ^ the input ended before a field did + | DecodeTlvError !TlvError + -- ^ the message's TLV stream is malformed + | DecodeInvalidTlvValue !Word64 + -- ^ a known TLV record (of the given type) has a malformed value + | DecodeUnknownEvenType !Word16 + -- ^ an unknown even message type; the connection must be closed + | DecodeUnknownOddType !Word16 + -- ^ an unknown odd message type; the message must be ignored + deriving (Eq, Show, Generic) --- | Encode an Init message payload. -encodeInit :: Init -> Either EncodeError BS.ByteString -encodeInit (Init gf feat tlvs) = do - gfLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength gf) - featLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength feat) - Right $ mconcat - [ gfLen - , gf - , featLen - , feat - , encodeTlvStream (encodeInitTlvs tlvs) - ] +instance NFData DecodeError --- | Encode an Error message payload. -encodeError :: Error -> Either EncodeError BS.ByteString -encodeError (Error cid dat) = do - datLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength dat) - Right $ mconcat [unChannelId cid, datLen, dat] +-- framing -------------------------------------------------------------------- --- | Encode a Warning message payload. -encodeWarning :: Warning -> Either EncodeError BS.ByteString -encodeWarning (Warning cid dat) = do - datLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength dat) - Right $ mconcat [unChannelId cid, datLen, dat] +-- | Prefix a payload with its message type. Fails if the result +-- exceeds the 65535-byte message limit. +-- +-- >>> encode_envelope 19 "\NUL\NUL" +-- Right "\NUL\DC3\NUL\NUL" +encode_envelope :: Word16 -> BS.ByteString -> Either EncodeError BS.ByteString +encode_envelope t payload + | BS.length payload > 65533 = Left EncodeMessageTooLarge + | otherwise = Right (encode_u16 t <> payload) --- | Encode a Ping message payload. -encodePing :: Ping -> Either EncodeError BS.ByteString -encodePing (Ping numPong ignored) = do - ignoredLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength ignored) - Right $ mconcat [encodeU16 numPong, ignoredLen, ignored] +-- | Split a message into its type and payload. +-- +-- >>> decode_envelope "\NUL\DC3\NUL\NUL" +-- Right (19,"\NUL\NUL") +decode_envelope :: BS.ByteString -> Either DecodeError (Word16, BS.ByteString) +decode_envelope bs = case decode_u16 bs of + Just r -> Right r + Nothing -> Left DecodeInsufficientBytes --- | Encode a Pong message payload. -encodePong :: Pong -> Either EncodeError BS.ByteString -encodePong (Pong ignored) = do - ignoredLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength ignored) - Right $ mconcat [ignoredLen, ignored] +-- | Encode a BOLT #1 message, including its type. +-- +-- >>> encode_message (MsgPong (Pong "" empty_tlv_stream)) +-- Right "\NUL\DC3\NUL\NUL" +encode_message :: Message -> Either EncodeError BS.ByteString +encode_message m = do + payload <- case m of + MsgInit a -> encode_init a + MsgError a -> encode_error a + MsgWarning a -> encode_warning a + MsgPing a -> encode_ping a + MsgPong a -> encode_pong a + MsgPeerStorage a -> encode_peer_storage a + MsgPeerStorageRetrieval a -> encode_peer_storage_retrieval a + encode_envelope (message_type m) payload --- | Encode a PeerStorage message payload. -encodePeerStorage :: PeerStorage -> Either EncodeError BS.ByteString -encodePeerStorage (PeerStorage blob) = do - blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob) - Right $ mconcat [blobLen, blob] +-- | Decode a BOLT #1 message, including its type. +-- +-- A type that BOLT #1 doesn't define yields 'DecodeUnknownEvenType' +-- or 'DecodeUnknownOddType'; callers dispatching messages from other +-- BOLTs should use 'decode_envelope' first. +-- +-- >>> decode_message "\NUL\DC3\NUL\NUL" +-- Right (MsgPong (Pong {pong_ignored = "", pong_tlvs = TlvStream []})) +-- >>> decode_message "\NUL\DC4\NUL\NUL" +-- Left (DecodeUnknownEvenType 20) +decode_message :: BS.ByteString -> Either DecodeError Message +decode_message bs = do + (t, payload) <- decode_envelope bs + case t of + 16 -> MsgInit <$> decode_init payload + 17 -> MsgError <$> decode_error payload + 1 -> MsgWarning <$> decode_warning payload + 18 -> MsgPing <$> decode_ping payload + 19 -> MsgPong <$> decode_pong payload + 7 -> MsgPeerStorage <$> decode_peer_storage payload + 9 -> MsgPeerStorageRetrieval <$> decode_peer_storage_retrieval payload + _ | even t -> Left (DecodeUnknownEvenType t) + | otherwise -> Left (DecodeUnknownOddType t) --- | Encode a PeerStorageRetrieval message payload. -encodePeerStorageRetrieval - :: PeerStorageRetrieval -> Either EncodeError BS.ByteString -encodePeerStorageRetrieval (PeerStorageRetrieval blob) = do - blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob) - Right $ mconcat [blobLen, blob] +-- helpers -------------------------------------------------------------------- --- | Encode a message to its payload bytes. --- --- Checks that the payload does not exceed 65533 bytes (the maximum --- possible given the 2-byte type field and 65535-byte message limit). -encodeMessage :: Message -> Either EncodeError BS.ByteString -encodeMessage msg = do - payload <- case msg of - MsgInitVal m -> encodeInit m - MsgErrorVal m -> encodeError m - MsgWarningVal m -> encodeWarning m - MsgPingVal m -> encodePing m - MsgPongVal m -> encodePong m - MsgPeerStorageVal m -> encodePeerStorage m - MsgPeerStorageRetrievalVal m -> encodePeerStorageRetrieval m - -- Payload must leave room for 2-byte type (max 65533 bytes) - when (BS.length payload > 65533) $ - Left EncodeMessageTooLarge - Right payload +prefixed :: BS.ByteString -> Either EncodeError BS.ByteString +prefixed bs = maybe (Left EncodeLengthOverflow) Right (encode_u16_prefixed bs) --- | Encode a message as a complete envelope (type + payload + extension). --- --- Per BOLT #1, the total message size must not exceed 65535 bytes. -encodeEnvelope :: Message -> Maybe TlvStream -> Either EncodeError BS.ByteString -encodeEnvelope msg mext = do - payload <- encodeMessage msg - let !typeBytes = encodeU16 (msgTypeWord (messageType msg)) - !extBytes = maybe BS.empty encodeTlvStream mext - !result = mconcat [typeBytes, payload, extBytes] - -- Per BOLT #1: message size must fit in 2 bytes (max 65535) - when (BS.length result > 65535) $ - Left EncodeMessageTooLarge - Right result +need :: Maybe a -> Either DecodeError a +need = maybe (Left DecodeInsufficientBytes) Right +{-# INLINE need #-} --- Decoding errors ------------------------------------------------------------- +-- an extension stream in which no types are known +extension :: BS.ByteString -> Either DecodeError TlvStream +extension bs = either (Left . DecodeTlvError) Right + (decode_tlv_stream (const False) bs) --- | Decoding errors. -data DecodeError - = DecodeInsufficientBytes - | DecodeInvalidLength - | DecodeUnknownEvenType !Word16 - | DecodeUnknownOddType !Word16 - | DecodeTlvError !TlvError - | DecodeInvalidChannelId - | DecodeInvalidExtension !TlvError - deriving stock (Eq, Show, Generic) +-- init ----------------------------------------------------------------------- -instance NFData DecodeError +-- | Encode an 'Init' payload. +encode_init :: Init -> Either EncodeError BS.ByteString +encode_init (Init gf f nets addr tlvs) = do + gf' <- prefixed (BOLT9.render gf) + f' <- prefixed (BOLT9.render f) + let known = maybe [] (\cs -> [TlvRecord 1 (mconcat (map un_chain_hash cs))]) + nets + <> maybe [] (\a -> [TlvRecord 3 a]) addr + stream <- maybe (Left EncodeInvalidTlvs) Right + (tlv_stream (known <> un_tlv_stream tlvs)) + pure (gf' <> f' <> encode_tlv_stream stream) --- Message decoding ------------------------------------------------------------ +-- | Decode an 'Init' payload. +decode_init :: BS.ByteString -> Either DecodeError Init +decode_init bs = do + (gf, r0) <- need (decode_u16_prefixed bs) + (f, r1) <- need (decode_u16_prefixed r0) + stream <- either (Left . DecodeTlvError) Right + (decode_tlv_stream (\t -> t == 1 || t == 3) r1) + nets <- traverse networks (lookup_tlv 1 stream) + pure Init + { init_global_features = BOLT9.parse gf + , init_features = BOLT9.parse f + , init_networks = nets + , init_remote_addr = lookup_tlv 3 stream + , init_tlvs = filter_tlv_stream (\t -> t /= 1 && t /= 3) stream + } + where + networks v + | BS.length v `rem` 32 /= 0 = Left (DecodeInvalidTlvValue 1) + | otherwise = Right (chunks v) + chunks !v = case decode_chain_hash v of + Just (h, rest) -> h : chunks rest + Nothing -> [] --- | Decode an Init message from payload bytes. --- --- Returns the decoded message and any remaining bytes. -decodeInit :: BS.ByteString -> Either DecodeError (Init, BS.ByteString) -decodeInit !bs = do - (gfLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 bs) - unless (BS.length rest1 >= fromIntegral gfLen) $ - Left DecodeInsufficientBytes - let !gf = BS.take (fromIntegral gfLen) rest1 - !rest2 = BS.drop (fromIntegral gfLen) rest1 - (fLen, rest3) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 rest2) - unless (BS.length rest3 >= fromIntegral fLen) $ - Left DecodeInsufficientBytes - let !feat = BS.take (fromIntegral fLen) rest3 - !rest4 = BS.drop (fromIntegral fLen) rest3 - -- Parse optional TLV stream (consumes all remaining bytes for init) - tlvs <- if BS.null rest4 - then Right (unsafeTlvStream []) - else either (Left . DecodeTlvError) Right (decodeTlvStream rest4) - initTlvList <- either (Left . DecodeTlvError) Right - (parseInitTlvs tlvs) - -- Init consumes all bytes (TLVs are part of init, not extensions) - Right (Init gf feat initTlvList, BS.empty) +-- error, warning ------------------------------------------------------------- --- | Decode an Error message from payload bytes. -decodeError :: BS.ByteString -> Either DecodeError (Error, BS.ByteString) -decodeError !bs = do - unless (BS.length bs >= 32) $ Left DecodeInsufficientBytes - let !cidBytes = BS.take 32 bs - !rest1 = BS.drop 32 bs - cid <- maybe (Left DecodeInvalidChannelId) Right (channelId cidBytes) - (dLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 rest1) - unless (BS.length rest2 >= fromIntegral dLen) $ - Left DecodeInsufficientBytes - let !dat = BS.take (fromIntegral dLen) rest2 - !rest3 = BS.drop (fromIntegral dLen) rest2 - Right (Error cid dat, rest3) +-- | Encode an 'Error' payload. +encode_error :: Error -> Either EncodeError BS.ByteString +encode_error (Error cid dat tlvs) = do + dat' <- prefixed dat + pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs) --- | Decode a Warning message from payload bytes. -decodeWarning :: BS.ByteString -> Either DecodeError (Warning, BS.ByteString) -decodeWarning !bs = do - unless (BS.length bs >= 32) $ Left DecodeInsufficientBytes - let !cidBytes = BS.take 32 bs - !rest1 = BS.drop 32 bs - cid <- maybe (Left DecodeInvalidChannelId) Right (channelId cidBytes) - (dLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 rest1) - unless (BS.length rest2 >= fromIntegral dLen) $ - Left DecodeInsufficientBytes - let !dat = BS.take (fromIntegral dLen) rest2 - !rest3 = BS.drop (fromIntegral dLen) rest2 - Right (Warning cid dat, rest3) +-- | Decode an 'Error' payload. +decode_error :: BS.ByteString -> Either DecodeError Error +decode_error bs = do + (cid, r0) <- need (decode_channel_id bs) + (dat, r1) <- need (decode_u16_prefixed r0) + Error cid dat <$> extension r1 --- | Decode a Ping message from payload bytes. -decodePing :: BS.ByteString -> Either DecodeError (Ping, BS.ByteString) -decodePing !bs = do - (numPong, rest1) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 bs) - (bLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 rest1) - unless (BS.length rest2 >= fromIntegral bLen) $ - Left DecodeInsufficientBytes - let !ignored = BS.take (fromIntegral bLen) rest2 - !rest3 = BS.drop (fromIntegral bLen) rest2 - Right (Ping numPong ignored, rest3) +-- | Encode a 'Warning' payload. +encode_warning :: Warning -> Either EncodeError BS.ByteString +encode_warning (Warning cid dat tlvs) = do + dat' <- prefixed dat + pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs) --- | Decode a Pong message from payload bytes. -decodePong :: BS.ByteString -> Either DecodeError (Pong, BS.ByteString) -decodePong !bs = do - (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 bs) - unless (BS.length rest1 >= fromIntegral bLen) $ - Left DecodeInsufficientBytes - let !ignored = BS.take (fromIntegral bLen) rest1 - !rest2 = BS.drop (fromIntegral bLen) rest1 - Right (Pong ignored, rest2) +-- | Decode a 'Warning' payload. +decode_warning :: BS.ByteString -> Either DecodeError Warning +decode_warning bs = do + (cid, r0) <- need (decode_channel_id bs) + (dat, r1) <- need (decode_u16_prefixed r0) + Warning cid dat <$> extension r1 --- | Decode a PeerStorage message from payload bytes. -decodePeerStorage - :: BS.ByteString -> Either DecodeError (PeerStorage, BS.ByteString) -decodePeerStorage !bs = do - (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 bs) - unless (BS.length rest1 >= fromIntegral bLen) $ - Left DecodeInsufficientBytes - let !blob = BS.take (fromIntegral bLen) rest1 - !rest2 = BS.drop (fromIntegral bLen) rest1 - Right (PeerStorage blob, rest2) +-- ping, pong ----------------------------------------------------------------- --- | Decode a PeerStorageRetrieval message from payload bytes. -decodePeerStorageRetrieval - :: BS.ByteString - -> Either DecodeError (PeerStorageRetrieval, BS.ByteString) -decodePeerStorageRetrieval !bs = do - (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 bs) - unless (BS.length rest1 >= fromIntegral bLen) $ - Left DecodeInsufficientBytes - let !blob = BS.take (fromIntegral bLen) rest1 - !rest2 = BS.drop (fromIntegral bLen) rest1 - Right (PeerStorageRetrieval blob, rest2) +-- | Encode a 'Ping' payload. +encode_ping :: Ping -> Either EncodeError BS.ByteString +encode_ping (Ping n ign tlvs) = do + ign' <- prefixed ign + pure (encode_u16 n <> ign' <> encode_tlv_stream tlvs) --- | Decode a message from its type and payload. --- --- Returns the decoded message and any remaining bytes (for extensions). --- For unknown types, returns an appropriate error. -decodeMessage - :: MsgType -> BS.ByteString -> Either DecodeError (Message, BS.ByteString) -decodeMessage MsgInit bs = do - (m, rest) <- decodeInit bs - Right (MsgInitVal m, rest) -decodeMessage MsgError bs = do - (m, rest) <- decodeError bs - Right (MsgErrorVal m, rest) -decodeMessage MsgWarning bs = do - (m, rest) <- decodeWarning bs - Right (MsgWarningVal m, rest) -decodeMessage MsgPing bs = do - (m, rest) <- decodePing bs - Right (MsgPingVal m, rest) -decodeMessage MsgPong bs = do - (m, rest) <- decodePong bs - Right (MsgPongVal m, rest) -decodeMessage MsgPeerStorage bs = do - (m, rest) <- decodePeerStorage bs - Right (MsgPeerStorageVal m, rest) -decodeMessage MsgPeerStorageRet bs = do - (m, rest) <- decodePeerStorageRetrieval bs - Right (MsgPeerStorageRetrievalVal m, rest) -decodeMessage (MsgUnknown w) _ - | even w = Left (DecodeUnknownEvenType w) - | otherwise = Left (DecodeUnknownOddType w) +-- | Decode a 'Ping' payload. +decode_ping :: BS.ByteString -> Either DecodeError Ping +decode_ping bs = do + (n, r0) <- need (decode_u16 bs) + (ign, r1) <- need (decode_u16_prefixed r0) + Ping n ign <$> extension r1 --- | Decode a complete envelope (type + payload + optional extension). --- --- Per BOLT #1: --- - Unknown odd message types are ignored (returns Nothing for message) --- - Unknown even message types cause connection close (returns error) --- - Invalid extension TLV causes connection close (returns error) --- --- This uses the default policy of treating all extension TLV types as --- unknown. Use 'decodeEnvelopeWith' for configurable extension handling. --- --- Returns the decoded message (if known) and any extension TLVs. -decodeEnvelope - :: BS.ByteString - -> Either DecodeError (Maybe Message, Maybe TlvStream) -decodeEnvelope = decodeEnvelopeWith (const False) +-- | Encode a 'Pong' payload. +encode_pong :: Pong -> Either EncodeError BS.ByteString +encode_pong (Pong ign tlvs) = do + ign' <- prefixed ign + pure (ign' <> encode_tlv_stream tlvs) --- | Decode a complete envelope with configurable extension TLV handling. --- --- The predicate determines which extension TLV types are "known" and --- should be preserved. Unknown even types cause failure; unknown odd --- types are skipped. --- --- Use @decodeEnvelopeWith (const False)@ to reject all even extension --- types (the default behavior of 'decodeEnvelope'). +-- | Decode a 'Pong' payload. +decode_pong :: BS.ByteString -> Either DecodeError Pong +decode_pong bs = do + (ign, r0) <- need (decode_u16_prefixed bs) + Pong ign <$> extension r0 + +-- | The 'Pong' a node must send in reply to a 'Ping', if any. Per +-- BOLT #1, a ping requesting 65532 or more bytes is ignored. -- --- Use @decodeEnvelopeWith (const True)@ to accept all extension types. -decodeEnvelopeWith - :: (Word64 -> Bool) -- ^ Predicate: is this extension TLV type known? - -> BS.ByteString - -> Either DecodeError (Maybe Message, Maybe TlvStream) -decodeEnvelopeWith isKnownExt !bs = do - (typeWord, rest1) <- maybe (Left DecodeInsufficientBytes) Right - (decodeU16 bs) - let !msgType = parseMsgType typeWord - case msgType of - MsgUnknown w - | even w -> Left (DecodeUnknownEvenType w) - | otherwise -> Right (Nothing, Nothing) -- Ignore unknown odd types - _ -> do - (msg, rest2) <- decodeMessage msgType rest1 - -- Parse any remaining bytes as extension TLV - ext <- if BS.null rest2 - then Right Nothing - else case decodeTlvStreamWith isKnownExt rest2 of - Left e -> Left (DecodeInvalidExtension e) - Right s -> Right (Just s) - Right (Just msg, ext) +-- >>> ping_response (Ping 4 "" empty_tlv_stream) +-- Just (Pong {pong_ignored = "\NUL\NUL\NUL\NUL", pong_tlvs = TlvStream []}) +-- >>> ping_response (Ping 65532 "" empty_tlv_stream) +-- Nothing +ping_response :: Ping -> Maybe Pong +ping_response (Ping n _ _) + | n >= 65532 = Nothing + | otherwise = + Just (Pong (BS.replicate (fromIntegral n) 0x00) empty_tlv_stream) + +-- peer storage --------------------------------------------------------------- + +-- | Encode a 'PeerStorage' payload. +encode_peer_storage :: PeerStorage -> Either EncodeError BS.ByteString +encode_peer_storage (PeerStorage blob tlvs) = do + blob' <- prefixed blob + pure (blob' <> encode_tlv_stream tlvs) + +-- | Decode a 'PeerStorage' payload. +decode_peer_storage :: BS.ByteString -> Either DecodeError PeerStorage +decode_peer_storage bs = do + (blob, r0) <- need (decode_u16_prefixed bs) + PeerStorage blob <$> extension r0 + +-- | Encode a 'PeerStorageRetrieval' payload. +encode_peer_storage_retrieval + :: PeerStorageRetrieval -> Either EncodeError BS.ByteString +encode_peer_storage_retrieval (PeerStorageRetrieval blob tlvs) = do + blob' <- prefixed blob + pure (blob' <> encode_tlv_stream tlvs) + +-- | Decode a 'PeerStorageRetrieval' payload. +decode_peer_storage_retrieval + :: BS.ByteString -> Either DecodeError PeerStorageRetrieval +decode_peer_storage_retrieval bs = do + (blob, r0) <- need (decode_u16_prefixed bs) + PeerStorageRetrieval blob <$> extension r0 diff --git a/lib/Lightning/Protocol/BOLT1/Message.hs b/lib/Lightning/Protocol/BOLT1/Message.hs --- a/lib/Lightning/Protocol/BOLT1/Message.hs +++ b/lib/Lightning/Protocol/BOLT1/Message.hs @@ -1,6 +1,5 @@ -{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -- | -- Module: Lightning.Protocol.BOLT1.Message @@ -8,206 +7,126 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- Message types for BOLT #1. +-- The messages defined by BOLT #1. module Lightning.Protocol.BOLT1.Message ( - -- * Message types - MsgType(..) - , msgTypeWord - , parseMsgType - - -- * Channel identifiers - , ChannelId - , channelId - , unChannelId - , allChannels - - -- * Setup messages - , Init(..) + Init(..) , Error(..) , Warning(..) - - -- * Control messages , Ping(..) , Pong(..) - - -- * Peer storage messages , PeerStorage(..) , PeerStorageRetrieval(..) - - -- * Message envelope , Message(..) - , messageType - , Envelope(..) + , message_type ) where import Control.DeepSeq (NFData) import qualified Data.ByteString as BS import Data.Word (Word16) import GHC.Generics (Generic) +import Lightning.Protocol.BOLT1.Prim import Lightning.Protocol.BOLT1.TLV - --- Message types --------------------------------------------------------------- - --- | BOLT #1 message type codes. -data MsgType - = MsgInit -- ^ 16 - | MsgError -- ^ 17 - | MsgPing -- ^ 18 - | MsgPong -- ^ 19 - | MsgWarning -- ^ 1 - | MsgPeerStorage -- ^ 7 - | MsgPeerStorageRet -- ^ 9 - | MsgUnknown !Word16 -- ^ Unknown type - deriving stock (Eq, Show, Generic) - -instance NFData MsgType - --- | Get the numeric type code for a message type. -msgTypeWord :: MsgType -> Word16 -msgTypeWord MsgInit = 16 -msgTypeWord MsgError = 17 -msgTypeWord MsgPing = 18 -msgTypeWord MsgPong = 19 -msgTypeWord MsgWarning = 1 -msgTypeWord MsgPeerStorage = 7 -msgTypeWord MsgPeerStorageRet = 9 -msgTypeWord (MsgUnknown w) = w - --- | Parse a message type from a word. -parseMsgType :: Word16 -> MsgType -parseMsgType 16 = MsgInit -parseMsgType 17 = MsgError -parseMsgType 18 = MsgPing -parseMsgType 19 = MsgPong -parseMsgType 1 = MsgWarning -parseMsgType 7 = MsgPeerStorage -parseMsgType 9 = MsgPeerStorageRet -parseMsgType w = MsgUnknown w - --- Channel identifiers --------------------------------------------------------- - --- | A 32-byte channel identifier. --- --- Use 'channelId' to construct, which validates the length. --- Use 'allChannels' for connection-level errors (all-zeros channel ID). -newtype ChannelId = ChannelId BS.ByteString - deriving stock (Eq, Show, Generic) - -instance NFData ChannelId - --- | 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 "\NUL\NUL...") --- >>> channelId "too short" --- Nothing -channelId :: BS.ByteString -> Maybe ChannelId -channelId bs - | BS.length bs == 32 = Just (ChannelId bs) - | otherwise = Nothing -{-# INLINE channelId #-} +import qualified Lightning.Protocol.BOLT9 as BOLT9 --- | The all-zeros channel ID, used for connection-level errors. +-- | The @init@ message (type 16). -- --- Per BOLT #1, setting channel_id to all zeros means the error applies --- to the connection rather than a specific channel. -allChannels :: ChannelId -allChannels = ChannelId (BS.replicate 32 0x00) - --- | Extract the raw bytes from a 'ChannelId'. -unChannelId :: ChannelId -> BS.ByteString -unChannelId (ChannelId bs) = bs -{-# INLINE unChannelId #-} - --- Message ADTs ---------------------------------------------------------------- - --- | The init message (type 16). +-- The two feature vectors are kept as received. Per BOLT #1, a +-- receiver treats their union ('BOLT9.union') as the peer's +-- features. data Init = Init - { initGlobalFeatures :: !BS.ByteString - , initFeatures :: !BS.ByteString - , initTlvs :: ![InitTlv] - } deriving stock (Eq, Show, Generic) + { init_global_features :: !BOLT9.FeatureVector + , init_features :: !BOLT9.FeatureVector + , init_networks :: !(Maybe [ChainHash]) + -- ^ @networks@ (TLV type 1): chains the node is interested in + , init_remote_addr :: !(Maybe BS.ByteString) + -- ^ @remote_addr@ (TLV type 3): a raw BOLT #7 address descriptor + , init_tlvs :: !TlvStream + -- ^ unknown odd TLV records + } deriving (Eq, Show, Generic) instance NFData Init --- | The error message (type 17). +-- | The @error@ message (type 17). data Error = Error - { errorChannelId :: !ChannelId - , errorData :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { error_channel_id :: !ChannelId + , error_data :: !BS.ByteString + , error_tlvs :: !TlvStream + -- ^ extension TLV records (all unknown odd) + } deriving (Eq, Show, Generic) instance NFData Error --- | The warning message (type 1). +-- | The @warning@ message (type 1). data Warning = Warning - { warningChannelId :: !ChannelId - , warningData :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { warning_channel_id :: !ChannelId + , warning_data :: !BS.ByteString + , warning_tlvs :: !TlvStream + -- ^ extension TLV records (all unknown odd) + } deriving (Eq, Show, Generic) instance NFData Warning --- | The ping message (type 18). +-- | The @ping@ message (type 18). data Ping = Ping - { pingNumPongBytes :: {-# UNPACK #-} !Word16 - , pingIgnored :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { ping_num_pong_bytes :: {-# UNPACK #-} !Word16 + , ping_ignored :: !BS.ByteString + , ping_tlvs :: !TlvStream + -- ^ extension TLV records (all unknown odd) + } deriving (Eq, Show, Generic) instance NFData Ping --- | The pong message (type 19). +-- | The @pong@ message (type 19). data Pong = Pong - { pongIgnored :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { pong_ignored :: !BS.ByteString + , pong_tlvs :: !TlvStream + -- ^ extension TLV records (all unknown odd) + } deriving (Eq, Show, Generic) instance NFData Pong --- | The peer_storage message (type 7). +-- | The @peer_storage@ message (type 7). data PeerStorage = PeerStorage - { peerStorageBlob :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { peer_storage_blob :: !BS.ByteString + , peer_storage_tlvs :: !TlvStream + -- ^ extension TLV records (all unknown odd) + } deriving (Eq, Show, Generic) instance NFData PeerStorage --- | The peer_storage_retrieval message (type 9). +-- | The @peer_storage_retrieval@ message (type 9). data PeerStorageRetrieval = PeerStorageRetrieval - { peerStorageRetrievalBlob :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { peer_storage_retrieval_blob :: !BS.ByteString + , peer_storage_retrieval_tlvs :: !TlvStream + -- ^ extension TLV records (all unknown odd) + } deriving (Eq, Show, Generic) instance NFData PeerStorageRetrieval --- | All BOLT #1 messages. +-- | A BOLT #1 message. data Message - = MsgInitVal !Init - | MsgErrorVal !Error - | MsgWarningVal !Warning - | MsgPingVal !Ping - | MsgPongVal !Pong - | MsgPeerStorageVal !PeerStorage - | MsgPeerStorageRetrievalVal !PeerStorageRetrieval - deriving stock (Eq, Show, Generic) + = MsgInit !Init + | MsgError !Error + | MsgWarning !Warning + | MsgPing !Ping + | MsgPong !Pong + | MsgPeerStorage !PeerStorage + | MsgPeerStorageRetrieval !PeerStorageRetrieval + deriving (Eq, Show, Generic) instance NFData Message --- | Get the message type for a message. -messageType :: Message -> MsgType -messageType (MsgInitVal _) = MsgInit -messageType (MsgErrorVal _) = MsgError -messageType (MsgWarningVal _) = MsgWarning -messageType (MsgPingVal _) = MsgPing -messageType (MsgPongVal _) = MsgPong -messageType (MsgPeerStorageVal _) = MsgPeerStorage -messageType (MsgPeerStorageRetrievalVal _) = MsgPeerStorageRet - --- Message envelope ------------------------------------------------------------ - --- | A complete message envelope with type, payload, and optional extension. -data Envelope = Envelope - { envType :: !MsgType - , envPayload :: !BS.ByteString - , envExtension :: !(Maybe TlvStream) - } deriving stock (Eq, Show, Generic) - -instance NFData Envelope +-- | The wire type of a 'Message'. +-- +-- >>> message_type (MsgPong (Pong "" empty_tlv_stream)) +-- 19 +message_type :: Message -> Word16 +message_type m = case m of + MsgInit {} -> 16 + MsgError {} -> 17 + MsgWarning {} -> 1 + MsgPing {} -> 18 + MsgPong {} -> 19 + MsgPeerStorage {} -> 7 + MsgPeerStorageRetrieval {} -> 9 diff --git a/lib/Lightning/Protocol/BOLT1/Prim.hs b/lib/Lightning/Protocol/BOLT1/Prim.hs --- a/lib/Lightning/Protocol/BOLT1/Prim.hs +++ b/lib/Lightning/Protocol/BOLT1/Prim.hs @@ -1,527 +1,804 @@ -{-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - --- | --- Module: Lightning.Protocol.BOLT1.Prim --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Primitive type encoding and decoding for BOLT #1. - -module Lightning.Protocol.BOLT1.Prim ( - -- * Chain hash - ChainHash - , chainHash - , unChainHash - - -- * Unsigned integer encoding - , encodeU16 - , encodeU32 - , encodeU64 - - -- * Signed integer encoding - , encodeS8 - , encodeS16 - , encodeS32 - , encodeS64 - - -- * Truncated unsigned integer encoding - , encodeTu16 - , encodeTu32 - , encodeTu64 - - -- * Minimal signed integer encoding - , encodeMinSigned - - -- * BigSize encoding - , encodeBigSize - - -- * Unsigned integer decoding - , decodeU16 - , decodeU32 - , decodeU64 - - -- * Signed integer decoding - , decodeS8 - , decodeS16 - , decodeS32 - , decodeS64 - - -- * Truncated unsigned integer decoding - , decodeTu16 - , decodeTu32 - , decodeTu64 - - -- * Minimal signed integer decoding - , decodeMinSigned - - -- * BigSize decoding - , decodeBigSize - - -- * Internal helpers - , encodeLength - ) where - -import Control.DeepSeq (NFData) -import Data.Bits (unsafeShiftL, unsafeShiftR, (.|.)) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BSB -import qualified Data.ByteString.Lazy as BSL -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word16, Word32, Word64) -import GHC.Generics (Generic) - --- Chain hash ------------------------------------------------------------------ - --- | A chain hash (32-byte hash identifying a blockchain). -newtype ChainHash = ChainHash BS.ByteString - deriving stock (Eq, Show, Generic) - -instance NFData ChainHash - --- | Construct a chain hash from a 32-byte bytestring. --- --- Returns 'Nothing' if the input is not exactly 32 bytes. -chainHash :: BS.ByteString -> Maybe ChainHash -chainHash bs - | BS.length bs == 32 = Just (ChainHash bs) - | otherwise = Nothing -{-# INLINE chainHash #-} - --- | Extract the raw bytes from a chain hash. -unChainHash :: ChainHash -> BS.ByteString -unChainHash (ChainHash bs) = bs -{-# INLINE unChainHash #-} - --- Unsigned integer encoding --------------------------------------------------- - --- | Encode a 16-bit unsigned integer (big-endian). --- --- >>> encodeU16 0x0102 --- "\SOH\STX" -encodeU16 :: Word16 -> BS.ByteString -encodeU16 = BSL.toStrict . BSB.toLazyByteString . BSB.word16BE -{-# INLINE encodeU16 #-} - --- | Encode a 32-bit unsigned integer (big-endian). --- --- >>> encodeU32 0x01020304 --- "\SOH\STX\ETX\EOT" -encodeU32 :: Word32 -> BS.ByteString -encodeU32 = BSL.toStrict . BSB.toLazyByteString . BSB.word32BE -{-# INLINE encodeU32 #-} - --- | Encode a 64-bit unsigned integer (big-endian). --- --- >>> encodeU64 0x0102030405060708 --- "\SOH\STX\ETX\EOT\ENQ\ACK\a\b" -encodeU64 :: Word64 -> BS.ByteString -encodeU64 = BSL.toStrict . BSB.toLazyByteString . BSB.word64BE -{-# INLINE encodeU64 #-} - --- Signed integer encoding ----------------------------------------------------- - --- | Encode an 8-bit signed integer. --- --- >>> encodeS8 42 --- "*" --- >>> encodeS8 (-42) --- "\214" -encodeS8 :: Int8 -> BS.ByteString -encodeS8 = BS.singleton . fromIntegral -{-# INLINE encodeS8 #-} - --- | Encode a 16-bit signed integer (big-endian two's complement). --- --- >>> encodeS16 0x0102 --- "\SOH\STX" --- >>> encodeS16 (-1) --- "\255\255" -encodeS16 :: Int16 -> BS.ByteString -encodeS16 = BSL.toStrict . BSB.toLazyByteString . BSB.int16BE -{-# INLINE encodeS16 #-} - --- | Encode a 32-bit signed integer (big-endian two's complement). --- --- >>> encodeS32 0x01020304 --- "\SOH\STX\ETX\EOT" --- >>> encodeS32 (-1) --- "\255\255\255\255" -encodeS32 :: Int32 -> BS.ByteString -encodeS32 = BSL.toStrict . BSB.toLazyByteString . BSB.int32BE -{-# INLINE encodeS32 #-} - --- | Encode a 64-bit signed integer (big-endian two's complement). --- --- >>> encodeS64 0x0102030405060708 --- "\SOH\STX\ETX\EOT\ENQ\ACK\a\b" --- >>> encodeS64 (-1) --- "\255\255\255\255\255\255\255\255" -encodeS64 :: Int64 -> BS.ByteString -encodeS64 = BSL.toStrict . BSB.toLazyByteString . BSB.int64BE -{-# INLINE encodeS64 #-} - --- Truncated unsigned integer encoding ----------------------------------------- - --- | Encode a truncated 16-bit unsigned integer (0-2 bytes). --- --- Leading zeros are omitted per BOLT #1. Zero encodes to empty. --- --- >>> encodeTu16 0 --- "" --- >>> encodeTu16 1 --- "\SOH" --- >>> encodeTu16 256 --- "\SOH\NUL" -encodeTu16 :: Word16 -> BS.ByteString -encodeTu16 0 = BS.empty -encodeTu16 !x - | x < 0x100 = BS.singleton (fromIntegral x) - | otherwise = encodeU16 x -{-# INLINE encodeTu16 #-} - --- | Encode a truncated 32-bit unsigned integer (0-4 bytes). --- --- Leading zeros are omitted per BOLT #1. Zero encodes to empty. --- --- >>> encodeTu32 0 --- "" --- >>> encodeTu32 1 --- "\SOH" --- >>> encodeTu32 0x010000 --- "\SOH\NUL\NUL" -encodeTu32 :: Word32 -> BS.ByteString -encodeTu32 0 = BS.empty -encodeTu32 !x - | x < 0x100 = BS.singleton (fromIntegral x) - | x < 0x10000 = encodeU16 (fromIntegral x) - | x < 0x1000000 = BS.pack [ fromIntegral (x `unsafeShiftR` 16) - , fromIntegral (x `unsafeShiftR` 8) - , fromIntegral x - ] - | otherwise = encodeU32 x -{-# INLINE encodeTu32 #-} - --- | Encode a truncated 64-bit unsigned integer (0-8 bytes). --- --- Leading zeros are omitted per BOLT #1. Zero encodes to empty. --- --- >>> encodeTu64 0 --- "" --- >>> encodeTu64 1 --- "\SOH" --- >>> encodeTu64 0x0100000000 --- "\SOH\NUL\NUL\NUL\NUL" -encodeTu64 :: Word64 -> BS.ByteString -encodeTu64 0 = BS.empty -encodeTu64 !x - | x < 0x100 = BS.singleton (fromIntegral x) - | x < 0x10000 = encodeU16 (fromIntegral x) - | x < 0x1000000 = BS.pack [ fromIntegral (x `unsafeShiftR` 16) - , fromIntegral (x `unsafeShiftR` 8) - , fromIntegral x - ] - | x < 0x100000000 = encodeU32 (fromIntegral x) - | x < 0x10000000000 = BS.pack [ fromIntegral (x `unsafeShiftR` 32) - , fromIntegral (x `unsafeShiftR` 24) - , fromIntegral (x `unsafeShiftR` 16) - , fromIntegral (x `unsafeShiftR` 8) - , fromIntegral x - ] - | x < 0x1000000000000 = BS.pack [ fromIntegral (x `unsafeShiftR` 40) - , fromIntegral (x `unsafeShiftR` 32) - , fromIntegral (x `unsafeShiftR` 24) - , fromIntegral (x `unsafeShiftR` 16) - , fromIntegral (x `unsafeShiftR` 8) - , fromIntegral x - ] - | x < 0x100000000000000 = BS.pack [ fromIntegral (x `unsafeShiftR` 48) - , fromIntegral (x `unsafeShiftR` 40) - , fromIntegral (x `unsafeShiftR` 32) - , fromIntegral (x `unsafeShiftR` 24) - , fromIntegral (x `unsafeShiftR` 16) - , fromIntegral (x `unsafeShiftR` 8) - , fromIntegral x - ] - | otherwise = encodeU64 x -{-# INLINE encodeTu64 #-} - --- Minimal signed integer encoding --------------------------------------------- - --- | Encode a signed 64-bit integer using minimal bytes. --- --- Uses the smallest number of bytes that can represent the value --- in two's complement. Per BOLT #1 Appendix D test vectors. --- --- >>> encodeMinSigned 0 --- "\NUL" --- >>> encodeMinSigned 127 --- "\DEL" --- >>> encodeMinSigned 128 --- "\NUL\128" --- >>> encodeMinSigned (-1) --- "\255" --- >>> encodeMinSigned (-128) --- "\128" --- >>> encodeMinSigned (-129) --- "\255\DEL" -encodeMinSigned :: Int64 -> BS.ByteString -encodeMinSigned !x - | x >= -128 && x <= 127 = - -- Fits in 1 byte - BS.singleton (fromIntegral x) - | x >= -32768 && x <= 32767 = - -- Fits in 2 bytes - encodeS16 (fromIntegral x) - | x >= -2147483648 && x <= 2147483647 = - -- Fits in 4 bytes - encodeS32 (fromIntegral x) - | otherwise = - -- Need 8 bytes - encodeS64 x -{-# INLINE encodeMinSigned #-} - --- BigSize encoding ------------------------------------------------------------ - --- | Encode a BigSize value (variable-length unsigned integer). --- --- >>> encodeBigSize 0 --- "\NUL" --- >>> encodeBigSize 252 --- "\252" --- >>> encodeBigSize 253 --- "\253\NUL\253" --- >>> encodeBigSize 65536 --- "\254\NUL\SOH\NUL\NUL" -encodeBigSize :: Word64 -> BS.ByteString -encodeBigSize !x - | x < 0xfd = BS.singleton (fromIntegral x) - | x < 0x10000 = BS.cons 0xfd (encodeU16 (fromIntegral x)) - | x < 0x100000000 = BS.cons 0xfe (encodeU32 (fromIntegral x)) - | otherwise = BS.cons 0xff (encodeU64 x) -{-# INLINE encodeBigSize #-} - --- Length encoding ------------------------------------------------------------- - --- | Encode a length as u16, checking bounds. --- --- Returns Nothing if the length exceeds 65535. -encodeLength :: BS.ByteString -> Maybe BS.ByteString -encodeLength !bs - | BS.length bs > 65535 = Nothing - | otherwise = Just (encodeU16 (fromIntegral (BS.length bs))) -{-# INLINE encodeLength #-} - --- Unsigned integer decoding --------------------------------------------------- - --- | Decode a 16-bit unsigned integer (big-endian). -decodeU16 :: BS.ByteString -> Maybe (Word16, BS.ByteString) -decodeU16 !bs - | BS.length bs < 2 = Nothing - | otherwise = - let !b0 = fromIntegral (BS.index bs 0) - !b1 = fromIntegral (BS.index bs 1) - !val = (b0 `unsafeShiftL` 8) .|. b1 - in Just (val, BS.drop 2 bs) -{-# INLINE decodeU16 #-} - --- | Decode a 32-bit unsigned integer (big-endian). -decodeU32 :: BS.ByteString -> Maybe (Word32, BS.ByteString) -decodeU32 !bs - | BS.length bs < 4 = Nothing - | otherwise = - let !b0 = fromIntegral (BS.index bs 0) - !b1 = fromIntegral (BS.index bs 1) - !b2 = fromIntegral (BS.index bs 2) - !b3 = fromIntegral (BS.index bs 3) - !val = (b0 `unsafeShiftL` 24) .|. (b1 `unsafeShiftL` 16) - .|. (b2 `unsafeShiftL` 8) .|. b3 - in Just (val, BS.drop 4 bs) -{-# INLINE decodeU32 #-} - --- | Decode a 64-bit unsigned integer (big-endian). -decodeU64 :: BS.ByteString -> Maybe (Word64, BS.ByteString) -decodeU64 !bs - | BS.length bs < 8 = Nothing - | otherwise = - let !b0 = fromIntegral (BS.index bs 0) - !b1 = fromIntegral (BS.index bs 1) - !b2 = fromIntegral (BS.index bs 2) - !b3 = fromIntegral (BS.index bs 3) - !b4 = fromIntegral (BS.index bs 4) - !b5 = fromIntegral (BS.index bs 5) - !b6 = fromIntegral (BS.index bs 6) - !b7 = fromIntegral (BS.index bs 7) - !val = (b0 `unsafeShiftL` 56) .|. (b1 `unsafeShiftL` 48) - .|. (b2 `unsafeShiftL` 40) .|. (b3 `unsafeShiftL` 32) - .|. (b4 `unsafeShiftL` 24) .|. (b5 `unsafeShiftL` 16) - .|. (b6 `unsafeShiftL` 8) .|. b7 - in Just (val, BS.drop 8 bs) -{-# INLINE decodeU64 #-} - --- Signed integer decoding ----------------------------------------------------- - --- | Decode an 8-bit signed integer. -decodeS8 :: BS.ByteString -> Maybe (Int8, BS.ByteString) -decodeS8 !bs - | BS.null bs = Nothing - | otherwise = Just (fromIntegral (BS.index bs 0), BS.drop 1 bs) -{-# INLINE decodeS8 #-} - --- | Decode a 16-bit signed integer (big-endian two's complement). -decodeS16 :: BS.ByteString -> Maybe (Int16, BS.ByteString) -decodeS16 !bs = do - (w, rest) <- decodeU16 bs - Just (fromIntegral w, rest) -{-# INLINE decodeS16 #-} - --- | Decode a 32-bit signed integer (big-endian two's complement). -decodeS32 :: BS.ByteString -> Maybe (Int32, BS.ByteString) -decodeS32 !bs = do - (w, rest) <- decodeU32 bs - Just (fromIntegral w, rest) -{-# INLINE decodeS32 #-} - --- | Decode a 64-bit signed integer (big-endian two's complement). -decodeS64 :: BS.ByteString -> Maybe (Int64, BS.ByteString) -decodeS64 !bs = do - (w, rest) <- decodeU64 bs - Just (fromIntegral w, rest) -{-# INLINE decodeS64 #-} - --- Truncated unsigned integer decoding ----------------------------------------- - --- | Decode a truncated 16-bit unsigned integer (0-2 bytes). --- --- Returns Nothing if the encoding is non-minimal (has leading zeros). -decodeTu16 :: Int -> BS.ByteString -> Maybe (Word16, BS.ByteString) -decodeTu16 !len !bs - | len < 0 || len > 2 = Nothing - | BS.length bs < len = Nothing - | len == 0 = Just (0, bs) - | otherwise = - let !bytes = BS.take len bs - !rest = BS.drop len bs - in if BS.index bytes 0 == 0 - then Nothing -- non-minimal: leading zero - else Just (decodeBeWord16 bytes, rest) - where - decodeBeWord16 :: BS.ByteString -> Word16 - decodeBeWord16 b = case BS.length b of - 1 -> fromIntegral (BS.index b 0) - 2 -> (fromIntegral (BS.index b 0) `unsafeShiftL` 8) - .|. fromIntegral (BS.index b 1) - _ -> 0 -{-# INLINE decodeTu16 #-} - --- | Decode a truncated 32-bit unsigned integer (0-4 bytes). --- --- Returns Nothing if the encoding is non-minimal (has leading zeros). -decodeTu32 :: Int -> BS.ByteString -> Maybe (Word32, BS.ByteString) -decodeTu32 !len !bs - | len < 0 || len > 4 = Nothing - | BS.length bs < len = Nothing - | len == 0 = Just (0, bs) - | otherwise = - let !bytes = BS.take len bs - !rest = BS.drop len bs - in if BS.index bytes 0 == 0 - then Nothing -- non-minimal: leading zero - else Just (decodeBeWord32 len bytes, rest) - where - decodeBeWord32 :: Int -> BS.ByteString -> Word32 - decodeBeWord32 n b = go 0 0 - where - go !acc !i - | i >= n = acc - | otherwise = go ((acc `unsafeShiftL` 8) - .|. fromIntegral (BS.index b i)) (i + 1) -{-# INLINE decodeTu32 #-} - --- | Decode a truncated 64-bit unsigned integer (0-8 bytes). --- --- Returns Nothing if the encoding is non-minimal (has leading zeros). -decodeTu64 :: Int -> BS.ByteString -> Maybe (Word64, BS.ByteString) -decodeTu64 !len !bs - | len < 0 || len > 8 = Nothing - | BS.length bs < len = Nothing - | len == 0 = Just (0, bs) - | otherwise = - let !bytes = BS.take len bs - !rest = BS.drop len bs - in if BS.index bytes 0 == 0 - then Nothing -- non-minimal: leading zero - else Just (decodeBeWord64 len bytes, rest) - where - decodeBeWord64 :: Int -> BS.ByteString -> Word64 - decodeBeWord64 n b = go 0 0 - where - go !acc !i - | i >= n = acc - | otherwise = go ((acc `unsafeShiftL` 8) - .|. fromIntegral (BS.index b i)) (i + 1) -{-# INLINE decodeTu64 #-} - --- Minimal signed integer decoding --------------------------------------------- - --- | Decode a minimal signed integer (1, 2, 4, or 8 bytes). --- --- Validates that the encoding is minimal: the value could not be --- represented in fewer bytes. Per BOLT #1 Appendix D test vectors. -decodeMinSigned :: Int -> BS.ByteString -> Maybe (Int64, BS.ByteString) -decodeMinSigned !len !bs - | BS.length bs < len = Nothing - | otherwise = case len of - 1 -> do - (v, rest) <- decodeS8 bs - Just (fromIntegral v, rest) - 2 -> do - (v, rest) <- decodeS16 bs - -- Must not fit in 1 byte - if v >= -128 && v <= 127 - then Nothing - else Just (fromIntegral v, rest) - 4 -> do - (v, rest) <- decodeS32 bs - -- Must not fit in 2 bytes - if v >= -32768 && v <= 32767 - then Nothing - else Just (fromIntegral v, rest) - 8 -> do - (v, rest) <- decodeS64 bs - -- Must not fit in 4 bytes - if v >= -2147483648 && v <= 2147483647 - then Nothing - else Just (v, rest) - _ -> Nothing -{-# INLINE decodeMinSigned #-} - --- BigSize decoding ------------------------------------------------------------ - --- | Decode a BigSize value with minimality check. -decodeBigSize :: BS.ByteString -> Maybe (Word64, BS.ByteString) -decodeBigSize !bs - | BS.null bs = Nothing - | otherwise = case BS.index bs 0 of - 0xff -> do - (val, rest) <- decodeU64 (BS.drop 1 bs) - -- Must be >= 0x100000000 for minimal encoding - if val >= 0x100000000 - then Just (val, rest) - else Nothing - 0xfe -> do - (val, rest) <- decodeU32 (BS.drop 1 bs) - -- Must be >= 0x10000 for minimal encoding - if val >= 0x10000 - then Just (fromIntegral val, rest) - else Nothing - 0xfd -> do - (val, rest) <- decodeU16 (BS.drop 1 bs) - -- Must be >= 0xfd for minimal encoding - if val >= 0xfd - then Just (fromIntegral val, rest) - else Nothing - b -> Just (fromIntegral b, BS.drop 1 bs) +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module: Lightning.Protocol.BOLT1.Prim +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Fundamental types and primitive encodings for BOLT #1. + +module Lightning.Protocol.BOLT1.Prim ( + -- * Fixed-size byte types + ChainHash + , chain_hash + , un_chain_hash + , ChannelId + , channel_id + , un_channel_id + , all_channels + , Signature + , signature + , un_signature + , Point + , point + , un_point + , PaymentHash + , payment_hash + , un_payment_hash + , PaymentPreimage + , payment_preimage + , un_payment_preimage + , PerCommitmentSecret + , per_commitment_secret + , un_per_commitment_secret + + -- * Short channel identifiers + , ShortChannelId(..) + , short_channel_id + , scid_block_height + , scid_tx_index + , scid_output_index + + -- * Amounts + , Satoshi + , satoshi + , un_satoshi + , max_satoshi + , MilliSatoshi + , milli_satoshi + , un_milli_satoshi + , max_milli_satoshi + , sat_to_msat + , msat_to_sat + , add_sat + , sub_sat + , add_msat + , sub_msat + + -- * Unsigned integers + , encode_u16 + , encode_u32 + , encode_u64 + , decode_u16 + , decode_u32 + , decode_u64 + + -- * Signed integers + , encode_s8 + , encode_s16 + , encode_s32 + , encode_s64 + , decode_s8 + , decode_s16 + , decode_s32 + , decode_s64 + + -- * Truncated unsigned integers + , encode_tu16 + , encode_tu32 + , encode_tu64 + , decode_tu16 + , decode_tu32 + , decode_tu64 + + -- * BigSize + , encode_bigsize + , decode_bigsize + , BigSizeError(..) + , decode_bigsize_detailed + + -- * Length-prefixed bytes + , encode_u16_prefixed + , decode_u16_prefixed + + -- * Fixed-size field codecs + , decode_chain_hash + , decode_channel_id + , decode_signature + , decode_point + , decode_payment_hash + , decode_payment_preimage + , decode_per_commitment_secret + , encode_short_channel_id + , decode_short_channel_id + , encode_satoshi + , decode_satoshi + , encode_milli_satoshi + , decode_milli_satoshi + ) where + +import Control.DeepSeq (NFData(..)) +import Data.Bits ((.&.), (.|.), unsafeShiftL, unsafeShiftR, xor) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Unsafe as BU +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.Ptr (Ptr) +import Foreign.Storable (pokeByteOff) +import GHC.Generics (Generic) + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +-- constant-time equality on equal-length bytestrings +ct_eq :: BS.ByteString -> BS.ByteString -> Bool +ct_eq a b + | BS.length a /= BS.length b = False + | otherwise = go 0 0 + where + !n = BS.length a + go :: Word8 -> Int -> Bool + go !acc !i + | i == n = acc == 0 + | otherwise = + go (acc .|. (BU.unsafeIndex a i `xor` BU.unsafeIndex b i)) + (i + 1) + +-- take exactly n bytes from the front of the input +take_n :: Int -> BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) +take_n !n !bs + | BS.length bs < n = Nothing + | otherwise = Just (BU.unsafeTake n bs, BU.unsafeDrop n bs) +{-# INLINE take_n #-} + +-- fixed-size byte types ------------------------------------------------------ + +-- | A 32-byte chain hash, identifying the chain a channel or message +-- belongs to. +newtype ChainHash = ChainHash BS.ByteString + deriving (Eq, Ord, Show, Generic) + +instance NFData ChainHash + +-- | Construct a 'ChainHash' from exactly 32 bytes. +-- +-- >>> fmap (BS.length . un_chain_hash) (chain_hash (BS.replicate 32 0)) +-- Just 32 +-- >>> chain_hash "too short" +-- Nothing +chain_hash :: BS.ByteString -> Maybe ChainHash +chain_hash bs + | BS.length bs == 32 = Just (ChainHash bs) + | otherwise = Nothing +{-# INLINE chain_hash #-} + +-- | The bytes of a 'ChainHash'. +un_chain_hash :: ChainHash -> BS.ByteString +un_chain_hash (ChainHash bs) = bs +{-# INLINE un_chain_hash #-} + +-- | A 32-byte channel identifier. +newtype ChannelId = ChannelId BS.ByteString + deriving (Eq, Ord, Show, Generic) + +instance NFData ChannelId + +-- | Construct a 'ChannelId' from exactly 32 bytes. +-- +-- >>> fmap (BS.length . un_channel_id) (channel_id (BS.replicate 32 1)) +-- Just 32 +channel_id :: BS.ByteString -> Maybe ChannelId +channel_id bs + | BS.length bs == 32 = Just (ChannelId bs) + | otherwise = Nothing +{-# INLINE channel_id #-} + +-- | The bytes of a 'ChannelId'. +un_channel_id :: ChannelId -> BS.ByteString +un_channel_id (ChannelId bs) = bs +{-# INLINE un_channel_id #-} + +-- | The all-zero channel identifier, which refers to all channels +-- (e.g. in connection-level @error@ and @warning@ messages). +all_channels :: ChannelId +all_channels = ChannelId (BS.replicate 32 0x00) + +-- | A 64-byte compact ECDSA signature. +newtype Signature = Signature BS.ByteString + deriving (Eq, Ord, Show, Generic) + +instance NFData Signature + +-- | Construct a 'Signature' from exactly 64 bytes. +-- +-- >>> signature (BS.replicate 63 0x00) +-- Nothing +signature :: BS.ByteString -> Maybe Signature +signature bs + | BS.length bs == 64 = Just (Signature bs) + | otherwise = Nothing +{-# INLINE signature #-} + +-- | The bytes of a 'Signature'. +un_signature :: Signature -> BS.ByteString +un_signature (Signature bs) = bs +{-# INLINE un_signature #-} + +-- | A 33-byte compressed secp256k1 point. +newtype Point = Point BS.ByteString + deriving (Eq, Ord, Show, Generic) + +instance NFData Point + +-- | Construct a 'Point' from 33 bytes with a compressed-encoding +-- prefix (0x02 or 0x03). The curve equation is not checked; use +-- ppad-secp256k1 to parse the point if it must be on the curve. +-- +-- >>> point (BS.cons 0x04 (BS.replicate 32 0x01)) +-- Nothing +point :: BS.ByteString -> Maybe Point +point bs + | BS.length bs == 33 + , let !h = BU.unsafeIndex bs 0 + , h == 0x02 || h == 0x03 = Just (Point bs) + | otherwise = Nothing +{-# INLINE point #-} + +-- | The bytes of a 'Point'. +un_point :: Point -> BS.ByteString +un_point (Point bs) = bs +{-# INLINE un_point #-} + +-- | A 32-byte SHA256 payment hash. +newtype PaymentHash = PaymentHash BS.ByteString + deriving (Eq, Ord, Show, Generic) + +instance NFData PaymentHash + +-- | Construct a 'PaymentHash' from exactly 32 bytes. +payment_hash :: BS.ByteString -> Maybe PaymentHash +payment_hash bs + | BS.length bs == 32 = Just (PaymentHash bs) + | otherwise = Nothing +{-# INLINE payment_hash #-} + +-- | The bytes of a 'PaymentHash'. +un_payment_hash :: PaymentHash -> BS.ByteString +un_payment_hash (PaymentHash bs) = bs +{-# INLINE un_payment_hash #-} + +-- | A 32-byte payment preimage. +-- +-- This is secret material: its 'Show' instance is redacted and its +-- 'Eq' instance runs in constant time. +newtype PaymentPreimage = PaymentPreimage BS.ByteString + +instance Eq PaymentPreimage where + PaymentPreimage a == PaymentPreimage b = ct_eq a b + +instance Show PaymentPreimage where + showsPrec d _ = showParen (d > 10) $ + showString "PaymentPreimage " + +instance NFData PaymentPreimage where + rnf (PaymentPreimage bs) = rnf bs + +-- | Construct a 'PaymentPreimage' from exactly 32 bytes. +payment_preimage :: BS.ByteString -> Maybe PaymentPreimage +payment_preimage bs + | BS.length bs == 32 = Just (PaymentPreimage bs) + | otherwise = Nothing +{-# INLINE payment_preimage #-} + +-- | The bytes of a 'PaymentPreimage'. +un_payment_preimage :: PaymentPreimage -> BS.ByteString +un_payment_preimage (PaymentPreimage bs) = bs +{-# INLINE un_payment_preimage #-} + +-- | A 32-byte per-commitment secret. +-- +-- This is secret material: its 'Show' instance is redacted and its +-- 'Eq' instance runs in constant time. +newtype PerCommitmentSecret = PerCommitmentSecret BS.ByteString + +instance Eq PerCommitmentSecret where + PerCommitmentSecret a == PerCommitmentSecret b = ct_eq a b + +instance Show PerCommitmentSecret where + showsPrec d _ = showParen (d > 10) $ + showString "PerCommitmentSecret " + +instance NFData PerCommitmentSecret where + rnf (PerCommitmentSecret bs) = rnf bs + +-- | Construct a 'PerCommitmentSecret' from exactly 32 bytes. +per_commitment_secret :: BS.ByteString -> Maybe PerCommitmentSecret +per_commitment_secret bs + | BS.length bs == 32 = Just (PerCommitmentSecret bs) + | otherwise = Nothing +{-# INLINE per_commitment_secret #-} + +-- | The bytes of a 'PerCommitmentSecret'. +un_per_commitment_secret :: PerCommitmentSecret -> BS.ByteString +un_per_commitment_secret (PerCommitmentSecret bs) = bs +{-# INLINE un_per_commitment_secret #-} + +-- short channel identifiers -------------------------------------------------- + +-- | A short channel identifier: block height (3 bytes), transaction +-- index (3 bytes) and output index (2 bytes), packed big-endian into +-- a 'Word64'. Every 'Word64' is a valid packing. +newtype ShortChannelId = ShortChannelId Word64 + deriving (Eq, Ord, Show, Generic) + +instance NFData ShortChannelId + +-- | Construct a 'ShortChannelId' from its components. Fails if the +-- block height or transaction index exceed 24 bits. +-- +-- >>> short_channel_id 539268 845 1 +-- Just (ShortChannelId 592931436542885889) +short_channel_id + :: Word32 -- ^ block height + -> Word32 -- ^ transaction index + -> Word16 -- ^ output index + -> Maybe ShortChannelId +short_channel_id h t o + | h > 0xFFFFFF = Nothing + | t > 0xFFFFFF = Nothing + | otherwise = Just $! ShortChannelId $! + (fi h `unsafeShiftL` 40) + .|. (fi t `unsafeShiftL` 16) + .|. fi o +{-# INLINE short_channel_id #-} + +-- | The block height of a 'ShortChannelId'. +scid_block_height :: ShortChannelId -> Word32 +scid_block_height (ShortChannelId w) = fi (w `unsafeShiftR` 40) +{-# INLINE scid_block_height #-} + +-- | The transaction index of a 'ShortChannelId'. +scid_tx_index :: ShortChannelId -> Word32 +scid_tx_index (ShortChannelId w) = fi ((w `unsafeShiftR` 16) .&. 0xFFFFFF) +{-# INLINE scid_tx_index #-} + +-- | The output index of a 'ShortChannelId'. +scid_output_index :: ShortChannelId -> Word16 +scid_output_index (ShortChannelId w) = fi (w .&. 0xFFFF) +{-# INLINE scid_output_index #-} + +-- amounts -------------------------------------------------------------------- + +-- | An amount in satoshis, at most 21 million BTC ('max_satoshi'). +newtype Satoshi = Satoshi Word64 + deriving (Eq, Ord, Show, Generic) + +instance NFData Satoshi + +-- | An amount in millisatoshis, at most 21 million BTC +-- ('max_milli_satoshi'). +newtype MilliSatoshi = MilliSatoshi Word64 + deriving (Eq, Ord, Show, Generic) + +instance NFData MilliSatoshi + +-- | 21 million BTC, in satoshis (0x000775f05a074000). +max_satoshi :: Satoshi +max_satoshi = Satoshi 0x000775f05a074000 + +-- | 21 million BTC, in millisatoshis (0x1d24b2dfac520000). +max_milli_satoshi :: MilliSatoshi +max_milli_satoshi = MilliSatoshi 0x1d24b2dfac520000 + +-- | Construct a 'Satoshi' amount, failing above 21 million BTC. +-- +-- >>> satoshi 1000 +-- Just (Satoshi 1000) +-- >>> satoshi 0xffffffffffffffff +-- Nothing +satoshi :: Word64 -> Maybe Satoshi +satoshi w + | w <= 0x000775f05a074000 = Just (Satoshi w) + | otherwise = Nothing +{-# INLINE satoshi #-} + +-- | The number of satoshis. +un_satoshi :: Satoshi -> Word64 +un_satoshi (Satoshi w) = w +{-# INLINE un_satoshi #-} + +-- | Construct a 'MilliSatoshi' amount, failing above 21 million BTC. +milli_satoshi :: Word64 -> Maybe MilliSatoshi +milli_satoshi w + | w <= 0x1d24b2dfac520000 = Just (MilliSatoshi w) + | otherwise = Nothing +{-# INLINE milli_satoshi #-} + +-- | The number of millisatoshis. +un_milli_satoshi :: MilliSatoshi -> Word64 +un_milli_satoshi (MilliSatoshi w) = w +{-# INLINE un_milli_satoshi #-} + +-- | Convert satoshis to millisatoshis. Total, since the bounds +-- correspond. +-- +-- >>> fmap sat_to_msat (satoshi 5) +-- Just (MilliSatoshi 5000) +sat_to_msat :: Satoshi -> MilliSatoshi +sat_to_msat (Satoshi s) = MilliSatoshi (s * 1000) +{-# INLINE sat_to_msat #-} + +-- | Convert millisatoshis to satoshis, rounding down. +msat_to_sat :: MilliSatoshi -> Satoshi +msat_to_sat (MilliSatoshi m) = Satoshi (m `quot` 1000) +{-# INLINE msat_to_sat #-} + +-- | Add two amounts, failing above 21 million BTC. (Amounts are +-- bounded well below 2^63, so the sum can't wrap.) +add_sat :: Satoshi -> Satoshi -> Maybe Satoshi +add_sat (Satoshi a) (Satoshi b) = satoshi (a + b) +{-# INLINE add_sat #-} + +-- | Subtract the second amount from the first, failing if the result +-- would be negative. +sub_sat :: Satoshi -> Satoshi -> Maybe Satoshi +sub_sat (Satoshi a) (Satoshi b) + | b > a = Nothing + | otherwise = Just (Satoshi (a - b)) +{-# INLINE sub_sat #-} + +-- | Add two amounts, failing above 21 million BTC. +add_msat :: MilliSatoshi -> MilliSatoshi -> Maybe MilliSatoshi +add_msat (MilliSatoshi a) (MilliSatoshi b) = milli_satoshi (a + b) +{-# INLINE add_msat #-} + +-- | Subtract the second amount from the first, failing if the result +-- would be negative. +sub_msat :: MilliSatoshi -> MilliSatoshi -> Maybe MilliSatoshi +sub_msat (MilliSatoshi a) (MilliSatoshi b) + | b > a = Nothing + | otherwise = Just (MilliSatoshi (a - b)) +{-# INLINE sub_msat #-} + +-- unsigned integers ---------------------------------------------------------- + +poke8 :: Ptr Word8 -> Int -> Word8 -> IO () +poke8 = pokeByteOff +{-# INLINE poke8 #-} + +-- | Encode a 'Word16' as 2 big-endian bytes. +-- +-- >>> encode_u16 0x0102 +-- "\SOH\STX" +encode_u16 :: Word16 -> BS.ByteString +encode_u16 w = BI.unsafeCreate 2 $ \p -> do + poke8 p 0 (fi (w `unsafeShiftR` 8)) + poke8 p 1 (fi w) +{-# INLINE encode_u16 #-} + +-- | Encode a 'Word32' as 4 big-endian bytes. +encode_u32 :: Word32 -> BS.ByteString +encode_u32 w = BI.unsafeCreate 4 $ \p -> do + poke8 p 0 (fi (w `unsafeShiftR` 24)) + poke8 p 1 (fi (w `unsafeShiftR` 16)) + poke8 p 2 (fi (w `unsafeShiftR` 8)) + poke8 p 3 (fi w) +{-# INLINE encode_u32 #-} + +-- | Encode a 'Word64' as 8 big-endian bytes. +encode_u64 :: Word64 -> BS.ByteString +encode_u64 w = BI.unsafeCreate 8 $ \p -> do + poke8 p 0 (fi (w `unsafeShiftR` 56)) + poke8 p 1 (fi (w `unsafeShiftR` 48)) + poke8 p 2 (fi (w `unsafeShiftR` 40)) + poke8 p 3 (fi (w `unsafeShiftR` 32)) + poke8 p 4 (fi (w `unsafeShiftR` 24)) + poke8 p 5 (fi (w `unsafeShiftR` 16)) + poke8 p 6 (fi (w `unsafeShiftR` 8)) + poke8 p 7 (fi w) +{-# INLINE encode_u64 #-} + +-- big-endian word from the first n bytes (n <= 8, length checked) +be :: Int -> BS.ByteString -> Word64 +be n bs = go 0 0 + where + go !acc !i + | i == n = acc + | otherwise = + go ((acc `unsafeShiftL` 8) .|. fi (BU.unsafeIndex bs i)) (i + 1) +{-# INLINE be #-} + +-- | Decode 2 big-endian bytes, returning the remaining input. +-- +-- >>> decode_u16 "\SOH\STXrest" +-- Just (258,"rest") +decode_u16 :: BS.ByteString -> Maybe (Word16, BS.ByteString) +decode_u16 bs + | BS.length bs < 2 = Nothing + | otherwise = Just (fi (be 2 bs), BU.unsafeDrop 2 bs) +{-# INLINE decode_u16 #-} + +-- | Decode 4 big-endian bytes, returning the remaining input. +decode_u32 :: BS.ByteString -> Maybe (Word32, BS.ByteString) +decode_u32 bs + | BS.length bs < 4 = Nothing + | otherwise = Just (fi (be 4 bs), BU.unsafeDrop 4 bs) +{-# INLINE decode_u32 #-} + +-- | Decode 8 big-endian bytes, returning the remaining input. +decode_u64 :: BS.ByteString -> Maybe (Word64, BS.ByteString) +decode_u64 bs + | BS.length bs < 8 = Nothing + | otherwise = Just (be 8 bs, BU.unsafeDrop 8 bs) +{-# INLINE decode_u64 #-} + +-- signed integers ------------------------------------------------------------ + +-- | Encode an 'Int8' as 1 byte (two's complement). +-- +-- >>> encode_s8 (-42) +-- "\214" +encode_s8 :: Int8 -> BS.ByteString +encode_s8 = BS.singleton . fi +{-# INLINE encode_s8 #-} + +-- | Encode an 'Int16' as 2 big-endian bytes (two's complement). +encode_s16 :: Int16 -> BS.ByteString +encode_s16 = encode_u16 . fi +{-# INLINE encode_s16 #-} + +-- | Encode an 'Int32' as 4 big-endian bytes (two's complement). +encode_s32 :: Int32 -> BS.ByteString +encode_s32 = encode_u32 . fi +{-# INLINE encode_s32 #-} + +-- | Encode an 'Int64' as 8 big-endian bytes (two's complement). +encode_s64 :: Int64 -> BS.ByteString +encode_s64 = encode_u64 . fi +{-# INLINE encode_s64 #-} + +-- | Decode 1 byte (two's complement), returning the remaining input. +decode_s8 :: BS.ByteString -> Maybe (Int8, BS.ByteString) +decode_s8 bs = case BS.uncons bs of + Just (h, t) -> Just (fi h, t) + Nothing -> Nothing +{-# INLINE decode_s8 #-} + +-- | Decode 2 big-endian bytes (two's complement). +decode_s16 :: BS.ByteString -> Maybe (Int16, BS.ByteString) +decode_s16 bs = case decode_u16 bs of + Just (w, t) -> Just (fi w, t) + Nothing -> Nothing +{-# INLINE decode_s16 #-} + +-- | Decode 4 big-endian bytes (two's complement). +decode_s32 :: BS.ByteString -> Maybe (Int32, BS.ByteString) +decode_s32 bs = case decode_u32 bs of + Just (w, t) -> Just (fi w, t) + Nothing -> Nothing +{-# INLINE decode_s32 #-} + +-- | Decode 8 big-endian bytes (two's complement). +decode_s64 :: BS.ByteString -> Maybe (Int64, BS.ByteString) +decode_s64 bs = case decode_u64 bs of + Just (w, t) -> Just (fi w, t) + Nothing -> Nothing +{-# INLINE decode_s64 #-} + +-- truncated unsigned integers ------------------------------------------------ + +-- minimal big-endian encoding: no leading zero bytes (zero is empty) +encode_tu :: Word64 -> BS.ByteString +encode_tu w = BS.drop (lz 0) (encode_u64 w) + where + lz :: Int -> Int + lz !i + | i < 8 && (w `unsafeShiftR` (56 - 8 * i)) .&. 0xff == 0 = lz (i + 1) + | otherwise = i + +decode_tu :: Int -> BS.ByteString -> Maybe Word64 +decode_tu maxlen bs + | n > maxlen = Nothing + | n > 0 && BU.unsafeIndex bs 0 == 0 = Nothing + | otherwise = Just (be n bs) + where + !n = BS.length bs + +-- | Encode a 'Word16' as a truncated integer (no leading zero bytes). +-- +-- >>> encode_tu16 0 +-- "" +-- >>> encode_tu16 0x0100 +-- "\SOH\NUL" +encode_tu16 :: Word16 -> BS.ByteString +encode_tu16 = encode_tu . fi + +-- | Encode a 'Word32' as a truncated integer (no leading zero bytes). +encode_tu32 :: Word32 -> BS.ByteString +encode_tu32 = encode_tu . fi + +-- | Encode a 'Word64' as a truncated integer (no leading zero bytes). +encode_tu64 :: Word64 -> BS.ByteString +encode_tu64 = encode_tu + +-- | Decode a truncated 16-bit integer occupying the whole input. Fails +-- on more than 2 bytes or a non-minimal encoding. +-- +-- >>> decode_tu16 "\SOH\NUL" +-- Just 256 +-- >>> decode_tu16 "\NUL\SOH" +-- Nothing +decode_tu16 :: BS.ByteString -> Maybe Word16 +decode_tu16 = fmap fi . decode_tu 2 + +-- | Decode a truncated 32-bit integer occupying the whole input. Fails +-- on more than 4 bytes or a non-minimal encoding. +decode_tu32 :: BS.ByteString -> Maybe Word32 +decode_tu32 = fmap fi . decode_tu 4 + +-- | Decode a truncated 64-bit integer occupying the whole input. Fails +-- on more than 8 bytes or a non-minimal encoding. +decode_tu64 :: BS.ByteString -> Maybe Word64 +decode_tu64 = decode_tu 8 + +-- bigsize -------------------------------------------------------------------- + +-- | Encode a 'Word64' in the minimal BigSize format. +-- +-- >>> encode_bigsize 252 +-- "\252" +-- >>> encode_bigsize 253 +-- "\253\NUL\253" +encode_bigsize :: Word64 -> BS.ByteString +encode_bigsize w + | w < 0xfd = BS.singleton (fi w) + | w <= 0xffff = BS.cons 0xfd (encode_u16 (fi w)) + | w <= 0xffffffff = BS.cons 0xfe (encode_u32 (fi w)) + | otherwise = BS.cons 0xff (encode_u64 w) + +-- | Why a BigSize failed to decode. +data BigSizeError + = BigSizeTruncated -- ^ input ended early + | BigSizeNonMinimal -- ^ a shorter encoding exists + deriving (Eq, Show, Generic) + +instance NFData BigSizeError + +-- | Decode a BigSize, distinguishing truncation from non-minimal +-- encodings. +decode_bigsize_detailed + :: BS.ByteString -> Either BigSizeError (Word64, BS.ByteString) +decode_bigsize_detailed bs = case BS.uncons bs of + Nothing -> Left BigSizeTruncated + Just (h, t) -> case h of + 0xfd -> wide 2 0xfd t + 0xfe -> wide 4 0x10000 t + 0xff -> wide 8 0x100000000 t + _ -> Right (fi h, t) + where + wide n lo t = case take_n n t of + Nothing -> Left BigSizeTruncated + Just (v, r) + | w < lo -> Left BigSizeNonMinimal + | otherwise -> Right (w, r) + where + !w = be n v + +-- | Decode a minimally-encoded BigSize, returning the remaining input. +-- +-- >>> decode_bigsize "\253\NUL\253rest" +-- Just (253,"rest") +-- >>> decode_bigsize "\253\NUL\252" +-- Nothing +decode_bigsize :: BS.ByteString -> Maybe (Word64, BS.ByteString) +decode_bigsize bs = case decode_bigsize_detailed bs of + Right r -> Just r + Left _ -> Nothing + +-- length-prefixed bytes ------------------------------------------------------ + +-- | Prefix bytes with their length as a u16. Fails if the input +-- exceeds 65535 bytes. +-- +-- >>> encode_u16_prefixed "abc" +-- Just "\NUL\ETXabc" +encode_u16_prefixed :: BS.ByteString -> Maybe BS.ByteString +encode_u16_prefixed bs + | BS.length bs > 0xffff = Nothing + | otherwise = Just (encode_u16 (fi (BS.length bs)) <> bs) + +-- | Decode u16-length-prefixed bytes, returning the remaining input. +-- +-- >>> decode_u16_prefixed "\NUL\ETXabcrest" +-- Just ("abc","rest") +decode_u16_prefixed + :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) +decode_u16_prefixed bs = do + (n, rest) <- decode_u16 bs + take_n (fi n) rest + +-- fixed-size field codecs ---------------------------------------------------- + +-- | Decode a 32-byte 'ChainHash', returning the remaining input. +decode_chain_hash :: BS.ByteString -> Maybe (ChainHash, BS.ByteString) +decode_chain_hash bs = do + (h, r) <- take_n 32 bs + pure (ChainHash h, r) + +-- | Decode a 32-byte 'ChannelId', returning the remaining input. +decode_channel_id :: BS.ByteString -> Maybe (ChannelId, BS.ByteString) +decode_channel_id bs = do + (h, r) <- take_n 32 bs + pure (ChannelId h, r) + +-- | Decode a 64-byte 'Signature', returning the remaining input. +decode_signature :: BS.ByteString -> Maybe (Signature, BS.ByteString) +decode_signature bs = do + (h, r) <- take_n 64 bs + pure (Signature h, r) + +-- | Decode a 33-byte 'Point', returning the remaining input. Fails if +-- the prefix byte is not 0x02 or 0x03. +decode_point :: BS.ByteString -> Maybe (Point, BS.ByteString) +decode_point bs = do + (h, r) <- take_n 33 bs + p <- point h + pure (p, r) + +-- | Decode a 32-byte 'PaymentHash', returning the remaining input. +decode_payment_hash :: BS.ByteString -> Maybe (PaymentHash, BS.ByteString) +decode_payment_hash bs = do + (h, r) <- take_n 32 bs + pure (PaymentHash h, r) + +-- | Decode a 32-byte 'PaymentPreimage', returning the remaining input. +decode_payment_preimage + :: BS.ByteString -> Maybe (PaymentPreimage, BS.ByteString) +decode_payment_preimage bs = do + (h, r) <- take_n 32 bs + pure (PaymentPreimage h, r) + +-- | Decode a 32-byte 'PerCommitmentSecret', returning the remaining +-- input. +decode_per_commitment_secret + :: BS.ByteString -> Maybe (PerCommitmentSecret, BS.ByteString) +decode_per_commitment_secret bs = do + (h, r) <- take_n 32 bs + pure (PerCommitmentSecret h, r) + +-- | Encode a 'ShortChannelId' as 8 big-endian bytes. +encode_short_channel_id :: ShortChannelId -> BS.ByteString +encode_short_channel_id (ShortChannelId w) = encode_u64 w +{-# INLINE encode_short_channel_id #-} + +-- | Decode an 8-byte 'ShortChannelId', returning the remaining input. +decode_short_channel_id + :: BS.ByteString -> Maybe (ShortChannelId, BS.ByteString) +decode_short_channel_id bs = do + (w, r) <- decode_u64 bs + pure (ShortChannelId w, r) +{-# INLINE decode_short_channel_id #-} + +-- | Encode a 'Satoshi' amount as a u64. +encode_satoshi :: Satoshi -> BS.ByteString +encode_satoshi (Satoshi w) = encode_u64 w +{-# INLINE encode_satoshi #-} + +-- | Decode a u64 'Satoshi' amount, returning the remaining input. Fails +-- above 21 million BTC. +decode_satoshi :: BS.ByteString -> Maybe (Satoshi, BS.ByteString) +decode_satoshi bs = do + (w, r) <- decode_u64 bs + s <- satoshi w + pure (s, r) +{-# INLINE decode_satoshi #-} + +-- | Encode a 'MilliSatoshi' amount as a u64. +encode_milli_satoshi :: MilliSatoshi -> BS.ByteString +encode_milli_satoshi (MilliSatoshi w) = encode_u64 w +{-# INLINE encode_milli_satoshi #-} + +-- | Decode a u64 'MilliSatoshi' amount, returning the remaining input. +-- Fails above 21 million BTC. +decode_milli_satoshi + :: BS.ByteString -> Maybe (MilliSatoshi, BS.ByteString) +decode_milli_satoshi bs = do + (w, r) <- decode_u64 bs + m <- milli_satoshi w + pure (m, r) +{-# INLINE decode_milli_satoshi #-} diff --git a/lib/Lightning/Protocol/BOLT1/TLV.hs b/lib/Lightning/Protocol/BOLT1/TLV.hs --- a/lib/Lightning/Protocol/BOLT1/TLV.hs +++ b/lib/Lightning/Protocol/BOLT1/TLV.hs @@ -1,7 +1,6 @@ -{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -- | -- Module: Lightning.Protocol.BOLT1.TLV @@ -9,236 +8,149 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- TLV (Type-Length-Value) format for BOLT #1. +-- The TLV (type-length-value) format of BOLT #1. module Lightning.Protocol.BOLT1.TLV ( - -- * TLV types TlvRecord(..) , TlvStream - , unTlvStream - , tlvStream - , unsafeTlvStream + , tlv_stream + , un_tlv_stream + , empty_tlv_stream + , lookup_tlv + , filter_tlv_stream , TlvError(..) - - -- * TLV encoding - , encodeTlvRecord - , encodeTlvStream - - -- * TLV decoding - , decodeTlvStream - , decodeTlvStreamWith - , decodeTlvStreamRaw - - -- * Init TLV types - , InitTlv(..) - , parseInitTlvs - , encodeInitTlvs - - -- * Re-exports - , ChainHash - , chainHash - , unChainHash + , encode_tlv_stream + , decode_tlv_stream ) where import Control.DeepSeq (NFData) -import Control.Monad (when) import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BU +import qualified Data.List as L import Data.Word (Word64) import GHC.Generics (Generic) import Lightning.Protocol.BOLT1.Prim --- TLV types ------------------------------------------------------------------- - -- | A single TLV record. data TlvRecord = TlvRecord - { tlvType :: {-# UNPACK #-} !Word64 - , tlvValue :: !BS.ByteString - } deriving stock (Eq, Show, Generic) + { tlv_type :: {-# UNPACK #-} !Word64 + , tlv_value :: !BS.ByteString + } deriving (Eq, Show, Generic) instance NFData TlvRecord --- | A TLV stream (series of TLV records). -newtype TlvStream = TlvStream { unTlvStream :: [TlvRecord] } - deriving stock (Eq, Show, Generic) +-- | A TLV stream: records in strictly increasing type order. +newtype TlvStream = TlvStream [TlvRecord] + deriving (Eq, Show, Generic) instance NFData TlvStream --- | Smart constructor for 'TlvStream' that validates records are --- strictly increasing by type. +-- | Construct a 'TlvStream' from records in any order. Fails if two +-- records share a type. -- --- Returns 'Nothing' if types are not strictly increasing. -tlvStream :: [TlvRecord] -> Maybe TlvStream -tlvStream recs - | isStrictlyIncreasing (map tlvType recs) = Just (TlvStream recs) - | otherwise = Nothing +-- >>> let Just s = tlv_stream [TlvRecord 3 "b", TlvRecord 1 "a"] +-- >>> map tlv_type (un_tlv_stream s) +-- [1,3] +-- >>> tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] +-- Nothing +tlv_stream :: [TlvRecord] -> Maybe TlvStream +tlv_stream rs + | increasing sorted = Just (TlvStream sorted) + | otherwise = Nothing where - isStrictlyIncreasing :: [Word64] -> Bool - isStrictlyIncreasing [] = True - isStrictlyIncreasing [_] = True - isStrictlyIncreasing (x:y:rest) = x < y && isStrictlyIncreasing (y:rest) + sorted = L.sortOn tlv_type rs --- | Unsafe constructor for 'TlvStream' that skips validation. --- --- Use only when ordering is already guaranteed (e.g., in decode functions). -unsafeTlvStream :: [TlvRecord] -> TlvStream -unsafeTlvStream = TlvStream +increasing :: [TlvRecord] -> Bool +increasing (a:rest@(b:_)) = tlv_type a < tlv_type b && increasing rest +increasing _ = True --- | TLV decoding errors. -data TlvError - = TlvNonMinimalEncoding - | TlvNotStrictlyIncreasing - | TlvLengthExceedsBounds - | TlvUnknownEvenType !Word64 - | TlvInvalidKnownType !Word64 - deriving stock (Eq, Show, Generic) +-- | The records of a 'TlvStream', in increasing type order. +un_tlv_stream :: TlvStream -> [TlvRecord] +un_tlv_stream (TlvStream rs) = rs +{-# INLINE un_tlv_stream #-} -instance NFData TlvError +-- | The empty 'TlvStream'. +empty_tlv_stream :: TlvStream +empty_tlv_stream = TlvStream [] --- TLV encoding ---------------------------------------------------------------- +-- | The value of the record with the given type, if present. +-- +-- >>> lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"] +-- Just "b" +lookup_tlv :: Word64 -> TlvStream -> Maybe BS.ByteString +lookup_tlv t (TlvStream rs) = go rs + where + go [] = Nothing + go (TlvRecord u v : more) + | u == t = Just v + | u > t = Nothing + | otherwise = go more --- | Encode a TLV record. -encodeTlvRecord :: TlvRecord -> BS.ByteString -encodeTlvRecord (TlvRecord typ val) = mconcat - [ encodeBigSize typ - , encodeBigSize (fromIntegral (BS.length val)) - , val - ] +-- | Keep the records whose types satisfy the predicate. +-- +-- >>> let Just s = tlv_stream [TlvRecord 1 "", TlvRecord 2 ""] +-- >>> map tlv_type (un_tlv_stream (filter_tlv_stream odd s)) +-- [1] +filter_tlv_stream :: (Word64 -> Bool) -> TlvStream -> TlvStream +filter_tlv_stream p (TlvStream rs) = TlvStream (filter (p . tlv_type) rs) --- | Encode a TLV stream. -encodeTlvStream :: TlvStream -> BS.ByteString -encodeTlvStream (TlvStream recs) = mconcat (map encodeTlvRecord recs) +-- | Why a TLV stream failed to decode. +data TlvError + = TlvTruncated -- ^ a type, length or value was cut off + | TlvNonMinimalBigSize -- ^ a type or length wasn't minimal + | TlvNotStrictlyIncreasing -- ^ types out of order or repeated + | TlvUnknownEvenType !Word64 -- ^ an even type the context doesn't know + deriving (Eq, Show, Generic) --- TLV decoding ---------------------------------------------------------------- +instance NFData TlvError --- | Decode a TLV stream without any known-type validation. --- --- This decoder only enforces structural validity: --- - Types must be strictly increasing --- - Lengths must not exceed bounds +-- | Encode a 'TlvStream'. -- --- All records are returned regardless of type. Note: this does NOT --- enforce the BOLT #1 unknown-even-type rule. Use 'decodeTlvStreamWith' --- with an appropriate predicate for spec-compliant parsing. -decodeTlvStreamRaw :: BS.ByteString -> Either TlvError TlvStream -decodeTlvStreamRaw = go Nothing [] +-- >>> fmap encode_tlv_stream (tlv_stream [TlvRecord 1 "a"]) +-- Just "\SOH\SOHa" +encode_tlv_stream :: TlvStream -> BS.ByteString +encode_tlv_stream (TlvStream rs) = mconcat (concatMap enc rs) where - go :: Maybe Word64 -> [TlvRecord] -> BS.ByteString - -> Either TlvError TlvStream - go !_ !acc !bs - | BS.null bs = Right (unsafeTlvStream (reverse acc)) - go !mPrevType !acc !bs = do - (typ, rest1) <- maybe (Left TlvNonMinimalEncoding) Right - (decodeBigSize bs) - -- Strictly increasing check - case mPrevType of - Just prevType -> when (typ <= prevType) $ - Left TlvNotStrictlyIncreasing - Nothing -> pure () - (len, rest2) <- maybe (Left TlvNonMinimalEncoding) Right - (decodeBigSize rest1) - -- Length bounds check - when (fromIntegral len > BS.length rest2) $ - Left TlvLengthExceedsBounds - let !val = BS.take (fromIntegral len) rest2 - !rest3 = BS.drop (fromIntegral len) rest2 - !rec = TlvRecord typ val - go (Just typ) (rec : acc) rest3 + enc (TlvRecord t v) = + [encode_bigsize t, encode_bigsize (fromIntegral (BS.length v)), v] --- | Decode a TLV stream with configurable known-type predicate. +-- | Decode a TLV stream occupying the whole input, given a predicate +-- identifying the types known in the stream's context. -- --- Per BOLT #1: --- - Types must be strictly increasing --- - Unknown even types cause failure --- - Unknown odd types are skipped +-- Per BOLT #1, decoding fails on truncation, non-minimal BigSize +-- encodings, types that are not strictly increasing, and unknown +-- even types. Every record is kept, including unknown odd ones, so +-- re-encoding reproduces the input. -- --- The predicate determines which types are "known" for the context. -decodeTlvStreamWith - :: (Word64 -> Bool) -- ^ Predicate: is this type known? +-- >>> let Right s = decode_tlv_stream (== 1) "\SOH\SOHa\ETX\NUL" +-- >>> map tlv_type (un_tlv_stream s) +-- [1,3] +-- >>> decode_tlv_stream (== 1) "\STX\NUL" +-- Left (TlvUnknownEvenType 2) +decode_tlv_stream + :: (Word64 -> Bool) -- ^ is this type known? -> BS.ByteString -> Either TlvError TlvStream -decodeTlvStreamWith isKnown = go Nothing [] - where - go :: Maybe Word64 -> [TlvRecord] -> BS.ByteString - -> Either TlvError TlvStream - go !_ !acc !bs - | BS.null bs = Right (unsafeTlvStream (reverse acc)) - go !mPrevType !acc !bs = do - (typ, rest1) <- maybe (Left TlvNonMinimalEncoding) Right - (decodeBigSize bs) - -- Strictly increasing check - case mPrevType of - Just prevType -> when (typ <= prevType) $ - Left TlvNotStrictlyIncreasing - Nothing -> pure () - (len, rest2) <- maybe (Left TlvNonMinimalEncoding) Right - (decodeBigSize rest1) - -- Length bounds check - when (fromIntegral len > BS.length rest2) $ - Left TlvLengthExceedsBounds - let !val = BS.take (fromIntegral len) rest2 - !rest3 = BS.drop (fromIntegral len) rest2 - !rec = TlvRecord typ val - -- Unknown type handling: even = fail, odd = skip - if isKnown typ - then go (Just typ) (rec : acc) rest3 - else if even typ - then Left (TlvUnknownEvenType typ) - else go (Just typ) acc rest3 -- skip unknown odd - --- | Decode a TLV stream with BOLT #1 init_tlvs validation. --- --- This uses the default known types for init messages (1 and 3). --- For other contexts, use 'decodeTlvStreamWith' with an appropriate --- predicate. -decodeTlvStream :: BS.ByteString -> Either TlvError TlvStream -decodeTlvStream = decodeTlvStreamWith isInitTlvType - where - isInitTlvType :: Word64 -> Bool - isInitTlvType 1 = True -- networks - isInitTlvType 3 = True -- remote_addr - isInitTlvType _ = False - --- Init TLV types -------------------------------------------------------------- - --- | TLV records for init message. -data InitTlv - = InitNetworks ![ChainHash] -- ^ Type 1: chain hashes (32 bytes each) - | InitRemoteAddr !BS.ByteString -- ^ Type 3: remote address - deriving stock (Eq, Show, Generic) - -instance NFData InitTlv - --- | Parse init TLVs from a TLV stream. -parseInitTlvs :: TlvStream -> Either TlvError [InitTlv] -parseInitTlvs (TlvStream recs) = traverse parseOne recs +decode_tlv_stream known = go Nothing [] where - parseOne (TlvRecord 1 val) - | BS.length val `mod` 32 == 0 = - Right (InitNetworks (map mkChainHash (chunksOf 32 val))) - | otherwise = Left (TlvInvalidKnownType 1) - parseOne (TlvRecord 3 val) = Right (InitRemoteAddr val) - parseOne (TlvRecord t _) = Left (TlvUnknownEvenType t) - - -- Each chunk is exactly 32 bytes from chunksOf, so chainHash always - -- succeeds. We use a partial pattern match as the Nothing case is - -- unreachable given our chunksOf guarantee. - mkChainHash bs = case chainHash bs of - Just ch -> ch - Nothing -> error "parseInitTlvs: impossible - chunk is not 32 bytes" - --- | Split bytestring into chunks of given size. -chunksOf :: Int -> BS.ByteString -> [BS.ByteString] -chunksOf !n !bs - | BS.null bs = [] - | otherwise = - let (!chunk, !rest) = BS.splitAt n bs - in chunk : chunksOf n rest + go !_ !acc !bs | BS.null bs = Right (TlvStream (reverse acc)) + go !prev !acc !bs = do + (t, r0) <- bigsize bs + case prev of + Just p | t <= p -> Left TlvNotStrictlyIncreasing + _ -> pure () + (l, r1) <- bigsize r0 + if l > fromIntegral (BS.length r1) + then Left TlvTruncated + else do + let !n = fromIntegral l + !v = BU.unsafeTake n r1 + !r2 = BU.unsafeDrop n r1 + if not (known t) && even t + then Left (TlvUnknownEvenType t) + else go (Just t) (TlvRecord t v : acc) r2 --- | Encode init TLVs to a TLV stream. -encodeInitTlvs :: [InitTlv] -> TlvStream -encodeInitTlvs = unsafeTlvStream . map toRecord - where - toRecord (InitNetworks chains) = - TlvRecord 1 (mconcat (map unChainHash chains)) - toRecord (InitRemoteAddr addr) = - TlvRecord 3 addr + bigsize b = case decode_bigsize_detailed b of + Right r -> Right r + Left BigSizeTruncated -> Left TlvTruncated + Left BigSizeNonMinimal -> Left TlvNonMinimalBigSize diff --git a/ppad-bolt1.cabal b/ppad-bolt1.cabal --- a/ppad-bolt1.cabal +++ b/ppad-bolt1.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-bolt1 -version: 0.0.1 +version: 0.1.0 synopsis: Base protocol per BOLT #1 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: Base protocol, per @@ -25,6 +25,7 @@ -Wall exposed-modules: Lightning.Protocol.BOLT1 + other-modules: Lightning.Protocol.BOLT1.Codec Lightning.Protocol.BOLT1.Message Lightning.Protocol.BOLT1.Prim @@ -33,6 +34,7 @@ base >= 4.9 && < 5 , bytestring >= 0.9 && < 0.13 , deepseq >= 1.4 && < 1.6 + , ppad-bolt9 >= 0.1 && < 0.2 test-suite bolt1-tests type: exitcode-stdio-1.0 @@ -41,13 +43,14 @@ main-is: Main.hs ghc-options: - -rtsopts -Wall -O2 + -rtsopts -Wall build-depends: base , bytestring , ppad-base16 , ppad-bolt1 + , ppad-bolt9 , tasty , tasty-hunit , tasty-quickcheck @@ -66,8 +69,8 @@ base , bytestring , criterion - , deepseq , ppad-bolt1 + , ppad-bolt9 benchmark bolt1-weigh type: exitcode-stdio-1.0 @@ -82,6 +85,6 @@ build-depends: base , bytestring - , deepseq , ppad-bolt1 + , ppad-bolt9 , weigh diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,696 +4,545 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 -import Lightning.Protocol.BOLT1 -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -main :: IO () -main = defaultMain $ testGroup "ppad-bolt1" [ - bigsize_tests - , primitive_tests - , signed_tests - , truncated_tests - , minsigned_tests - , tlv_tests - , message_tests - , envelope_tests - , extension_tests - , bounds_tests - , property_tests - ] - --- BigSize test vectors from BOLT #1 Appendix A ------------------------------- - -bigsize_tests :: TestTree -bigsize_tests = testGroup "BigSize (Appendix A)" [ - testCase "zero" $ - encodeBigSize 0 @?= unhex "00" - , testCase "one byte high (252)" $ - encodeBigSize 252 @?= unhex "fc" - , testCase "two byte low (253)" $ - encodeBigSize 253 @?= unhex "fd00fd" - , testCase "two byte high (65535)" $ - encodeBigSize 65535 @?= unhex "fdffff" - , testCase "four byte low (65536)" $ - encodeBigSize 65536 @?= unhex "fe00010000" - , testCase "four byte high (4294967295)" $ - encodeBigSize 4294967295 @?= unhex "feffffffff" - , testCase "eight byte low (4294967296)" $ - encodeBigSize 4294967296 @?= unhex "ff0000000100000000" - , testCase "eight byte high (max u64)" $ - encodeBigSize 18446744073709551615 @?= unhex "ffffffffffffffffff" - , testCase "decode zero" $ - decodeBigSize (unhex "00") @?= Just (0, "") - , testCase "decode 252" $ - decodeBigSize (unhex "fc") @?= Just (252, "") - , testCase "decode 253" $ - decodeBigSize (unhex "fd00fd") @?= Just (253, "") - , testCase "decode 65535" $ - decodeBigSize (unhex "fdffff") @?= Just (65535, "") - , testCase "decode 65536" $ - decodeBigSize (unhex "fe00010000") @?= Just (65536, "") - , testCase "decode 4294967295" $ - decodeBigSize (unhex "feffffffff") @?= Just (4294967295, "") - , testCase "decode 4294967296" $ - decodeBigSize (unhex "ff0000000100000000") @?= Just (4294967296, "") - , testCase "decode max u64" $ - decodeBigSize (unhex "ffffffffffffffffff") @?= - Just (18446744073709551615, "") - , testCase "non-minimal 2-byte fails" $ - decodeBigSize (unhex "fd00fc") @?= Nothing - , testCase "non-minimal 4-byte fails" $ - decodeBigSize (unhex "fe0000ffff") @?= Nothing - , testCase "non-minimal 8-byte fails" $ - decodeBigSize (unhex "ff00000000ffffffff") @?= Nothing - ] - --- Primitive encode/decode tests ----------------------------------------------- - -primitive_tests :: TestTree -primitive_tests = testGroup "Primitives" [ - testCase "encodeU16 0x0102" $ - encodeU16 0x0102 @?= BS.pack [0x01, 0x02] - , testCase "decodeU16 0x0102" $ - decodeU16 (BS.pack [0x01, 0x02]) @?= Just (0x0102, "") - , testCase "encodeU32 0x01020304" $ - encodeU32 0x01020304 @?= BS.pack [0x01, 0x02, 0x03, 0x04] - , testCase "decodeU32 0x01020304" $ - decodeU32 (BS.pack [0x01, 0x02, 0x03, 0x04]) @?= Just (0x01020304, "") - , testCase "encodeU64" $ - encodeU64 0x0102030405060708 @?= - BS.pack [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08] - , testCase "decodeU64" $ - decodeU64 (BS.pack [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08]) @?= - Just (0x0102030405060708, "") - , testCase "decodeU16 insufficient" $ - decodeU16 (BS.pack [0x01]) @?= Nothing - , testCase "decodeU32 insufficient" $ - decodeU32 (BS.pack [0x01, 0x02]) @?= Nothing - , testCase "decodeU64 insufficient" $ - decodeU64 (BS.pack [0x01, 0x02, 0x03, 0x04]) @?= Nothing - ] - --- Signed integer tests --------------------------------------------------------- - -signed_tests :: TestTree -signed_tests = testGroup "Signed integers" [ - testCase "encodeS8 42" $ - encodeS8 42 @?= BS.pack [0x2a] - , testCase "encodeS8 -42" $ - encodeS8 (-42) @?= BS.pack [0xd6] - , testCase "encodeS8 127" $ - encodeS8 127 @?= BS.pack [0x7f] - , testCase "encodeS8 -128" $ - encodeS8 (-128) @?= BS.pack [0x80] - , testCase "decodeS8 42" $ - decodeS8 (BS.pack [0x2a]) @?= Just (42, "") - , testCase "decodeS8 -42" $ - decodeS8 (BS.pack [0xd6]) @?= Just (-42, "") - , testCase "encodeS16 -1" $ - encodeS16 (-1) @?= BS.pack [0xff, 0xff] - , testCase "encodeS16 32767" $ - encodeS16 32767 @?= BS.pack [0x7f, 0xff] - , testCase "encodeS16 -32768" $ - encodeS16 (-32768) @?= BS.pack [0x80, 0x00] - , testCase "decodeS16 -1" $ - decodeS16 (BS.pack [0xff, 0xff]) @?= Just (-1, "") - , testCase "encodeS32 -1" $ - encodeS32 (-1) @?= BS.pack [0xff, 0xff, 0xff, 0xff] - , testCase "encodeS32 2147483647" $ - encodeS32 2147483647 @?= BS.pack [0x7f, 0xff, 0xff, 0xff] - , testCase "encodeS32 -2147483648" $ - encodeS32 (-2147483648) @?= BS.pack [0x80, 0x00, 0x00, 0x00] - , testCase "decodeS32 -1" $ - decodeS32 (BS.pack [0xff, 0xff, 0xff, 0xff]) @?= Just (-1, "") - , testCase "encodeS64 -1" $ - encodeS64 (-1) @?= - BS.pack [0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff] - , testCase "decodeS64 -1" $ - decodeS64 (BS.pack [0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) @?= - Just (-1, "") - ] - --- Truncated unsigned integer tests --------------------------------------------- - -truncated_tests :: TestTree -truncated_tests = testGroup "Truncated unsigned integers" [ - testCase "encodeTu16 0" $ - encodeTu16 0 @?= "" - , testCase "encodeTu16 1" $ - encodeTu16 1 @?= BS.pack [0x01] - , testCase "encodeTu16 255" $ - encodeTu16 255 @?= BS.pack [0xff] - , testCase "encodeTu16 256" $ - encodeTu16 256 @?= BS.pack [0x01, 0x00] - , testCase "encodeTu16 65535" $ - encodeTu16 65535 @?= BS.pack [0xff, 0xff] - , testCase "decodeTu16 0 bytes" $ - decodeTu16 0 "" @?= Just (0, "") - , testCase "decodeTu16 1 byte" $ - decodeTu16 1 (BS.pack [0x01]) @?= Just (1, "") - , testCase "decodeTu16 2 bytes" $ - decodeTu16 2 (BS.pack [0x01, 0x00]) @?= Just (256, "") - , testCase "decodeTu16 non-minimal fails" $ - decodeTu16 2 (BS.pack [0x00, 0x01]) @?= Nothing - , testCase "encodeTu32 0" $ - encodeTu32 0 @?= "" - , testCase "encodeTu32 1" $ - encodeTu32 1 @?= BS.pack [0x01] - , testCase "encodeTu32 0x010000" $ - encodeTu32 0x010000 @?= BS.pack [0x01, 0x00, 0x00] - , testCase "encodeTu32 0x01000000" $ - encodeTu32 0x01000000 @?= BS.pack [0x01, 0x00, 0x00, 0x00] - , testCase "decodeTu32 0 bytes" $ - decodeTu32 0 "" @?= Just (0, "") - , testCase "decodeTu32 3 bytes" $ - decodeTu32 3 (BS.pack [0x01, 0x00, 0x00]) @?= Just (0x010000, "") - , testCase "decodeTu32 non-minimal fails" $ - decodeTu32 3 (BS.pack [0x00, 0x01, 0x00]) @?= Nothing - , testCase "encodeTu64 0" $ - encodeTu64 0 @?= "" - , testCase "encodeTu64 0x0100000000" $ - encodeTu64 0x0100000000 @?= BS.pack [0x01, 0x00, 0x00, 0x00, 0x00] - , testCase "decodeTu64 5 bytes" $ - decodeTu64 5 (BS.pack [0x01, 0x00, 0x00, 0x00, 0x00]) @?= - Just (0x0100000000, "") - , testCase "decodeTu64 non-minimal fails" $ - decodeTu64 5 (BS.pack [0x00, 0x01, 0x00, 0x00, 0x00]) @?= Nothing - ] - --- Minimal signed integer tests (Appendix D) ------------------------------------ - -minsigned_tests :: TestTree -minsigned_tests = testGroup "Minimal signed (Appendix D)" [ - -- Test vectors from BOLT #1 Appendix D - testCase "encode 0" $ - encodeMinSigned 0 @?= unhex "00" - , testCase "encode 42" $ - encodeMinSigned 42 @?= unhex "2a" - , testCase "encode -42" $ - encodeMinSigned (-42) @?= unhex "d6" - , testCase "encode 127" $ - encodeMinSigned 127 @?= unhex "7f" - , testCase "encode -128" $ - encodeMinSigned (-128) @?= unhex "80" - , testCase "encode 128" $ - encodeMinSigned 128 @?= unhex "0080" - , testCase "encode -129" $ - encodeMinSigned (-129) @?= unhex "ff7f" - , testCase "encode 15000" $ - encodeMinSigned 15000 @?= unhex "3a98" - , testCase "encode -15000" $ - encodeMinSigned (-15000) @?= unhex "c568" - , testCase "encode 32767" $ - encodeMinSigned 32767 @?= unhex "7fff" - , testCase "encode -32768" $ - encodeMinSigned (-32768) @?= unhex "8000" - , testCase "encode 32768" $ - encodeMinSigned 32768 @?= unhex "00008000" - , testCase "encode -32769" $ - encodeMinSigned (-32769) @?= unhex "ffff7fff" - , testCase "encode 21000000" $ - encodeMinSigned 21000000 @?= unhex "01406f40" - , testCase "encode -21000000" $ - encodeMinSigned (-21000000) @?= unhex "febf90c0" - , testCase "encode 2147483647" $ - encodeMinSigned 2147483647 @?= unhex "7fffffff" - , testCase "encode -2147483648" $ - encodeMinSigned (-2147483648) @?= unhex "80000000" - , testCase "encode 2147483648" $ - encodeMinSigned 2147483648 @?= unhex "0000000080000000" - , testCase "encode -2147483649" $ - encodeMinSigned (-2147483649) @?= unhex "ffffffff7fffffff" - , testCase "encode 500000000000" $ - encodeMinSigned 500000000000 @?= unhex "000000746a528800" - , testCase "encode -500000000000" $ - encodeMinSigned (-500000000000) @?= unhex "ffffff8b95ad7800" - , testCase "encode max int64" $ - encodeMinSigned 9223372036854775807 @?= unhex "7fffffffffffffff" - , testCase "encode min int64" $ - encodeMinSigned (-9223372036854775808) @?= unhex "8000000000000000" - -- Decode tests - , testCase "decode 1-byte 42" $ - decodeMinSigned 1 (unhex "2a") @?= Just (42, "") - , testCase "decode 1-byte -42" $ - decodeMinSigned 1 (unhex "d6") @?= Just (-42, "") - , testCase "decode 2-byte 128" $ - decodeMinSigned 2 (unhex "0080") @?= Just (128, "") - , testCase "decode 2-byte -129" $ - decodeMinSigned 2 (unhex "ff7f") @?= Just (-129, "") - , testCase "decode 4-byte 32768" $ - decodeMinSigned 4 (unhex "00008000") @?= Just (32768, "") - , testCase "decode 8-byte 2147483648" $ - decodeMinSigned 8 (unhex "0000000080000000") @?= Just (2147483648, "") - -- Minimality rejection - , testCase "decode 2-byte for 1-byte value fails" $ - decodeMinSigned 2 (unhex "0042") @?= Nothing -- 42 fits in 1 byte - , testCase "decode 4-byte for 2-byte value fails" $ - decodeMinSigned 4 (unhex "00000080") @?= Nothing -- 128 fits in 2 bytes - , testCase "decode 8-byte for 4-byte value fails" $ - decodeMinSigned 8 (unhex "0000000000008000") @?= Nothing -- 32768 fits in 4 - ] - --- TLV tests ------------------------------------------------------------------- - -tlv_tests :: TestTree -tlv_tests = testGroup "TLV" [ - testGroup "tlvStream smart constructor" [ - testCase "empty list succeeds" $ - tlvStream [] @?= Just (unsafeTlvStream []) - , testCase "single record succeeds" $ - tlvStream [TlvRecord 1 "a"] @?= Just (unsafeTlvStream [TlvRecord 1 "a"]) - , testCase "strictly increasing succeeds" $ - tlvStream [TlvRecord 1 "a", TlvRecord 3 "b", TlvRecord 5 "c"] @?= - Just (unsafeTlvStream [TlvRecord 1 "a", TlvRecord 3 "b", - TlvRecord 5 "c"]) - , testCase "non-increasing fails" $ - tlvStream [TlvRecord 5 "a", TlvRecord 3 "b"] @?= Nothing - , testCase "duplicate types fails" $ - tlvStream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing - , testCase "equal adjacent types fails" $ - tlvStream [TlvRecord 1 "a", TlvRecord 2 "b", TlvRecord 2 "c"] @?= - Nothing - ] - , testCase "empty stream" $ - decodeTlvStream "" @?= Right (unsafeTlvStream []) - , testCase "single record type 1" $ do - let bs = mconcat [ - encodeBigSize 1 -- type - , encodeBigSize 32 -- length - , BS.replicate 32 0x00 -- value (chain hash) - ] - case decodeTlvStream bs of - Right stream -> case unTlvStream stream of - [r] -> do - tlvType r @?= 1 - BS.length (tlvValue r) @?= 32 - _ -> assertFailure "expected single record" - Left e -> assertFailure $ "unexpected error: " ++ show e - , testCase "strictly increasing types" $ do - let bs = mconcat [ - encodeBigSize 1, encodeBigSize 0 - , encodeBigSize 3, encodeBigSize 4, "test" - ] - case decodeTlvStream bs of - Right stream -> length (unTlvStream stream) @?= 2 - Left e -> assertFailure $ "unexpected error: " ++ show e - , testCase "non-increasing types fails" $ do - let bs = mconcat [ - encodeBigSize 3, encodeBigSize 0 - , encodeBigSize 1, encodeBigSize 0 - ] - case decodeTlvStream bs of - Left TlvNotStrictlyIncreasing -> pure () - other -> assertFailure $ "expected TlvNotStrictlyIncreasing: " ++ - show other - , testCase "duplicate types fails" $ do - let bs = mconcat [ - encodeBigSize 1, encodeBigSize 0 - , encodeBigSize 1, encodeBigSize 0 - ] - case decodeTlvStream bs of - Left TlvNotStrictlyIncreasing -> pure () - other -> assertFailure $ "expected TlvNotStrictlyIncreasing: " ++ - show other - , testCase "unknown even type fails" $ do - let bs = mconcat [encodeBigSize 2, encodeBigSize 0] - case decodeTlvStream bs of - Left (TlvUnknownEvenType 2) -> pure () - other -> assertFailure $ "expected TlvUnknownEvenType: " ++ show other - , testCase "unknown odd type skipped" $ do - let bs = mconcat [ - encodeBigSize 5, encodeBigSize 2, "hi" - , encodeBigSize 7, encodeBigSize 0 - ] - case decodeTlvStream bs of - Right stream | null (unTlvStream stream) -> pure () -- both skipped - other -> assertFailure $ "expected empty stream: " ++ show other - , testCase "length exceeds bounds fails" $ do - let bs = mconcat [encodeBigSize 1, encodeBigSize 100, "short"] - case decodeTlvStream bs of - Left TlvLengthExceedsBounds -> pure () - other -> assertFailure $ "expected TlvLengthExceedsBounds: " ++ - show other - , testCase "decodeTlvStreamWith custom predicate" $ do - -- Use a predicate that only knows type 5 - let isKnown t = t == 5 - bs = mconcat [ - encodeBigSize 5, encodeBigSize 2, "hi" - ] - case decodeTlvStreamWith isKnown bs of - Right stream -> case unTlvStream stream of - [r] -> tlvType r @?= 5 - _ -> assertFailure "expected single record" - Left e -> assertFailure $ "unexpected error: " ++ show e - , testCase "decodeTlvStreamRaw returns all records" $ do - let bs = mconcat [ - encodeBigSize 2, encodeBigSize 1, "a" -- even type - , encodeBigSize 5, encodeBigSize 1, "b" -- odd type - ] - case decodeTlvStreamRaw bs of - Right stream -> length (unTlvStream stream) @?= 2 - Left e -> assertFailure $ "unexpected error: " ++ show e - ] - --- Message encode/decode tests ------------------------------------------------- - -message_tests :: TestTree -message_tests = testGroup "Messages" [ - testGroup "Init" [ - testCase "encode/decode minimal init" $ do - let msg = Init "" "" [] - case encodeMessage (MsgInitVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgInit encoded of - Right (MsgInitVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "encode/decode init with features" $ do - let msg = Init (BS.pack [0x01]) (BS.pack [0x02, 0x0a]) [] - case encodeMessage (MsgInitVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgInit encoded of - Right (MsgInitVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "encode/decode init with networks TLV" $ do - let ch = unsafeChainHash (BS.replicate 32 0xab) - msg = Init "" "" [InitNetworks [ch]] - case encodeMessage (MsgInitVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgInit encoded of - Right (MsgInitVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - ] - , testGroup "Error" [ - testCase "encode/decode error" $ do - let cid = unsafeChannelId (BS.replicate 32 0xff) - msg = Error cid "something went wrong" - case encodeMessage (MsgErrorVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgError encoded of - Right (MsgErrorVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "error insufficient channel_id" $ do - case decodeMessage MsgError (BS.replicate 31 0x00) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - ] - , testGroup "Warning" [ - testCase "encode/decode warning" $ do - let cid = unsafeChannelId (BS.replicate 32 0x00) - msg = Warning cid "be careful" - case encodeMessage (MsgWarningVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgWarning encoded of - Right (MsgWarningVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - ] - , testGroup "Ping" [ - testCase "encode/decode ping" $ do - let msg = Ping 100 (BS.replicate 10 0x00) - case encodeMessage (MsgPingVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgPing encoded of - Right (MsgPingVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "ping with zero ignored" $ do - let msg = Ping 50 "" - case encodeMessage (MsgPingVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgPing encoded of - Right (MsgPingVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - ] - , testGroup "Pong" [ - testCase "encode/decode pong" $ do - let msg = Pong (BS.replicate 100 0x00) - case encodeMessage (MsgPongVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgPong encoded of - Right (MsgPongVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - ] - , testGroup "PeerStorage" [ - testCase "encode/decode peer_storage" $ do - let msg = PeerStorage "encrypted blob data" - case encodeMessage (MsgPeerStorageVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgPeerStorage encoded of - Right (MsgPeerStorageVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - ] - , testGroup "PeerStorageRetrieval" [ - testCase "encode/decode peer_storage_retrieval" $ do - let msg = PeerStorageRetrieval "retrieved blob" - case encodeMessage (MsgPeerStorageRetrievalVal msg) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeMessage MsgPeerStorageRet encoded of - Right (MsgPeerStorageRetrievalVal decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - ] - , testGroup "Unknown types" [ - testCase "decodeMessage unknown even type" $ do - case decodeMessage (MsgUnknown 100) "payload" of - Left (DecodeUnknownEvenType 100) -> pure () - other -> assertFailure $ "expected unknown even: " ++ show other - , testCase "decodeMessage unknown odd type" $ do - case decodeMessage (MsgUnknown 101) "payload" of - Left (DecodeUnknownOddType 101) -> pure () - other -> assertFailure $ "expected unknown odd: " ++ show other - ] - ] - --- Envelope tests -------------------------------------------------------------- - -envelope_tests :: TestTree -envelope_tests = testGroup "Envelope" [ - testCase "encode/decode init envelope" $ do - let msg = MsgInitVal (Init "" "" []) - case encodeEnvelope msg Nothing of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeEnvelope encoded of - Right (Just decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "encode/decode ping envelope" $ do - let msg = MsgPingVal (Ping 10 "") - case encodeEnvelope msg Nothing of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeEnvelope encoded of - Right (Just decoded, _) -> decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "unknown even type fails" $ do - let bs = encodeU16 100 <> "payload" -- 100 is even, unknown - case decodeEnvelope bs of - Left (DecodeUnknownEvenType 100) -> pure () - other -> assertFailure $ "expected unknown even: " ++ show other - , testCase "unknown odd type ignored" $ do - let bs = encodeU16 101 <> "payload" -- 101 is odd, unknown - case decodeEnvelope bs of - Right (Nothing, Nothing) -> pure () -- ignored - other -> assertFailure $ "expected (Nothing, Nothing): " ++ show other - , testCase "insufficient bytes for type" $ do - case decodeEnvelope (BS.pack [0x00]) of - Left DecodeInsufficientBytes -> pure () - other -> assertFailure $ "expected insufficient: " ++ show other - , testCase "message type codes" $ do - msgTypeWord MsgInit @?= 16 - msgTypeWord MsgError @?= 17 - msgTypeWord MsgPing @?= 18 - msgTypeWord MsgPong @?= 19 - msgTypeWord MsgWarning @?= 1 - msgTypeWord MsgPeerStorage @?= 7 - msgTypeWord MsgPeerStorageRet @?= 9 - ] - --- Extension TLV tests --------------------------------------------------------- - -extension_tests :: TestTree -extension_tests = testGroup "Extension TLV" [ - testCase "encode envelope with extension (odd type)" $ do - let msg = MsgPingVal (Ping 10 "") - ext = unsafeTlvStream [TlvRecord 101 "extension data"] -- odd type - case encodeEnvelope msg (Just ext) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> do - -- Should contain message + extension - assertBool "encoded should be longer" (BS.length encoded > 6) - , testCase "decode envelope with odd extension - skipped per BOLT#1" $ do - -- Per BOLT #1: unknown odd types are ignored (skipped) - let msg = MsgPingVal (Ping 10 "") - ext = unsafeTlvStream [TlvRecord 101 "ext"] -- odd type - case encodeEnvelope msg (Just ext) of - Left e -> assertFailure $ "encode failed: " ++ show e - Right encoded -> case decodeEnvelope encoded of - Right (Just decoded, Just stream) - | null (unTlvStream stream) -> do - -- Extension is empty because unknown odd types are skipped - decoded @?= msg - other -> assertFailure $ "unexpected: " ++ show other - , testCase "decode envelope with unknown even extension fails" $ do - -- Per BOLT #1: unknown even types must cause failure - let pingPayload = mconcat [encodeU16 10, encodeU16 0] -- numPong=10, len=0 - extTlv = mconcat [encodeBigSize 100, encodeBigSize 3, "abc"] -- even! - envelope = encodeU16 18 <> pingPayload <> extTlv -- type 18 = ping - case decodeEnvelope envelope of - Left (DecodeInvalidExtension (TlvUnknownEvenType 100)) -> pure () - other -> assertFailure $ "expected unknown even error: " ++ show other - , testCase "decode envelope with invalid extension fails" $ do - -- Ping + invalid TLV (non-strictly-increasing) - let pingPayload = mconcat [encodeU16 10, encodeU16 0] - badTlv = mconcat [ - encodeBigSize 101, encodeBigSize 1, "a" -- odd types for this test - , encodeBigSize 51, encodeBigSize 1, "b" -- 51 < 101, invalid - ] - envelope = encodeU16 18 <> pingPayload <> badTlv - case decodeEnvelope envelope of - Left (DecodeInvalidExtension TlvNotStrictlyIncreasing) -> pure () - other -> assertFailure $ "expected invalid extension: " ++ show other - , testCase "unknown even in extension fails even with odd types present" $ do - -- Mixed odd and even - should fail on the even type - let pingPayload = mconcat [encodeU16 10, encodeU16 0] - extTlv = mconcat [ - encodeBigSize 101, encodeBigSize 1, "a" -- odd, would be skipped - , encodeBigSize 200, encodeBigSize 1, "b" -- even, must fail - ] - envelope = encodeU16 18 <> pingPayload <> extTlv - case decodeEnvelope envelope of - Left (DecodeInvalidExtension (TlvUnknownEvenType 200)) -> pure () - other -> assertFailure $ "expected unknown even error: " ++ show other - ] - --- Bounds checking tests ------------------------------------------------------- - -bounds_tests :: TestTree -bounds_tests = testGroup "Bounds checking" [ - testCase "encode ping with oversized ignored fails" $ do - let msg = Ping 10 (BS.replicate 70000 0x00) -- > 65535 - case encodeMessage (MsgPingVal msg) of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encode pong with oversized ignored fails" $ do - let msg = Pong (BS.replicate 70000 0x00) - case encodeMessage (MsgPongVal msg) of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encode error with oversized data fails" $ do - let cid = unsafeChannelId (BS.replicate 32 0x00) - msg = Error cid (BS.replicate 70000 0x00) - case encodeMessage (MsgErrorVal msg) of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encode init with oversized features fails" $ do - let msg = Init "" (BS.replicate 70000 0x00) [] - case encodeMessage (MsgInitVal msg) of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encode peer_storage with oversized blob fails" $ do - let msg = PeerStorage (BS.replicate 70000 0x00) - case encodeMessage (MsgPeerStorageVal msg) of - Left EncodeLengthOverflow -> pure () - other -> assertFailure $ "expected overflow: " ++ show other - , testCase "encode envelope exceeding 65535 bytes fails" $ do - -- Create a message that fits in encodeMessage but combined with - -- extension exceeds 65535 bytes total - let msg = MsgPongVal (Pong (BS.replicate 60000 0x00)) - ext = unsafeTlvStream [TlvRecord 101 (BS.replicate 10000 0x00)] - case encodeEnvelope msg (Just ext) of - Left EncodeMessageTooLarge -> pure () - other -> assertFailure $ "expected message too large: " ++ show other - ] - --- Property tests -------------------------------------------------------------- - -property_tests :: TestTree -property_tests = testGroup "Properties" [ - testProperty "BigSize roundtrip" $ \(NonNegative n) -> - case decodeBigSize (encodeBigSize n) of - Just (m, rest) -> m == n && BS.null rest - Nothing -> False - , testProperty "U16 roundtrip" $ \w -> - decodeU16 (encodeU16 w) == Just (w, "") - , testProperty "U32 roundtrip" $ \w -> - decodeU32 (encodeU32 w) == Just (w, "") - , testProperty "U64 roundtrip" $ \w -> - decodeU64 (encodeU64 w) == Just (w, "") - , testProperty "Ping roundtrip" $ \(NonNegative num) bs -> - let ignored = BS.pack (take 1000 bs) -- limit size - msg = Ping (fromIntegral (num `mod` 65536 :: Integer)) ignored - in case encodeMessage (MsgPingVal msg) of - Left _ -> False - Right encoded -> case decodeMessage MsgPing encoded of - Right (MsgPingVal decoded, rest) -> - decoded == msg && BS.null rest - _ -> False - , testProperty "Pong roundtrip" $ \bs -> - let ignored = BS.pack (take 1000 bs) - msg = Pong ignored - in case encodeMessage (MsgPongVal msg) of - Left _ -> False - Right encoded -> case decodeMessage MsgPong encoded of - Right (MsgPongVal decoded, rest) -> - decoded == msg && BS.null rest - _ -> False - , testProperty "PeerStorage roundtrip" $ \bs -> - let blob = BS.pack (take 1000 bs) - msg = PeerStorage blob - in case encodeMessage (MsgPeerStorageVal msg) of - Left _ -> False - Right encoded -> case decodeMessage MsgPeerStorage encoded of - Right (MsgPeerStorageVal decoded, rest) -> - decoded == msg && BS.null rest - _ -> False - , testProperty "Error roundtrip" $ \bs -> - let cid = unsafeChannelId (BS.replicate 32 0x00) - dat = BS.pack (take 1000 bs) - msg = Error cid dat - in case encodeMessage (MsgErrorVal msg) of - Left _ -> False - Right encoded -> case decodeMessage MsgError encoded of - Right (MsgErrorVal decoded, rest) -> - decoded == msg && BS.null rest - _ -> False - , testProperty "Envelope with odd extension (skipped per BOLT#1)" $ \bs -> - -- Unknown odd types in extensions are skipped per BOLT #1 - let msg = MsgPingVal (Ping 42 "") - extData = BS.pack (take 100 bs) - ext = unsafeTlvStream [TlvRecord 101 extData] -- odd type, skipped - in case encodeEnvelope msg (Just ext) of - Left _ -> False - Right encoded -> case decodeEnvelope encoded of - -- Extension should be empty (odd types skipped) - Right (Just decoded, Just stream) -> - null (unTlvStream stream) && decoded == msg - _ -> False - ] - --- Helpers --------------------------------------------------------------------- - --- | Construct a 'ChannelId' from a known-valid 32-byte 'BS.ByteString'. --- --- Uses 'error' for invalid input since all channel IDs in tests are --- known-valid compile-time constants. -unsafeChannelId :: BS.ByteString -> ChannelId -unsafeChannelId bs = case channelId bs of - Just cid -> cid - Nothing -> error $ "unsafeChannelId: invalid length: " ++ show (BS.length bs) - --- | Decode hex string (test-only helper). --- --- Uses 'error' for invalid hex since all hex literals in tests are --- known-valid compile-time constants. This is acceptable in test code --- where the failure would indicate a bug in the test itself. -unhex :: BS.ByteString -> BS.ByteString -unhex bs = case B16.decode bs of - Just r -> r - Nothing -> error $ "unhex: invalid hex literal: " ++ show bs - --- | Construct a ChainHash from a bytestring (test-only helper). --- --- Uses 'error' for invalid input since all chain hashes in tests are --- known-valid 32-byte constants. This is acceptable in test code where --- the failure would indicate a bug in the test itself. -unsafeChainHash :: BS.ByteString -> ChainHash -unsafeChainHash bs = case chainHash bs of - Just c -> c - Nothing -> error $ "unsafeChainHash: not 32 bytes: " ++ show (BS.length bs) +import qualified Data.ByteString.Char8 as B8 +import Data.Int (Int64) +import qualified Data.List as L +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Word (Word16, Word32, Word64) +import Lightning.Protocol.BOLT1 +import qualified Lightning.Protocol.BOLT9 as BOLT9 +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +main :: IO () +main = defaultMain $ testGroup "ppad-bolt1" [ + appendix_a + , appendix_b + , appendix_c + , appendix_d + , primitives + , tlv + , messages + , properties + ] + +-- helpers -------------------------------------------------------------------- + +-- run an assertion on decoded hex (spaces and a 0x prefix are allowed), +-- failing the test if the literal isn't valid hex +with_hex :: String -> (BS.ByteString -> Assertion) -> Assertion +with_hex s k = case B16.decode (B8.pack (strip s)) of + Nothing -> assertFailure ("invalid hex literal: " ++ s) + Just bs -> k bs + where + strip = filter (/= ' ') . drop0x + drop0x ('0':'x':r) = r + drop0x r = r + +is_left :: Either a b -> Bool +is_left = either (const True) (const False) + +empty_fv :: BOLT9.FeatureVector +empty_fv = BOLT9.parse "" + +-- Appendix A: BigSize -------------------------------------------------------- + +appendix_a :: TestTree +appendix_a = testGroup "Appendix A (BigSize)" [ + testGroup "decoding" (map dec ok_vectors) + , testGroup "encoding" (map enc ok_vectors) + , testGroup "decoding failures" (map bad bad_vectors) + ] + where + dec (v, h) = testCase ("decode " ++ h) $ with_hex h $ \bs -> + decode_bigsize bs @?= Just (v, "") + enc (v, h) = testCase ("encode " ++ show v) $ with_hex h $ \bs -> + encode_bigsize v @?= bs + bad h = testCase ("reject " ++ show h) $ with_hex h $ \bs -> + decode_bigsize bs @?= Nothing + + ok_vectors :: [(Word64, String)] + ok_vectors = [ + (0, "00"), (252, "fc"), (253, "fd00fd"), (65535, "fdffff") + , (65536, "fe00010000"), (4294967295, "feffffffff") + , (4294967296, "ff0000000100000000") + , (18446744073709551615, "ffffffffffffffffff") + ] + + -- non-canonical encodings, short reads and no reads + bad_vectors = [ + "fd00fc", "fe0000ffff", "ff00000000ffffffff" + , "fd00", "feffff", "ffffffffff" + , "", "fd", "fe", "ff" + ] + +-- Appendix B: TLV ------------------------------------------------------------ + +-- the n1 and n2 test namespaces, decoded with bolt1's primitives + +data N1 = N1Tlv1 !Word64 + | N1Tlv2 !ShortChannelId + | N1Tlv3 !Point !Word64 !Word64 + | N1Tlv4 !Word16 + deriving (Eq, Show) + +decode_n1 :: BS.ByteString -> Either String [N1] +decode_n1 bs = do + s <- either (Left . show) Right (decode_tlv_stream (`elem` n1_types) bs) + sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` n1_types ] + where + n1_types = [1, 2, 3, 254] + one (TlvRecord 1 v) = maybe (Left "tlv1") (Right . N1Tlv1) + (decode_tu64 v) + one (TlvRecord 2 v) = case decode_short_channel_id v of + Just (c, "") -> Right (N1Tlv2 c) + _ -> Left "tlv2" + one (TlvRecord 3 v) = maybe (Left "tlv3") Right $ do + (p, r0) <- decode_point v + (a, r1) <- decode_u64 r0 + (b, r2) <- decode_u64 r1 + if BS.null r2 then pure (N1Tlv3 p a b) else Nothing + one (TlvRecord 254 v) = case decode_u16 v of + Just (c, "") -> Right (N1Tlv4 c) + _ -> Left "tlv4" + one _ = Left "unreachable" + +decode_n2 :: BS.ByteString -> Either String [(Word64, Word64)] +decode_n2 bs = do + s <- either (Left . show) Right (decode_tlv_stream (`elem` [0, 11]) bs) + sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` [0, 11] ] + where + one (TlvRecord 0 v) = maybe (Left "tlv1") (Right . (,) 0) (decode_tu64 v) + one (TlvRecord 11 v) = + maybe (Left "tlv2") (Right . (,) 11 . fromIntegral) (decode_tu32 v) + one _ = Left "unreachable" + +appendix_b :: TestTree +appendix_b = testGroup "Appendix B (TLV)" [ + testGroup "failures in any namespace" [ + testCase h $ with_hex h $ \bs -> do + assertBool "n1" (is_left (decode_n1 bs)) + assertBool "n2" (is_left (decode_n2 bs)) + | h <- any_fail ] + , testGroup "n1 failures" [ + testCase h $ with_hex h $ \bs -> assertBool "n1" (is_left (decode_n1 bs)) + | h <- n1_fail ] + , testGroup "n2 failures" [ + testCase h $ with_hex h $ \bs -> assertBool "n2" (is_left (decode_n2 bs)) + | h <- n2_fail ] + , testGroup "ignored successes" [ + testCase h $ with_hex h $ \bs -> do + decode_n1 bs @?= Right [] + decode_n2 bs @?= Right [] + | h <- any_ok ] + , testGroup "n1 successes" [ + testCase h $ with_hex h $ \bs -> decode_n1 bs @?= Right [v] + | (h, v) <- n1_ok ] + , testCase "n1 tlv3" $ with_hex n1_tlv3 $ \bs -> + with_hex node_id $ \pk -> case point pk of + Nothing -> assertFailure "bad node_id" + Just p -> decode_n1 bs @?= Right [N1Tlv3 p 1 2] + , testCase "unknown even types fail when no types are known" $ + mapM_ (\h -> with_hex h $ \bs -> + assertBool h (is_left (decode_tlv_stream (const False) bs))) + ["12 00", "fd0102 00", "fe01000002 00", "ff0100000000000002 00"] + , testCase "appending a higher-numbered valid stream succeeds" $ + with_hex "01 01 01" $ \a -> with_hex "fd00fe 02 0226" $ \b -> + decode_n1 (a <> b) @?= Right [N1Tlv1 1, N1Tlv4 550] + , testCase "appending an invalid stream fails" $ + with_hex "01 01 01" $ \a -> mapM_ (\h -> with_hex h $ \b -> + assertBool h (is_left (decode_n1 (a <> b)))) any_fail + ] + where + any_fail = [ + "0xfd", "0xfd01", "0xfd0001 00", "0xfd0101", "0x0f fd", "0x0f fd26" + , "0x0f fd2602", "0x0f fd0001 00", "0x0f fd0201 " ++ replicate 1024 '0' + , "0x12 00", "0xfd0102 00", "0xfe01000002 00" + , "0xff0100000000000002 00" + ] + n1_fail = [ + "0x01 09 ffffffffffffffffff", "0x01 01 00", "0x01 02 0001" + , "0x01 03 000100", "0x01 04 00010000", "0x01 05 0001000000" + , "0x01 06 000100000000", "0x01 07 00010000000000" + , "0x01 08 0001000000000000", "0x02 07 01010101010101" + , "0x02 09 010101010101010101" + , "0x03 21 " ++ node_id + , "0x03 29 " ++ node_id ++ "0000000000000001" + , "0x03 30 " ++ node_id ++ "000000000000000100000000000001" + , "0x03 31 04" ++ drop 2 node_id + ++ "00000000000000010000000000000002" + , "0x03 32 " ++ node_id ++ "0000000000000001000000000000000001" + , "0xfd00fe 00", "0xfd00fe 01 01", "0xfd00fe 03 010101", "0x00 00" + , "0x02 08 0000000000000226 01 01 2a" + , "0x02 08 0000000000000231 02 08 0000000000000451" + , "0x1f 00 0f 01 2a", "0x1f 00 1f 01 2a" + ] + n2_fail = ["0xffffffffffffffffff 00 00 00"] + any_ok = [ + "0x", "0x21 00", "0xfd0201 00", "0xfd00fd 00", "0xfd00ff 00" + , "0xfe02000001 00", "0xff0200000000000001 00" + ] + n1_ok = [ + ("0x01 00", N1Tlv1 0), ("0x01 01 01", N1Tlv1 1) + , ("0x01 02 0100", N1Tlv1 256), ("0x01 03 010000", N1Tlv1 65536) + , ("0x01 04 01000000", N1Tlv1 16777216) + , ("0x01 05 0100000000", N1Tlv1 4294967296) + , ("0x01 06 010000000000", N1Tlv1 1099511627776) + , ("0x01 07 01000000000000", N1Tlv1 281474976710656) + , ("0x01 08 0100000000000000", N1Tlv1 72057594037927936) + , ("0x02 08 0000000000000226", N1Tlv2 (ShortChannelId 0x226)) + , ("0xfd00fe 02 0226", N1Tlv4 550) + ] + node_id = + "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb" + n1_tlv3 = "0x03 31 " ++ node_id ++ "00000000000000010000000000000002" + +-- Appendix C: message extension ---------------------------------------------- + +appendix_c :: TestTree +appendix_c = testGroup "Appendix C (message extension)" [ + testCase "no extension" $ with_hex "001000000000" $ \bs -> + case decode_message bs of + Right (MsgInit i) -> do + init_networks i @?= Nothing + init_tlvs i @?= empty_tlv_stream + other -> assertFailure (show other) + , testCase "two unknown odd records are kept" $ + with_hex "001000000000c9012acb0104" $ \bs -> + case decode_message bs of + Right m@(MsgInit i) -> do + map tlv_type (un_tlv_stream (init_tlvs i)) @?= [0xc9, 0xcb] + encode_message m @?= Right bs + other -> assertFailure (show other) + , testCase "truncated extension" $ with_hex "00100000000001" $ \bs -> + decode_message bs @?= Left (DecodeTlvError TlvTruncated) + , testCase "unknown even record" $ with_hex "001000000000ca012a" $ \bs -> + decode_message bs @?= Left (DecodeTlvError (TlvUnknownEvenType 0xca)) + , testCase "duplicate record" $ with_hex "001000000000c90101c90102" $ \bs -> + decode_message bs @?= Left (DecodeTlvError TlvNotStrictlyIncreasing) + ] + +-- Appendix D: signed integers ------------------------------------------------ + +appendix_d :: TestTree +appendix_d = testGroup "Appendix D (signed integers)" [ + testCase (show v) $ with_hex h $ \bs -> case BS.length bs of + 1 -> do + encode_s8 (fromIntegral v) @?= bs + decode_s8 bs @?= Just (fromIntegral v, "") + 2 -> do + encode_s16 (fromIntegral v) @?= bs + decode_s16 bs @?= Just (fromIntegral v, "") + 4 -> do + encode_s32 (fromIntegral v) @?= bs + decode_s32 bs @?= Just (fromIntegral v, "") + 8 -> do + encode_s64 v @?= bs + decode_s64 bs @?= Just (v, "") + _ -> assertFailure "bad vector width" + | (v, h) <- vectors ] + where + vectors :: [(Int64, String)] + vectors = [ + (0, "00"), (42, "2a"), (-42, "d6"), (127, "7f"), (-128, "80") + , (128, "0080"), (-129, "ff7f"), (15000, "3a98"), (-15000, "c568") + , (32767, "7fff"), (-32768, "8000"), (32768, "00008000") + , (-32769, "ffff7fff"), (21000000, "01406f40") + , (-21000000, "febf90c0"), (2147483647, "7fffffff") + , (-2147483648, "80000000"), (2147483648, "0000000080000000") + , (-2147483649, "ffffffff7fffffff"), (500000000000, "000000746a528800") + , (-500000000000, "ffffff8b95ad7800") + , (9223372036854775807, "7fffffffffffffff") + , (-9223372036854775808, "8000000000000000") + ] + +-- primitives ----------------------------------------------------------------- + +primitives :: TestTree +primitives = testGroup "Primitives" [ + testCase "u16/u32/u64 known answers" $ do + encode_u16 0x0102 @?= "\x01\x02" + encode_u32 0x01020304 @?= "\x01\x02\x03\x04" + encode_u64 0x0102030405060708 @?= "\x01\x02\x03\x04\x05\x06\x07\x08" + decode_u32 "\x01\x02\x03\x04rest" @?= Just (0x01020304, "rest") + , testCase "short reads fail" $ do + decode_u16 "\x01" @?= Nothing + decode_u32 "\x01\x02\x03" @?= Nothing + decode_u64 "\x01\x02\x03\x04\x05\x06\x07" @?= Nothing + decode_s8 "" @?= Nothing + , testCase "truncated integers" $ do + encode_tu64 0 @?= "" + encode_tu64 1 @?= "\x01" + encode_tu32 0x010000 @?= "\x01\x00\x00" + decode_tu16 "" @?= Just 0 + decode_tu16 "\x00\x01" @?= Nothing + decode_tu16 "\x01\x00\x00" @?= Nothing + decode_tu32 "\x01\x00\x00\x00\x00" @?= Nothing + decode_tu64 "\x01\x00\x00\x00\x00\x00\x00\x00\x00" @?= Nothing + , testCase "length-prefixed bytes" $ do + encode_u16_prefixed "abc" @?= Just "\x00\x03\&abc" + encode_u16_prefixed (BS.replicate 65536 0) @?= Nothing + decode_u16_prefixed "\x00\x03\&abcde" @?= Just ("abc", "de") + decode_u16_prefixed "\x00\x03\&ab" @?= Nothing + , testCase "fixed-size types check their lengths" $ do + assertBool "chain_hash" (isNothing (chain_hash (BS.replicate 31 0))) + assertBool "channel_id" (isNothing (channel_id (BS.replicate 33 0))) + assertBool "signature" (isNothing (signature (BS.replicate 65 0))) + assertBool "payment_hash" (isNothing (payment_hash "")) + assertBool "preimage" (isNothing (payment_preimage "")) + assertBool "secret" (isNothing (per_commitment_secret "")) + , testCase "point prefix" $ do + assertBool "02" (isJust (point (BS.cons 0x02 (BS.replicate 32 1)))) + assertBool "03" (isJust (point (BS.cons 0x03 (BS.replicate 32 1)))) + assertBool "04" (isNothing (point (BS.cons 0x04 (BS.replicate 32 1)))) + assertBool "len" (isNothing (point (BS.cons 0x02 (BS.replicate 31 1)))) + , testCase "short_channel_id" $ case short_channel_id 539268 845 1 of + Nothing -> assertFailure "valid scid rejected" + Just c -> do + scid_block_height c @?= 539268 + scid_tx_index c @?= 845 + scid_output_index c @?= 1 + encode_short_channel_id c @?= "\x08\x3a\x84\x00\x03\x4d\x00\x01" + , testCase "short_channel_id rejects 25-bit components" $ do + short_channel_id 0x1000000 0 0 @?= Nothing + short_channel_id 0 0x1000000 0 @?= Nothing + , testCase "amount bounds" $ do + fmap un_satoshi (satoshi 0x000775f05a074000) @?= Just 0x000775f05a074000 + satoshi 0x000775f05a074001 @?= Nothing + fmap un_milli_satoshi (milli_satoshi 0x1d24b2dfac520000) + @?= Just 0x1d24b2dfac520000 + milli_satoshi 0x1d24b2dfac520001 @?= Nothing + sat_to_msat max_satoshi @?= max_milli_satoshi + decode_satoshi (encode_u64 0x000775f05a074001) @?= Nothing + decode_milli_satoshi (encode_u64 maxBound) @?= Nothing + , testCase "checked arithmetic" $ do + add_sat max_satoshi max_satoshi @?= Nothing + (do a <- satoshi 1; b <- satoshi 2; sub_sat a b) @?= Nothing + (do a <- satoshi 2; b <- satoshi 1; sub_sat a b) @?= satoshi 1 + (do a <- milli_satoshi 1; b <- milli_satoshi 2; sub_msat a b) + @?= Nothing + add_msat max_milli_satoshi max_milli_satoshi @?= Nothing + , testCase "secrets don't show" $ + case payment_preimage (BS.replicate 32 7) of + Nothing -> assertFailure "valid preimage rejected" + Just p -> do + show p @?= "PaymentPreimage " + show (Just p) @?= "Just (PaymentPreimage )" + , testCase "secret equality" $ do + let a = payment_preimage (BS.replicate 32 7) + b = payment_preimage (BS.replicate 31 7 <> "\x08") + assertBool "equal" (a == a) + assertBool "unequal" (a /= b) + ] + +-- TLV ------------------------------------------------------------------------ + +tlv :: TestTree +tlv = testGroup "TLV" [ + testCase "tlv_stream sorts" $ + fmap (map tlv_type . un_tlv_stream) + (tlv_stream [TlvRecord 5 "", TlvRecord 1 "", TlvRecord 3 ""]) + @?= Just [1, 3, 5] + , testCase "tlv_stream rejects duplicates" $ + tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing + , testCase "lookup_tlv" $ do + (lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"]) + @?= Just "b" + (lookup_tlv 2 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"]) + @?= Nothing + , testCase "huge lengths are rejected, not wrapped" $ + mapM_ (\h -> with_hex h $ \bs -> + decode_tlv_stream (const True) bs @?= Left TlvTruncated) + [ "01ffffffffffffffffff", "01ff800000000000000067" + , "01ffffffffffffffffff6701aa" ] + , testCase "truncation vs non-minimal" $ do + decode_tlv_stream (const True) "\xfd" @?= Left TlvTruncated + decode_tlv_stream (const True) "\xfd\x00\x01\x00" + @?= Left TlvNonMinimalBigSize + , testCase "unknown odd records are kept" $ + fmap (map tlv_type . un_tlv_stream) + (decode_tlv_stream (const False) "\x01\x00\x03\x01\x2a") + @?= Right [1, 3] + ] + +-- messages ------------------------------------------------------------------- + +messages :: TestTree +messages = testGroup "Messages" [ + testCase "pong known answer" $ + encode_message (MsgPong (Pong "\x00\x00" empty_tlv_stream)) + @?= Right "\x00\x13\x00\x02\x00\x00" + , testCase "ping known answer" $ + encode_message (MsgPing (Ping 4 "" empty_tlv_stream)) + @?= Right "\x00\x12\x00\x04\x00\x00" + , testCase "error known answer" $ + encode_message (MsgError (Error all_channels "x" empty_tlv_stream)) + @?= Right ("\x00\x11" <> BS.replicate 32 0 <> "\x00\x01x") + , testCase "init with networks and remote_addr" $ + case chain_hash (BS.replicate 32 0x6f) of + Nothing -> assertFailure "valid chain hash rejected" + Just ch -> do + let addr = "\x01\x7f\x00\x00\x01\x26\x07" + i = Init empty_fv (BOLT9.parse "\x02") (Just [ch]) + (Just addr) empty_tlv_stream + wire = "\x00\x10\x00\x00\x00\x01\x02" + <> "\x01\x20" <> un_chain_hash ch <> "\x03\x07" <> addr + encode_message (MsgInit i) @?= Right wire + decode_message wire @?= Right (MsgInit i) + , testCase "init networks must be a multiple of 32 bytes" $ + decode_init "\x00\x00\x00\x00\x01\x01\x00" + @?= Left (DecodeInvalidTlvValue 1) + , testCase "init rejects tlvs clashing with typed fields" $ + case tlv_stream [TlvRecord 3 "x"] of + Nothing -> assertFailure "valid stream rejected" + Just s -> encode_init (Init empty_fv empty_fv Nothing (Just "y") s) + @?= Left EncodeInvalidTlvs + , testCase "unknown message types" $ do + decode_message "\x00\x20" @?= Left (DecodeUnknownEvenType 32) + decode_message "\x80\x01" @?= Left (DecodeUnknownOddType 32769) + decode_message "\x00" @?= Left DecodeInsufficientBytes + , testCase "truncated payloads" $ do + decode_init "\x00" @?= Left DecodeInsufficientBytes + decode_init "\x00\x01" @?= Left DecodeInsufficientBytes + decode_error (BS.replicate 31 0) @?= Left DecodeInsufficientBytes + decode_warning (BS.replicate 33 0) @?= Left DecodeInsufficientBytes + decode_ping "\x00\x04\x00\x02\x00" @?= Left DecodeInsufficientBytes + decode_pong "\x00\x02\x00" @?= Left DecodeInsufficientBytes + decode_peer_storage "\x00\x01" @?= Left DecodeInsufficientBytes + decode_peer_storage_retrieval "\x00" @?= Left DecodeInsufficientBytes + , testCase "invalid extensions" $ do + decode_pong "\x00\x00\x02\x00" @?= Left + (DecodeTlvError (TlvUnknownEvenType 2)) + decode_ping "\x00\x00\x00\x00\x01" @?= Left (DecodeTlvError TlvTruncated) + , testCase "message size limit" $ do + encode_envelope 7 (BS.replicate 65533 0) @?= + Right (encode_u16 7 <> BS.replicate 65533 0) + encode_envelope 7 (BS.replicate 65534 0) @?= Left EncodeMessageTooLarge + encode_message (MsgPeerStorage (PeerStorage (BS.replicate 65532 0) + empty_tlv_stream)) @?= Left EncodeMessageTooLarge + encode_pong (Pong (BS.replicate 65536 0) empty_tlv_stream) + @?= Left EncodeLengthOverflow + , testCase "ping_response" $ do + ping_response (Ping 3 "ab" empty_tlv_stream) + @?= Just (Pong "\x00\x00\x00" empty_tlv_stream) + ping_response (Ping 65531 "" empty_tlv_stream) @?= + Just (Pong (BS.replicate 65531 0) empty_tlv_stream) + ping_response (Ping 65532 "" empty_tlv_stream) @?= Nothing + ] + +-- properties ----------------------------------------------------------------- + +newtype Bytes = Bytes BS.ByteString + deriving Show + +instance Arbitrary Bytes where + arbitrary = Bytes . BS.pack <$> (choose (0, 64) >>= vector) + +-- streams of unknown odd records +newtype OddTlvs = OddTlvs TlvStream + deriving Show + +instance Arbitrary OddTlvs where + arbitrary = do + ts <- L.nub . map (\t -> 2 * (t `div` 2) + 1) + <$> listOf (arbitrary :: Gen Word64) + vs <- vectorOf (length ts) arbitrary + pure . OddTlvs . fromMaybe empty_tlv_stream $ + tlv_stream [ TlvRecord t v | (t, Bytes v) <- zip ts vs ] + +newtype Bytes32 = Bytes32 BS.ByteString + deriving Show + +instance Arbitrary Bytes32 where + arbitrary = Bytes32 . BS.pack <$> vector 32 + +newtype Msg = Msg Message + deriving Show + +instance Arbitrary Msg where + arbitrary = Msg <$> oneof [ + do Bytes a <- arbitrary + Bytes b <- arbitrary + nets <- oneof [pure Nothing, Just <$> listOf chain] + addr <- oneof [pure Nothing, (\(Bytes x) -> Just x) <$> arbitrary] + OddTlvs s <- arbitrary + let s' = filter_tlv_stream (\t -> t /= 1 && t /= 3) s + pure (MsgInit (Init (BOLT9.parse a) (BOLT9.parse b) nets addr s')) + , do c <- cid + Bytes d <- arbitrary + OddTlvs s <- arbitrary + pure (MsgError (Error c d s)) + , do c <- cid + Bytes d <- arbitrary + OddTlvs s <- arbitrary + pure (MsgWarning (Warning c d s)) + , do n <- arbitrary + Bytes d <- arbitrary + OddTlvs s <- arbitrary + pure (MsgPing (Ping n d s)) + , do Bytes d <- arbitrary + OddTlvs s <- arbitrary + pure (MsgPong (Pong d s)) + , do Bytes d <- arbitrary + OddTlvs s <- arbitrary + pure (MsgPeerStorage (PeerStorage d s)) + , do Bytes d <- arbitrary + OddTlvs s <- arbitrary + pure (MsgPeerStorageRetrieval (PeerStorageRetrieval d s)) + ] + where + chain = do + Bytes32 b <- arbitrary + maybe chain pure (chain_hash b) + cid = do + Bytes32 b <- arbitrary + pure (fromMaybe all_channels (channel_id b)) + +properties :: TestTree +properties = testGroup "Properties" [ + testProperty "bigsize round-trips" $ \w -> + decode_bigsize (encode_bigsize w) === Just (w, "") + , testProperty "tu16 round-trips" $ \w -> + decode_tu16 (encode_tu16 w) === Just w + , testProperty "tu32 round-trips" $ \w -> + decode_tu32 (encode_tu32 w) === Just w + , testProperty "tu64 round-trips" $ \w -> + decode_tu64 (encode_tu64 w) === Just w + , testProperty "u16 round-trips" $ \w -> + decode_u16 (encode_u16 w) === Just (w, "") + , testProperty "u32 round-trips" $ \w -> + decode_u32 (encode_u32 w) === Just (w, "") + , testProperty "u64 round-trips" $ \w -> + decode_u64 (encode_u64 w) === Just (w, "") + , testProperty "s64 round-trips" $ \w -> + decode_s64 (encode_s64 w) === Just (w, "") + , testProperty "scid components round-trip" $ \h t o -> + let h' = h `mod` 0x1000000 :: Word32 + t' = t `mod` 0x1000000 :: Word32 + in fmap (\c -> (scid_block_height c, scid_tx_index c, + scid_output_index c)) (short_channel_id h' t' o) + === Just (h', t', o) + , testProperty "sat -> msat -> sat is the identity" $ + forAll (choose (0, 0x000775f05a074000)) $ \w -> + fmap (msat_to_sat . sat_to_msat) (satoshi w) === satoshi w + , testProperty "add then sub is the identity" $ + forAll (choose (0, 0x000775f05a074000)) $ \a -> + forAll (choose (0, 0x000775f05a074000 - a)) $ \b -> + (do x <- satoshi a + y <- satoshi b + z <- add_sat x y + sub_sat z y) === satoshi a + , testProperty "tlv streams round-trip" $ \(OddTlvs s) -> + decode_tlv_stream (const False) (encode_tlv_stream s) === Right s + , testProperty "messages round-trip" $ \(Msg m) -> + case encode_message m of + Left e -> counterexample (show e) False + Right bs -> decode_message bs === Right m + , testProperty "re-encoding reproduces the wire bytes" $ \(Msg m) -> + case encode_message m of + Left e -> counterexample (show e) False + Right bs -> case decode_message bs of + Left e -> counterexample (show e) False + Right m' -> encode_message m' === Right bs + ]