ppad-bolt1 0.0.1 → 0.1.0

raw patch · 11 files changed

+2001/−3215 lines, 11 filesdep +ppad-bolt9dep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: ppad-bolt9

Dependency ranges changed: deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG +31/−1
• bench/Fixtures.hs +34/−417
• bench/Main.hs +24/−517
• bench/Weight.hs +19/−338
• lib/Lightning/Protocol/BOLT1.hs +126/−70
• lib/Lightning/Protocol/BOLT1/Codec.hs +232/−297
• lib/Lightning/Protocol/BOLT1/Message.hs +74/−155
• lib/Lightning/Protocol/BOLT1/Prim.hs +804/−527
• lib/Lightning/Protocol/BOLT1/TLV.hs +107/−195
• ppad-bolt1.cabal +8/−5
• test/Main.hs +542/−693

@@ -1,4 +1,34 @@ # Changelog -- 0.0.1 (2025-01-25)+- 0.1.0 (2026-10-10)+  * A substantial rewrite, with breaking changes throughout:++    * The API is exported from Lightning.Protocol.BOLT1 alone, and uses+      snake_case names (e.g. encode_message, channel_id, un_channel_id).++    * Fundamental types are abstract, constructed only via validating+      smart constructors. Points must carry a compressed-encoding+      prefix. Satoshi and MilliSatoshi are bounded at 21M BTC and+      provide checked arithmetic instead of Num.++    * Every message decoder consumes its whole payload and preserves+      unknown odd TLV records, so encoding a decoded message reproduces+      its wire bytes. Init has typed networks and remote_addr fields,+      and uses ppad-bolt9 feature vectors.++    * A single TLV decoder takes the set of known types, rejects+      unknown even types, and keeps unknown odd ones.++    * Removed the Envelope type, the minimal signed integer codecs and+      the Internal module; added ping_response and fixed-size field+      codecs.++  * Fixes TLV decoding, which accepted lengths of 2^63 or more as+    empty values.++  * Fixed-width encoders no longer allocate kilobytes per call.++  * Tests now cover every BOLT #1 appendix vector.++- 0.0.1 (2026-04-18)   * Initial release.

@@ -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---- Sample ByteStrings --------------------------------------------------------- | 64-byte sample data.-bytes64 :: BS.ByteString-bytes64 = BS.replicate 64 0xAB-{-# NOINLINE bytes64 #-}---- | 1KB sample data.-bytes1k :: BS.ByteString-bytes1k = BS.replicate 1024 0xCD-{-# NOINLINE bytes1k #-}---- | 16KB sample data.-bytes16k :: BS.ByteString-bytes16k = BS.replicate 16384 0xEF-{-# NOINLINE bytes16k #-}---- Sample chain hashes (32 bytes each) ---------------------------------------- | Bitcoin mainnet genesis block hash (reversed, as used in LN).-mainnetChainHash :: ChainHash-mainnetChainHash = fromJust $ chainHash $ BS.pack-  [ 0x6f, 0xe2, 0x8c, 0x0a, 0xb6, 0xf1, 0xb3, 0x72-  , 0xc1, 0xa6, 0xa2, 0x46, 0xae, 0x63, 0xf7, 0x4f-  , 0x93, 0x1e, 0x83, 0x65, 0xe1, 0x5a, 0x08, 0x9c-  , 0x68, 0xd6, 0x19, 0x00, 0x00, 0x00, 0x00, 0x00-  ]-{-# NOINLINE mainnetChainHash #-}---- | Bitcoin testnet genesis block hash (reversed, as used in LN).-testnetChainHash :: ChainHash-testnetChainHash = fromJust $ chainHash $ BS.pack-  [ 0x43, 0x49, 0x7f, 0xd7, 0xf8, 0x26, 0x95, 0x71-  , 0x08, 0xf4, 0xa3, 0x0f, 0xd9, 0xce, 0xc3, 0xae-  , 0xba, 0x79, 0x97, 0x20, 0x84, 0xe9, 0x0e, 0xad-  , 0x01, 0xea, 0x33, 0x09, 0x00, 0x00, 0x00, 0x00-  ]-{-# NOINLINE testnetChainHash #-}---- Sample channel IDs (32 bytes each) -------------------------------------+import qualified Lightning.Protocol.BOLT9 as BOLT9 --- | Sample channel ID (non-zero).-sampleChannelId :: ChannelId-sampleChannelId = fromJust $ channelId $ BS.pack-  [ 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08-  , 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10-  , 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18-  , 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20-  ]-{-# NOINLINE sampleChannelId #-}+{-# NOINLINE tlvs #-}+tlvs :: TlvStream+tlvs = fromMaybe empty_tlv_stream $+  tlv_stream [ TlvRecord t (BS.replicate 32 0x2a) | t <- [1, 3 .. 41] ] --- Sample Init messages ---------------------------------------------------+{-# NOINLINE tlvs_bytes #-}+tlvs_bytes :: BS.ByteString+tlvs_bytes = encode_tlv_stream tlvs --- | Minimal Init message (empty features, no TLVs).-minimalInit :: Init-minimalInit = Init-  { initGlobalFeatures = BS.empty-  , initFeatures       = BS.empty-  , initTlvs           = []+{-# NOINLINE init_msg #-}+init_msg :: Message+init_msg = MsgInit Init {+    init_global_features = BOLT9.parse ""+  , init_features        = BOLT9.parse "\x02\xaa\x52\x69\xa1"+  , init_networks        = fmap pure (chain_hash (BS.replicate 32 0x6f))+  , init_remote_addr     = Just "\x01\x7f\x00\x00\x01\x26\x07"+  , init_tlvs            = empty_tlv_stream   }-{-# NOINLINE minimalInit #-} --- | Init with feature bits set.-initWithFeatures :: Init-initWithFeatures = Init-  { initGlobalFeatures = BS.pack [0x00, 0x01]  -- 2 bytes-  , initFeatures       = BS.pack [0x02, 0xa2]  -- data_loss_protect, etc.-  , initTlvs           = []-  }-{-# NOINLINE initWithFeatures #-}---- | Init with TLV extensions.-initWithTlvs :: Init-initWithTlvs = Init-  { initGlobalFeatures = BS.empty-  , initFeatures       = BS.pack [0x02, 0xa2]-  , initTlvs           = [InitNetworks [mainnetChainHash]]-  }-{-# NOINLINE initWithTlvs #-}---- | Init with multiple chain hashes.-initWithMultipleChains :: Init-initWithMultipleChains = Init-  { initGlobalFeatures = BS.empty-  , initFeatures       = BS.pack [0x02, 0xa2]-  , initTlvs           = [InitNetworks [mainnetChainHash, testnetChainHash]]-  }-{-# NOINLINE initWithMultipleChains #-}---- | Full Init with features and remote_addr TLV.-fullInit :: Init-fullInit = Init-  { initGlobalFeatures = BS.pack [0x00, 0x01]-  , initFeatures       = BS.pack [0x02, 0xa2, 0x01]-  , initTlvs           =-      [ InitNetworks [mainnetChainHash]-      , InitRemoteAddr (BS.pack [0x01, 0x7f, 0x00, 0x00, 0x01, 0x27, 0x10])-      ]-  }-{-# NOINLINE fullInit #-}---- Sample Error messages ------------------------------------------------------ | Minimal Error message (connection-level, empty data).-minimalError :: Error-minimalError = Error-  { errorChannelId = allChannels-  , errorData      = BS.empty-  }-{-# NOINLINE minimalError #-}---- | Error with channel ID and message.-errorWithData :: Error-errorWithData = Error-  { errorChannelId = sampleChannelId-  , errorData      = "funding transaction failed"-  }-{-# NOINLINE errorWithData #-}---- | Error with longer data.-errorWithLongData :: Error-errorWithLongData = Error-  { errorChannelId = sampleChannelId-  , errorData      = bytes1k-  }-{-# NOINLINE errorWithLongData #-}---- Sample Warning messages ---------------------------------------------------- | Minimal Warning message.-minimalWarning :: Warning-minimalWarning = Warning-  { warningChannelId = allChannels-  , warningData      = BS.empty-  }-{-# NOINLINE minimalWarning #-}---- | Warning with message.-warningWithData :: Warning-warningWithData = Warning-  { warningChannelId = sampleChannelId-  , warningData      = "channel fee too low"-  }-{-# NOINLINE warningWithData #-}---- Sample Ping messages ------------------------------------------------------- | Minimal Ping (no padding, no response requested).-minimalPing :: Ping-minimalPing = Ping-  { pingNumPongBytes = 0-  , pingIgnored      = BS.empty-  }-{-# NOINLINE minimalPing #-}---- | Ping with response requested but no padding.-pingWithResponse :: Ping-pingWithResponse = Ping-  { pingNumPongBytes = 64-  , pingIgnored      = BS.empty-  }-{-# NOINLINE pingWithResponse #-}---- | Ping with padding (64 bytes).-pingWithPadding :: Ping-pingWithPadding = Ping-  { pingNumPongBytes = 64-  , pingIgnored      = bytes64-  }-{-# NOINLINE pingWithPadding #-}---- | Ping with large padding (1KB).-pingWithLargePadding :: Ping-pingWithLargePadding = Ping-  { pingNumPongBytes = 128-  , pingIgnored      = bytes1k-  }-{-# NOINLINE pingWithLargePadding #-}---- Sample Pong messages ------------------------------------------------------- | Minimal Pong (no ignored bytes).-minimalPong :: Pong-minimalPong = Pong-  { pongIgnored = BS.empty-  }-{-# NOINLINE minimalPong #-}---- | Pong with padding (64 bytes).-pongWithPadding :: Pong-pongWithPadding = Pong-  { pongIgnored = bytes64-  }-{-# NOINLINE pongWithPadding #-}---- | Pong with large padding (1KB).-pongWithLargePadding :: Pong-pongWithLargePadding = Pong-  { pongIgnored = bytes1k-  }-{-# NOINLINE pongWithLargePadding #-}---- Sample PeerStorage messages ------------------------------------------------ | Minimal PeerStorage (empty blob).-minimalPeerStorage :: PeerStorage-minimalPeerStorage = PeerStorage-  { peerStorageBlob = BS.empty-  }-{-# NOINLINE minimalPeerStorage #-}---- | PeerStorage with 1KB blob.-peerStorageSmall :: PeerStorage-peerStorageSmall = PeerStorage-  { peerStorageBlob = bytes1k-  }-{-# NOINLINE peerStorageSmall #-}---- | PeerStorage with 16KB blob.-peerStorageLarge :: PeerStorage-peerStorageLarge = PeerStorage-  { peerStorageBlob = bytes16k-  }-{-# NOINLINE peerStorageLarge #-}---- Sample PeerStorageRetrieval messages --------------------------------------- | Minimal PeerStorageRetrieval (empty blob).-minimalPeerStorageRetrieval :: PeerStorageRetrieval-minimalPeerStorageRetrieval = PeerStorageRetrieval-  { peerStorageRetrievalBlob = BS.empty-  }-{-# NOINLINE minimalPeerStorageRetrieval #-}---- | PeerStorageRetrieval with 1KB blob.-peerStorageRetrievalSmall :: PeerStorageRetrieval-peerStorageRetrievalSmall = PeerStorageRetrieval-  { peerStorageRetrievalBlob = bytes1k-  }-{-# NOINLINE peerStorageRetrievalSmall #-}---- | PeerStorageRetrieval with 16KB blob.-peerStorageRetrievalLarge :: PeerStorageRetrieval-peerStorageRetrievalLarge = PeerStorageRetrieval-  { peerStorageRetrievalBlob = bytes16k-  }-{-# NOINLINE peerStorageRetrievalLarge #-}---- Sample TLV streams --------------------------------------------------------- | Empty TLV stream.-emptyTlvStream :: TlvStream-emptyTlvStream = unsafeTlvStream []-{-# NOINLINE emptyTlvStream #-}---- | TLV stream with 1 record.-smallTlvStream :: TlvStream-smallTlvStream = unsafeTlvStream-  [ TlvRecord 1 (BS.replicate 32 0x01)-  ]-{-# NOINLINE smallTlvStream #-}---- | TLV stream with 5 records.-mediumTlvStream :: TlvStream-mediumTlvStream = unsafeTlvStream-  [ TlvRecord 1 (BS.replicate 8 0x01)-  , TlvRecord 3 (BS.replicate 16 0x03)-  , TlvRecord 5 (BS.replicate 32 0x05)-  , TlvRecord 7 (BS.replicate 64 0x07)-  , TlvRecord 9 (BS.replicate 128 0x09)-  ]-{-# NOINLINE mediumTlvStream #-}---- | TLV stream with 20 records.-largeTlvStream :: TlvStream-largeTlvStream = unsafeTlvStream-  [ TlvRecord 1  (BS.replicate 8 0x01)-  , TlvRecord 3  (BS.replicate 16 0x02)-  , TlvRecord 5  (BS.replicate 8 0x03)-  , TlvRecord 7  (BS.replicate 16 0x04)-  , TlvRecord 9  (BS.replicate 8 0x05)-  , TlvRecord 11 (BS.replicate 16 0x06)-  , TlvRecord 13 (BS.replicate 8 0x07)-  , TlvRecord 15 (BS.replicate 16 0x08)-  , TlvRecord 17 (BS.replicate 8 0x09)-  , TlvRecord 19 (BS.replicate 16 0x0a)-  , TlvRecord 21 (BS.replicate 8 0x0b)-  , TlvRecord 23 (BS.replicate 16 0x0c)-  , TlvRecord 25 (BS.replicate 8 0x0d)-  , TlvRecord 27 (BS.replicate 16 0x0e)-  , TlvRecord 29 (BS.replicate 8 0x0f)-  , TlvRecord 31 (BS.replicate 16 0x10)-  , TlvRecord 33 (BS.replicate 8 0x11)-  , TlvRecord 35 (BS.replicate 16 0x12)-  , TlvRecord 37 (BS.replicate 8 0x13)-  , TlvRecord 39 (BS.replicate 16 0x14)-  ]-{-# NOINLINE largeTlvStream #-}---- Encoded message bytes (for decode benchmarks) ------------------------------ Helper to encode or fail.-encodeOrFail :: Either EncodeError BS.ByteString -> BS.ByteString-encodeOrFail (Right bs) = bs-encodeOrFail (Left _)   = error "encodeOrFail: encoding failed"---- | Encoded minimal Init.-encodedMinimalInit :: BS.ByteString-encodedMinimalInit = encodeOrFail $ encodeEnvelope (MsgInitVal minimalInit) Nothing-{-# NOINLINE encodedMinimalInit #-}---- | Encoded Init with TLVs.-encodedInitWithTlvs :: BS.ByteString-encodedInitWithTlvs = encodeOrFail $ encodeEnvelope (MsgInitVal initWithTlvs) Nothing-{-# NOINLINE encodedInitWithTlvs #-}---- | Encoded full Init.-encodedFullInit :: BS.ByteString-encodedFullInit = encodeOrFail $ encodeEnvelope (MsgInitVal fullInit) Nothing-{-# NOINLINE encodedFullInit #-}---- | Encoded minimal Error.-encodedMinimalError :: BS.ByteString-encodedMinimalError = encodeOrFail $ encodeEnvelope (MsgErrorVal minimalError) Nothing-{-# NOINLINE encodedMinimalError #-}---- | Encoded Error with data.-encodedErrorWithData :: BS.ByteString-encodedErrorWithData = encodeOrFail $ encodeEnvelope (MsgErrorVal errorWithData) Nothing-{-# NOINLINE encodedErrorWithData #-}---- | Encoded minimal Warning.-encodedMinimalWarning :: BS.ByteString-encodedMinimalWarning = encodeOrFail $-  encodeEnvelope (MsgWarningVal minimalWarning) Nothing-{-# NOINLINE encodedMinimalWarning #-}---- | Encoded Warning with data.-encodedWarningWithData :: BS.ByteString-encodedWarningWithData = encodeOrFail $-  encodeEnvelope (MsgWarningVal warningWithData) Nothing-{-# NOINLINE encodedWarningWithData #-}---- | Encoded minimal Ping.-encodedMinimalPing :: BS.ByteString-encodedMinimalPing = encodeOrFail $ encodeEnvelope (MsgPingVal minimalPing) Nothing-{-# NOINLINE encodedMinimalPing #-}---- | Encoded Ping with padding.-encodedPingWithPadding :: BS.ByteString-encodedPingWithPadding = encodeOrFail $-  encodeEnvelope (MsgPingVal pingWithPadding) Nothing-{-# NOINLINE encodedPingWithPadding #-}---- | Encoded Ping with large padding.-encodedPingWithLargePadding :: BS.ByteString-encodedPingWithLargePadding = encodeOrFail $-  encodeEnvelope (MsgPingVal pingWithLargePadding) Nothing-{-# NOINLINE encodedPingWithLargePadding #-}---- | Encoded minimal Pong.-encodedMinimalPong :: BS.ByteString-encodedMinimalPong = encodeOrFail $ encodeEnvelope (MsgPongVal minimalPong) Nothing-{-# NOINLINE encodedMinimalPong #-}---- | Encoded Pong with padding.-encodedPongWithPadding :: BS.ByteString-encodedPongWithPadding = encodeOrFail $-  encodeEnvelope (MsgPongVal pongWithPadding) Nothing-{-# NOINLINE encodedPongWithPadding #-}---- | Encoded minimal PeerStorage.-encodedMinimalPeerStorage :: BS.ByteString-encodedMinimalPeerStorage = encodeOrFail $-  encodeEnvelope (MsgPeerStorageVal minimalPeerStorage) Nothing-{-# NOINLINE encodedMinimalPeerStorage #-}---- | Encoded PeerStorage with 1KB blob.-encodedPeerStorageSmall :: BS.ByteString-encodedPeerStorageSmall = encodeOrFail $-  encodeEnvelope (MsgPeerStorageVal peerStorageSmall) Nothing-{-# NOINLINE encodedPeerStorageSmall #-}---- | Encoded minimal PeerStorageRetrieval.-encodedMinimalPeerStorageRetrieval :: BS.ByteString-encodedMinimalPeerStorageRetrieval = encodeOrFail $-  encodeEnvelope (MsgPeerStorageRetrievalVal minimalPeerStorageRetrieval) Nothing-{-# NOINLINE encodedMinimalPeerStorageRetrieval #-}---- | Encoded PeerStorageRetrieval with 1KB blob.-encodedPeerStorageRetrievalSmall :: BS.ByteString-encodedPeerStorageRetrievalSmall = encodeOrFail $-  encodeEnvelope (MsgPeerStorageRetrievalVal peerStorageRetrievalSmall) Nothing-{-# NOINLINE encodedPeerStorageRetrievalSmall #-}+{-# NOINLINE ping_msg #-}+ping_msg :: Message+ping_msg = MsgPing (Ping 128 (BS.replicate 64 0) empty_tlv_stream) --- Encoded TLV streams (for decode benchmarks) ----------------------------+{-# NOINLINE error_msg #-}+error_msg :: Message+error_msg = MsgError (Error all_channels (BS.replicate 128 0x61) tlvs) --- | Encoded empty TLV stream.-encodedEmptyTlvStream :: BS.ByteString-encodedEmptyTlvStream = encodeTlvStream emptyTlvStream-{-# NOINLINE encodedEmptyTlvStream #-}+wire :: Message -> BS.ByteString+wire m = either (const BS.empty) id (encode_message m) --- | Encoded small TLV stream (1 record).-encodedSmallTlvStream :: BS.ByteString-encodedSmallTlvStream = encodeTlvStream smallTlvStream-{-# NOINLINE encodedSmallTlvStream #-}+{-# NOINLINE init_bytes #-}+init_bytes :: BS.ByteString+init_bytes = wire init_msg --- | Encoded medium TLV stream (5 records).-encodedMediumTlvStream :: BS.ByteString-encodedMediumTlvStream = encodeTlvStream mediumTlvStream-{-# NOINLINE encodedMediumTlvStream #-}+{-# NOINLINE ping_bytes #-}+ping_bytes :: BS.ByteString+ping_bytes = wire ping_msg --- | Encoded large TLV stream (20 records).-encodedLargeTlvStream :: BS.ByteString-encodedLargeTlvStream = encodeTlvStream largeTlvStream-{-# NOINLINE encodedLargeTlvStream #-}+{-# NOINLINE error_bytes #-}+error_bytes :: BS.ByteString+error_bytes = wire error_msg

@@ -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 #-}

@@ -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

@@ -6,96 +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(..)-  , msgTypeWord--  -- * Channel identifiers-  , ChannelId-  , channelId-  , allChannels--  -- ** Setup messages+  , message_type   , Init(..)   , Error(..)   , Warning(..)--  -- ** Control messages   , Ping(..)   , Pong(..)--  -- ** Peer storage+  , ping_response   , PeerStorage(..)   , PeerStorageRetrieval(..) +  -- * Encoding and decoding messages+  , encode_message+  , decode_message+  , encode_envelope+  , decode_envelope+  , EncodeError(..)+  , DecodeError(..)++  -- ** Payloads+  , encode_init+  , decode_init+  , encode_error+  , decode_error+  , encode_warning+  , decode_warning+  , encode_ping+  , decode_ping+  , encode_pong+  , decode_pong+  , encode_peer_storage+  , decode_peer_storage+  , encode_peer_storage_retrieval+  , decode_peer_storage_retrieval+   -- * TLV   , TlvRecord(..)   , TlvStream-  , unTlvStream-  , tlvStream-  , unsafeTlvStream+  , tlv_stream+  , un_tlv_stream+  , empty_tlv_stream+  , lookup_tlv+  , filter_tlv_stream+  , encode_tlv_stream+  , decode_tlv_stream   , TlvError(..)-  , encodeTlvStream-  , decodeTlvStream-  , decodeTlvStreamWith-  , decodeTlvStreamRaw -  -- ** Init TLVs-  , InitTlv(..)+  -- * Fundamental types   , ChainHash-  , chainHash-  , unChainHash--  -- * Message envelope-  , Envelope(..)--  -- * Encoding-  , EncodeError(..)-  , encodeMessage-  , encodeEnvelope--  -- * Decoding-  , DecodeError(..)-  , decodeMessage-  , decodeEnvelope-  , decodeEnvelopeWith+  , chain_hash+  , un_chain_hash+  , ChannelId+  , channel_id+  , un_channel_id+  , all_channels+  , Signature+  , signature+  , un_signature+  , Point+  , point+  , un_point+  , PaymentHash+  , payment_hash+  , un_payment_hash+  , PaymentPreimage+  , payment_preimage+  , un_payment_preimage+  , PerCommitmentSecret+  , per_commitment_secret+  , un_per_commitment_secret+  , ShortChannelId(..)+  , short_channel_id+  , scid_block_height+  , scid_tx_index+  , scid_output_index -  -- * Primitive encoding-  , encodeU16-  , encodeU32-  , encodeU64-  , encodeS8-  , encodeS16-  , encodeS32-  , encodeS64-  , encodeTu16-  , encodeTu32-  , encodeTu64-  , encodeMinSigned-  , encodeBigSize+  -- ** Amounts+  , Satoshi+  , satoshi+  , un_satoshi+  , max_satoshi+  , MilliSatoshi+  , milli_satoshi+  , un_milli_satoshi+  , max_milli_satoshi+  , sat_to_msat+  , msat_to_sat+  , add_sat+  , sub_sat+  , add_msat+  , sub_msat -  -- * Primitive decoding-  , decodeU16-  , decodeU32-  , decodeU64-  , decodeS8-  , decodeS16-  , decodeS32-  , decodeS64-  , decodeTu16-  , decodeTu32-  , decodeTu64-  , decodeMinSigned-  , decodeBigSize+  -- * Primitive encodings+  -- | Decoders return the decoded value and the remaining input, except+  --   for the truncated integers, which occupy their whole input.+  , encode_u16+  , encode_u32+  , encode_u64+  , decode_u16+  , decode_u32+  , decode_u64+  , encode_s8+  , encode_s16+  , encode_s32+  , encode_s64+  , decode_s8+  , decode_s16+  , decode_s32+  , decode_s64+  , encode_tu16+  , encode_tu32+  , encode_tu64+  , decode_tu16+  , decode_tu32+  , decode_tu64+  , encode_bigsize+  , decode_bigsize+  , encode_u16_prefixed+  , decode_u16_prefixed+  , decode_chain_hash+  , decode_channel_id+  , decode_signature+  , decode_point+  , decode_payment_hash+  , decode_payment_preimage+  , decode_per_commitment_secret+  , encode_short_channel_id+  , decode_short_channel_id+  , encode_satoshi+  , decode_satoshi+  , encode_milli_satoshi+  , decode_milli_satoshi   ) where --- Re-export from sub-modules+import Lightning.Protocol.BOLT1.Codec+import Lightning.Protocol.BOLT1.Message import Lightning.Protocol.BOLT1.Prim import Lightning.Protocol.BOLT1.TLV-import Lightning.Protocol.BOLT1.Message-import Lightning.Protocol.BOLT1.Codec

@@ -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(..)+  , DecodeError(..) -  -- * Message encoding-  , encodeInit-  , encodeError-  , encodeWarning-  , encodePing-  , encodePong-  , encodePeerStorage-  , encodePeerStorageRetrieval-  , encodeMessage-  , encodeEnvelope+  , encode_envelope+  , decode_envelope -  -- * Decoding errors-  , DecodeError(..)+  , encode_message+  , decode_message -  -- * Message decoding-  , decodeInit-  , decodeError-  , decodeWarning-  , decodePing-  , decodePong-  , decodePeerStorage-  , decodePeerStorageRetrieval-  , decodeMessage-  , decodeEnvelope-  , decodeEnvelopeWith+  , encode_init+  , decode_init+  , encode_error+  , decode_error+  , encode_warning+  , decode_warning+  , encode_ping+  , decode_ping+  , encode_pong+  , decode_pong+  , encode_peer_storage+  , decode_peer_storage+  , encode_peer_storage_retrieval+  , decode_peer_storage_retrieval++  , ping_response   ) where  import Control.DeepSeq (NFData)-import Control.Monad (when, unless) import qualified Data.ByteString as BS import Data.Word (Word16, Word64) import GHC.Generics (Generic)+import Lightning.Protocol.BOLT1.Message import Lightning.Protocol.BOLT1.Prim import Lightning.Protocol.BOLT1.TLV-import Lightning.Protocol.BOLT1.Message---- Encoding errors -------------------------------------------------------------+import qualified Lightning.Protocol.BOLT9 as BOLT9 --- | Encoding errors.+-- | Why a message failed to encode. data EncodeError-  = EncodeLengthOverflow   -- ^ Field length exceeds u16 max (65535 bytes)-  | EncodeMessageTooLarge  -- ^ Total message size exceeds 65535 bytes-  deriving stock (Eq, Show, Generic)+  = EncodeLengthOverflow+    -- ^ a length-prefixed field exceeds 65535 bytes+  | EncodeMessageTooLarge+    -- ^ the message (type and payload) exceeds 65535 bytes+  | EncodeInvalidTlvs+    -- ^ a record in a @_tlvs@ field duplicates a typed field+  deriving (Eq, Show, Generic)  instance NFData EncodeError --- Message encoding ------------------------------------------------------------+-- | Why a message failed to decode.+data DecodeError+  = DecodeInsufficientBytes+    -- ^ the input ended before a field did+  | DecodeTlvError !TlvError+    -- ^ the message's TLV stream is malformed+  | DecodeInvalidTlvValue !Word64+    -- ^ a known TLV record (of the given type) has a malformed value+  | DecodeUnknownEvenType !Word16+    -- ^ an unknown even message type; the connection must be closed+  | DecodeUnknownOddType !Word16+    -- ^ an unknown odd message type; the message must be ignored+  deriving (Eq, Show, Generic) --- | Encode an Init message payload.-encodeInit :: Init -> Either EncodeError BS.ByteString-encodeInit (Init gf feat tlvs) = do-  gfLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength gf)-  featLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength feat)-  Right $ mconcat-    [ gfLen-    , gf-    , featLen-    , feat-    , encodeTlvStream (encodeInitTlvs tlvs)-    ]+instance NFData DecodeError --- | Encode an Error message payload.-encodeError :: Error -> Either EncodeError BS.ByteString-encodeError (Error cid dat) = do-  datLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength dat)-  Right $ mconcat [unChannelId cid, datLen, dat]+-- framing -------------------------------------------------------------------- --- | Encode a Warning message payload.-encodeWarning :: Warning -> Either EncodeError BS.ByteString-encodeWarning (Warning cid dat) = do-  datLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength dat)-  Right $ mconcat [unChannelId cid, datLen, dat]+-- | Prefix a payload with its message type. Fails if the result+--   exceeds the 65535-byte message limit.+--+--   >>> encode_envelope 19 "\NUL\NUL"+--   Right "\NUL\DC3\NUL\NUL"+encode_envelope :: Word16 -> BS.ByteString -> Either EncodeError BS.ByteString+encode_envelope t payload+  | BS.length payload > 65533 = Left EncodeMessageTooLarge+  | otherwise                 = Right (encode_u16 t <> payload) --- | Encode a Ping message payload.-encodePing :: Ping -> Either EncodeError BS.ByteString-encodePing (Ping numPong ignored) = do-  ignoredLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength ignored)-  Right $ mconcat [encodeU16 numPong, ignoredLen, ignored]+-- | Split a message into its type and payload.+--+--   >>> decode_envelope "\NUL\DC3\NUL\NUL"+--   Right (19,"\NUL\NUL")+decode_envelope :: BS.ByteString -> Either DecodeError (Word16, BS.ByteString)+decode_envelope bs = case decode_u16 bs of+  Just r  -> Right r+  Nothing -> Left DecodeInsufficientBytes --- | Encode a Pong message payload.-encodePong :: Pong -> Either EncodeError BS.ByteString-encodePong (Pong ignored) = do-  ignoredLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength ignored)-  Right $ mconcat [ignoredLen, ignored]+-- | Encode a BOLT #1 message, including its type.+--+--   >>> encode_message (MsgPong (Pong "" empty_tlv_stream))+--   Right "\NUL\DC3\NUL\NUL"+encode_message :: Message -> Either EncodeError BS.ByteString+encode_message m = do+  payload <- case m of+    MsgInit a                 -> encode_init a+    MsgError a                -> encode_error a+    MsgWarning a              -> encode_warning a+    MsgPing a                 -> encode_ping a+    MsgPong a                 -> encode_pong a+    MsgPeerStorage a          -> encode_peer_storage a+    MsgPeerStorageRetrieval a -> encode_peer_storage_retrieval a+  encode_envelope (message_type m) payload --- | Encode a PeerStorage message payload.-encodePeerStorage :: PeerStorage -> Either EncodeError BS.ByteString-encodePeerStorage (PeerStorage blob) = do-  blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob)-  Right $ mconcat [blobLen, blob]+-- | Decode a BOLT #1 message, including its type.+--+--   A type that BOLT #1 doesn't define yields 'DecodeUnknownEvenType'+--   or 'DecodeUnknownOddType'; callers dispatching messages from other+--   BOLTs should use 'decode_envelope' first.+--+--   >>> decode_message "\NUL\DC3\NUL\NUL"+--   Right (MsgPong (Pong {pong_ignored = "", pong_tlvs = TlvStream []}))+--   >>> decode_message "\NUL\DC4\NUL\NUL"+--   Left (DecodeUnknownEvenType 20)+decode_message :: BS.ByteString -> Either DecodeError Message+decode_message bs = do+  (t, payload) <- decode_envelope bs+  case t of+    16 -> MsgInit <$> decode_init payload+    17 -> MsgError <$> decode_error payload+    1  -> MsgWarning <$> decode_warning payload+    18 -> MsgPing <$> decode_ping payload+    19 -> MsgPong <$> decode_pong payload+    7  -> MsgPeerStorage <$> decode_peer_storage payload+    9  -> MsgPeerStorageRetrieval <$> decode_peer_storage_retrieval payload+    _ | even t    -> Left (DecodeUnknownEvenType t)+      | otherwise -> Left (DecodeUnknownOddType t) --- | Encode a PeerStorageRetrieval message payload.-encodePeerStorageRetrieval-  :: PeerStorageRetrieval -> Either EncodeError BS.ByteString-encodePeerStorageRetrieval (PeerStorageRetrieval blob) = do-  blobLen <- maybe (Left EncodeLengthOverflow) Right (encodeLength blob)-  Right $ mconcat [blobLen, blob]+-- helpers -------------------------------------------------------------------- --- | Encode a message to its payload bytes.------ Checks that the payload does not exceed 65533 bytes (the maximum--- possible given the 2-byte type field and 65535-byte message limit).-encodeMessage :: Message -> Either EncodeError BS.ByteString-encodeMessage msg = do-  payload <- case msg of-    MsgInitVal m                 -> encodeInit m-    MsgErrorVal m                -> encodeError m-    MsgWarningVal m              -> encodeWarning m-    MsgPingVal m                 -> encodePing m-    MsgPongVal m                 -> encodePong m-    MsgPeerStorageVal m          -> encodePeerStorage m-    MsgPeerStorageRetrievalVal m -> encodePeerStorageRetrieval m-  -- Payload must leave room for 2-byte type (max 65533 bytes)-  when (BS.length payload > 65533) $-    Left EncodeMessageTooLarge-  Right payload+prefixed :: BS.ByteString -> Either EncodeError BS.ByteString+prefixed bs = maybe (Left EncodeLengthOverflow) Right (encode_u16_prefixed bs) --- | Encode a message as a complete envelope (type + payload + extension).------ Per BOLT #1, the total message size must not exceed 65535 bytes.-encodeEnvelope :: Message -> Maybe TlvStream -> Either EncodeError BS.ByteString-encodeEnvelope msg mext = do-  payload <- encodeMessage msg-  let !typeBytes = encodeU16 (msgTypeWord (messageType msg))-      !extBytes = maybe BS.empty encodeTlvStream mext-      !result = mconcat [typeBytes, payload, extBytes]-  -- Per BOLT #1: message size must fit in 2 bytes (max 65535)-  when (BS.length result > 65535) $-    Left EncodeMessageTooLarge-  Right result+need :: Maybe a -> Either DecodeError a+need = maybe (Left DecodeInsufficientBytes) Right+{-# INLINE need #-} --- Decoding errors -------------------------------------------------------------+-- an extension stream in which no types are known+extension :: BS.ByteString -> Either DecodeError TlvStream+extension bs = either (Left . DecodeTlvError) Right+  (decode_tlv_stream (const False) bs) --- | Decoding errors.-data DecodeError-  = DecodeInsufficientBytes-  | DecodeInvalidLength-  | DecodeUnknownEvenType !Word16-  | DecodeUnknownOddType !Word16-  | DecodeTlvError !TlvError-  | DecodeInvalidChannelId-  | DecodeInvalidExtension !TlvError-  deriving stock (Eq, Show, Generic)+-- init ----------------------------------------------------------------------- -instance NFData DecodeError+-- | Encode an 'Init' payload.+encode_init :: Init -> Either EncodeError BS.ByteString+encode_init (Init gf f nets addr tlvs) = do+  gf' <- prefixed (BOLT9.render gf)+  f'  <- prefixed (BOLT9.render f)+  let known = maybe [] (\cs -> [TlvRecord 1 (mconcat (map un_chain_hash cs))])+                nets+           <> maybe [] (\a -> [TlvRecord 3 a]) addr+  stream <- maybe (Left EncodeInvalidTlvs) Right+              (tlv_stream (known <> un_tlv_stream tlvs))+  pure (gf' <> f' <> encode_tlv_stream stream) --- Message decoding ------------------------------------------------------------+-- | Decode an 'Init' payload.+decode_init :: BS.ByteString -> Either DecodeError Init+decode_init bs = do+  (gf, r0) <- need (decode_u16_prefixed bs)+  (f, r1)  <- need (decode_u16_prefixed r0)+  stream   <- either (Left . DecodeTlvError) Right+                (decode_tlv_stream (\t -> t == 1 || t == 3) r1)+  nets <- traverse networks (lookup_tlv 1 stream)+  pure Init+    { init_global_features = BOLT9.parse gf+    , init_features        = BOLT9.parse f+    , init_networks        = nets+    , init_remote_addr     = lookup_tlv 3 stream+    , init_tlvs            = filter_tlv_stream (\t -> t /= 1 && t /= 3) stream+    }+  where+    networks v+      | BS.length v `rem` 32 /= 0 = Left (DecodeInvalidTlvValue 1)+      | otherwise = Right (chunks v)+    chunks !v = case decode_chain_hash v of+      Just (h, rest) -> h : chunks rest+      Nothing        -> [] --- | Decode an Init message from payload bytes.------ Returns the decoded message and any remaining bytes.-decodeInit :: BS.ByteString -> Either DecodeError (Init, BS.ByteString)-decodeInit !bs = do-  (gfLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right-                      (decodeU16 bs)-  unless (BS.length rest1 >= fromIntegral gfLen) $-    Left DecodeInsufficientBytes-  let !gf = BS.take (fromIntegral gfLen) rest1-      !rest2 = BS.drop (fromIntegral gfLen) rest1-  (fLen, rest3) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 rest2)-  unless (BS.length rest3 >= fromIntegral fLen) $-    Left DecodeInsufficientBytes-  let !feat = BS.take (fromIntegral fLen) rest3-      !rest4 = BS.drop (fromIntegral fLen) rest3-  -- Parse optional TLV stream (consumes all remaining bytes for init)-  tlvs <- if BS.null rest4-    then Right (unsafeTlvStream [])-    else either (Left . DecodeTlvError) Right (decodeTlvStream rest4)-  initTlvList <- either (Left . DecodeTlvError) Right-                   (parseInitTlvs tlvs)-  -- Init consumes all bytes (TLVs are part of init, not extensions)-  Right (Init gf feat initTlvList, BS.empty)+-- error, warning ------------------------------------------------------------- --- | Decode an Error message from payload bytes.-decodeError :: BS.ByteString -> Either DecodeError (Error, BS.ByteString)-decodeError !bs = do-  unless (BS.length bs >= 32) $ Left DecodeInsufficientBytes-  let !cidBytes = BS.take 32 bs-      !rest1 = BS.drop 32 bs-  cid <- maybe (Left DecodeInvalidChannelId) Right (channelId cidBytes)-  (dLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 rest1)-  unless (BS.length rest2 >= fromIntegral dLen) $-    Left DecodeInsufficientBytes-  let !dat = BS.take (fromIntegral dLen) rest2-      !rest3 = BS.drop (fromIntegral dLen) rest2-  Right (Error cid dat, rest3)+-- | Encode an 'Error' payload.+encode_error :: Error -> Either EncodeError BS.ByteString+encode_error (Error cid dat tlvs) = do+  dat' <- prefixed dat+  pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs) --- | Decode a Warning message from payload bytes.-decodeWarning :: BS.ByteString -> Either DecodeError (Warning, BS.ByteString)-decodeWarning !bs = do-  unless (BS.length bs >= 32) $ Left DecodeInsufficientBytes-  let !cidBytes = BS.take 32 bs-      !rest1 = BS.drop 32 bs-  cid <- maybe (Left DecodeInvalidChannelId) Right (channelId cidBytes)-  (dLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 rest1)-  unless (BS.length rest2 >= fromIntegral dLen) $-    Left DecodeInsufficientBytes-  let !dat = BS.take (fromIntegral dLen) rest2-      !rest3 = BS.drop (fromIntegral dLen) rest2-  Right (Warning cid dat, rest3)+-- | Decode an 'Error' payload.+decode_error :: BS.ByteString -> Either DecodeError Error+decode_error bs = do+  (cid, r0) <- need (decode_channel_id bs)+  (dat, r1) <- need (decode_u16_prefixed r0)+  Error cid dat <$> extension r1 --- | Decode a Ping message from payload bytes.-decodePing :: BS.ByteString -> Either DecodeError (Ping, BS.ByteString)-decodePing !bs = do-  (numPong, rest1) <- maybe (Left DecodeInsufficientBytes) Right-                        (decodeU16 bs)-  (bLen, rest2) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 rest1)-  unless (BS.length rest2 >= fromIntegral bLen) $-    Left DecodeInsufficientBytes-  let !ignored = BS.take (fromIntegral bLen) rest2-      !rest3 = BS.drop (fromIntegral bLen) rest2-  Right (Ping numPong ignored, rest3)+-- | Encode a 'Warning' payload.+encode_warning :: Warning -> Either EncodeError BS.ByteString+encode_warning (Warning cid dat tlvs) = do+  dat' <- prefixed dat+  pure (un_channel_id cid <> dat' <> encode_tlv_stream tlvs) --- | Decode a Pong message from payload bytes.-decodePong :: BS.ByteString -> Either DecodeError (Pong, BS.ByteString)-decodePong !bs = do-  (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 bs)-  unless (BS.length rest1 >= fromIntegral bLen) $-    Left DecodeInsufficientBytes-  let !ignored = BS.take (fromIntegral bLen) rest1-      !rest2 = BS.drop (fromIntegral bLen) rest1-  Right (Pong ignored, rest2)+-- | Decode a 'Warning' payload.+decode_warning :: BS.ByteString -> Either DecodeError Warning+decode_warning bs = do+  (cid, r0) <- need (decode_channel_id bs)+  (dat, r1) <- need (decode_u16_prefixed r0)+  Warning cid dat <$> extension r1 --- | Decode a PeerStorage message from payload bytes.-decodePeerStorage-  :: BS.ByteString -> Either DecodeError (PeerStorage, BS.ByteString)-decodePeerStorage !bs = do-  (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 bs)-  unless (BS.length rest1 >= fromIntegral bLen) $-    Left DecodeInsufficientBytes-  let !blob = BS.take (fromIntegral bLen) rest1-      !rest2 = BS.drop (fromIntegral bLen) rest1-  Right (PeerStorage blob, rest2)+-- ping, pong ----------------------------------------------------------------- --- | Decode a PeerStorageRetrieval message from payload bytes.-decodePeerStorageRetrieval-  :: BS.ByteString-  -> Either DecodeError (PeerStorageRetrieval, BS.ByteString)-decodePeerStorageRetrieval !bs = do-  (bLen, rest1) <- maybe (Left DecodeInsufficientBytes) Right-                     (decodeU16 bs)-  unless (BS.length rest1 >= fromIntegral bLen) $-    Left DecodeInsufficientBytes-  let !blob = BS.take (fromIntegral bLen) rest1-      !rest2 = BS.drop (fromIntegral bLen) rest1-  Right (PeerStorageRetrieval blob, rest2)+-- | Encode a 'Ping' payload.+encode_ping :: Ping -> Either EncodeError BS.ByteString+encode_ping (Ping n ign tlvs) = do+  ign' <- prefixed ign+  pure (encode_u16 n <> ign' <> encode_tlv_stream tlvs) --- | Decode a message from its type and payload.------ Returns the decoded message and any remaining bytes (for extensions).--- For unknown types, returns an appropriate error.-decodeMessage-  :: MsgType -> BS.ByteString -> Either DecodeError (Message, BS.ByteString)-decodeMessage MsgInit bs = do-  (m, rest) <- decodeInit bs-  Right (MsgInitVal m, rest)-decodeMessage MsgError bs = do-  (m, rest) <- decodeError bs-  Right (MsgErrorVal m, rest)-decodeMessage MsgWarning bs = do-  (m, rest) <- decodeWarning bs-  Right (MsgWarningVal m, rest)-decodeMessage MsgPing bs = do-  (m, rest) <- decodePing bs-  Right (MsgPingVal m, rest)-decodeMessage MsgPong bs = do-  (m, rest) <- decodePong bs-  Right (MsgPongVal m, rest)-decodeMessage MsgPeerStorage bs = do-  (m, rest) <- decodePeerStorage bs-  Right (MsgPeerStorageVal m, rest)-decodeMessage MsgPeerStorageRet bs = do-  (m, rest) <- decodePeerStorageRetrieval bs-  Right (MsgPeerStorageRetrievalVal m, rest)-decodeMessage (MsgUnknown w) _-  | even w    = Left (DecodeUnknownEvenType w)-  | otherwise = Left (DecodeUnknownOddType w)+-- | Decode a 'Ping' payload.+decode_ping :: BS.ByteString -> Either DecodeError Ping+decode_ping bs = do+  (n, r0)   <- need (decode_u16 bs)+  (ign, r1) <- need (decode_u16_prefixed r0)+  Ping n ign <$> extension r1 --- | Decode a complete envelope (type + payload + optional extension).------ Per BOLT #1:--- - Unknown odd message types are ignored (returns Nothing for message)--- - Unknown even message types cause connection close (returns error)--- - Invalid extension TLV causes connection close (returns error)------ This uses the default policy of treating all extension TLV types as--- unknown. Use 'decodeEnvelopeWith' for configurable extension handling.------ Returns the decoded message (if known) and any extension TLVs.-decodeEnvelope-  :: BS.ByteString-  -> Either DecodeError (Maybe Message, Maybe TlvStream)-decodeEnvelope = decodeEnvelopeWith (const False)+-- | Encode a 'Pong' payload.+encode_pong :: Pong -> Either EncodeError BS.ByteString+encode_pong (Pong ign tlvs) = do+  ign' <- prefixed ign+  pure (ign' <> encode_tlv_stream tlvs) --- | Decode a complete envelope with configurable extension TLV handling.------ The predicate determines which extension TLV types are "known" and--- should be preserved. Unknown even types cause failure; unknown odd--- types are skipped.------ Use @decodeEnvelopeWith (const False)@ to reject all even extension--- types (the default behavior of 'decodeEnvelope').+-- | Decode a 'Pong' payload.+decode_pong :: BS.ByteString -> Either DecodeError Pong+decode_pong bs = do+  (ign, r0) <- need (decode_u16_prefixed bs)+  Pong ign <$> extension r0++-- | The 'Pong' a node must send in reply to a 'Ping', if any. Per+--   BOLT #1, a ping requesting 65532 or more bytes is ignored. ----- Use @decodeEnvelopeWith (const True)@ to accept all extension types.-decodeEnvelopeWith-  :: (Word64 -> Bool)  -- ^ Predicate: is this extension TLV type known?-  -> BS.ByteString-  -> Either DecodeError (Maybe Message, Maybe TlvStream)-decodeEnvelopeWith isKnownExt !bs = do-  (typeWord, rest1) <- maybe (Left DecodeInsufficientBytes) Right-                         (decodeU16 bs)-  let !msgType = parseMsgType typeWord-  case msgType of-    MsgUnknown w-      | even w    -> Left (DecodeUnknownEvenType w)-      | otherwise -> Right (Nothing, Nothing)  -- Ignore unknown odd types-    _ -> do-      (msg, rest2) <- decodeMessage msgType rest1-      -- Parse any remaining bytes as extension TLV-      ext <- if BS.null rest2-        then Right Nothing-        else case decodeTlvStreamWith isKnownExt rest2 of-          Left e  -> Left (DecodeInvalidExtension e)-          Right s -> Right (Just s)-      Right (Just msg, ext)+--   >>> ping_response (Ping 4 "" empty_tlv_stream)+--   Just (Pong {pong_ignored = "\NUL\NUL\NUL\NUL", pong_tlvs = TlvStream []})+--   >>> ping_response (Ping 65532 "" empty_tlv_stream)+--   Nothing+ping_response :: Ping -> Maybe Pong+ping_response (Ping n _ _)+  | n >= 65532 = Nothing+  | otherwise  =+      Just (Pong (BS.replicate (fromIntegral n) 0x00) empty_tlv_stream)++-- peer storage ---------------------------------------------------------------++-- | Encode a 'PeerStorage' payload.+encode_peer_storage :: PeerStorage -> Either EncodeError BS.ByteString+encode_peer_storage (PeerStorage blob tlvs) = do+  blob' <- prefixed blob+  pure (blob' <> encode_tlv_stream tlvs)++-- | Decode a 'PeerStorage' payload.+decode_peer_storage :: BS.ByteString -> Either DecodeError PeerStorage+decode_peer_storage bs = do+  (blob, r0) <- need (decode_u16_prefixed bs)+  PeerStorage blob <$> extension r0++-- | Encode a 'PeerStorageRetrieval' payload.+encode_peer_storage_retrieval+  :: PeerStorageRetrieval -> Either EncodeError BS.ByteString+encode_peer_storage_retrieval (PeerStorageRetrieval blob tlvs) = do+  blob' <- prefixed blob+  pure (blob' <> encode_tlv_stream tlvs)++-- | Decode a 'PeerStorageRetrieval' payload.+decode_peer_storage_retrieval+  :: BS.ByteString -> Either DecodeError PeerStorageRetrieval+decode_peer_storage_retrieval bs = do+  (blob, r0) <- need (decode_u16_prefixed bs)+  PeerStorageRetrieval blob <$> extension r0

@@ -1,6 +1,5 @@-{-# OPTIONS_HADDOCK prune #-}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}  -- | -- Module: Lightning.Protocol.BOLT1.Message@@ -8,206 +7,126 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Message types for BOLT #1.+-- The messages defined by BOLT #1.  module Lightning.Protocol.BOLT1.Message (-  -- * Message types-    MsgType(..)-  , msgTypeWord-  , parseMsgType--  -- * Channel identifiers-  , ChannelId-  , channelId-  , unChannelId-  , allChannels--  -- * Setup messages-  , Init(..)+    Init(..)   , Error(..)   , Warning(..)--  -- * Control messages   , Ping(..)   , Pong(..)--  -- * Peer storage messages   , PeerStorage(..)   , PeerStorageRetrieval(..)--  -- * Message envelope   , Message(..)-  , messageType-  , Envelope(..)+  , message_type   ) where  import Control.DeepSeq (NFData) import qualified Data.ByteString as BS import Data.Word (Word16) import GHC.Generics (Generic)+import Lightning.Protocol.BOLT1.Prim import Lightning.Protocol.BOLT1.TLV---- Message types ------------------------------------------------------------------- | BOLT #1 message type codes.-data MsgType-  = MsgInit              -- ^ 16-  | MsgError             -- ^ 17-  | MsgPing              -- ^ 18-  | MsgPong              -- ^ 19-  | MsgWarning           -- ^ 1-  | MsgPeerStorage       -- ^ 7-  | MsgPeerStorageRet    -- ^ 9-  | MsgUnknown !Word16   -- ^ Unknown type-  deriving stock (Eq, Show, Generic)--instance NFData MsgType---- | Get the numeric type code for a message type.-msgTypeWord :: MsgType -> Word16-msgTypeWord MsgInit            = 16-msgTypeWord MsgError           = 17-msgTypeWord MsgPing            = 18-msgTypeWord MsgPong            = 19-msgTypeWord MsgWarning         = 1-msgTypeWord MsgPeerStorage     = 7-msgTypeWord MsgPeerStorageRet  = 9-msgTypeWord (MsgUnknown w)     = w---- | Parse a message type from a word.-parseMsgType :: Word16 -> MsgType-parseMsgType 16 = MsgInit-parseMsgType 17 = MsgError-parseMsgType 18 = MsgPing-parseMsgType 19 = MsgPong-parseMsgType 1  = MsgWarning-parseMsgType 7  = MsgPeerStorage-parseMsgType 9  = MsgPeerStorageRet-parseMsgType w  = MsgUnknown w---- Channel identifiers ------------------------------------------------------------- | A 32-byte channel identifier.------ Use 'channelId' to construct, which validates the length.--- Use 'allChannels' for connection-level errors (all-zeros channel ID).-newtype ChannelId = ChannelId BS.ByteString-  deriving stock (Eq, Show, Generic)--instance NFData ChannelId---- | Construct a 'ChannelId' from a 32-byte 'BS.ByteString'.------ Returns 'Nothing' if the input is not exactly 32 bytes.------ >>> channelId (BS.replicate 32 0x00)--- Just (ChannelId "\NUL\NUL...")--- >>> channelId "too short"--- Nothing-channelId :: BS.ByteString -> Maybe ChannelId-channelId bs-  | BS.length bs == 32 = Just (ChannelId bs)-  | otherwise          = Nothing-{-# INLINE channelId #-}+import qualified Lightning.Protocol.BOLT9 as BOLT9 --- | The all-zeros channel ID, used for connection-level errors.+-- | The @init@ message (type 16). ----- Per BOLT #1, setting channel_id to all zeros means the error applies--- to the connection rather than a specific channel.-allChannels :: ChannelId-allChannels = ChannelId (BS.replicate 32 0x00)---- | Extract the raw bytes from a 'ChannelId'.-unChannelId :: ChannelId -> BS.ByteString-unChannelId (ChannelId bs) = bs-{-# INLINE unChannelId #-}---- Message ADTs -------------------------------------------------------------------- | The init message (type 16).+--   The two feature vectors are kept as received. Per BOLT #1, a+--   receiver treats their union ('BOLT9.union') as the peer's+--   features. data Init = Init-  { initGlobalFeatures :: !BS.ByteString-  , initFeatures       :: !BS.ByteString-  , initTlvs           :: ![InitTlv]-  } deriving stock (Eq, Show, Generic)+  { init_global_features :: !BOLT9.FeatureVector+  , init_features        :: !BOLT9.FeatureVector+  , init_networks        :: !(Maybe [ChainHash])+    -- ^ @networks@ (TLV type 1): chains the node is interested in+  , init_remote_addr     :: !(Maybe BS.ByteString)+    -- ^ @remote_addr@ (TLV type 3): a raw BOLT #7 address descriptor+  , init_tlvs            :: !TlvStream+    -- ^ unknown odd TLV records+  } deriving (Eq, Show, Generic)  instance NFData Init --- | The error message (type 17).+-- | The @error@ message (type 17). data Error = Error-  { errorChannelId :: !ChannelId-  , errorData      :: !BS.ByteString-  } deriving stock (Eq, Show, Generic)+  { error_channel_id :: !ChannelId+  , error_data       :: !BS.ByteString+  , error_tlvs       :: !TlvStream+    -- ^ extension TLV records (all unknown odd)+  } deriving (Eq, Show, Generic)  instance NFData Error --- | The warning message (type 1).+-- | The @warning@ message (type 1). data Warning = Warning-  { warningChannelId :: !ChannelId-  , warningData      :: !BS.ByteString-  } deriving stock (Eq, Show, Generic)+  { warning_channel_id :: !ChannelId+  , warning_data       :: !BS.ByteString+  , warning_tlvs       :: !TlvStream+    -- ^ extension TLV records (all unknown odd)+  } deriving (Eq, Show, Generic)  instance NFData Warning --- | The ping message (type 18).+-- | The @ping@ message (type 18). data Ping = Ping-  { pingNumPongBytes :: {-# UNPACK #-} !Word16-  , pingIgnored      :: !BS.ByteString-  } deriving stock (Eq, Show, Generic)+  { ping_num_pong_bytes :: {-# UNPACK #-} !Word16+  , ping_ignored        :: !BS.ByteString+  , ping_tlvs           :: !TlvStream+    -- ^ extension TLV records (all unknown odd)+  } deriving (Eq, Show, Generic)  instance NFData Ping --- | The pong message (type 19).+-- | The @pong@ message (type 19). data Pong = Pong-  { pongIgnored :: !BS.ByteString-  } deriving stock (Eq, Show, Generic)+  { pong_ignored :: !BS.ByteString+  , pong_tlvs    :: !TlvStream+    -- ^ extension TLV records (all unknown odd)+  } deriving (Eq, Show, Generic)  instance NFData Pong --- | The peer_storage message (type 7).+-- | The @peer_storage@ message (type 7). data PeerStorage = PeerStorage-  { peerStorageBlob :: !BS.ByteString-  } deriving stock (Eq, Show, Generic)+  { peer_storage_blob :: !BS.ByteString+  , peer_storage_tlvs :: !TlvStream+    -- ^ extension TLV records (all unknown odd)+  } deriving (Eq, Show, Generic)  instance NFData PeerStorage --- | The peer_storage_retrieval message (type 9).+-- | The @peer_storage_retrieval@ message (type 9). data PeerStorageRetrieval = PeerStorageRetrieval-  { peerStorageRetrievalBlob :: !BS.ByteString-  } deriving stock (Eq, Show, Generic)+  { peer_storage_retrieval_blob :: !BS.ByteString+  , peer_storage_retrieval_tlvs :: !TlvStream+    -- ^ extension TLV records (all unknown odd)+  } deriving (Eq, Show, Generic)  instance NFData PeerStorageRetrieval --- | All BOLT #1 messages.+-- | A BOLT #1 message. data Message-  = MsgInitVal !Init-  | MsgErrorVal !Error-  | MsgWarningVal !Warning-  | MsgPingVal !Ping-  | MsgPongVal !Pong-  | MsgPeerStorageVal !PeerStorage-  | MsgPeerStorageRetrievalVal !PeerStorageRetrieval-  deriving stock (Eq, Show, Generic)+  = MsgInit !Init+  | MsgError !Error+  | MsgWarning !Warning+  | MsgPing !Ping+  | MsgPong !Pong+  | MsgPeerStorage !PeerStorage+  | MsgPeerStorageRetrieval !PeerStorageRetrieval+  deriving (Eq, Show, Generic)  instance NFData Message --- | Get the message type for a message.-messageType :: Message -> MsgType-messageType (MsgInitVal _)                 = MsgInit-messageType (MsgErrorVal _)                = MsgError-messageType (MsgWarningVal _)              = MsgWarning-messageType (MsgPingVal _)                 = MsgPing-messageType (MsgPongVal _)                 = MsgPong-messageType (MsgPeerStorageVal _)          = MsgPeerStorage-messageType (MsgPeerStorageRetrievalVal _) = MsgPeerStorageRet---- Message envelope ---------------------------------------------------------------- | A complete message envelope with type, payload, and optional extension.-data Envelope = Envelope-  { envType      :: !MsgType-  , envPayload   :: !BS.ByteString-  , envExtension :: !(Maybe TlvStream)-  } deriving stock (Eq, Show, Generic)--instance NFData Envelope+-- | The wire type of a 'Message'.+--+--   >>> message_type (MsgPong (Pong "" empty_tlv_stream))+--   19+message_type :: Message -> Word16+message_type m = case m of+  MsgInit {}                 -> 16+  MsgError {}                -> 17+  MsgWarning {}              -> 1+  MsgPing {}                 -> 18+  MsgPong {}                 -> 19+  MsgPeerStorage {}          -> 7+  MsgPeerStorageRetrieval {} -> 9

@@ -1,527 +1,804 @@-{-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}---- |--- Module: Lightning.Protocol.BOLT1.Prim--- Copyright: (c) 2025 Jared Tobin--- License: MIT--- Maintainer: Jared Tobin <jared@ppad.tech>------ Primitive type encoding and decoding for BOLT #1.--module Lightning.Protocol.BOLT1.Prim (-  -- * Chain hash-    ChainHash-  , chainHash-  , unChainHash--  -- * Unsigned integer encoding-  , encodeU16-  , encodeU32-  , encodeU64--  -- * Signed integer encoding-  , encodeS8-  , encodeS16-  , encodeS32-  , encodeS64--  -- * Truncated unsigned integer encoding-  , encodeTu16-  , encodeTu32-  , encodeTu64--  -- * Minimal signed integer encoding-  , encodeMinSigned--  -- * BigSize encoding-  , encodeBigSize--  -- * Unsigned integer decoding-  , decodeU16-  , decodeU32-  , decodeU64--  -- * Signed integer decoding-  , decodeS8-  , decodeS16-  , decodeS32-  , decodeS64--  -- * Truncated unsigned integer decoding-  , decodeTu16-  , decodeTu32-  , decodeTu64--  -- * Minimal signed integer decoding-  , decodeMinSigned--  -- * BigSize decoding-  , decodeBigSize--  -- * Internal helpers-  , encodeLength-  ) where--import Control.DeepSeq (NFData)-import Data.Bits (unsafeShiftL, unsafeShiftR, (.|.))-import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as BSB-import qualified Data.ByteString.Lazy as BSL-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word16, Word32, Word64)-import GHC.Generics (Generic)---- Chain hash ---------------------------------------------------------------------- | A chain hash (32-byte hash identifying a blockchain).-newtype ChainHash = ChainHash BS.ByteString-  deriving stock (Eq, Show, Generic)--instance NFData ChainHash---- | Construct a chain hash from a 32-byte bytestring.------ Returns 'Nothing' if the input is not exactly 32 bytes.-chainHash :: BS.ByteString -> Maybe ChainHash-chainHash bs-  | BS.length bs == 32 = Just (ChainHash bs)-  | otherwise = Nothing-{-# INLINE chainHash #-}---- | Extract the raw bytes from a chain hash.-unChainHash :: ChainHash -> BS.ByteString-unChainHash (ChainHash bs) = bs-{-# INLINE unChainHash #-}---- Unsigned integer encoding ------------------------------------------------------- | Encode a 16-bit unsigned integer (big-endian).------ >>> encodeU16 0x0102--- "\SOH\STX"-encodeU16 :: Word16 -> BS.ByteString-encodeU16 = BSL.toStrict . BSB.toLazyByteString . BSB.word16BE-{-# INLINE encodeU16 #-}---- | Encode a 32-bit unsigned integer (big-endian).------ >>> encodeU32 0x01020304--- "\SOH\STX\ETX\EOT"-encodeU32 :: Word32 -> BS.ByteString-encodeU32 = BSL.toStrict . BSB.toLazyByteString . BSB.word32BE-{-# INLINE encodeU32 #-}---- | Encode a 64-bit unsigned integer (big-endian).------ >>> encodeU64 0x0102030405060708--- "\SOH\STX\ETX\EOT\ENQ\ACK\a\b"-encodeU64 :: Word64 -> BS.ByteString-encodeU64 = BSL.toStrict . BSB.toLazyByteString . BSB.word64BE-{-# INLINE encodeU64 #-}---- Signed integer encoding --------------------------------------------------------- | Encode an 8-bit signed integer.------ >>> encodeS8 42--- "*"--- >>> encodeS8 (-42)--- "\214"-encodeS8 :: Int8 -> BS.ByteString-encodeS8 = BS.singleton . fromIntegral-{-# INLINE encodeS8 #-}---- | Encode a 16-bit signed integer (big-endian two's complement).------ >>> encodeS16 0x0102--- "\SOH\STX"--- >>> encodeS16 (-1)--- "\255\255"-encodeS16 :: Int16 -> BS.ByteString-encodeS16 = BSL.toStrict . BSB.toLazyByteString . BSB.int16BE-{-# INLINE encodeS16 #-}---- | Encode a 32-bit signed integer (big-endian two's complement).------ >>> encodeS32 0x01020304--- "\SOH\STX\ETX\EOT"--- >>> encodeS32 (-1)--- "\255\255\255\255"-encodeS32 :: Int32 -> BS.ByteString-encodeS32 = BSL.toStrict . BSB.toLazyByteString . BSB.int32BE-{-# INLINE encodeS32 #-}---- | Encode a 64-bit signed integer (big-endian two's complement).------ >>> encodeS64 0x0102030405060708--- "\SOH\STX\ETX\EOT\ENQ\ACK\a\b"--- >>> encodeS64 (-1)--- "\255\255\255\255\255\255\255\255"-encodeS64 :: Int64 -> BS.ByteString-encodeS64 = BSL.toStrict . BSB.toLazyByteString . BSB.int64BE-{-# INLINE encodeS64 #-}---- Truncated unsigned integer encoding --------------------------------------------- | Encode a truncated 16-bit unsigned integer (0-2 bytes).------ Leading zeros are omitted per BOLT #1. Zero encodes to empty.------ >>> encodeTu16 0--- ""--- >>> encodeTu16 1--- "\SOH"--- >>> encodeTu16 256--- "\SOH\NUL"-encodeTu16 :: Word16 -> BS.ByteString-encodeTu16 0 = BS.empty-encodeTu16 !x-  | x < 0x100 = BS.singleton (fromIntegral x)-  | otherwise = encodeU16 x-{-# INLINE encodeTu16 #-}---- | Encode a truncated 32-bit unsigned integer (0-4 bytes).------ Leading zeros are omitted per BOLT #1. Zero encodes to empty.------ >>> encodeTu32 0--- ""--- >>> encodeTu32 1--- "\SOH"--- >>> encodeTu32 0x010000--- "\SOH\NUL\NUL"-encodeTu32 :: Word32 -> BS.ByteString-encodeTu32 0 = BS.empty-encodeTu32 !x-  | x < 0x100       = BS.singleton (fromIntegral x)-  | x < 0x10000     = encodeU16 (fromIntegral x)-  | x < 0x1000000   = BS.pack [ fromIntegral (x `unsafeShiftR` 16)-                              , fromIntegral (x `unsafeShiftR` 8)-                              , fromIntegral x-                              ]-  | otherwise       = encodeU32 x-{-# INLINE encodeTu32 #-}---- | Encode a truncated 64-bit unsigned integer (0-8 bytes).------ Leading zeros are omitted per BOLT #1. Zero encodes to empty.------ >>> encodeTu64 0--- ""--- >>> encodeTu64 1--- "\SOH"--- >>> encodeTu64 0x0100000000--- "\SOH\NUL\NUL\NUL\NUL"-encodeTu64 :: Word64 -> BS.ByteString-encodeTu64 0 = BS.empty-encodeTu64 !x-  | x < 0x100             = BS.singleton (fromIntegral x)-  | x < 0x10000           = encodeU16 (fromIntegral x)-  | x < 0x1000000         = BS.pack [ fromIntegral (x `unsafeShiftR` 16)-                                    , fromIntegral (x `unsafeShiftR` 8)-                                    , fromIntegral x-                                    ]-  | x < 0x100000000       = encodeU32 (fromIntegral x)-  | x < 0x10000000000     = BS.pack [ fromIntegral (x `unsafeShiftR` 32)-                                    , fromIntegral (x `unsafeShiftR` 24)-                                    , fromIntegral (x `unsafeShiftR` 16)-                                    , fromIntegral (x `unsafeShiftR` 8)-                                    , fromIntegral x-                                    ]-  | x < 0x1000000000000   = BS.pack [ fromIntegral (x `unsafeShiftR` 40)-                                    , fromIntegral (x `unsafeShiftR` 32)-                                    , fromIntegral (x `unsafeShiftR` 24)-                                    , fromIntegral (x `unsafeShiftR` 16)-                                    , fromIntegral (x `unsafeShiftR` 8)-                                    , fromIntegral x-                                    ]-  | x < 0x100000000000000 = BS.pack [ fromIntegral (x `unsafeShiftR` 48)-                                    , fromIntegral (x `unsafeShiftR` 40)-                                    , fromIntegral (x `unsafeShiftR` 32)-                                    , fromIntegral (x `unsafeShiftR` 24)-                                    , fromIntegral (x `unsafeShiftR` 16)-                                    , fromIntegral (x `unsafeShiftR` 8)-                                    , fromIntegral x-                                    ]-  | otherwise             = encodeU64 x-{-# INLINE encodeTu64 #-}---- Minimal signed integer encoding ------------------------------------------------- | Encode a signed 64-bit integer using minimal bytes.------ Uses the smallest number of bytes that can represent the value--- in two's complement. Per BOLT #1 Appendix D test vectors.------ >>> encodeMinSigned 0--- "\NUL"--- >>> encodeMinSigned 127--- "\DEL"--- >>> encodeMinSigned 128--- "\NUL\128"--- >>> encodeMinSigned (-1)--- "\255"--- >>> encodeMinSigned (-128)--- "\128"--- >>> encodeMinSigned (-129)--- "\255\DEL"-encodeMinSigned :: Int64 -> BS.ByteString-encodeMinSigned !x-  | x >= -128 && x <= 127 =-      -- Fits in 1 byte-      BS.singleton (fromIntegral x)-  | x >= -32768 && x <= 32767 =-      -- Fits in 2 bytes-      encodeS16 (fromIntegral x)-  | x >= -2147483648 && x <= 2147483647 =-      -- Fits in 4 bytes-      encodeS32 (fromIntegral x)-  | otherwise =-      -- Need 8 bytes-      encodeS64 x-{-# INLINE encodeMinSigned #-}---- BigSize encoding ---------------------------------------------------------------- | Encode a BigSize value (variable-length unsigned integer).------ >>> encodeBigSize 0--- "\NUL"--- >>> encodeBigSize 252--- "\252"--- >>> encodeBigSize 253--- "\253\NUL\253"--- >>> encodeBigSize 65536--- "\254\NUL\SOH\NUL\NUL"-encodeBigSize :: Word64 -> BS.ByteString-encodeBigSize !x-  | x < 0xfd = BS.singleton (fromIntegral x)-  | x < 0x10000 = BS.cons 0xfd (encodeU16 (fromIntegral x))-  | x < 0x100000000 = BS.cons 0xfe (encodeU32 (fromIntegral x))-  | otherwise = BS.cons 0xff (encodeU64 x)-{-# INLINE encodeBigSize #-}---- Length encoding ----------------------------------------------------------------- | Encode a length as u16, checking bounds.------ Returns Nothing if the length exceeds 65535.-encodeLength :: BS.ByteString -> Maybe BS.ByteString-encodeLength !bs-  | BS.length bs > 65535 = Nothing-  | otherwise = Just (encodeU16 (fromIntegral (BS.length bs)))-{-# INLINE encodeLength #-}---- Unsigned integer decoding ------------------------------------------------------- | Decode a 16-bit unsigned integer (big-endian).-decodeU16 :: BS.ByteString -> Maybe (Word16, BS.ByteString)-decodeU16 !bs-  | BS.length bs < 2 = Nothing-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0)-          !b1 = fromIntegral (BS.index bs 1)-          !val = (b0 `unsafeShiftL` 8) .|. b1-      in  Just (val, BS.drop 2 bs)-{-# INLINE decodeU16 #-}---- | Decode a 32-bit unsigned integer (big-endian).-decodeU32 :: BS.ByteString -> Maybe (Word32, BS.ByteString)-decodeU32 !bs-  | BS.length bs < 4 = Nothing-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0)-          !b1 = fromIntegral (BS.index bs 1)-          !b2 = fromIntegral (BS.index bs 2)-          !b3 = fromIntegral (BS.index bs 3)-          !val = (b0 `unsafeShiftL` 24) .|. (b1 `unsafeShiftL` 16)-              .|. (b2 `unsafeShiftL` 8) .|. b3-      in  Just (val, BS.drop 4 bs)-{-# INLINE decodeU32 #-}---- | Decode a 64-bit unsigned integer (big-endian).-decodeU64 :: BS.ByteString -> Maybe (Word64, BS.ByteString)-decodeU64 !bs-  | BS.length bs < 8 = Nothing-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0)-          !b1 = fromIntegral (BS.index bs 1)-          !b2 = fromIntegral (BS.index bs 2)-          !b3 = fromIntegral (BS.index bs 3)-          !b4 = fromIntegral (BS.index bs 4)-          !b5 = fromIntegral (BS.index bs 5)-          !b6 = fromIntegral (BS.index bs 6)-          !b7 = fromIntegral (BS.index bs 7)-          !val = (b0 `unsafeShiftL` 56) .|. (b1 `unsafeShiftL` 48)-              .|. (b2 `unsafeShiftL` 40) .|. (b3 `unsafeShiftL` 32)-              .|. (b4 `unsafeShiftL` 24) .|. (b5 `unsafeShiftL` 16)-              .|. (b6 `unsafeShiftL` 8) .|. b7-      in  Just (val, BS.drop 8 bs)-{-# INLINE decodeU64 #-}---- Signed integer decoding --------------------------------------------------------- | Decode an 8-bit signed integer.-decodeS8 :: BS.ByteString -> Maybe (Int8, BS.ByteString)-decodeS8 !bs-  | BS.null bs = Nothing-  | otherwise  = Just (fromIntegral (BS.index bs 0), BS.drop 1 bs)-{-# INLINE decodeS8 #-}---- | Decode a 16-bit signed integer (big-endian two's complement).-decodeS16 :: BS.ByteString -> Maybe (Int16, BS.ByteString)-decodeS16 !bs = do-  (w, rest) <- decodeU16 bs-  Just (fromIntegral w, rest)-{-# INLINE decodeS16 #-}---- | Decode a 32-bit signed integer (big-endian two's complement).-decodeS32 :: BS.ByteString -> Maybe (Int32, BS.ByteString)-decodeS32 !bs = do-  (w, rest) <- decodeU32 bs-  Just (fromIntegral w, rest)-{-# INLINE decodeS32 #-}---- | Decode a 64-bit signed integer (big-endian two's complement).-decodeS64 :: BS.ByteString -> Maybe (Int64, BS.ByteString)-decodeS64 !bs = do-  (w, rest) <- decodeU64 bs-  Just (fromIntegral w, rest)-{-# INLINE decodeS64 #-}---- Truncated unsigned integer decoding --------------------------------------------- | Decode a truncated 16-bit unsigned integer (0-2 bytes).------ Returns Nothing if the encoding is non-minimal (has leading zeros).-decodeTu16 :: Int -> BS.ByteString -> Maybe (Word16, BS.ByteString)-decodeTu16 !len !bs-  | len < 0 || len > 2 = Nothing-  | BS.length bs < len = Nothing-  | len == 0 = Just (0, bs)-  | otherwise =-      let !bytes = BS.take len bs-          !rest = BS.drop len bs-      in  if BS.index bytes 0 == 0-            then Nothing  -- non-minimal: leading zero-            else Just (decodeBeWord16 bytes, rest)-  where-    decodeBeWord16 :: BS.ByteString -> Word16-    decodeBeWord16 b = case BS.length b of-      1 -> fromIntegral (BS.index b 0)-      2 -> (fromIntegral (BS.index b 0) `unsafeShiftL` 8)-        .|. fromIntegral (BS.index b 1)-      _ -> 0-{-# INLINE decodeTu16 #-}---- | Decode a truncated 32-bit unsigned integer (0-4 bytes).------ Returns Nothing if the encoding is non-minimal (has leading zeros).-decodeTu32 :: Int -> BS.ByteString -> Maybe (Word32, BS.ByteString)-decodeTu32 !len !bs-  | len < 0 || len > 4 = Nothing-  | BS.length bs < len = Nothing-  | len == 0 = Just (0, bs)-  | otherwise =-      let !bytes = BS.take len bs-          !rest = BS.drop len bs-      in  if BS.index bytes 0 == 0-            then Nothing  -- non-minimal: leading zero-            else Just (decodeBeWord32 len bytes, rest)-  where-    decodeBeWord32 :: Int -> BS.ByteString -> Word32-    decodeBeWord32 n b = go 0 0-      where-        go !acc !i-          | i >= n    = acc-          | otherwise = go ((acc `unsafeShiftL` 8)-                           .|. fromIntegral (BS.index b i)) (i + 1)-{-# INLINE decodeTu32 #-}---- | Decode a truncated 64-bit unsigned integer (0-8 bytes).------ Returns Nothing if the encoding is non-minimal (has leading zeros).-decodeTu64 :: Int -> BS.ByteString -> Maybe (Word64, BS.ByteString)-decodeTu64 !len !bs-  | len < 0 || len > 8 = Nothing-  | BS.length bs < len = Nothing-  | len == 0 = Just (0, bs)-  | otherwise =-      let !bytes = BS.take len bs-          !rest = BS.drop len bs-      in  if BS.index bytes 0 == 0-            then Nothing  -- non-minimal: leading zero-            else Just (decodeBeWord64 len bytes, rest)-  where-    decodeBeWord64 :: Int -> BS.ByteString -> Word64-    decodeBeWord64 n b = go 0 0-      where-        go !acc !i-          | i >= n    = acc-          | otherwise = go ((acc `unsafeShiftL` 8)-                           .|. fromIntegral (BS.index b i)) (i + 1)-{-# INLINE decodeTu64 #-}---- Minimal signed integer decoding ------------------------------------------------- | Decode a minimal signed integer (1, 2, 4, or 8 bytes).------ Validates that the encoding is minimal: the value could not be--- represented in fewer bytes. Per BOLT #1 Appendix D test vectors.-decodeMinSigned :: Int -> BS.ByteString -> Maybe (Int64, BS.ByteString)-decodeMinSigned !len !bs-  | BS.length bs < len = Nothing-  | otherwise = case len of-      1 -> do-        (v, rest) <- decodeS8 bs-        Just (fromIntegral v, rest)-      2 -> do-        (v, rest) <- decodeS16 bs-        -- Must not fit in 1 byte-        if v >= -128 && v <= 127-          then Nothing-          else Just (fromIntegral v, rest)-      4 -> do-        (v, rest) <- decodeS32 bs-        -- Must not fit in 2 bytes-        if v >= -32768 && v <= 32767-          then Nothing-          else Just (fromIntegral v, rest)-      8 -> do-        (v, rest) <- decodeS64 bs-        -- Must not fit in 4 bytes-        if v >= -2147483648 && v <= 2147483647-          then Nothing-          else Just (v, rest)-      _ -> Nothing-{-# INLINE decodeMinSigned #-}---- BigSize decoding ---------------------------------------------------------------- | Decode a BigSize value with minimality check.-decodeBigSize :: BS.ByteString -> Maybe (Word64, BS.ByteString)-decodeBigSize !bs-  | BS.null bs = Nothing-  | otherwise = case BS.index bs 0 of-      0xff -> do-        (val, rest) <- decodeU64 (BS.drop 1 bs)-        -- Must be >= 0x100000000 for minimal encoding-        if val >= 0x100000000-          then Just (val, rest)-          else Nothing-      0xfe -> do-        (val, rest) <- decodeU32 (BS.drop 1 bs)-        -- Must be >= 0x10000 for minimal encoding-        if val >= 0x10000-          then Just (fromIntegral val, rest)-          else Nothing-      0xfd -> do-        (val, rest) <- decodeU16 (BS.drop 1 bs)-        -- Must be >= 0xfd for minimal encoding-        if val >= 0xfd-          then Just (fromIntegral val, rest)-          else Nothing-      b -> Just (fromIntegral b, BS.drop 1 bs)+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Lightning.Protocol.BOLT1.Prim+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Fundamental types and primitive encodings for BOLT #1.++module Lightning.Protocol.BOLT1.Prim (+  -- * Fixed-size byte types+    ChainHash+  , chain_hash+  , un_chain_hash+  , ChannelId+  , channel_id+  , un_channel_id+  , all_channels+  , Signature+  , signature+  , un_signature+  , Point+  , point+  , un_point+  , PaymentHash+  , payment_hash+  , un_payment_hash+  , PaymentPreimage+  , payment_preimage+  , un_payment_preimage+  , PerCommitmentSecret+  , per_commitment_secret+  , un_per_commitment_secret++  -- * Short channel identifiers+  , ShortChannelId(..)+  , short_channel_id+  , scid_block_height+  , scid_tx_index+  , scid_output_index++  -- * Amounts+  , Satoshi+  , satoshi+  , un_satoshi+  , max_satoshi+  , MilliSatoshi+  , milli_satoshi+  , un_milli_satoshi+  , max_milli_satoshi+  , sat_to_msat+  , msat_to_sat+  , add_sat+  , sub_sat+  , add_msat+  , sub_msat++  -- * Unsigned integers+  , encode_u16+  , encode_u32+  , encode_u64+  , decode_u16+  , decode_u32+  , decode_u64++  -- * Signed integers+  , encode_s8+  , encode_s16+  , encode_s32+  , encode_s64+  , decode_s8+  , decode_s16+  , decode_s32+  , decode_s64++  -- * Truncated unsigned integers+  , encode_tu16+  , encode_tu32+  , encode_tu64+  , decode_tu16+  , decode_tu32+  , decode_tu64++  -- * BigSize+  , encode_bigsize+  , decode_bigsize+  , BigSizeError(..)+  , decode_bigsize_detailed++  -- * Length-prefixed bytes+  , encode_u16_prefixed+  , decode_u16_prefixed++  -- * Fixed-size field codecs+  , decode_chain_hash+  , decode_channel_id+  , decode_signature+  , decode_point+  , decode_payment_hash+  , decode_payment_preimage+  , decode_per_commitment_secret+  , encode_short_channel_id+  , decode_short_channel_id+  , encode_satoshi+  , decode_satoshi+  , encode_milli_satoshi+  , decode_milli_satoshi+  ) where++import Control.DeepSeq (NFData(..))+import Data.Bits ((.&.), (.|.), unsafeShiftL, unsafeShiftR, xor)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Unsafe as BU+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Foreign.Ptr (Ptr)+import Foreign.Storable (pokeByteOff)+import GHC.Generics (Generic)++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++-- constant-time equality on equal-length bytestrings+ct_eq :: BS.ByteString -> BS.ByteString -> Bool+ct_eq a b+  | BS.length a /= BS.length b = False+  | otherwise = go 0 0+  where+    !n = BS.length a+    go :: Word8 -> Int -> Bool+    go !acc !i+      | i == n    = acc == 0+      | otherwise =+          go (acc .|. (BU.unsafeIndex a i `xor` BU.unsafeIndex b i))+             (i + 1)++-- take exactly n bytes from the front of the input+take_n :: Int -> BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)+take_n !n !bs+  | BS.length bs < n = Nothing+  | otherwise        = Just (BU.unsafeTake n bs, BU.unsafeDrop n bs)+{-# INLINE take_n #-}++-- fixed-size byte types ------------------------------------------------------++-- | A 32-byte chain hash, identifying the chain a channel or message+--   belongs to.+newtype ChainHash = ChainHash BS.ByteString+  deriving (Eq, Ord, Show, Generic)++instance NFData ChainHash++-- | Construct a 'ChainHash' from exactly 32 bytes.+--+--   >>> fmap (BS.length . un_chain_hash) (chain_hash (BS.replicate 32 0))+--   Just 32+--   >>> chain_hash "too short"+--   Nothing+chain_hash :: BS.ByteString -> Maybe ChainHash+chain_hash bs+  | BS.length bs == 32 = Just (ChainHash bs)+  | otherwise          = Nothing+{-# INLINE chain_hash #-}++-- | The bytes of a 'ChainHash'.+un_chain_hash :: ChainHash -> BS.ByteString+un_chain_hash (ChainHash bs) = bs+{-# INLINE un_chain_hash #-}++-- | A 32-byte channel identifier.+newtype ChannelId = ChannelId BS.ByteString+  deriving (Eq, Ord, Show, Generic)++instance NFData ChannelId++-- | Construct a 'ChannelId' from exactly 32 bytes.+--+--   >>> fmap (BS.length . un_channel_id) (channel_id (BS.replicate 32 1))+--   Just 32+channel_id :: BS.ByteString -> Maybe ChannelId+channel_id bs+  | BS.length bs == 32 = Just (ChannelId bs)+  | otherwise          = Nothing+{-# INLINE channel_id #-}++-- | The bytes of a 'ChannelId'.+un_channel_id :: ChannelId -> BS.ByteString+un_channel_id (ChannelId bs) = bs+{-# INLINE un_channel_id #-}++-- | The all-zero channel identifier, which refers to all channels+--   (e.g. in connection-level @error@ and @warning@ messages).+all_channels :: ChannelId+all_channels = ChannelId (BS.replicate 32 0x00)++-- | A 64-byte compact ECDSA signature.+newtype Signature = Signature BS.ByteString+  deriving (Eq, Ord, Show, Generic)++instance NFData Signature++-- | Construct a 'Signature' from exactly 64 bytes.+--+--   >>> signature (BS.replicate 63 0x00)+--   Nothing+signature :: BS.ByteString -> Maybe Signature+signature bs+  | BS.length bs == 64 = Just (Signature bs)+  | otherwise          = Nothing+{-# INLINE signature #-}++-- | The bytes of a 'Signature'.+un_signature :: Signature -> BS.ByteString+un_signature (Signature bs) = bs+{-# INLINE un_signature #-}++-- | A 33-byte compressed secp256k1 point.+newtype Point = Point BS.ByteString+  deriving (Eq, Ord, Show, Generic)++instance NFData Point++-- | Construct a 'Point' from 33 bytes with a compressed-encoding+--   prefix (0x02 or 0x03). The curve equation is not checked; use+--   ppad-secp256k1 to parse the point if it must be on the curve.+--+--   >>> point (BS.cons 0x04 (BS.replicate 32 0x01))+--   Nothing+point :: BS.ByteString -> Maybe Point+point bs+  | BS.length bs == 33+  , let !h = BU.unsafeIndex bs 0+  , h == 0x02 || h == 0x03 = Just (Point bs)+  | otherwise              = Nothing+{-# INLINE point #-}++-- | The bytes of a 'Point'.+un_point :: Point -> BS.ByteString+un_point (Point bs) = bs+{-# INLINE un_point #-}++-- | A 32-byte SHA256 payment hash.+newtype PaymentHash = PaymentHash BS.ByteString+  deriving (Eq, Ord, Show, Generic)++instance NFData PaymentHash++-- | Construct a 'PaymentHash' from exactly 32 bytes.+payment_hash :: BS.ByteString -> Maybe PaymentHash+payment_hash bs+  | BS.length bs == 32 = Just (PaymentHash bs)+  | otherwise          = Nothing+{-# INLINE payment_hash #-}++-- | The bytes of a 'PaymentHash'.+un_payment_hash :: PaymentHash -> BS.ByteString+un_payment_hash (PaymentHash bs) = bs+{-# INLINE un_payment_hash #-}++-- | A 32-byte payment preimage.+--+--   This is secret material: its 'Show' instance is redacted and its+--   'Eq' instance runs in constant time.+newtype PaymentPreimage = PaymentPreimage BS.ByteString++instance Eq PaymentPreimage where+  PaymentPreimage a == PaymentPreimage b = ct_eq a b++instance Show PaymentPreimage where+  showsPrec d _ = showParen (d > 10) $+    showString "PaymentPreimage <redacted>"++instance NFData PaymentPreimage where+  rnf (PaymentPreimage bs) = rnf bs++-- | Construct a 'PaymentPreimage' from exactly 32 bytes.+payment_preimage :: BS.ByteString -> Maybe PaymentPreimage+payment_preimage bs+  | BS.length bs == 32 = Just (PaymentPreimage bs)+  | otherwise          = Nothing+{-# INLINE payment_preimage #-}++-- | The bytes of a 'PaymentPreimage'.+un_payment_preimage :: PaymentPreimage -> BS.ByteString+un_payment_preimage (PaymentPreimage bs) = bs+{-# INLINE un_payment_preimage #-}++-- | A 32-byte per-commitment secret.+--+--   This is secret material: its 'Show' instance is redacted and its+--   'Eq' instance runs in constant time.+newtype PerCommitmentSecret = PerCommitmentSecret BS.ByteString++instance Eq PerCommitmentSecret where+  PerCommitmentSecret a == PerCommitmentSecret b = ct_eq a b++instance Show PerCommitmentSecret where+  showsPrec d _ = showParen (d > 10) $+    showString "PerCommitmentSecret <redacted>"++instance NFData PerCommitmentSecret where+  rnf (PerCommitmentSecret bs) = rnf bs++-- | Construct a 'PerCommitmentSecret' from exactly 32 bytes.+per_commitment_secret :: BS.ByteString -> Maybe PerCommitmentSecret+per_commitment_secret bs+  | BS.length bs == 32 = Just (PerCommitmentSecret bs)+  | otherwise          = Nothing+{-# INLINE per_commitment_secret #-}++-- | The bytes of a 'PerCommitmentSecret'.+un_per_commitment_secret :: PerCommitmentSecret -> BS.ByteString+un_per_commitment_secret (PerCommitmentSecret bs) = bs+{-# INLINE un_per_commitment_secret #-}++-- short channel identifiers --------------------------------------------------++-- | A short channel identifier: block height (3 bytes), transaction+--   index (3 bytes) and output index (2 bytes), packed big-endian into+--   a 'Word64'. Every 'Word64' is a valid packing.+newtype ShortChannelId = ShortChannelId Word64+  deriving (Eq, Ord, Show, Generic)++instance NFData ShortChannelId++-- | Construct a 'ShortChannelId' from its components. Fails if the+--   block height or transaction index exceed 24 bits.+--+--   >>> short_channel_id 539268 845 1+--   Just (ShortChannelId 592931436542885889)+short_channel_id+  :: Word32 -- ^ block height+  -> Word32 -- ^ transaction index+  -> Word16 -- ^ output index+  -> Maybe ShortChannelId+short_channel_id h t o+  | h > 0xFFFFFF = Nothing+  | t > 0xFFFFFF = Nothing+  | otherwise    = Just $! ShortChannelId $!+          (fi h `unsafeShiftL` 40)+      .|. (fi t `unsafeShiftL` 16)+      .|. fi o+{-# INLINE short_channel_id #-}++-- | The block height of a 'ShortChannelId'.+scid_block_height :: ShortChannelId -> Word32+scid_block_height (ShortChannelId w) = fi (w `unsafeShiftR` 40)+{-# INLINE scid_block_height #-}++-- | The transaction index of a 'ShortChannelId'.+scid_tx_index :: ShortChannelId -> Word32+scid_tx_index (ShortChannelId w) = fi ((w `unsafeShiftR` 16) .&. 0xFFFFFF)+{-# INLINE scid_tx_index #-}++-- | The output index of a 'ShortChannelId'.+scid_output_index :: ShortChannelId -> Word16+scid_output_index (ShortChannelId w) = fi (w .&. 0xFFFF)+{-# INLINE scid_output_index #-}++-- amounts --------------------------------------------------------------------++-- | An amount in satoshis, at most 21 million BTC ('max_satoshi').+newtype Satoshi = Satoshi Word64+  deriving (Eq, Ord, Show, Generic)++instance NFData Satoshi++-- | An amount in millisatoshis, at most 21 million BTC+--   ('max_milli_satoshi').+newtype MilliSatoshi = MilliSatoshi Word64+  deriving (Eq, Ord, Show, Generic)++instance NFData MilliSatoshi++-- | 21 million BTC, in satoshis (0x000775f05a074000).+max_satoshi :: Satoshi+max_satoshi = Satoshi 0x000775f05a074000++-- | 21 million BTC, in millisatoshis (0x1d24b2dfac520000).+max_milli_satoshi :: MilliSatoshi+max_milli_satoshi = MilliSatoshi 0x1d24b2dfac520000++-- | Construct a 'Satoshi' amount, failing above 21 million BTC.+--+--   >>> satoshi 1000+--   Just (Satoshi 1000)+--   >>> satoshi 0xffffffffffffffff+--   Nothing+satoshi :: Word64 -> Maybe Satoshi+satoshi w+  | w <= 0x000775f05a074000 = Just (Satoshi w)+  | otherwise               = Nothing+{-# INLINE satoshi #-}++-- | The number of satoshis.+un_satoshi :: Satoshi -> Word64+un_satoshi (Satoshi w) = w+{-# INLINE un_satoshi #-}++-- | Construct a 'MilliSatoshi' amount, failing above 21 million BTC.+milli_satoshi :: Word64 -> Maybe MilliSatoshi+milli_satoshi w+  | w <= 0x1d24b2dfac520000 = Just (MilliSatoshi w)+  | otherwise               = Nothing+{-# INLINE milli_satoshi #-}++-- | The number of millisatoshis.+un_milli_satoshi :: MilliSatoshi -> Word64+un_milli_satoshi (MilliSatoshi w) = w+{-# INLINE un_milli_satoshi #-}++-- | Convert satoshis to millisatoshis. Total, since the bounds+--   correspond.+--+--   >>> fmap sat_to_msat (satoshi 5)+--   Just (MilliSatoshi 5000)+sat_to_msat :: Satoshi -> MilliSatoshi+sat_to_msat (Satoshi s) = MilliSatoshi (s * 1000)+{-# INLINE sat_to_msat #-}++-- | Convert millisatoshis to satoshis, rounding down.+msat_to_sat :: MilliSatoshi -> Satoshi+msat_to_sat (MilliSatoshi m) = Satoshi (m `quot` 1000)+{-# INLINE msat_to_sat #-}++-- | Add two amounts, failing above 21 million BTC. (Amounts are+--   bounded well below 2^63, so the sum can't wrap.)+add_sat :: Satoshi -> Satoshi -> Maybe Satoshi+add_sat (Satoshi a) (Satoshi b) = satoshi (a + b)+{-# INLINE add_sat #-}++-- | Subtract the second amount from the first, failing if the result+--   would be negative.+sub_sat :: Satoshi -> Satoshi -> Maybe Satoshi+sub_sat (Satoshi a) (Satoshi b)+  | b > a     = Nothing+  | otherwise = Just (Satoshi (a - b))+{-# INLINE sub_sat #-}++-- | Add two amounts, failing above 21 million BTC.+add_msat :: MilliSatoshi -> MilliSatoshi -> Maybe MilliSatoshi+add_msat (MilliSatoshi a) (MilliSatoshi b) = milli_satoshi (a + b)+{-# INLINE add_msat #-}++-- | Subtract the second amount from the first, failing if the result+--   would be negative.+sub_msat :: MilliSatoshi -> MilliSatoshi -> Maybe MilliSatoshi+sub_msat (MilliSatoshi a) (MilliSatoshi b)+  | b > a     = Nothing+  | otherwise = Just (MilliSatoshi (a - b))+{-# INLINE sub_msat #-}++-- unsigned integers ----------------------------------------------------------++poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()+poke8 = pokeByteOff+{-# INLINE poke8 #-}++-- | Encode a 'Word16' as 2 big-endian bytes.+--+--   >>> encode_u16 0x0102+--   "\SOH\STX"+encode_u16 :: Word16 -> BS.ByteString+encode_u16 w = BI.unsafeCreate 2 $ \p -> do+  poke8 p 0 (fi (w `unsafeShiftR` 8))+  poke8 p 1 (fi w)+{-# INLINE encode_u16 #-}++-- | Encode a 'Word32' as 4 big-endian bytes.+encode_u32 :: Word32 -> BS.ByteString+encode_u32 w = BI.unsafeCreate 4 $ \p -> do+  poke8 p 0 (fi (w `unsafeShiftR` 24))+  poke8 p 1 (fi (w `unsafeShiftR` 16))+  poke8 p 2 (fi (w `unsafeShiftR` 8))+  poke8 p 3 (fi w)+{-# INLINE encode_u32 #-}++-- | Encode a 'Word64' as 8 big-endian bytes.+encode_u64 :: Word64 -> BS.ByteString+encode_u64 w = BI.unsafeCreate 8 $ \p -> do+  poke8 p 0 (fi (w `unsafeShiftR` 56))+  poke8 p 1 (fi (w `unsafeShiftR` 48))+  poke8 p 2 (fi (w `unsafeShiftR` 40))+  poke8 p 3 (fi (w `unsafeShiftR` 32))+  poke8 p 4 (fi (w `unsafeShiftR` 24))+  poke8 p 5 (fi (w `unsafeShiftR` 16))+  poke8 p 6 (fi (w `unsafeShiftR` 8))+  poke8 p 7 (fi w)+{-# INLINE encode_u64 #-}++-- big-endian word from the first n bytes (n <= 8, length checked)+be :: Int -> BS.ByteString -> Word64+be n bs = go 0 0+  where+    go !acc !i+      | i == n    = acc+      | otherwise =+          go ((acc `unsafeShiftL` 8) .|. fi (BU.unsafeIndex bs i)) (i + 1)+{-# INLINE be #-}++-- | Decode 2 big-endian bytes, returning the remaining input.+--+--   >>> decode_u16 "\SOH\STXrest"+--   Just (258,"rest")+decode_u16 :: BS.ByteString -> Maybe (Word16, BS.ByteString)+decode_u16 bs+  | BS.length bs < 2 = Nothing+  | otherwise        = Just (fi (be 2 bs), BU.unsafeDrop 2 bs)+{-# INLINE decode_u16 #-}++-- | Decode 4 big-endian bytes, returning the remaining input.+decode_u32 :: BS.ByteString -> Maybe (Word32, BS.ByteString)+decode_u32 bs+  | BS.length bs < 4 = Nothing+  | otherwise        = Just (fi (be 4 bs), BU.unsafeDrop 4 bs)+{-# INLINE decode_u32 #-}++-- | Decode 8 big-endian bytes, returning the remaining input.+decode_u64 :: BS.ByteString -> Maybe (Word64, BS.ByteString)+decode_u64 bs+  | BS.length bs < 8 = Nothing+  | otherwise        = Just (be 8 bs, BU.unsafeDrop 8 bs)+{-# INLINE decode_u64 #-}++-- signed integers ------------------------------------------------------------++-- | Encode an 'Int8' as 1 byte (two's complement).+--+--   >>> encode_s8 (-42)+--   "\214"+encode_s8 :: Int8 -> BS.ByteString+encode_s8 = BS.singleton . fi+{-# INLINE encode_s8 #-}++-- | Encode an 'Int16' as 2 big-endian bytes (two's complement).+encode_s16 :: Int16 -> BS.ByteString+encode_s16 = encode_u16 . fi+{-# INLINE encode_s16 #-}++-- | Encode an 'Int32' as 4 big-endian bytes (two's complement).+encode_s32 :: Int32 -> BS.ByteString+encode_s32 = encode_u32 . fi+{-# INLINE encode_s32 #-}++-- | Encode an 'Int64' as 8 big-endian bytes (two's complement).+encode_s64 :: Int64 -> BS.ByteString+encode_s64 = encode_u64 . fi+{-# INLINE encode_s64 #-}++-- | Decode 1 byte (two's complement), returning the remaining input.+decode_s8 :: BS.ByteString -> Maybe (Int8, BS.ByteString)+decode_s8 bs = case BS.uncons bs of+  Just (h, t) -> Just (fi h, t)+  Nothing     -> Nothing+{-# INLINE decode_s8 #-}++-- | Decode 2 big-endian bytes (two's complement).+decode_s16 :: BS.ByteString -> Maybe (Int16, BS.ByteString)+decode_s16 bs = case decode_u16 bs of+  Just (w, t) -> Just (fi w, t)+  Nothing     -> Nothing+{-# INLINE decode_s16 #-}++-- | Decode 4 big-endian bytes (two's complement).+decode_s32 :: BS.ByteString -> Maybe (Int32, BS.ByteString)+decode_s32 bs = case decode_u32 bs of+  Just (w, t) -> Just (fi w, t)+  Nothing     -> Nothing+{-# INLINE decode_s32 #-}++-- | Decode 8 big-endian bytes (two's complement).+decode_s64 :: BS.ByteString -> Maybe (Int64, BS.ByteString)+decode_s64 bs = case decode_u64 bs of+  Just (w, t) -> Just (fi w, t)+  Nothing     -> Nothing+{-# INLINE decode_s64 #-}++-- truncated unsigned integers ------------------------------------------------++-- minimal big-endian encoding: no leading zero bytes (zero is empty)+encode_tu :: Word64 -> BS.ByteString+encode_tu w = BS.drop (lz 0) (encode_u64 w)+  where+    lz :: Int -> Int+    lz !i+      | i < 8 && (w `unsafeShiftR` (56 - 8 * i)) .&. 0xff == 0 = lz (i + 1)+      | otherwise = i++decode_tu :: Int -> BS.ByteString -> Maybe Word64+decode_tu maxlen bs+  | n > maxlen                       = Nothing+  | n > 0 && BU.unsafeIndex bs 0 == 0 = Nothing+  | otherwise                        = Just (be n bs)+  where+    !n = BS.length bs++-- | Encode a 'Word16' as a truncated integer (no leading zero bytes).+--+--   >>> encode_tu16 0+--   ""+--   >>> encode_tu16 0x0100+--   "\SOH\NUL"+encode_tu16 :: Word16 -> BS.ByteString+encode_tu16 = encode_tu . fi++-- | Encode a 'Word32' as a truncated integer (no leading zero bytes).+encode_tu32 :: Word32 -> BS.ByteString+encode_tu32 = encode_tu . fi++-- | Encode a 'Word64' as a truncated integer (no leading zero bytes).+encode_tu64 :: Word64 -> BS.ByteString+encode_tu64 = encode_tu++-- | Decode a truncated 16-bit integer occupying the whole input. Fails+--   on more than 2 bytes or a non-minimal encoding.+--+--   >>> decode_tu16 "\SOH\NUL"+--   Just 256+--   >>> decode_tu16 "\NUL\SOH"+--   Nothing+decode_tu16 :: BS.ByteString -> Maybe Word16+decode_tu16 = fmap fi . decode_tu 2++-- | Decode a truncated 32-bit integer occupying the whole input. Fails+--   on more than 4 bytes or a non-minimal encoding.+decode_tu32 :: BS.ByteString -> Maybe Word32+decode_tu32 = fmap fi . decode_tu 4++-- | Decode a truncated 64-bit integer occupying the whole input. Fails+--   on more than 8 bytes or a non-minimal encoding.+decode_tu64 :: BS.ByteString -> Maybe Word64+decode_tu64 = decode_tu 8++-- bigsize --------------------------------------------------------------------++-- | Encode a 'Word64' in the minimal BigSize format.+--+--   >>> encode_bigsize 252+--   "\252"+--   >>> encode_bigsize 253+--   "\253\NUL\253"+encode_bigsize :: Word64 -> BS.ByteString+encode_bigsize w+  | w < 0xfd        = BS.singleton (fi w)+  | w <= 0xffff     = BS.cons 0xfd (encode_u16 (fi w))+  | w <= 0xffffffff = BS.cons 0xfe (encode_u32 (fi w))+  | otherwise       = BS.cons 0xff (encode_u64 w)++-- | Why a BigSize failed to decode.+data BigSizeError+  = BigSizeTruncated   -- ^ input ended early+  | BigSizeNonMinimal  -- ^ a shorter encoding exists+  deriving (Eq, Show, Generic)++instance NFData BigSizeError++-- | Decode a BigSize, distinguishing truncation from non-minimal+--   encodings.+decode_bigsize_detailed+  :: BS.ByteString -> Either BigSizeError (Word64, BS.ByteString)+decode_bigsize_detailed bs = case BS.uncons bs of+  Nothing -> Left BigSizeTruncated+  Just (h, t) -> case h of+    0xfd -> wide 2 0xfd t+    0xfe -> wide 4 0x10000 t+    0xff -> wide 8 0x100000000 t+    _    -> Right (fi h, t)+  where+    wide n lo t = case take_n n t of+      Nothing -> Left BigSizeTruncated+      Just (v, r)+        | w < lo    -> Left BigSizeNonMinimal+        | otherwise -> Right (w, r)+        where+          !w = be n v++-- | Decode a minimally-encoded BigSize, returning the remaining input.+--+--   >>> decode_bigsize "\253\NUL\253rest"+--   Just (253,"rest")+--   >>> decode_bigsize "\253\NUL\252"+--   Nothing+decode_bigsize :: BS.ByteString -> Maybe (Word64, BS.ByteString)+decode_bigsize bs = case decode_bigsize_detailed bs of+  Right r -> Just r+  Left _  -> Nothing++-- length-prefixed bytes ------------------------------------------------------++-- | Prefix bytes with their length as a u16. Fails if the input+--   exceeds 65535 bytes.+--+--   >>> encode_u16_prefixed "abc"+--   Just "\NUL\ETXabc"+encode_u16_prefixed :: BS.ByteString -> Maybe BS.ByteString+encode_u16_prefixed bs+  | BS.length bs > 0xffff = Nothing+  | otherwise = Just (encode_u16 (fi (BS.length bs)) <> bs)++-- | Decode u16-length-prefixed bytes, returning the remaining input.+--+--   >>> decode_u16_prefixed "\NUL\ETXabcrest"+--   Just ("abc","rest")+decode_u16_prefixed+  :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)+decode_u16_prefixed bs = do+  (n, rest) <- decode_u16 bs+  take_n (fi n) rest++-- fixed-size field codecs ----------------------------------------------------++-- | Decode a 32-byte 'ChainHash', returning the remaining input.+decode_chain_hash :: BS.ByteString -> Maybe (ChainHash, BS.ByteString)+decode_chain_hash bs = do+  (h, r) <- take_n 32 bs+  pure (ChainHash h, r)++-- | Decode a 32-byte 'ChannelId', returning the remaining input.+decode_channel_id :: BS.ByteString -> Maybe (ChannelId, BS.ByteString)+decode_channel_id bs = do+  (h, r) <- take_n 32 bs+  pure (ChannelId h, r)++-- | Decode a 64-byte 'Signature', returning the remaining input.+decode_signature :: BS.ByteString -> Maybe (Signature, BS.ByteString)+decode_signature bs = do+  (h, r) <- take_n 64 bs+  pure (Signature h, r)++-- | Decode a 33-byte 'Point', returning the remaining input. Fails if+--   the prefix byte is not 0x02 or 0x03.+decode_point :: BS.ByteString -> Maybe (Point, BS.ByteString)+decode_point bs = do+  (h, r) <- take_n 33 bs+  p <- point h+  pure (p, r)++-- | Decode a 32-byte 'PaymentHash', returning the remaining input.+decode_payment_hash :: BS.ByteString -> Maybe (PaymentHash, BS.ByteString)+decode_payment_hash bs = do+  (h, r) <- take_n 32 bs+  pure (PaymentHash h, r)++-- | Decode a 32-byte 'PaymentPreimage', returning the remaining input.+decode_payment_preimage+  :: BS.ByteString -> Maybe (PaymentPreimage, BS.ByteString)+decode_payment_preimage bs = do+  (h, r) <- take_n 32 bs+  pure (PaymentPreimage h, r)++-- | Decode a 32-byte 'PerCommitmentSecret', returning the remaining+--   input.+decode_per_commitment_secret+  :: BS.ByteString -> Maybe (PerCommitmentSecret, BS.ByteString)+decode_per_commitment_secret bs = do+  (h, r) <- take_n 32 bs+  pure (PerCommitmentSecret h, r)++-- | Encode a 'ShortChannelId' as 8 big-endian bytes.+encode_short_channel_id :: ShortChannelId -> BS.ByteString+encode_short_channel_id (ShortChannelId w) = encode_u64 w+{-# INLINE encode_short_channel_id #-}++-- | Decode an 8-byte 'ShortChannelId', returning the remaining input.+decode_short_channel_id+  :: BS.ByteString -> Maybe (ShortChannelId, BS.ByteString)+decode_short_channel_id bs = do+  (w, r) <- decode_u64 bs+  pure (ShortChannelId w, r)+{-# INLINE decode_short_channel_id #-}++-- | Encode a 'Satoshi' amount as a u64.+encode_satoshi :: Satoshi -> BS.ByteString+encode_satoshi (Satoshi w) = encode_u64 w+{-# INLINE encode_satoshi #-}++-- | Decode a u64 'Satoshi' amount, returning the remaining input. Fails+--   above 21 million BTC.+decode_satoshi :: BS.ByteString -> Maybe (Satoshi, BS.ByteString)+decode_satoshi bs = do+  (w, r) <- decode_u64 bs+  s <- satoshi w+  pure (s, r)+{-# INLINE decode_satoshi #-}++-- | Encode a 'MilliSatoshi' amount as a u64.+encode_milli_satoshi :: MilliSatoshi -> BS.ByteString+encode_milli_satoshi (MilliSatoshi w) = encode_u64 w+{-# INLINE encode_milli_satoshi #-}++-- | Decode a u64 'MilliSatoshi' amount, returning the remaining input.+--   Fails above 21 million BTC.+decode_milli_satoshi+  :: BS.ByteString -> Maybe (MilliSatoshi, BS.ByteString)+decode_milli_satoshi bs = do+  (w, r) <- decode_u64 bs+  m <- milli_satoshi w+  pure (m, r)+{-# INLINE decode_milli_satoshi #-}

@@ -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-      when (fromIntegral len > BS.length rest2) $-        Left TlvLengthExceedsBounds-      let !val = BS.take (fromIntegral len) rest2-          !rest3 = BS.drop (fromIntegral len) rest2-          !rec = TlvRecord typ val-      go (Just typ) (rec : acc) rest3+    enc (TlvRecord t v) =+      [encode_bigsize t, encode_bigsize (fromIntegral (BS.length v)), v] --- | Decode a TLV stream with configurable known-type predicate.+-- | Decode a TLV stream occupying the whole input, given a predicate+--   identifying the types known in the stream's context. ----- Per BOLT #1:--- - Types must be strictly increasing--- - Unknown even types cause failure--- - Unknown odd types are skipped+--   Per BOLT #1, decoding fails on truncation, non-minimal BigSize+--   encodings, types that are not strictly increasing, and unknown+--   even types. Every record is kept, including unknown odd ones, so+--   re-encoding reproduces the input. ----- The predicate determines which types are "known" for the context.-decodeTlvStreamWith-  :: (Word64 -> Bool)  -- ^ Predicate: is this type known?+--   >>> let Right s = decode_tlv_stream (== 1) "\SOH\SOHa\ETX\NUL"+--   >>> map tlv_type (un_tlv_stream s)+--   [1,3]+--   >>> decode_tlv_stream (== 1) "\STX\NUL"+--   Left (TlvUnknownEvenType 2)+decode_tlv_stream+  :: (Word64 -> Bool)  -- ^ is this type known?   -> BS.ByteString   -> Either TlvError TlvStream-decodeTlvStreamWith isKnown = go Nothing []-  where-    go :: Maybe Word64 -> [TlvRecord] -> BS.ByteString-       -> Either TlvError TlvStream-    go !_ !acc !bs-      | BS.null bs = Right (unsafeTlvStream (reverse acc))-    go !mPrevType !acc !bs = do-      (typ, rest1) <- maybe (Left TlvNonMinimalEncoding) Right-                        (decodeBigSize bs)-      -- Strictly increasing check-      case mPrevType of-        Just prevType -> when (typ <= prevType) $-          Left TlvNotStrictlyIncreasing-        Nothing -> pure ()-      (len, rest2) <- maybe (Left TlvNonMinimalEncoding) Right-                        (decodeBigSize rest1)-      -- Length bounds check-      when (fromIntegral len > BS.length rest2) $-        Left TlvLengthExceedsBounds-      let !val = BS.take (fromIntegral len) rest2-          !rest3 = BS.drop (fromIntegral len) rest2-          !rec = TlvRecord typ val-      -- Unknown type handling: even = fail, odd = skip-      if isKnown typ-        then go (Just typ) (rec : acc) rest3-        else if even typ-          then Left (TlvUnknownEvenType typ)-          else go (Just typ) acc rest3  -- skip unknown odd---- | Decode a TLV stream with BOLT #1 init_tlvs validation.------ This uses the default known types for init messages (1 and 3).--- For other contexts, use 'decodeTlvStreamWith' with an appropriate--- predicate.-decodeTlvStream :: BS.ByteString -> Either TlvError TlvStream-decodeTlvStream = decodeTlvStreamWith isInitTlvType-  where-    isInitTlvType :: Word64 -> Bool-    isInitTlvType 1 = True  -- networks-    isInitTlvType 3 = True  -- remote_addr-    isInitTlvType _ = False---- Init TLV types ------------------------------------------------------------------ | TLV records for init message.-data InitTlv-  = InitNetworks ![ChainHash]      -- ^ Type 1: chain hashes (32 bytes each)-  | InitRemoteAddr !BS.ByteString  -- ^ Type 3: remote address-  deriving stock (Eq, Show, Generic)--instance NFData InitTlv---- | Parse init TLVs from a TLV stream.-parseInitTlvs :: TlvStream -> Either TlvError [InitTlv]-parseInitTlvs (TlvStream recs) = traverse parseOne recs+decode_tlv_stream known = go Nothing []   where-    parseOne (TlvRecord 1 val)-      | BS.length val `mod` 32 == 0 =-          Right (InitNetworks (map mkChainHash (chunksOf 32 val)))-      | otherwise = Left (TlvInvalidKnownType 1)-    parseOne (TlvRecord 3 val) = Right (InitRemoteAddr val)-    parseOne (TlvRecord t _) = Left (TlvUnknownEvenType t)--    -- Each chunk is exactly 32 bytes from chunksOf, so chainHash always-    -- succeeds. We use a partial pattern match as the Nothing case is-    -- unreachable given our chunksOf guarantee.-    mkChainHash bs = case chainHash bs of-      Just ch -> ch-      Nothing -> error "parseInitTlvs: impossible - chunk is not 32 bytes"---- | Split bytestring into chunks of given size.-chunksOf :: Int -> BS.ByteString -> [BS.ByteString]-chunksOf !n !bs-  | BS.null bs = []-  | otherwise =-      let (!chunk, !rest) = BS.splitAt n bs-      in  chunk : chunksOf n rest+    go !_ !acc !bs | BS.null bs = Right (TlvStream (reverse acc))+    go !prev !acc !bs = do+      (t, r0) <- bigsize bs+      case prev of+        Just p | t <= p -> Left TlvNotStrictlyIncreasing+        _ -> pure ()+      (l, r1) <- bigsize r0+      if l > fromIntegral (BS.length r1)+        then Left TlvTruncated+        else do+          let !n = fromIntegral l+              !v = BU.unsafeTake n r1+              !r2 = BU.unsafeDrop n r1+          if not (known t) && even t+            then Left (TlvUnknownEvenType t)+            else go (Just t) (TlvRecord t v : acc) r2 --- | Encode init TLVs to a TLV stream.-encodeInitTlvs :: [InitTlv] -> TlvStream-encodeInitTlvs = unsafeTlvStream . map toRecord-  where-    toRecord (InitNetworks chains) =-      TlvRecord 1 (mconcat (map unChainHash chains))-    toRecord (InitRemoteAddr addr) =-      TlvRecord 3 addr+    bigsize b = case decode_bigsize_detailed b of+      Right r                -> Right r+      Left BigSizeTruncated  -> Left TlvTruncated+      Left BigSizeNonMinimal -> Left TlvNonMinimalBigSize

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               ppad-bolt1-version:            0.0.1+version:            0.1.0 synopsis:           Base protocol per BOLT #1 license:            MIT license-file:       LICENSE@@ -8,7 +8,7 @@ maintainer:         jared@ppad.tech category:           Cryptography build-type:         Simple-tested-with:        GHC == 9.10.3+tested-with:        GHC == { 9.10.3 } extra-doc-files:    CHANGELOG description:   Base protocol, per@@ -25,6 +25,7 @@       -Wall   exposed-modules:       Lightning.Protocol.BOLT1+  other-modules:       Lightning.Protocol.BOLT1.Codec       Lightning.Protocol.BOLT1.Message       Lightning.Protocol.BOLT1.Prim@@ -33,6 +34,7 @@       base >= 4.9 && < 5     , bytestring >= 0.9 && < 0.13     , deepseq >= 1.4 && < 1.6+    , ppad-bolt9 >= 0.1 && < 0.2  test-suite bolt1-tests   type:                exitcode-stdio-1.0@@ -41,13 +43,14 @@   main-is:             Main.hs    ghc-options:-    -rtsopts -Wall -O2+    -rtsopts -Wall    build-depends:       base     , bytestring     , ppad-base16     , ppad-bolt1+    , ppad-bolt9     , tasty     , tasty-hunit     , tasty-quickcheck@@ -66,8 +69,8 @@       base     , bytestring     , criterion-    , deepseq     , ppad-bolt1+    , ppad-bolt9  benchmark bolt1-weigh   type:                exitcode-stdio-1.0@@ -82,6 +85,6 @@   build-depends:       base     , bytestring-    , deepseq     , ppad-bolt1+    , ppad-bolt9     , weigh

@@ -4,696 +4,545 @@  import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16-import Lightning.Protocol.BOLT1-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck--main :: IO ()-main = defaultMain $ testGroup "ppad-bolt1" [-    bigsize_tests-  , primitive_tests-  , signed_tests-  , truncated_tests-  , minsigned_tests-  , tlv_tests-  , message_tests-  , envelope_tests-  , extension_tests-  , bounds_tests-  , property_tests-  ]---- BigSize test vectors from BOLT #1 Appendix A ---------------------------------bigsize_tests :: TestTree-bigsize_tests = testGroup "BigSize (Appendix A)" [-    testCase "zero" $-      encodeBigSize 0 @?= unhex "00"-  , testCase "one byte high (252)" $-      encodeBigSize 252 @?= unhex "fc"-  , testCase "two byte low (253)" $-      encodeBigSize 253 @?= unhex "fd00fd"-  , testCase "two byte high (65535)" $-      encodeBigSize 65535 @?= unhex "fdffff"-  , testCase "four byte low (65536)" $-      encodeBigSize 65536 @?= unhex "fe00010000"-  , testCase "four byte high (4294967295)" $-      encodeBigSize 4294967295 @?= unhex "feffffffff"-  , testCase "eight byte low (4294967296)" $-      encodeBigSize 4294967296 @?= unhex "ff0000000100000000"-  , testCase "eight byte high (max u64)" $-      encodeBigSize 18446744073709551615 @?= unhex "ffffffffffffffffff"-  , testCase "decode zero" $-      decodeBigSize (unhex "00") @?= Just (0, "")-  , testCase "decode 252" $-      decodeBigSize (unhex "fc") @?= Just (252, "")-  , testCase "decode 253" $-      decodeBigSize (unhex "fd00fd") @?= Just (253, "")-  , testCase "decode 65535" $-      decodeBigSize (unhex "fdffff") @?= Just (65535, "")-  , testCase "decode 65536" $-      decodeBigSize (unhex "fe00010000") @?= Just (65536, "")-  , testCase "decode 4294967295" $-      decodeBigSize (unhex "feffffffff") @?= Just (4294967295, "")-  , testCase "decode 4294967296" $-      decodeBigSize (unhex "ff0000000100000000") @?= Just (4294967296, "")-  , testCase "decode max u64" $-      decodeBigSize (unhex "ffffffffffffffffff") @?=-        Just (18446744073709551615, "")-  , testCase "non-minimal 2-byte fails" $-      decodeBigSize (unhex "fd00fc") @?= Nothing-  , testCase "non-minimal 4-byte fails" $-      decodeBigSize (unhex "fe0000ffff") @?= Nothing-  , testCase "non-minimal 8-byte fails" $-      decodeBigSize (unhex "ff00000000ffffffff") @?= Nothing-  ]---- Primitive encode/decode tests -------------------------------------------------primitive_tests :: TestTree-primitive_tests = testGroup "Primitives" [-    testCase "encodeU16 0x0102" $-      encodeU16 0x0102 @?= BS.pack [0x01, 0x02]-  , testCase "decodeU16 0x0102" $-      decodeU16 (BS.pack [0x01, 0x02]) @?= Just (0x0102, "")-  , testCase "encodeU32 0x01020304" $-      encodeU32 0x01020304 @?= BS.pack [0x01, 0x02, 0x03, 0x04]-  , testCase "decodeU32 0x01020304" $-      decodeU32 (BS.pack [0x01, 0x02, 0x03, 0x04]) @?= Just (0x01020304, "")-  , testCase "encodeU64" $-      encodeU64 0x0102030405060708 @?=-        BS.pack [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08]-  , testCase "decodeU64" $-      decodeU64 (BS.pack [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08]) @?=-        Just (0x0102030405060708, "")-  , testCase "decodeU16 insufficient" $-      decodeU16 (BS.pack [0x01]) @?= Nothing-  , testCase "decodeU32 insufficient" $-      decodeU32 (BS.pack [0x01, 0x02]) @?= Nothing-  , testCase "decodeU64 insufficient" $-      decodeU64 (BS.pack [0x01, 0x02, 0x03, 0x04]) @?= Nothing-  ]---- Signed integer tests -----------------------------------------------------------signed_tests :: TestTree-signed_tests = testGroup "Signed integers" [-    testCase "encodeS8 42" $-      encodeS8 42 @?= BS.pack [0x2a]-  , testCase "encodeS8 -42" $-      encodeS8 (-42) @?= BS.pack [0xd6]-  , testCase "encodeS8 127" $-      encodeS8 127 @?= BS.pack [0x7f]-  , testCase "encodeS8 -128" $-      encodeS8 (-128) @?= BS.pack [0x80]-  , testCase "decodeS8 42" $-      decodeS8 (BS.pack [0x2a]) @?= Just (42, "")-  , testCase "decodeS8 -42" $-      decodeS8 (BS.pack [0xd6]) @?= Just (-42, "")-  , testCase "encodeS16 -1" $-      encodeS16 (-1) @?= BS.pack [0xff, 0xff]-  , testCase "encodeS16 32767" $-      encodeS16 32767 @?= BS.pack [0x7f, 0xff]-  , testCase "encodeS16 -32768" $-      encodeS16 (-32768) @?= BS.pack [0x80, 0x00]-  , testCase "decodeS16 -1" $-      decodeS16 (BS.pack [0xff, 0xff]) @?= Just (-1, "")-  , testCase "encodeS32 -1" $-      encodeS32 (-1) @?= BS.pack [0xff, 0xff, 0xff, 0xff]-  , testCase "encodeS32 2147483647" $-      encodeS32 2147483647 @?= BS.pack [0x7f, 0xff, 0xff, 0xff]-  , testCase "encodeS32 -2147483648" $-      encodeS32 (-2147483648) @?= BS.pack [0x80, 0x00, 0x00, 0x00]-  , testCase "decodeS32 -1" $-      decodeS32 (BS.pack [0xff, 0xff, 0xff, 0xff]) @?= Just (-1, "")-  , testCase "encodeS64 -1" $-      encodeS64 (-1) @?=-        BS.pack [0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]-  , testCase "decodeS64 -1" $-      decodeS64 (BS.pack [0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) @?=-        Just (-1, "")-  ]---- Truncated unsigned integer tests -----------------------------------------------truncated_tests :: TestTree-truncated_tests = testGroup "Truncated unsigned integers" [-    testCase "encodeTu16 0" $-      encodeTu16 0 @?= ""-  , testCase "encodeTu16 1" $-      encodeTu16 1 @?= BS.pack [0x01]-  , testCase "encodeTu16 255" $-      encodeTu16 255 @?= BS.pack [0xff]-  , testCase "encodeTu16 256" $-      encodeTu16 256 @?= BS.pack [0x01, 0x00]-  , testCase "encodeTu16 65535" $-      encodeTu16 65535 @?= BS.pack [0xff, 0xff]-  , testCase "decodeTu16 0 bytes" $-      decodeTu16 0 "" @?= Just (0, "")-  , testCase "decodeTu16 1 byte" $-      decodeTu16 1 (BS.pack [0x01]) @?= Just (1, "")-  , testCase "decodeTu16 2 bytes" $-      decodeTu16 2 (BS.pack [0x01, 0x00]) @?= Just (256, "")-  , testCase "decodeTu16 non-minimal fails" $-      decodeTu16 2 (BS.pack [0x00, 0x01]) @?= Nothing-  , testCase "encodeTu32 0" $-      encodeTu32 0 @?= ""-  , testCase "encodeTu32 1" $-      encodeTu32 1 @?= BS.pack [0x01]-  , testCase "encodeTu32 0x010000" $-      encodeTu32 0x010000 @?= BS.pack [0x01, 0x00, 0x00]-  , testCase "encodeTu32 0x01000000" $-      encodeTu32 0x01000000 @?= BS.pack [0x01, 0x00, 0x00, 0x00]-  , testCase "decodeTu32 0 bytes" $-      decodeTu32 0 "" @?= Just (0, "")-  , testCase "decodeTu32 3 bytes" $-      decodeTu32 3 (BS.pack [0x01, 0x00, 0x00]) @?= Just (0x010000, "")-  , testCase "decodeTu32 non-minimal fails" $-      decodeTu32 3 (BS.pack [0x00, 0x01, 0x00]) @?= Nothing-  , testCase "encodeTu64 0" $-      encodeTu64 0 @?= ""-  , testCase "encodeTu64 0x0100000000" $-      encodeTu64 0x0100000000 @?= BS.pack [0x01, 0x00, 0x00, 0x00, 0x00]-  , testCase "decodeTu64 5 bytes" $-      decodeTu64 5 (BS.pack [0x01, 0x00, 0x00, 0x00, 0x00]) @?=-        Just (0x0100000000, "")-  , testCase "decodeTu64 non-minimal fails" $-      decodeTu64 5 (BS.pack [0x00, 0x01, 0x00, 0x00, 0x00]) @?= Nothing-  ]---- Minimal signed integer tests (Appendix D) --------------------------------------minsigned_tests :: TestTree-minsigned_tests = testGroup "Minimal signed (Appendix D)" [-    -- Test vectors from BOLT #1 Appendix D-    testCase "encode 0" $-      encodeMinSigned 0 @?= unhex "00"-  , testCase "encode 42" $-      encodeMinSigned 42 @?= unhex "2a"-  , testCase "encode -42" $-      encodeMinSigned (-42) @?= unhex "d6"-  , testCase "encode 127" $-      encodeMinSigned 127 @?= unhex "7f"-  , testCase "encode -128" $-      encodeMinSigned (-128) @?= unhex "80"-  , testCase "encode 128" $-      encodeMinSigned 128 @?= unhex "0080"-  , testCase "encode -129" $-      encodeMinSigned (-129) @?= unhex "ff7f"-  , testCase "encode 15000" $-      encodeMinSigned 15000 @?= unhex "3a98"-  , testCase "encode -15000" $-      encodeMinSigned (-15000) @?= unhex "c568"-  , testCase "encode 32767" $-      encodeMinSigned 32767 @?= unhex "7fff"-  , testCase "encode -32768" $-      encodeMinSigned (-32768) @?= unhex "8000"-  , testCase "encode 32768" $-      encodeMinSigned 32768 @?= unhex "00008000"-  , testCase "encode -32769" $-      encodeMinSigned (-32769) @?= unhex "ffff7fff"-  , testCase "encode 21000000" $-      encodeMinSigned 21000000 @?= unhex "01406f40"-  , testCase "encode -21000000" $-      encodeMinSigned (-21000000) @?= unhex "febf90c0"-  , testCase "encode 2147483647" $-      encodeMinSigned 2147483647 @?= unhex "7fffffff"-  , testCase "encode -2147483648" $-      encodeMinSigned (-2147483648) @?= unhex "80000000"-  , testCase "encode 2147483648" $-      encodeMinSigned 2147483648 @?= unhex "0000000080000000"-  , testCase "encode -2147483649" $-      encodeMinSigned (-2147483649) @?= unhex "ffffffff7fffffff"-  , testCase "encode 500000000000" $-      encodeMinSigned 500000000000 @?= unhex "000000746a528800"-  , testCase "encode -500000000000" $-      encodeMinSigned (-500000000000) @?= unhex "ffffff8b95ad7800"-  , testCase "encode max int64" $-      encodeMinSigned 9223372036854775807 @?= unhex "7fffffffffffffff"-  , testCase "encode min int64" $-      encodeMinSigned (-9223372036854775808) @?= unhex "8000000000000000"-  -- Decode tests-  , testCase "decode 1-byte 42" $-      decodeMinSigned 1 (unhex "2a") @?= Just (42, "")-  , testCase "decode 1-byte -42" $-      decodeMinSigned 1 (unhex "d6") @?= Just (-42, "")-  , testCase "decode 2-byte 128" $-      decodeMinSigned 2 (unhex "0080") @?= Just (128, "")-  , testCase "decode 2-byte -129" $-      decodeMinSigned 2 (unhex "ff7f") @?= Just (-129, "")-  , testCase "decode 4-byte 32768" $-      decodeMinSigned 4 (unhex "00008000") @?= Just (32768, "")-  , testCase "decode 8-byte 2147483648" $-      decodeMinSigned 8 (unhex "0000000080000000") @?= Just (2147483648, "")-  -- Minimality rejection-  , testCase "decode 2-byte for 1-byte value fails" $-      decodeMinSigned 2 (unhex "0042") @?= Nothing  -- 42 fits in 1 byte-  , testCase "decode 4-byte for 2-byte value fails" $-      decodeMinSigned 4 (unhex "00000080") @?= Nothing  -- 128 fits in 2 bytes-  , testCase "decode 8-byte for 4-byte value fails" $-      decodeMinSigned 8 (unhex "0000000000008000") @?= Nothing  -- 32768 fits in 4-  ]---- TLV tests ---------------------------------------------------------------------tlv_tests :: TestTree-tlv_tests = testGroup "TLV" [-    testGroup "tlvStream smart constructor" [-      testCase "empty list succeeds" $-        tlvStream [] @?= Just (unsafeTlvStream [])-    , testCase "single record succeeds" $-        tlvStream [TlvRecord 1 "a"] @?= Just (unsafeTlvStream [TlvRecord 1 "a"])-    , testCase "strictly increasing succeeds" $-        tlvStream [TlvRecord 1 "a", TlvRecord 3 "b", TlvRecord 5 "c"] @?=-          Just (unsafeTlvStream [TlvRecord 1 "a", TlvRecord 3 "b",-                                 TlvRecord 5 "c"])-    , testCase "non-increasing fails" $-        tlvStream [TlvRecord 5 "a", TlvRecord 3 "b"] @?= Nothing-    , testCase "duplicate types fails" $-        tlvStream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing-    , testCase "equal adjacent types fails" $-        tlvStream [TlvRecord 1 "a", TlvRecord 2 "b", TlvRecord 2 "c"] @?=-          Nothing-    ]-  , testCase "empty stream" $-      decodeTlvStream "" @?= Right (unsafeTlvStream [])-  , testCase "single record type 1" $ do-      let bs = mconcat [-              encodeBigSize 1      -- type-            , encodeBigSize 32     -- length-            , BS.replicate 32 0x00 -- value (chain hash)-            ]-      case decodeTlvStream bs of-        Right stream -> case unTlvStream stream of-          [r] -> do-            tlvType r @?= 1-            BS.length (tlvValue r) @?= 32-          _ -> assertFailure "expected single record"-        Left e -> assertFailure $ "unexpected error: " ++ show e-  , testCase "strictly increasing types" $ do-      let bs = mconcat [-              encodeBigSize 1, encodeBigSize 0-            , encodeBigSize 3, encodeBigSize 4, "test"-            ]-      case decodeTlvStream bs of-        Right stream -> length (unTlvStream stream) @?= 2-        Left e -> assertFailure $ "unexpected error: " ++ show e-  , testCase "non-increasing types fails" $ do-      let bs = mconcat [-              encodeBigSize 3, encodeBigSize 0-            , encodeBigSize 1, encodeBigSize 0-            ]-      case decodeTlvStream bs of-        Left TlvNotStrictlyIncreasing -> pure ()-        other -> assertFailure $ "expected TlvNotStrictlyIncreasing: " ++-                                 show other-  , testCase "duplicate types fails" $ do-      let bs = mconcat [-              encodeBigSize 1, encodeBigSize 0-            , encodeBigSize 1, encodeBigSize 0-            ]-      case decodeTlvStream bs of-        Left TlvNotStrictlyIncreasing -> pure ()-        other -> assertFailure $ "expected TlvNotStrictlyIncreasing: " ++-                                 show other-  , testCase "unknown even type fails" $ do-      let bs = mconcat [encodeBigSize 2, encodeBigSize 0]-      case decodeTlvStream bs of-        Left (TlvUnknownEvenType 2) -> pure ()-        other -> assertFailure $ "expected TlvUnknownEvenType: " ++ show other-  , testCase "unknown odd type skipped" $ do-      let bs = mconcat [-              encodeBigSize 5, encodeBigSize 2, "hi"-            , encodeBigSize 7, encodeBigSize 0-            ]-      case decodeTlvStream bs of-        Right stream | null (unTlvStream stream) -> pure ()  -- both skipped-        other -> assertFailure $ "expected empty stream: " ++ show other-  , testCase "length exceeds bounds fails" $ do-      let bs = mconcat [encodeBigSize 1, encodeBigSize 100, "short"]-      case decodeTlvStream bs of-        Left TlvLengthExceedsBounds -> pure ()-        other -> assertFailure $ "expected TlvLengthExceedsBounds: " ++-                                 show other-  , testCase "decodeTlvStreamWith custom predicate" $ do-      -- Use a predicate that only knows type 5-      let isKnown t = t == 5-          bs = mconcat [-              encodeBigSize 5, encodeBigSize 2, "hi"-            ]-      case decodeTlvStreamWith isKnown bs of-        Right stream -> case unTlvStream stream of-          [r] -> tlvType r @?= 5-          _ -> assertFailure "expected single record"-        Left e -> assertFailure $ "unexpected error: " ++ show e-  , testCase "decodeTlvStreamRaw returns all records" $ do-      let bs = mconcat [-              encodeBigSize 2, encodeBigSize 1, "a"  -- even type-            , encodeBigSize 5, encodeBigSize 1, "b"  -- odd type-            ]-      case decodeTlvStreamRaw bs of-        Right stream -> length (unTlvStream stream) @?= 2-        Left e -> assertFailure $ "unexpected error: " ++ show e-  ]---- Message encode/decode tests ---------------------------------------------------message_tests :: TestTree-message_tests = testGroup "Messages" [-    testGroup "Init" [-      testCase "encode/decode minimal init" $ do-        let msg = Init "" "" []-        case encodeMessage (MsgInitVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgInit encoded of-            Right (MsgInitVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    , testCase "encode/decode init with features" $ do-        let msg = Init (BS.pack [0x01]) (BS.pack [0x02, 0x0a]) []-        case encodeMessage (MsgInitVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgInit encoded of-            Right (MsgInitVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    , testCase "encode/decode init with networks TLV" $ do-        let ch = unsafeChainHash (BS.replicate 32 0xab)-            msg = Init "" "" [InitNetworks [ch]]-        case encodeMessage (MsgInitVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgInit encoded of-            Right (MsgInitVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    ]-  , testGroup "Error" [-      testCase "encode/decode error" $ do-        let cid = unsafeChannelId (BS.replicate 32 0xff)-            msg = Error cid "something went wrong"-        case encodeMessage (MsgErrorVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgError encoded of-            Right (MsgErrorVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    , testCase "error insufficient channel_id" $ do-        case decodeMessage MsgError (BS.replicate 31 0x00) of-          Left DecodeInsufficientBytes -> pure ()-          other -> assertFailure $ "expected insufficient: " ++ show other-    ]-  , testGroup "Warning" [-      testCase "encode/decode warning" $ do-        let cid = unsafeChannelId (BS.replicate 32 0x00)-            msg = Warning cid "be careful"-        case encodeMessage (MsgWarningVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgWarning encoded of-            Right (MsgWarningVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    ]-  , testGroup "Ping" [-      testCase "encode/decode ping" $ do-        let msg = Ping 100 (BS.replicate 10 0x00)-        case encodeMessage (MsgPingVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgPing encoded of-            Right (MsgPingVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    , testCase "ping with zero ignored" $ do-        let msg = Ping 50 ""-        case encodeMessage (MsgPingVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgPing encoded of-            Right (MsgPingVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    ]-  , testGroup "Pong" [-      testCase "encode/decode pong" $ do-        let msg = Pong (BS.replicate 100 0x00)-        case encodeMessage (MsgPongVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgPong encoded of-            Right (MsgPongVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    ]-  , testGroup "PeerStorage" [-      testCase "encode/decode peer_storage" $ do-        let msg = PeerStorage "encrypted blob data"-        case encodeMessage (MsgPeerStorageVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgPeerStorage encoded of-            Right (MsgPeerStorageVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    ]-  , testGroup "PeerStorageRetrieval" [-      testCase "encode/decode peer_storage_retrieval" $ do-        let msg = PeerStorageRetrieval "retrieved blob"-        case encodeMessage (MsgPeerStorageRetrievalVal msg) of-          Left e -> assertFailure $ "encode failed: " ++ show e-          Right encoded -> case decodeMessage MsgPeerStorageRet encoded of-            Right (MsgPeerStorageRetrievalVal decoded, _) -> decoded @?= msg-            other -> assertFailure $ "unexpected: " ++ show other-    ]-  , testGroup "Unknown types" [-      testCase "decodeMessage unknown even type" $ do-        case decodeMessage (MsgUnknown 100) "payload" of-          Left (DecodeUnknownEvenType 100) -> pure ()-          other -> assertFailure $ "expected unknown even: " ++ show other-    , testCase "decodeMessage unknown odd type" $ do-        case decodeMessage (MsgUnknown 101) "payload" of-          Left (DecodeUnknownOddType 101) -> pure ()-          other -> assertFailure $ "expected unknown odd: " ++ show other-    ]-  ]---- Envelope tests ----------------------------------------------------------------envelope_tests :: TestTree-envelope_tests = testGroup "Envelope" [-    testCase "encode/decode init envelope" $ do-      let msg = MsgInitVal (Init "" "" [])-      case encodeEnvelope msg Nothing of-        Left e -> assertFailure $ "encode failed: " ++ show e-        Right encoded -> case decodeEnvelope encoded of-          Right (Just decoded, _) -> decoded @?= msg-          other -> assertFailure $ "unexpected: " ++ show other-  , testCase "encode/decode ping envelope" $ do-      let msg = MsgPingVal (Ping 10 "")-      case encodeEnvelope msg Nothing of-        Left e -> assertFailure $ "encode failed: " ++ show e-        Right encoded -> case decodeEnvelope encoded of-          Right (Just decoded, _) -> decoded @?= msg-          other -> assertFailure $ "unexpected: " ++ show other-  , testCase "unknown even type fails" $ do-      let bs = encodeU16 100 <> "payload"  -- 100 is even, unknown-      case decodeEnvelope bs of-        Left (DecodeUnknownEvenType 100) -> pure ()-        other -> assertFailure $ "expected unknown even: " ++ show other-  , testCase "unknown odd type ignored" $ do-      let bs = encodeU16 101 <> "payload"  -- 101 is odd, unknown-      case decodeEnvelope bs of-        Right (Nothing, Nothing) -> pure ()  -- ignored-        other -> assertFailure $ "expected (Nothing, Nothing): " ++ show other-  , testCase "insufficient bytes for type" $ do-      case decodeEnvelope (BS.pack [0x00]) of-        Left DecodeInsufficientBytes -> pure ()-        other -> assertFailure $ "expected insufficient: " ++ show other-  , testCase "message type codes" $ do-      msgTypeWord MsgInit @?= 16-      msgTypeWord MsgError @?= 17-      msgTypeWord MsgPing @?= 18-      msgTypeWord MsgPong @?= 19-      msgTypeWord MsgWarning @?= 1-      msgTypeWord MsgPeerStorage @?= 7-      msgTypeWord MsgPeerStorageRet @?= 9-  ]---- Extension TLV tests -----------------------------------------------------------extension_tests :: TestTree-extension_tests = testGroup "Extension TLV" [-    testCase "encode envelope with extension (odd type)" $ do-      let msg = MsgPingVal (Ping 10 "")-          ext = unsafeTlvStream [TlvRecord 101 "extension data"]  -- odd type-      case encodeEnvelope msg (Just ext) of-        Left e -> assertFailure $ "encode failed: " ++ show e-        Right encoded -> do-          -- Should contain message + extension-          assertBool "encoded should be longer" (BS.length encoded > 6)-  , testCase "decode envelope with odd extension - skipped per BOLT#1" $ do-      -- Per BOLT #1: unknown odd types are ignored (skipped)-      let msg = MsgPingVal (Ping 10 "")-          ext = unsafeTlvStream [TlvRecord 101 "ext"]  -- odd type-      case encodeEnvelope msg (Just ext) of-        Left e -> assertFailure $ "encode failed: " ++ show e-        Right encoded -> case decodeEnvelope encoded of-          Right (Just decoded, Just stream)-            | null (unTlvStream stream) -> do-                -- Extension is empty because unknown odd types are skipped-                decoded @?= msg-          other -> assertFailure $ "unexpected: " ++ show other-  , testCase "decode envelope with unknown even extension fails" $ do-      -- Per BOLT #1: unknown even types must cause failure-      let pingPayload = mconcat [encodeU16 10, encodeU16 0]  -- numPong=10, len=0-          extTlv = mconcat [encodeBigSize 100, encodeBigSize 3, "abc"]  -- even!-          envelope = encodeU16 18 <> pingPayload <> extTlv  -- type 18 = ping-      case decodeEnvelope envelope of-        Left (DecodeInvalidExtension (TlvUnknownEvenType 100)) -> pure ()-        other -> assertFailure $ "expected unknown even error: " ++ show other-  , testCase "decode envelope with invalid extension fails" $ do-      -- Ping + invalid TLV (non-strictly-increasing)-      let pingPayload = mconcat [encodeU16 10, encodeU16 0]-          badTlv = mconcat [-              encodeBigSize 101, encodeBigSize 1, "a"  -- odd types for this test-            , encodeBigSize 51, encodeBigSize 1, "b"   -- 51 < 101, invalid-            ]-          envelope = encodeU16 18 <> pingPayload <> badTlv-      case decodeEnvelope envelope of-        Left (DecodeInvalidExtension TlvNotStrictlyIncreasing) -> pure ()-        other -> assertFailure $ "expected invalid extension: " ++ show other-  , testCase "unknown even in extension fails even with odd types present" $ do-      -- Mixed odd and even - should fail on the even type-      let pingPayload = mconcat [encodeU16 10, encodeU16 0]-          extTlv = mconcat [-              encodeBigSize 101, encodeBigSize 1, "a"  -- odd, would be skipped-            , encodeBigSize 200, encodeBigSize 1, "b"  -- even, must fail-            ]-          envelope = encodeU16 18 <> pingPayload <> extTlv-      case decodeEnvelope envelope of-        Left (DecodeInvalidExtension (TlvUnknownEvenType 200)) -> pure ()-        other -> assertFailure $ "expected unknown even error: " ++ show other-  ]---- Bounds checking tests ---------------------------------------------------------bounds_tests :: TestTree-bounds_tests = testGroup "Bounds checking" [-    testCase "encode ping with oversized ignored fails" $ do-      let msg = Ping 10 (BS.replicate 70000 0x00)  -- > 65535-      case encodeMessage (MsgPingVal msg) of-        Left EncodeLengthOverflow -> pure ()-        other -> assertFailure $ "expected overflow: " ++ show other-  , testCase "encode pong with oversized ignored fails" $ do-      let msg = Pong (BS.replicate 70000 0x00)-      case encodeMessage (MsgPongVal msg) of-        Left EncodeLengthOverflow -> pure ()-        other -> assertFailure $ "expected overflow: " ++ show other-  , testCase "encode error with oversized data fails" $ do-      let cid = unsafeChannelId (BS.replicate 32 0x00)-          msg = Error cid (BS.replicate 70000 0x00)-      case encodeMessage (MsgErrorVal msg) of-        Left EncodeLengthOverflow -> pure ()-        other -> assertFailure $ "expected overflow: " ++ show other-  , testCase "encode init with oversized features fails" $ do-      let msg = Init "" (BS.replicate 70000 0x00) []-      case encodeMessage (MsgInitVal msg) of-        Left EncodeLengthOverflow -> pure ()-        other -> assertFailure $ "expected overflow: " ++ show other-  , testCase "encode peer_storage with oversized blob fails" $ do-      let msg = PeerStorage (BS.replicate 70000 0x00)-      case encodeMessage (MsgPeerStorageVal msg) of-        Left EncodeLengthOverflow -> pure ()-        other -> assertFailure $ "expected overflow: " ++ show other-  , testCase "encode envelope exceeding 65535 bytes fails" $ do-      -- Create a message that fits in encodeMessage but combined with-      -- extension exceeds 65535 bytes total-      let msg = MsgPongVal (Pong (BS.replicate 60000 0x00))-          ext = unsafeTlvStream [TlvRecord 101 (BS.replicate 10000 0x00)]-      case encodeEnvelope msg (Just ext) of-        Left EncodeMessageTooLarge -> pure ()-        other -> assertFailure $ "expected message too large: " ++ show other-  ]---- Property tests ----------------------------------------------------------------property_tests :: TestTree-property_tests = testGroup "Properties" [-    testProperty "BigSize roundtrip" $ \(NonNegative n) ->-      case decodeBigSize (encodeBigSize n) of-        Just (m, rest) -> m == n && BS.null rest-        Nothing -> False-  , testProperty "U16 roundtrip" $ \w ->-      decodeU16 (encodeU16 w) == Just (w, "")-  , testProperty "U32 roundtrip" $ \w ->-      decodeU32 (encodeU32 w) == Just (w, "")-  , testProperty "U64 roundtrip" $ \w ->-      decodeU64 (encodeU64 w) == Just (w, "")-  , testProperty "Ping roundtrip" $ \(NonNegative num) bs ->-      let ignored = BS.pack (take 1000 bs)  -- limit size-          msg = Ping (fromIntegral (num `mod` 65536 :: Integer)) ignored-      in case encodeMessage (MsgPingVal msg) of-           Left _ -> False-           Right encoded -> case decodeMessage MsgPing encoded of-             Right (MsgPingVal decoded, rest) ->-               decoded == msg && BS.null rest-             _ -> False-  , testProperty "Pong roundtrip" $ \bs ->-      let ignored = BS.pack (take 1000 bs)-          msg = Pong ignored-      in case encodeMessage (MsgPongVal msg) of-           Left _ -> False-           Right encoded -> case decodeMessage MsgPong encoded of-             Right (MsgPongVal decoded, rest) ->-               decoded == msg && BS.null rest-             _ -> False-  , testProperty "PeerStorage roundtrip" $ \bs ->-      let blob = BS.pack (take 1000 bs)-          msg = PeerStorage blob-      in case encodeMessage (MsgPeerStorageVal msg) of-           Left _ -> False-           Right encoded -> case decodeMessage MsgPeerStorage encoded of-             Right (MsgPeerStorageVal decoded, rest) ->-               decoded == msg && BS.null rest-             _ -> False-  , testProperty "Error roundtrip" $ \bs ->-      let cid = unsafeChannelId (BS.replicate 32 0x00)-          dat = BS.pack (take 1000 bs)-          msg = Error cid dat-      in case encodeMessage (MsgErrorVal msg) of-           Left _ -> False-           Right encoded -> case decodeMessage MsgError encoded of-             Right (MsgErrorVal decoded, rest) ->-               decoded == msg && BS.null rest-             _ -> False-  , testProperty "Envelope with odd extension (skipped per BOLT#1)" $ \bs ->-      -- Unknown odd types in extensions are skipped per BOLT #1-      let msg = MsgPingVal (Ping 42 "")-          extData = BS.pack (take 100 bs)-          ext = unsafeTlvStream [TlvRecord 101 extData]  -- odd type, skipped-      in case encodeEnvelope msg (Just ext) of-           Left _ -> False-           Right encoded -> case decodeEnvelope encoded of-             -- Extension should be empty (odd types skipped)-             Right (Just decoded, Just stream) ->-               null (unTlvStream stream) && decoded == msg-             _ -> False-  ]---- Helpers ------------------------------------------------------------------------- | Construct a 'ChannelId' from a known-valid 32-byte 'BS.ByteString'.------ Uses 'error' for invalid input since all channel IDs in tests are--- known-valid compile-time constants.-unsafeChannelId :: BS.ByteString -> ChannelId-unsafeChannelId bs = case channelId bs of-  Just cid -> cid-  Nothing  -> error $ "unsafeChannelId: invalid length: " ++ show (BS.length bs)---- | Decode hex string (test-only helper).------ Uses 'error' for invalid hex since all hex literals in tests are--- known-valid compile-time constants. This is acceptable in test code--- where the failure would indicate a bug in the test itself.-unhex :: BS.ByteString -> BS.ByteString-unhex bs = case B16.decode bs of-  Just r  -> r-  Nothing -> error $ "unhex: invalid hex literal: " ++ show bs---- | Construct a ChainHash from a bytestring (test-only helper).------ Uses 'error' for invalid input since all chain hashes in tests are--- known-valid 32-byte constants. This is acceptable in test code where--- the failure would indicate a bug in the test itself.-unsafeChainHash :: BS.ByteString -> ChainHash-unsafeChainHash bs = case chainHash bs of-  Just c  -> c-  Nothing -> error $ "unsafeChainHash: not 32 bytes: " ++ show (BS.length bs)+import qualified Data.ByteString.Char8 as B8+import Data.Int (Int64)+import qualified Data.List as L+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Word (Word16, Word32, Word64)+import Lightning.Protocol.BOLT1+import qualified Lightning.Protocol.BOLT9 as BOLT9+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain $ testGroup "ppad-bolt1" [+    appendix_a+  , appendix_b+  , appendix_c+  , appendix_d+  , primitives+  , tlv+  , messages+  , properties+  ]++-- helpers --------------------------------------------------------------------++-- run an assertion on decoded hex (spaces and a 0x prefix are allowed),+-- failing the test if the literal isn't valid hex+with_hex :: String -> (BS.ByteString -> Assertion) -> Assertion+with_hex s k = case B16.decode (B8.pack (strip s)) of+  Nothing -> assertFailure ("invalid hex literal: " ++ s)+  Just bs -> k bs+  where+    strip = filter (/= ' ') . drop0x+    drop0x ('0':'x':r) = r+    drop0x r = r++is_left :: Either a b -> Bool+is_left = either (const True) (const False)++empty_fv :: BOLT9.FeatureVector+empty_fv = BOLT9.parse ""++-- Appendix A: BigSize --------------------------------------------------------++appendix_a :: TestTree+appendix_a = testGroup "Appendix A (BigSize)" [+    testGroup "decoding" (map dec ok_vectors)+  , testGroup "encoding" (map enc ok_vectors)+  , testGroup "decoding failures" (map bad bad_vectors)+  ]+  where+    dec (v, h) = testCase ("decode " ++ h) $ with_hex h $ \bs ->+      decode_bigsize bs @?= Just (v, "")+    enc (v, h) = testCase ("encode " ++ show v) $ with_hex h $ \bs ->+      encode_bigsize v @?= bs+    bad h = testCase ("reject " ++ show h) $ with_hex h $ \bs ->+      decode_bigsize bs @?= Nothing++    ok_vectors :: [(Word64, String)]+    ok_vectors = [+        (0, "00"), (252, "fc"), (253, "fd00fd"), (65535, "fdffff")+      , (65536, "fe00010000"), (4294967295, "feffffffff")+      , (4294967296, "ff0000000100000000")+      , (18446744073709551615, "ffffffffffffffffff")+      ]++    -- non-canonical encodings, short reads and no reads+    bad_vectors = [+        "fd00fc", "fe0000ffff", "ff00000000ffffffff"+      , "fd00", "feffff", "ffffffffff"+      , "", "fd", "fe", "ff"+      ]++-- Appendix B: TLV ------------------------------------------------------------++-- the n1 and n2 test namespaces, decoded with bolt1's primitives++data N1 = N1Tlv1 !Word64+        | N1Tlv2 !ShortChannelId+        | N1Tlv3 !Point !Word64 !Word64+        | N1Tlv4 !Word16+  deriving (Eq, Show)++decode_n1 :: BS.ByteString -> Either String [N1]+decode_n1 bs = do+  s <- either (Left . show) Right (decode_tlv_stream (`elem` n1_types) bs)+  sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` n1_types ]+  where+    n1_types = [1, 2, 3, 254]+    one (TlvRecord 1 v) = maybe (Left "tlv1") (Right . N1Tlv1)+      (decode_tu64 v)+    one (TlvRecord 2 v) = case decode_short_channel_id v of+      Just (c, "") -> Right (N1Tlv2 c)+      _ -> Left "tlv2"+    one (TlvRecord 3 v) = maybe (Left "tlv3") Right $ do+      (p, r0) <- decode_point v+      (a, r1) <- decode_u64 r0+      (b, r2) <- decode_u64 r1+      if BS.null r2 then pure (N1Tlv3 p a b) else Nothing+    one (TlvRecord 254 v) = case decode_u16 v of+      Just (c, "") -> Right (N1Tlv4 c)+      _ -> Left "tlv4"+    one _ = Left "unreachable"++decode_n2 :: BS.ByteString -> Either String [(Word64, Word64)]+decode_n2 bs = do+  s <- either (Left . show) Right (decode_tlv_stream (`elem` [0, 11]) bs)+  sequence [ one r | r <- un_tlv_stream s, tlv_type r `elem` [0, 11] ]+  where+    one (TlvRecord 0 v) = maybe (Left "tlv1") (Right . (,) 0) (decode_tu64 v)+    one (TlvRecord 11 v) =+      maybe (Left "tlv2") (Right . (,) 11 . fromIntegral) (decode_tu32 v)+    one _ = Left "unreachable"++appendix_b :: TestTree+appendix_b = testGroup "Appendix B (TLV)" [+    testGroup "failures in any namespace" [+      testCase h $ with_hex h $ \bs -> do+        assertBool "n1" (is_left (decode_n1 bs))+        assertBool "n2" (is_left (decode_n2 bs))+    | h <- any_fail ]+  , testGroup "n1 failures" [+      testCase h $ with_hex h $ \bs -> assertBool "n1" (is_left (decode_n1 bs))+    | h <- n1_fail ]+  , testGroup "n2 failures" [+      testCase h $ with_hex h $ \bs -> assertBool "n2" (is_left (decode_n2 bs))+    | h <- n2_fail ]+  , testGroup "ignored successes" [+      testCase h $ with_hex h $ \bs -> do+        decode_n1 bs @?= Right []+        decode_n2 bs @?= Right []+    | h <- any_ok ]+  , testGroup "n1 successes" [+      testCase h $ with_hex h $ \bs -> decode_n1 bs @?= Right [v]+    | (h, v) <- n1_ok ]+  , testCase "n1 tlv3" $ with_hex n1_tlv3 $ \bs ->+      with_hex node_id $ \pk -> case point pk of+        Nothing -> assertFailure "bad node_id"+        Just p  -> decode_n1 bs @?= Right [N1Tlv3 p 1 2]+  , testCase "unknown even types fail when no types are known" $+      mapM_ (\h -> with_hex h $ \bs ->+        assertBool h (is_left (decode_tlv_stream (const False) bs)))+        ["12 00", "fd0102 00", "fe01000002 00", "ff0100000000000002 00"]+  , testCase "appending a higher-numbered valid stream succeeds" $+      with_hex "01 01 01" $ \a -> with_hex "fd00fe 02 0226" $ \b ->+        decode_n1 (a <> b) @?= Right [N1Tlv1 1, N1Tlv4 550]+  , testCase "appending an invalid stream fails" $+      with_hex "01 01 01" $ \a -> mapM_ (\h -> with_hex h $ \b ->+        assertBool h (is_left (decode_n1 (a <> b)))) any_fail+  ]+  where+    any_fail = [+        "0xfd", "0xfd01", "0xfd0001 00", "0xfd0101", "0x0f fd", "0x0f fd26"+      , "0x0f fd2602", "0x0f fd0001 00", "0x0f fd0201 " ++ replicate 1024 '0'+      , "0x12 00", "0xfd0102 00", "0xfe01000002 00"+      , "0xff0100000000000002 00"+      ]+    n1_fail = [+        "0x01 09 ffffffffffffffffff", "0x01 01 00", "0x01 02 0001"+      , "0x01 03 000100", "0x01 04 00010000", "0x01 05 0001000000"+      , "0x01 06 000100000000", "0x01 07 00010000000000"+      , "0x01 08 0001000000000000", "0x02 07 01010101010101"+      , "0x02 09 010101010101010101"+      , "0x03 21 " ++ node_id+      , "0x03 29 " ++ node_id ++ "0000000000000001"+      , "0x03 30 " ++ node_id ++ "000000000000000100000000000001"+      , "0x03 31 04" ++ drop 2 node_id+          ++ "00000000000000010000000000000002"+      , "0x03 32 " ++ node_id ++ "0000000000000001000000000000000001"+      , "0xfd00fe 00", "0xfd00fe 01 01", "0xfd00fe 03 010101", "0x00 00"+      , "0x02 08 0000000000000226 01 01 2a"+      , "0x02 08 0000000000000231 02 08 0000000000000451"+      , "0x1f 00 0f 01 2a", "0x1f 00 1f 01 2a"+      ]+    n2_fail = ["0xffffffffffffffffff 00 00 00"]+    any_ok = [+        "0x", "0x21 00", "0xfd0201 00", "0xfd00fd 00", "0xfd00ff 00"+      , "0xfe02000001 00", "0xff0200000000000001 00"+      ]+    n1_ok = [+        ("0x01 00", N1Tlv1 0), ("0x01 01 01", N1Tlv1 1)+      , ("0x01 02 0100", N1Tlv1 256), ("0x01 03 010000", N1Tlv1 65536)+      , ("0x01 04 01000000", N1Tlv1 16777216)+      , ("0x01 05 0100000000", N1Tlv1 4294967296)+      , ("0x01 06 010000000000", N1Tlv1 1099511627776)+      , ("0x01 07 01000000000000", N1Tlv1 281474976710656)+      , ("0x01 08 0100000000000000", N1Tlv1 72057594037927936)+      , ("0x02 08 0000000000000226", N1Tlv2 (ShortChannelId 0x226))+      , ("0xfd00fe 02 0226", N1Tlv4 550)+      ]+    node_id =+      "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"+    n1_tlv3 = "0x03 31 " ++ node_id ++ "00000000000000010000000000000002"++-- Appendix C: message extension ----------------------------------------------++appendix_c :: TestTree+appendix_c = testGroup "Appendix C (message extension)" [+    testCase "no extension" $ with_hex "001000000000" $ \bs ->+      case decode_message bs of+        Right (MsgInit i) -> do+          init_networks i @?= Nothing+          init_tlvs i @?= empty_tlv_stream+        other -> assertFailure (show other)+  , testCase "two unknown odd records are kept" $+      with_hex "001000000000c9012acb0104" $ \bs ->+        case decode_message bs of+          Right m@(MsgInit i) -> do+            map tlv_type (un_tlv_stream (init_tlvs i)) @?= [0xc9, 0xcb]+            encode_message m @?= Right bs+          other -> assertFailure (show other)+  , testCase "truncated extension" $ with_hex "00100000000001" $ \bs ->+      decode_message bs @?= Left (DecodeTlvError TlvTruncated)+  , testCase "unknown even record" $ with_hex "001000000000ca012a" $ \bs ->+      decode_message bs @?= Left (DecodeTlvError (TlvUnknownEvenType 0xca))+  , testCase "duplicate record" $ with_hex "001000000000c90101c90102" $ \bs ->+      decode_message bs @?= Left (DecodeTlvError TlvNotStrictlyIncreasing)+  ]++-- Appendix D: signed integers ------------------------------------------------++appendix_d :: TestTree+appendix_d = testGroup "Appendix D (signed integers)" [+    testCase (show v) $ with_hex h $ \bs -> case BS.length bs of+      1 -> do+        encode_s8 (fromIntegral v) @?= bs+        decode_s8 bs @?= Just (fromIntegral v, "")+      2 -> do+        encode_s16 (fromIntegral v) @?= bs+        decode_s16 bs @?= Just (fromIntegral v, "")+      4 -> do+        encode_s32 (fromIntegral v) @?= bs+        decode_s32 bs @?= Just (fromIntegral v, "")+      8 -> do+        encode_s64 v @?= bs+        decode_s64 bs @?= Just (v, "")+      _ -> assertFailure "bad vector width"+  | (v, h) <- vectors ]+  where+    vectors :: [(Int64, String)]+    vectors = [+        (0, "00"), (42, "2a"), (-42, "d6"), (127, "7f"), (-128, "80")+      , (128, "0080"), (-129, "ff7f"), (15000, "3a98"), (-15000, "c568")+      , (32767, "7fff"), (-32768, "8000"), (32768, "00008000")+      , (-32769, "ffff7fff"), (21000000, "01406f40")+      , (-21000000, "febf90c0"), (2147483647, "7fffffff")+      , (-2147483648, "80000000"), (2147483648, "0000000080000000")+      , (-2147483649, "ffffffff7fffffff"), (500000000000, "000000746a528800")+      , (-500000000000, "ffffff8b95ad7800")+      , (9223372036854775807, "7fffffffffffffff")+      , (-9223372036854775808, "8000000000000000")+      ]++-- primitives -----------------------------------------------------------------++primitives :: TestTree+primitives = testGroup "Primitives" [+    testCase "u16/u32/u64 known answers" $ do+      encode_u16 0x0102 @?= "\x01\x02"+      encode_u32 0x01020304 @?= "\x01\x02\x03\x04"+      encode_u64 0x0102030405060708 @?= "\x01\x02\x03\x04\x05\x06\x07\x08"+      decode_u32 "\x01\x02\x03\x04rest" @?= Just (0x01020304, "rest")+  , testCase "short reads fail" $ do+      decode_u16 "\x01" @?= Nothing+      decode_u32 "\x01\x02\x03" @?= Nothing+      decode_u64 "\x01\x02\x03\x04\x05\x06\x07" @?= Nothing+      decode_s8 "" @?= Nothing+  , testCase "truncated integers" $ do+      encode_tu64 0 @?= ""+      encode_tu64 1 @?= "\x01"+      encode_tu32 0x010000 @?= "\x01\x00\x00"+      decode_tu16 "" @?= Just 0+      decode_tu16 "\x00\x01" @?= Nothing+      decode_tu16 "\x01\x00\x00" @?= Nothing+      decode_tu32 "\x01\x00\x00\x00\x00" @?= Nothing+      decode_tu64 "\x01\x00\x00\x00\x00\x00\x00\x00\x00" @?= Nothing+  , testCase "length-prefixed bytes" $ do+      encode_u16_prefixed "abc" @?= Just "\x00\x03\&abc"+      encode_u16_prefixed (BS.replicate 65536 0) @?= Nothing+      decode_u16_prefixed "\x00\x03\&abcde" @?= Just ("abc", "de")+      decode_u16_prefixed "\x00\x03\&ab" @?= Nothing+  , testCase "fixed-size types check their lengths" $ do+      assertBool "chain_hash" (isNothing (chain_hash (BS.replicate 31 0)))+      assertBool "channel_id" (isNothing (channel_id (BS.replicate 33 0)))+      assertBool "signature" (isNothing (signature (BS.replicate 65 0)))+      assertBool "payment_hash" (isNothing (payment_hash ""))+      assertBool "preimage" (isNothing (payment_preimage ""))+      assertBool "secret" (isNothing (per_commitment_secret ""))+  , testCase "point prefix" $ do+      assertBool "02" (isJust (point (BS.cons 0x02 (BS.replicate 32 1))))+      assertBool "03" (isJust (point (BS.cons 0x03 (BS.replicate 32 1))))+      assertBool "04" (isNothing (point (BS.cons 0x04 (BS.replicate 32 1))))+      assertBool "len" (isNothing (point (BS.cons 0x02 (BS.replicate 31 1))))+  , testCase "short_channel_id" $ case short_channel_id 539268 845 1 of+      Nothing -> assertFailure "valid scid rejected"+      Just c -> do+        scid_block_height c @?= 539268+        scid_tx_index c @?= 845+        scid_output_index c @?= 1+        encode_short_channel_id c @?= "\x08\x3a\x84\x00\x03\x4d\x00\x01"+  , testCase "short_channel_id rejects 25-bit components" $ do+      short_channel_id 0x1000000 0 0 @?= Nothing+      short_channel_id 0 0x1000000 0 @?= Nothing+  , testCase "amount bounds" $ do+      fmap un_satoshi (satoshi 0x000775f05a074000) @?= Just 0x000775f05a074000+      satoshi 0x000775f05a074001 @?= Nothing+      fmap un_milli_satoshi (milli_satoshi 0x1d24b2dfac520000)+        @?= Just 0x1d24b2dfac520000+      milli_satoshi 0x1d24b2dfac520001 @?= Nothing+      sat_to_msat max_satoshi @?= max_milli_satoshi+      decode_satoshi (encode_u64 0x000775f05a074001) @?= Nothing+      decode_milli_satoshi (encode_u64 maxBound) @?= Nothing+  , testCase "checked arithmetic" $ do+      add_sat max_satoshi max_satoshi @?= Nothing+      (do a <- satoshi 1; b <- satoshi 2; sub_sat a b) @?= Nothing+      (do a <- satoshi 2; b <- satoshi 1; sub_sat a b) @?= satoshi 1+      (do a <- milli_satoshi 1; b <- milli_satoshi 2; sub_msat a b)+        @?= Nothing+      add_msat max_milli_satoshi max_milli_satoshi @?= Nothing+  , testCase "secrets don't show" $+      case payment_preimage (BS.replicate 32 7) of+        Nothing -> assertFailure "valid preimage rejected"+        Just p -> do+          show p @?= "PaymentPreimage <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)+  ]++-- TLV ------------------------------------------------------------------------++tlv :: TestTree+tlv = testGroup "TLV" [+    testCase "tlv_stream sorts" $+      fmap (map tlv_type . un_tlv_stream)+        (tlv_stream [TlvRecord 5 "", TlvRecord 1 "", TlvRecord 3 ""])+        @?= Just [1, 3, 5]+  , testCase "tlv_stream rejects duplicates" $+      tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] @?= Nothing+  , testCase "lookup_tlv" $ do+      (lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"])+        @?= Just "b"+      (lookup_tlv 2 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"])+        @?= Nothing+  , testCase "huge lengths are rejected, not wrapped" $+      mapM_ (\h -> with_hex h $ \bs ->+               decode_tlv_stream (const True) bs @?= Left TlvTruncated)+        [ "01ffffffffffffffffff", "01ff800000000000000067"+        , "01ffffffffffffffffff6701aa" ]+  , testCase "truncation vs non-minimal" $ do+      decode_tlv_stream (const True) "\xfd" @?= Left TlvTruncated+      decode_tlv_stream (const True) "\xfd\x00\x01\x00"+        @?= Left TlvNonMinimalBigSize+  , testCase "unknown odd records are kept" $+      fmap (map tlv_type . un_tlv_stream)+        (decode_tlv_stream (const False) "\x01\x00\x03\x01\x2a")+        @?= Right [1, 3]+  ]++-- messages -------------------------------------------------------------------++messages :: TestTree+messages = testGroup "Messages" [+    testCase "pong known answer" $+      encode_message (MsgPong (Pong "\x00\x00" empty_tlv_stream))+        @?= Right "\x00\x13\x00\x02\x00\x00"+  , testCase "ping known answer" $+      encode_message (MsgPing (Ping 4 "" empty_tlv_stream))+        @?= Right "\x00\x12\x00\x04\x00\x00"+  , testCase "error known answer" $+      encode_message (MsgError (Error all_channels "x" empty_tlv_stream))+        @?= Right ("\x00\x11" <> BS.replicate 32 0 <> "\x00\x01x")+  , testCase "init with networks and remote_addr" $+      case chain_hash (BS.replicate 32 0x6f) of+        Nothing -> assertFailure "valid chain hash rejected"+        Just ch -> do+          let addr = "\x01\x7f\x00\x00\x01\x26\x07"+              i = Init empty_fv (BOLT9.parse "\x02") (Just [ch])+                    (Just addr) empty_tlv_stream+              wire = "\x00\x10\x00\x00\x00\x01\x02"+                  <> "\x01\x20" <> un_chain_hash ch <> "\x03\x07" <> addr+          encode_message (MsgInit i) @?= Right wire+          decode_message wire @?= Right (MsgInit i)+  , testCase "init networks must be a multiple of 32 bytes" $+      decode_init "\x00\x00\x00\x00\x01\x01\x00"+        @?= Left (DecodeInvalidTlvValue 1)+  , testCase "init rejects tlvs clashing with typed fields" $+      case tlv_stream [TlvRecord 3 "x"] of+        Nothing -> assertFailure "valid stream rejected"+        Just s  -> encode_init (Init empty_fv empty_fv Nothing (Just "y") s)+          @?= Left EncodeInvalidTlvs+  , testCase "unknown message types" $ do+      decode_message "\x00\x20" @?= Left (DecodeUnknownEvenType 32)+      decode_message "\x80\x01" @?= Left (DecodeUnknownOddType 32769)+      decode_message "\x00" @?= Left DecodeInsufficientBytes+  , testCase "truncated payloads" $ do+      decode_init "\x00" @?= Left DecodeInsufficientBytes+      decode_init "\x00\x01" @?= Left DecodeInsufficientBytes+      decode_error (BS.replicate 31 0) @?= Left DecodeInsufficientBytes+      decode_warning (BS.replicate 33 0) @?= Left DecodeInsufficientBytes+      decode_ping "\x00\x04\x00\x02\x00" @?= Left DecodeInsufficientBytes+      decode_pong "\x00\x02\x00" @?= Left DecodeInsufficientBytes+      decode_peer_storage "\x00\x01" @?= Left DecodeInsufficientBytes+      decode_peer_storage_retrieval "\x00" @?= Left DecodeInsufficientBytes+  , testCase "invalid extensions" $ do+      decode_pong "\x00\x00\x02\x00" @?= Left+        (DecodeTlvError (TlvUnknownEvenType 2))+      decode_ping "\x00\x00\x00\x00\x01" @?= Left (DecodeTlvError TlvTruncated)+  , testCase "message size limit" $ do+      encode_envelope 7 (BS.replicate 65533 0) @?=+        Right (encode_u16 7 <> BS.replicate 65533 0)+      encode_envelope 7 (BS.replicate 65534 0) @?= Left EncodeMessageTooLarge+      encode_message (MsgPeerStorage (PeerStorage (BS.replicate 65532 0)+        empty_tlv_stream)) @?= Left EncodeMessageTooLarge+      encode_pong (Pong (BS.replicate 65536 0) empty_tlv_stream)+        @?= Left EncodeLengthOverflow+  , testCase "ping_response" $ do+      ping_response (Ping 3 "ab" empty_tlv_stream)+        @?= Just (Pong "\x00\x00\x00" empty_tlv_stream)+      ping_response (Ping 65531 "" empty_tlv_stream) @?=+        Just (Pong (BS.replicate 65531 0) empty_tlv_stream)+      ping_response (Ping 65532 "" empty_tlv_stream) @?= Nothing+  ]++-- properties -----------------------------------------------------------------++newtype Bytes = Bytes BS.ByteString+  deriving Show++instance Arbitrary Bytes where+  arbitrary = Bytes . BS.pack <$> (choose (0, 64) >>= vector)++-- streams of unknown odd records+newtype OddTlvs = OddTlvs TlvStream+  deriving Show++instance Arbitrary OddTlvs where+  arbitrary = do+    ts <- L.nub . map (\t -> 2 * (t `div` 2) + 1)+            <$> listOf (arbitrary :: Gen Word64)+    vs <- vectorOf (length ts) arbitrary+    pure . OddTlvs . fromMaybe empty_tlv_stream $+      tlv_stream [ TlvRecord t v | (t, Bytes v) <- zip ts vs ]++newtype Bytes32 = Bytes32 BS.ByteString+  deriving Show++instance Arbitrary Bytes32 where+  arbitrary = Bytes32 . BS.pack <$> vector 32++newtype Msg = Msg Message+  deriving Show++instance Arbitrary Msg where+  arbitrary = Msg <$> oneof [+      do Bytes a <- arbitrary+         Bytes b <- arbitrary+         nets <- oneof [pure Nothing, Just <$> listOf chain]+         addr <- oneof [pure Nothing, (\(Bytes x) -> Just x) <$> arbitrary]+         OddTlvs s <- arbitrary+         let s' = filter_tlv_stream (\t -> t /= 1 && t /= 3) s+         pure (MsgInit (Init (BOLT9.parse a) (BOLT9.parse b) nets addr s'))+    , do c <- cid+         Bytes d <- arbitrary+         OddTlvs s <- arbitrary+         pure (MsgError (Error c d s))+    , do c <- cid+         Bytes d <- arbitrary+         OddTlvs s <- arbitrary+         pure (MsgWarning (Warning c d s))+    , do n <- arbitrary+         Bytes d <- arbitrary+         OddTlvs s <- arbitrary+         pure (MsgPing (Ping n d s))+    , do Bytes d <- arbitrary+         OddTlvs s <- arbitrary+         pure (MsgPong (Pong d s))+    , do Bytes d <- arbitrary+         OddTlvs s <- arbitrary+         pure (MsgPeerStorage (PeerStorage d s))+    , do Bytes d <- arbitrary+         OddTlvs s <- arbitrary+         pure (MsgPeerStorageRetrieval (PeerStorageRetrieval d s))+    ]+    where+      chain = do+        Bytes32 b <- arbitrary+        maybe chain pure (chain_hash b)+      cid = do+        Bytes32 b <- arbitrary+        pure (fromMaybe all_channels (channel_id b))++properties :: TestTree+properties = testGroup "Properties" [+    testProperty "bigsize round-trips" $ \w ->+      decode_bigsize (encode_bigsize w) === Just (w, "")+  , testProperty "tu16 round-trips" $ \w ->+      decode_tu16 (encode_tu16 w) === Just w+  , testProperty "tu32 round-trips" $ \w ->+      decode_tu32 (encode_tu32 w) === Just w+  , testProperty "tu64 round-trips" $ \w ->+      decode_tu64 (encode_tu64 w) === Just w+  , testProperty "u16 round-trips" $ \w ->+      decode_u16 (encode_u16 w) === Just (w, "")+  , testProperty "u32 round-trips" $ \w ->+      decode_u32 (encode_u32 w) === Just (w, "")+  , testProperty "u64 round-trips" $ \w ->+      decode_u64 (encode_u64 w) === Just (w, "")+  , testProperty "s64 round-trips" $ \w ->+      decode_s64 (encode_s64 w) === Just (w, "")+  , testProperty "scid components round-trip" $ \h t o ->+      let h' = h `mod` 0x1000000 :: Word32+          t' = t `mod` 0x1000000 :: Word32+      in  fmap (\c -> (scid_block_height c, scid_tx_index c,+                       scid_output_index c)) (short_channel_id h' t' o)+            === Just (h', t', o)+  , testProperty "sat -> msat -> sat is the identity" $+      forAll (choose (0, 0x000775f05a074000)) $ \w ->+        fmap (msat_to_sat . sat_to_msat) (satoshi w) === satoshi w+  , testProperty "add then sub is the identity" $+      forAll (choose (0, 0x000775f05a074000)) $ \a ->+      forAll (choose (0, 0x000775f05a074000 - a)) $ \b ->+        (do x <- satoshi a+            y <- satoshi b+            z <- add_sat x y+            sub_sat z y) === satoshi a+  , testProperty "tlv streams round-trip" $ \(OddTlvs s) ->+      decode_tlv_stream (const False) (encode_tlv_stream s) === Right s+  , testProperty "messages round-trip" $ \(Msg m) ->+      case encode_message m of+        Left e   -> counterexample (show e) False+        Right bs -> decode_message bs === Right m+  , testProperty "re-encoding reproduces the wire bytes" $ \(Msg m) ->+      case encode_message m of+        Left e   -> counterexample (show e) False+        Right bs -> case decode_message bs of+          Left e   -> counterexample (show e) False+          Right m' -> encode_message m' === Right bs+  ]