commit 3df0fdc773fd7c055b5bfbfd0a3a363274aa03cb
parent 1216ddbcdc35dee03c6c883c4edbb2c60ceaa59b
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 25 Jan 2026 14:46:36 +0400
ppad-bolt4: add Types and Codec modules
Implement core data types and serialization for BOLT4:
Types module:
- OnionPacket, HopPayload, ShortChannelId, PaymentData, TlvRecord
- FailureMessage and FailureCode with flag patterns
- ProcessResult, ForwardInfo, ReceiveInfo
- Protocol constants
Codec module:
- BigSize encoding/decoding per BOLT1
- TLV stream encoding/decoding with ordering validation
- OnionPacket and HopPayload serialization
- ShortChannelId 8-byte encoding
- FailureMessage encoding/decoding
Includes comprehensive tests for boundary values, roundtrip properties,
and malformed input rejection.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
Diffstat:
4 files changed, 762 insertions(+), 1 deletion(-)
diff --git a/lib/Lightning/Protocol/BOLT4/Codec.hs b/lib/Lightning/Protocol/BOLT4/Codec.hs
@@ -0,0 +1,378 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Lightning.Protocol.BOLT4.Codec
+-- Copyright: (c) 2025 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- Serialization and deserialization for BOLT4 types.
+
+module Lightning.Protocol.BOLT4.Codec (
+ -- * BigSize encoding
+ encodeBigSize
+ , decodeBigSize
+ , bigSizeLen
+
+ -- * TLV encoding
+ , encodeTlv
+ , decodeTlv
+ , decodeTlvStream
+ , encodeTlvStream
+
+ -- * Packet serialization
+ , encodeOnionPacket
+ , decodeOnionPacket
+ , encodeHopPayload
+ , decodeHopPayload
+
+ -- * ShortChannelId
+ , encodeShortChannelId
+ , decodeShortChannelId
+
+ -- * Failure messages
+ , encodeFailureMessage
+ , decodeFailureMessage
+ ) where
+
+import Data.Bits (shiftL, shiftR, (.&.))
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as B
+import qualified Data.ByteString.Lazy as BL
+import Data.Word (Word8, Word16, Word32, Word64)
+import Lightning.Protocol.BOLT4.Types
+
+-- BigSize encoding ---------------------------------------------------------
+
+-- | Encode integer as BigSize.
+--
+-- * 0-0xFC: 1 byte
+-- * 0xFD-0xFFFF: 0xFD ++ 2 bytes BE
+-- * 0x10000-0xFFFFFFFF: 0xFE ++ 4 bytes BE
+-- * larger: 0xFF ++ 8 bytes BE
+encodeBigSize :: Word64 -> BS.ByteString
+encodeBigSize !n
+ | n < 0xFD = BS.singleton (fromIntegral n)
+ | n <= 0xFFFF = toStrict $
+ B.word8 0xFD <> B.word16BE (fromIntegral n)
+ | n <= 0xFFFFFFFF = toStrict $
+ B.word8 0xFE <> B.word32BE (fromIntegral n)
+ | otherwise = toStrict $
+ B.word8 0xFF <> B.word64BE n
+{-# INLINE encodeBigSize #-}
+
+-- | Decode BigSize, returning (value, remaining bytes).
+decodeBigSize :: BS.ByteString -> Maybe (Word64, BS.ByteString)
+decodeBigSize !bs = case BS.uncons bs of
+ Nothing -> Nothing
+ Just (b, rest)
+ | b < 0xFD -> Just (fromIntegral b, rest)
+ | b == 0xFD -> do
+ (hi, r1) <- BS.uncons rest
+ (lo, r2) <- BS.uncons r1
+ let !val = fromIntegral hi `shiftL` 8 + fromIntegral lo
+ -- Canonical: must be >= 0xFD
+ if val < 0xFD then Nothing else Just (val, r2)
+ | b == 0xFE -> do
+ if BS.length rest < 4 then Nothing else do
+ let !bytes = BS.take 4 rest
+ !r = BS.drop 4 rest
+ !val = word32BE bytes
+ -- Canonical: must be > 0xFFFF
+ if val <= 0xFFFF then Nothing else Just (fromIntegral val, r)
+ | otherwise -> do -- b == 0xFF
+ if BS.length rest < 8 then Nothing else do
+ let !bytes = BS.take 8 rest
+ !r = BS.drop 8 rest
+ !val = word64BE bytes
+ -- Canonical: must be > 0xFFFFFFFF
+ if val <= 0xFFFFFFFF then Nothing else Just (val, r)
+{-# INLINE decodeBigSize #-}
+
+-- | Get encoded size of a BigSize value without encoding.
+bigSizeLen :: Word64 -> Int
+bigSizeLen !n
+ | n < 0xFD = 1
+ | n <= 0xFFFF = 3
+ | n <= 0xFFFFFFFF = 5
+ | otherwise = 9
+{-# INLINE bigSizeLen #-}
+
+-- TLV encoding -------------------------------------------------------------
+
+-- | Encode a TLV record.
+encodeTlv :: TlvRecord -> BS.ByteString
+encodeTlv (TlvRecord !typ !val) = toStrict $
+ B.byteString (encodeBigSize typ) <>
+ B.byteString (encodeBigSize (fromIntegral (BS.length val))) <>
+ B.byteString val
+{-# INLINE encodeTlv #-}
+
+-- | Decode a single TLV record.
+decodeTlv :: BS.ByteString -> Maybe (TlvRecord, BS.ByteString)
+decodeTlv !bs = do
+ (typ, r1) <- decodeBigSize bs
+ (len, r2) <- decodeBigSize r1
+ let !len' = fromIntegral len
+ if BS.length r2 < len'
+ then Nothing
+ else do
+ let !val = BS.take len' r2
+ !rest = BS.drop len' r2
+ Just (TlvRecord typ val, rest)
+{-# INLINE decodeTlv #-}
+
+-- | Decode a TLV stream (sequence of records).
+-- Validates strictly increasing type order.
+decodeTlvStream :: BS.ByteString -> Maybe [TlvRecord]
+decodeTlvStream = go Nothing
+ where
+ go :: Maybe Word64 -> BS.ByteString -> Maybe [TlvRecord]
+ go _ !bs | BS.null bs = Just []
+ go !mPrev !bs = do
+ (rec@(TlvRecord typ _), rest) <- decodeTlv bs
+ -- Check strictly increasing order
+ case mPrev of
+ Just prev | typ <= prev -> Nothing
+ _ -> do
+ recs <- go (Just typ) rest
+ Just (rec : recs)
+
+-- | Encode a TLV stream from records.
+-- Records must be sorted by type, no duplicates.
+encodeTlvStream :: [TlvRecord] -> BS.ByteString
+encodeTlvStream !recs = toStrict $ foldMap (B.byteString . encodeTlv) recs
+{-# INLINE encodeTlvStream #-}
+
+-- Packet serialization -----------------------------------------------------
+
+-- | Serialize OnionPacket to 1366 bytes.
+encodeOnionPacket :: OnionPacket -> BS.ByteString
+encodeOnionPacket (OnionPacket !ver !eph !payloads !mac) = toStrict $
+ B.word8 ver <>
+ B.byteString eph <>
+ B.byteString payloads <>
+ B.byteString mac
+{-# INLINE encodeOnionPacket #-}
+
+-- | Parse OnionPacket from 1366 bytes.
+decodeOnionPacket :: BS.ByteString -> Maybe OnionPacket
+decodeOnionPacket !bs
+ | BS.length bs /= onionPacketSize = Nothing
+ | otherwise =
+ let !ver = BS.index bs 0
+ !eph = BS.take pubkeySize (BS.drop 1 bs)
+ !payloads = BS.take hopPayloadsSize (BS.drop (1 + pubkeySize) bs)
+ !mac = BS.drop (1 + pubkeySize + hopPayloadsSize) bs
+ in Just (OnionPacket ver eph payloads mac)
+{-# INLINE decodeOnionPacket #-}
+
+-- | Encode HopPayload to bytes (without length prefix).
+encodeHopPayload :: HopPayload -> BS.ByteString
+encodeHopPayload !hp = encodeTlvStream (buildTlvs hp)
+ where
+ buildTlvs :: HopPayload -> [TlvRecord]
+ buildTlvs (HopPayload amt cltv sci pd ed cpk unk) =
+ let amt' = maybe [] (\a -> [TlvRecord 2 (encodeWord64TU a)]) amt
+ cltv' = maybe [] (\c -> [TlvRecord 4 (encodeWord32TU c)]) cltv
+ sci' = maybe [] (\s -> [TlvRecord 6 (encodeShortChannelId s)]) sci
+ pd' = maybe [] (\p -> [TlvRecord 8 (encodePaymentData p)]) pd
+ ed' = maybe [] (\e -> [TlvRecord 10 e]) ed
+ cpk' = maybe [] (\k -> [TlvRecord 12 k]) cpk
+ in amt' ++ cltv' ++ sci' ++ pd' ++ ed' ++ cpk' ++ unk
+
+-- | Decode HopPayload from bytes.
+decodeHopPayload :: BS.ByteString -> Maybe HopPayload
+decodeHopPayload !bs = do
+ tlvs <- decodeTlvStream bs
+ parseHopPayload tlvs
+
+parseHopPayload :: [TlvRecord] -> Maybe HopPayload
+parseHopPayload = go emptyHop
+ where
+ emptyHop :: HopPayload
+ emptyHop = HopPayload Nothing Nothing Nothing Nothing Nothing Nothing []
+
+ go :: HopPayload -> [TlvRecord] -> Maybe HopPayload
+ go !hp [] = Just hp { hpUnknownTlvs = reverse (hpUnknownTlvs hp) }
+ go !hp (TlvRecord typ val : rest) = case typ of
+ 2 -> do
+ amt <- decodeWord64TU val
+ go hp { hpAmtToForward = Just amt } rest
+ 4 -> do
+ cltv <- decodeWord32TU val
+ go hp { hpOutgoingCltv = Just cltv } rest
+ 6 -> do
+ sci <- decodeShortChannelId val
+ go hp { hpShortChannelId = Just sci } rest
+ 8 -> do
+ pd <- decodePaymentData val
+ go hp { hpPaymentData = Just pd } rest
+ 10 -> go hp { hpEncryptedData = Just val } rest
+ 12 -> go hp { hpCurrentPathKey = Just val } rest
+ _ -> go hp { hpUnknownTlvs = TlvRecord typ val : hpUnknownTlvs hp } rest
+
+-- ShortChannelId -----------------------------------------------------------
+
+-- | Encode ShortChannelId to 8 bytes.
+-- Format: 3 bytes block || 3 bytes tx || 2 bytes output (all BE)
+encodeShortChannelId :: ShortChannelId -> BS.ByteString
+encodeShortChannelId (ShortChannelId !blk !tx !out) = toStrict $
+ -- Block height: 3 bytes
+ B.word8 (fromIntegral (blk `shiftR` 16) .&. 0xFF) <>
+ B.word8 (fromIntegral (blk `shiftR` 8) .&. 0xFF) <>
+ B.word8 (fromIntegral blk .&. 0xFF) <>
+ -- Tx index: 3 bytes
+ B.word8 (fromIntegral (tx `shiftR` 16) .&. 0xFF) <>
+ B.word8 (fromIntegral (tx `shiftR` 8) .&. 0xFF) <>
+ B.word8 (fromIntegral tx .&. 0xFF) <>
+ -- Output index: 2 bytes
+ B.word16BE out
+{-# INLINE encodeShortChannelId #-}
+
+-- | Decode ShortChannelId from 8 bytes.
+decodeShortChannelId :: BS.ByteString -> Maybe ShortChannelId
+decodeShortChannelId !bs
+ | BS.length bs /= 8 = Nothing
+ | otherwise =
+ let !b0 = fromIntegral (BS.index bs 0) :: Word32
+ !b1 = fromIntegral (BS.index bs 1) :: Word32
+ !b2 = fromIntegral (BS.index bs 2) :: Word32
+ !blk = (b0 `shiftL` 16) + (b1 `shiftL` 8) + b2
+ !t0 = fromIntegral (BS.index bs 3) :: Word32
+ !t1 = fromIntegral (BS.index bs 4) :: Word32
+ !t2 = fromIntegral (BS.index bs 5) :: Word32
+ !tx = (t0 `shiftL` 16) + (t1 `shiftL` 8) + t2
+ !o0 = fromIntegral (BS.index bs 6) :: Word16
+ !o1 = fromIntegral (BS.index bs 7) :: Word16
+ !out = (o0 `shiftL` 8) + o1
+ in Just (ShortChannelId blk tx out)
+{-# INLINE decodeShortChannelId #-}
+
+-- Failure messages ---------------------------------------------------------
+
+-- | Encode failure message.
+encodeFailureMessage :: FailureMessage -> BS.ByteString
+encodeFailureMessage (FailureMessage (FailureCode !code) !dat !tlvs) =
+ toStrict $
+ B.word16BE code <>
+ B.word16BE (fromIntegral (BS.length dat)) <>
+ B.byteString dat <>
+ B.byteString (encodeTlvStream tlvs)
+{-# INLINE encodeFailureMessage #-}
+
+-- | Decode failure message.
+decodeFailureMessage :: BS.ByteString -> Maybe FailureMessage
+decodeFailureMessage !bs = do
+ if BS.length bs < 4 then Nothing else do
+ let !code = word16BE (BS.take 2 bs)
+ !dlen = fromIntegral (word16BE (BS.take 2 (BS.drop 2 bs)))
+ if BS.length bs < 4 + dlen then Nothing else do
+ let !dat = BS.take dlen (BS.drop 4 bs)
+ !tlvBytes = BS.drop (4 + dlen) bs
+ tlvs <- if BS.null tlvBytes
+ then Just []
+ else decodeTlvStream tlvBytes
+ Just (FailureMessage (FailureCode code) dat tlvs)
+
+-- Helper functions ---------------------------------------------------------
+
+-- | Convert Builder to strict ByteString.
+toStrict :: B.Builder -> BS.ByteString
+toStrict = BL.toStrict . B.toLazyByteString
+{-# INLINE toStrict #-}
+
+-- | Decode big-endian Word16.
+word16BE :: BS.ByteString -> Word16
+word16BE !bs =
+ let !b0 = fromIntegral (BS.index bs 0) :: Word16
+ !b1 = fromIntegral (BS.index bs 1) :: Word16
+ in (b0 `shiftL` 8) + b1
+{-# INLINE word16BE #-}
+
+-- | Decode big-endian Word32.
+word32BE :: BS.ByteString -> Word32
+word32BE !bs =
+ let !b0 = fromIntegral (BS.index bs 0) :: Word32
+ !b1 = fromIntegral (BS.index bs 1) :: Word32
+ !b2 = fromIntegral (BS.index bs 2) :: Word32
+ !b3 = fromIntegral (BS.index bs 3) :: Word32
+ in (b0 `shiftL` 24) + (b1 `shiftL` 16) + (b2 `shiftL` 8) + b3
+{-# INLINE word32BE #-}
+
+-- | Decode big-endian Word64.
+word64BE :: BS.ByteString -> Word64
+word64BE !bs =
+ let !b0 = fromIntegral (BS.index bs 0) :: Word64
+ !b1 = fromIntegral (BS.index bs 1) :: Word64
+ !b2 = fromIntegral (BS.index bs 2) :: Word64
+ !b3 = fromIntegral (BS.index bs 3) :: Word64
+ !b4 = fromIntegral (BS.index bs 4) :: Word64
+ !b5 = fromIntegral (BS.index bs 5) :: Word64
+ !b6 = fromIntegral (BS.index bs 6) :: Word64
+ !b7 = fromIntegral (BS.index bs 7) :: Word64
+ in (b0 `shiftL` 56) + (b1 `shiftL` 48) + (b2 `shiftL` 40) +
+ (b3 `shiftL` 32) + (b4 `shiftL` 24) + (b5 `shiftL` 16) +
+ (b6 `shiftL` 8) + b7
+{-# INLINE word64BE #-}
+
+-- | Encode Word64 as truncated unsigned (minimal bytes).
+encodeWord64TU :: Word64 -> BS.ByteString
+encodeWord64TU !n
+ | n == 0 = BS.empty
+ | otherwise = BS.dropWhile (== 0) (toStrict (B.word64BE n))
+{-# INLINE encodeWord64TU #-}
+
+-- | Decode truncated unsigned to Word64.
+decodeWord64TU :: BS.ByteString -> Maybe Word64
+decodeWord64TU !bs
+ | BS.null bs = Just 0
+ | BS.length bs > 8 = Nothing
+ | not (BS.null bs) && BS.index bs 0 == 0 = Nothing -- Non-canonical
+ | otherwise = Just (go 0 bs)
+ where
+ go :: Word64 -> BS.ByteString -> Word64
+ go !acc !b = case BS.uncons b of
+ Nothing -> acc
+ Just (x, rest) -> go ((acc `shiftL` 8) + fromIntegral x) rest
+{-# INLINE decodeWord64TU #-}
+
+-- | Encode Word32 as truncated unsigned.
+encodeWord32TU :: Word32 -> BS.ByteString
+encodeWord32TU !n
+ | n == 0 = BS.empty
+ | otherwise = BS.dropWhile (== 0) (toStrict (B.word32BE n))
+{-# INLINE encodeWord32TU #-}
+
+-- | Decode truncated unsigned to Word32.
+decodeWord32TU :: BS.ByteString -> Maybe Word32
+decodeWord32TU !bs
+ | BS.null bs = Just 0
+ | BS.length bs > 4 = Nothing
+ | not (BS.null bs) && BS.index bs 0 == 0 = Nothing -- Non-canonical
+ | otherwise = Just (go 0 bs)
+ where
+ go :: Word32 -> BS.ByteString -> Word32
+ go !acc !b = case BS.uncons b of
+ Nothing -> acc
+ Just (x, rest) -> go ((acc `shiftL` 8) + fromIntegral x) rest
+{-# INLINE decodeWord32TU #-}
+
+-- | Encode PaymentData.
+encodePaymentData :: PaymentData -> BS.ByteString
+encodePaymentData (PaymentData !secret !total) =
+ secret <> encodeWord64TU total
+{-# INLINE encodePaymentData #-}
+
+-- | Decode PaymentData.
+decodePaymentData :: BS.ByteString -> Maybe PaymentData
+decodePaymentData !bs
+ | BS.length bs < 32 = Nothing
+ | otherwise = do
+ let !secret = BS.take 32 bs
+ !rest = BS.drop 32 bs
+ total <- decodeWord64TU rest
+ Just (PaymentData secret total)
+{-# INLINE decodePaymentData #-}
diff --git a/lib/Lightning/Protocol/BOLT4/Types.hs b/lib/Lightning/Protocol/BOLT4/Types.hs
@@ -0,0 +1,214 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+-- |
+-- Module: Lightning.Protocol.BOLT4.Types
+-- Copyright: (c) 2025 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- Core data types for BOLT4 onion routing.
+
+module Lightning.Protocol.BOLT4.Types (
+ -- * Packet types
+ OnionPacket(..)
+ , HopPayload(..)
+ , ShortChannelId(..)
+ , PaymentData(..)
+ , TlvRecord(..)
+
+ -- * Error types
+ , FailureMessage(..)
+ , FailureCode(..)
+ -- ** Flag bits
+ , pattern BADONION
+ , pattern PERM
+ , pattern NODE
+ , pattern UPDATE
+ -- ** Common failure codes
+ , pattern InvalidRealm
+ , pattern TemporaryNodeFailure
+ , pattern PermanentNodeFailure
+ , pattern InvalidOnionHmac
+ , pattern InvalidOnionKey
+ , pattern TemporaryChannelFailure
+ , pattern IncorrectOrUnknownPaymentDetails
+
+ -- * Processing results
+ , ProcessResult(..)
+ , ForwardInfo(..)
+ , ReceiveInfo(..)
+
+ -- * Constants
+ , onionPacketSize
+ , hopPayloadsSize
+ , hmacSize
+ , pubkeySize
+ , versionByte
+ , maxPayloadSize
+ ) where
+
+import Data.Bits ((.&.), (.|.))
+import qualified Data.ByteString as BS
+import Data.Word (Word8, Word16, Word32, Word64)
+import GHC.Generics (Generic)
+
+-- Packet types -------------------------------------------------------------
+
+-- | Complete onion packet (1366 bytes).
+data OnionPacket = OnionPacket
+ { opVersion :: {-# UNPACK #-} !Word8
+ , opEphemeralKey :: !BS.ByteString -- ^ 33 bytes, compressed pubkey
+ , opHopPayloads :: !BS.ByteString -- ^ 1300 bytes
+ , opHmac :: !BS.ByteString -- ^ 32 bytes
+ } deriving (Eq, Show, Generic)
+
+-- | Parsed hop payload after decryption.
+data HopPayload = HopPayload
+ { hpAmtToForward :: !(Maybe Word64) -- ^ TLV type 2
+ , hpOutgoingCltv :: !(Maybe Word32) -- ^ TLV type 4
+ , hpShortChannelId :: !(Maybe ShortChannelId) -- ^ TLV type 6
+ , hpPaymentData :: !(Maybe PaymentData) -- ^ TLV type 8
+ , hpEncryptedData :: !(Maybe BS.ByteString) -- ^ TLV type 10
+ , hpCurrentPathKey :: !(Maybe BS.ByteString) -- ^ TLV type 12
+ , hpUnknownTlvs :: ![TlvRecord] -- ^ Unknown types
+ } deriving (Eq, Show, Generic)
+
+-- | Short channel ID (8 bytes): block height, tx index, output index.
+data ShortChannelId = ShortChannelId
+ { sciBlockHeight :: {-# UNPACK #-} !Word32 -- ^ 3 bytes in encoding
+ , sciTxIndex :: {-# UNPACK #-} !Word32 -- ^ 3 bytes in encoding
+ , sciOutputIndex :: {-# UNPACK #-} !Word16 -- ^ 2 bytes in encoding
+ } deriving (Eq, Show, Generic)
+
+-- | Payment data for final hop (TLV type 8).
+data PaymentData = PaymentData
+ { pdPaymentSecret :: !BS.ByteString -- ^ 32 bytes
+ , pdTotalMsat :: {-# UNPACK #-} !Word64
+ } deriving (Eq, Show, Generic)
+
+-- | Generic TLV record for unknown/extension types.
+data TlvRecord = TlvRecord
+ { tlvType :: {-# UNPACK #-} !Word64
+ , tlvValue :: !BS.ByteString
+ } deriving (Eq, Show, Generic)
+
+-- Error types --------------------------------------------------------------
+
+-- | Failure message from intermediate or final node.
+data FailureMessage = FailureMessage
+ { fmCode :: {-# UNPACK #-} !FailureCode
+ , fmData :: !BS.ByteString
+ , fmTlvs :: ![TlvRecord]
+ } deriving (Eq, Show, Generic)
+
+-- | 2-byte failure code with flag bits.
+newtype FailureCode = FailureCode Word16
+ deriving (Eq, Show)
+
+-- Flag bits
+
+-- | BADONION flag (0x8000): error was in parsing the onion.
+pattern BADONION :: Word16
+pattern BADONION = 0x8000
+
+-- | PERM flag (0x4000): permanent failure, do not retry.
+pattern PERM :: Word16
+pattern PERM = 0x4000
+
+-- | NODE flag (0x2000): node failure rather than channel.
+pattern NODE :: Word16
+pattern NODE = 0x2000
+
+-- | UPDATE flag (0x1000): channel update is attached.
+pattern UPDATE :: Word16
+pattern UPDATE = 0x1000
+
+-- Common failure codes
+
+-- | Invalid realm byte in onion.
+pattern InvalidRealm :: FailureCode
+pattern InvalidRealm = FailureCode 0x4001 -- PERM .|. 1
+
+-- | Temporary node failure.
+pattern TemporaryNodeFailure :: FailureCode
+pattern TemporaryNodeFailure = FailureCode 0x2002 -- NODE .|. 2
+
+-- | Permanent node failure.
+pattern PermanentNodeFailure :: FailureCode
+pattern PermanentNodeFailure = FailureCode 0x6002 -- PERM .|. NODE .|. 2
+
+-- | Invalid HMAC in onion.
+pattern InvalidOnionHmac :: FailureCode
+pattern InvalidOnionHmac = FailureCode 0xC005 -- BADONION .|. PERM .|. 5
+
+-- | Invalid ephemeral key in onion.
+pattern InvalidOnionKey :: FailureCode
+pattern InvalidOnionKey = FailureCode 0xC006 -- BADONION .|. PERM .|. 6
+
+-- | Temporary channel failure.
+pattern TemporaryChannelFailure :: FailureCode
+pattern TemporaryChannelFailure = FailureCode 0x1007 -- UPDATE .|. 7
+
+-- | Payment details incorrect or unknown.
+pattern IncorrectOrUnknownPaymentDetails :: FailureCode
+pattern IncorrectOrUnknownPaymentDetails = FailureCode 0x400F -- PERM .|. 15
+
+-- Processing results -------------------------------------------------------
+
+-- | Result of processing an onion packet.
+data ProcessResult
+ = Forward !ForwardInfo -- ^ Forward to next hop
+ | Receive !ReceiveInfo -- ^ Final destination reached
+ deriving (Eq, Show, Generic)
+
+-- | Information for forwarding to next hop.
+data ForwardInfo = ForwardInfo
+ { fiNextPacket :: !OnionPacket
+ , fiPayload :: !HopPayload
+ , fiSharedSecret :: !BS.ByteString -- ^ For error attribution
+ } deriving (Eq, Show, Generic)
+
+-- | Information for receiving at final destination.
+data ReceiveInfo = ReceiveInfo
+ { riPayload :: !HopPayload
+ , riSharedSecret :: !BS.ByteString
+ } deriving (Eq, Show, Generic)
+
+-- Constants ----------------------------------------------------------------
+
+-- | Total onion packet size (1366 bytes).
+onionPacketSize :: Int
+onionPacketSize = 1366
+{-# INLINE onionPacketSize #-}
+
+-- | Hop payloads section size (1300 bytes).
+hopPayloadsSize :: Int
+hopPayloadsSize = 1300
+{-# INLINE hopPayloadsSize #-}
+
+-- | HMAC size (32 bytes).
+hmacSize :: Int
+hmacSize = 32
+{-# INLINE hmacSize #-}
+
+-- | Compressed public key size (33 bytes).
+pubkeySize :: Int
+pubkeySize = 33
+{-# INLINE pubkeySize #-}
+
+-- | Version byte for onion packets.
+versionByte :: Word8
+versionByte = 0x00
+{-# INLINE versionByte #-}
+
+-- | Maximum payload size (1300 - 32 - 1 = 1267 bytes).
+maxPayloadSize :: Int
+maxPayloadSize = hopPayloadsSize - hmacSize - 1
+{-# INLINE maxPayloadSize #-}
+
+-- Silence unused import warning
+_useBits :: Word16
+_useBits = BADONION .&. PERM .|. NODE .|. UPDATE
diff --git a/ppad-bolt4.cabal b/ppad-bolt4.cabal
@@ -24,12 +24,14 @@ library
-Wall
exposed-modules:
Lightning.Protocol.BOLT4
+ Lightning.Protocol.BOLT4.Codec
+ Lightning.Protocol.BOLT4.Types
build-depends:
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
, ppad-chacha >= 0.1 && < 0.2
, ppad-hmac-sha256 >= 0.1 && < 0.2
- , ppad-secp256k1 >= 0.3 && < 0.4
+ , ppad-secp256k1 >= 0.3 && < 0.6
, ppad-sha256 >= 0.3 && < 0.4
test-suite bolt4-tests
diff --git a/test/Main.hs b/test/Main.hs
@@ -2,8 +2,175 @@
module Main where
+import qualified Data.ByteString as BS
+import Lightning.Protocol.BOLT4.Codec
+import Lightning.Protocol.BOLT4.Types
import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
main :: IO ()
main = defaultMain $ testGroup "ppad-bolt4" [
+ testGroup "BigSize" [
+ bigsizeTests
+ , bigsizeRoundtripProp
+ ]
+ , testGroup "TLV" [
+ tlvTests
+ ]
+ , testGroup "ShortChannelId" [
+ sciTests
+ ]
+ , testGroup "OnionPacket" [
+ onionPacketTests
+ ]
+ ]
+
+-- BigSize tests ------------------------------------------------------------
+
+bigsizeTests :: TestTree
+bigsizeTests = testGroup "boundary values" [
+ testCase "0" $
+ encodeBigSize 0 @?= BS.pack [0x00]
+ , testCase "0xFC" $
+ encodeBigSize 0xFC @?= BS.pack [0xFC]
+ , testCase "0xFD" $
+ encodeBigSize 0xFD @?= BS.pack [0xFD, 0x00, 0xFD]
+ , testCase "0xFFFF" $
+ encodeBigSize 0xFFFF @?= BS.pack [0xFD, 0xFF, 0xFF]
+ , testCase "0x10000" $
+ encodeBigSize 0x10000 @?= BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00]
+ , testCase "0xFFFFFFFF" $
+ encodeBigSize 0xFFFFFFFF @?= BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF]
+ , testCase "0x100000000" $
+ encodeBigSize 0x100000000 @?=
+ BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00]
+ , testCase "decode 0" $ do
+ let result = decodeBigSize (BS.pack [0x00])
+ result @?= Just (0, BS.empty)
+ , testCase "decode 0xFC" $ do
+ let result = decodeBigSize (BS.pack [0xFC])
+ result @?= Just (0xFC, BS.empty)
+ , testCase "decode 0xFD" $ do
+ let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFD])
+ result @?= Just (0xFD, BS.empty)
+ , testCase "decode 0xFFFF" $ do
+ let result = decodeBigSize (BS.pack [0xFD, 0xFF, 0xFF])
+ result @?= Just (0xFFFF, BS.empty)
+ , testCase "decode 0x10000" $ do
+ let result = decodeBigSize (BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00])
+ result @?= Just (0x10000, BS.empty)
+ , testCase "decode 0xFFFFFFFF" $ do
+ let result = decodeBigSize (BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF])
+ result @?= Just (0xFFFFFFFF, BS.empty)
+ , testCase "decode 0x100000000" $ do
+ let result = decodeBigSize $
+ BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00]
+ result @?= Just (0x100000000, BS.empty)
+ , testCase "reject non-canonical 0xFD encoding of small value" $ do
+ -- 0x00FC encoded as 0xFD 0x00 0xFC should be rejected
+ let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFC])
+ result @?= Nothing
+ , testCase "reject non-canonical 0xFE encoding of small value" $ do
+ -- 0x0000FFFF encoded with 0xFE should be rejected
+ let result = decodeBigSize (BS.pack [0xFE, 0x00, 0x00, 0xFF, 0xFF])
+ result @?= Nothing
+ , testCase "bigSizeLen" $ do
+ bigSizeLen 0 @?= 1
+ bigSizeLen 0xFC @?= 1
+ bigSizeLen 0xFD @?= 3
+ bigSizeLen 0xFFFF @?= 3
+ bigSizeLen 0x10000 @?= 5
+ bigSizeLen 0xFFFFFFFF @?= 5
+ bigSizeLen 0x100000000 @?= 9
+ ]
+
+bigsizeRoundtripProp :: TestTree
+bigsizeRoundtripProp = testProperty "roundtrip" $ \n ->
+ let encoded = encodeBigSize n
+ decoded = decodeBigSize encoded
+ in decoded == Just (n, BS.empty)
+
+-- TLV tests ----------------------------------------------------------------
+
+tlvTests :: TestTree
+tlvTests = testGroup "encoding/decoding" [
+ testCase "single record" $ do
+ let rec = TlvRecord 2 (BS.pack [0x01, 0x02, 0x03])
+ encoded = encodeTlv rec
+ decoded = decodeTlv encoded
+ decoded @?= Just (rec, BS.empty)
+ , testCase "stream roundtrip" $ do
+ let recs = [ TlvRecord 2 (BS.pack [0x01])
+ , TlvRecord 4 (BS.pack [0x02, 0x03])
+ , TlvRecord 100 (BS.pack [0x04, 0x05, 0x06])
+ ]
+ encoded = encodeTlvStream recs
+ decoded = decodeTlvStream encoded
+ decoded @?= Just recs
+ , testCase "reject out-of-order types" $ do
+ -- Manually construct out-of-order stream
+ let rec1 = encodeTlv (TlvRecord 4 (BS.pack [0x01]))
+ rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02]))
+ badStream = rec1 <> rec2
+ decoded = decodeTlvStream badStream
+ decoded @?= Nothing
+ , testCase "reject duplicate types" $ do
+ let rec1 = encodeTlv (TlvRecord 2 (BS.pack [0x01]))
+ rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02]))
+ badStream = rec1 <> rec2
+ decoded = decodeTlvStream badStream
+ decoded @?= Nothing
+ , testCase "empty stream" $ do
+ let decoded = decodeTlvStream BS.empty
+ decoded @?= Just []
+ ]
+
+-- ShortChannelId tests -----------------------------------------------------
+
+sciTests :: TestTree
+sciTests = testGroup "encoding/decoding" [
+ testCase "known value" $ do
+ let sci = ShortChannelId 700000 1234 5
+ encoded = encodeShortChannelId sci
+ BS.length encoded @?= 8
+ let decoded = decodeShortChannelId encoded
+ decoded @?= Just sci
+ , testCase "maximum values" $ do
+ -- Max 3-byte block (0xFFFFFF), max 3-byte tx (0xFFFFFF), max output
+ let sci = ShortChannelId 0xFFFFFF 0xFFFFFF 0xFFFF
+ encoded = encodeShortChannelId sci
+ BS.length encoded @?= 8
+ let decoded = decodeShortChannelId encoded
+ decoded @?= Just sci
+ , testCase "zero values" $ do
+ let sci = ShortChannelId 0 0 0
+ encoded = encodeShortChannelId sci
+ expected = BS.pack [0, 0, 0, 0, 0, 0, 0, 0]
+ encoded @?= expected
+ let decoded = decodeShortChannelId encoded
+ decoded @?= Just sci
+ , testCase "reject wrong length" $ do
+ let decoded = decodeShortChannelId (BS.pack [0, 1, 2, 3, 4, 5, 6])
+ decoded @?= Nothing
+ ]
+
+-- OnionPacket tests --------------------------------------------------------
+
+onionPacketTests :: TestTree
+onionPacketTests = testGroup "encoding/decoding" [
+ testCase "roundtrip" $ do
+ let packet = OnionPacket
+ { opVersion = 0x00
+ , opEphemeralKey = BS.replicate 33 0xAB
+ , opHopPayloads = BS.replicate 1300 0xCD
+ , opHmac = BS.replicate 32 0xEF
+ }
+ encoded = encodeOnionPacket packet
+ BS.length encoded @?= onionPacketSize
+ let decoded = decodeOnionPacket encoded
+ decoded @?= Just packet
+ , testCase "reject wrong size" $ do
+ let decoded = decodeOnionPacket (BS.replicate 1000 0x00)
+ decoded @?= Nothing
]
