diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +# Changelog + +- 0.0.1 (2025-01-25) + * Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs new file mode 100644 --- /dev/null +++ b/bench/Fixtures.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Fixtures +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Test fixtures for BOLT #1 benchmarks. + +module Fixtures where + +import qualified Data.ByteString as BS +import Data.Maybe (fromJust) +import 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 #-} diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 #-} diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -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 diff --git a/lib/Lightning/Protocol/BOLT1.hs b/lib/Lightning/Protocol/BOLT1.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT1.hs @@ -0,0 +1,101 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module: Lightning.Protocol.BOLT1 +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT1/Codec.hs b/lib/Lightning/Protocol/BOLT1/Codec.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT1/Codec.hs @@ -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 +-- +-- 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) diff --git a/lib/Lightning/Protocol/BOLT1/Message.hs b/lib/Lightning/Protocol/BOLT1/Message.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT1/Message.hs @@ -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 +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT1/Prim.hs b/lib/Lightning/Protocol/BOLT1/Prim.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT1/Prim.hs @@ -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 +-- +-- 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) diff --git a/lib/Lightning/Protocol/BOLT1/TLV.hs b/lib/Lightning/Protocol/BOLT1/TLV.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT1/TLV.hs @@ -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 +-- +-- 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 diff --git a/ppad-bolt1.cabal b/ppad-bolt1.cabal new file mode 100644 --- /dev/null +++ b/ppad-bolt1.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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)