commit 36fceee777eeeff95f642d81d0b64f204017e13e
parent f2dfffdce6dd1d0fb3135cf967ee23a466f26fac
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 13:22:19 +0400
lib: rewrite the API for 0.1.0
Export everything from Lightning.Protocol.BOLT1, with the submodules
internal, and use snake_case names throughout.
- Fundamental types are abstract and built only by validating smart
constructors; points must carry a 0x02/0x03 prefix. Secret types
(preimages, per-commitment secrets) have redacted Show and
constant-time Eq, and no Generic.
- Satoshi and MilliSatoshi are bounded at 21M BTC per BOLT #1, with
checked arithmetic in place of Num.
- One TLV decoder, parameterised by the known types: it rejects
unknown even types and keeps every other record, so re-encoding
reproduces the input. tlv_stream sorts its input and rejects
duplicate types; truncation is distinguished from non-minimal
BigSize encodings.
- Message decoders consume their whole payload; every message keeps
its extension TLV records. Init has typed networks and remote_addr
fields and uses ppad-bolt9 feature vectors.
- Fixed-width encoders write directly into the result instead of
going through a lazy Builder.
- Adds fixed-size field codecs, u16-prefixed byte codecs and
ping_response; removes Envelope, the minimal signed integer codecs
and the Internal module.
Diffstat:
11 files changed, 1249 insertions(+), 3558 deletions(-)
diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs
@@ -1,433 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- |
--- Module: Fixtures
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Test fixtures for BOLT #1 benchmarks.
-
-module Fixtures where
-
-import qualified Data.ByteString as BS
-import Data.Maybe (fromJust)
-import Lightning.Protocol.BOLT1
-
--- Sample ByteStrings -----------------------------------------------------
-
--- | 64-byte sample data.
-bytes64 :: BS.ByteString
-bytes64 = BS.replicate 64 0xAB
-{-# NOINLINE bytes64 #-}
-
--- | 1KB sample data.
-bytes1k :: BS.ByteString
-bytes1k = BS.replicate 1024 0xCD
-{-# NOINLINE bytes1k #-}
-
--- | 16KB sample data.
-bytes16k :: BS.ByteString
-bytes16k = BS.replicate 16384 0xEF
-{-# NOINLINE bytes16k #-}
-
--- Sample chain hashes (32 bytes each) ------------------------------------
-
--- | Bitcoin mainnet genesis block hash (reversed, as used in LN).
-mainnetChainHash :: ChainHash
-mainnetChainHash = fromJust $ chainHash $ BS.pack
- [ 0x6f, 0xe2, 0x8c, 0x0a, 0xb6, 0xf1, 0xb3, 0x72
- , 0xc1, 0xa6, 0xa2, 0x46, 0xae, 0x63, 0xf7, 0x4f
- , 0x93, 0x1e, 0x83, 0x65, 0xe1, 0x5a, 0x08, 0x9c
- , 0x68, 0xd6, 0x19, 0x00, 0x00, 0x00, 0x00, 0x00
- ]
-{-# NOINLINE mainnetChainHash #-}
-
--- | Bitcoin testnet genesis block hash (reversed, as used in LN).
-testnetChainHash :: ChainHash
-testnetChainHash = fromJust $ chainHash $ BS.pack
- [ 0x43, 0x49, 0x7f, 0xd7, 0xf8, 0x26, 0x95, 0x71
- , 0x08, 0xf4, 0xa3, 0x0f, 0xd9, 0xce, 0xc3, 0xae
- , 0xba, 0x79, 0x97, 0x20, 0x84, 0xe9, 0x0e, 0xad
- , 0x01, 0xea, 0x33, 0x09, 0x00, 0x00, 0x00, 0x00
- ]
-{-# NOINLINE testnetChainHash #-}
-
--- Sample channel IDs (32 bytes each) -------------------------------------
-
--- | Sample channel ID (non-zero).
-sampleChannelId :: ChannelId
-sampleChannelId = fromJust $ channelId $ BS.pack
- [ 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08
- , 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10
- , 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18
- , 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20
- ]
-{-# NOINLINE sampleChannelId #-}
-
--- Sample Init messages ---------------------------------------------------
-
--- | Minimal Init message (empty features, no TLVs).
-minimalInit :: Init
-minimalInit = Init
- { initGlobalFeatures = BS.empty
- , initFeatures = BS.empty
- , initTlvs = []
- }
-{-# NOINLINE minimalInit #-}
-
--- | Init with feature bits set.
-initWithFeatures :: Init
-initWithFeatures = Init
- { initGlobalFeatures = BS.pack [0x00, 0x01] -- 2 bytes
- , initFeatures = BS.pack [0x02, 0xa2] -- data_loss_protect, etc.
- , initTlvs = []
- }
-{-# NOINLINE initWithFeatures #-}
-
--- | Init with TLV extensions.
-initWithTlvs :: Init
-initWithTlvs = Init
- { initGlobalFeatures = BS.empty
- , initFeatures = BS.pack [0x02, 0xa2]
- , initTlvs = [InitNetworks [mainnetChainHash]]
- }
-{-# NOINLINE initWithTlvs #-}
-
--- | Init with multiple chain hashes.
-initWithMultipleChains :: Init
-initWithMultipleChains = Init
- { initGlobalFeatures = BS.empty
- , initFeatures = BS.pack [0x02, 0xa2]
- , initTlvs = [InitNetworks [mainnetChainHash, testnetChainHash]]
- }
-{-# NOINLINE initWithMultipleChains #-}
-
--- | Full Init with features and remote_addr TLV.
-fullInit :: Init
-fullInit = Init
- { initGlobalFeatures = BS.pack [0x00, 0x01]
- , initFeatures = BS.pack [0x02, 0xa2, 0x01]
- , initTlvs =
- [ InitNetworks [mainnetChainHash]
- , InitRemoteAddr (BS.pack [0x01, 0x7f, 0x00, 0x00, 0x01, 0x27, 0x10])
- ]
- }
-{-# NOINLINE fullInit #-}
-
--- Sample Error messages --------------------------------------------------
-
--- | Minimal Error message (connection-level, empty data).
-minimalError :: Error
-minimalError = Error
- { errorChannelId = allChannels
- , errorData = BS.empty
- }
-{-# NOINLINE minimalError #-}
-
--- | Error with channel ID and message.
-errorWithData :: Error
-errorWithData = Error
- { errorChannelId = sampleChannelId
- , errorData = "funding transaction failed"
- }
-{-# NOINLINE errorWithData #-}
-
--- | Error with longer data.
-errorWithLongData :: Error
-errorWithLongData = Error
- { errorChannelId = sampleChannelId
- , errorData = bytes1k
- }
-{-# NOINLINE errorWithLongData #-}
-
--- Sample Warning messages ------------------------------------------------
-
--- | Minimal Warning message.
-minimalWarning :: Warning
-minimalWarning = Warning
- { warningChannelId = allChannels
- , warningData = BS.empty
- }
-{-# NOINLINE minimalWarning #-}
-
--- | Warning with message.
-warningWithData :: Warning
-warningWithData = Warning
- { warningChannelId = sampleChannelId
- , warningData = "channel fee too low"
- }
-{-# NOINLINE warningWithData #-}
-
--- Sample Ping messages ---------------------------------------------------
-
--- | Minimal Ping (no padding, no response requested).
-minimalPing :: Ping
-minimalPing = Ping
- { pingNumPongBytes = 0
- , pingIgnored = BS.empty
- }
-{-# NOINLINE minimalPing #-}
-
--- | Ping with response requested but no padding.
-pingWithResponse :: Ping
-pingWithResponse = Ping
- { pingNumPongBytes = 64
- , pingIgnored = BS.empty
- }
-{-# NOINLINE pingWithResponse #-}
-
--- | Ping with padding (64 bytes).
-pingWithPadding :: Ping
-pingWithPadding = Ping
- { pingNumPongBytes = 64
- , pingIgnored = bytes64
- }
-{-# NOINLINE pingWithPadding #-}
-
--- | Ping with large padding (1KB).
-pingWithLargePadding :: Ping
-pingWithLargePadding = Ping
- { pingNumPongBytes = 128
- , pingIgnored = bytes1k
- }
-{-# NOINLINE pingWithLargePadding #-}
-
--- Sample Pong messages ---------------------------------------------------
-
--- | Minimal Pong (no ignored bytes).
-minimalPong :: Pong
-minimalPong = Pong
- { pongIgnored = BS.empty
- }
-{-# NOINLINE minimalPong #-}
-
--- | Pong with padding (64 bytes).
-pongWithPadding :: Pong
-pongWithPadding = Pong
- { pongIgnored = bytes64
- }
-{-# NOINLINE pongWithPadding #-}
-
--- | Pong with large padding (1KB).
-pongWithLargePadding :: Pong
-pongWithLargePadding = Pong
- { pongIgnored = bytes1k
- }
-{-# NOINLINE pongWithLargePadding #-}
-
--- Sample PeerStorage messages --------------------------------------------
-
--- | Minimal PeerStorage (empty blob).
-minimalPeerStorage :: PeerStorage
-minimalPeerStorage = PeerStorage
- { peerStorageBlob = BS.empty
- }
-{-# NOINLINE minimalPeerStorage #-}
-
--- | PeerStorage with 1KB blob.
-peerStorageSmall :: PeerStorage
-peerStorageSmall = PeerStorage
- { peerStorageBlob = bytes1k
- }
-{-# NOINLINE peerStorageSmall #-}
-
--- | PeerStorage with 16KB blob.
-peerStorageLarge :: PeerStorage
-peerStorageLarge = PeerStorage
- { peerStorageBlob = bytes16k
- }
-{-# NOINLINE peerStorageLarge #-}
-
--- Sample PeerStorageRetrieval messages -----------------------------------
-
--- | Minimal PeerStorageRetrieval (empty blob).
-minimalPeerStorageRetrieval :: PeerStorageRetrieval
-minimalPeerStorageRetrieval = PeerStorageRetrieval
- { peerStorageRetrievalBlob = BS.empty
- }
-{-# NOINLINE minimalPeerStorageRetrieval #-}
-
--- | PeerStorageRetrieval with 1KB blob.
-peerStorageRetrievalSmall :: PeerStorageRetrieval
-peerStorageRetrievalSmall = PeerStorageRetrieval
- { peerStorageRetrievalBlob = bytes1k
- }
-{-# NOINLINE peerStorageRetrievalSmall #-}
-
--- | PeerStorageRetrieval with 16KB blob.
-peerStorageRetrievalLarge :: PeerStorageRetrieval
-peerStorageRetrievalLarge = PeerStorageRetrieval
- { peerStorageRetrievalBlob = bytes16k
- }
-{-# NOINLINE peerStorageRetrievalLarge #-}
-
--- Sample TLV streams -----------------------------------------------------
-
--- | Empty TLV stream.
-emptyTlvStream :: TlvStream
-emptyTlvStream = unsafeTlvStream []
-{-# NOINLINE emptyTlvStream #-}
-
--- | TLV stream with 1 record.
-smallTlvStream :: TlvStream
-smallTlvStream = unsafeTlvStream
- [ TlvRecord 1 (BS.replicate 32 0x01)
- ]
-{-# NOINLINE smallTlvStream #-}
-
--- | TLV stream with 5 records.
-mediumTlvStream :: TlvStream
-mediumTlvStream = unsafeTlvStream
- [ TlvRecord 1 (BS.replicate 8 0x01)
- , TlvRecord 3 (BS.replicate 16 0x03)
- , TlvRecord 5 (BS.replicate 32 0x05)
- , TlvRecord 7 (BS.replicate 64 0x07)
- , TlvRecord 9 (BS.replicate 128 0x09)
- ]
-{-# NOINLINE mediumTlvStream #-}
-
--- | TLV stream with 20 records.
-largeTlvStream :: TlvStream
-largeTlvStream = unsafeTlvStream
- [ TlvRecord 1 (BS.replicate 8 0x01)
- , TlvRecord 3 (BS.replicate 16 0x02)
- , TlvRecord 5 (BS.replicate 8 0x03)
- , TlvRecord 7 (BS.replicate 16 0x04)
- , TlvRecord 9 (BS.replicate 8 0x05)
- , TlvRecord 11 (BS.replicate 16 0x06)
- , TlvRecord 13 (BS.replicate 8 0x07)
- , TlvRecord 15 (BS.replicate 16 0x08)
- , TlvRecord 17 (BS.replicate 8 0x09)
- , TlvRecord 19 (BS.replicate 16 0x0a)
- , TlvRecord 21 (BS.replicate 8 0x0b)
- , TlvRecord 23 (BS.replicate 16 0x0c)
- , TlvRecord 25 (BS.replicate 8 0x0d)
- , TlvRecord 27 (BS.replicate 16 0x0e)
- , TlvRecord 29 (BS.replicate 8 0x0f)
- , TlvRecord 31 (BS.replicate 16 0x10)
- , TlvRecord 33 (BS.replicate 8 0x11)
- , TlvRecord 35 (BS.replicate 16 0x12)
- , TlvRecord 37 (BS.replicate 8 0x13)
- , TlvRecord 39 (BS.replicate 16 0x14)
- ]
-{-# NOINLINE largeTlvStream #-}
-
--- Encoded message bytes (for decode benchmarks) --------------------------
-
--- Helper to encode or fail.
-encodeOrFail :: Either EncodeError BS.ByteString -> BS.ByteString
-encodeOrFail (Right bs) = bs
-encodeOrFail (Left _) = error "encodeOrFail: encoding failed"
-
--- | Encoded minimal Init.
-encodedMinimalInit :: BS.ByteString
-encodedMinimalInit = encodeOrFail $ encodeEnvelope (MsgInitVal minimalInit) Nothing
-{-# NOINLINE encodedMinimalInit #-}
-
--- | Encoded Init with TLVs.
-encodedInitWithTlvs :: BS.ByteString
-encodedInitWithTlvs = encodeOrFail $ encodeEnvelope (MsgInitVal initWithTlvs) Nothing
-{-# NOINLINE encodedInitWithTlvs #-}
-
--- | Encoded full Init.
-encodedFullInit :: BS.ByteString
-encodedFullInit = encodeOrFail $ encodeEnvelope (MsgInitVal fullInit) Nothing
-{-# NOINLINE encodedFullInit #-}
-
--- | Encoded minimal Error.
-encodedMinimalError :: BS.ByteString
-encodedMinimalError = encodeOrFail $ encodeEnvelope (MsgErrorVal minimalError) Nothing
-{-# NOINLINE encodedMinimalError #-}
-
--- | Encoded Error with data.
-encodedErrorWithData :: BS.ByteString
-encodedErrorWithData = encodeOrFail $ encodeEnvelope (MsgErrorVal errorWithData) Nothing
-{-# NOINLINE encodedErrorWithData #-}
-
--- | Encoded minimal Warning.
-encodedMinimalWarning :: BS.ByteString
-encodedMinimalWarning = encodeOrFail $
- encodeEnvelope (MsgWarningVal minimalWarning) Nothing
-{-# NOINLINE encodedMinimalWarning #-}
-
--- | Encoded Warning with data.
-encodedWarningWithData :: BS.ByteString
-encodedWarningWithData = encodeOrFail $
- encodeEnvelope (MsgWarningVal warningWithData) Nothing
-{-# NOINLINE encodedWarningWithData #-}
-
--- | Encoded minimal Ping.
-encodedMinimalPing :: BS.ByteString
-encodedMinimalPing = encodeOrFail $ encodeEnvelope (MsgPingVal minimalPing) Nothing
-{-# NOINLINE encodedMinimalPing #-}
-
--- | Encoded Ping with padding.
-encodedPingWithPadding :: BS.ByteString
-encodedPingWithPadding = encodeOrFail $
- encodeEnvelope (MsgPingVal pingWithPadding) Nothing
-{-# NOINLINE encodedPingWithPadding #-}
-
--- | Encoded Ping with large padding.
-encodedPingWithLargePadding :: BS.ByteString
-encodedPingWithLargePadding = encodeOrFail $
- encodeEnvelope (MsgPingVal pingWithLargePadding) Nothing
-{-# NOINLINE encodedPingWithLargePadding #-}
-
--- | Encoded minimal Pong.
-encodedMinimalPong :: BS.ByteString
-encodedMinimalPong = encodeOrFail $ encodeEnvelope (MsgPongVal minimalPong) Nothing
-{-# NOINLINE encodedMinimalPong #-}
-
--- | Encoded Pong with padding.
-encodedPongWithPadding :: BS.ByteString
-encodedPongWithPadding = encodeOrFail $
- encodeEnvelope (MsgPongVal pongWithPadding) Nothing
-{-# NOINLINE encodedPongWithPadding #-}
-
--- | Encoded minimal PeerStorage.
-encodedMinimalPeerStorage :: BS.ByteString
-encodedMinimalPeerStorage = encodeOrFail $
- encodeEnvelope (MsgPeerStorageVal minimalPeerStorage) Nothing
-{-# NOINLINE encodedMinimalPeerStorage #-}
-
--- | Encoded PeerStorage with 1KB blob.
-encodedPeerStorageSmall :: BS.ByteString
-encodedPeerStorageSmall = encodeOrFail $
- encodeEnvelope (MsgPeerStorageVal peerStorageSmall) Nothing
-{-# NOINLINE encodedPeerStorageSmall #-}
-
--- | Encoded minimal PeerStorageRetrieval.
-encodedMinimalPeerStorageRetrieval :: BS.ByteString
-encodedMinimalPeerStorageRetrieval = encodeOrFail $
- encodeEnvelope (MsgPeerStorageRetrievalVal minimalPeerStorageRetrieval) Nothing
-{-# NOINLINE encodedMinimalPeerStorageRetrieval #-}
-
--- | Encoded PeerStorageRetrieval with 1KB blob.
-encodedPeerStorageRetrievalSmall :: BS.ByteString
-encodedPeerStorageRetrievalSmall = encodeOrFail $
- encodeEnvelope (MsgPeerStorageRetrievalVal peerStorageRetrievalSmall) Nothing
-{-# NOINLINE encodedPeerStorageRetrievalSmall #-}
-
--- Encoded TLV streams (for decode benchmarks) ----------------------------
-
--- | Encoded empty TLV stream.
-encodedEmptyTlvStream :: BS.ByteString
-encodedEmptyTlvStream = encodeTlvStream emptyTlvStream
-{-# NOINLINE encodedEmptyTlvStream #-}
-
--- | Encoded small TLV stream (1 record).
-encodedSmallTlvStream :: BS.ByteString
-encodedSmallTlvStream = encodeTlvStream smallTlvStream
-{-# NOINLINE encodedSmallTlvStream #-}
-
--- | Encoded medium TLV stream (5 records).
-encodedMediumTlvStream :: BS.ByteString
-encodedMediumTlvStream = encodeTlvStream mediumTlvStream
-{-# NOINLINE encodedMediumTlvStream #-}
-
--- | Encoded large TLV stream (20 records).
-encodedLargeTlvStream :: BS.ByteString
-encodedLargeTlvStream = encodeTlvStream largeTlvStream
-{-# NOINLINE encodedLargeTlvStream #-}
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -1,526 +0,0 @@
-{-# 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
@@ -1,347 +0,0 @@
-{-# 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
@@ -6,145 +6,152 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Base protocol for the Lightning Network, per
--- [BOLT #1](https://github.com/lightning/bolts/blob/master/01-messaging.md).
+-- The base protocol of the Lightning Network, per
+-- [BOLT #1](https://github.com/lightning/bolts/blob/master/01-messaging.md):
+-- fundamental types and their encodings, the TLV format, and the
+-- @init@, @error@, @warning@, @ping@, @pong@, @peer_storage@ and
+-- @peer_storage_retrieval@ messages.
+--
+-- The fundamental types and TLV machinery here are shared by the other
+-- ppad BOLT libraries.
module Lightning.Protocol.BOLT1 (
- -- * Message types
+ -- * Messages
Message(..)
- , MsgType(
- MsgInit
- , MsgError
- , MsgPing
- , MsgPong
- , MsgWarning
- , MsgPeerStorage
- , MsgPeerStorageRet
- )
- , msgUnknown
- , msgTypeWord
-
- -- * Channel identifiers
- , ChannelId(..)
- , channelId
- , unChannelId
- , allChannels
-
- -- * Signatures and keys
- , Signature(..)
- , signature
- , unSignature
- , Point(..)
- , point
- , unPoint
-
- -- * Payment types
- , PaymentHash(..)
- , paymentHash
- , unPaymentHash
- , PaymentPreimage(..)
- , paymentPreimage
- , unPaymentPreimage
-
- -- * Per-commitment secret
- , PerCommitmentSecret(..)
- , perCommitmentSecret
- , unPerCommitmentSecret
-
- -- * Short channel identifier
- , ShortChannelId(..)
- , shortChannelId
- , scidWord64
- , scidBlockHeight
- , scidTxIndex
- , scidOutputIndex
-
- -- * Amounts
- , Satoshi(..)
- , MilliSatoshi(..)
- , satToMsat
- , msatToSat
-
- -- ** Setup messages
+ , message_type
, Init(..)
, Error(..)
, Warning(..)
-
- -- ** Control messages
, Ping(..)
, Pong(..)
-
- -- ** Peer storage
+ , ping_response
, PeerStorage(..)
, PeerStorageRetrieval(..)
+ -- * Encoding and decoding messages
+ , encode_message
+ , decode_message
+ , encode_envelope
+ , decode_envelope
+ , EncodeError(..)
+ , DecodeError(..)
+
+ -- ** Payloads
+ , encode_init
+ , decode_init
+ , encode_error
+ , decode_error
+ , encode_warning
+ , decode_warning
+ , encode_ping
+ , decode_ping
+ , encode_pong
+ , decode_pong
+ , encode_peer_storage
+ , decode_peer_storage
+ , encode_peer_storage_retrieval
+ , decode_peer_storage_retrieval
+
-- * TLV
, TlvRecord(..)
, TlvStream
- , unTlvStream
- , tlvStream
- , unsafeTlvStream
+ , tlv_stream
+ , un_tlv_stream
+ , empty_tlv_stream
+ , lookup_tlv
+ , filter_tlv_stream
+ , encode_tlv_stream
+ , decode_tlv_stream
, TlvError(..)
- , encodeTlvStream
- , decodeTlvStream
- , decodeTlvStreamWith
- , decodeTlvStreamRaw
-
- -- ** Init TLVs
- , InitTlv(..)
- , ChainHash(..)
- , chainHash
- , unChainHash
-
- -- * Message envelope
- , Envelope
- , envelope
- , envType
- , envPayload
- , envExtension
-
- -- * 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
+ -- * Fundamental types
+ , ChainHash
+ , chain_hash
+ , un_chain_hash
+ , ChannelId
+ , channel_id
+ , un_channel_id
+ , all_channels
+ , Signature
+ , signature
+ , un_signature
+ , Point
+ , point
+ , un_point
+ , PaymentHash
+ , payment_hash
+ , un_payment_hash
+ , PaymentPreimage
+ , payment_preimage
+ , un_payment_preimage
+ , PerCommitmentSecret
+ , per_commitment_secret
+ , un_per_commitment_secret
+ , ShortChannelId(..)
+ , short_channel_id
+ , scid_block_height
+ , scid_tx_index
+ , scid_output_index
+
+ -- ** Amounts
+ , Satoshi
+ , satoshi
+ , un_satoshi
+ , max_satoshi
+ , MilliSatoshi
+ , milli_satoshi
+ , un_milli_satoshi
+ , max_milli_satoshi
+ , sat_to_msat
+ , msat_to_sat
+ , add_sat
+ , sub_sat
+ , add_msat
+ , sub_msat
+
+ -- * Primitive encodings
+ -- | Decoders return the decoded value and the remaining input, except
+ -- for the truncated integers, which occupy their whole input.
+ , encode_u16
+ , encode_u32
+ , encode_u64
+ , decode_u16
+ , decode_u32
+ , decode_u64
+ , encode_s8
+ , encode_s16
+ , encode_s32
+ , encode_s64
+ , decode_s8
+ , decode_s16
+ , decode_s32
+ , decode_s64
+ , encode_tu16
+ , encode_tu32
+ , encode_tu64
+ , decode_tu16
+ , decode_tu32
+ , decode_tu64
+ , encode_bigsize
+ , decode_bigsize
+ , encode_u16_prefixed
+ , decode_u16_prefixed
+ , decode_chain_hash
+ , decode_channel_id
+ , decode_signature
+ , decode_point
+ , decode_payment_hash
+ , decode_payment_preimage
+ , decode_per_commitment_secret
+ , encode_short_channel_id
+ , decode_short_channel_id
+ , encode_satoshi
+ , decode_satoshi
+ , encode_milli_satoshi
+ , decode_milli_satoshi
) where
--- Re-export from sub-modules
+import Lightning.Protocol.BOLT1.Codec
+import Lightning.Protocol.BOLT1.Message
import Lightning.Protocol.BOLT1.Prim
import Lightning.Protocol.BOLT1.TLV
-import Lightning.Protocol.BOLT1.Message
-import Lightning.Protocol.BOLT1.Codec
diff --git a/lib/Lightning/Protocol/BOLT1/Codec.hs b/lib/Lightning/Protocol/BOLT1/Codec.hs
@@ -1,8 +1,6 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE LambdaCase #-}
-- |
-- Module: Lightning.Protocol.BOLT1.Codec
@@ -10,340 +8,277 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Message encoding and decoding for BOLT #1.
+-- Encoding and decoding of BOLT #1 messages.
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
+ , encode_envelope
+ , decode_envelope
+
+ , encode_message
+ , decode_message
+
+ , encode_init
+ , decode_init
+ , encode_error
+ , decode_error
+ , encode_warning
+ , decode_warning
+ , encode_ping
+ , decode_ping
+ , encode_pong
+ , decode_pong
+ , encode_peer_storage
+ , decode_peer_storage
+ , encode_peer_storage_retrieval
+ , decode_peer_storage_retrieval
+
+ , ping_response
) where
import Control.DeepSeq (NFData)
-import Control.Monad (when, unless)
import qualified Data.ByteString as BS
import Data.Word (Word16, Word64)
import GHC.Generics (Generic)
+import Lightning.Protocol.BOLT1.Message
import Lightning.Protocol.BOLT1.Prim
import Lightning.Protocol.BOLT1.TLV
-import Lightning.Protocol.BOLT1.Message
-
--- Encoding errors -------------------------------------------------------------
+import qualified Lightning.Protocol.BOLT9 as BOLT9
--- | Encoding errors.
+-- | Why a message failed to encode.
data EncodeError
- = EncodeLengthOverflow -- ^ Field length exceeds u16 max (65535 bytes)
- | EncodeMessageTooLarge -- ^ Total message size exceeds 65535 bytes
- deriving stock (Eq, Show, Generic)
+ = EncodeLengthOverflow
+ -- ^ a length-prefixed field exceeds 65535 bytes
+ | EncodeMessageTooLarge
+ -- ^ the message (type and payload) exceeds 65535 bytes
+ | EncodeInvalidTlvs
+ -- ^ a record in a @_tlvs@ field duplicates a typed field
+ deriving (Eq, Show, Generic)
instance NFData EncodeError
--- Message encoding ------------------------------------------------------------
-
--- | 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.
+-- | Why a message failed to decode.
data DecodeError
= DecodeInsufficientBytes
- | DecodeInvalidLength
+ -- ^ the input ended before a field did
+ | DecodeTlvError !TlvError
+ -- ^ the message's TLV stream is malformed
+ | DecodeInvalidTlvValue !Word64
+ -- ^ a known TLV record (of the given type) has a malformed value
| DecodeUnknownEvenType !Word16
+ -- ^ an unknown even message type; the connection must be closed
| DecodeUnknownOddType !Word16
- | DecodeTlvError !TlvError
- | DecodeInvalidChannelId
- | DecodeInvalidExtension !TlvError
- deriving stock (Eq, Show, Generic)
+ -- ^ an unknown odd message type; the message must be ignored
+ deriving (Eq, Show, Generic)
instance NFData DecodeError
--- Message decoding ------------------------------------------------------------
+-- framing --------------------------------------------------------------------
--- | Decode an Init message from payload bytes.
+-- | Prefix a payload with its message type. Fails if the result
+-- exceeds the 65535-byte message limit.
--
--- 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.
+-- >>> encode_envelope 19 "\NUL\NUL"
+-- Right "\NUL\DC3\NUL\NUL"
+encode_envelope :: Word16 -> BS.ByteString -> Either EncodeError BS.ByteString
+encode_envelope t payload
+ | BS.length payload > 65533 = Left EncodeMessageTooLarge
+ | otherwise = Right (encode_u16 t <> payload)
+
+-- | Split a message into 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).
+-- >>> decode_envelope "\NUL\DC3\NUL\NUL"
+-- Right (19,"\NUL\NUL")
+decode_envelope :: BS.ByteString -> Either DecodeError (Word16, BS.ByteString)
+decode_envelope bs = case decode_u16 bs of
+ Just r -> Right r
+ Nothing -> Left DecodeInsufficientBytes
+
+-- | Encode a BOLT #1 message, including its type.
--
--- 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)
+-- >>> encode_message (MsgPong (Pong "" empty_tlv_stream))
+-- Right "\NUL\DC3\NUL\NUL"
+encode_message :: Message -> Either EncodeError BS.ByteString
+encode_message m = do
+ payload <- case m of
+ MsgInit a -> encode_init a
+ MsgError a -> encode_error a
+ MsgWarning a -> encode_warning a
+ MsgPing a -> encode_ping a
+ MsgPong a -> encode_pong a
+ MsgPeerStorage a -> encode_peer_storage a
+ MsgPeerStorageRetrieval a -> encode_peer_storage_retrieval a
+ encode_envelope (message_type m) payload
+
+-- | Decode a BOLT #1 message, including its type.
--
--- This uses the default policy of treating all extension TLV types as
--- unknown. Use 'decodeEnvelopeWith' for configurable extension handling.
+-- A type that BOLT #1 doesn't define yields 'DecodeUnknownEvenType'
+-- or 'DecodeUnknownOddType'; callers dispatching messages from other
+-- BOLTs should use 'decode_envelope' first.
--
--- 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.
+-- >>> decode_message "\NUL\DC3\NUL\NUL"
+-- Right (MsgPong (Pong {pong_ignored = "", pong_tlvs = TlvStream []}))
+-- >>> decode_message "\NUL\DC4\NUL\NUL"
+-- Left (DecodeUnknownEvenType 20)
+decode_message :: BS.ByteString -> Either DecodeError Message
+decode_message bs = do
+ (t, payload) <- decode_envelope bs
+ case t of
+ 16 -> MsgInit <$> decode_init payload
+ 17 -> MsgError <$> decode_error payload
+ 1 -> MsgWarning <$> decode_warning payload
+ 18 -> MsgPing <$> decode_ping payload
+ 19 -> MsgPong <$> decode_pong payload
+ 7 -> MsgPeerStorage <$> decode_peer_storage payload
+ 9 -> MsgPeerStorageRetrieval <$> decode_peer_storage_retrieval payload
+ _ | even t -> Left (DecodeUnknownEvenType t)
+ | otherwise -> Left (DecodeUnknownOddType t)
+
+-- helpers --------------------------------------------------------------------
+
+prefixed :: BS.ByteString -> Either EncodeError BS.ByteString
+prefixed bs = maybe (Left EncodeLengthOverflow) Right (encode_u16_prefixed bs)
+
+need :: Maybe a -> Either DecodeError a
+need = maybe (Left DecodeInsufficientBytes) Right
+{-# INLINE need #-}
+
+-- an extension stream in which no types are known
+extension :: BS.ByteString -> Either DecodeError TlvStream
+extension bs = either (Left . DecodeTlvError) Right
+ (decode_tlv_stream (const False) bs)
+
+-- init -----------------------------------------------------------------------
+
+-- | Encode an 'Init' payload.
+encode_init :: Init -> Either EncodeError BS.ByteString
+encode_init (Init gf f nets addr tlvs) = do
+ gf' <- prefixed (BOLT9.render gf)
+ f' <- prefixed (BOLT9.render f)
+ let known = maybe [] (\cs -> [TlvRecord 1 (mconcat (map un_chain_hash cs))])
+ nets
+ <> maybe [] (\a -> [TlvRecord 3 a]) addr
+ stream <- maybe (Left EncodeInvalidTlvs) Right
+ (tlv_stream (known <> un_tlv_stream tlvs))
+ pure (gf' <> f' <> encode_tlv_stream stream)
+
+-- | Decode an 'Init' payload.
+decode_init :: BS.ByteString -> Either DecodeError Init
+decode_init bs = do
+ (gf, r0) <- need (decode_u16_prefixed bs)
+ (f, r1) <- need (decode_u16_prefixed r0)
+ stream <- either (Left . DecodeTlvError) Right
+ (decode_tlv_stream (\t -> t == 1 || t == 3) r1)
+ nets <- traverse networks (lookup_tlv 1 stream)
+ pure Init
+ { init_global_features = BOLT9.parse gf
+ , init_features = BOLT9.parse f
+ , init_networks = nets
+ , init_remote_addr = lookup_tlv 3 stream
+ , init_tlvs = filter_tlv_stream (\t -> t /= 1 && t /= 3) stream
+ }
+ where
+ networks v
+ | BS.length v `rem` 32 /= 0 = Left (DecodeInvalidTlvValue 1)
+ | otherwise = Right (chunks v)
+ chunks !v = case decode_chain_hash v of
+ Just (h, rest) -> h : chunks rest
+ Nothing -> []
+
+-- error, warning -------------------------------------------------------------
+
+-- | Encode an 'Error' payload.
+encode_error :: Error -> Either EncodeError BS.ByteString
+encode_error (Error cid dat tlvs) = do
+ dat' <- prefixed dat
+ pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs)
+
+-- | Decode an 'Error' payload.
+decode_error :: BS.ByteString -> Either DecodeError Error
+decode_error bs = do
+ (cid, r0) <- need (decode_channel_id bs)
+ (dat, r1) <- need (decode_u16_prefixed r0)
+ Error cid dat <$> extension r1
+
+-- | Encode a 'Warning' payload.
+encode_warning :: Warning -> Either EncodeError BS.ByteString
+encode_warning (Warning cid dat tlvs) = do
+ dat' <- prefixed dat
+ pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs)
+
+-- | Decode a 'Warning' payload.
+decode_warning :: BS.ByteString -> Either DecodeError Warning
+decode_warning bs = do
+ (cid, r0) <- need (decode_channel_id bs)
+ (dat, r1) <- need (decode_u16_prefixed r0)
+ Warning cid dat <$> extension r1
+
+-- ping, pong -----------------------------------------------------------------
+
+-- | Encode a 'Ping' payload.
+encode_ping :: Ping -> Either EncodeError BS.ByteString
+encode_ping (Ping n ign tlvs) = do
+ ign' <- prefixed ign
+ pure (encode_u16 n <> ign' <> encode_tlv_stream tlvs)
+
+-- | Decode a 'Ping' payload.
+decode_ping :: BS.ByteString -> Either DecodeError Ping
+decode_ping bs = do
+ (n, r0) <- need (decode_u16 bs)
+ (ign, r1) <- need (decode_u16_prefixed r0)
+ Ping n ign <$> extension r1
+
+-- | Encode a 'Pong' payload.
+encode_pong :: Pong -> Either EncodeError BS.ByteString
+encode_pong (Pong ign tlvs) = do
+ ign' <- prefixed ign
+ pure (ign' <> encode_tlv_stream tlvs)
+
+-- | Decode a 'Pong' payload.
+decode_pong :: BS.ByteString -> Either DecodeError Pong
+decode_pong bs = do
+ (ign, r0) <- need (decode_u16_prefixed bs)
+ Pong ign <$> extension r0
+
+-- | The 'Pong' a node must send in reply to a 'Ping', if any. Per
+-- BOLT #1, a ping requesting 65532 or more bytes is ignored.
--
--- 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)
+-- >>> ping_response (Ping 4 "" empty_tlv_stream)
+-- Just (Pong {pong_ignored = "\NUL\NUL\NUL\NUL", pong_tlvs = TlvStream []})
+-- >>> ping_response (Ping 65532 "" empty_tlv_stream)
+-- Nothing
+ping_response :: Ping -> Maybe Pong
+ping_response (Ping n _ _)
+ | n >= 65532 = Nothing
+ | otherwise =
+ Just (Pong (BS.replicate (fromIntegral n) 0x00) empty_tlv_stream)
+
+-- peer storage ---------------------------------------------------------------
+
+-- | Encode a 'PeerStorage' payload.
+encode_peer_storage :: PeerStorage -> Either EncodeError BS.ByteString
+encode_peer_storage (PeerStorage blob tlvs) = do
+ blob' <- prefixed blob
+ pure (blob' <> encode_tlv_stream tlvs)
+
+-- | Decode a 'PeerStorage' payload.
+decode_peer_storage :: BS.ByteString -> Either DecodeError PeerStorage
+decode_peer_storage bs = do
+ (blob, r0) <- need (decode_u16_prefixed bs)
+ PeerStorage blob <$> extension r0
+
+-- | Encode a 'PeerStorageRetrieval' payload.
+encode_peer_storage_retrieval
+ :: PeerStorageRetrieval -> Either EncodeError BS.ByteString
+encode_peer_storage_retrieval (PeerStorageRetrieval blob tlvs) = do
+ blob' <- prefixed blob
+ pure (blob' <> encode_tlv_stream tlvs)
+
+-- | Decode a 'PeerStorageRetrieval' payload.
+decode_peer_storage_retrieval
+ :: BS.ByteString -> Either DecodeError PeerStorageRetrieval
+decode_peer_storage_retrieval bs = do
+ (blob, r0) <- need (decode_u16_prefixed bs)
+ PeerStorageRetrieval blob <$> extension r0
diff --git a/lib/Lightning/Protocol/BOLT1/Internal.hs b/lib/Lightning/Protocol/BOLT1/Internal.hs
@@ -1,56 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-
--- |
--- Module: Lightning.Protocol.BOLT1.Internal
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Internal definitions for BOLT #1.
---
--- This module exports unsafe constructors that bypass
--- validation. Use only in tests or trusted internal code.
-
-module Lightning.Protocol.BOLT1.Internal (
- -- * Unsafe constructors
- unsafeMsgUnknown
- , unsafeEnvelope
- , unsafeChainHash
- , unsafeChannelId
- ) where
-
-import qualified Data.ByteString as BS
-import Data.Word (Word16)
-import Lightning.Protocol.BOLT1.Message
-import Lightning.Protocol.BOLT1.Prim
-import Lightning.Protocol.BOLT1.TLV
-
--- | Construct a 'MsgUnknown' without validation.
---
--- This bypasses the check that prevents wrapping known
--- type codes. For test use only.
-unsafeMsgUnknown :: Word16 -> MsgType
-unsafeMsgUnknown = MsgUnknown
-
--- | Construct an 'Envelope' without validation.
---
--- This bypasses the check that 'envType' matches the
--- message. For test use only.
-unsafeEnvelope
- :: MsgType
- -> BS.ByteString
- -> Maybe TlvStream
- -> Envelope
-unsafeEnvelope = Envelope
-
--- | Construct a 'ChainHash' without length validation.
---
--- For test use only.
-unsafeChainHash :: BS.ByteString -> ChainHash
-unsafeChainHash = ChainHash
-
--- | Construct a 'ChannelId' without length validation.
---
--- For test use only.
-unsafeChannelId :: BS.ByteString -> ChannelId
-unsafeChannelId = ChannelId
diff --git a/lib/Lightning/Protocol/BOLT1/Message.hs b/lib/Lightning/Protocol/BOLT1/Message.hs
@@ -1,6 +1,5 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-- |
-- Module: Lightning.Protocol.BOLT1.Message
@@ -8,194 +7,126 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Message types for BOLT #1.
+-- The messages defined by BOLT #1.
module Lightning.Protocol.BOLT1.Message (
- -- * Message types
- MsgType(..)
- , msgUnknown
- , msgTypeWord
- , parseMsgType
-
- -- * Channel identifiers
- , ChannelId
- , channelId
- , unChannelId
- , allChannels
-
- -- * Setup messages
- , Init(..)
+ Init(..)
, Error(..)
, Warning(..)
-
- -- * Control messages
, Ping(..)
, Pong(..)
-
- -- * Peer storage messages
, PeerStorage(..)
, PeerStorageRetrieval(..)
-
- -- * Message envelope
, Message(..)
- , messageType
- , Envelope(..)
- , envelope
+ , message_type
) where
import Control.DeepSeq (NFData)
import qualified Data.ByteString as BS
import Data.Word (Word16)
import GHC.Generics (Generic)
-import Lightning.Protocol.BOLT1.Prim (ChannelId, channelId,
- unChannelId, allChannels)
+import Lightning.Protocol.BOLT1.Prim
import Lightning.Protocol.BOLT1.TLV
+import qualified Lightning.Protocol.BOLT9 as BOLT9
--- 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
-
--- | Smart constructor for unknown message types.
+-- | The @init@ message (type 16).
--
--- Returns the appropriate known constructor for known
--- type codes (16, 17, 18, 19, 1, 7, 9) and only uses
--- 'MsgUnknown' for truly unknown codes.
-msgUnknown :: Word16 -> MsgType
-msgUnknown = parseMsgType
-{-# INLINE msgUnknown #-}
-
--- Message ADTs ----------------------------------------------------------------
-
--- | The init message (type 16).
+-- The two feature vectors are kept as received. Per BOLT #1, a
+-- receiver treats their union ('BOLT9.union') as the peer's
+-- features.
data Init = Init
- { initGlobalFeatures :: !BS.ByteString
- , initFeatures :: !BS.ByteString
- , initTlvs :: ![InitTlv]
- } deriving stock (Eq, Show, Generic)
+ { init_global_features :: !BOLT9.FeatureVector
+ , init_features :: !BOLT9.FeatureVector
+ , init_networks :: !(Maybe [ChainHash])
+ -- ^ @networks@ (TLV type 1): chains the node is interested in
+ , init_remote_addr :: !(Maybe BS.ByteString)
+ -- ^ @remote_addr@ (TLV type 3): a raw BOLT #7 address descriptor
+ , init_tlvs :: !TlvStream
+ -- ^ unknown odd TLV records
+ } deriving (Eq, Show, Generic)
instance NFData Init
--- | The error message (type 17).
+-- | The @error@ message (type 17).
data Error = Error
- { errorChannelId :: !ChannelId
- , errorData :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { error_channel_id :: !ChannelId
+ , error_data :: !BS.ByteString
+ , error_tlvs :: !TlvStream
+ -- ^ extension TLV records (all unknown odd)
+ } deriving (Eq, Show, Generic)
instance NFData Error
--- | The warning message (type 1).
+-- | The @warning@ message (type 1).
data Warning = Warning
- { warningChannelId :: !ChannelId
- , warningData :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { warning_channel_id :: !ChannelId
+ , warning_data :: !BS.ByteString
+ , warning_tlvs :: !TlvStream
+ -- ^ extension TLV records (all unknown odd)
+ } deriving (Eq, Show, Generic)
instance NFData Warning
--- | The ping message (type 18).
+-- | The @ping@ message (type 18).
data Ping = Ping
- { pingNumPongBytes :: {-# UNPACK #-} !Word16
- , pingIgnored :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { ping_num_pong_bytes :: {-# UNPACK #-} !Word16
+ , ping_ignored :: !BS.ByteString
+ , ping_tlvs :: !TlvStream
+ -- ^ extension TLV records (all unknown odd)
+ } deriving (Eq, Show, Generic)
instance NFData Ping
--- | The pong message (type 19).
+-- | The @pong@ message (type 19).
data Pong = Pong
- { pongIgnored :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { pong_ignored :: !BS.ByteString
+ , pong_tlvs :: !TlvStream
+ -- ^ extension TLV records (all unknown odd)
+ } deriving (Eq, Show, Generic)
instance NFData Pong
--- | The peer_storage message (type 7).
+-- | The @peer_storage@ message (type 7).
data PeerStorage = PeerStorage
- { peerStorageBlob :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { peer_storage_blob :: !BS.ByteString
+ , peer_storage_tlvs :: !TlvStream
+ -- ^ extension TLV records (all unknown odd)
+ } deriving (Eq, Show, Generic)
instance NFData PeerStorage
--- | The peer_storage_retrieval message (type 9).
+-- | The @peer_storage_retrieval@ message (type 9).
data PeerStorageRetrieval = PeerStorageRetrieval
- { peerStorageRetrievalBlob :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { peer_storage_retrieval_blob :: !BS.ByteString
+ , peer_storage_retrieval_tlvs :: !TlvStream
+ -- ^ extension TLV records (all unknown odd)
+ } deriving (Eq, Show, Generic)
instance NFData PeerStorageRetrieval
--- | All BOLT #1 messages.
+-- | A BOLT #1 message.
data Message
- = MsgInitVal !Init
- | MsgErrorVal !Error
- | MsgWarningVal !Warning
- | MsgPingVal !Ping
- | MsgPongVal !Pong
- | MsgPeerStorageVal !PeerStorage
- | MsgPeerStorageRetrievalVal !PeerStorageRetrieval
- deriving stock (Eq, Show, Generic)
+ = MsgInit !Init
+ | MsgError !Error
+ | MsgWarning !Warning
+ | MsgPing !Ping
+ | MsgPong !Pong
+ | MsgPeerStorage !PeerStorage
+ | MsgPeerStorageRetrieval !PeerStorageRetrieval
+ deriving (Eq, Show, Generic)
instance NFData Message
--- | Get the message type for a message.
-messageType :: Message -> MsgType
-messageType (MsgInitVal _) = MsgInit
-messageType (MsgErrorVal _) = MsgError
-messageType (MsgWarningVal _) = MsgWarning
-messageType (MsgPingVal _) = MsgPing
-messageType (MsgPongVal _) = MsgPong
-messageType (MsgPeerStorageVal _) = MsgPeerStorage
-messageType (MsgPeerStorageRetrievalVal _) = MsgPeerStorageRet
-
--- Message envelope ------------------------------------------------------------
-
--- | A complete message envelope with type, payload,
--- and optional extension.
-data Envelope = Envelope
- { envType :: !MsgType
- , envPayload :: !BS.ByteString
- , envExtension :: !(Maybe TlvStream)
- } deriving stock (Eq, Show, Generic)
-
-instance NFData Envelope
-
--- | Construct an 'Envelope' from a 'Message' and optional
--- extension TLV stream. The 'envType' is derived
--- automatically from the 'Message'.
-envelope :: Message -> Maybe TlvStream -> Envelope
-envelope msg mext = Envelope
- { envType = messageType msg
- , envPayload = BS.empty
- , envExtension = mext
- }
-{-# INLINE envelope #-}
+-- | The wire type of a 'Message'.
+--
+-- >>> message_type (MsgPong (Pong "" empty_tlv_stream))
+-- 19
+message_type :: Message -> Word16
+message_type m = case m of
+ MsgInit {} -> 16
+ MsgError {} -> 17
+ MsgWarning {} -> 1
+ MsgPing {} -> 18
+ MsgPong {} -> 19
+ MsgPeerStorage {} -> 7
+ MsgPeerStorageRetrieval {} -> 9
diff --git a/lib/Lightning/Protocol/BOLT1/Prim.hs b/lib/Lightning/Protocol/BOLT1/Prim.hs
@@ -1,8 +1,6 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Module: Lightning.Protocol.BOLT1.Prim
@@ -10,778 +8,797 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Primitive type encoding and decoding for BOLT #1.
+-- Fundamental types and primitive encodings for BOLT #1.
module Lightning.Protocol.BOLT1.Prim (
- -- * Chain hash
- ChainHash(..)
- , chainHash
- , unChainHash
-
- -- * Channel identifier
- , ChannelId(..)
- , channelId
- , unChannelId
- , allChannels
-
- -- * Signatures and keys
- , Signature(..)
+ -- * Fixed-size byte types
+ ChainHash
+ , chain_hash
+ , un_chain_hash
+ , ChannelId
+ , channel_id
+ , un_channel_id
+ , all_channels
+ , Signature
, signature
- , unSignature
- , Point(..)
+ , un_signature
+ , Point
, point
- , unPoint
-
- -- * Payment types
- , PaymentHash(..)
- , paymentHash
- , unPaymentHash
- , PaymentPreimage(..)
- , paymentPreimage
- , unPaymentPreimage
-
- -- * Per-commitment secret
- , PerCommitmentSecret(..)
- , perCommitmentSecret
- , unPerCommitmentSecret
-
- -- * Short channel identifier
+ , un_point
+ , PaymentHash
+ , payment_hash
+ , un_payment_hash
+ , PaymentPreimage
+ , payment_preimage
+ , un_payment_preimage
+ , PerCommitmentSecret
+ , per_commitment_secret
+ , un_per_commitment_secret
+
+ -- * Short channel identifiers
, ShortChannelId(..)
- , shortChannelId
- , scidWord64
- , scidBlockHeight
- , scidTxIndex
- , scidOutputIndex
+ , short_channel_id
+ , scid_block_height
+ , scid_tx_index
+ , scid_output_index
-- * Amounts
- , Satoshi(..)
- , MilliSatoshi(..)
- , satToMsat
- , msatToSat
-
- -- * 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
+ , Satoshi
+ , satoshi
+ , un_satoshi
+ , max_satoshi
+ , MilliSatoshi
+ , milli_satoshi
+ , un_milli_satoshi
+ , max_milli_satoshi
+ , sat_to_msat
+ , msat_to_sat
+ , add_sat
+ , sub_sat
+ , add_msat
+ , sub_msat
+
+ -- * Unsigned integers
+ , encode_u16
+ , encode_u32
+ , encode_u64
+ , decode_u16
+ , decode_u32
+ , decode_u64
+
+ -- * Signed integers
+ , encode_s8
+ , encode_s16
+ , encode_s32
+ , encode_s64
+ , decode_s8
+ , decode_s16
+ , decode_s32
+ , decode_s64
+
+ -- * Truncated unsigned integers
+ , encode_tu16
+ , encode_tu32
+ , encode_tu64
+ , decode_tu16
+ , decode_tu32
+ , decode_tu64
+
+ -- * BigSize
+ , encode_bigsize
+ , decode_bigsize
+ , BigSizeError(..)
+ , decode_bigsize_detailed
+
+ -- * Length-prefixed bytes
+ , encode_u16_prefixed
+ , decode_u16_prefixed
+
+ -- * Fixed-size field codecs
+ , decode_chain_hash
+ , decode_channel_id
+ , decode_signature
+ , decode_point
+ , decode_payment_hash
+ , decode_payment_preimage
+ , decode_per_commitment_secret
+ , encode_short_channel_id
+ , decode_short_channel_id
+ , encode_satoshi
+ , decode_satoshi
+ , encode_milli_satoshi
+ , decode_milli_satoshi
) where
-import Control.DeepSeq (NFData)
-import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))
+import Control.DeepSeq (NFData(..))
+import Data.Bits ((.&.), (.|.), unsafeShiftL, unsafeShiftR, xor)
import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as BSB
-import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Internal as BI
+import qualified Data.ByteString.Unsafe as BU
import Data.Int (Int8, Int16, Int32, Int64)
-import Data.Word (Word16, Word32, Word64)
+import Data.Word (Word8, Word16, Word32, Word64)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (pokeByteOff)
import GHC.Generics (Generic)
--- Chain hash ------------------------------------------------------------------
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+{-# INLINE fi #-}
--- | A chain hash (32-byte hash identifying a blockchain).
+-- constant-time equality on equal-length bytestrings
+ct_eq :: BS.ByteString -> BS.ByteString -> Bool
+ct_eq a b
+ | BS.length a /= BS.length b = False
+ | otherwise = go 0 0
+ where
+ !n = BS.length a
+ go :: Word8 -> Int -> Bool
+ go !acc !i
+ | i == n = acc == 0
+ | otherwise =
+ go (acc .|. (BU.unsafeIndex a i `xor` BU.unsafeIndex b i))
+ (i + 1)
+
+-- take exactly n bytes from the front of the input
+take_n :: Int -> BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
+take_n !n !bs
+ | BS.length bs < n = Nothing
+ | otherwise = Just (BU.unsafeTake n bs, BU.unsafeDrop n bs)
+{-# INLINE take_n #-}
+
+-- fixed-size byte types ------------------------------------------------------
+
+-- | A 32-byte chain hash, identifying the chain a channel or message
+-- belongs to.
newtype ChainHash = ChainHash BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance NFData ChainHash
--- | Construct a chain hash from a 32-byte bytestring.
+-- | Construct a 'ChainHash' from exactly 32 bytes.
--
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-chainHash :: BS.ByteString -> Maybe ChainHash
-chainHash bs
+-- >>> fmap (BS.length . un_chain_hash) (chain_hash (BS.replicate 32 0))
+-- Just 32
+-- >>> chain_hash "too short"
+-- Nothing
+chain_hash :: BS.ByteString -> Maybe ChainHash
+chain_hash bs
| BS.length bs == 32 = Just (ChainHash bs)
- | otherwise = Nothing
-{-# INLINE chainHash #-}
-
--- | Extract the raw bytes from a chain hash.
-unChainHash :: ChainHash -> BS.ByteString
-unChainHash (ChainHash bs) = bs
-{-# INLINE unChainHash #-}
+ | otherwise = Nothing
+{-# INLINE chain_hash #-}
--- Channel identifier ---------------------------------------------------------
+-- | The bytes of a 'ChainHash'.
+un_chain_hash :: ChainHash -> BS.ByteString
+un_chain_hash (ChainHash bs) = bs
+{-# INLINE un_chain_hash #-}
-- | A 32-byte channel identifier.
newtype ChannelId = ChannelId BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance NFData ChannelId
--- | Construct a 'ChannelId' from a 32-byte 'BS.ByteString'.
+-- | Construct a 'ChannelId' from exactly 32 bytes.
--
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-channelId :: BS.ByteString -> Maybe ChannelId
-channelId bs
+-- >>> fmap (BS.length . un_channel_id) (channel_id (BS.replicate 32 1))
+-- Just 32
+channel_id :: BS.ByteString -> Maybe ChannelId
+channel_id bs
| BS.length bs == 32 = Just (ChannelId bs)
| otherwise = Nothing
-{-# INLINE channelId #-}
+{-# INLINE channel_id #-}
--- | Extract the raw bytes from a 'ChannelId'.
-unChannelId :: ChannelId -> BS.ByteString
-unChannelId (ChannelId bs) = bs
-{-# INLINE unChannelId #-}
+-- | The bytes of a 'ChannelId'.
+un_channel_id :: ChannelId -> BS.ByteString
+un_channel_id (ChannelId bs) = bs
+{-# INLINE un_channel_id #-}
--- | The all-zeros channel ID (connection-level errors).
-allChannels :: ChannelId
-allChannels = ChannelId (BS.replicate 32 0x00)
-
--- Signatures and keys --------------------------------------------------------
+-- | The all-zero channel identifier, which refers to all channels
+-- (e.g. in connection-level @error@ and @warning@ messages).
+all_channels :: ChannelId
+all_channels = ChannelId (BS.replicate 32 0x00)
-- | A 64-byte compact ECDSA signature.
newtype Signature = Signature BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance NFData Signature
--- | Construct a 'Signature' from a 64-byte 'BS.ByteString'.
+-- | Construct a 'Signature' from exactly 64 bytes.
--
--- Returns 'Nothing' if the input is not exactly 64 bytes.
+-- >>> signature (BS.replicate 63 0x00)
+-- Nothing
signature :: BS.ByteString -> Maybe Signature
-signature !bs
+signature bs
| BS.length bs == 64 = Just (Signature bs)
| otherwise = Nothing
{-# INLINE signature #-}
--- | Extract the raw bytes from a 'Signature'.
-unSignature :: Signature -> BS.ByteString
-unSignature (Signature bs) = bs
-{-# INLINE unSignature #-}
+-- | The bytes of a 'Signature'.
+un_signature :: Signature -> BS.ByteString
+un_signature (Signature bs) = bs
+{-# INLINE un_signature #-}
--- | A 33-byte compressed secp256k1 public key.
+-- | A 33-byte compressed secp256k1 point.
newtype Point = Point BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance NFData Point
--- | Construct a 'Point' from a 33-byte 'BS.ByteString'.
+-- | Construct a 'Point' from 33 bytes with a compressed-encoding
+-- prefix (0x02 or 0x03). The curve equation is not checked; use
+-- ppad-secp256k1 to parse the point if it must be on the curve.
--
--- Returns 'Nothing' if the input is not exactly 33 bytes, or does not
--- begin with a compressed-encoding prefix (0x02 or 0x03). The curve
--- equation is not checked.
+-- >>> point (BS.cons 0x04 (BS.replicate 32 0x01))
+-- Nothing
point :: BS.ByteString -> Maybe Point
-point !bs
+point bs
| BS.length bs == 33
- , let !h = BS.index bs 0
+ , let !h = BU.unsafeIndex bs 0
, h == 0x02 || h == 0x03 = Just (Point bs)
| otherwise = Nothing
{-# INLINE point #-}
--- | Extract the raw bytes from a 'Point'.
-unPoint :: Point -> BS.ByteString
-unPoint (Point bs) = bs
-{-# INLINE unPoint #-}
-
--- Payment types --------------------------------------------------------------
+-- | The bytes of a 'Point'.
+un_point :: Point -> BS.ByteString
+un_point (Point bs) = bs
+{-# INLINE un_point #-}
-- | A 32-byte SHA256 payment hash.
newtype PaymentHash = PaymentHash BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance NFData PaymentHash
--- | Construct a 'PaymentHash' from a 32-byte 'BS.ByteString'.
---
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-paymentHash :: BS.ByteString -> Maybe PaymentHash
-paymentHash !bs
+-- | Construct a 'PaymentHash' from exactly 32 bytes.
+payment_hash :: BS.ByteString -> Maybe PaymentHash
+payment_hash bs
| BS.length bs == 32 = Just (PaymentHash bs)
| otherwise = Nothing
-{-# INLINE paymentHash #-}
+{-# INLINE payment_hash #-}
--- | Extract the raw bytes from a 'PaymentHash'.
-unPaymentHash :: PaymentHash -> BS.ByteString
-unPaymentHash (PaymentHash bs) = bs
-{-# INLINE unPaymentHash #-}
+-- | The bytes of a 'PaymentHash'.
+un_payment_hash :: PaymentHash -> BS.ByteString
+un_payment_hash (PaymentHash bs) = bs
+{-# INLINE un_payment_hash #-}
-- | A 32-byte payment preimage.
+--
+-- This is secret material: its 'Show' instance is redacted and its
+-- 'Eq' instance runs in constant time.
newtype PaymentPreimage = PaymentPreimage BS.ByteString
- deriving stock (Eq, Ord, Generic)
-instance NFData PaymentPreimage
+instance Eq PaymentPreimage where
+ PaymentPreimage a == PaymentPreimage b = ct_eq a b
instance Show PaymentPreimage where
- show _ = "PaymentPreimage <redacted>"
+ showsPrec d _ = showParen (d > 10) $
+ showString "PaymentPreimage <redacted>"
--- | Construct a 'PaymentPreimage' from a 32-byte 'BS.ByteString'.
---
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-paymentPreimage :: BS.ByteString -> Maybe PaymentPreimage
-paymentPreimage !bs
+instance NFData PaymentPreimage where
+ rnf (PaymentPreimage bs) = rnf bs
+
+-- | Construct a 'PaymentPreimage' from exactly 32 bytes.
+payment_preimage :: BS.ByteString -> Maybe PaymentPreimage
+payment_preimage bs
| BS.length bs == 32 = Just (PaymentPreimage bs)
| otherwise = Nothing
-{-# INLINE paymentPreimage #-}
-
--- | Extract the raw bytes from a 'PaymentPreimage'.
-unPaymentPreimage :: PaymentPreimage -> BS.ByteString
-unPaymentPreimage (PaymentPreimage bs) = bs
-{-# INLINE unPaymentPreimage #-}
+{-# INLINE payment_preimage #-}
--- Per-commitment secret ------------------------------------------------------
+-- | The bytes of a 'PaymentPreimage'.
+un_payment_preimage :: PaymentPreimage -> BS.ByteString
+un_payment_preimage (PaymentPreimage bs) = bs
+{-# INLINE un_payment_preimage #-}
-- | A 32-byte per-commitment secret.
+--
+-- This is secret material: its 'Show' instance is redacted and its
+-- 'Eq' instance runs in constant time.
newtype PerCommitmentSecret = PerCommitmentSecret BS.ByteString
- deriving stock (Eq, Ord, Generic)
-instance NFData PerCommitmentSecret
+instance Eq PerCommitmentSecret where
+ PerCommitmentSecret a == PerCommitmentSecret b = ct_eq a b
instance Show PerCommitmentSecret where
- show _ = "PerCommitmentSecret <redacted>"
+ showsPrec d _ = showParen (d > 10) $
+ showString "PerCommitmentSecret <redacted>"
--- | Construct a 'PerCommitmentSecret' from a 32-byte
--- 'BS.ByteString'.
---
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-perCommitmentSecret :: BS.ByteString -> Maybe PerCommitmentSecret
-perCommitmentSecret !bs
+instance NFData PerCommitmentSecret where
+ rnf (PerCommitmentSecret bs) = rnf bs
+
+-- | Construct a 'PerCommitmentSecret' from exactly 32 bytes.
+per_commitment_secret :: BS.ByteString -> Maybe PerCommitmentSecret
+per_commitment_secret bs
| BS.length bs == 32 = Just (PerCommitmentSecret bs)
| otherwise = Nothing
-{-# INLINE perCommitmentSecret #-}
+{-# INLINE per_commitment_secret #-}
--- | Extract the raw bytes from a 'PerCommitmentSecret'.
-unPerCommitmentSecret :: PerCommitmentSecret -> BS.ByteString
-unPerCommitmentSecret (PerCommitmentSecret bs) = bs
-{-# INLINE unPerCommitmentSecret #-}
+-- | The bytes of a 'PerCommitmentSecret'.
+un_per_commitment_secret :: PerCommitmentSecret -> BS.ByteString
+un_per_commitment_secret (PerCommitmentSecret bs) = bs
+{-# INLINE un_per_commitment_secret #-}
--- Short channel identifier ---------------------------------------------------
+-- short channel identifiers --------------------------------------------------
--- | A short channel identifier (8 bytes packed as 'Word64').
---
--- Encodes block height (3 bytes), transaction index (3 bytes),
--- and output index (2 bytes).
+-- | A short channel identifier: block height (3 bytes), transaction
+-- index (3 bytes) and output index (2 bytes), packed big-endian into
+-- a 'Word64'. Every 'Word64' is a valid packing.
newtype ShortChannelId = ShortChannelId Word64
- deriving stock (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance NFData ShortChannelId
--- | Construct a 'ShortChannelId' from components.
+-- | Construct a 'ShortChannelId' from its components. Fails if the
+-- block height or transaction index exceed 24 bits.
--
--- Returns 'Nothing' if block height or tx index exceed 24 bits.
-shortChannelId
- :: Word32 -- ^ Block height (24 bits max)
- -> Word32 -- ^ Transaction index (24 bits max)
- -> Word16 -- ^ Output index
+-- >>> short_channel_id 539268 845 1
+-- Just (ShortChannelId 592931436542885889)
+short_channel_id
+ :: Word32 -- ^ block height
+ -> Word32 -- ^ transaction index
+ -> Word16 -- ^ output index
-> Maybe ShortChannelId
-shortChannelId !blockHeight !txIndex !outputIndex
- | blockHeight > 0xFFFFFF = Nothing
- | txIndex > 0xFFFFFF = Nothing
- | otherwise = Just $! ShortChannelId w
- where
- !w = (fromIntegral blockHeight `unsafeShiftL` 40)
- .|. (fromIntegral txIndex `unsafeShiftL` 16)
- .|. fromIntegral outputIndex
-{-# INLINE shortChannelId #-}
-
--- | Extract the packed 'Word64' from a 'ShortChannelId'.
-scidWord64 :: ShortChannelId -> Word64
-scidWord64 (ShortChannelId w) = w
-{-# INLINE scidWord64 #-}
-
--- | Extract the block height from a 'ShortChannelId'.
-scidBlockHeight :: ShortChannelId -> Word32
-scidBlockHeight (ShortChannelId !w) =
- fromIntegral $! (w `unsafeShiftR` 40) .&. 0xFFFFFF
-{-# INLINE scidBlockHeight #-}
-
--- | Extract the transaction index from a 'ShortChannelId'.
-scidTxIndex :: ShortChannelId -> Word32
-scidTxIndex (ShortChannelId !w) =
- fromIntegral $! (w `unsafeShiftR` 16) .&. 0xFFFFFF
-{-# INLINE scidTxIndex #-}
-
--- | Extract the output index from a 'ShortChannelId'.
-scidOutputIndex :: ShortChannelId -> Word16
-scidOutputIndex (ShortChannelId !w) =
- fromIntegral $! w .&. 0xFFFF
-{-# INLINE scidOutputIndex #-}
-
--- Amounts --------------------------------------------------------------------
-
--- | Amount in satoshis.
-newtype Satoshi = Satoshi { unSatoshi :: Word64 }
- deriving stock (Eq, Ord, Show, Generic)
- deriving newtype (NFData, Num, Enum, Real, Integral)
-
--- | Amount in millisatoshis.
-newtype MilliSatoshi = MilliSatoshi
- { unMilliSatoshi :: Word64 }
- deriving stock (Eq, Ord, Show, Generic)
- deriving newtype (NFData, Num, Enum, Real, Integral)
-
--- | Convert 'Satoshi' to 'MilliSatoshi'.
-satToMsat :: Satoshi -> MilliSatoshi
-satToMsat (Satoshi !s) = MilliSatoshi $! s * 1000
-{-# INLINE satToMsat #-}
-
--- | Convert 'MilliSatoshi' to 'Satoshi' (rounds down).
-msatToSat :: MilliSatoshi -> Satoshi
-msatToSat (MilliSatoshi !m) = Satoshi $! m `div` 1000
-{-# INLINE msatToSat #-}
-
--- Unsigned integer encoding ---------------------------------------------------
-
--- | Encode a 16-bit unsigned integer (big-endian).
+short_channel_id h t o
+ | h > 0xFFFFFF = Nothing
+ | t > 0xFFFFFF = Nothing
+ | otherwise = Just $! ShortChannelId $!
+ (fi h `unsafeShiftL` 40)
+ .|. (fi t `unsafeShiftL` 16)
+ .|. fi o
+{-# INLINE short_channel_id #-}
+
+-- | The block height of a 'ShortChannelId'.
+scid_block_height :: ShortChannelId -> Word32
+scid_block_height (ShortChannelId w) = fi (w `unsafeShiftR` 40)
+{-# INLINE scid_block_height #-}
+
+-- | The transaction index of a 'ShortChannelId'.
+scid_tx_index :: ShortChannelId -> Word32
+scid_tx_index (ShortChannelId w) = fi ((w `unsafeShiftR` 16) .&. 0xFFFFFF)
+{-# INLINE scid_tx_index #-}
+
+-- | The output index of a 'ShortChannelId'.
+scid_output_index :: ShortChannelId -> Word16
+scid_output_index (ShortChannelId w) = fi (w .&. 0xFFFF)
+{-# INLINE scid_output_index #-}
+
+-- amounts --------------------------------------------------------------------
+
+-- | An amount in satoshis, at most 21 million BTC ('max_satoshi').
+newtype Satoshi = Satoshi Word64
+ deriving (Eq, Ord, Show, Generic)
+
+instance NFData Satoshi
+
+-- | An amount in millisatoshis, at most 21 million BTC
+-- ('max_milli_satoshi').
+newtype MilliSatoshi = MilliSatoshi Word64
+ deriving (Eq, Ord, Show, Generic)
+
+instance NFData MilliSatoshi
+
+-- | 21 million BTC, in satoshis (0x000775f05a074000).
+max_satoshi :: Satoshi
+max_satoshi = Satoshi 0x000775f05a074000
+
+-- | 21 million BTC, in millisatoshis (0x1d24b2dfac520000).
+max_milli_satoshi :: MilliSatoshi
+max_milli_satoshi = MilliSatoshi 0x1d24b2dfac520000
+
+-- | Construct a 'Satoshi' amount, failing above 21 million BTC.
--
--- >>> 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).
+-- >>> satoshi 1000
+-- Just (Satoshi 1000)
+-- >>> satoshi 0xffffffffffffffff
+-- Nothing
+satoshi :: Word64 -> Maybe Satoshi
+satoshi w
+ | w <= 0x000775f05a074000 = Just (Satoshi w)
+ | otherwise = Nothing
+{-# INLINE satoshi #-}
+
+-- | The number of satoshis.
+un_satoshi :: Satoshi -> Word64
+un_satoshi (Satoshi w) = w
+{-# INLINE un_satoshi #-}
+
+-- | Construct a 'MilliSatoshi' amount, failing above 21 million BTC.
+milli_satoshi :: Word64 -> Maybe MilliSatoshi
+milli_satoshi w
+ | w <= 0x1d24b2dfac520000 = Just (MilliSatoshi w)
+ | otherwise = Nothing
+{-# INLINE milli_satoshi #-}
+
+-- | The number of millisatoshis.
+un_milli_satoshi :: MilliSatoshi -> Word64
+un_milli_satoshi (MilliSatoshi w) = w
+{-# INLINE un_milli_satoshi #-}
+
+-- | Convert satoshis to millisatoshis. Total, since the bounds
+-- correspond.
+--
+-- >>> fmap sat_to_msat (satoshi 5)
+-- Just (MilliSatoshi 5000)
+sat_to_msat :: Satoshi -> MilliSatoshi
+sat_to_msat (Satoshi s) = MilliSatoshi (s * 1000)
+{-# INLINE sat_to_msat #-}
+
+-- | Convert millisatoshis to satoshis, rounding down.
+msat_to_sat :: MilliSatoshi -> Satoshi
+msat_to_sat (MilliSatoshi m) = Satoshi (m `quot` 1000)
+{-# INLINE msat_to_sat #-}
+
+-- | Add two amounts, failing above 21 million BTC. (Amounts are
+-- bounded well below 2^63, so the sum can't wrap.)
+add_sat :: Satoshi -> Satoshi -> Maybe Satoshi
+add_sat (Satoshi a) (Satoshi b) = satoshi (a + b)
+{-# INLINE add_sat #-}
+
+-- | Subtract the second amount from the first, failing if the result
+-- would be negative.
+sub_sat :: Satoshi -> Satoshi -> Maybe Satoshi
+sub_sat (Satoshi a) (Satoshi b)
+ | b > a = Nothing
+ | otherwise = Just (Satoshi (a - b))
+{-# INLINE sub_sat #-}
+
+-- | Add two amounts, failing above 21 million BTC.
+add_msat :: MilliSatoshi -> MilliSatoshi -> Maybe MilliSatoshi
+add_msat (MilliSatoshi a) (MilliSatoshi b) = milli_satoshi (a + b)
+{-# INLINE add_msat #-}
+
+-- | Subtract the second amount from the first, failing if the result
+-- would be negative.
+sub_msat :: MilliSatoshi -> MilliSatoshi -> Maybe MilliSatoshi
+sub_msat (MilliSatoshi a) (MilliSatoshi b)
+ | b > a = Nothing
+ | otherwise = Just (MilliSatoshi (a - b))
+{-# INLINE sub_msat #-}
+
+-- unsigned integers ----------------------------------------------------------
+
+poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()
+poke8 = pokeByteOff
+{-# INLINE poke8 #-}
+
+-- | Encode a 'Word16' as 2 big-endian bytes.
--
--- >>> encodeU32 0x01020304
--- "\SOH\STX\ETX\EOT"
-encodeU32 :: Word32 -> BS.ByteString
-encodeU32 = BSL.toStrict . BSB.toLazyByteString . BSB.word32BE
-{-# INLINE encodeU32 #-}
+-- >>> encode_u16 0x0102
+-- "\SOH\STX"
+encode_u16 :: Word16 -> BS.ByteString
+encode_u16 w = BI.unsafeCreate 2 $ \p -> do
+ poke8 p 0 (fi (w `unsafeShiftR` 8))
+ poke8 p 1 (fi w)
+{-# INLINE encode_u16 #-}
+
+-- | Encode a 'Word32' as 4 big-endian bytes.
+encode_u32 :: Word32 -> BS.ByteString
+encode_u32 w = BI.unsafeCreate 4 $ \p -> do
+ poke8 p 0 (fi (w `unsafeShiftR` 24))
+ poke8 p 1 (fi (w `unsafeShiftR` 16))
+ poke8 p 2 (fi (w `unsafeShiftR` 8))
+ poke8 p 3 (fi w)
+{-# INLINE encode_u32 #-}
+
+-- | Encode a 'Word64' as 8 big-endian bytes.
+encode_u64 :: Word64 -> BS.ByteString
+encode_u64 w = BI.unsafeCreate 8 $ \p -> do
+ poke8 p 0 (fi (w `unsafeShiftR` 56))
+ poke8 p 1 (fi (w `unsafeShiftR` 48))
+ poke8 p 2 (fi (w `unsafeShiftR` 40))
+ poke8 p 3 (fi (w `unsafeShiftR` 32))
+ poke8 p 4 (fi (w `unsafeShiftR` 24))
+ poke8 p 5 (fi (w `unsafeShiftR` 16))
+ poke8 p 6 (fi (w `unsafeShiftR` 8))
+ poke8 p 7 (fi w)
+{-# INLINE encode_u64 #-}
+
+-- big-endian word from the first n bytes (n <= 8, length checked)
+be :: Int -> BS.ByteString -> Word64
+be n bs = go 0 0
+ where
+ go !acc !i
+ | i == n = acc
+ | otherwise =
+ go ((acc `unsafeShiftL` 8) .|. fi (BU.unsafeIndex bs i)) (i + 1)
+{-# INLINE be #-}
--- | Encode a 64-bit unsigned integer (big-endian).
+-- | Decode 2 big-endian bytes, returning the remaining input.
--
--- >>> encodeU64 0x0102030405060708
--- "\SOH\STX\ETX\EOT\ENQ\ACK\a\b"
-encodeU64 :: Word64 -> BS.ByteString
-encodeU64 = BSL.toStrict . BSB.toLazyByteString . BSB.word64BE
-{-# INLINE encodeU64 #-}
+-- >>> decode_u16 "\SOH\STXrest"
+-- Just (258,"rest")
+decode_u16 :: BS.ByteString -> Maybe (Word16, BS.ByteString)
+decode_u16 bs
+ | BS.length bs < 2 = Nothing
+ | otherwise = Just (fi (be 2 bs), BU.unsafeDrop 2 bs)
+{-# INLINE decode_u16 #-}
--- Signed integer encoding -----------------------------------------------------
+-- | Decode 4 big-endian bytes, returning the remaining input.
+decode_u32 :: BS.ByteString -> Maybe (Word32, BS.ByteString)
+decode_u32 bs
+ | BS.length bs < 4 = Nothing
+ | otherwise = Just (fi (be 4 bs), BU.unsafeDrop 4 bs)
+{-# INLINE decode_u32 #-}
--- | 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 #-}
+-- | Decode 8 big-endian bytes, returning the remaining input.
+decode_u64 :: BS.ByteString -> Maybe (Word64, BS.ByteString)
+decode_u64 bs
+ | BS.length bs < 8 = Nothing
+ | otherwise = Just (be 8 bs, BU.unsafeDrop 8 bs)
+{-# INLINE decode_u64 #-}
--- Truncated unsigned integer encoding -----------------------------------------
+-- signed integers ------------------------------------------------------------
--- | 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.
+-- | Encode an 'Int8' as 1 byte (two's complement).
--
--- >>> 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).
+-- >>> encode_s8 (-42)
+-- "\214"
+encode_s8 :: Int8 -> BS.ByteString
+encode_s8 = BS.singleton . fi
+{-# INLINE encode_s8 #-}
+
+-- | Encode an 'Int16' as 2 big-endian bytes (two's complement).
+encode_s16 :: Int16 -> BS.ByteString
+encode_s16 = encode_u16 . fi
+{-# INLINE encode_s16 #-}
+
+-- | Encode an 'Int32' as 4 big-endian bytes (two's complement).
+encode_s32 :: Int32 -> BS.ByteString
+encode_s32 = encode_u32 . fi
+{-# INLINE encode_s32 #-}
+
+-- | Encode an 'Int64' as 8 big-endian bytes (two's complement).
+encode_s64 :: Int64 -> BS.ByteString
+encode_s64 = encode_u64 . fi
+{-# INLINE encode_s64 #-}
+
+-- | Decode 1 byte (two's complement), returning the remaining input.
+decode_s8 :: BS.ByteString -> Maybe (Int8, BS.ByteString)
+decode_s8 bs = case BS.uncons bs of
+ Just (h, t) -> Just (fi h, t)
+ Nothing -> Nothing
+{-# INLINE decode_s8 #-}
+
+-- | Decode 2 big-endian bytes (two's complement).
+decode_s16 :: BS.ByteString -> Maybe (Int16, BS.ByteString)
+decode_s16 bs = case decode_u16 bs of
+ Just (w, t) -> Just (fi w, t)
+ Nothing -> Nothing
+{-# INLINE decode_s16 #-}
+
+-- | Decode 4 big-endian bytes (two's complement).
+decode_s32 :: BS.ByteString -> Maybe (Int32, BS.ByteString)
+decode_s32 bs = case decode_u32 bs of
+ Just (w, t) -> Just (fi w, t)
+ Nothing -> Nothing
+{-# INLINE decode_s32 #-}
+
+-- | Decode 8 big-endian bytes (two's complement).
+decode_s64 :: BS.ByteString -> Maybe (Int64, BS.ByteString)
+decode_s64 bs = case decode_u64 bs of
+ Just (w, t) -> Just (fi w, t)
+ Nothing -> Nothing
+{-# INLINE decode_s64 #-}
+
+-- truncated unsigned integers ------------------------------------------------
+
+-- minimal big-endian encoding: no leading zero bytes (zero is empty)
+encode_tu :: Word64 -> BS.ByteString
+encode_tu w = BS.drop (lz 0) (encode_u64 w)
+ where
+ lz :: Int -> Int
+ lz !i
+ | i < 8 && (w `unsafeShiftR` (56 - 8 * i)) .&. 0xff == 0 = lz (i + 1)
+ | otherwise = i
+
+decode_tu :: Int -> BS.ByteString -> Maybe Word64
+decode_tu maxlen bs
+ | n > maxlen = Nothing
+ | n > 0 && BU.unsafeIndex bs 0 == 0 = Nothing
+ | otherwise = Just (be n bs)
+ where
+ !n = BS.length bs
+
+-- | Encode a 'Word16' as a truncated integer (no leading zero bytes).
--
--- >>> 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.
+-- >>> encode_tu16 0
+-- ""
+-- >>> encode_tu16 0x0100
+-- "\SOH\NUL"
+encode_tu16 :: Word16 -> BS.ByteString
+encode_tu16 = encode_tu . fi
+
+-- | Encode a 'Word32' as a truncated integer (no leading zero bytes).
+encode_tu32 :: Word32 -> BS.ByteString
+encode_tu32 = encode_tu . fi
+
+-- | Encode a 'Word64' as a truncated integer (no leading zero bytes).
+encode_tu64 :: Word64 -> BS.ByteString
+encode_tu64 = encode_tu
+
+-- | Decode a truncated 16-bit integer occupying the whole input. Fails
+-- on more than 2 bytes or a non-minimal encoding.
--
--- 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).
+-- >>> decode_tu16 "\SOH\NUL"
+-- Just 256
+-- >>> decode_tu16 "\NUL\SOH"
+-- Nothing
+decode_tu16 :: BS.ByteString -> Maybe Word16
+decode_tu16 = fmap fi . decode_tu 2
+
+-- | Decode a truncated 32-bit integer occupying the whole input. Fails
+-- on more than 4 bytes or a non-minimal encoding.
+decode_tu32 :: BS.ByteString -> Maybe Word32
+decode_tu32 = fmap fi . decode_tu 4
+
+-- | Decode a truncated 64-bit integer occupying the whole input. Fails
+-- on more than 8 bytes or a non-minimal encoding.
+decode_tu64 :: BS.ByteString -> Maybe Word64
+decode_tu64 = decode_tu 8
+
+-- bigsize --------------------------------------------------------------------
+
+-- | Encode a 'Word64' in the minimal BigSize format.
--
--- 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)
+-- >>> encode_bigsize 252
+-- "\252"
+-- >>> encode_bigsize 253
+-- "\253\NUL\253"
+encode_bigsize :: Word64 -> BS.ByteString
+encode_bigsize w
+ | w < 0xfd = BS.singleton (fi w)
+ | w <= 0xffff = BS.cons 0xfd (encode_u16 (fi w))
+ | w <= 0xffffffff = BS.cons 0xfe (encode_u32 (fi w))
+ | otherwise = BS.cons 0xff (encode_u64 w)
+
+-- | Why a BigSize failed to decode.
+data BigSizeError
+ = BigSizeTruncated -- ^ input ended early
+ | BigSizeNonMinimal -- ^ a shorter encoding exists
+ deriving (Eq, Show, Generic)
+
+instance NFData BigSizeError
+
+-- | Decode a BigSize, distinguishing truncation from non-minimal
+-- encodings.
+decode_bigsize_detailed
+ :: BS.ByteString -> Either BigSizeError (Word64, BS.ByteString)
+decode_bigsize_detailed bs = case BS.uncons bs of
+ Nothing -> Left BigSizeTruncated
+ Just (h, t) -> case h of
+ 0xfd -> wide 2 0xfd t
+ 0xfe -> wide 4 0x10000 t
+ 0xff -> wide 8 0x100000000 t
+ _ -> Right (fi h, t)
where
- 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).
+ wide n lo t = case take_n n t of
+ Nothing -> Left BigSizeTruncated
+ Just (v, r)
+ | w < lo -> Left BigSizeNonMinimal
+ | otherwise -> Right (w, r)
+ where
+ !w = be n v
+
+-- | Decode a minimally-encoded BigSize, returning the remaining input.
--
--- 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).
+-- >>> decode_bigsize "\253\NUL\253rest"
+-- Just (253,"rest")
+-- >>> decode_bigsize "\253\NUL\252"
+-- Nothing
+decode_bigsize :: BS.ByteString -> Maybe (Word64, BS.ByteString)
+decode_bigsize bs = case decode_bigsize_detailed bs of
+ Right r -> Just r
+ Left _ -> Nothing
+
+-- length-prefixed bytes ------------------------------------------------------
+
+-- | Prefix bytes with their length as a u16. Fails if the input
+-- exceeds 65535 bytes.
--
--- 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).
+-- >>> encode_u16_prefixed "abc"
+-- Just "\NUL\ETXabc"
+encode_u16_prefixed :: BS.ByteString -> Maybe BS.ByteString
+encode_u16_prefixed bs
+ | BS.length bs > 0xffff = Nothing
+ | otherwise = Just (encode_u16 (fi (BS.length bs)) <> bs)
+
+-- | Decode u16-length-prefixed bytes, returning the remaining input.
--
--- 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)
+-- >>> decode_u16_prefixed "\NUL\ETXabcrest"
+-- Just ("abc","rest")
+decode_u16_prefixed
+ :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
+decode_u16_prefixed bs = do
+ (n, rest) <- decode_u16 bs
+ take_n (fi n) rest
+
+-- fixed-size field codecs ----------------------------------------------------
+
+-- | Decode a 32-byte 'ChainHash', returning the remaining input.
+decode_chain_hash :: BS.ByteString -> Maybe (ChainHash, BS.ByteString)
+decode_chain_hash bs = do
+ (h, r) <- take_n 32 bs
+ pure (ChainHash h, r)
+
+-- | Decode a 32-byte 'ChannelId', returning the remaining input.
+decode_channel_id :: BS.ByteString -> Maybe (ChannelId, BS.ByteString)
+decode_channel_id bs = do
+ (h, r) <- take_n 32 bs
+ pure (ChannelId h, r)
+
+-- | Decode a 64-byte 'Signature', returning the remaining input.
+decode_signature :: BS.ByteString -> Maybe (Signature, BS.ByteString)
+decode_signature bs = do
+ (h, r) <- take_n 64 bs
+ pure (Signature h, r)
+
+-- | Decode a 33-byte 'Point', returning the remaining input. Fails if
+-- the prefix byte is not 0x02 or 0x03.
+decode_point :: BS.ByteString -> Maybe (Point, BS.ByteString)
+decode_point bs = do
+ (h, r) <- take_n 33 bs
+ p <- point h
+ pure (p, r)
+
+-- | Decode a 32-byte 'PaymentHash', returning the remaining input.
+decode_payment_hash :: BS.ByteString -> Maybe (PaymentHash, BS.ByteString)
+decode_payment_hash bs = do
+ (h, r) <- take_n 32 bs
+ pure (PaymentHash h, r)
+
+-- | Decode a 32-byte 'PaymentPreimage', returning the remaining input.
+decode_payment_preimage
+ :: BS.ByteString -> Maybe (PaymentPreimage, BS.ByteString)
+decode_payment_preimage bs = do
+ (h, r) <- take_n 32 bs
+ pure (PaymentPreimage h, r)
+
+-- | Decode a 32-byte 'PerCommitmentSecret', returning the remaining
+-- input.
+decode_per_commitment_secret
+ :: BS.ByteString -> Maybe (PerCommitmentSecret, BS.ByteString)
+decode_per_commitment_secret bs = do
+ (h, r) <- take_n 32 bs
+ pure (PerCommitmentSecret h, r)
+
+-- | Encode a 'ShortChannelId' as 8 big-endian bytes.
+encode_short_channel_id :: ShortChannelId -> BS.ByteString
+encode_short_channel_id (ShortChannelId w) = encode_u64 w
+{-# INLINE encode_short_channel_id #-}
+
+-- | Decode an 8-byte 'ShortChannelId', returning the remaining input.
+decode_short_channel_id
+ :: BS.ByteString -> Maybe (ShortChannelId, BS.ByteString)
+decode_short_channel_id bs = do
+ (w, r) <- decode_u64 bs
+ pure (ShortChannelId w, r)
+{-# INLINE decode_short_channel_id #-}
+
+-- | Encode a 'Satoshi' amount as a u64.
+encode_satoshi :: Satoshi -> BS.ByteString
+encode_satoshi (Satoshi w) = encode_u64 w
+{-# INLINE encode_satoshi #-}
+
+-- | Decode a u64 'Satoshi' amount, returning the remaining input. Fails
+-- above 21 million BTC.
+decode_satoshi :: BS.ByteString -> Maybe (Satoshi, BS.ByteString)
+decode_satoshi bs = do
+ (w, r) <- decode_u64 bs
+ s <- satoshi w
+ pure (s, r)
+{-# INLINE decode_satoshi #-}
+
+-- | Encode a 'MilliSatoshi' amount as a u64.
+encode_milli_satoshi :: MilliSatoshi -> BS.ByteString
+encode_milli_satoshi (MilliSatoshi w) = encode_u64 w
+{-# INLINE encode_milli_satoshi #-}
+
+-- | Decode a u64 'MilliSatoshi' amount, returning the remaining input.
+-- Fails above 21 million BTC.
+decode_milli_satoshi
+ :: BS.ByteString -> Maybe (MilliSatoshi, BS.ByteString)
+decode_milli_satoshi bs = do
+ (w, r) <- decode_u64 bs
+ m <- milli_satoshi w
+ pure (m, r)
+{-# INLINE decode_milli_satoshi #-}
diff --git a/lib/Lightning/Protocol/BOLT1/TLV.hs b/lib/Lightning/Protocol/BOLT1/TLV.hs
@@ -1,7 +1,6 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-- |
-- Module: Lightning.Protocol.BOLT1.TLV
@@ -9,236 +8,149 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- TLV (Type-Length-Value) format for BOLT #1.
+-- The TLV (type-length-value) format of BOLT #1.
module Lightning.Protocol.BOLT1.TLV (
- -- * TLV types
TlvRecord(..)
, TlvStream
- , unTlvStream
- , tlvStream
- , unsafeTlvStream
+ , tlv_stream
+ , un_tlv_stream
+ , empty_tlv_stream
+ , lookup_tlv
+ , filter_tlv_stream
, TlvError(..)
-
- -- * TLV encoding
- , encodeTlvRecord
- , encodeTlvStream
-
- -- * TLV decoding
- , decodeTlvStream
- , decodeTlvStreamWith
- , decodeTlvStreamRaw
-
- -- * Init TLV types
- , InitTlv(..)
- , parseInitTlvs
- , encodeInitTlvs
-
- -- * Re-exports
- , ChainHash
- , chainHash
- , unChainHash
+ , encode_tlv_stream
+ , decode_tlv_stream
) where
import Control.DeepSeq (NFData)
-import Control.Monad (when)
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BU
+import qualified Data.List as L
import Data.Word (Word64)
import GHC.Generics (Generic)
import Lightning.Protocol.BOLT1.Prim
--- TLV types -------------------------------------------------------------------
-
-- | A single TLV record.
data TlvRecord = TlvRecord
- { tlvType :: {-# UNPACK #-} !Word64
- , tlvValue :: !BS.ByteString
- } deriving stock (Eq, Show, Generic)
+ { tlv_type :: {-# UNPACK #-} !Word64
+ , tlv_value :: !BS.ByteString
+ } deriving (Eq, Show, Generic)
instance NFData TlvRecord
--- | A TLV stream (series of TLV records).
-newtype TlvStream = TlvStream { unTlvStream :: [TlvRecord] }
- deriving stock (Eq, Show, Generic)
+-- | A TLV stream: records in strictly increasing type order.
+newtype TlvStream = TlvStream [TlvRecord]
+ deriving (Eq, Show, Generic)
instance NFData TlvStream
--- | Smart constructor for 'TlvStream' that validates records are
--- strictly increasing by type.
+-- | Construct a 'TlvStream' from records in any order. Fails if two
+-- records share a type.
--
--- Returns 'Nothing' if types are not strictly increasing.
-tlvStream :: [TlvRecord] -> Maybe TlvStream
-tlvStream recs
- | isStrictlyIncreasing (map tlvType recs) = Just (TlvStream recs)
- | otherwise = Nothing
+-- >>> let Just s = tlv_stream [TlvRecord 3 "b", TlvRecord 1 "a"]
+-- >>> map tlv_type (un_tlv_stream s)
+-- [1,3]
+-- >>> tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"]
+-- Nothing
+tlv_stream :: [TlvRecord] -> Maybe TlvStream
+tlv_stream rs
+ | increasing sorted = Just (TlvStream sorted)
+ | otherwise = Nothing
where
- isStrictlyIncreasing :: [Word64] -> Bool
- isStrictlyIncreasing [] = True
- isStrictlyIncreasing [_] = True
- isStrictlyIncreasing (x:y:rest) = x < y && isStrictlyIncreasing (y:rest)
+ sorted = L.sortOn tlv_type rs
--- | Unsafe constructor for 'TlvStream' that skips validation.
---
--- Use only when ordering is already guaranteed (e.g., in decode functions).
-unsafeTlvStream :: [TlvRecord] -> TlvStream
-unsafeTlvStream = TlvStream
+increasing :: [TlvRecord] -> Bool
+increasing (a:rest@(b:_)) = tlv_type a < tlv_type b && increasing rest
+increasing _ = True
--- | TLV decoding errors.
-data TlvError
- = TlvNonMinimalEncoding
- | TlvNotStrictlyIncreasing
- | TlvLengthExceedsBounds
- | TlvUnknownEvenType !Word64
- | TlvInvalidKnownType !Word64
- deriving stock (Eq, Show, Generic)
+-- | The records of a 'TlvStream', in increasing type order.
+un_tlv_stream :: TlvStream -> [TlvRecord]
+un_tlv_stream (TlvStream rs) = rs
+{-# INLINE un_tlv_stream #-}
-instance NFData TlvError
+-- | The empty 'TlvStream'.
+empty_tlv_stream :: TlvStream
+empty_tlv_stream = TlvStream []
--- TLV encoding ----------------------------------------------------------------
+-- | The value of the record with the given type, if present.
+--
+-- >>> lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"]
+-- Just "b"
+lookup_tlv :: Word64 -> TlvStream -> Maybe BS.ByteString
+lookup_tlv t (TlvStream rs) = go rs
+ where
+ go [] = Nothing
+ go (TlvRecord u v : more)
+ | u == t = Just v
+ | u > t = Nothing
+ | otherwise = go more
--- | Encode a TLV record.
-encodeTlvRecord :: TlvRecord -> BS.ByteString
-encodeTlvRecord (TlvRecord typ val) = mconcat
- [ encodeBigSize typ
- , encodeBigSize (fromIntegral (BS.length val))
- , val
- ]
+-- | Keep the records whose types satisfy the predicate.
+--
+-- >>> let Just s = tlv_stream [TlvRecord 1 "", TlvRecord 2 ""]
+-- >>> map tlv_type (un_tlv_stream (filter_tlv_stream odd s))
+-- [1]
+filter_tlv_stream :: (Word64 -> Bool) -> TlvStream -> TlvStream
+filter_tlv_stream p (TlvStream rs) = TlvStream (filter (p . tlv_type) rs)
--- | Encode a TLV stream.
-encodeTlvStream :: TlvStream -> BS.ByteString
-encodeTlvStream (TlvStream recs) = mconcat (map encodeTlvRecord recs)
+-- | Why a TLV stream failed to decode.
+data TlvError
+ = TlvTruncated -- ^ a type, length or value was cut off
+ | TlvNonMinimalBigSize -- ^ a type or length wasn't minimal
+ | TlvNotStrictlyIncreasing -- ^ types out of order or repeated
+ | TlvUnknownEvenType !Word64 -- ^ an even type the context doesn't know
+ deriving (Eq, Show, Generic)
--- TLV decoding ----------------------------------------------------------------
+instance NFData TlvError
--- | Decode a TLV stream without any known-type validation.
---
--- This decoder only enforces structural validity:
--- - Types must be strictly increasing
--- - Lengths must not exceed bounds
+-- | Encode a 'TlvStream'.
--
--- All records are returned regardless of type. Note: this does NOT
--- enforce the BOLT #1 unknown-even-type rule. Use 'decodeTlvStreamWith'
--- with an appropriate predicate for spec-compliant parsing.
-decodeTlvStreamRaw :: BS.ByteString -> Either TlvError TlvStream
-decodeTlvStreamRaw = go Nothing []
+-- >>> fmap encode_tlv_stream (tlv_stream [TlvRecord 1 "a"])
+-- Just "\SOH\SOHa"
+encode_tlv_stream :: TlvStream -> BS.ByteString
+encode_tlv_stream (TlvStream rs) = mconcat (concatMap enc rs)
where
- go :: Maybe Word64 -> [TlvRecord] -> BS.ByteString
- -> Either TlvError TlvStream
- go !_ !acc !bs
- | BS.null bs = Right (unsafeTlvStream (reverse acc))
- go !mPrevType !acc !bs = do
- (typ, rest1) <- maybe (Left TlvNonMinimalEncoding) Right
- (decodeBigSize bs)
- -- Strictly increasing check
- case mPrevType of
- Just prevType -> when (typ <= prevType) $
- Left TlvNotStrictlyIncreasing
- Nothing -> pure ()
- (len, rest2) <- maybe (Left TlvNonMinimalEncoding) Right
- (decodeBigSize rest1)
- -- Length bounds check (in Word64, so huge lengths can't wrap)
- when (len > fromIntegral (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.
+ enc (TlvRecord t v) =
+ [encode_bigsize t, encode_bigsize (fromIntegral (BS.length v)), v]
+
+-- | Decode a TLV stream occupying the whole input, given a predicate
+-- identifying the types known in the stream's context.
--
--- Per BOLT #1:
--- - Types must be strictly increasing
--- - Unknown even types cause failure
--- - Unknown odd types are skipped
+-- Per BOLT #1, decoding fails on truncation, non-minimal BigSize
+-- encodings, types that are not strictly increasing, and unknown
+-- even types. Every record is kept, including unknown odd ones, so
+-- re-encoding reproduces the input.
--
--- The predicate determines which types are "known" for the context.
-decodeTlvStreamWith
- :: (Word64 -> Bool) -- ^ Predicate: is this type known?
+-- >>> let Right s = decode_tlv_stream (== 1) "\SOH\SOHa\ETX\NUL"
+-- >>> map tlv_type (un_tlv_stream s)
+-- [1,3]
+-- >>> decode_tlv_stream (== 1) "\STX\NUL"
+-- Left (TlvUnknownEvenType 2)
+decode_tlv_stream
+ :: (Word64 -> Bool) -- ^ is this type known?
-> BS.ByteString
-> Either TlvError TlvStream
-decodeTlvStreamWith isKnown = go Nothing []
- where
- go :: Maybe Word64 -> [TlvRecord] -> BS.ByteString
- -> Either TlvError TlvStream
- go !_ !acc !bs
- | BS.null bs = Right (unsafeTlvStream (reverse acc))
- go !mPrevType !acc !bs = do
- (typ, rest1) <- maybe (Left TlvNonMinimalEncoding) Right
- (decodeBigSize bs)
- -- Strictly increasing check
- case mPrevType of
- Just prevType -> when (typ <= prevType) $
- Left TlvNotStrictlyIncreasing
- Nothing -> pure ()
- (len, rest2) <- maybe (Left TlvNonMinimalEncoding) Right
- (decodeBigSize rest1)
- -- Length bounds check (in Word64, so huge lengths can't wrap)
- when (len > fromIntegral (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
+decode_tlv_stream known = go Nothing []
where
- toRecord (InitNetworks chains) =
- TlvRecord 1 (mconcat (map unChainHash chains))
- toRecord (InitRemoteAddr addr) =
- TlvRecord 3 addr
+ go !_ !acc !bs | BS.null bs = Right (TlvStream (reverse acc))
+ go !prev !acc !bs = do
+ (t, r0) <- bigsize bs
+ case prev of
+ Just p | t <= p -> Left TlvNotStrictlyIncreasing
+ _ -> pure ()
+ (l, r1) <- bigsize r0
+ if l > fromIntegral (BS.length r1)
+ then Left TlvTruncated
+ else do
+ let !n = fromIntegral l
+ !v = BU.unsafeTake n r1
+ !r2 = BU.unsafeDrop n r1
+ if not (known t) && even t
+ then Left (TlvUnknownEvenType t)
+ else go (Just t) (TlvRecord t v : acc) r2
+
+ bigsize b = case decode_bigsize_detailed b of
+ Right r -> Right r
+ Left BigSizeTruncated -> Left TlvTruncated
+ Left BigSizeNonMinimal -> Left TlvNonMinimalBigSize
diff --git a/ppad-bolt1.cabal b/ppad-bolt1.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ppad-bolt1
-version: 0.0.1
+version: 0.1.0
synopsis: Base protocol per BOLT #1
license: MIT
license-file: LICENSE
@@ -8,7 +8,7 @@ author: Jared Tobin
maintainer: jared@ppad.tech
category: Cryptography
build-type: Simple
-tested-with: GHC == 9.10.3
+tested-with: GHC == { 9.10.3 }
extra-doc-files: CHANGELOG
description:
Base protocol, per
@@ -25,8 +25,8 @@ library
-Wall
exposed-modules:
Lightning.Protocol.BOLT1
+ other-modules:
Lightning.Protocol.BOLT1.Codec
- Lightning.Protocol.BOLT1.Internal
Lightning.Protocol.BOLT1.Message
Lightning.Protocol.BOLT1.Prim
Lightning.Protocol.BOLT1.TLV
@@ -34,6 +34,7 @@ library
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
, deepseq >= 1.4 && < 1.6
+ , ppad-bolt9 >= 0.1 && < 0.2
test-suite bolt1-tests
type: exitcode-stdio-1.0
@@ -42,13 +43,14 @@ test-suite bolt1-tests
main-is: Main.hs
ghc-options:
- -rtsopts -Wall -O2
+ -rtsopts -Wall
build-depends:
base
, bytestring
, ppad-base16
, ppad-bolt1
+ , ppad-bolt9
, tasty
, tasty-hunit
, tasty-quickcheck
@@ -67,8 +69,8 @@ benchmark bolt1-bench
base
, bytestring
, criterion
- , deepseq
, ppad-bolt1
+ , ppad-bolt9
benchmark bolt1-weigh
type: exitcode-stdio-1.0
@@ -83,6 +85,6 @@ benchmark bolt1-weigh
build-depends:
base
, bytestring
- , deepseq
, ppad-bolt1
+ , ppad-bolt9
, weigh
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,751 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Main where
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Base16 as B16
-import Data.Word (Word64)
-import Lightning.Protocol.BOLT1
-import Lightning.Protocol.BOLT1.Internal
- (unsafeChannelId, unsafeChainHash, unsafeMsgUnknown)
-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
- , testCase "point accepts 0x02 prefix" $
- fmap unPoint (point (BS.cons 0x02 (BS.replicate 32 0x01)))
- @?= Just (BS.cons 0x02 (BS.replicate 32 0x01))
- , testCase "point accepts 0x03 prefix" $
- fmap unPoint (point (BS.cons 0x03 (BS.replicate 32 0x01)))
- @?= Just (BS.cons 0x03 (BS.replicate 32 0x01))
- , testCase "point rejects 0x04 prefix (Appendix B)" $
- point (unhex ("043da092f6980e58d2c037173180e9a465476026ee50f9"
- <> "6695963e8efe436f54eb"))
- @?= Nothing
- , testCase "point rejects wrong length" $
- point (BS.cons 0x02 (BS.replicate 31 0x01)) @?= 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 "length 2^64-1 rejected (raw)" $
- decodeTlvStreamRaw (unhex "01ffffffffffffffffff")
- @?= Left TlvLengthExceedsBounds
- , testCase "length 2^63 rejected (raw)" $
- decodeTlvStreamRaw (unhex "01ff800000000000000067")
- @?= Left TlvLengthExceedsBounds
- , testCase "length 2^64-1 rejected (with predicate)" $
- decodeTlvStreamWith (const True) (unhex "01ffffffffffffffffff")
- @?= Left TlvLengthExceedsBounds
- , testCase "huge length not reparsed as later records" $
- decodeTlvStreamRaw (unhex "01ffffffffffffffffff6701aa")
- @?= Left TlvLengthExceedsBounds
- , 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 (unsafeMsgUnknown 100) "payload" of
- Left (DecodeUnknownEvenType 100) -> pure ()
- other -> assertFailure $ "expected unknown even: " ++ show other
- , testCase "decodeMessage unknown odd type" $ do
- case decodeMessage (unsafeMsgUnknown 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!
- env = encodeU16 18 <> pingPayload <> extTlv -- type 18 = ping
- case decodeEnvelope env 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
- ]
- env = encodeU16 18 <> pingPayload <> badTlv
- case decodeEnvelope env 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
- ]
- env = encodeU16 18 <> pingPayload <> extTlv
- case decodeEnvelope env 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)
- 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" $ \bs ->
- let msg = MsgPingVal (Ping 42 "")
- extData = BS.pack (take 100 bs)
- ext = unsafeTlvStream
- [TlvRecord 101 extData]
- in case encodeEnvelope msg (Just ext) of
- Left _ -> False
- Right encoded -> case decodeEnvelope encoded of
- Right (Just decoded, Just stream) ->
- null (unTlvStream stream)
- && decoded == msg
- _ -> False
- , testProperty "MinSigned roundtrip" $ \v ->
- let encoded = encodeMinSigned v
- len = BS.length encoded
- in case decodeMinSigned len encoded of
- Just (decoded, rest) ->
- decoded == v && BS.null rest
- Nothing -> False
- , testProperty "ShortChannelId component roundtrip" $
- forAll (choose (0, 0xFFFFFF)) $ \bh ->
- forAll (choose (0, 0xFFFFFF)) $ \ti ->
- forAll arbitrary $ \oi ->
- case shortChannelId bh ti oi of
- Nothing -> False
- Just scid ->
- scidBlockHeight scid == bh
- && scidTxIndex scid == ti
- && scidOutputIndex scid == oi
- , testProperty "TLV stream enforces strict ordering" $
- forAll (listOf (choose (0, 1000))) $ \types ->
- case tlvStream (map (\t -> TlvRecord t "") types) of
- Just stream ->
- isStrictlyIncreasing
- (map tlvType (unTlvStream stream))
- Nothing ->
- not (isStrictlyIncreasing types)
- , testProperty "satToMsat/msatToSat roundtrip" $
- forAll (choose (0, maxSafe)) $ \w ->
- let s = Satoshi w
- in msatToSat (satToMsat s) == s
- ]
-
--- | Check that a list is strictly increasing.
-isStrictlyIncreasing :: Ord a => [a] -> Bool
-isStrictlyIncreasing [] = True
-isStrictlyIncreasing [_] = True
-isStrictlyIncreasing (x:y:rest) =
- x < y && isStrictlyIncreasing (y : rest)
-
--- | Maximum Satoshi value that won't overflow Word64 when
--- multiplied by 1000 in satToMsat.
-maxSafe :: Word64
-maxSafe = maxBound `div` 1000
-
--- Helpers ---------------------------------------------------------------------
-
--- | 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
