commit b4b4b507bf0be00435a15c448ef2366ed0c22581
parent f2dfffdce6dd1d0fb3135cf967ee23a466f26fac
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 13:39:00 +0400
Merge impl/modernize: 0.1.0 API
A rewrite of the library for its 0.1.0 release.
- One public module, Lightning.Protocol.BOLT1, with snake_case names.
- Abstract fundamental types behind validating smart constructors;
points must carry a compressed prefix; secret types have redacted
Show and constant-time Eq.
- Satoshi and MilliSatoshi are bounded at 21M BTC per BOLT #1 and use
checked arithmetic.
- A single TLV decoder, parameterised by the known types, which
rejects unknown even types and keeps everything else, so decoded
messages re-encode to their wire bytes. Every message keeps its
extension records; init has typed networks/remote_addr fields and
ppad-bolt9 feature vectors.
- Fast fixed-width encoders; fixed-size field and u16-prefixed byte
codecs for the downstream BOLT libraries.
- Tests cover every BOLT #1 appendix vector; benches rewritten; the
spec copy is pinned to lightning/bolts@1aadb719; README and
CHANGELOG rewritten.
Diffstat:
18 files changed, 2786 insertions(+), 3583 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -6,10 +6,11 @@ Specification: https://github.com/lightning/bolts/blob/master/01-messaging.md
## Project Structure
-- `lib/` - library source (Lightning.Protocol.BOLT1)
+- `lib/` - library source (public API: Lightning.Protocol.BOLT1;
+ submodules are internal)
- `test/` - tests (tasty + tasty-hunit)
- `bench/` - benchmarks (criterion for timing, weigh for allocations)
-- `etc/` - reference materials (BOLT spec)
+- `etc/` - reference materials (BOLT spec, pinned upstream commit)
- `flake.nix` - nix flake for dependency and build management
- `ppad-bolt1.cabal` - cabal package definition
- `CLAUDE.md` / `AGENTS.md` - keep these in sync
@@ -135,5 +136,4 @@ When planning work:
The flake.nix follows ppad conventions:
- Uses ppad-nixpkgs as base
- Follows references to avoid duplication
-- Supports LLVM backend via cabal flag
- Provides devShell with ghc, cabal, cc, llvm
diff --git a/CHANGELOG b/CHANGELOG
@@ -1,4 +1,34 @@
# Changelog
-- 0.0.1 (2025-01-25)
+- 0.1.0 (UNRELEASED)
+ * A substantial rewrite, with breaking changes throughout:
+
+ * The API is exported from Lightning.Protocol.BOLT1 alone, and uses
+ snake_case names (e.g. encode_message, channel_id, un_channel_id).
+
+ * Fundamental types are abstract, constructed only via validating
+ smart constructors. Points must carry a compressed-encoding
+ prefix. Satoshi and MilliSatoshi are bounded at 21M BTC and
+ provide checked arithmetic instead of Num.
+
+ * Every message decoder consumes its whole payload and preserves
+ unknown odd TLV records, so encoding a decoded message reproduces
+ its wire bytes. Init has typed networks and remote_addr fields,
+ and uses ppad-bolt9 feature vectors.
+
+ * A single TLV decoder takes the set of known types, rejects
+ unknown even types, and keeps unknown odd ones.
+
+ * Removed the Envelope type, the minimal signed integer codecs and
+ the Internal module; added ping_response and fixed-size field
+ codecs.
+
+ * Fixes TLV decoding, which accepted lengths of 2^63 or more as
+ empty values.
+
+ * Fixed-width encoders no longer allocate kilobytes per call.
+
+ * Tests now cover every BOLT #1 appendix vector.
+
+- 0.0.1 (2026-04-18)
* Initial release.
diff --git a/CLAUDE.md b/CLAUDE.md
@@ -6,10 +6,11 @@ Specification: https://github.com/lightning/bolts/blob/master/01-messaging.md
## Project Structure
-- `lib/` - library source (Lightning.Protocol.BOLT1)
+- `lib/` - library source (public API: Lightning.Protocol.BOLT1;
+ submodules are internal)
- `test/` - tests (tasty + tasty-hunit)
- `bench/` - benchmarks (criterion for timing, weigh for allocations)
-- `etc/` - reference materials (BOLT spec)
+- `etc/` - reference materials (BOLT spec, pinned upstream commit)
- `flake.nix` - nix flake for dependency and build management
- `ppad-bolt1.cabal` - cabal package definition
- `CLAUDE.md` / `AGENTS.md` - keep these in sync
@@ -135,5 +136,4 @@ When planning work:
The flake.nix follows ppad conventions:
- Uses ppad-nixpkgs as base
- Follows references to avoid duplication
-- Supports LLVM backend via cabal flag
- Provides devShell with ghc, cabal, cc, llvm
diff --git a/README.md b/README.md
@@ -4,8 +4,14 @@
[](https://docs.ppad.tech/bolt1)
-A Haskell implementation of the Lightning Network base protocol (BOLT
-#1), providing message and TLV encoding/decoding with validation.
+A pure Haskell implementation of the Lightning Network base protocol,
+[BOLT #1][bolt1]: the 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 (channel ids, points, signatures, short channel
+ids, bounded amounts, etc.) and the TLV machinery are shared by the
+other ppad BOLT libraries.
## Usage
@@ -13,20 +19,30 @@ A sample GHCi session:
```
> :set -XOverloadedStrings
- >
- > import qualified Data.ByteString as BS
> import Lightning.Protocol.BOLT1
>
- > let msg = MsgPingVal (Ping 10 "")
- > let ext = TlvStream [TlvRecord 101 "ext"]
+ > -- a ping carrying an (odd, hence ignorable) extension record
+ > let Just ext = tlv_stream [TlvRecord 101 "ext"]
+ > let Right wire = encode_message (MsgPing (Ping 4 "" ext))
+ > wire
+ "\NUL\DC2\NUL\EOT\NUL\NULe\ETXext"
>
- > Right enc = encodeEnvelope msg (Just ext)
- > enc
- "\NUL\DC2\NUL\n\NUL\NULe\ETXext"
+ > -- unknown odd records are preserved, so re-encoding is exact
+ > decode_message wire
+ Right (MsgPing (Ping {ping_num_pong_bytes = 4, ping_ignored = "",
+ ping_tlvs = TlvStream [TlvRecord {tlv_type = 101, tlv_value = "ext"}]}))
>
- > decodeEnvelope enc
- Right (Just (MsgPingVal (Ping {pingNumPongBytes = 10, pingIgnored = ""})),
- Just (TlvStream [TlvRecord {tlvType = 101, tlvValue = "ext"}]))
+ > -- unknown even message types must close the connection
+ > decode_message "\NUL\DC4\NUL"
+ Left (DecodeUnknownEvenType 20)
+ >
+ > -- amounts are bounded at 21M BTC and use checked arithmetic
+ > let Just a = satoshi 1000
+ > let Just b = satoshi 2500
+ > sub_sat a b
+ Nothing
+ > fmap sat_to_msat (add_sat a b)
+ Just (MilliSatoshi 3500000)
```
## Documentation
@@ -34,10 +50,18 @@ A sample GHCi session:
Haddocks (API documentation, etc.) are hosted at
[docs.ppad.tech/bolt1](https://docs.ppad.tech/bolt1).
+## Specification
+
+This library implements BOLT #1 as of lightning/bolts commit
+[1aadb719][spec] (2026-09-21); a copy lives in `etc/`.
+
+Feature vectors (in `init`) are represented with [ppad-bolt9][bolt9].
+The `remote_addr` address descriptor is kept as raw bytes.
+
## Performance
-The aim is best-in-class performance for message encoding/decoding.
-Benchmarks are available under `bench/` and can be run with:
+The aim is best-in-class performance for pure Haskell code. Run the
+benchmarks with:
```
$ cabal bench
@@ -45,8 +69,10 @@ $ cabal bench
## Security
-This is a pre-release library that, at present, claims no security
-properties whatsoever.
+This library has received no security audit. It validates every field
+the specification constrains when decoding, rejects unknown even message
+and TLV types, and keeps secret types (preimages, per-commitment
+secrets) out of `Show` output, comparing them in constant time.
## Development
@@ -65,10 +91,8 @@ $ cabal repl ppad-bolt1
to get a REPL for the main library.
-## Attribution
-
-This library implements the Lightning Network BOLT #1 specification:
-https://github.com/lightning/bolts/blob/master/01-messaging.md
-
+[bolt1]: https://github.com/lightning/bolts/blob/master/01-messaging.md
+[bolt9]: https://git.ppad.tech/bolt9
+[spec]: https://github.com/lightning/bolts/tree/1aadb719b4007c4cea0ba6e36b08c4fb53788dee
[nixos]: https://nixos.org/
[flake]: https://nixos.org/manual/nix/unstable/command-ref/new-cli/nix3-flake.html
diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs
@@ -1,433 +1,50 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
--- |
--- Module: Fixtures
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Test fixtures for BOLT #1 benchmarks.
-
module Fixtures where
import qualified Data.ByteString as BS
-import Data.Maybe (fromJust)
+import Data.Maybe (fromMaybe)
import Lightning.Protocol.BOLT1
+import qualified Lightning.Protocol.BOLT9 as BOLT9
--- 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 #-}
+{-# NOINLINE tlvs #-}
+tlvs :: TlvStream
+tlvs = fromMaybe empty_tlv_stream $
+ tlv_stream [ TlvRecord t (BS.replicate 32 0x2a) | t <- [1, 3 .. 41] ]
--- Sample Pong messages ---------------------------------------------------
+{-# NOINLINE tlvs_bytes #-}
+tlvs_bytes :: BS.ByteString
+tlvs_bytes = encode_tlv_stream tlvs
--- | Minimal Pong (no ignored bytes).
-minimalPong :: Pong
-minimalPong = Pong
- { pongIgnored = BS.empty
+{-# NOINLINE init_msg #-}
+init_msg :: Message
+init_msg = MsgInit Init {
+ init_global_features = BOLT9.parse ""
+ , init_features = BOLT9.parse "\x02\xaa\x52\x69\xa1"
+ , init_networks = fmap pure (chain_hash (BS.replicate 32 0x6f))
+ , init_remote_addr = Just "\x01\x7f\x00\x00\x01\x26\x07"
+ , init_tlvs = empty_tlv_stream
}
-{-# NOINLINE minimalPong #-}
-
--- | Pong with padding (64 bytes).
-pongWithPadding :: Pong
-pongWithPadding = Pong
- { pongIgnored = bytes64
- }
-{-# NOINLINE pongWithPadding #-}
-
--- | Pong with large padding (1KB).
-pongWithLargePadding :: Pong
-pongWithLargePadding = Pong
- { pongIgnored = bytes1k
- }
-{-# NOINLINE pongWithLargePadding #-}
-
--- Sample PeerStorage messages --------------------------------------------
-
--- | Minimal PeerStorage (empty blob).
-minimalPeerStorage :: PeerStorage
-minimalPeerStorage = PeerStorage
- { peerStorageBlob = BS.empty
- }
-{-# NOINLINE minimalPeerStorage #-}
-
--- | PeerStorage with 1KB blob.
-peerStorageSmall :: PeerStorage
-peerStorageSmall = PeerStorage
- { peerStorageBlob = bytes1k
- }
-{-# NOINLINE peerStorageSmall #-}
-
--- | PeerStorage with 16KB blob.
-peerStorageLarge :: PeerStorage
-peerStorageLarge = PeerStorage
- { peerStorageBlob = bytes16k
- }
-{-# NOINLINE peerStorageLarge #-}
-
--- Sample PeerStorageRetrieval messages -----------------------------------
-
--- | Minimal PeerStorageRetrieval (empty blob).
-minimalPeerStorageRetrieval :: PeerStorageRetrieval
-minimalPeerStorageRetrieval = PeerStorageRetrieval
- { peerStorageRetrievalBlob = BS.empty
- }
-{-# NOINLINE minimalPeerStorageRetrieval #-}
-
--- | PeerStorageRetrieval with 1KB blob.
-peerStorageRetrievalSmall :: PeerStorageRetrieval
-peerStorageRetrievalSmall = PeerStorageRetrieval
- { peerStorageRetrievalBlob = bytes1k
- }
-{-# NOINLINE peerStorageRetrievalSmall #-}
-
--- | PeerStorageRetrieval with 16KB blob.
-peerStorageRetrievalLarge :: PeerStorageRetrieval
-peerStorageRetrievalLarge = PeerStorageRetrieval
- { peerStorageRetrievalBlob = bytes16k
- }
-{-# NOINLINE peerStorageRetrievalLarge #-}
-
--- Sample TLV streams -----------------------------------------------------
-
--- | Empty TLV stream.
-emptyTlvStream :: TlvStream
-emptyTlvStream = unsafeTlvStream []
-{-# NOINLINE emptyTlvStream #-}
-
--- | TLV stream with 1 record.
-smallTlvStream :: TlvStream
-smallTlvStream = unsafeTlvStream
- [ TlvRecord 1 (BS.replicate 32 0x01)
- ]
-{-# NOINLINE smallTlvStream #-}
-
--- | TLV stream with 5 records.
-mediumTlvStream :: TlvStream
-mediumTlvStream = unsafeTlvStream
- [ TlvRecord 1 (BS.replicate 8 0x01)
- , TlvRecord 3 (BS.replicate 16 0x03)
- , TlvRecord 5 (BS.replicate 32 0x05)
- , TlvRecord 7 (BS.replicate 64 0x07)
- , TlvRecord 9 (BS.replicate 128 0x09)
- ]
-{-# NOINLINE mediumTlvStream #-}
-
--- | TLV stream with 20 records.
-largeTlvStream :: TlvStream
-largeTlvStream = unsafeTlvStream
- [ TlvRecord 1 (BS.replicate 8 0x01)
- , TlvRecord 3 (BS.replicate 16 0x02)
- , TlvRecord 5 (BS.replicate 8 0x03)
- , TlvRecord 7 (BS.replicate 16 0x04)
- , TlvRecord 9 (BS.replicate 8 0x05)
- , TlvRecord 11 (BS.replicate 16 0x06)
- , TlvRecord 13 (BS.replicate 8 0x07)
- , TlvRecord 15 (BS.replicate 16 0x08)
- , TlvRecord 17 (BS.replicate 8 0x09)
- , TlvRecord 19 (BS.replicate 16 0x0a)
- , TlvRecord 21 (BS.replicate 8 0x0b)
- , TlvRecord 23 (BS.replicate 16 0x0c)
- , TlvRecord 25 (BS.replicate 8 0x0d)
- , TlvRecord 27 (BS.replicate 16 0x0e)
- , TlvRecord 29 (BS.replicate 8 0x0f)
- , TlvRecord 31 (BS.replicate 16 0x10)
- , TlvRecord 33 (BS.replicate 8 0x11)
- , TlvRecord 35 (BS.replicate 16 0x12)
- , TlvRecord 37 (BS.replicate 8 0x13)
- , TlvRecord 39 (BS.replicate 16 0x14)
- ]
-{-# NOINLINE largeTlvStream #-}
-
--- Encoded message bytes (for decode benchmarks) --------------------------
-
--- Helper to encode or fail.
-encodeOrFail :: Either EncodeError BS.ByteString -> BS.ByteString
-encodeOrFail (Right bs) = bs
-encodeOrFail (Left _) = error "encodeOrFail: encoding failed"
-
--- | Encoded minimal Init.
-encodedMinimalInit :: BS.ByteString
-encodedMinimalInit = encodeOrFail $ encodeEnvelope (MsgInitVal minimalInit) Nothing
-{-# NOINLINE encodedMinimalInit #-}
-
--- | Encoded Init with TLVs.
-encodedInitWithTlvs :: BS.ByteString
-encodedInitWithTlvs = encodeOrFail $ encodeEnvelope (MsgInitVal initWithTlvs) Nothing
-{-# NOINLINE encodedInitWithTlvs #-}
-
--- | Encoded full Init.
-encodedFullInit :: BS.ByteString
-encodedFullInit = encodeOrFail $ encodeEnvelope (MsgInitVal fullInit) Nothing
-{-# NOINLINE encodedFullInit #-}
-
--- | Encoded minimal Error.
-encodedMinimalError :: BS.ByteString
-encodedMinimalError = encodeOrFail $ encodeEnvelope (MsgErrorVal minimalError) Nothing
-{-# NOINLINE encodedMinimalError #-}
-
--- | Encoded Error with data.
-encodedErrorWithData :: BS.ByteString
-encodedErrorWithData = encodeOrFail $ encodeEnvelope (MsgErrorVal errorWithData) Nothing
-{-# NOINLINE encodedErrorWithData #-}
-
--- | Encoded minimal Warning.
-encodedMinimalWarning :: BS.ByteString
-encodedMinimalWarning = encodeOrFail $
- encodeEnvelope (MsgWarningVal minimalWarning) Nothing
-{-# NOINLINE encodedMinimalWarning #-}
-
--- | Encoded Warning with data.
-encodedWarningWithData :: BS.ByteString
-encodedWarningWithData = encodeOrFail $
- encodeEnvelope (MsgWarningVal warningWithData) Nothing
-{-# NOINLINE encodedWarningWithData #-}
-
--- | Encoded minimal Ping.
-encodedMinimalPing :: BS.ByteString
-encodedMinimalPing = encodeOrFail $ encodeEnvelope (MsgPingVal minimalPing) Nothing
-{-# NOINLINE encodedMinimalPing #-}
-
--- | Encoded Ping with padding.
-encodedPingWithPadding :: BS.ByteString
-encodedPingWithPadding = encodeOrFail $
- encodeEnvelope (MsgPingVal pingWithPadding) Nothing
-{-# NOINLINE encodedPingWithPadding #-}
-
--- | Encoded Ping with large padding.
-encodedPingWithLargePadding :: BS.ByteString
-encodedPingWithLargePadding = encodeOrFail $
- encodeEnvelope (MsgPingVal pingWithLargePadding) Nothing
-{-# NOINLINE encodedPingWithLargePadding #-}
-
--- | Encoded minimal Pong.
-encodedMinimalPong :: BS.ByteString
-encodedMinimalPong = encodeOrFail $ encodeEnvelope (MsgPongVal minimalPong) Nothing
-{-# NOINLINE encodedMinimalPong #-}
-
--- | Encoded Pong with padding.
-encodedPongWithPadding :: BS.ByteString
-encodedPongWithPadding = encodeOrFail $
- encodeEnvelope (MsgPongVal pongWithPadding) Nothing
-{-# NOINLINE encodedPongWithPadding #-}
-
--- | Encoded minimal PeerStorage.
-encodedMinimalPeerStorage :: BS.ByteString
-encodedMinimalPeerStorage = encodeOrFail $
- encodeEnvelope (MsgPeerStorageVal minimalPeerStorage) Nothing
-{-# NOINLINE encodedMinimalPeerStorage #-}
-
--- | Encoded PeerStorage with 1KB blob.
-encodedPeerStorageSmall :: BS.ByteString
-encodedPeerStorageSmall = encodeOrFail $
- encodeEnvelope (MsgPeerStorageVal peerStorageSmall) Nothing
-{-# NOINLINE encodedPeerStorageSmall #-}
-
--- | Encoded minimal PeerStorageRetrieval.
-encodedMinimalPeerStorageRetrieval :: BS.ByteString
-encodedMinimalPeerStorageRetrieval = encodeOrFail $
- encodeEnvelope (MsgPeerStorageRetrievalVal minimalPeerStorageRetrieval) Nothing
-{-# NOINLINE encodedMinimalPeerStorageRetrieval #-}
--- | Encoded PeerStorageRetrieval with 1KB blob.
-encodedPeerStorageRetrievalSmall :: BS.ByteString
-encodedPeerStorageRetrievalSmall = encodeOrFail $
- encodeEnvelope (MsgPeerStorageRetrievalVal peerStorageRetrievalSmall) Nothing
-{-# NOINLINE encodedPeerStorageRetrievalSmall #-}
+{-# NOINLINE ping_msg #-}
+ping_msg :: Message
+ping_msg = MsgPing (Ping 128 (BS.replicate 64 0) empty_tlv_stream)
--- Encoded TLV streams (for decode benchmarks) ----------------------------
+{-# NOINLINE error_msg #-}
+error_msg :: Message
+error_msg = MsgError (Error all_channels (BS.replicate 128 0x61) tlvs)
--- | Encoded empty TLV stream.
-encodedEmptyTlvStream :: BS.ByteString
-encodedEmptyTlvStream = encodeTlvStream emptyTlvStream
-{-# NOINLINE encodedEmptyTlvStream #-}
+wire :: Message -> BS.ByteString
+wire m = either (const BS.empty) id (encode_message m)
--- | Encoded small TLV stream (1 record).
-encodedSmallTlvStream :: BS.ByteString
-encodedSmallTlvStream = encodeTlvStream smallTlvStream
-{-# NOINLINE encodedSmallTlvStream #-}
+{-# NOINLINE init_bytes #-}
+init_bytes :: BS.ByteString
+init_bytes = wire init_msg
--- | Encoded medium TLV stream (5 records).
-encodedMediumTlvStream :: BS.ByteString
-encodedMediumTlvStream = encodeTlvStream mediumTlvStream
-{-# NOINLINE encodedMediumTlvStream #-}
+{-# NOINLINE ping_bytes #-}
+ping_bytes :: BS.ByteString
+ping_bytes = wire ping_msg
--- | Encoded large TLV stream (20 records).
-encodedLargeTlvStream :: BS.ByteString
-encodedLargeTlvStream = encodeTlvStream largeTlvStream
-{-# NOINLINE encodedLargeTlvStream #-}
+{-# NOINLINE error_bytes #-}
+error_bytes :: BS.ByteString
+error_bytes = wire error_msg
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -1,526 +1,33 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Criterion.Main
-import qualified Data.ByteString as BS
-import Data.Word (Word16, Word32, Word64)
-import Data.Int (Int8, Int16, Int32, Int64)
+import Fixtures
import Lightning.Protocol.BOLT1
-import Lightning.Protocol.BOLT1.Codec
-import Lightning.Protocol.BOLT1.TLV (encodeInitTlvs, encodeTlvRecord, parseInitTlvs)
-
--- Fixtures --------------------------------------------------------------------
-
--- Prevent constant folding by marking fixtures as NOINLINE.
-
-{-# NOINLINE u16Val #-}
-u16Val :: Word16
-u16Val = 0x1234
-
-{-# NOINLINE u32Val #-}
-u32Val :: Word32
-u32Val = 0x12345678
-
-{-# NOINLINE u64Val #-}
-u64Val :: Word64
-u64Val = 0x123456789ABCDEF0
-
-{-# NOINLINE s8Val #-}
-s8Val :: Int8
-s8Val = -42
-
-{-# NOINLINE s16Val #-}
-s16Val :: Int16
-s16Val = -1234
-
-{-# NOINLINE s32Val #-}
-s32Val :: Int32
-s32Val = -12345678
-
-{-# NOINLINE s64Val #-}
-s64Val :: Int64
-s64Val = -123456789012345
-
--- Truncated values
-
-{-# NOINLINE tu16Zero #-}
-tu16Zero :: Word16
-tu16Zero = 0
-
-{-# NOINLINE tu16Small #-}
-tu16Small :: Word16
-tu16Small = 0x42
-
-{-# NOINLINE tu16Max #-}
-tu16Max :: Word16
-tu16Max = 0xFFFF
-
-{-# NOINLINE tu32Zero #-}
-tu32Zero :: Word32
-tu32Zero = 0
-
-{-# NOINLINE tu32Small #-}
-tu32Small :: Word32
-tu32Small = 0x42
-
-{-# NOINLINE tu32Max #-}
-tu32Max :: Word32
-tu32Max = 0xFFFFFFFF
-
-{-# NOINLINE tu64Zero #-}
-tu64Zero :: Word64
-tu64Zero = 0
-
-{-# NOINLINE tu64Small #-}
-tu64Small :: Word64
-tu64Small = 0x42
-
-{-# NOINLINE tu64Max #-}
-tu64Max :: Word64
-tu64Max = 0xFFFFFFFFFFFFFFFF
-
--- MinSigned values
-
-{-# NOINLINE ms0 #-}
-ms0 :: Int64
-ms0 = 0
-
-{-# NOINLINE ms127 #-}
-ms127 :: Int64
-ms127 = 127
-
-{-# NOINLINE ms128 #-}
-ms128 :: Int64
-ms128 = 128
-
-{-# NOINLINE msNeg128 #-}
-msNeg128 :: Int64
-msNeg128 = -128
-
-{-# NOINLINE msNeg129 #-}
-msNeg129 :: Int64
-msNeg129 = -129
-
--- BigSize values
-
-{-# NOINLINE bs0 #-}
-bs0 :: Word64
-bs0 = 0
-
-{-# NOINLINE bs252 #-}
-bs252 :: Word64
-bs252 = 252
-
-{-# NOINLINE bs253 #-}
-bs253 :: Word64
-bs253 = 253
-
-{-# NOINLINE bs65535 #-}
-bs65535 :: Word64
-bs65535 = 65535
-
-{-# NOINLINE bs65536 #-}
-bs65536 :: Word64
-bs65536 = 65536
-
-{-# NOINLINE bsLarge #-}
-bsLarge :: Word64
-bsLarge = 0x100000000
-
--- Encoded bytes for decode benchmarks
-
-{-# NOINLINE encodedU16 #-}
-encodedU16 :: BS.ByteString
-encodedU16 = encodeU16 u16Val
-
-{-# NOINLINE encodedU32 #-}
-encodedU32 :: BS.ByteString
-encodedU32 = encodeU32 u32Val
-
-{-# NOINLINE encodedU64 #-}
-encodedU64 :: BS.ByteString
-encodedU64 = encodeU64 u64Val
-
-{-# NOINLINE encodedS8 #-}
-encodedS8 :: BS.ByteString
-encodedS8 = encodeS8 s8Val
-
-{-# NOINLINE encodedS16 #-}
-encodedS16 :: BS.ByteString
-encodedS16 = encodeS16 s16Val
-
-{-# NOINLINE encodedS32 #-}
-encodedS32 :: BS.ByteString
-encodedS32 = encodeS32 s32Val
-
-{-# NOINLINE encodedS64 #-}
-encodedS64 :: BS.ByteString
-encodedS64 = encodeS64 s64Val
-
-{-# NOINLINE encodedTu16Small #-}
-encodedTu16Small :: BS.ByteString
-encodedTu16Small = encodeTu16 tu16Small
-
-{-# NOINLINE encodedTu32Small #-}
-encodedTu32Small :: BS.ByteString
-encodedTu32Small = encodeTu32 tu32Small
-
-{-# NOINLINE encodedTu64Small #-}
-encodedTu64Small :: BS.ByteString
-encodedTu64Small = encodeTu64 tu64Small
-
-{-# NOINLINE encodedMs127 #-}
-encodedMs127 :: BS.ByteString
-encodedMs127 = encodeMinSigned ms127
-
-{-# NOINLINE encodedMsNeg129 #-}
-encodedMsNeg129 :: BS.ByteString
-encodedMsNeg129 = encodeMinSigned msNeg129
-
-{-# NOINLINE encodedBs0 #-}
-encodedBs0 :: BS.ByteString
-encodedBs0 = encodeBigSize bs0
-
-{-# NOINLINE encodedBs253 #-}
-encodedBs253 :: BS.ByteString
-encodedBs253 = encodeBigSize bs253
-
-{-# NOINLINE encodedBs65536 #-}
-encodedBs65536 :: BS.ByteString
-encodedBs65536 = encodeBigSize bs65536
-
-{-# NOINLINE encodedBsLarge #-}
-encodedBsLarge :: BS.ByteString
-encodedBsLarge = encodeBigSize bsLarge
-
--- TLV fixtures
-
-{-# NOINLINE tlvRec1 #-}
-tlvRec1 :: TlvRecord
-tlvRec1 = TlvRecord 1 "test"
-
-{-# NOINLINE tlvRec3 #-}
-tlvRec3 :: TlvRecord
-tlvRec3 = TlvRecord 3 "addr"
-
-{-# NOINLINE tlvRec5 #-}
-tlvRec5 :: TlvRecord
-tlvRec5 = TlvRecord 5 "value"
-
-{-# NOINLINE tlvStream1 #-}
-tlvStream1 :: TlvStream
-tlvStream1 = unsafeTlvStream [tlvRec1]
-
-{-# NOINLINE tlvStream5 #-}
-tlvStream5 :: TlvStream
-tlvStream5 = unsafeTlvStream
- [ TlvRecord 1 "one"
- , TlvRecord 3 "three"
- , TlvRecord 5 "five"
- , TlvRecord 7 "seven"
- , TlvRecord 9 "nine"
- ]
-
-{-# NOINLINE tlvStream20 #-}
-tlvStream20 :: TlvStream
-tlvStream20 = unsafeTlvStream
- [ TlvRecord (2*i + 1) (BS.replicate 10 (fromIntegral i))
- | i <- [0..19]
- ]
-
-{-# NOINLINE encodedTlvStream1 #-}
-encodedTlvStream1 :: BS.ByteString
-encodedTlvStream1 = encodeTlvStream tlvStream1
-
-{-# NOINLINE encodedTlvStream5 #-}
-encodedTlvStream5 :: BS.ByteString
-encodedTlvStream5 = encodeTlvStream tlvStream5
-
-{-# NOINLINE encodedTlvStream20 #-}
-encodedTlvStream20 :: BS.ByteString
-encodedTlvStream20 = encodeTlvStream tlvStream20
-
--- Init TLV fixtures
-
-{-# NOINLINE chainHash1 #-}
-chainHash1 :: ChainHash
-chainHash1 = case chainHash (BS.replicate 32 0x01) of
- Just ch -> ch
- Nothing -> error "impossible"
-
-{-# NOINLINE initTlvNetworks #-}
-initTlvNetworks :: [InitTlv]
-initTlvNetworks = [InitNetworks [chainHash1]]
-
-{-# NOINLINE initTlvRemoteAddr #-}
-initTlvRemoteAddr :: [InitTlv]
-initTlvRemoteAddr = [InitRemoteAddr "127.0.0.1"]
-
-{-# NOINLINE encodedInitTlvs #-}
-encodedInitTlvs :: BS.ByteString
-encodedInitTlvs = encodeTlvStream (encodeInitTlvs initTlvNetworks)
-
--- Message fixtures
-
-{-# NOINLINE initMinimal #-}
-initMinimal :: Init
-initMinimal = Init BS.empty BS.empty []
-
-{-# NOINLINE initWithTlvs #-}
-initWithTlvs :: Init
-initWithTlvs = Init (BS.pack [0x00, 0x01]) (BS.pack [0x02, 0x03]) initTlvNetworks
-
-{-# NOINLINE errorMinimal #-}
-errorMinimal :: Error
-errorMinimal = Error allChannels BS.empty
-
-{-# NOINLINE errorWithData #-}
-errorWithData :: Error
-errorWithData = Error allChannels "Connection reset by peer"
-
-{-# NOINLINE warningMsg #-}
-warningMsg :: Warning
-warningMsg = Warning allChannels "Low disk space"
-
-{-# NOINLINE pingMinimal #-}
-pingMinimal :: Ping
-pingMinimal = Ping 64 BS.empty
-
-{-# NOINLINE pingWithPadding #-}
-pingWithPadding :: Ping
-pingWithPadding = Ping 64 (BS.replicate 64 0x00)
-
-{-# NOINLINE pongMsg #-}
-pongMsg :: Pong
-pongMsg = Pong (BS.replicate 64 0x00)
-
-{-# NOINLINE peerStorageMsg #-}
-peerStorageMsg :: PeerStorage
-peerStorageMsg = PeerStorage (BS.replicate 100 0xAB)
-
-{-# NOINLINE peerStorageRetMsg #-}
-peerStorageRetMsg :: PeerStorageRetrieval
-peerStorageRetMsg = PeerStorageRetrieval (BS.replicate 100 0xCD)
-
--- Encoded messages for decode benchmarks
-
-{-# NOINLINE encodedInitMinimal #-}
-encodedInitMinimal :: BS.ByteString
-encodedInitMinimal = case encodeInit initMinimal of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedInitWithTlvs #-}
-encodedInitWithTlvs :: BS.ByteString
-encodedInitWithTlvs = case encodeInit initWithTlvs of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedErrorMinimal #-}
-encodedErrorMinimal :: BS.ByteString
-encodedErrorMinimal = case encodeError errorMinimal of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedErrorWithData #-}
-encodedErrorWithData :: BS.ByteString
-encodedErrorWithData = case encodeError errorWithData of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedWarning #-}
-encodedWarning :: BS.ByteString
-encodedWarning = case encodeWarning warningMsg of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedPingMinimal #-}
-encodedPingMinimal :: BS.ByteString
-encodedPingMinimal = case encodePing pingMinimal of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedPingWithPadding #-}
-encodedPingWithPadding :: BS.ByteString
-encodedPingWithPadding = case encodePing pingWithPadding of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedPong #-}
-encodedPong :: BS.ByteString
-encodedPong = case encodePong pongMsg of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedPeerStorage #-}
-encodedPeerStorage :: BS.ByteString
-encodedPeerStorage = case encodePeerStorage peerStorageMsg of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedPeerStorageRet #-}
-encodedPeerStorageRet :: BS.ByteString
-encodedPeerStorageRet = case encodePeerStorageRetrieval peerStorageRetMsg of
- Right bs -> bs
- Left _ -> error "impossible"
-
--- Envelope fixtures
-
-{-# NOINLINE msgInit #-}
-msgInit :: Message
-msgInit = MsgInitVal initMinimal
-
-{-# NOINLINE msgPing #-}
-msgPing :: Message
-msgPing = MsgPingVal pingMinimal
-
-{-# NOINLINE encodedEnvelopeNoExt #-}
-encodedEnvelopeNoExt :: BS.ByteString
-encodedEnvelopeNoExt = case encodeEnvelope msgPing Nothing of
- Right bs -> bs
- Left _ -> error "impossible"
-
-{-# NOINLINE encodedEnvelopeWithExt #-}
-encodedEnvelopeWithExt :: BS.ByteString
-encodedEnvelopeWithExt = case encodeEnvelope msgPing (Just tlvStream5) of
- Right bs -> bs
- Left _ -> error "impossible"
-
--- Main ------------------------------------------------------------------------
main :: IO ()
-main = defaultMain
- [ bgroup "prim/encode"
- [ bench "encodeU16" $ whnf encodeU16 u16Val
- , bench "encodeU32" $ whnf encodeU32 u32Val
- , bench "encodeU64" $ whnf encodeU64 u64Val
- , bench "encodeS8" $ whnf encodeS8 s8Val
- , bench "encodeS16" $ whnf encodeS16 s16Val
- , bench "encodeS32" $ whnf encodeS32 s32Val
- , bench "encodeS64" $ whnf encodeS64 s64Val
- , bench "encodeTu16/0" $ whnf encodeTu16 tu16Zero
- , bench "encodeTu16/small" $ whnf encodeTu16 tu16Small
- , bench "encodeTu16/max" $ whnf encodeTu16 tu16Max
- , bench "encodeTu32/0" $ whnf encodeTu32 tu32Zero
- , bench "encodeTu32/small" $ whnf encodeTu32 tu32Small
- , bench "encodeTu32/max" $ whnf encodeTu32 tu32Max
- , bench "encodeTu64/0" $ whnf encodeTu64 tu64Zero
- , bench "encodeTu64/small" $ whnf encodeTu64 tu64Small
- , bench "encodeTu64/max" $ whnf encodeTu64 tu64Max
- , bench "encodeMinSigned/0" $ whnf encodeMinSigned ms0
- , bench "encodeMinSigned/127" $ whnf encodeMinSigned ms127
- , bench "encodeMinSigned/128" $ whnf encodeMinSigned ms128
- , bench "encodeMinSigned/-128" $ whnf encodeMinSigned msNeg128
- , bench "encodeMinSigned/-129" $ whnf encodeMinSigned msNeg129
- , bench "encodeBigSize/0" $ whnf encodeBigSize bs0
- , bench "encodeBigSize/252" $ whnf encodeBigSize bs252
- , bench "encodeBigSize/253" $ whnf encodeBigSize bs253
- , bench "encodeBigSize/65535" $ whnf encodeBigSize bs65535
- , bench "encodeBigSize/65536" $ whnf encodeBigSize bs65536
- , bench "encodeBigSize/large" $ whnf encodeBigSize bsLarge
- ]
-
- , bgroup "prim/decode"
- [ bench "decodeU16" $ nf decodeU16 encodedU16
- , bench "decodeU32" $ nf decodeU32 encodedU32
- , bench "decodeU64" $ nf decodeU64 encodedU64
- , bench "decodeS8" $ nf decodeS8 encodedS8
- , bench "decodeS16" $ nf decodeS16 encodedS16
- , bench "decodeS32" $ nf decodeS32 encodedS32
- , bench "decodeS64" $ nf decodeS64 encodedS64
- , bench "decodeTu16" $ nf (decodeTu16 1) encodedTu16Small
- , bench "decodeTu32" $ nf (decodeTu32 1) encodedTu32Small
- , bench "decodeTu64" $ nf (decodeTu64 1) encodedTu64Small
- , bench "decodeMinSigned/1" $ nf (decodeMinSigned 1) encodedMs127
- , bench "decodeMinSigned/2" $ nf (decodeMinSigned 2) encodedMsNeg129
- , bench "decodeBigSize/0" $ nf decodeBigSize encodedBs0
- , bench "decodeBigSize/253" $ nf decodeBigSize encodedBs253
- , bench "decodeBigSize/65536" $ nf decodeBigSize encodedBs65536
- , bench "decodeBigSize/large" $ nf decodeBigSize encodedBsLarge
- ]
-
- , bgroup "tlv/encode"
- [ bench "encodeTlvRecord" $ whnf encodeTlvRecord tlvRec1
- , bench "encodeTlvStream/1" $ whnf encodeTlvStream tlvStream1
- , bench "encodeTlvStream/5" $ whnf encodeTlvStream tlvStream5
- , bench "encodeTlvStream/20" $ whnf encodeTlvStream tlvStream20
- , bench "encodeInitTlvs" $ nf encodeInitTlvs initTlvNetworks
- ]
-
- , bgroup "tlv/decode"
- [ bench "decodeTlvStreamRaw/1" $ nf decodeTlvStreamRaw encodedTlvStream1
- , bench "decodeTlvStreamRaw/5" $ nf decodeTlvStreamRaw encodedTlvStream5
- , bench "decodeTlvStreamRaw/20" $ nf decodeTlvStreamRaw encodedTlvStream20
- , bench "decodeTlvStream" $ nf decodeTlvStream encodedInitTlvs
- , bench "decodeTlvStreamWith" $
- nf (decodeTlvStreamWith (const True)) encodedTlvStream5
- , bench "parseInitTlvs" $
- nf parseInitTlvs (encodeInitTlvs initTlvNetworks)
- ]
-
- , bgroup "message/encode"
- [ bench "encodeInit/minimal" $ nf encodeInit initMinimal
- , bench "encodeInit/with-tlvs" $ nf encodeInit initWithTlvs
- , bench "encodeError/minimal" $ nf encodeError errorMinimal
- , bench "encodeError/with-data" $ nf encodeError errorWithData
- , bench "encodeWarning" $ nf encodeWarning warningMsg
- , bench "encodePing/minimal" $ nf encodePing pingMinimal
- , bench "encodePing/with-padding" $ nf encodePing pingWithPadding
- , bench "encodePong" $ nf encodePong pongMsg
- , bench "encodePeerStorage" $ nf encodePeerStorage peerStorageMsg
- , bench "encodePeerStorageRetrieval" $
- nf encodePeerStorageRetrieval peerStorageRetMsg
- ]
-
- , bgroup "message/decode"
- [ bench "decodeInit/minimal" $ nf decodeInit encodedInitMinimal
- , bench "decodeInit/with-tlvs" $ nf decodeInit encodedInitWithTlvs
- , bench "decodeError/minimal" $ nf decodeError encodedErrorMinimal
- , bench "decodeError/with-data" $ nf decodeError encodedErrorWithData
- , bench "decodeWarning" $ nf decodeWarning encodedWarning
- , bench "decodePing/minimal" $ nf decodePing encodedPingMinimal
- , bench "decodePing/with-padding" $ nf decodePing encodedPingWithPadding
- , bench "decodePong" $ nf decodePong encodedPong
- , bench "decodePeerStorage" $ nf decodePeerStorage encodedPeerStorage
- , bench "decodePeerStorageRetrieval" $
- nf decodePeerStorageRetrieval encodedPeerStorageRet
- ]
-
- , bgroup "envelope"
- [ bench "encodeEnvelope/no-ext" $ nf (encodeEnvelope msgPing) Nothing
- , bench "encodeEnvelope/with-ext" $
- nf (encodeEnvelope msgPing) (Just tlvStream5)
- , bench "decodeEnvelope/no-ext" $ nf decodeEnvelope encodedEnvelopeNoExt
- , bench "decodeEnvelope/with-ext" $
- nf decodeEnvelope encodedEnvelopeWithExt
- , bench "decodeEnvelopeWith" $
- nf (decodeEnvelopeWith (const True)) encodedEnvelopeWithExt
- ]
-
- , bgroup "roundtrip"
- [ bench "init/minimal" $ nf (decodeInit . forceRight . encodeInit)
- initMinimal
- , bench "init/with-tlvs" $ nf (decodeInit . forceRight . encodeInit)
- initWithTlvs
- , bench "error" $ nf (decodeError . forceRight . encodeError) errorWithData
- , bench "warning" $ nf (decodeWarning . forceRight . encodeWarning)
- warningMsg
- , bench "ping" $ nf (decodePing . forceRight . encodePing) pingWithPadding
- , bench "pong" $ nf (decodePong . forceRight . encodePong) pongMsg
- , bench "peer-storage" $
- nf (decodePeerStorage . forceRight . encodePeerStorage) peerStorageMsg
- , bench "peer-storage-retrieval" $
- nf (decodePeerStorageRetrieval . forceRight . encodePeerStorageRetrieval)
- peerStorageRetMsg
- , bench "envelope" $ nf
- (decodeEnvelope . forceRight . encodeEnvelope msgPing) (Just tlvStream5)
- ]
+main = defaultMain [
+ bgroup "primitives" [
+ bench "encode_u64" $ nf encode_u64 0x0102030405060708
+ , bench "decode_u64" $ nf decode_u64 "\x01\x02\x03\x04\x05\x06\x07\x08"
+ , bench "encode_tu64" $ nf encode_tu64 0x010203
+ , bench "decode_tu64" $ nf decode_tu64 "\x01\x02\x03"
+ , bench "encode_bigsize (9 bytes)" $ nf encode_bigsize 0x100000000
+ , bench "decode_bigsize (9 bytes)" $
+ nf decode_bigsize "\xff\x00\x00\x00\x01\x00\x00\x00\x00"
+ ]
+ , bgroup "tlv" [
+ bench "encode_tlv_stream (21 records)" $ nf encode_tlv_stream tlvs
+ , bench "decode_tlv_stream (21 records)" $
+ nf (decode_tlv_stream (const False)) tlvs_bytes
+ ]
+ , bgroup "messages" [
+ bench "encode init" $ nf encode_message init_msg
+ , bench "decode init" $ nf decode_message init_bytes
+ , bench "encode ping" $ nf encode_message ping_msg
+ , bench "decode ping" $ nf decode_message ping_bytes
+ , bench "encode error (with tlvs)" $ nf encode_message error_msg
+ , bench "decode error (with tlvs)" $ nf decode_message error_bytes
+ ]
]
-
--- Helper for roundtrip benchmarks
-forceRight :: Either a b -> b
-forceRight (Right b) = b
-forceRight (Left _) = error "forceRight: Left"
-{-# INLINE forceRight #-}
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -1,347 +1,28 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import qualified Data.ByteString as BS
-import Data.Word (Word16, Word32, Word64)
-import Data.Int (Int8, Int16, Int32, Int64)
+import Fixtures
import Lightning.Protocol.BOLT1
-import Lightning.Protocol.BOLT1.Codec
-import Lightning.Protocol.BOLT1.TLV (encodeTlvRecord)
import Weigh
--- Fixtures --------------------------------------------------------------------
-
--- Prevent constant folding with NOINLINE
-
-{-# NOINLINE w16Val #-}
-w16Val :: Word16
-w16Val = 0x1234
-
-{-# NOINLINE w32Val #-}
-w32Val :: Word32
-w32Val = 0x12345678
-
-{-# NOINLINE w64Val #-}
-w64Val :: Word64
-w64Val = 0x0102030405060708
-
-{-# NOINLINE s8Val #-}
-s8Val :: Int8
-s8Val = -42
-
-{-# NOINLINE s16Val #-}
-s16Val :: Int16
-s16Val = -1000
-
-{-# NOINLINE s32Val #-}
-s32Val :: Int32
-s32Val = -100000
-
-{-# NOINLINE s64Val #-}
-s64Val :: Int64
-s64Val = -10000000000
-
-{-# NOINLINE tu16Small #-}
-tu16Small :: Word16
-tu16Small = 0x7f
-
-{-# NOINLINE tu16Full #-}
-tu16Full :: Word16
-tu16Full = 0xffff
-
-{-# NOINLINE tu32Small #-}
-tu32Small :: Word32
-tu32Small = 0x42
-
-{-# NOINLINE tu32Full #-}
-tu32Full :: Word32
-tu32Full = 0xffffffff
-
-{-# NOINLINE tu64Small #-}
-tu64Small :: Word64
-tu64Small = 0x10
-
-{-# NOINLINE tu64Full #-}
-tu64Full :: Word64
-tu64Full = 0xffffffffffffffff
-
-{-# NOINLINE bigSizeSmall #-}
-bigSizeSmall :: Word64
-bigSizeSmall = 0xfc
-
-{-# NOINLINE bigSizeMedium #-}
-bigSizeMedium :: Word64
-bigSizeMedium = 0x1000
-
-{-# NOINLINE bigSizeLarge #-}
-bigSizeLarge :: Word64
-bigSizeLarge = 0x100000000
-
--- Pre-encoded bytes for decoder benchmarks
-
-{-# NOINLINE u16Bytes #-}
-u16Bytes :: BS.ByteString
-u16Bytes = encodeU16 w16Val
-
-{-# NOINLINE u32Bytes #-}
-u32Bytes :: BS.ByteString
-u32Bytes = encodeU32 w32Val
-
-{-# NOINLINE u64Bytes #-}
-u64Bytes :: BS.ByteString
-u64Bytes = encodeU64 w64Val
-
-{-# NOINLINE s8Bytes #-}
-s8Bytes :: BS.ByteString
-s8Bytes = encodeS8 s8Val
-
-{-# NOINLINE s16Bytes #-}
-s16Bytes :: BS.ByteString
-s16Bytes = encodeS16 s16Val
-
-{-# NOINLINE s32Bytes #-}
-s32Bytes :: BS.ByteString
-s32Bytes = encodeS32 s32Val
-
-{-# NOINLINE s64Bytes #-}
-s64Bytes :: BS.ByteString
-s64Bytes = encodeS64 s64Val
-
-{-# NOINLINE bigSizeBytes #-}
-bigSizeBytes :: BS.ByteString
-bigSizeBytes = encodeBigSize bigSizeLarge
-
--- TLV fixtures
-
-{-# NOINLINE tlvRecord1 #-}
-tlvRecord1 :: TlvRecord
-tlvRecord1 = TlvRecord 1 "test-value"
-
-{-# NOINLINE tlvStream1 #-}
-tlvStream1 :: TlvStream
-tlvStream1 = unsafeTlvStream [tlvRecord1]
-
-{-# NOINLINE tlvStream5 #-}
-tlvStream5 :: TlvStream
-tlvStream5 = unsafeTlvStream
- [ TlvRecord 1 "value1"
- , TlvRecord 3 "value3"
- , TlvRecord 5 "value5"
- , TlvRecord 7 "value7"
- , TlvRecord 9 "value9"
- ]
-
-{-# NOINLINE tlvStream20 #-}
-tlvStream20 :: TlvStream
-tlvStream20 = unsafeTlvStream
- [ TlvRecord (2 * i + 1) (BS.replicate 10 (fromIntegral i))
- | i <- [0..19]
- ]
-
-{-# NOINLINE tlvStreamBytes1 #-}
-tlvStreamBytes1 :: BS.ByteString
-tlvStreamBytes1 = encodeTlvStream tlvStream1
-
-{-# NOINLINE tlvStreamBytes5 #-}
-tlvStreamBytes5 :: BS.ByteString
-tlvStreamBytes5 = encodeTlvStream tlvStream5
-
-{-# NOINLINE tlvStreamBytes20 #-}
-tlvStreamBytes20 :: BS.ByteString
-tlvStreamBytes20 = encodeTlvStream tlvStream20
-
--- Message fixtures
-
-{-# NOINLINE minimalInit #-}
-minimalInit :: Init
-minimalInit = Init BS.empty BS.empty []
-
-{-# NOINLINE initWithFeatures #-}
-initWithFeatures :: Init
-initWithFeatures = Init "\x00\x08" "\x00\x0a\x8a" []
-
-{-# NOINLINE initWithTlvs #-}
-initWithTlvs :: Init
-initWithTlvs = Init BS.empty "\x00\x01" [InitRemoteAddr "127.0.0.1"]
-
-{-# NOINLINE errorMsg #-}
-errorMsg :: Error
-errorMsg = Error allChannels "something bad happened"
-
-{-# NOINLINE warningMsg #-}
-warningMsg :: Warning
-warningMsg = Warning allChannels "something concerning"
-
-{-# NOINLINE pingMinimal #-}
-pingMinimal :: Ping
-pingMinimal = Ping 4 BS.empty
-
-{-# NOINLINE pingWithPadding #-}
-pingWithPadding :: Ping
-pingWithPadding = Ping 4 (BS.replicate 64 0x00)
-
-{-# NOINLINE pongMsg #-}
-pongMsg :: Pong
-pongMsg = Pong (BS.replicate 4 0x00)
-
-{-# NOINLINE peerStorageMsg #-}
-peerStorageMsg :: PeerStorage
-peerStorageMsg = PeerStorage (BS.replicate 100 0xab)
-
-{-# NOINLINE peerStorageRetrievalMsg #-}
-peerStorageRetrievalMsg :: PeerStorageRetrieval
-peerStorageRetrievalMsg = PeerStorageRetrieval (BS.replicate 50 0xcd)
-
--- Pre-encoded message bytes for decoder benchmarks
-
-{-# NOINLINE initMinimalBytes #-}
-initMinimalBytes :: BS.ByteString
-initMinimalBytes = either (const BS.empty) id (encodeInit minimalInit)
-
-{-# NOINLINE initWithTlvsBytes #-}
-initWithTlvsBytes :: BS.ByteString
-initWithTlvsBytes = either (const BS.empty) id (encodeInit initWithTlvs)
-
-{-# NOINLINE errorBytes #-}
-errorBytes :: BS.ByteString
-errorBytes = either (const BS.empty) id (encodeError errorMsg)
-
-{-# NOINLINE warningBytes #-}
-warningBytes :: BS.ByteString
-warningBytes = either (const BS.empty) id (encodeWarning warningMsg)
-
-{-# NOINLINE pingMinimalBytes #-}
-pingMinimalBytes :: BS.ByteString
-pingMinimalBytes = either (const BS.empty) id (encodePing pingMinimal)
-
-{-# NOINLINE pingWithPaddingBytes #-}
-pingWithPaddingBytes :: BS.ByteString
-pingWithPaddingBytes = either (const BS.empty) id (encodePing pingWithPadding)
-
-{-# NOINLINE pongBytes #-}
-pongBytes :: BS.ByteString
-pongBytes = either (const BS.empty) id (encodePong pongMsg)
-
-{-# NOINLINE peerStorageBytes #-}
-peerStorageBytes :: BS.ByteString
-peerStorageBytes = either (const BS.empty) id (encodePeerStorage peerStorageMsg)
-
-{-# NOINLINE peerStorageRetrievalBytes #-}
-peerStorageRetrievalBytes :: BS.ByteString
-peerStorageRetrievalBytes =
- either (const BS.empty) id (encodePeerStorageRetrieval peerStorageRetrievalMsg)
-
--- Envelope fixtures
-
-{-# NOINLINE initMessage #-}
-initMessage :: Message
-initMessage = MsgInitVal minimalInit
-
-{-# NOINLINE pingMessage #-}
-pingMessage :: Message
-pingMessage = MsgPingVal pingMinimal
-
-{-# NOINLINE envelopeBytes #-}
-envelopeBytes :: BS.ByteString
-envelopeBytes = either (const BS.empty) id (encodeEnvelope initMessage Nothing)
-
--- Main ------------------------------------------------------------------------
-
main :: IO ()
main = mainWith $ do
- setColumns [Case, Allocated, GCs, Max]
-
- -- Primitive encoders --------------------------------------------------------
-
- wgroup "Primitive Encoders" $ do
- func "encodeU16" encodeU16 w16Val
- func "encodeU32" encodeU32 w32Val
- func "encodeU64" encodeU64 w64Val
- func "encodeS8" encodeS8 s8Val
- func "encodeS16" encodeS16 s16Val
- func "encodeS32" encodeS32 s32Val
- func "encodeS64" encodeS64 s64Val
-
- wgroup "Truncated Unsigned Encoders" $ do
- func "encodeTu16/small" encodeTu16 tu16Small
- func "encodeTu16/full" encodeTu16 tu16Full
- func "encodeTu32/small" encodeTu32 tu32Small
- func "encodeTu32/full" encodeTu32 tu32Full
- func "encodeTu64/small" encodeTu64 tu64Small
- func "encodeTu64/full" encodeTu64 tu64Full
-
- wgroup "Minimal Signed Encoder" $ do
- func "encodeMinSigned/1-byte" encodeMinSigned (0 :: Int64)
- func "encodeMinSigned/2-byte" encodeMinSigned (1000 :: Int64)
- func "encodeMinSigned/4-byte" encodeMinSigned (100000 :: Int64)
- func "encodeMinSigned/8-byte" encodeMinSigned s64Val
-
- wgroup "BigSize Encoder" $ do
- func "encodeBigSize/1-byte" encodeBigSize bigSizeSmall
- func "encodeBigSize/3-byte" encodeBigSize bigSizeMedium
- func "encodeBigSize/9-byte" encodeBigSize bigSizeLarge
-
- -- Primitive decoders --------------------------------------------------------
-
- wgroup "Primitive Decoders" $ do
- func "decodeU16" decodeU16 u16Bytes
- func "decodeU32" decodeU32 u32Bytes
- func "decodeU64" decodeU64 u64Bytes
- func "decodeS8" decodeS8 s8Bytes
- func "decodeS16" decodeS16 s16Bytes
- func "decodeS32" decodeS32 s32Bytes
- func "decodeS64" decodeS64 s64Bytes
- func "decodeBigSize" decodeBigSize bigSizeBytes
-
- -- TLV operations ------------------------------------------------------------
-
- wgroup "TLV Encoding" $ do
- func "encodeTlvRecord" encodeTlvRecord tlvRecord1
- func "encodeTlvStream/1-record" encodeTlvStream tlvStream1
- func "encodeTlvStream/5-records" encodeTlvStream tlvStream5
- func "encodeTlvStream/20-records" encodeTlvStream tlvStream20
-
- wgroup "TLV Decoding" $ do
- func "decodeTlvStreamRaw/1-record" decodeTlvStreamRaw tlvStreamBytes1
- func "decodeTlvStreamRaw/5-records" decodeTlvStreamRaw tlvStreamBytes5
- func "decodeTlvStreamRaw/20-records" decodeTlvStreamRaw tlvStreamBytes20
- func "decodeTlvStream/1-record" decodeTlvStream tlvStreamBytes1
- func "decodeTlvStream/5-records" decodeTlvStream tlvStreamBytes5
-
- -- Message encoders ----------------------------------------------------------
-
- wgroup "Message Encoders" $ do
- func "encodeInit/minimal" encodeInit minimalInit
- func "encodeInit/with-features" encodeInit initWithFeatures
- func "encodeInit/with-tlvs" encodeInit initWithTlvs
- func "encodeError" encodeError errorMsg
- func "encodeWarning" encodeWarning warningMsg
- func "encodePing/minimal" encodePing pingMinimal
- func "encodePing/with-padding" encodePing pingWithPadding
- func "encodePong" encodePong pongMsg
- func "encodePeerStorage" encodePeerStorage peerStorageMsg
- func "encodePeerStorageRetrieval" encodePeerStorageRetrieval
- peerStorageRetrievalMsg
-
- -- Message decoders ----------------------------------------------------------
-
- wgroup "Message Decoders" $ do
- func "decodeInit/minimal" decodeInit initMinimalBytes
- func "decodeInit/with-tlvs" decodeInit initWithTlvsBytes
- func "decodeError" decodeError errorBytes
- func "decodeWarning" decodeWarning warningBytes
- func "decodePing/minimal" decodePing pingMinimalBytes
- func "decodePing/with-padding" decodePing pingWithPaddingBytes
- func "decodePong" decodePong pongBytes
- func "decodePeerStorage" decodePeerStorage peerStorageBytes
- func "decodePeerStorageRetrieval" decodePeerStorageRetrieval
- peerStorageRetrievalBytes
-
- -- Envelope operations -------------------------------------------------------
-
- wgroup "Envelope Operations" $ do
- func "encodeEnvelope/init" (flip encodeEnvelope Nothing) initMessage
- func "encodeEnvelope/ping" (flip encodeEnvelope Nothing) pingMessage
- func "decodeEnvelope" decodeEnvelope envelopeBytes
+ wgroup "primitives" $ do
+ func "baseline (weigh overhead)" (+ (1 :: Int)) 1
+ func "encode_u16" encode_u16 0x0102
+ func "encode_u64" encode_u64 0x0102030405060708
+ func "decode_u64" decode_u64 "\x01\x02\x03\x04\x05\x06\x07\x08"
+ func "encode_tu64" encode_tu64 0x010203
+ func "encode_bigsize (9 bytes)" encode_bigsize 0x100000000
+ wgroup "tlv" $ do
+ func "encode_tlv_stream (21 records)" encode_tlv_stream tlvs
+ func "decode_tlv_stream (21 records)"
+ (decode_tlv_stream (const False)) tlvs_bytes
+ wgroup "messages" $ do
+ func "encode init" encode_message init_msg
+ func "decode init" decode_message init_bytes
+ func "encode ping" encode_message ping_msg
+ func "decode ping" decode_message ping_bytes
+ func "encode error (with tlvs)" encode_message error_msg
+ func "decode error (with tlvs)" decode_message error_bytes
diff --git a/etc/01-messaging.md b/etc/01-messaging.md
@@ -168,11 +168,9 @@ The receiving node:
- MUST fail to parse the `tlv_stream`.
- if `type` is known:
- MUST decode the next `length` bytes using the known encoding for `type`.
- - if `length` is not exactly equal to that required for the known encoding
- for `type`:
+ - if `length` is not exactly equal to that required for the known encoding for `type`:
- MUST fail to parse the `tlv_stream`.
- - if variable-length fields within the known encoding for `type` are not
- minimal:
+ - if variable-length fields within the known encoding for `type` are not minimal:
- MUST fail to parse the `tlv_stream`.
- otherwise, if `type` is unknown:
- if `type` is even:
@@ -236,8 +234,8 @@ Various fundamental types are referred to in the message specifications:
Signed integers use standard big-endian two's complement representation
(see test vectors [below](#appendix-d-signed-integers-test-vectors)).
-For the final value in TLV records, truncated integers may be used. Leading
-zeros in truncated integers MUST be omitted:
+For the final value in TLV records, truncated integers may be used. Leading zeros in
+truncated integers MUST be omitted:
* `tu16`: a 0 to 2 byte truncated unsigned integer
* `tu32`: a 0 to 4 byte truncated unsigned integer
@@ -257,28 +255,25 @@ The following convenience types are also defined:
* `signature`: a 64-byte bitcoin Elliptic Curve signature
* `bip340sig`: a 64-byte bitcoin Elliptic Curve Schnorr signature as per [BIP-340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki)
* `point`: a 33-byte Elliptic Curve point (compressed encoding as per [SEC 1 standard](http://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3))
-* `short_channel_id`: an 8 byte value identifying a channel (see [BOLT #7](07-routing-gossip.md#definition-of-short_channel_id))
-* `sciddir_or_pubkey`: either 9 or 33 bytes referencing or identifying a node
-* `bigsize`: a variable-length, unsigned integer similar to Bitcoin's CompactSize encoding, but big-endian. Described in [BigSize](#appendix-a-bigsize-test-vectors).
-* `utf8`: a byte as part of a UTF-8 string.
+* `short_channel_id`: an 8 byte value identifying a channel (see [BOLT #7](07-routing-gossip.md#definition-of-short-channel-id))
+* `sciddir_or_pubkey`: either 9 or 33 bytes referencing or identifying a node, respectively
+ * if the first byte is 0 or 1, then an 8-byte `short_channel_id` follows for a total of 9 bytes
+ * 0 for the first byte indicates this refers to `node_id_1` in the `channel_announcement` for `short_channel_id`
+ * 1 for the first byte indicates this refers to `node_id_2` in the `channel_announcement` for `short_channel_id`
+ (see [BOLT #7](07-routing-gossip.md#the-channel_announcement-message)
+ * if the first byte is 2 or 3, then the value is a 33-byte `point`
+* `bigsize`: a variable-length, unsigned integer similar to Bitcoin's CompactSize encoding, but big-endian. Described in [BigSize](#appendix-a-bigsize-test-vectors).
+* `utf8`: a byte as part of a UTF-8 string. A writer MUST ensure an array of these is a valid UTF-8 string, a reader MAY reject any messages containing an array of these which is not a valid UTF-8 string.
## Setup Messages
### The `init` Message
-Once authentication is complete, the first message reveals the features
-supported or required by this node, even if this is a reconnection.
+Once authentication is complete, the first message reveals the features supported or required by this node, even if this is a reconnection.
-[BOLT #9](09-features.md) specifies lists of features. Each feature is
-generally represented by 2 bits. The least-significant bit is numbered 0,
-which is _even_, and the next most significant bit is numbered 1, which is
-_odd_. For historical reasons, features are divided into global and local
-feature bitmasks.
+[BOLT #9](09-features.md) specifies lists of features. Each feature is generally represented by 2 bits. The least-significant bit is numbered 0, which is _even_, and the next most significant bit is numbered 1, which is _odd_. For historical reasons, features are divided into global and local feature bitmasks.
-A feature is *offered* if a peer set it in the `init` message for the current
-connection (as either even or odd). A feature is *negotiated* if either both
-peers offered it, or the local node offered it as even: it can assume the peer
-supports it, as it did not disconnect as it would be required to do.
+A feature is *offered* if a peer set it in the `init` message for the current connection (as either even or odd). A feature is *negotiated* if either both peers offered it, or the local node offered it as even: it can assume the peer supports it, as it did not disconnect as it would be required to do.
The `features` field MUST be padded to bytes with 0s.
@@ -299,10 +294,57 @@ The `features` field MUST be padded to bytes with 0s.
2. data:
* [`...*byte`:`data`]
+The optional `networks` indicates the chains the node is interested in.
+The optional `remote_addr` can be used to circumvent NAT issues.
+
+#### Requirements
+
+The sending node:
+ - MUST send `init` as the first Lightning message for any connection.
+ - MUST set feature bits as defined in [BOLT #9](09-features.md).
+ - MUST set any undefined feature bits to 0.
+ - SHOULD NOT set features greater than 13 in `globalfeatures`.
+ - SHOULD use the minimum length required to represent the `features` field.
+ - SHOULD set `networks` to all chains it will gossip or open channels for.
+ - SHOULD set `remote_addr` to reflect the remote IP address (and port) of an
+ incoming connection, if the node is the receiver and the connection was done
+ via IP.
+ - if it sets `remote_addr`:
+ - MUST set it to a valid `address descriptor` (1 byte type and data) as described in [BOLT 7](07-routing-gossip.md#the-node_announcement-message).
+ - SHOULD NOT set private addresses as `remote_addr`.
+
+The receiving node:
+ - MUST wait to receive `init` before sending any other messages.
+ - MUST combine (bitwise OR) the two feature bitmaps into one logical `features` map.
+ - MUST respond to known feature bits as specified in [BOLT #9](09-features.md).
+ - upon receiving unknown _odd_ feature bits that are non-zero:
+ - MUST ignore the bit.
+ - upon receiving unknown _even_ feature bits that are non-zero:
+ - MUST close the connection.
+ - upon receiving `networks` containing no common chains
+ - MAY close the connection.
+ - if the feature vector does not set all known, transitive dependencies:
+ - MUST close the connection.
+ - MAY use the `remote_addr` to update its `node_announcement`
+
+#### Rationale
+
+There used to be two feature bitfields here, but for backwards compatibility they're now
+combined into one.
+
+This semantic allows both future incompatible changes and future backward compatible changes. Bits should generally be assigned in pairs, in order that optional features may later become compulsory.
+
+Nodes wait for receipt of the other's features to simplify error
+diagnosis when features are incompatible.
+
+Since all networks share the same port, but most implementations only
+support a single network, the `networks` fields avoids nodes
+erroneously believing they will receive updates about their preferred
+network, or that they can open channels.
+
### The `error` and `warning` Messages
-For simplicity of diagnosis, it's often useful to tell a peer that something
-is incorrect.
+For simplicity of diagnosis, it's often useful to tell a peer that something is incorrect.
1. type: 17 (`error`)
2. data:
@@ -316,13 +358,74 @@ is incorrect.
* [`u16`:`len`]
* [`len*byte`:`data`]
+#### Requirements
+
+The channel is referred to by `channel_id`, unless `channel_id` is 0 (i.e. all bytes are 0), in which case it refers to all channels.
+
+The funding node using channel establishment v1 (`open_channel`):
+ - for all error messages sent before (and including) the `funding_created` message:
+ - MUST use `temporary_channel_id` in lieu of `channel_id`.
+
+The fundee node using channel establishment v1 (`accept_channel`):
+ - for all error messages sent before (and not including) the `funding_signed` message:
+ - MUST use `temporary_channel_id` in lieu of `channel_id`.
+
+The opener node using channel establishment v2 (`open_channel2`):
+ - for all error messages sent before the `accept_channel2` message is received:
+ - MUST use `temporary_channel_id` in lieu of `channel_id`.
+
+The accepter node using channel establishment v2 (`open_channel2`):
+ - for all error messages sent before (and including) the `accept_channel2` message:
+ - MUST use `temporary_channel_id` in lieu of `channel_id`.
+
+A sending node:
+ - SHOULD send `error` for protocol violations or internal errors that make channels unusable or that make further communication unusable.
+ - SHOULD send `error` with the unknown `channel_id` in reply to messages of type `32`-`255` related to unknown channels.
+ - when sending `error`:
+ - MUST fail the channel(s) referred to by the error message.
+ - MAY set `channel_id` to all zero to indicate all channels.
+ - when sending `warning`:
+ - MAY set `channel_id` to all zero if the warning is not related to a specific channel.
+ - MAY send an empty `data` field.
+ - when failure was caused by an invalid signature check:
+ - SHOULD include the raw, hex-encoded transaction in reply to a `funding_created`, `funding_signed`, `closing_signed`, or `commitment_signed` message.
+
+The receiving node:
+ - upon receiving `error`:
+ - if `channel_id` is all zero:
+ - MUST fail all channels with the sending node.
+ - otherwise:
+ - MUST fail the channel referred to by `channel_id`, if that channel is with the sending node.
+ - upon receiving `warning`:
+ - SHOULD log the message for later diagnosis.
+ - MAY attempt `shutdown` if permitted at this point.
+ - if no existing channel is referred to by `channel_id`:
+ - MUST ignore the message.
+ - if `data` is not composed solely of printable ASCII characters (For reference: the printable character set includes byte values 32 through 126, inclusive):
+ - SHOULD NOT print out `data` verbatim.
+
+#### Rationale
+
+There are unrecoverable errors that require an abort of conversations;
+if the connection is simply dropped, then the peer may retry the
+connection. It's also useful to describe protocol violations for
+diagnosis, as this indicates that one peer has a bug.
+
+On the other hand, overuse of error messages has lead to
+implementations ignoring them (to avoid an otherwise expensive channel
+break), so the "warning" message was added to allow some degree of
+retry or recovery for spurious errors.
+
+It may be wise not to distinguish errors in production settings, lest
+it leak information — hence, the optional `data` field.
+
## Control Messages
### The `ping` and `pong` Messages
-In order to allow for the existence of long-lived TCP connections, at times it
-may be required that both ends keep alive the TCP connection at the application
-level. Such messages also allow obfuscation of traffic patterns.
+In order to allow for the existence of long-lived TCP connections, at
+times it may be required that both ends keep alive the TCP connection at the
+application level. Such messages also allow obfuscation of traffic patterns.
1. type: 18 (`ping`)
2. data:
@@ -330,34 +433,160 @@ level. Such messages also allow obfuscation of traffic patterns.
* [`u16`:`byteslen`]
* [`byteslen*byte`:`ignored`]
+The `pong` message is to be sent whenever a `ping` message is received. It
+serves as a reply and also serves to keep the connection alive, while
+explicitly notifying the other end that the receiver is still active. Within
+the received `ping` message, the sender will specify the number of bytes to be
+included within the data payload of the `pong` message.
+
1. type: 19 (`pong`)
2. data:
* [`u16`:`byteslen`]
* [`byteslen*byte`:`ignored`]
-## Peer Storage
+#### Requirements
+
+A node sending a `ping` message:
+ - SHOULD set `ignored` to 0s.
+ - MUST NOT set `ignored` to sensitive data such as secrets or portions of initialized
+memory.
+ - if it doesn't receive a corresponding `pong`:
+ - MAY close the network connection,
+ - and MUST NOT fail the channels in this case.
+
+A node sending a `pong` message:
+ - SHOULD set `ignored` to 0s.
+ - MUST NOT set `ignored` to sensitive data such as secrets or portions of initialized
+ memory.
+
+A node receiving a `ping` message:
+ - if `num_pong_bytes` is less than 65532:
+ - MUST respond by sending a `pong` message, with `byteslen` equal to `num_pong_bytes`.
+ - otherwise (`num_pong_bytes` is **not** less than 65532):
+ - MUST ignore the `ping`.
+
+A node receiving a `pong` message:
+ - if `byteslen` does not correspond to any `ping`'s `num_pong_bytes` value it has sent:
+ - MAY close the connection.
+
+### Rationale
+
+The largest possible message is 65535 bytes; thus, the maximum sensible `byteslen`
+is 65531 — in order to account for the type field (`pong`) and the `byteslen` itself. This allows
+a convenient cutoff for `num_pong_bytes` to indicate that no reply should be sent.
+
+Connections between nodes within the network may be long lived, as payment
+channels have an indefinite lifetime. However, it's likely that
+no new data will be
+exchanged for a
+significant portion of a connection's lifetime. Also, on several platforms it's possible that Lightning
+clients will be put to sleep without prior warning. Hence, a
+distinct `ping` message is used, in order to probe for the liveness of the connection on
+the other side, as well as to keep the established connection active.
+
+Additionally, the ability for a sender to request that the receiver send a
+response with a particular number of bytes enables nodes on the network to
+create _synthetic_ traffic. Such traffic can be used to partially defend
+against packet and timing analysis — as nodes can fake the traffic patterns of
+typical exchanges without applying any true updates to their respective
+channels.
+
+When combined with the onion routing protocol defined in
+[BOLT #4](04-onion-routing.md),
+careful statistically driven synthetic traffic can serve to further bolster the
+privacy of participants within the network.
+
+Limited precautions are recommended against `ping` flooding, however some
+latitude is given because of network delays. Note that there are other methods
+of incoming traffic flooding (e.g. sending _odd_ unknown message types, or padding
+every message maximally).
+
+Finally, the usage of periodic `ping` messages serves to promote frequent key
+rotations as specified within [BOLT #8](08-transport.md).
+
+## Peer storage
### The `peer_storage` and `peer_storage_retrieval` Messages
Nodes that advertise the `option_provide_storage` feature offer storing
-arbitrary data for their peers.
+arbitrary data for their peers. The data stored must not exceed 65531 bytes,
+which lets it fit in lightning messages.
+
+Nodes can verify that their `option_provide_storage` peers correctly store
+their data at each reconnection, by comparing the contents of the
+retrieved data with the last one they sent. However, nodes should not expect
+their peers to always have their latest data available.
+
+Nodes ask their peers to store data using the `peer_storage` message and expect
+peers to return the latest data to them using the `peer_storage_retrieval` message:
1. type: 7 (`peer_storage`)
2. data:
* [`u16`:`length`]
* [`length*byte`:`blob`]
+
1. type: 9 (`peer_storage_retrieval`)
2. data:
* [`u16`:`length`]
* [`length*byte`:`blob`]
+
+Requirements:
+
+The sender of `peer_storage`:
+ - MAY send `peer_storage` whenever necessary.
+ - MUST limit its `blob` to 65531 bytes.
+ - MUST encrypt the data in a manner that ensures its integrity upon receipt.
+ - SHOULD pad the `blob` to ensure its length is always exactly 65531 bytes.
+
+The receiver of `peer_storage`:
+ - If it offered `option_provide_storage`:
+ - if it has an open channel with the sender:
+ - MUST store the message.
+ - MAY store the message anyway.
+
+- If it does store the message:
+ - MAY delay storage to ratelimit peer to no more than one update per minute.
+ - MUST replace the old `blob` with the latest received.
+ - MUST send `peer_storage_retrieval` again after reconnection, after exchanging `init` messages.
+
+
+The sender of `peer_storage_retrieval`:
+ - MUST include the last `blob` it stored for that peer.
+ - when all channels with that peer are closed:
+ - SHOULD wait at least 2016 blocks before deleting the `blob`.
+
+The receiver of `peer_storage_retrieval`:
+ - when it receives `peer_storage_retrieval` with an outdated or irrelevant data:
+ - MAY send a warning.
+
+#### Rationale:
+The `peer_storage` and `peer_storage_retrieval` messages enable nodes to securely store
+and share data with other nodes in the network, serving as a backup mechanism for important
+information. By utilizing them, nodes can safeguard crucial data, enhancing the network's
+resilience and reliability. Additionally, even if we don't have an open channel, some nodes
+might provide this service in exchange for some sats so they may store `peer_storage`.
+
+Nodes should pad the `blob` to obscure its actual size, enhancing privacy by making size-based
+analysis more difficult for the receiver.
+
+`peer_storage_retrieval` should not be sent after `channel_reestablish` because then the user
+wouldn't have an option to recover the node and update its state in case they lost data.
+
+Nodes should send a `peer_storage` message whenever they wish to update the `blob` stored with their peers.
+This `blob` can be used to distribute encrypted data, which could be helpful in restoring the node.
+
## Appendix A: BigSize Test Vectors
+The following test vectors can be used to assert the correctness of a BigSize
+implementation used in the TLV format. The format is identical to the
+CompactSize encoding used in bitcoin, but replaces the little-endian encoding of
+multi-byte values with big-endian.
+
Values encoded with BigSize will produce an encoding of either 1, 3, 5, or 9
bytes depending on the size of the integer. The encoding is a piece-wise
function that takes a `uint64` value `x` and produces:
-
```
uint8(x) if x < 0xfd
0xfd + be16(uint16(x)) if x < 0x10000
@@ -365,57 +594,584 @@ function that takes a `uint64` value `x` and produces:
0xff + be64(x) otherwise.
```
+Here `+` denotes concatenation and `be16`, `be32`, and `be64` produce a
+big-endian encoding of the input for 16, 32, and 64-bit integers, respectively.
+
+A value is said to be _minimally encoded_ if it could not be encoded using
+fewer bytes. For example, a BigSize encoding that occupies 5 bytes
+but whose value is less than 0x10000 is not minimally encoded. All values
+decoded with BigSize should be checked to ensure they are minimally encoded.
+
### BigSize Decoding Tests
+The following is an example of how to execute the BigSize decoding tests.
+```golang
+func testReadBigSize(t *testing.T, test bigSizeTest) {
+ var buf [8]byte
+ r := bytes.NewReader(test.Bytes)
+ val, err := tlv.ReadBigSize(r, &buf)
+ if err != nil && err.Error() != test.ExpErr {
+ t.Fatalf("expected decoding error: %v, got: %v",
+ test.ExpErr, err)
+ }
+
+ // If we expected a decoding error, there's no point checking the value.
+ if test.ExpErr != "" {
+ return
+ }
+
+ if val != test.Value {
+ t.Fatalf("expected value: %d, got %d", test.Value, val)
+ }
+}
+```
+
+A correct implementation should pass against these test vectors:
+```json
+[
+ {
+ "name": "zero",
+ "value": 0,
+ "bytes": "00"
+ },
+ {
+ "name": "one byte high",
+ "value": 252,
+ "bytes": "fc"
+ },
+ {
+ "name": "two byte low",
+ "value": 253,
+ "bytes": "fd00fd"
+ },
+ {
+ "name": "two byte high",
+ "value": 65535,
+ "bytes": "fdffff"
+ },
+ {
+ "name": "four byte low",
+ "value": 65536,
+ "bytes": "fe00010000"
+ },
+ {
+ "name": "four byte high",
+ "value": 4294967295,
+ "bytes": "feffffffff"
+ },
+ {
+ "name": "eight byte low",
+ "value": 4294967296,
+ "bytes": "ff0000000100000000"
+ },
+ {
+ "name": "eight byte high",
+ "value": 18446744073709551615,
+ "bytes": "ffffffffffffffffff"
+ },
+ {
+ "name": "two byte not canonical",
+ "value": 0,
+ "bytes": "fd00fc",
+ "exp_error": "decoded bigsize is not canonical"
+ },
+ {
+ "name": "four byte not canonical",
+ "value": 0,
+ "bytes": "fe0000ffff",
+ "exp_error": "decoded bigsize is not canonical"
+ },
+ {
+ "name": "eight byte not canonical",
+ "value": 0,
+ "bytes": "ff00000000ffffffff",
+ "exp_error": "decoded bigsize is not canonical"
+ },
+ {
+ "name": "two byte short read",
+ "value": 0,
+ "bytes": "fd00",
+ "exp_error": "unexpected EOF"
+ },
+ {
+ "name": "four byte short read",
+ "value": 0,
+ "bytes": "feffff",
+ "exp_error": "unexpected EOF"
+ },
+ {
+ "name": "eight byte short read",
+ "value": 0,
+ "bytes": "ffffffffff",
+ "exp_error": "unexpected EOF"
+ },
+ {
+ "name": "one byte no read",
+ "value": 0,
+ "bytes": "",
+ "exp_error": "EOF"
+ },
+ {
+ "name": "two byte no read",
+ "value": 0,
+ "bytes": "fd",
+ "exp_error": "unexpected EOF"
+ },
+ {
+ "name": "four byte no read",
+ "value": 0,
+ "bytes": "fe",
+ "exp_error": "unexpected EOF"
+ },
+ {
+ "name": "eight byte no read",
+ "value": 0,
+ "bytes": "ff",
+ "exp_error": "unexpected EOF"
+ }
+]
+```
+
+### BigSize Encoding Tests
+
+The following is an example of how to execute the BigSize encoding tests.
+```golang
+func testWriteBigSize(t *testing.T, test bigSizeTest) {
+ var (
+ w bytes.Buffer
+ buf [8]byte
+ )
+ err := tlv.WriteBigSize(&w, test.Value, &buf)
+ if err != nil {
+ t.Fatalf("unable to encode %d as bigsize: %v",
+ test.Value, err)
+ }
+
+ if bytes.Compare(w.Bytes(), test.Bytes) != 0 {
+ t.Fatalf("expected bytes: %v, got %v",
+ test.Bytes, w.Bytes())
+ }
+}
+```
+
+A correct implementation should pass against the following test vectors:
```json
[
- { "name": "zero", "value": 0, "bytes": "00" },
- { "name": "one byte high", "value": 252, "bytes": "fc" },
- { "name": "two byte low", "value": 253, "bytes": "fd00fd" },
- { "name": "two byte high", "value": 65535, "bytes": "fdffff" },
- { "name": "four byte low", "value": 65536, "bytes": "fe00010000" },
- { "name": "four byte high", "value": 4294967295, "bytes": "feffffffff" },
- { "name": "eight byte low", "value": 4294967296,
- "bytes": "ff0000000100000000" },
- { "name": "eight byte high", "value": 18446744073709551615,
- "bytes": "ffffffffffffffffff" }
+ {
+ "name": "zero",
+ "value": 0,
+ "bytes": "00"
+ },
+ {
+ "name": "one byte high",
+ "value": 252,
+ "bytes": "fc"
+ },
+ {
+ "name": "two byte low",
+ "value": 253,
+ "bytes": "fd00fd"
+ },
+ {
+ "name": "two byte high",
+ "value": 65535,
+ "bytes": "fdffff"
+ },
+ {
+ "name": "four byte low",
+ "value": 65536,
+ "bytes": "fe00010000"
+ },
+ {
+ "name": "four byte high",
+ "value": 4294967295,
+ "bytes": "feffffffff"
+ },
+ {
+ "name": "eight byte low",
+ "value": 4294967296,
+ "bytes": "ff0000000100000000"
+ },
+ {
+ "name": "eight byte high",
+ "value": 18446744073709551615,
+ "bytes": "ffffffffffffffffff"
+ }
]
```
+## Appendix B: Type-Length-Value Test Vectors
+
+The following tests assume that two separate TLV namespaces exist: n1 and n2.
+
+The n1 namespace supports the following TLV types:
+
+1. `tlv_stream`: `n1`
+2. types:
+ 1. type: 1 (`tlv1`)
+ 2. data:
+ * [`tu64`:`amount_msat`]
+ 1. type: 2 (`tlv2`)
+ 2. data:
+ * [`short_channel_id`:`scid`]
+ 1. type: 3 (`tlv3`)
+ 2. data:
+ * [`point`:`node_id`]
+ * [`u64`:`amount_msat_1`]
+ * [`u64`:`amount_msat_2`]
+ 1. type: 254 (`tlv4`)
+ 2. data:
+ * [`u16`:`cltv_delta`]
+
+The n2 namespace supports the following TLV types:
+
+1. `tlv_stream`: `n2`
+2. types:
+ 1. type: 0 (`tlv1`)
+ 2. data:
+ * [`tu64`:`amount_msat`]
+ 1. type: 11 (`tlv2`)
+ 2. data:
+ * [`tu32`:`cltv_expiry`]
+
+### TLV Decoding Failures
+
+The following TLV streams in any namespace should trigger a decoding failure:
+
+1. Invalid stream: 0xfd
+2. Reason: type truncated
+
+1. Invalid stream: 0xfd01
+2. Reason: type truncated
+
+1. Invalid stream: 0xfd0001 00
+2. Reason: not minimally encoded type
+
+1. Invalid stream: 0xfd0101
+2. Reason: missing length
+
+1. Invalid stream: 0x0f fd
+2. Reason: (length truncated)
+
+1. Invalid stream: 0x0f fd26
+2. Reason: (length truncated)
+
+1. Invalid stream: 0x0f fd2602
+2. Reason: missing value
+
+1. Invalid stream: 0x0f fd0001 00
+2. Reason: not minimally encoded length
+
+1. Invalid stream: 0x0f fd0201 000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+2. Reason: value truncated
+
+The following TLV streams in either namespace should trigger a
+decoding failure:
+
+1. Invalid stream: 0x12 00
+2. Reason: unknown even type.
+
+1. Invalid stream: 0xfd0102 00
+2. Reason: unknown even type.
+
+1. Invalid stream: 0xfe01000002 00
+2. Reason: unknown even type.
+
+1. Invalid stream: 0xff0100000000000002 00
+2. Reason: unknown even type.
+
+The following TLV streams in namespace `n1` should trigger a decoding
+failure:
+
+1. Invalid stream: 0x01 09 ffffffffffffffffff
+2. Reason: greater than encoding length for `n1`s `tlv1`.
+
+1. Invalid stream: 0x01 01 00
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 02 0001
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 03 000100
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 04 00010000
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 05 0001000000
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 06 000100000000
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 07 00010000000000
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x01 08 0001000000000000
+2. Reason: encoding for `n1`s `tlv1`s `amount_msat` is not minimal
+
+1. Invalid stream: 0x02 07 01010101010101
+2. Reason: less than encoding length for `n1`s `tlv2`.
+
+1. Invalid stream: 0x02 09 010101010101010101
+2. Reason: greater than encoding length for `n1`s `tlv2`.
+
+1. Invalid stream: 0x03 21 023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb
+2. Reason: less than encoding length for `n1`s `tlv3`.
+
+1. Invalid stream: 0x03 29 023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb0000000000000001
+2. Reason: less than encoding length for `n1`s `tlv3`.
+
+1. Invalid stream: 0x03 30 023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb000000000000000100000000000001
+2. Reason: less than encoding length for `n1`s `tlv3`.
+
+1. Invalid stream: 0x03 31 043da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb00000000000000010000000000000002
+2. Reason: `n1`s `node_id` is not a valid point.
+
+1. Invalid stream: 0x03 32 023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb0000000000000001000000000000000001
+2. Reason: greater than encoding length for `n1`s `tlv3`.
+
+1. Invalid stream: 0xfd00fe 00
+2. Reason: less than encoding length for `n1`s `tlv4`.
+
+1. Invalid stream: 0xfd00fe 01 01
+2. Reason: less than encoding length for `n1`s `tlv4`.
+
+1. Invalid stream: 0xfd00fe 03 010101
+2. Reason: greater than encoding length for `n1`s `tlv4`.
+
+1. Invalid stream: 0x00 00
+2. Reason: unknown even field for `n1`s namespace.
+
+### TLV Decoding Successes
+
+The following TLV streams in either namespace should correctly decode,
+and be ignored:
+
+1. Valid stream: 0x
+2. Explanation: empty message
+
+1. Valid stream: 0x21 00
+2. Explanation: Unknown odd type.
+
+1. Valid stream: 0xfd0201 00
+2. Explanation: Unknown odd type.
+
+1. Valid stream: 0xfd00fd 00
+2. Explanation: Unknown odd type.
+
+1. Valid stream: 0xfd00ff 00
+2. Explanation: Unknown odd type.
+
+1. Valid stream: 0xfe02000001 00
+2. Explanation: Unknown odd type.
+
+1. Valid stream: 0xff0200000000000001 00
+2. Explanation: Unknown odd type.
+
+The following TLV streams in `n1` namespace should correctly decode,
+with the values given here:
+
+1. Valid stream: 0x01 00
+2. Values: `tlv1` `amount_msat`=0
+
+1. Valid stream: 0x01 01 01
+2. Values: `tlv1` `amount_msat`=1
+
+1. Valid stream: 0x01 02 0100
+2. Values: `tlv1` `amount_msat`=256
+
+1. Valid stream: 0x01 03 010000
+2. Values: `tlv1` `amount_msat`=65536
+
+1. Valid stream: 0x01 04 01000000
+2. Values: `tlv1` `amount_msat`=16777216
+
+1. Valid stream: 0x01 05 0100000000
+2. Values: `tlv1` `amount_msat`=4294967296
+
+1. Valid stream: 0x01 06 010000000000
+2. Values: `tlv1` `amount_msat`=1099511627776
+
+1. Valid stream: 0x01 07 01000000000000
+2. Values: `tlv1` `amount_msat`=281474976710656
+
+1. Valid stream: 0x01 08 0100000000000000
+2. Values: `tlv1` `amount_msat`=72057594037927936
+
+1. Valid stream: 0x02 08 0000000000000226
+2. Values: `tlv2` `scid`=0x0x550
+
+1. Valid stream: 0x03 31 023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb00000000000000010000000000000002
+2. Values: `tlv3` `node_id`=023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb `amount_msat_1`=1 `amount_msat_2`=2
+
+1. Valid stream: 0xfd00fe 02 0226
+2. Values: `tlv4` `cltv_delta`=550
+
+### TLV Stream Decoding Failure
+
+Any appending of an invalid stream to a valid stream should trigger
+a decoding failure.
+
+Any appending of a higher-numbered valid stream to a lower-numbered
+valid stream should not trigger a decoding failure.
+
+In addition, the following TLV streams in namespace `n1` should
+trigger a decoding failure:
+
+1. Invalid stream: 0x02 08 0000000000000226 01 01 2a
+2. Reason: valid TLV records but invalid ordering
+
+1. Invalid stream: 0x02 08 0000000000000231 02 08 0000000000000451
+2. Reason: duplicate TLV type
+
+1. Invalid stream: 0x1f 00 0f 01 2a
+2. Reason: valid (ignored) TLV records but invalid ordering
+
+1. Invalid stream: 0x1f 00 1f 01 2a
+2. Reason: duplicate TLV type (ignored)
+
+The following TLV stream in namespace `n2` should trigger a decoding
+failure:
+
+1. Invalid stream: 0xffffffffffffffffff 00 00 00
+2. Reason: valid TLV records but invalid ordering
+
+## Appendix C: Message Extension
+
+This section contains examples of valid and invalid extensions on the `init`
+message. The base `init` message (without extensions) for these examples is
+`0x001000000000` (all features turned off).
+
+The following `init` messages are valid:
+
+- `0x001000000000`: no extension provided
+- `0x001000000000c9012acb0104`: the extension contains two unknown _odd_ TLV records (with types `0xc9` and `0xcb`)
+
+The following `init` messages are invalid:
+
+- `0x00100000000001`: the extension is present but truncated
+- `0x001000000000ca012a`: the extension contains unknown _even_ TLV records (assuming that TLV type `0xca` is unknown)
+- `0x001000000000c90101c90102`: the extension TLV stream is invalid (duplicate TLV record type `0xc9`)
+
+Note that when messages are signed, the _extension_ is part of the signed bytes.
+Nodes should store the _extension_ bytes even if they don't understand them to
+be able to correctly verify signatures.
+
## Appendix D: Signed Integers Test Vectors
+The following test vector show how signed integers (`s8`, `s16`, `s32`
+and `s64`) are encoded using big-endian two's complement.
+
```json
[
- { "value": 0, "bytes": "00" },
- { "value": 42, "bytes": "2a" },
- { "value": -42, "bytes": "d6" },
- { "value": 127, "bytes": "7f" },
- { "value": -128, "bytes": "80" },
- { "value": 128, "bytes": "0080" },
- { "value": -129, "bytes": "ff7f" },
- { "value": 15000, "bytes": "3a98" },
- { "value": -15000, "bytes": "c568" },
- { "value": 32767, "bytes": "7fff" },
- { "value": -32768, "bytes": "8000" },
- { "value": 32768, "bytes": "00008000" },
- { "value": -32769, "bytes": "ffff7fff" },
- { "value": 21000000, "bytes": "01406f40" },
- { "value": -21000000, "bytes": "febf90c0" },
- { "value": 2147483647, "bytes": "7fffffff" },
- { "value": -2147483648, "bytes": "80000000" },
- { "value": 2147483648, "bytes": "0000000080000000" },
- { "value": -2147483649, "bytes": "ffffffff7fffffff" },
- { "value": 500000000000, "bytes": "000000746a528800" },
- { "value": -500000000000, "bytes": "ffffff8b95ad7800" },
- { "value": 9223372036854775807, "bytes": "7fffffffffffffff" },
- { "value": -9223372036854775808, "bytes": "8000000000000000" }
+ {
+ "value": 0,
+ "bytes": "00"
+ },
+ {
+ "value": 42,
+ "bytes": "2a"
+ },
+ {
+ "value": -42,
+ "bytes": "d6"
+ },
+ {
+ "value": 127,
+ "bytes": "7f"
+ },
+ {
+ "value": -128,
+ "bytes": "80"
+ },
+ {
+ "value": 128,
+ "bytes": "0080"
+ },
+ {
+ "value": -129,
+ "bytes": "ff7f"
+ },
+ {
+ "value": 15000,
+ "bytes": "3a98"
+ },
+ {
+ "value": -15000,
+ "bytes": "c568"
+ },
+ {
+ "value": 32767,
+ "bytes": "7fff"
+ },
+ {
+ "value": -32768,
+ "bytes": "8000"
+ },
+ {
+ "value": 32768,
+ "bytes": "00008000"
+ },
+ {
+ "value": -32769,
+ "bytes": "ffff7fff"
+ },
+ {
+ "value": 21000000,
+ "bytes": "01406f40"
+ },
+ {
+ "value": -21000000,
+ "bytes": "febf90c0"
+ },
+ {
+ "value": 2147483647,
+ "bytes": "7fffffff"
+ },
+ {
+ "value": -2147483648,
+ "bytes": "80000000"
+ },
+ {
+ "value": 2147483648,
+ "bytes": "0000000080000000"
+ },
+ {
+ "value": -2147483649,
+ "bytes": "ffffffff7fffffff"
+ },
+ {
+ "value": 500000000000,
+ "bytes": "000000746a528800"
+ },
+ {
+ "value": -500000000000,
+ "bytes": "ffffff8b95ad7800"
+ },
+ {
+ "value": 9223372036854775807,
+ "bytes": "7fffffffffffffff"
+ },
+ {
+ "value": -9223372036854775808,
+ "bytes": "8000000000000000"
+ }
]
```
+## Acknowledgments
+
+[ TODO: (roasbeef); fin ]
+
## References
1. <a id="reference-1">http://www.unicode.org/charts/PDF/U2600.pdf</a>
+## Authors
+
+[ FIXME: Insert Author List ]
+
<br>
This work is licensed under a [Creative Commons Attribution 4.0 International License](http://creativecommons.org/licenses/by/4.0/).
diff --git a/flake.lock b/flake.lock
@@ -65,6 +65,37 @@
"url": "git://git.ppad.tech/base16.git"
}
},
+ "ppad-bolt9": {
+ "inputs": {
+ "flake-utils": [
+ "ppad-bolt9",
+ "ppad-nixpkgs",
+ "flake-utils"
+ ],
+ "nixpkgs": [
+ "ppad-bolt9",
+ "ppad-nixpkgs",
+ "nixpkgs"
+ ],
+ "ppad-nixpkgs": [
+ "ppad-nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1791624953,
+ "narHash": "sha256-DWafVJvu2LTXkAI/zH0Q0BqTrjLo0c7hyTvaW/9N0VM=",
+ "ref": "master",
+ "rev": "280946ab905a374c8c6d4a37678a4cc362551ab9",
+ "revCount": 39,
+ "type": "git",
+ "url": "git://git.ppad.tech/bolt9.git"
+ },
+ "original": {
+ "ref": "master",
+ "type": "git",
+ "url": "git://git.ppad.tech/bolt9.git"
+ }
+ },
"ppad-nixpkgs": {
"inputs": {
"flake-utils": "flake-utils",
@@ -96,6 +127,7 @@
"nixpkgs"
],
"ppad-base16": "ppad-base16",
+ "ppad-bolt9": "ppad-bolt9",
"ppad-nixpkgs": "ppad-nixpkgs"
}
},
diff --git a/flake.nix b/flake.nix
@@ -8,6 +8,12 @@
ref = "master";
inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
};
+ ppad-bolt9 = {
+ type = "git";
+ url = "git://git.ppad.tech/bolt9.git";
+ ref = "master";
+ inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
+ };
ppad-nixpkgs = {
type = "git";
url = "git://git.ppad.tech/nixpkgs.git";
@@ -17,7 +23,8 @@
nixpkgs.follows = "ppad-nixpkgs/nixpkgs";
};
- outputs = { self, nixpkgs, flake-utils, ppad-nixpkgs, ppad-base16 }:
+ outputs = { self, nixpkgs, flake-utils, ppad-nixpkgs, ppad-base16
+ , ppad-bolt9 }:
flake-utils.lib.eachDefaultSystem (system:
let
lib = "ppad-bolt1";
@@ -33,10 +40,14 @@
(hlib.enableCabalFlag base16 "llvm")
[ llvm clang ];
+ bolt9 = ppad-bolt9.packages.${system}.default;
+
hpkgs = pkgs.haskell.packages.ghc910.extend (new: old: {
ppad-base16 = base16-llvm;
+ ppad-bolt9 = bolt9;
${lib} = new.callCabal2nix lib ./. {
ppad-base16 = new.ppad-base16;
+ ppad-bolt9 = new.ppad-bolt9;
};
});
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
@@ -4,748 +4,545 @@ module Main where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
-import Data.Word (Word64)
+import qualified Data.ByteString.Char8 as B8
+import Data.Int (Int64)
+import qualified Data.List as L
+import Data.Maybe (fromMaybe, isJust, isNothing)
+import Data.Word (Word16, Word32, Word64)
import Lightning.Protocol.BOLT1
-import Lightning.Protocol.BOLT1.Internal
- (unsafeChannelId, unsafeChainHash, unsafeMsgUnknown)
+import qualified Lightning.Protocol.BOLT9 as BOLT9
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
main :: IO ()
main = defaultMain $ testGroup "ppad-bolt1" [
- bigsize_tests
- , primitive_tests
- , signed_tests
- , truncated_tests
- , minsigned_tests
- , tlv_tests
- , message_tests
- , envelope_tests
- , extension_tests
- , bounds_tests
- , property_tests
+ appendix_a
+ , appendix_b
+ , appendix_c
+ , appendix_d
+ , primitives
+ , tlv
+ , messages
+ , properties
]
--- 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
- ]
+-- helpers --------------------------------------------------------------------
--- 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
- ]
+-- run an assertion on decoded hex (spaces and a 0x prefix are allowed),
+-- failing the test if the literal isn't valid hex
+with_hex :: String -> (BS.ByteString -> Assertion) -> Assertion
+with_hex s k = case B16.decode (B8.pack (strip s)) of
+ Nothing -> assertFailure ("invalid hex literal: " ++ s)
+ Just bs -> k bs
+ where
+ strip = filter (/= ' ') . drop0x
+ drop0x ('0':'x':r) = r
+ drop0x r = r
--- 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, "")
- ]
+is_left :: Either a b -> Bool
+is_left = either (const True) (const False)
--- 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
- ]
+empty_fv :: BOLT9.FeatureVector
+empty_fv = BOLT9.parse ""
--- 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
- ]
+-- Appendix A: BigSize --------------------------------------------------------
--- 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
+appendix_a :: TestTree
+appendix_a = testGroup "Appendix A (BigSize)" [
+ testGroup "decoding" (map dec ok_vectors)
+ , testGroup "encoding" (map enc ok_vectors)
+ , testGroup "decoding failures" (map bad bad_vectors)
]
+ where
+ dec (v, h) = testCase ("decode " ++ h) $ with_hex h $ \bs ->
+ decode_bigsize bs @?= Just (v, "")
+ enc (v, h) = testCase ("encode " ++ show v) $ with_hex h $ \bs ->
+ encode_bigsize v @?= bs
+ bad h = testCase ("reject " ++ show h) $ with_hex h $ \bs ->
+ decode_bigsize bs @?= Nothing
--- 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
- ]
+ ok_vectors :: [(Word64, String)]
+ ok_vectors = [
+ (0, "00"), (252, "fc"), (253, "fd00fd"), (65535, "fdffff")
+ , (65536, "fe00010000"), (4294967295, "feffffffff")
+ , (4294967296, "ff0000000100000000")
+ , (18446744073709551615, "ffffffffffffffffff")
+ ]
+
+ -- non-canonical encodings, short reads and no reads
+ bad_vectors = [
+ "fd00fc", "fe0000ffff", "ff00000000ffffffff"
+ , "fd00", "feffff", "ffffffffff"
+ , "", "fd", "fe", "ff"
+ ]
+
+-- Appendix B: TLV ------------------------------------------------------------
+
+-- the n1 and n2 test namespaces, decoded with bolt1's primitives
+
+data N1 = N1Tlv1 !Word64
+ | N1Tlv2 !ShortChannelId
+ | N1Tlv3 !Point !Word64 !Word64
+ | N1Tlv4 !Word16
+ deriving (Eq, Show)
+
+decode_n1 :: BS.ByteString -> Either String [N1]
+decode_n1 bs = do
+ s <- either (Left . show) Right (decode_tlv_stream (`elem` n1_types) bs)
+ sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` n1_types ]
+ where
+ n1_types = [1, 2, 3, 254]
+ one (TlvRecord 1 v) = maybe (Left "tlv1") (Right . N1Tlv1)
+ (decode_tu64 v)
+ one (TlvRecord 2 v) = case decode_short_channel_id v of
+ Just (c, "") -> Right (N1Tlv2 c)
+ _ -> Left "tlv2"
+ one (TlvRecord 3 v) = maybe (Left "tlv3") Right $ do
+ (p, r0) <- decode_point v
+ (a, r1) <- decode_u64 r0
+ (b, r2) <- decode_u64 r1
+ if BS.null r2 then pure (N1Tlv3 p a b) else Nothing
+ one (TlvRecord 254 v) = case decode_u16 v of
+ Just (c, "") -> Right (N1Tlv4 c)
+ _ -> Left "tlv4"
+ one _ = Left "unreachable"
+
+decode_n2 :: BS.ByteString -> Either String [(Word64, Word64)]
+decode_n2 bs = do
+ s <- either (Left . show) Right (decode_tlv_stream (`elem` [0, 11]) bs)
+ sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` [0, 11] ]
+ where
+ one (TlvRecord 0 v) = maybe (Left "tlv1") (Right . (,) 0) (decode_tu64 v)
+ one (TlvRecord 11 v) =
+ maybe (Left "tlv2") (Right . (,) 11 . fromIntegral) (decode_tu32 v)
+ one _ = Left "unreachable"
+
+appendix_b :: TestTree
+appendix_b = testGroup "Appendix B (TLV)" [
+ testGroup "failures in any namespace" [
+ testCase h $ with_hex h $ \bs -> do
+ assertBool "n1" (is_left (decode_n1 bs))
+ assertBool "n2" (is_left (decode_n2 bs))
+ | h <- any_fail ]
+ , testGroup "n1 failures" [
+ testCase h $ with_hex h $ \bs -> assertBool "n1" (is_left (decode_n1 bs))
+ | h <- n1_fail ]
+ , testGroup "n2 failures" [
+ testCase h $ with_hex h $ \bs -> assertBool "n2" (is_left (decode_n2 bs))
+ | h <- n2_fail ]
+ , testGroup "ignored successes" [
+ testCase h $ with_hex h $ \bs -> do
+ decode_n1 bs @?= Right []
+ decode_n2 bs @?= Right []
+ | h <- any_ok ]
+ , testGroup "n1 successes" [
+ testCase h $ with_hex h $ \bs -> decode_n1 bs @?= Right [v]
+ | (h, v) <- n1_ok ]
+ , testCase "n1 tlv3" $ with_hex n1_tlv3 $ \bs ->
+ with_hex node_id $ \pk -> case point pk of
+ Nothing -> assertFailure "bad node_id"
+ Just p -> decode_n1 bs @?= Right [N1Tlv3 p 1 2]
+ , testCase "unknown even types fail when no types are known" $
+ mapM_ (\h -> with_hex h $ \bs ->
+ assertBool h (is_left (decode_tlv_stream (const False) bs)))
+ ["12 00", "fd0102 00", "fe01000002 00", "ff0100000000000002 00"]
+ , testCase "appending a higher-numbered valid stream succeeds" $
+ with_hex "01 01 01" $ \a -> with_hex "fd00fe 02 0226" $ \b ->
+ decode_n1 (a <> b) @?= Right [N1Tlv1 1, N1Tlv4 550]
+ , testCase "appending an invalid stream fails" $
+ with_hex "01 01 01" $ \a -> mapM_ (\h -> with_hex h $ \b ->
+ assertBool h (is_left (decode_n1 (a <> b)))) any_fail
]
+ where
+ any_fail = [
+ "0xfd", "0xfd01", "0xfd0001 00", "0xfd0101", "0x0f fd", "0x0f fd26"
+ , "0x0f fd2602", "0x0f fd0001 00", "0x0f fd0201 " ++ replicate 1024 '0'
+ , "0x12 00", "0xfd0102 00", "0xfe01000002 00"
+ , "0xff0100000000000002 00"
+ ]
+ n1_fail = [
+ "0x01 09 ffffffffffffffffff", "0x01 01 00", "0x01 02 0001"
+ , "0x01 03 000100", "0x01 04 00010000", "0x01 05 0001000000"
+ , "0x01 06 000100000000", "0x01 07 00010000000000"
+ , "0x01 08 0001000000000000", "0x02 07 01010101010101"
+ , "0x02 09 010101010101010101"
+ , "0x03 21 " ++ node_id
+ , "0x03 29 " ++ node_id ++ "0000000000000001"
+ , "0x03 30 " ++ node_id ++ "000000000000000100000000000001"
+ , "0x03 31 04" ++ drop 2 node_id
+ ++ "00000000000000010000000000000002"
+ , "0x03 32 " ++ node_id ++ "0000000000000001000000000000000001"
+ , "0xfd00fe 00", "0xfd00fe 01 01", "0xfd00fe 03 010101", "0x00 00"
+ , "0x02 08 0000000000000226 01 01 2a"
+ , "0x02 08 0000000000000231 02 08 0000000000000451"
+ , "0x1f 00 0f 01 2a", "0x1f 00 1f 01 2a"
+ ]
+ n2_fail = ["0xffffffffffffffffff 00 00 00"]
+ any_ok = [
+ "0x", "0x21 00", "0xfd0201 00", "0xfd00fd 00", "0xfd00ff 00"
+ , "0xfe02000001 00", "0xff0200000000000001 00"
+ ]
+ n1_ok = [
+ ("0x01 00", N1Tlv1 0), ("0x01 01 01", N1Tlv1 1)
+ , ("0x01 02 0100", N1Tlv1 256), ("0x01 03 010000", N1Tlv1 65536)
+ , ("0x01 04 01000000", N1Tlv1 16777216)
+ , ("0x01 05 0100000000", N1Tlv1 4294967296)
+ , ("0x01 06 010000000000", N1Tlv1 1099511627776)
+ , ("0x01 07 01000000000000", N1Tlv1 281474976710656)
+ , ("0x01 08 0100000000000000", N1Tlv1 72057594037927936)
+ , ("0x02 08 0000000000000226", N1Tlv2 (ShortChannelId 0x226))
+ , ("0xfd00fe 02 0226", N1Tlv4 550)
+ ]
+ node_id =
+ "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"
+ n1_tlv3 = "0x03 31 " ++ node_id ++ "00000000000000010000000000000002"
+
+-- Appendix C: message extension ----------------------------------------------
--- 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
+appendix_c :: TestTree
+appendix_c = testGroup "Appendix C (message extension)" [
+ testCase "no extension" $ with_hex "001000000000" $ \bs ->
+ case decode_message bs of
+ Right (MsgInit i) -> do
+ init_networks i @?= Nothing
+ init_tlvs i @?= empty_tlv_stream
+ other -> assertFailure (show other)
+ , testCase "two unknown odd records are kept" $
+ with_hex "001000000000c9012acb0104" $ \bs ->
+ case decode_message bs of
+ Right m@(MsgInit i) -> do
+ map tlv_type (un_tlv_stream (init_tlvs i)) @?= [0xc9, 0xcb]
+ encode_message m @?= Right bs
+ other -> assertFailure (show other)
+ , testCase "truncated extension" $ with_hex "00100000000001" $ \bs ->
+ decode_message bs @?= Left (DecodeTlvError TlvTruncated)
+ , testCase "unknown even record" $ with_hex "001000000000ca012a" $ \bs ->
+ decode_message bs @?= Left (DecodeTlvError (TlvUnknownEvenType 0xca))
+ , testCase "duplicate record" $ with_hex "001000000000c90101c90102" $ \bs ->
+ decode_message bs @?= Left (DecodeTlvError TlvNotStrictlyIncreasing)
]
--- 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
+-- Appendix D: signed integers ------------------------------------------------
+
+appendix_d :: TestTree
+appendix_d = testGroup "Appendix D (signed integers)" [
+ testCase (show v) $ with_hex h $ \bs -> case BS.length bs of
+ 1 -> do
+ encode_s8 (fromIntegral v) @?= bs
+ decode_s8 bs @?= Just (fromIntegral v, "")
+ 2 -> do
+ encode_s16 (fromIntegral v) @?= bs
+ decode_s16 bs @?= Just (fromIntegral v, "")
+ 4 -> do
+ encode_s32 (fromIntegral v) @?= bs
+ decode_s32 bs @?= Just (fromIntegral v, "")
+ 8 -> do
+ encode_s64 v @?= bs
+ decode_s64 bs @?= Just (v, "")
+ _ -> assertFailure "bad vector width"
+ | (v, h) <- vectors ]
+ where
+ vectors :: [(Int64, String)]
+ vectors = [
+ (0, "00"), (42, "2a"), (-42, "d6"), (127, "7f"), (-128, "80")
+ , (128, "0080"), (-129, "ff7f"), (15000, "3a98"), (-15000, "c568")
+ , (32767, "7fff"), (-32768, "8000"), (32768, "00008000")
+ , (-32769, "ffff7fff"), (21000000, "01406f40")
+ , (-21000000, "febf90c0"), (2147483647, "7fffffff")
+ , (-2147483648, "80000000"), (2147483648, "0000000080000000")
+ , (-2147483649, "ffffffff7fffffff"), (500000000000, "000000746a528800")
+ , (-500000000000, "ffffff8b95ad7800")
+ , (9223372036854775807, "7fffffffffffffff")
+ , (-9223372036854775808, "8000000000000000")
+ ]
+
+-- primitives -----------------------------------------------------------------
+
+primitives :: TestTree
+primitives = testGroup "Primitives" [
+ testCase "u16/u32/u64 known answers" $ do
+ encode_u16 0x0102 @?= "\x01\x02"
+ encode_u32 0x01020304 @?= "\x01\x02\x03\x04"
+ encode_u64 0x0102030405060708 @?= "\x01\x02\x03\x04\x05\x06\x07\x08"
+ decode_u32 "\x01\x02\x03\x04rest" @?= Just (0x01020304, "rest")
+ , testCase "short reads fail" $ do
+ decode_u16 "\x01" @?= Nothing
+ decode_u32 "\x01\x02\x03" @?= Nothing
+ decode_u64 "\x01\x02\x03\x04\x05\x06\x07" @?= Nothing
+ decode_s8 "" @?= Nothing
+ , testCase "truncated integers" $ do
+ encode_tu64 0 @?= ""
+ encode_tu64 1 @?= "\x01"
+ encode_tu32 0x010000 @?= "\x01\x00\x00"
+ decode_tu16 "" @?= Just 0
+ decode_tu16 "\x00\x01" @?= Nothing
+ decode_tu16 "\x01\x00\x00" @?= Nothing
+ decode_tu32 "\x01\x00\x00\x00\x00" @?= Nothing
+ decode_tu64 "\x01\x00\x00\x00\x00\x00\x00\x00\x00" @?= Nothing
+ , testCase "length-prefixed bytes" $ do
+ encode_u16_prefixed "abc" @?= Just "\x00\x03\&abc"
+ encode_u16_prefixed (BS.replicate 65536 0) @?= Nothing
+ decode_u16_prefixed "\x00\x03\&abcde" @?= Just ("abc", "de")
+ decode_u16_prefixed "\x00\x03\&ab" @?= Nothing
+ , testCase "fixed-size types check their lengths" $ do
+ assertBool "chain_hash" (isNothing (chain_hash (BS.replicate 31 0)))
+ assertBool "channel_id" (isNothing (channel_id (BS.replicate 33 0)))
+ assertBool "signature" (isNothing (signature (BS.replicate 65 0)))
+ assertBool "payment_hash" (isNothing (payment_hash ""))
+ assertBool "preimage" (isNothing (payment_preimage ""))
+ assertBool "secret" (isNothing (per_commitment_secret ""))
+ , testCase "point prefix" $ do
+ assertBool "02" (isJust (point (BS.cons 0x02 (BS.replicate 32 1))))
+ assertBool "03" (isJust (point (BS.cons 0x03 (BS.replicate 32 1))))
+ assertBool "04" (isNothing (point (BS.cons 0x04 (BS.replicate 32 1))))
+ assertBool "len" (isNothing (point (BS.cons 0x02 (BS.replicate 31 1))))
+ , testCase "short_channel_id" $ case short_channel_id 539268 845 1 of
+ Nothing -> assertFailure "valid scid rejected"
+ Just c -> do
+ scid_block_height c @?= 539268
+ scid_tx_index c @?= 845
+ scid_output_index c @?= 1
+ encode_short_channel_id c @?= "\x08\x3a\x84\x00\x03\x4d\x00\x01"
+ , testCase "short_channel_id rejects 25-bit components" $ do
+ short_channel_id 0x1000000 0 0 @?= Nothing
+ short_channel_id 0 0x1000000 0 @?= Nothing
+ , testCase "amount bounds" $ do
+ fmap un_satoshi (satoshi 0x000775f05a074000) @?= Just 0x000775f05a074000
+ satoshi 0x000775f05a074001 @?= Nothing
+ fmap un_milli_satoshi (milli_satoshi 0x1d24b2dfac520000)
+ @?= Just 0x1d24b2dfac520000
+ milli_satoshi 0x1d24b2dfac520001 @?= Nothing
+ sat_to_msat max_satoshi @?= max_milli_satoshi
+ decode_satoshi (encode_u64 0x000775f05a074001) @?= Nothing
+ decode_milli_satoshi (encode_u64 maxBound) @?= Nothing
+ , testCase "checked arithmetic" $ do
+ add_sat max_satoshi max_satoshi @?= Nothing
+ (do a <- satoshi 1; b <- satoshi 2; sub_sat a b) @?= Nothing
+ (do a <- satoshi 2; b <- satoshi 1; sub_sat a b) @?= satoshi 1
+ (do a <- milli_satoshi 1; b <- milli_satoshi 2; sub_msat a b)
+ @?= Nothing
+ add_msat max_milli_satoshi max_milli_satoshi @?= Nothing
+ , testCase "secrets don't show" $
+ case payment_preimage (BS.replicate 32 7) of
+ Nothing -> assertFailure "valid preimage rejected"
+ Just p -> do
+ show p @?= "PaymentPreimage <redacted>"
+ show (Just p) @?= "Just (PaymentPreimage <redacted>)"
+ , testCase "secret equality" $ do
+ let a = payment_preimage (BS.replicate 32 7)
+ b = payment_preimage (BS.replicate 31 7 <> "\x08")
+ assertBool "equal" (a == a)
+ assertBool "unequal" (a /= b)
]
--- 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
+-- TLV ------------------------------------------------------------------------
+
+tlv :: TestTree
+tlv = testGroup "TLV" [
+ testCase "tlv_stream sorts" $
+ fmap (map tlv_type . un_tlv_stream)
+ (tlv_stream [TlvRecord 5 "", TlvRecord 1 "", TlvRecord 3 ""])
+ @?= Just [1, 3, 5]
+ , testCase "tlv_stream rejects duplicates" $
+ tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing
+ , testCase "lookup_tlv" $ do
+ (lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"])
+ @?= Just "b"
+ (lookup_tlv 2 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"])
+ @?= Nothing
+ , testCase "huge lengths are rejected, not wrapped" $
+ mapM_ (\h -> with_hex h $ \bs ->
+ decode_tlv_stream (const True) bs @?= Left TlvTruncated)
+ [ "01ffffffffffffffffff", "01ff800000000000000067"
+ , "01ffffffffffffffffff6701aa" ]
+ , testCase "truncation vs non-minimal" $ do
+ decode_tlv_stream (const True) "\xfd" @?= Left TlvTruncated
+ decode_tlv_stream (const True) "\xfd\x00\x01\x00"
+ @?= Left TlvNonMinimalBigSize
+ , testCase "unknown odd records are kept" $
+ fmap (map tlv_type . un_tlv_stream)
+ (decode_tlv_stream (const False) "\x01\x00\x03\x01\x2a")
+ @?= Right [1, 3]
]
--- 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
+-- messages -------------------------------------------------------------------
+
+messages :: TestTree
+messages = testGroup "Messages" [
+ testCase "pong known answer" $
+ encode_message (MsgPong (Pong "\x00\x00" empty_tlv_stream))
+ @?= Right "\x00\x13\x00\x02\x00\x00"
+ , testCase "ping known answer" $
+ encode_message (MsgPing (Ping 4 "" empty_tlv_stream))
+ @?= Right "\x00\x12\x00\x04\x00\x00"
+ , testCase "error known answer" $
+ encode_message (MsgError (Error all_channels "x" empty_tlv_stream))
+ @?= Right ("\x00\x11" <> BS.replicate 32 0 <> "\x00\x01x")
+ , testCase "init with networks and remote_addr" $
+ case chain_hash (BS.replicate 32 0x6f) of
+ Nothing -> assertFailure "valid chain hash rejected"
+ Just ch -> do
+ let addr = "\x01\x7f\x00\x00\x01\x26\x07"
+ i = Init empty_fv (BOLT9.parse "\x02") (Just [ch])
+ (Just addr) empty_tlv_stream
+ wire = "\x00\x10\x00\x00\x00\x01\x02"
+ <> "\x01\x20" <> un_chain_hash ch <> "\x03\x07" <> addr
+ encode_message (MsgInit i) @?= Right wire
+ decode_message wire @?= Right (MsgInit i)
+ , testCase "init networks must be a multiple of 32 bytes" $
+ decode_init "\x00\x00\x00\x00\x01\x01\x00"
+ @?= Left (DecodeInvalidTlvValue 1)
+ , testCase "init rejects tlvs clashing with typed fields" $
+ case tlv_stream [TlvRecord 3 "x"] of
+ Nothing -> assertFailure "valid stream rejected"
+ Just s -> encode_init (Init empty_fv empty_fv Nothing (Just "y") s)
+ @?= Left EncodeInvalidTlvs
+ , testCase "unknown message types" $ do
+ decode_message "\x00\x20" @?= Left (DecodeUnknownEvenType 32)
+ decode_message "\x80\x01" @?= Left (DecodeUnknownOddType 32769)
+ decode_message "\x00" @?= Left DecodeInsufficientBytes
+ , testCase "truncated payloads" $ do
+ decode_init "\x00" @?= Left DecodeInsufficientBytes
+ decode_init "\x00\x01" @?= Left DecodeInsufficientBytes
+ decode_error (BS.replicate 31 0) @?= Left DecodeInsufficientBytes
+ decode_warning (BS.replicate 33 0) @?= Left DecodeInsufficientBytes
+ decode_ping "\x00\x04\x00\x02\x00" @?= Left DecodeInsufficientBytes
+ decode_pong "\x00\x02\x00" @?= Left DecodeInsufficientBytes
+ decode_peer_storage "\x00\x01" @?= Left DecodeInsufficientBytes
+ decode_peer_storage_retrieval "\x00" @?= Left DecodeInsufficientBytes
+ , testCase "invalid extensions" $ do
+ decode_pong "\x00\x00\x02\x00" @?= Left
+ (DecodeTlvError (TlvUnknownEvenType 2))
+ decode_ping "\x00\x00\x00\x00\x01" @?= Left (DecodeTlvError TlvTruncated)
+ , testCase "message size limit" $ do
+ encode_envelope 7 (BS.replicate 65533 0) @?=
+ Right (encode_u16 7 <> BS.replicate 65533 0)
+ encode_envelope 7 (BS.replicate 65534 0) @?= Left EncodeMessageTooLarge
+ encode_message (MsgPeerStorage (PeerStorage (BS.replicate 65532 0)
+ empty_tlv_stream)) @?= Left EncodeMessageTooLarge
+ encode_pong (Pong (BS.replicate 65536 0) empty_tlv_stream)
+ @?= Left EncodeLengthOverflow
+ , testCase "ping_response" $ do
+ ping_response (Ping 3 "ab" empty_tlv_stream)
+ @?= Just (Pong "\x00\x00\x00" empty_tlv_stream)
+ ping_response (Ping 65531 "" empty_tlv_stream) @?=
+ Just (Pong (BS.replicate 65531 0) empty_tlv_stream)
+ ping_response (Ping 65532 "" empty_tlv_stream) @?= Nothing
]
--- | 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
+-- properties -----------------------------------------------------------------
+
+newtype Bytes = Bytes BS.ByteString
+ deriving Show
+
+instance Arbitrary Bytes where
+ arbitrary = Bytes . BS.pack <$> (choose (0, 64) >>= vector)
+
+-- streams of unknown odd records
+newtype OddTlvs = OddTlvs TlvStream
+ deriving Show
+
+instance Arbitrary OddTlvs where
+ arbitrary = do
+ ts <- L.nub . map (\t -> 2 * (t `div` 2) + 1)
+ <$> listOf (arbitrary :: Gen Word64)
+ vs <- vectorOf (length ts) arbitrary
+ pure . OddTlvs . fromMaybe empty_tlv_stream $
+ tlv_stream [ TlvRecord t v | (t, Bytes v) <- zip ts vs ]
+
+newtype Bytes32 = Bytes32 BS.ByteString
+ deriving Show
+
+instance Arbitrary Bytes32 where
+ arbitrary = Bytes32 . BS.pack <$> vector 32
+
+newtype Msg = Msg Message
+ deriving Show
+
+instance Arbitrary Msg where
+ arbitrary = Msg <$> oneof [
+ do Bytes a <- arbitrary
+ Bytes b <- arbitrary
+ nets <- oneof [pure Nothing, Just <$> listOf chain]
+ addr <- oneof [pure Nothing, (\(Bytes x) -> Just x) <$> arbitrary]
+ OddTlvs s <- arbitrary
+ let s' = filter_tlv_stream (\t -> t /= 1 && t /= 3) s
+ pure (MsgInit (Init (BOLT9.parse a) (BOLT9.parse b) nets addr s'))
+ , do c <- cid
+ Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgError (Error c d s))
+ , do c <- cid
+ Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgWarning (Warning c d s))
+ , do n <- arbitrary
+ Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPing (Ping n d s))
+ , do Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPong (Pong d s))
+ , do Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPeerStorage (PeerStorage d s))
+ , do Bytes d <- arbitrary
+ OddTlvs s <- arbitrary
+ pure (MsgPeerStorageRetrieval (PeerStorageRetrieval d s))
+ ]
+ where
+ chain = do
+ Bytes32 b <- arbitrary
+ maybe chain pure (chain_hash b)
+ cid = do
+ Bytes32 b <- arbitrary
+ pure (fromMaybe all_channels (channel_id b))
+
+properties :: TestTree
+properties = testGroup "Properties" [
+ testProperty "bigsize round-trips" $ \w ->
+ decode_bigsize (encode_bigsize w) === Just (w, "")
+ , testProperty "tu16 round-trips" $ \w ->
+ decode_tu16 (encode_tu16 w) === Just w
+ , testProperty "tu32 round-trips" $ \w ->
+ decode_tu32 (encode_tu32 w) === Just w
+ , testProperty "tu64 round-trips" $ \w ->
+ decode_tu64 (encode_tu64 w) === Just w
+ , testProperty "u16 round-trips" $ \w ->
+ decode_u16 (encode_u16 w) === Just (w, "")
+ , testProperty "u32 round-trips" $ \w ->
+ decode_u32 (encode_u32 w) === Just (w, "")
+ , testProperty "u64 round-trips" $ \w ->
+ decode_u64 (encode_u64 w) === Just (w, "")
+ , testProperty "s64 round-trips" $ \w ->
+ decode_s64 (encode_s64 w) === Just (w, "")
+ , testProperty "scid components round-trip" $ \h t o ->
+ let h' = h `mod` 0x1000000 :: Word32
+ t' = t `mod` 0x1000000 :: Word32
+ in fmap (\c -> (scid_block_height c, scid_tx_index c,
+ scid_output_index c)) (short_channel_id h' t' o)
+ === Just (h', t', o)
+ , testProperty "sat -> msat -> sat is the identity" $
+ forAll (choose (0, 0x000775f05a074000)) $ \w ->
+ fmap (msat_to_sat . sat_to_msat) (satoshi w) === satoshi w
+ , testProperty "add then sub is the identity" $
+ forAll (choose (0, 0x000775f05a074000)) $ \a ->
+ forAll (choose (0, 0x000775f05a074000 - a)) $ \b ->
+ (do x <- satoshi a
+ y <- satoshi b
+ z <- add_sat x y
+ sub_sat z y) === satoshi a
+ , testProperty "tlv streams round-trip" $ \(OddTlvs s) ->
+ decode_tlv_stream (const False) (encode_tlv_stream s) === Right s
+ , testProperty "messages round-trip" $ \(Msg m) ->
+ case encode_message m of
+ Left e -> counterexample (show e) False
+ Right bs -> decode_message bs === Right m
+ , testProperty "re-encoding reproduces the wire bytes" $ \(Msg m) ->
+ case encode_message m of
+ Left e -> counterexample (show e) False
+ Right bs -> case decode_message bs of
+ Left e -> counterexample (show e) False
+ Right m' -> encode_message m' === Right bs
+ ]
