ppad-bolt1 (empty) → 0.0.1
raw patch · 12 files changed
+3550/−0 lines, 12 filesdep +basedep +bytestringdep +criterion
Dependencies added: base, bytestring, criterion, deepseq, ppad-base16, ppad-bolt1, tasty, tasty-hunit, tasty-quickcheck, weigh
Files
- CHANGELOG +4/−0
- LICENSE +20/−0
- bench/Fixtures.hs +433/−0
- bench/Main.hs +526/−0
- bench/Weight.hs +347/−0
- lib/Lightning/Protocol/BOLT1.hs +101/−0
- lib/Lightning/Protocol/BOLT1/Codec.hs +349/−0
- lib/Lightning/Protocol/BOLT1/Message.hs +213/−0
- lib/Lightning/Protocol/BOLT1/Prim.hs +527/−0
- lib/Lightning/Protocol/BOLT1/TLV.hs +244/−0
- ppad-bolt1.cabal +87/−0
- test/Main.hs +699/−0
+ CHANGELOG view
@@ -0,0 +1,4 @@+# Changelog++- 0.0.1 (2025-01-25)+ * Initial release.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2025 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ bench/Fixtures.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Fixtures+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Test fixtures for BOLT #1 benchmarks.++module Fixtures where++import qualified Data.ByteString as BS+import Data.Maybe (fromJust)+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) -------------------------------------++-- | 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 #-}++-- Sample Init messages ---------------------------------------------------++-- | Minimal Init message (empty features, no TLVs).+minimalInit :: Init+minimalInit = Init+ { initGlobalFeatures = BS.empty+ , initFeatures = BS.empty+ , initTlvs = []+ }+{-# 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 #-}++-- Encoded TLV streams (for decode benchmarks) ----------------------------++-- | Encoded empty TLV stream.+encodedEmptyTlvStream :: BS.ByteString+encodedEmptyTlvStream = encodeTlvStream emptyTlvStream+{-# NOINLINE encodedEmptyTlvStream #-}++-- | Encoded small TLV stream (1 record).+encodedSmallTlvStream :: BS.ByteString+encodedSmallTlvStream = encodeTlvStream smallTlvStream+{-# NOINLINE encodedSmallTlvStream #-}++-- | Encoded medium TLV stream (5 records).+encodedMediumTlvStream :: BS.ByteString+encodedMediumTlvStream = encodeTlvStream mediumTlvStream+{-# NOINLINE encodedMediumTlvStream #-}++-- | Encoded large TLV stream (20 records).+encodedLargeTlvStream :: BS.ByteString+encodedLargeTlvStream = encodeTlvStream largeTlvStream+{-# NOINLINE encodedLargeTlvStream #-}
+ bench/Main.hs view
@@ -0,0 +1,526 @@+{-# 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 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)+ ]+ ]++-- Helper for roundtrip benchmarks+forceRight :: Either a b -> b+forceRight (Right b) = b+forceRight (Left _) = error "forceRight: Left"+{-# INLINE forceRight #-}
+ bench/Weight.hs view
@@ -0,0 +1,347 @@+{-# 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 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
+ lib/Lightning/Protocol/BOLT1.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Module: Lightning.Protocol.BOLT1+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Base protocol for the Lightning Network, per+-- [BOLT #1](https://github.com/lightning/bolts/blob/master/01-messaging.md).++module Lightning.Protocol.BOLT1 (+ -- * Message types+ Message(..)+ , MsgType(..)+ , msgTypeWord++ -- * Channel identifiers+ , ChannelId+ , channelId+ , allChannels++ -- ** Setup messages+ , Init(..)+ , Error(..)+ , Warning(..)++ -- ** Control messages+ , Ping(..)+ , Pong(..)++ -- ** Peer storage+ , PeerStorage(..)+ , PeerStorageRetrieval(..)++ -- * TLV+ , TlvRecord(..)+ , TlvStream+ , unTlvStream+ , tlvStream+ , unsafeTlvStream+ , TlvError(..)+ , encodeTlvStream+ , decodeTlvStream+ , decodeTlvStreamWith+ , decodeTlvStreamRaw++ -- ** Init TLVs+ , InitTlv(..)+ , ChainHash+ , chainHash+ , unChainHash++ -- * Message envelope+ , Envelope(..)++ -- * Encoding+ , EncodeError(..)+ , encodeMessage+ , encodeEnvelope++ -- * Decoding+ , DecodeError(..)+ , decodeMessage+ , decodeEnvelope+ , decodeEnvelopeWith++ -- * Primitive encoding+ , encodeU16+ , encodeU32+ , encodeU64+ , encodeS8+ , encodeS16+ , encodeS32+ , encodeS64+ , encodeTu16+ , encodeTu32+ , encodeTu64+ , encodeMinSigned+ , encodeBigSize++ -- * Primitive decoding+ , decodeU16+ , decodeU32+ , decodeU64+ , decodeS8+ , decodeS16+ , decodeS32+ , decodeS64+ , decodeTu16+ , decodeTu32+ , decodeTu64+ , decodeMinSigned+ , decodeBigSize+ ) where++-- Re-export from sub-modules+import Lightning.Protocol.BOLT1.Prim+import Lightning.Protocol.BOLT1.TLV+import Lightning.Protocol.BOLT1.Message+import Lightning.Protocol.BOLT1.Codec
+ lib/Lightning/Protocol/BOLT1/Codec.hs view
@@ -0,0 +1,349 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}++-- |+-- Module: Lightning.Protocol.BOLT1.Codec+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Message encoding and decoding for BOLT #1.++module Lightning.Protocol.BOLT1.Codec (+ -- * Encoding errors+ EncodeError(..)++ -- * Message encoding+ , encodeInit+ , encodeError+ , encodeWarning+ , encodePing+ , encodePong+ , encodePeerStorage+ , encodePeerStorageRetrieval+ , encodeMessage+ , encodeEnvelope++ -- * Decoding errors+ , DecodeError(..)++ -- * Message decoding+ , decodeInit+ , decodeError+ , decodeWarning+ , decodePing+ , decodePong+ , decodePeerStorage+ , decodePeerStorageRetrieval+ , decodeMessage+ , decodeEnvelope+ , decodeEnvelopeWith+ ) 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.Prim+import Lightning.Protocol.BOLT1.TLV+import Lightning.Protocol.BOLT1.Message++-- Encoding errors -------------------------------------------------------------++-- | Encoding errors.+data EncodeError+ = EncodeLengthOverflow -- ^ Field length exceeds u16 max (65535 bytes)+ | EncodeMessageTooLarge -- ^ Total message size exceeds 65535 bytes+ deriving stock (Eq, Show, Generic)++instance NFData EncodeError++-- Message encoding ------------------------------------------------------------++-- | 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)+ ]++-- | 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]++-- | 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]++-- | 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]++-- | 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 PeerStorage message payload.+encodePeerStorage :: PeerStorage -> Either EncodeError BS.ByteString+encodePeerStorage (PeerStorage blob) = do+ blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob)+ Right $ mconcat [blobLen, blob]++-- | 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]++-- | 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++-- | 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++-- Decoding errors -------------------------------------------------------------++-- | Decoding errors.+data DecodeError+ = DecodeInsufficientBytes+ | DecodeInvalidLength+ | DecodeUnknownEvenType !Word16+ | DecodeUnknownOddType !Word16+ | DecodeTlvError !TlvError+ | DecodeInvalidChannelId+ | DecodeInvalidExtension !TlvError+ deriving stock (Eq, Show, Generic)++instance NFData DecodeError++-- Message decoding ------------------------------------------------------------++-- | 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)++-- | 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)++-- | 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 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)++-- | 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 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)++-- | 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)++-- | 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 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)++-- | 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').+--+-- 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)
+ lib/Lightning/Protocol/BOLT1/Message.hs view
@@ -0,0 +1,213 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- |+-- Module: Lightning.Protocol.BOLT1.Message+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Message types for BOLT #1.++module Lightning.Protocol.BOLT1.Message (+ -- * Message types+ MsgType(..)+ , msgTypeWord+ , parseMsgType++ -- * Channel identifiers+ , ChannelId+ , channelId+ , unChannelId+ , allChannels++ -- * Setup messages+ , Init(..)+ , Error(..)+ , Warning(..)++ -- * Control messages+ , Ping(..)+ , Pong(..)++ -- * Peer storage messages+ , PeerStorage(..)+ , PeerStorageRetrieval(..)++ -- * Message envelope+ , Message(..)+ , messageType+ , Envelope(..)+ ) where++import Control.DeepSeq (NFData)+import qualified Data.ByteString as BS+import Data.Word (Word16)+import GHC.Generics (Generic)+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 #-}++-- | The all-zeros channel ID, used for connection-level errors.+--+-- 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).+data Init = Init+ { initGlobalFeatures :: !BS.ByteString+ , initFeatures :: !BS.ByteString+ , initTlvs :: ![InitTlv]+ } deriving stock (Eq, Show, Generic)++instance NFData Init++-- | The error message (type 17).+data Error = Error+ { errorChannelId :: !ChannelId+ , errorData :: !BS.ByteString+ } deriving stock (Eq, Show, Generic)++instance NFData Error++-- | The warning message (type 1).+data Warning = Warning+ { warningChannelId :: !ChannelId+ , warningData :: !BS.ByteString+ } deriving stock (Eq, Show, Generic)++instance NFData Warning++-- | The ping message (type 18).+data Ping = Ping+ { pingNumPongBytes :: {-# UNPACK #-} !Word16+ , pingIgnored :: !BS.ByteString+ } deriving stock (Eq, Show, Generic)++instance NFData Ping++-- | The pong message (type 19).+data Pong = Pong+ { pongIgnored :: !BS.ByteString+ } deriving stock (Eq, Show, Generic)++instance NFData Pong++-- | The peer_storage message (type 7).+data PeerStorage = PeerStorage+ { peerStorageBlob :: !BS.ByteString+ } deriving stock (Eq, Show, Generic)++instance NFData PeerStorage++-- | The peer_storage_retrieval message (type 9).+data PeerStorageRetrieval = PeerStorageRetrieval+ { peerStorageRetrievalBlob :: !BS.ByteString+ } deriving stock (Eq, Show, Generic)++instance NFData PeerStorageRetrieval++-- | All BOLT #1 messages.+data Message+ = MsgInitVal !Init+ | MsgErrorVal !Error+ | MsgWarningVal !Warning+ | MsgPingVal !Ping+ | MsgPongVal !Pong+ | MsgPeerStorageVal !PeerStorage+ | MsgPeerStorageRetrievalVal !PeerStorageRetrieval+ deriving stock (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
+ lib/Lightning/Protocol/BOLT1/Prim.hs view
@@ -0,0 +1,527 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- |+-- Module: Lightning.Protocol.BOLT1.Prim+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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)
+ lib/Lightning/Protocol/BOLT1/TLV.hs view
@@ -0,0 +1,244 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- |+-- Module: Lightning.Protocol.BOLT1.TLV+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- TLV (Type-Length-Value) format for BOLT #1.++module Lightning.Protocol.BOLT1.TLV (+ -- * TLV types+ TlvRecord(..)+ , TlvStream+ , unTlvStream+ , tlvStream+ , unsafeTlvStream+ , TlvError(..)++ -- * TLV encoding+ , encodeTlvRecord+ , encodeTlvStream++ -- * TLV decoding+ , decodeTlvStream+ , decodeTlvStreamWith+ , decodeTlvStreamRaw++ -- * Init TLV types+ , InitTlv(..)+ , parseInitTlvs+ , encodeInitTlvs++ -- * Re-exports+ , ChainHash+ , chainHash+ , unChainHash+ ) where++import Control.DeepSeq (NFData)+import Control.Monad (when)+import qualified Data.ByteString as BS+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)++instance NFData TlvRecord++-- | A TLV stream (series of TLV records).+newtype TlvStream = TlvStream { unTlvStream :: [TlvRecord] }+ deriving stock (Eq, Show, Generic)++instance NFData TlvStream++-- | Smart constructor for 'TlvStream' that validates records are+-- strictly increasing by type.+--+-- Returns 'Nothing' if types are not strictly increasing.+tlvStream :: [TlvRecord] -> Maybe TlvStream+tlvStream recs+ | isStrictlyIncreasing (map tlvType recs) = Just (TlvStream recs)+ | otherwise = Nothing+ where+ isStrictlyIncreasing :: [Word64] -> Bool+ isStrictlyIncreasing [] = True+ isStrictlyIncreasing [_] = True+ isStrictlyIncreasing (x:y:rest) = x < y && isStrictlyIncreasing (y:rest)++-- | Unsafe constructor for 'TlvStream' that skips validation.+--+-- Use only when ordering is already guaranteed (e.g., in decode functions).+unsafeTlvStream :: [TlvRecord] -> TlvStream+unsafeTlvStream = TlvStream++-- | TLV decoding errors.+data TlvError+ = TlvNonMinimalEncoding+ | TlvNotStrictlyIncreasing+ | TlvLengthExceedsBounds+ | TlvUnknownEvenType !Word64+ | TlvInvalidKnownType !Word64+ deriving stock (Eq, Show, Generic)++instance NFData TlvError++-- TLV encoding ----------------------------------------------------------------++-- | Encode a TLV record.+encodeTlvRecord :: TlvRecord -> BS.ByteString+encodeTlvRecord (TlvRecord typ val) = mconcat+ [ encodeBigSize typ+ , encodeBigSize (fromIntegral (BS.length val))+ , val+ ]++-- | Encode a TLV stream.+encodeTlvStream :: TlvStream -> BS.ByteString+encodeTlvStream (TlvStream recs) = mconcat (map encodeTlvRecord recs)++-- TLV decoding ----------------------------------------------------------------++-- | 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+--+-- 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 []+ 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++-- | Decode a TLV stream with configurable known-type predicate.+--+-- Per BOLT #1:+-- - Types must be strictly increasing+-- - Unknown even types cause failure+-- - Unknown odd types are skipped+--+-- The predicate determines which types are "known" for the context.+decodeTlvStreamWith+ :: (Word64 -> Bool) -- ^ Predicate: 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+ 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++-- | 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
+ ppad-bolt1.cabal view
@@ -0,0 +1,87 @@+cabal-version: 3.0+name: ppad-bolt1+version: 0.0.1+synopsis: Base protocol per BOLT #1+license: MIT+license-file: LICENSE+author: Jared Tobin+maintainer: jared@ppad.tech+category: Cryptography+build-type: Simple+tested-with: GHC == 9.10.3+extra-doc-files: CHANGELOG+description:+ Base protocol, per+ [BOLT #1](https://github.com/lightning/bolts/blob/master/01-messaging.md).++source-repository head+ type: git+ location: git.ppad.tech/bolt1.git++library+ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options:+ -Wall+ exposed-modules:+ Lightning.Protocol.BOLT1+ Lightning.Protocol.BOLT1.Codec+ Lightning.Protocol.BOLT1.Message+ Lightning.Protocol.BOLT1.Prim+ Lightning.Protocol.BOLT1.TLV+ build-depends:+ base >= 4.9 && < 5+ , bytestring >= 0.9 && < 0.13+ , deepseq >= 1.4 && < 1.6++test-suite bolt1-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs++ ghc-options:+ -rtsopts -Wall -O2++ build-depends:+ base+ , bytestring+ , ppad-base16+ , ppad-bolt1+ , tasty+ , tasty-hunit+ , tasty-quickcheck++benchmark bolt1-bench+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Main.hs+ other-modules: Fixtures++ ghc-options:+ -rtsopts -O2 -Wall -fno-warn-orphans++ build-depends:+ base+ , bytestring+ , criterion+ , deepseq+ , ppad-bolt1++benchmark bolt1-weigh+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Weight.hs+ other-modules: Fixtures++ ghc-options:+ -rtsopts -O2 -Wall -fno-warn-orphans++ build-depends:+ base+ , bytestring+ , deepseq+ , ppad-bolt1+ , weigh
+ test/Main.hs view
@@ -0,0 +1,699 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++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)