commit 52bc65a98228e7aa10cb047dd2131a1943b64dad
parent 6f3327fe2856fded5511e8f8db21a44361d4c8c5
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 25 Jan 2026 15:36:28 +0400
ppad-bolt4: implement error handling (IMPL5)
Add Error module for constructing, wrapping, and unwrapping error
packets per BOLT4 spec. Error packets are at least 256 bytes and
use HMAC-SHA256 for authentication and ChaCha20-based obfuscation.
Key additions:
- ErrorPacket newtype for wrapped error packets
- AttributionResult type for unwrap results
- constructError: create error at failing node
- wrapError: add obfuscation layer at intermediate node
- unwrapError: peel layers and attribute error to hop
Also adds missing failure codes to Types.hs and comprehensive tests
for error construction, multi-hop wrapping, and attribution.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
Diffstat:
4 files changed, 459 insertions(+), 0 deletions(-)
diff --git a/lib/Lightning/Protocol/BOLT4/Error.hs b/lib/Lightning/Protocol/BOLT4/Error.hs
@@ -0,0 +1,223 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Lightning.Protocol.BOLT4.Error
+-- Copyright: (c) 2025 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- Error packet construction and unwrapping for BOLT4 onion routing.
+--
+-- Failing nodes construct error packets that are wrapped at each
+-- intermediate hop on the return path. The origin node unwraps
+-- layers to attribute the error to a specific hop.
+
+module Lightning.Protocol.BOLT4.Error (
+ -- * Types
+ ErrorPacket(..)
+ , AttributionResult(..)
+ , minErrorPacketSize
+
+ -- * Error construction (failing node)
+ , constructError
+
+ -- * Error forwarding (intermediate node)
+ , wrapError
+
+ -- * Error unwrapping (origin node)
+ , unwrapError
+ ) where
+
+import Data.Bits (xor)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Crypto.Hash.SHA256 as SHA256
+import Data.Word (Word8, Word16)
+import Lightning.Protocol.BOLT4.Codec (encodeFailureMessage, decodeFailureMessage)
+import Lightning.Protocol.BOLT4.Prim
+import Lightning.Protocol.BOLT4.Types (FailureMessage)
+
+-- | Wrapped error packet ready for return to origin.
+newtype ErrorPacket = ErrorPacket BS.ByteString
+ deriving (Eq, Show)
+
+-- | Result of error attribution.
+data AttributionResult
+ = Attributed {-# UNPACK #-} !Int !FailureMessage
+ -- ^ (hop index, failure)
+ | UnknownOrigin !BS.ByteString
+ -- ^ Could not attribute to any hop
+ deriving (Eq, Show)
+
+-- | Minimum error packet size (256 bytes per spec).
+minErrorPacketSize :: Int
+minErrorPacketSize = 256
+{-# INLINE minErrorPacketSize #-}
+
+-- Error construction ---------------------------------------------------------
+
+-- | Construct an error packet at a failing node.
+--
+-- Takes the shared secret (from processing) and failure message,
+-- and wraps it for return to origin.
+constructError
+ :: SharedSecret -- ^ from packet processing
+ -> FailureMessage -- ^ failure details
+ -> ErrorPacket
+constructError !ss !failure =
+ let !um = deriveUm ss
+ !ammag = deriveAmmag ss
+ !inner = buildErrorMessage um failure
+ !obfuscated = obfuscateError ammag inner
+ in ErrorPacket obfuscated
+{-# INLINE constructError #-}
+
+-- | Wrap an existing error packet for forwarding back.
+--
+-- Each intermediate node wraps the error with its own layer.
+wrapError
+ :: SharedSecret -- ^ this node's shared secret
+ -> ErrorPacket -- ^ error from downstream
+ -> ErrorPacket
+wrapError !ss (ErrorPacket !packet) =
+ let !ammag = deriveAmmag ss
+ !wrapped = obfuscateError ammag packet
+ in ErrorPacket wrapped
+{-# INLINE wrapError #-}
+
+-- Error unwrapping -----------------------------------------------------------
+
+-- | Attempt to attribute an error to a specific hop.
+--
+-- Takes the shared secrets from original packet construction
+-- (in order from first hop to final) and the error packet.
+--
+-- Tries each hop's keys until HMAC verifies, revealing origin.
+unwrapError
+ :: [SharedSecret] -- ^ secrets from construction, in route order
+ -> ErrorPacket -- ^ received error
+ -> AttributionResult
+unwrapError secrets (ErrorPacket !initialPacket) = go 0 initialPacket secrets
+ where
+ go :: Int -> BS.ByteString -> [SharedSecret] -> AttributionResult
+ go !_ !packet [] = UnknownOrigin packet
+ go !idx !packet (ss:rest) =
+ let !ammag = deriveAmmag ss
+ !um = deriveUm ss
+ !deobfuscated = deobfuscateError ammag packet
+ in if verifyErrorHmac um deobfuscated
+ then case parseErrorMessage (BS.drop 32 deobfuscated) of
+ Just msg -> Attributed idx msg
+ Nothing -> UnknownOrigin deobfuscated
+ else go (idx + 1) deobfuscated rest
+
+-- Internal functions ---------------------------------------------------------
+
+-- | Build the inner error message structure.
+--
+-- Format: HMAC (32) || len (2) || message || pad_len (2) || padding
+-- Total must be >= 256 bytes.
+buildErrorMessage
+ :: DerivedKey -- ^ um key
+ -> FailureMessage -- ^ failure to encode
+ -> BS.ByteString -- ^ complete message with HMAC
+buildErrorMessage (DerivedKey !umKey) !failure =
+ let !encoded = encodeFailureMessage failure
+ !msgLen = BS.length encoded
+ -- Total payload: len(2) + msg + pad_len(2) + padding = 256 - 32 = 224
+ -- padding = 224 - 2 - msgLen - 2 = 220 - msgLen
+ !padLen = max 0 (minErrorPacketSize - 32 - 2 - msgLen - 2)
+ !padding = BS.replicate padLen 0
+ -- Build: len || message || pad_len || padding
+ !payload = toStrict $
+ B.word16BE (fromIntegral msgLen) <>
+ B.byteString encoded <>
+ B.word16BE (fromIntegral padLen) <>
+ B.byteString padding
+ -- HMAC over the payload
+ SHA256.MAC !hmac = SHA256.hmac umKey payload
+ in hmac <> payload
+{-# INLINE buildErrorMessage #-}
+
+-- | Obfuscate error packet with ammag stream.
+--
+-- XORs the entire packet with pseudo-random stream.
+obfuscateError
+ :: DerivedKey -- ^ ammag key
+ -> BS.ByteString -- ^ error packet
+ -> BS.ByteString -- ^ obfuscated packet
+obfuscateError !ammag !packet =
+ let !stream = generateStream ammag (BS.length packet)
+ in xorBytes packet stream
+{-# INLINE obfuscateError #-}
+
+-- | Remove one layer of obfuscation from error packet.
+--
+-- XOR is its own inverse, so same as obfuscation.
+deobfuscateError
+ :: DerivedKey -- ^ ammag key
+ -> BS.ByteString -- ^ obfuscated packet
+ -> BS.ByteString -- ^ deobfuscated packet
+deobfuscateError = obfuscateError
+{-# INLINE deobfuscateError #-}
+
+-- | Verify error HMAC after deobfuscation.
+verifyErrorHmac
+ :: DerivedKey -- ^ um key
+ -> BS.ByteString -- ^ deobfuscated packet (HMAC || rest)
+ -> Bool
+verifyErrorHmac (DerivedKey !umKey) !packet
+ | BS.length packet < 32 = False
+ | otherwise =
+ let !receivedHmac = BS.take 32 packet
+ !payload = BS.drop 32 packet
+ SHA256.MAC !computedHmac = SHA256.hmac umKey payload
+ in constantTimeEq receivedHmac computedHmac
+{-# INLINE verifyErrorHmac #-}
+
+-- | Parse error message from deobfuscated packet (after HMAC).
+parseErrorMessage
+ :: BS.ByteString -- ^ packet after HMAC (len || msg || pad_len || pad)
+ -> Maybe FailureMessage
+parseErrorMessage !bs
+ | BS.length bs < 4 = Nothing
+ | otherwise =
+ let !msgLen = fromIntegral (word16BE (BS.take 2 bs))
+ in if BS.length bs < 2 + msgLen
+ then Nothing
+ else decodeFailureMessage (BS.take msgLen (BS.drop 2 bs))
+{-# INLINE parseErrorMessage #-}
+
+-- Helper functions -----------------------------------------------------------
+
+-- | XOR two ByteStrings of equal length.
+xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString
+xorBytes !a !b = BS.pack $ BS.zipWith xor a b
+{-# INLINE xorBytes #-}
+
+-- | Constant-time equality comparison.
+constantTimeEq :: BS.ByteString -> BS.ByteString -> Bool
+constantTimeEq !a !b
+ | BS.length a /= BS.length b = False
+ | otherwise = go 0 (BS.zip a b)
+ where
+ go :: Word8 -> [(Word8, Word8)] -> Bool
+ go !acc [] = acc == 0
+ go !acc ((x, y):rest) = go (acc `xor` (x `xor` y)) rest
+{-# INLINE constantTimeEq #-}
+
+-- | 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 * 256) + b1
+{-# INLINE word16BE #-}
+
+-- | Convert Builder to strict ByteString.
+toStrict :: B.Builder -> BS.ByteString
+toStrict = BL.toStrict . B.toLazyByteString
+{-# INLINE toStrict #-}
diff --git a/lib/Lightning/Protocol/BOLT4/Types.hs b/lib/Lightning/Protocol/BOLT4/Types.hs
@@ -31,10 +31,23 @@ module Lightning.Protocol.BOLT4.Types (
, pattern InvalidRealm
, pattern TemporaryNodeFailure
, pattern PermanentNodeFailure
+ , pattern RequiredNodeFeatureMissing
+ , pattern InvalidOnionVersion
, pattern InvalidOnionHmac
, pattern InvalidOnionKey
, pattern TemporaryChannelFailure
+ , pattern PermanentChannelFailure
+ , pattern AmountBelowMinimum
+ , pattern FeeInsufficient
+ , pattern IncorrectCltvExpiry
+ , pattern ExpiryTooSoon
, pattern IncorrectOrUnknownPaymentDetails
+ , pattern FinalIncorrectCltvExpiry
+ , pattern FinalIncorrectHtlcAmount
+ , pattern ChannelDisabled
+ , pattern ExpiryTooFar
+ , pattern InvalidOnionPayload
+ , pattern MppTimeout
-- * Processing results
, ProcessResult(..)
@@ -140,6 +153,14 @@ pattern TemporaryNodeFailure = FailureCode 0x2002 -- NODE .|. 2
pattern PermanentNodeFailure :: FailureCode
pattern PermanentNodeFailure = FailureCode 0x6002 -- PERM .|. NODE .|. 2
+-- | Required node feature missing.
+pattern RequiredNodeFeatureMissing :: FailureCode
+pattern RequiredNodeFeatureMissing = FailureCode 0x6003 -- PERM .|. NODE .|. 3
+
+-- | Invalid onion version.
+pattern InvalidOnionVersion :: FailureCode
+pattern InvalidOnionVersion = FailureCode 0xC004 -- BADONION .|. PERM .|. 4
+
-- | Invalid HMAC in onion.
pattern InvalidOnionHmac :: FailureCode
pattern InvalidOnionHmac = FailureCode 0xC005 -- BADONION .|. PERM .|. 5
@@ -152,10 +173,54 @@ pattern InvalidOnionKey = FailureCode 0xC006 -- BADONION .|. PERM .|. 6
pattern TemporaryChannelFailure :: FailureCode
pattern TemporaryChannelFailure = FailureCode 0x1007 -- UPDATE .|. 7
+-- | Permanent channel failure.
+pattern PermanentChannelFailure :: FailureCode
+pattern PermanentChannelFailure = FailureCode 0x4008 -- PERM .|. 8
+
+-- | Amount below minimum for channel.
+pattern AmountBelowMinimum :: FailureCode
+pattern AmountBelowMinimum = FailureCode 0x100B -- UPDATE .|. 11
+
+-- | Fee insufficient.
+pattern FeeInsufficient :: FailureCode
+pattern FeeInsufficient = FailureCode 0x100C -- UPDATE .|. 12
+
+-- | Incorrect CLTV expiry.
+pattern IncorrectCltvExpiry :: FailureCode
+pattern IncorrectCltvExpiry = FailureCode 0x100D -- UPDATE .|. 13
+
+-- | Expiry too soon.
+pattern ExpiryTooSoon :: FailureCode
+pattern ExpiryTooSoon = FailureCode 0x100E -- UPDATE .|. 14
+
-- | Payment details incorrect or unknown.
pattern IncorrectOrUnknownPaymentDetails :: FailureCode
pattern IncorrectOrUnknownPaymentDetails = FailureCode 0x400F -- PERM .|. 15
+-- | Final incorrect CLTV expiry.
+pattern FinalIncorrectCltvExpiry :: FailureCode
+pattern FinalIncorrectCltvExpiry = FailureCode 18 -- 0x12
+
+-- | Final incorrect HTLC amount.
+pattern FinalIncorrectHtlcAmount :: FailureCode
+pattern FinalIncorrectHtlcAmount = FailureCode 19 -- 0x13
+
+-- | Channel disabled.
+pattern ChannelDisabled :: FailureCode
+pattern ChannelDisabled = FailureCode 0x1014 -- UPDATE .|. 20
+
+-- | Expiry too far.
+pattern ExpiryTooFar :: FailureCode
+pattern ExpiryTooFar = FailureCode 21 -- 0x15
+
+-- | Invalid onion payload.
+pattern InvalidOnionPayload :: FailureCode
+pattern InvalidOnionPayload = FailureCode 0x4016 -- PERM .|. 22
+
+-- | MPP timeout.
+pattern MppTimeout :: FailureCode
+pattern MppTimeout = FailureCode 23 -- 0x17
+
-- Processing results -------------------------------------------------------
-- | Result of processing an onion packet.
diff --git a/ppad-bolt4.cabal b/ppad-bolt4.cabal
@@ -25,6 +25,7 @@ library
exposed-modules:
Lightning.Protocol.BOLT4
Lightning.Protocol.BOLT4.Codec
+ Lightning.Protocol.BOLT4.Error
Lightning.Protocol.BOLT4.Prim
Lightning.Protocol.BOLT4.Types
build-depends:
diff --git a/test/Main.hs b/test/Main.hs
@@ -6,6 +6,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Crypto.Curve.Secp256k1 as Secp256k1
import Lightning.Protocol.BOLT4.Codec
+import Lightning.Protocol.BOLT4.Error
import Lightning.Protocol.BOLT4.Prim
import Lightning.Protocol.BOLT4.Types
import Test.Tasty
@@ -30,6 +31,9 @@ main = defaultMain $ testGroup "ppad-bolt4" [
, testGroup "OnionPacket" [
onionPacketTests
]
+ , testGroup "Error" [
+ errorTests
+ ]
]
-- BigSize tests ------------------------------------------------------------
@@ -321,3 +325,169 @@ testHmacOperations = testGroup "HMAC operations" [
assertBool "verifyHmac should fail"
(not $ verifyHmac "short" "different length")
]
+
+-- Error tests -----------------------------------------------------------------
+
+errorTests :: TestTree
+errorTests = testGroup "error handling" [
+ testErrorConstruction
+ , testErrorRoundtrip
+ , testMultiHopWrapping
+ , testErrorAttribution
+ , testFailureMessageParsing
+ ]
+
+-- Shared secrets for testing (deterministic)
+testSecret1 :: SharedSecret
+testSecret1 = SharedSecret (BS.replicate 32 0x11)
+
+testSecret2 :: SharedSecret
+testSecret2 = SharedSecret (BS.replicate 32 0x22)
+
+testSecret3 :: SharedSecret
+testSecret3 = SharedSecret (BS.replicate 32 0x33)
+
+testSecret4 :: SharedSecret
+testSecret4 = SharedSecret (BS.replicate 32 0x44)
+
+-- Simple failure message for testing
+testFailure :: FailureMessage
+testFailure = FailureMessage IncorrectOrUnknownPaymentDetails BS.empty []
+
+testErrorConstruction :: TestTree
+testErrorConstruction = testCase "error packet construction" $ do
+ let errPacket = constructError testSecret1 testFailure
+ ErrorPacket bs = errPacket
+ -- Error packet should be at least minErrorPacketSize
+ assertBool "error packet >= 256 bytes" (BS.length bs >= minErrorPacketSize)
+
+testErrorRoundtrip :: TestTree
+testErrorRoundtrip = testCase "construct and unwrap roundtrip" $ do
+ let errPacket = constructError testSecret1 testFailure
+ result = unwrapError [testSecret1] errPacket
+ case result of
+ Attributed idx msg -> do
+ idx @?= 0
+ fmCode msg @?= IncorrectOrUnknownPaymentDetails
+ UnknownOrigin _ ->
+ assertFailure "Expected Attributed, got UnknownOrigin"
+
+testMultiHopWrapping :: TestTree
+testMultiHopWrapping = testGroup "multi-hop wrapping" [
+ testCase "3-hop route, error from hop 2 (final)" $ do
+ -- Route: origin -> hop0 -> hop1 -> hop2 (final, fails)
+ -- Error constructed at hop2, wrapped at hop1, wrapped at hop0
+ let secrets = [testSecret1, testSecret2, testSecret3]
+ -- Hop 2 constructs error
+ err0 = constructError testSecret3 testFailure
+ -- Hop 1 wraps
+ err1 = wrapError testSecret2 err0
+ -- Hop 0 wraps
+ err2 = wrapError testSecret1 err1
+ -- Origin unwraps
+ result = unwrapError secrets err2
+ case result of
+ Attributed idx msg -> do
+ idx @?= 2
+ fmCode msg @?= IncorrectOrUnknownPaymentDetails
+ UnknownOrigin _ ->
+ assertFailure "Expected Attributed, got UnknownOrigin"
+
+ , testCase "4-hop route, error from hop 1 (intermediate)" $ do
+ -- Route: origin -> hop0 -> hop1 (fails) -> hop2 -> hop3
+ let secrets = [testSecret1, testSecret2, testSecret3, testSecret4]
+ -- Hop 1 constructs error
+ err0 = constructError testSecret2 testFailure
+ -- Hop 0 wraps
+ err1 = wrapError testSecret1 err0
+ -- Origin unwraps
+ result = unwrapError secrets err1
+ case result of
+ Attributed idx msg -> do
+ idx @?= 1
+ fmCode msg @?= IncorrectOrUnknownPaymentDetails
+ UnknownOrigin _ ->
+ assertFailure "Expected Attributed, got UnknownOrigin"
+
+ , testCase "4-hop route, error from hop 0 (first)" $ do
+ let secrets = [testSecret1, testSecret2, testSecret3, testSecret4]
+ -- Hop 0 constructs error (no wrapping needed)
+ err0 = constructError testSecret1 testFailure
+ -- Origin unwraps
+ result = unwrapError secrets err0
+ case result of
+ Attributed idx msg -> do
+ idx @?= 0
+ fmCode msg @?= IncorrectOrUnknownPaymentDetails
+ UnknownOrigin _ ->
+ assertFailure "Expected Attributed, got UnknownOrigin"
+ ]
+
+testErrorAttribution :: TestTree
+testErrorAttribution = testGroup "error attribution" [
+ testCase "wrong secrets gives UnknownOrigin" $ do
+ let err = constructError testSecret1 testFailure
+ wrongSecrets = [testSecret2, testSecret3]
+ result = unwrapError wrongSecrets err
+ case result of
+ UnknownOrigin _ -> return ()
+ Attributed _ _ ->
+ assertFailure "Expected UnknownOrigin with wrong secrets"
+
+ , testCase "empty secrets gives UnknownOrigin" $ do
+ let err = constructError testSecret1 testFailure
+ result = unwrapError [] err
+ case result of
+ UnknownOrigin _ -> return ()
+ Attributed _ _ ->
+ assertFailure "Expected UnknownOrigin with empty secrets"
+
+ , testCase "correct attribution with multiple failures" $ do
+ -- Test different failure codes
+ let failures =
+ [ (TemporaryNodeFailure, testSecret1)
+ , (PermanentNodeFailure, testSecret2)
+ , (InvalidOnionHmac, testSecret3)
+ ]
+ mapM_ (\(code, secret) -> do
+ let failure = FailureMessage code BS.empty []
+ err = constructError secret failure
+ result = unwrapError [secret] err
+ case result of
+ Attributed 0 msg -> fmCode msg @?= code
+ _ -> assertFailure $ "Failed for code: " ++ show code
+ ) failures
+ ]
+
+testFailureMessageParsing :: TestTree
+testFailureMessageParsing = testGroup "failure message parsing" [
+ testCase "code with data" $ do
+ -- AmountBelowMinimum typically includes channel update data
+ let failData = BS.replicate 10 0xAB
+ failure = FailureMessage AmountBelowMinimum failData []
+ err = constructError testSecret1 failure
+ result = unwrapError [testSecret1] err
+ case result of
+ Attributed 0 msg -> do
+ fmCode msg @?= AmountBelowMinimum
+ fmData msg @?= failData
+ _ -> assertFailure "Expected Attributed"
+
+ , testCase "various failure codes roundtrip" $ do
+ let codes =
+ [ InvalidRealm
+ , TemporaryNodeFailure
+ , PermanentNodeFailure
+ , InvalidOnionHmac
+ , TemporaryChannelFailure
+ , IncorrectOrUnknownPaymentDetails
+ ]
+ mapM_ (\code -> do
+ let failure = FailureMessage code BS.empty []
+ err = constructError testSecret1 failure
+ result = unwrapError [testSecret1] err
+ case result of
+ Attributed 0 msg -> fmCode msg @?= code
+ _ -> assertFailure $ "Failed for code: " ++ show code
+ ) codes
+ ]
