ppad-bolt4 (empty) → 0.0.1

raw patch · 14 files changed

+3279/−0 lines, 14 filesdep +basedep +bytestringdep +criterion

Dependencies added: base, bytestring, criterion, deepseq, ppad-aead, ppad-base16, ppad-bolt4, ppad-chacha, ppad-fixed, ppad-secp256k1, ppad-sha256, tasty, tasty-hunit, tasty-quickcheck, weigh

Files

• CHANGELOG +4/−0
• LICENSE +20/−0
• bench/Main.hs +10/−0
• bench/Weight.hs +9/−0
• lib/Lightning/Protocol/BOLT4.hs +24/−0
• lib/Lightning/Protocol/BOLT4/Blinding.hs +391/−0
• lib/Lightning/Protocol/BOLT4/Codec.hs +387/−0
• lib/Lightning/Protocol/BOLT4/Construct.hs +212/−0
• lib/Lightning/Protocol/BOLT4/Error.hs +223/−0
• lib/Lightning/Protocol/BOLT4/Prim.hs +226/−0
• lib/Lightning/Protocol/BOLT4/Process.hs +220/−0
• lib/Lightning/Protocol/BOLT4/Types.hs +279/−0
• ppad-bolt4.cabal +86/−0
• test/Main.hs +1188/−0

@@ -0,0 +1,4 @@+# Changelog++- 0.0.1 (UNRELEASED)+  * Initial release.

@@ -0,0 +1,20 @@+Copyright (c) 2025 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,10 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Criterion.Main++main :: IO ()+main = defaultMain [+  ]

@@ -0,0 +1,9 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Weigh++main :: IO ()+main = mainWith (pure ())

@@ -0,0 +1,24 @@+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Module: Lightning.Protocol.BOLT4+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- BOLT4 onion routing for the Lightning Network.+--+-- This module re-exports the public interface from submodules.++module Lightning.Protocol.BOLT4 (+    -- * Re-exports+    module Lightning.Protocol.BOLT4.Blinding+  , module Lightning.Protocol.BOLT4.Codec+  , module Lightning.Protocol.BOLT4.Prim+  , module Lightning.Protocol.BOLT4.Types+  ) where++import Lightning.Protocol.BOLT4.Blinding+import Lightning.Protocol.BOLT4.Codec+import Lightning.Protocol.BOLT4.Prim+import Lightning.Protocol.BOLT4.Types

@@ -0,0 +1,391 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Lightning.Protocol.BOLT4.Blinding+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Route blinding for BOLT4 onion routing.++module Lightning.Protocol.BOLT4.Blinding (+    -- * Types+    BlindedPath(..)+  , BlindedHop(..)+  , BlindedHopData(..)+  , PaymentRelay(..)+  , PaymentConstraints(..)+  , BlindingError(..)++    -- * Path creation+  , createBlindedPath++    -- * Hop processing+  , processBlindedHop++    -- * Key derivation (exported for testing)+  , deriveBlindingRho+  , deriveBlindedNodeId+  , nextEphemeral++    -- * TLV encoding (exported for testing)+  , encodeBlindedHopData+  , decodeBlindedHopData++    -- * Encryption (exported for testing)+  , encryptHopData+  , decryptHopData+  ) where++import qualified Crypto.AEAD.ChaCha20Poly1305 as AEAD+import qualified Crypto.Curve.Secp256k1 as Secp256k1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B+import Data.Word (Word16, Word32, Word64)+import qualified Numeric.Montgomery.Secp256k1.Scalar as S+import Lightning.Protocol.BOLT4.Codec+  ( encodeShortChannelId, decodeShortChannelId+  , encodeTlvStream, decodeTlvStream+  , toStrict, word16BE, word32BE+  , encodeWord64TU, decodeWord64TU+  , encodeWord32TU, decodeWord32TU+  )+import Lightning.Protocol.BOLT4.Prim (SharedSecret(..), DerivedKey(..))+import Lightning.Protocol.BOLT4.Types (ShortChannelId(..), TlvRecord(..))++-- Types ---------------------------------------------------------------------++-- | A blinded route provided by recipient.+data BlindedPath = BlindedPath+  { bpIntroductionNode :: !Secp256k1.Projective  -- ^ First node (unblinded)+  , bpBlindingKey      :: !Secp256k1.Projective  -- ^ E_0, initial ephemeral+  , bpBlindedHops      :: ![BlindedHop]+  } deriving (Eq, Show)++-- | A single hop in a blinded path.+data BlindedHop = BlindedHop+  { bhBlindedNodeId :: !BS.ByteString  -- ^ 33 bytes, blinded pubkey+  , bhEncryptedData :: !BS.ByteString  -- ^ Encrypted routing data+  } deriving (Eq, Show)++-- | Data encrypted for each blinded hop (before encryption).+data BlindedHopData = BlindedHopData+  { bhdPadding             :: !(Maybe BS.ByteString)  -- ^ TLV 1+  , bhdShortChannelId      :: !(Maybe ShortChannelId) -- ^ TLV 2+  , bhdNextNodeId          :: !(Maybe BS.ByteString)  -- ^ TLV 4, 33-byte pubkey+  , bhdPathId              :: !(Maybe BS.ByteString)  -- ^ TLV 6+  , bhdNextPathKeyOverride :: !(Maybe BS.ByteString)  -- ^ TLV 8+  , bhdPaymentRelay        :: !(Maybe PaymentRelay)   -- ^ TLV 10+  , bhdPaymentConstraints  :: !(Maybe PaymentConstraints) -- ^ TLV 12+  , bhdAllowedFeatures     :: !(Maybe BS.ByteString)  -- ^ TLV 14+  } deriving (Eq, Show)++-- | Payment relay parameters (TLV 10).+data PaymentRelay = PaymentRelay+  { prCltvExpiryDelta  :: {-# UNPACK #-} !Word16+  , prFeeProportional  :: {-# UNPACK #-} !Word32  -- ^ Fee in millionths+  , prFeeBaseMsat      :: {-# UNPACK #-} !Word32+  } deriving (Eq, Show)++-- | Payment constraints (TLV 12).+data PaymentConstraints = PaymentConstraints+  { pcMaxCltvExpiry   :: {-# UNPACK #-} !Word32+  , pcHtlcMinimumMsat :: {-# UNPACK #-} !Word64+  } deriving (Eq, Show)++-- | Errors during blinding operations.+data BlindingError+  = InvalidSeed+  | EmptyPath+  | InvalidNodeKey Int+  | DecryptionFailed+  | InvalidPathKey+  deriving (Eq, Show)++-- Key derivation ------------------------------------------------------------++-- | Derive rho key for encrypting hop data.+--+-- @rho = HMAC-SHA256(key="rho", data=shared_secret)@+deriveBlindingRho :: SharedSecret -> DerivedKey+deriveBlindingRho (SharedSecret !ss) =+  let SHA256.MAC !result = SHA256.hmac "rho" ss+  in  DerivedKey result+{-# INLINE deriveBlindingRho #-}++-- | Derive blinded node ID from shared secret and node pubkey.+--+-- @B_i = HMAC256("blinded_node_id", ss_i) * N_i@+deriveBlindedNodeId+  :: SharedSecret+  -> Secp256k1.Projective+  -> Maybe BS.ByteString+deriveBlindedNodeId (SharedSecret !ss) !nodePub = do+  let SHA256.MAC !hmacResult = SHA256.hmac "blinded_node_id" ss+  sk <- Secp256k1.roll32 hmacResult+  blindedPub <- Secp256k1.mul nodePub sk+  pure $! Secp256k1.serialize_point blindedPub+{-# INLINE deriveBlindedNodeId #-}++-- | Compute next ephemeral key pair.+--+-- @e_{i+1} = SHA256(E_i || ss_i) * e_i@+-- @E_{i+1} = SHA256(E_i || ss_i) * E_i@+nextEphemeral+  :: BS.ByteString        -- ^ e_i (32-byte secret key)+  -> Secp256k1.Projective -- ^ E_i+  -> SharedSecret         -- ^ ss_i+  -> Maybe (BS.ByteString, Secp256k1.Projective)  -- ^ (e_{i+1}, E_{i+1})+nextEphemeral !secKey !pubKey (SharedSecret !ss) = do+  let !pubBytes = Secp256k1.serialize_point pubKey+      !blindingFactor = SHA256.hash (pubBytes <> ss)+  bfInt <- Secp256k1.roll32 blindingFactor+  -- Compute e_{i+1} = e_i * blindingFactor (mod q)+  let !newSecKey = mulSecKey secKey blindingFactor+  -- Compute E_{i+1} = E_i * blindingFactor+  newPubKey <- Secp256k1.mul pubKey bfInt+  pure (newSecKey, newPubKey)+{-# INLINE nextEphemeral #-}++-- | Compute blinding factor for next path key (public key only).+nextPathKey+  :: Secp256k1.Projective -- ^ E_i+  -> SharedSecret         -- ^ ss_i+  -> Maybe Secp256k1.Projective  -- ^ E_{i+1}+nextPathKey !pubKey (SharedSecret !ss) = do+  let !pubBytes = Secp256k1.serialize_point pubKey+      !blindingFactor = SHA256.hash (pubBytes <> ss)+  bfInt <- Secp256k1.roll32 blindingFactor+  Secp256k1.mul pubKey bfInt+{-# INLINE nextPathKey #-}++-- Encryption/Decryption -----------------------------------------------------++-- | Encrypt hop data with ChaCha20-Poly1305.+--+-- Uses rho key and 12-byte zero nonce, empty AAD.+encryptHopData :: DerivedKey -> BlindedHopData -> BS.ByteString+encryptHopData (DerivedKey !rho) !hopData =+  let !plaintext = encodeBlindedHopData hopData+      !nonce = BS.replicate 12 0+  in  case AEAD.encrypt BS.empty rho nonce plaintext of+        Left e -> error $ "encryptHopData: unexpected AEAD error: " ++ show e+        Right (!ciphertext, !mac) -> ciphertext <> mac+{-# INLINE encryptHopData #-}++-- | Decrypt hop data with ChaCha20-Poly1305.+decryptHopData :: DerivedKey -> BS.ByteString -> Maybe BlindedHopData+decryptHopData (DerivedKey !rho) !encData+  | BS.length encData < 16 = Nothing+  | otherwise = do+      let !ciphertext = BS.take (BS.length encData - 16) encData+          !mac = BS.drop (BS.length encData - 16) encData+          !nonce = BS.replicate 12 0+      case AEAD.decrypt BS.empty rho nonce (ciphertext, mac) of+        Left _ -> Nothing+        Right !plaintext -> decodeBlindedHopData plaintext+{-# INLINE decryptHopData #-}++-- TLV Encoding/Decoding -----------------------------------------------------++-- | Encode BlindedHopData to TLV stream.+encodeBlindedHopData :: BlindedHopData -> BS.ByteString+encodeBlindedHopData !bhd = encodeTlvStream (buildTlvs bhd)+  where+    buildTlvs :: BlindedHopData -> [TlvRecord]+    buildTlvs (BlindedHopData pad sci nid pid pko pr pc af) =+      let pad'  = maybe [] (\p -> [TlvRecord 1 p]) pad+          sci'  = maybe [] (\s -> [TlvRecord 2 (encodeShortChannelId s)]) sci+          nid'  = maybe [] (\n -> [TlvRecord 4 n]) nid+          pid'  = maybe [] (\p -> [TlvRecord 6 p]) pid+          pko'  = maybe [] (\k -> [TlvRecord 8 k]) pko+          pr'   = maybe [] (\r -> [TlvRecord 10 (encodePaymentRelay r)]) pr+          pc'   = maybe [] (\c -> [TlvRecord 12 (encodePaymentConstraints c)]) pc+          af'   = maybe [] (\f -> [TlvRecord 14 f]) af+      in  pad' ++ sci' ++ nid' ++ pid' ++ pko' ++ pr' ++ pc' ++ af'+{-# INLINE encodeBlindedHopData #-}++-- | Decode TLV stream to BlindedHopData.+decodeBlindedHopData :: BS.ByteString -> Maybe BlindedHopData+decodeBlindedHopData !bs = do+  tlvs <- decodeTlvStream bs+  parseBlindedHopData tlvs++parseBlindedHopData :: [TlvRecord] -> Maybe BlindedHopData+parseBlindedHopData = go emptyHopData+  where+    emptyHopData :: BlindedHopData+    emptyHopData = BlindedHopData+      Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++    go :: BlindedHopData -> [TlvRecord] -> Maybe BlindedHopData+    go !bhd [] = Just bhd+    go !bhd (TlvRecord typ val : rest) = case typ of+      1  -> go bhd { bhdPadding = Just val } rest+      2  -> do+        sci <- decodeShortChannelId val+        go bhd { bhdShortChannelId = Just sci } rest+      4  -> go bhd { bhdNextNodeId = Just val } rest+      6  -> go bhd { bhdPathId = Just val } rest+      8  -> go bhd { bhdNextPathKeyOverride = Just val } rest+      10 -> do+        pr <- decodePaymentRelay val+        go bhd { bhdPaymentRelay = Just pr } rest+      12 -> do+        pc <- decodePaymentConstraints val+        go bhd { bhdPaymentConstraints = Just pc } rest+      14 -> go bhd { bhdAllowedFeatures = Just val } rest+      _  -> go bhd rest  -- Skip unknown TLVs++-- PaymentRelay encoding/decoding --------------------------------------------++-- | Encode PaymentRelay.+--+-- Format: 2-byte cltv_delta BE, 4-byte fee_prop BE, tu32 fee_base+encodePaymentRelay :: PaymentRelay -> BS.ByteString+encodePaymentRelay (PaymentRelay !cltv !feeProp !feeBase) = toStrict $+  B.word16BE cltv <>+  B.word32BE feeProp <>+  B.byteString (encodeWord32TU feeBase)+{-# INLINE encodePaymentRelay #-}++-- | Decode PaymentRelay.+decodePaymentRelay :: BS.ByteString -> Maybe PaymentRelay+decodePaymentRelay !bs+  | BS.length bs < 6 = Nothing+  | otherwise = do+      let !cltv = word16BE (BS.take 2 bs)+          !feeProp = word32BE (BS.take 4 (BS.drop 2 bs))+          !feeBaseBytes = BS.drop 6 bs+      feeBase <- decodeWord32TU feeBaseBytes+      Just (PaymentRelay cltv feeProp feeBase)+{-# INLINE decodePaymentRelay #-}++-- PaymentConstraints encoding/decoding --------------------------------------++-- | Encode PaymentConstraints.+--+-- Format: 4-byte max_cltv BE, tu64 htlc_min+encodePaymentConstraints :: PaymentConstraints -> BS.ByteString+encodePaymentConstraints (PaymentConstraints !maxCltv !htlcMin) = toStrict $+  B.word32BE maxCltv <>+  B.byteString (encodeWord64TU htlcMin)+{-# INLINE encodePaymentConstraints #-}++-- | Decode PaymentConstraints.+decodePaymentConstraints :: BS.ByteString -> Maybe PaymentConstraints+decodePaymentConstraints !bs+  | BS.length bs < 4 = Nothing+  | otherwise = do+      let !maxCltv = word32BE (BS.take 4 bs)+          !htlcMinBytes = BS.drop 4 bs+      htlcMin <- decodeWord64TU htlcMinBytes+      Just (PaymentConstraints maxCltv htlcMin)+{-# INLINE decodePaymentConstraints #-}++-- Shared secret computation -------------------------------------------------++-- | Compute shared secret from ECDH.+computeSharedSecret+  :: BS.ByteString         -- ^ 32-byte secret key+  -> Secp256k1.Projective  -- ^ Public key+  -> Maybe SharedSecret+computeSharedSecret !secBs !pub = do+  sec <- Secp256k1.roll32 secBs+  ecdhPoint <- Secp256k1.mul pub sec+  let !compressed = Secp256k1.serialize_point ecdhPoint+      !ss = SHA256.hash compressed+  pure $! SharedSecret ss+{-# INLINE computeSharedSecret #-}++-- Path creation -------------------------------------------------------------++-- | Create a blinded path from a seed and list of nodes with their data.+createBlindedPath+  :: BS.ByteString  -- ^ 32-byte random seed for ephemeral key+  -> [(Secp256k1.Projective, BlindedHopData)]  -- ^ Nodes with their data+  -> Either BlindingError BlindedPath+createBlindedPath !seed !nodes+  | BS.length seed /= 32 = Left InvalidSeed+  | otherwise = case nodes of+      [] -> Left EmptyPath+      ((introNode, _) : _) -> do+        -- (e_0, E_0) = keypair from seed+        e0 <- maybe (Left InvalidSeed) Right (Secp256k1.roll32 seed)+        e0Pub <- maybe (Left InvalidSeed) Right+                   (Secp256k1.mul Secp256k1._CURVE_G e0)+        -- Process all hops+        hops <- processHops seed e0Pub nodes 0+        Right (BlindedPath introNode e0Pub hops)++processHops+  :: BS.ByteString  -- ^ Current e_i+  -> Secp256k1.Projective  -- ^ Current E_i+  -> [(Secp256k1.Projective, BlindedHopData)]+  -> Int  -- ^ Index for error reporting+  -> Either BlindingError [BlindedHop]+processHops _ _ [] _ = Right []+processHops !eKey !ePub ((nodePub, hopData) : rest) !idx = do+  -- ss_i = SHA256(ECDH(e_i, N_i))+  ss <- maybe (Left (InvalidNodeKey idx)) Right+          (computeSharedSecret eKey nodePub)+  -- rho_i = deriveBlindingRho(ss_i)+  let !rho = deriveBlindingRho ss+  -- B_i = deriveBlindedNodeId(ss_i, N_i)+  blindedId <- maybe (Left (InvalidNodeKey idx)) Right+                 (deriveBlindedNodeId ss nodePub)+  -- encrypted_i = encryptHopData(rho_i, data_i)+  let !encData = encryptHopData rho hopData+      !hop = BlindedHop blindedId encData+  -- (e_{i+1}, E_{i+1}) = nextEphemeral(e_i, E_i, ss_i)+  (nextE, nextEPub) <- maybe (Left (InvalidNodeKey idx)) Right+                         (nextEphemeral eKey ePub ss)+  -- Process remaining hops+  restHops <- processHops nextE nextEPub rest (idx + 1)+  Right (hop : restHops)++-- Hop processing ------------------------------------------------------------++-- | Process a blinded hop, returning decrypted data and next path key.+processBlindedHop+  :: BS.ByteString        -- ^ Node's 32-byte private key+  -> Secp256k1.Projective -- ^ E_i, current path key (blinding point)+  -> BS.ByteString        -- ^ encrypted_data from onion payload+  -> Either BlindingError (BlindedHopData, Secp256k1.Projective)+processBlindedHop !nodeSecKey !pathKey !encData = do+  -- ss = SHA256(ECDH(node_seckey, path_key))+  ss <- maybe (Left InvalidPathKey) Right+          (computeSharedSecret nodeSecKey pathKey)+  -- rho = deriveBlindingRho(ss)+  let !rho = deriveBlindingRho ss+  -- hop_data = decryptHopData(rho, encrypted_data)+  hopData <- maybe (Left DecryptionFailed) Right+               (decryptHopData rho encData)+  -- Compute next path key+  nextKey <- case bhdNextPathKeyOverride hopData of+    Just override -> do+      -- Parse override as compressed point+      maybe (Left InvalidPathKey) Right (Secp256k1.parse_point override)+    Nothing -> do+      -- E_next = SHA256(path_key || ss) * path_key+      maybe (Left InvalidPathKey) Right (nextPathKey pathKey ss)+  Right (hopData, nextKey)++-- Scalar multiplication -----------------------------------------------------++-- | Multiply two 32-byte scalars mod curve order q.+--+-- Uses Montgomery multiplication from ppad-fixed for efficiency.+mulSecKey :: BS.ByteString -> BS.ByteString -> BS.ByteString+mulSecKey !a !b =+  let !aW = Secp256k1.unsafe_roll32 a+      !bW = Secp256k1.unsafe_roll32 b+      !aM = S.to aW+      !bM = S.to bW+      !resultM = S.mul aM bM+      !resultW = S.retr resultM+  in  Secp256k1.unroll32 resultW+{-# INLINE mulSecKey #-}

@@ -0,0 +1,387 @@+{-# 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++    -- * Internal helpers (for Blinding)+  , toStrict+  , word16BE+  , word32BE+  , encodeWord64TU+  , decodeWord64TU+  , encodeWord32TU+  , decodeWord32TU+  ) 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 (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 #-}

@@ -0,0 +1,212 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Lightning.Protocol.BOLT4.Construct+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Onion packet construction for BOLT4.++module Lightning.Protocol.BOLT4.Construct (+    -- * Types+    Hop(..)+  , Error(..)++    -- * Packet construction+  , construct+  ) where++import Data.Bits (xor)+import qualified Crypto.Curve.Secp256k1 as Secp256k1+import qualified Data.ByteString as BS+import Lightning.Protocol.BOLT4.Codec+import Lightning.Protocol.BOLT4.Prim+import Lightning.Protocol.BOLT4.Types++-- | Route information for a single hop.+data Hop = Hop+  { hopPubKey  :: !Secp256k1.Projective  -- ^ node's public key+  , hopPayload :: !HopPayload            -- ^ routing data for this hop+  } deriving (Eq, Show)++-- | Errors during packet construction.+data Error+  = InvalidSessionKey+  | EmptyRoute+  | TooManyHops+  | PayloadTooLarge !Int+  | InvalidHopPubKey !Int+  deriving (Eq, Show)++-- | Maximum number of hops in a route.+maxHops :: Int+maxHops = 20+{-# INLINE maxHops #-}++-- | Construct an onion packet for a payment route.+--+-- Takes a session key (32 bytes random), list of hops, and associated+-- data (typically payment_hash).+--+-- Returns the onion packet and list of shared secrets (for error+-- attribution).+construct+  :: BS.ByteString       -- ^ 32-byte session key (random)+  -> [Hop]               -- ^ route (first hop to final destination)+  -> BS.ByteString       -- ^ associated data+  -> Either Error (OnionPacket, [SharedSecret])+construct !sessionKey !hops !assocData+  | BS.length sessionKey /= 32 = Left InvalidSessionKey+  | null hops = Left EmptyRoute+  | length hops > maxHops = Left TooManyHops+  | otherwise = do+      -- Initialize ephemeral keypair from session key+      ephSec <- maybe (Left InvalidSessionKey) Right+                  (Secp256k1.roll32 sessionKey)+      ephPub <- maybe (Left InvalidSessionKey) Right+                  (Secp256k1.derive_pub ephSec)++      -- Compute shared secrets and blinding factors for all hops+      let hopPubKeys = map hopPubKey hops+      (secrets, _) <- computeAllSecrets sessionKey ephPub hopPubKeys++      -- Validate payload sizes+      let payloadBytes = map (encodeHopPayload . hopPayload) hops+          payloadSizes = map payloadShiftSize payloadBytes+          totalSize = sum payloadSizes+      if totalSize > hopPayloadsSize+        then Left (PayloadTooLarge totalSize)+        else do+          -- Generate filler using secrets for all but final hop+          let numHops = length hops+              secretsExceptFinal = take (numHops - 1) secrets+              sizesExceptFinal = take (numHops - 1) payloadSizes+              filler = generateFiller secretsExceptFinal sizesExceptFinal++          -- Initialize hop_payloads with deterministic padding+          let DerivedKey padKey = derivePad (SharedSecret sessionKey)+              initialPayloads = generateStream (DerivedKey padKey)+                                  hopPayloadsSize++          -- Wrap payloads in reverse order (final hop first)+          let (finalPayloads, finalHmac) = wrapAllHops+                secrets payloadBytes filler assocData initialPayloads++          -- Build the final packet+          let ephPubBytes = Secp256k1.serialize_point ephPub+              packet = OnionPacket+                { opVersion = versionByte+                , opEphemeralKey = ephPubBytes+                , opHopPayloads = finalPayloads+                , opHmac = finalHmac+                }++          Right (packet, secrets)++-- | Compute the total shift size for a payload.+payloadShiftSize :: BS.ByteString -> Int+payloadShiftSize !payload =+  let !len = BS.length payload+      !bsLen = bigSizeLen (fromIntegral len)+  in  bsLen + len + hmacSize+{-# INLINE payloadShiftSize #-}++-- | Compute shared secrets for all hops.+computeAllSecrets+  :: BS.ByteString+  -> Secp256k1.Projective+  -> [Secp256k1.Projective]+  -> Either Error ([SharedSecret], Secp256k1.Projective)+computeAllSecrets !initSec !initPub = go initSec initPub 0 []+  where+    go !_ephSec !ephPub !_ !acc [] = Right (reverse acc, ephPub)+    go !ephSec !ephPub !idx !acc (hopPub:rest) = do+      ss <- maybe (Left (InvalidHopPubKey idx)) Right+              (computeSharedSecret ephSec hopPub)+      let !bf = computeBlindingFactor ephPub ss+      newEphSec <- maybe (Left (InvalidHopPubKey idx)) Right+                     (blindSecKey ephSec bf)+      newEphPub <- maybe (Left (InvalidHopPubKey idx)) Right+                     (blindPubKey ephPub bf)+      go newEphSec newEphPub (idx + 1) (ss : acc) rest++-- | Generate filler bytes.+generateFiller :: [SharedSecret] -> [Int] -> BS.ByteString+generateFiller !secrets !sizes = go BS.empty secrets sizes+  where+    go !filler [] [] = filler+    go !filler (ss:sss) (sz:szs) =+      let !extended = filler <> BS.replicate sz 0+          !rhoKey = deriveRho ss+          !stream = generateStream rhoKey (2 * hopPayloadsSize)+          !streamOffset = hopPayloadsSize+          !streamPart = BS.take (BS.length extended)+                          (BS.drop streamOffset stream)+          !newFiller = xorBytes extended streamPart+      in  go newFiller sss szs+    go !filler _ _ = filler+{-# INLINE generateFiller #-}++-- | Wrap all hops in reverse order.+wrapAllHops+  :: [SharedSecret]+  -> [BS.ByteString]+  -> BS.ByteString+  -> BS.ByteString+  -> BS.ByteString+  -> (BS.ByteString, BS.ByteString)+wrapAllHops !secrets !payloads !filler !assocData !initPayloads =+  let !paired = reverse (zip secrets payloads)+      !numHops = length paired+      !initHmac = BS.replicate hmacSize 0+  in  go numHops initPayloads initHmac paired+  where+    go !_ !hopPayloads !hmac [] = (hopPayloads, hmac)+    go !remaining !hopPayloads !hmac ((ss, payload):rest) =+      let !isLastHop = remaining == length (reverse (zip secrets payloads))+          (!newPayloads, !newHmac) = wrapHop ss payload hmac hopPayloads+                                       assocData filler isLastHop+      in  go (remaining - 1) newPayloads newHmac rest++-- | Wrap a single hop's payload.+wrapHop+  :: SharedSecret+  -> BS.ByteString+  -> BS.ByteString+  -> BS.ByteString+  -> BS.ByteString+  -> BS.ByteString+  -> Bool+  -> (BS.ByteString, BS.ByteString)+wrapHop !ss !payload !hmac !hopPayloads !assocData !filler !isFinalHop =+  let !payloadLen = BS.length payload+      !lenBytes = encodeBigSize (fromIntegral payloadLen)+      !shiftSize = BS.length lenBytes + payloadLen + hmacSize+      !shifted = BS.take (hopPayloadsSize - shiftSize) hopPayloads+      !prepended = lenBytes <> payload <> hmac <> shifted+      !rhoKey = deriveRho ss+      !stream = generateStream rhoKey hopPayloadsSize+      !obfuscated = xorBytes prepended stream+      !withFiller = if isFinalHop && not (BS.null filler)+                      then applyFiller obfuscated filler+                      else obfuscated+      !muKey = deriveMu ss+      !newHmac = computeHmac muKey withFiller assocData+  in  (withFiller, newHmac)+{-# INLINE wrapHop #-}++-- | Apply filler to the tail of hop_payloads.+applyFiller :: BS.ByteString -> BS.ByteString -> BS.ByteString+applyFiller !hopPayloads !filler =+  let !fillerLen = BS.length filler+      !prefix = BS.take (hopPayloadsSize - fillerLen) hopPayloads+  in  prefix <> filler+{-# INLINE applyFiller #-}++-- | XOR two ByteStrings.+xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString+xorBytes !a !b = BS.pack $ BS.zipWith xor a b+{-# INLINE xorBytes #-}

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

@@ -0,0 +1,226 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Lightning.Protocol.BOLT4.Prim+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Low-level cryptographic primitives for BOLT4 onion routing.++module Lightning.Protocol.BOLT4.Prim (+    -- * Types+    SharedSecret(..)+  , DerivedKey(..)+  , BlindingFactor(..)++    -- * Key derivation+  , deriveRho+  , deriveMu+  , deriveUm+  , derivePad+  , deriveAmmag++    -- * Shared secret computation+  , computeSharedSecret++    -- * Blinding factor computation+  , computeBlindingFactor++    -- * Key blinding+  , blindPubKey+  , blindSecKey++    -- * Stream generation+  , generateStream++    -- * HMAC operations+  , computeHmac+  , verifyHmac+  ) where++import qualified Crypto.Cipher.ChaCha20 as ChaCha+import qualified Crypto.Curve.Secp256k1 as Secp256k1+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Bits (xor)+import qualified Data.ByteString as BS+import qualified Data.List as L+import Data.Word (Word8, Word32)+import qualified Numeric.Montgomery.Secp256k1.Scalar as S++-- | 32-byte shared secret derived from ECDH.+newtype SharedSecret = SharedSecret BS.ByteString+  deriving (Eq, Show)++-- | 32-byte derived key (rho, mu, um, pad, ammag).+newtype DerivedKey = DerivedKey BS.ByteString+  deriving (Eq, Show)++-- | 32-byte blinding factor for ephemeral key updates.+newtype BlindingFactor = BlindingFactor BS.ByteString+  deriving (Eq, Show)++-- Key derivation ------------------------------------------------------------++-- | Derive rho key for obfuscation stream generation.+--+-- @rho = HMAC-SHA256(key="rho", data=shared_secret)@+deriveRho :: SharedSecret -> DerivedKey+deriveRho = deriveKey "rho"+{-# INLINE deriveRho #-}++-- | Derive mu key for HMAC computation.+--+-- @mu = HMAC-SHA256(key="mu", data=shared_secret)@+deriveMu :: SharedSecret -> DerivedKey+deriveMu = deriveKey "mu"+{-# INLINE deriveMu #-}++-- | Derive um key for return error HMAC.+--+-- @um = HMAC-SHA256(key="um", data=shared_secret)@+deriveUm :: SharedSecret -> DerivedKey+deriveUm = deriveKey "um"+{-# INLINE deriveUm #-}++-- | Derive pad key for filler generation.+--+-- @pad = HMAC-SHA256(key="pad", data=shared_secret)@+derivePad :: SharedSecret -> DerivedKey+derivePad = deriveKey "pad"+{-# INLINE derivePad #-}++-- | Derive ammag key for error obfuscation.+--+-- @ammag = HMAC-SHA256(key="ammag", data=shared_secret)@+deriveAmmag :: SharedSecret -> DerivedKey+deriveAmmag = deriveKey "ammag"+{-# INLINE deriveAmmag #-}++-- Internal helper for key derivation.+deriveKey :: BS.ByteString -> SharedSecret -> DerivedKey+deriveKey !keyType (SharedSecret !ss) =+  let SHA256.MAC !result = SHA256.hmac keyType ss+  in  DerivedKey result+{-# INLINE deriveKey #-}++-- Shared secret computation -------------------------------------------------++-- | Compute shared secret from ECDH.+--+-- Takes a 32-byte secret key and a public key.+-- Returns SHA256 of the compressed ECDH point (33 bytes).+computeSharedSecret+  :: BS.ByteString         -- ^ 32-byte secret key+  -> Secp256k1.Projective  -- ^ public key+  -> Maybe SharedSecret+computeSharedSecret !secBs !pub = do+  sec <- Secp256k1.roll32 secBs+  ecdhPoint <- Secp256k1.mul pub sec+  let !compressed = Secp256k1.serialize_point ecdhPoint+      !ss = SHA256.hash compressed+  pure $! SharedSecret ss+{-# INLINE computeSharedSecret #-}++-- Blinding factor -----------------------------------------------------------++-- | Compute blinding factor for ephemeral key updates.+--+-- @blinding_factor = SHA256(ephemeral_pubkey || shared_secret)@+computeBlindingFactor+  :: Secp256k1.Projective  -- ^ ephemeral public key+  -> SharedSecret          -- ^ shared secret+  -> BlindingFactor+computeBlindingFactor !pub (SharedSecret !ss) =+  let !pubBytes = Secp256k1.serialize_point pub+      !combined = pubBytes <> ss+      !hashed = SHA256.hash combined+  in  BlindingFactor hashed+{-# INLINE computeBlindingFactor #-}++-- Key blinding --------------------------------------------------------------++-- | Blind a public key by multiplying with blinding factor.+--+-- @new_pubkey = pubkey * blinding_factor@+blindPubKey+  :: Secp256k1.Projective+  -> BlindingFactor+  -> Maybe Secp256k1.Projective+blindPubKey !pub (BlindingFactor !bf) = do+  sk <- Secp256k1.roll32 bf+  Secp256k1.mul pub sk+{-# INLINE blindPubKey #-}++-- | Blind a secret key by multiplying with blinding factor (mod curve order).+--+-- @new_seckey = seckey * blinding_factor (mod q)@+--+-- Uses Montgomery multiplication from ppad-fixed for efficiency.+-- Takes a 32-byte secret key and returns a 32-byte blinded secret key.+blindSecKey+  :: BS.ByteString     -- ^ 32-byte secret key+  -> BlindingFactor    -- ^ blinding factor+  -> Maybe BS.ByteString  -- ^ 32-byte blinded secret key+blindSecKey !secBs (BlindingFactor !bf)+  | BS.length secBs /= 32 = Nothing+  | BS.length bf /= 32 = Nothing+  | otherwise =+      let !secW = Secp256k1.unsafe_roll32 secBs+          !bfW = Secp256k1.unsafe_roll32 bf+          !secM = S.to secW+          !bfM = S.to bfW+          !resultM = S.mul secM bfM+          !resultW = S.retr resultM+      in  Just $! Secp256k1.unroll32 resultW+{-# INLINE blindSecKey #-}++-- Stream generation ---------------------------------------------------------++-- | Generate pseudo-random byte stream using ChaCha20.+--+-- Uses derived key as ChaCha20 key, 96-bit zero nonce, counter=0.+-- Encrypts zeros to produce keystream.+generateStream+  :: DerivedKey     -- ^ rho or ammag key+  -> Int            -- ^ desired length+  -> BS.ByteString+generateStream (DerivedKey !key) !len =+  let !nonce = BS.replicate 12 0+      !zeros = BS.replicate len 0+  in  either (const (BS.replicate len 0)) id+        (ChaCha.cipher key (0 :: Word32) nonce zeros)+{-# INLINE generateStream #-}++-- HMAC operations -----------------------------------------------------------++-- | Compute HMAC-SHA256 for packet integrity.+computeHmac+  :: DerivedKey      -- ^ mu key+  -> BS.ByteString   -- ^ hop_payloads+  -> BS.ByteString   -- ^ associated_data+  -> BS.ByteString   -- ^ 32-byte HMAC+computeHmac (DerivedKey !key) !payloads !assocData =+  let SHA256.MAC !result = SHA256.hmac key (payloads <> assocData)+  in  result+{-# INLINE computeHmac #-}++-- | Constant-time HMAC comparison.+verifyHmac+  :: BS.ByteString  -- ^ expected+  -> BS.ByteString  -- ^ computed+  -> Bool+verifyHmac !expected !computed+  | BS.length expected /= BS.length computed = False+  | otherwise = constantTimeEq expected computed+{-# INLINE verifyHmac #-}++-- Constant-time equality comparison.+constantTimeEq :: BS.ByteString -> BS.ByteString -> Bool+constantTimeEq !a !b =+  let !diff = L.foldl' (\acc (x, y) -> acc `xor` (x `xor` y)) (0 :: Word8)+                       (BS.zip a b)+  in  diff == 0+{-# INLINE constantTimeEq #-}

@@ -0,0 +1,220 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Lightning.Protocol.BOLT4.Process+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Onion packet processing for BOLT4.++module Lightning.Protocol.BOLT4.Process (+    -- * Processing+    process++    -- * Rejection reasons+  , RejectReason(..)+  ) where++import Data.Bits (xor)+import qualified Crypto.Curve.Secp256k1 as Secp256k1+import qualified Data.ByteString as BS+import Data.Word (Word8)+import GHC.Generics (Generic)+import Lightning.Protocol.BOLT4.Codec+import Lightning.Protocol.BOLT4.Prim+import Lightning.Protocol.BOLT4.Types++-- | Reasons for rejecting a packet.+data RejectReason+  = InvalidVersion !Word8       -- ^ Version byte is not 0x00+  | InvalidEphemeralKey         -- ^ Malformed public key+  | HmacMismatch                -- ^ HMAC verification failed+  | InvalidPayload !String      -- ^ Malformed hop payload+  deriving (Eq, Show, Generic)++-- | Process an incoming onion packet.+--+-- Takes the receiving node's private key, the incoming packet, and+-- associated data (typically the payment hash).+--+-- Returns either a rejection reason or the processing result+-- (forward to next hop or receive at final destination).+process+  :: BS.ByteString    -- ^ 32-byte secret key of this node+  -> OnionPacket      -- ^ incoming onion packet+  -> BS.ByteString    -- ^ associated data (payment hash)+  -> Either RejectReason ProcessResult+process !secKey !packet !assocData = do+  -- Step 1: Validate version+  validateVersion packet++  -- Step 2: Parse ephemeral public key+  ephemeral <- parseEphemeralKey packet++  -- Step 3: Compute shared secret+  ss <- case computeSharedSecret secKey ephemeral of+    Nothing -> Left InvalidEphemeralKey+    Just s  -> Right s++  -- Step 4: Derive keys+  let !muKey = deriveMu ss+      !rhoKey = deriveRho ss++  -- Step 5: Verify HMAC+  if not (verifyPacketHmac muKey packet assocData)+    then Left HmacMismatch+    else pure ()++  -- Step 6: Decrypt hop payloads+  let !decrypted = decryptPayloads rhoKey (opHopPayloads packet)++  -- Step 7: Extract payload+  (payloadBytes, nextHmac, remaining) <- extractPayload decrypted++  -- Step 8: Parse payload TLV+  hopPayload <- case decodeHopPayload payloadBytes of+    Nothing -> Left (InvalidPayload "failed to decode TLV")+    Just hp -> Right hp++  -- Step 9: Check if final hop+  let SharedSecret ssBytes = ss+  if isFinalHop nextHmac+    then Right $! Receive $! ReceiveInfo+      { riPayload = hopPayload+      , riSharedSecret = ssBytes+      }+    else do+      -- Step 10: Prepare forward packet+      nextPacket <- case prepareForward ephemeral ss remaining nextHmac of+        Nothing -> Left InvalidEphemeralKey+        Just np -> Right np++      Right $! Forward $! ForwardInfo+        { fiNextPacket = nextPacket+        , fiPayload = hopPayload+        , fiSharedSecret = ssBytes+        }++-- | Validate packet version is 0x00.+validateVersion :: OnionPacket -> Either RejectReason ()+validateVersion !packet+  | opVersion packet == versionByte = Right ()+  | otherwise = Left (InvalidVersion (opVersion packet))+{-# INLINE validateVersion #-}++-- | Parse and validate ephemeral public key from packet.+parseEphemeralKey :: OnionPacket -> Either RejectReason Secp256k1.Projective+parseEphemeralKey !packet =+  case Secp256k1.parse_point (opEphemeralKey packet) of+    Nothing  -> Left InvalidEphemeralKey+    Just pub -> Right pub+{-# INLINE parseEphemeralKey #-}++-- | Decrypt hop payloads by XORing with rho stream.+--+-- Generates a stream of 2*1300 bytes and XORs with hop_payloads+-- extended with 1300 zero bytes.+decryptPayloads+  :: DerivedKey      -- ^ rho key+  -> BS.ByteString   -- ^ hop_payloads (1300 bytes)+  -> BS.ByteString   -- ^ decrypted (2600 bytes, first 1300 useful)+decryptPayloads !rhoKey !payloads =+  let !streamLen = 2 * hopPayloadsSize  -- 2600 bytes+      !stream = generateStream rhoKey streamLen+      -- Extend payloads with zeros for the shift operation+      !extended = payloads <> BS.replicate hopPayloadsSize 0+  in  xorBytes stream extended+{-# INLINE decryptPayloads #-}++-- | 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 #-}++-- | Extract payload from decrypted buffer.+--+-- Parses BigSize length prefix, extracts payload bytes and next HMAC.+extractPayload+  :: BS.ByteString+  -> Either RejectReason (BS.ByteString, BS.ByteString, BS.ByteString)+     -- ^ (payload_bytes, next_hmac, remaining_hop_payloads)+extractPayload !decrypted = do+  -- Parse length prefix+  (len, afterLen) <- case decodeBigSize decrypted of+    Nothing -> Left (InvalidPayload "invalid length prefix")+    Just (l, r) -> Right (fromIntegral l :: Int, r)++  -- Validate length+  if len > BS.length afterLen+    then Left (InvalidPayload "payload length exceeds buffer")+    else if len == 0+      then Left (InvalidPayload "zero-length payload")+      else pure ()++  -- Extract payload bytes+  let !payloadBytes = BS.take len afterLen+      !afterPayload = BS.drop len afterLen++  -- Extract next HMAC (32 bytes)+  if BS.length afterPayload < hmacSize+    then Left (InvalidPayload "insufficient bytes for HMAC")+    else do+      let !nextHmac = BS.take hmacSize afterPayload+          -- Remaining payloads: skip the HMAC, take first 1300 bytes+          -- This is already "shifted" by the payload extraction+          !remaining = BS.drop hmacSize afterPayload++      Right (payloadBytes, nextHmac, remaining)++-- | Verify packet HMAC.+--+-- Computes HMAC over (hop_payloads || associated_data) using mu key+-- and compares with packet's HMAC using constant-time comparison.+verifyPacketHmac+  :: DerivedKey      -- ^ mu key+  -> OnionPacket     -- ^ packet with HMAC to verify+  -> BS.ByteString   -- ^ associated data+  -> Bool+verifyPacketHmac !muKey !packet !assocData =+  let !computed = computeHmac muKey (opHopPayloads packet) assocData+  in  verifyHmac (opHmac packet) computed+{-# INLINE verifyPacketHmac #-}++-- | Prepare packet for forwarding to next hop.+--+-- Computes blinded ephemeral key and constructs next OnionPacket.+prepareForward+  :: Secp256k1.Projective  -- ^ current ephemeral key+  -> SharedSecret          -- ^ shared secret (for blinding)+  -> BS.ByteString         -- ^ remaining hop_payloads (after shift)+  -> BS.ByteString         -- ^ next HMAC+  -> Maybe OnionPacket+prepareForward !ephemeral !ss !remaining !nextHmac = do+  -- Compute blinding factor and blind ephemeral key+  let !bf = computeBlindingFactor ephemeral ss+  newEphemeral <- blindPubKey ephemeral bf++  -- Serialize new ephemeral key+  let !newEphBytes = Secp256k1.serialize_point newEphemeral++  -- Truncate remaining to exactly 1300 bytes+  let !newPayloads = BS.take hopPayloadsSize remaining++  -- Construct next packet+  pure $! OnionPacket+    { opVersion = versionByte+    , opEphemeralKey = newEphBytes+    , opHopPayloads = newPayloads+    , opHmac = nextHmac+    }++-- | Check if this is the final hop.+--+-- Final hop is indicated by next_hmac being all zeros.+isFinalHop :: BS.ByteString -> Bool+isFinalHop !hmac = hmac == BS.replicate hmacSize 0+{-# INLINE isFinalHop #-}

@@ -0,0 +1,279 @@+{-# 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 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(..)+  , 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++-- | 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++-- | 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++-- | 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.+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

@@ -0,0 +1,86 @@+cabal-version:      3.0+name:               ppad-bolt4+version:            0.0.1+synopsis:           BOLT4 (onion routing) for Lightning Network+license:            MIT+license-file:       LICENSE+author:             Jared Tobin+maintainer:         jared@ppad.tech+category:           Cryptography+build-type:         Simple+tested-with:        GHC == 9.10.3+extra-doc-files:    CHANGELOG+description:+  A pure Haskell implementation of BOLT4 (onion routing) from+  the Lightning Network protocol specification.++source-repository head+  type:     git+  location: git.ppad.tech/bolt4.git++library+  default-language: Haskell2010+  hs-source-dirs:   lib+  ghc-options:+    -Wall+  exposed-modules:+    Lightning.Protocol.BOLT4+    Lightning.Protocol.BOLT4.Blinding+    Lightning.Protocol.BOLT4.Codec+    Lightning.Protocol.BOLT4.Construct+    Lightning.Protocol.BOLT4.Error+    Lightning.Protocol.BOLT4.Prim+    Lightning.Protocol.BOLT4.Process+    Lightning.Protocol.BOLT4.Types+  build-depends:+      base >= 4.9 && < 5+    , bytestring >= 0.9 && < 0.13+    , ppad-aead >= 0.3 && < 0.4+    , ppad-chacha >= 0.2 && < 0.3+    , ppad-fixed >= 0.1 && < 0.2+    , ppad-secp256k1 >= 0.5 && < 0.6+    , ppad-sha256 >= 0.3 && < 0.4++test-suite bolt4-tests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   test+  main-is:          Main.hs+  ghc-options:+      -rtsopts -Wall -O2+  build-depends:+      base+    , bytestring+    , ppad-base16+    , ppad-bolt4+    , ppad-secp256k1+    , tasty+    , tasty-hunit+    , tasty-quickcheck++benchmark bolt4-bench+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   bench+  main-is:          Main.hs+  ghc-options:+      -rtsopts -O2 -Wall -fno-warn-orphans+  build-depends:+      base+    , bytestring+    , criterion+    , deepseq+    , ppad-bolt4++benchmark bolt4-weigh+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   bench+  main-is:          Weight.hs+  ghc-options:+      -rtsopts -O2 -Wall -fno-warn-orphans+  build-depends:+      base+    , bytestring+    , ppad-bolt4+    , weigh

@@ -0,0 +1,1188 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Bits (xor)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Crypto.Curve.Secp256k1 as Secp256k1+import Data.Word (Word8)+import Lightning.Protocol.BOLT4.Blinding+import Lightning.Protocol.BOLT4.Codec+import Lightning.Protocol.BOLT4.Construct+import Lightning.Protocol.BOLT4.Error+import Lightning.Protocol.BOLT4.Prim+import Lightning.Protocol.BOLT4.Process+import Lightning.Protocol.BOLT4.Types+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++-- | Demand a Just value in IO, failing the test on Nothing.+demand :: String -> Maybe a -> IO a+demand _ (Just a) = pure a+demand msg Nothing = assertFailure msg++main :: IO ()+main = defaultMain $ testGroup "ppad-bolt4" [+    testGroup "Prim" [+        primTests+      ]+  , testGroup "BigSize" [+        bigsizeTests+      , bigsizeRoundtripProp+      ]+  , testGroup "TLV" [+        tlvTests+      ]+  , testGroup "ShortChannelId" [+        sciTests+      ]+  , testGroup "OnionPacket" [+        onionPacketTests+      ]+  , testGroup "Construct" [+        constructTests+      ]+  , testGroup "Process" [+        processTests+      ]+  , testGroup "Error" [+        errorTests+      ]+  , testGroup "Blinding" [+        blindingKeyDerivationTests+      , blindingEphemeralKeyTests+      , blindingTlvTests+      , blindingEncryptionTests+      , blindingCreatePathTests+      , blindingProcessHopTests+      ]+  ]++-- 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+      let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFC])+      result @?= Nothing+  , testCase "reject non-canonical 0xFE encoding of small value" $ do+      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+      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+      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+  ]++-- Prim tests ---------------------------------------------------------------++sessionKey :: BS.ByteString+sessionKey = BS.replicate 32 0x41++hop0PubKeyHex :: BS.ByteString+hop0PubKeyHex =+  "02eec7245d6b7d2ccb30380bfbe2a3648cd7a942653f5aa340edcea1f283686619"++hop0SharedSecretHex :: BS.ByteString+hop0SharedSecretHex =+  "53eb63ea8a3fec3b3cd433b85cd62a4b145e1dda09391b348c4e1cd36a03ea66"++hop0BlindingFactorHex :: BS.ByteString+hop0BlindingFactorHex =+  "2ec2e5da605776054187180343287683aa6a51b4b1c04d6dd49c45d8cffb3c36"++fromHex :: BS.ByteString -> BS.ByteString+fromHex h = case B16.decode h of+  Just bs -> bs+  Nothing -> error "fromHex: invalid hex"++primTests :: TestTree+primTests = testGroup "cryptographic primitives" [+    testSharedSecret+  , testBlindingFactor+  , testKeyDerivation+  , testBlindPubKey+  , testGenerateStream+  , testHmacOperations+  ]++testSharedSecret :: TestTree+testSharedSecret = testCase "computeSharedSecret (BOLT4 spec hop 0)" $ do+  pubKey <- demand "parse_point" $+    Secp256k1.parse_point (fromHex hop0PubKeyHex)+  case computeSharedSecret sessionKey pubKey of+    Nothing -> assertFailure "computeSharedSecret returned Nothing"+    Just (SharedSecret computed) -> do+      let expected = fromHex hop0SharedSecretHex+      computed @?= expected++testBlindingFactor :: TestTree+testBlindingFactor = testCase "computeBlindingFactor (BOLT4 spec hop 0)" $ do+  sk <- demand "roll32" $ Secp256k1.roll32 sessionKey+  ephemPubKey <- demand "derive_pub" $ Secp256k1.derive_pub sk+  nodePubKey <- demand "parse_point" $+    Secp256k1.parse_point (fromHex hop0PubKeyHex)+  case computeSharedSecret sessionKey nodePubKey of+    Nothing -> assertFailure "computeSharedSecret returned Nothing"+    Just sharedSecret -> do+      let BlindingFactor computed =+            computeBlindingFactor ephemPubKey sharedSecret+          expected = fromHex hop0BlindingFactorHex+      computed @?= expected++testKeyDerivation :: TestTree+testKeyDerivation = testGroup "key derivation" [+    testCase "deriveRho produces 32 bytes" $ do+      let ss = SharedSecret (BS.replicate 32 0)+          DerivedKey rho = deriveRho ss+      BS.length rho @?= 32+  , testCase "deriveMu produces 32 bytes" $ do+      let ss = SharedSecret (BS.replicate 32 0)+          DerivedKey mu = deriveMu ss+      BS.length mu @?= 32+  , testCase "deriveUm produces 32 bytes" $ do+      let ss = SharedSecret (BS.replicate 32 0)+          DerivedKey um = deriveUm ss+      BS.length um @?= 32+  , testCase "derivePad produces 32 bytes" $ do+      let ss = SharedSecret (BS.replicate 32 0)+          DerivedKey pad = derivePad ss+      BS.length pad @?= 32+  , testCase "deriveAmmag produces 32 bytes" $ do+      let ss = SharedSecret (BS.replicate 32 0)+          DerivedKey ammag = deriveAmmag ss+      BS.length ammag @?= 32+  , testCase "different key types produce different results" $ do+      let ss = SharedSecret (BS.replicate 32 0x42)+          DerivedKey rho = deriveRho ss+          DerivedKey mu = deriveMu ss+          DerivedKey um = deriveUm ss+      assertBool "rho /= mu" (rho /= mu)+      assertBool "mu /= um" (mu /= um)+      assertBool "rho /= um" (rho /= um)+  ]++testBlindPubKey :: TestTree+testBlindPubKey = testGroup "key blinding" [+    testCase "blindPubKey produces valid key" $ do+      sk <- demand "roll32" $ Secp256k1.roll32 sessionKey+      pubKey <- demand "derive_pub" $ Secp256k1.derive_pub sk+      let bf = BlindingFactor (fromHex hop0BlindingFactorHex)+      case blindPubKey pubKey bf of+        Nothing -> assertFailure "blindPubKey returned Nothing"+        Just _blinded -> return ()+  , testCase "blindSecKey produces valid key" $ do+      let bf = BlindingFactor (fromHex hop0BlindingFactorHex)+      case blindSecKey sessionKey bf of+        Nothing -> assertFailure "blindSecKey returned Nothing"+        Just _blinded -> return ()+  ]++testGenerateStream :: TestTree+testGenerateStream = testGroup "generateStream" [+    testCase "produces correct length" $ do+      let dk = DerivedKey (BS.replicate 32 0)+          stream = generateStream dk 100+      BS.length stream @?= 100+  , testCase "1300-byte stream for hop_payloads" $ do+      let dk = DerivedKey (BS.replicate 32 0x42)+          stream = generateStream dk 1300+      BS.length stream @?= 1300+  , testCase "deterministic output" $ do+      let dk = DerivedKey (BS.replicate 32 0x55)+          stream1 = generateStream dk 64+          stream2 = generateStream dk 64+      stream1 @?= stream2+  ]++testHmacOperations :: TestTree+testHmacOperations = testGroup "HMAC operations" [+    testCase "computeHmac produces 32 bytes" $ do+      let dk = DerivedKey (BS.replicate 32 0)+          hmac = computeHmac dk "payloads" "assocdata"+      BS.length hmac @?= 32+  , testCase "verifyHmac succeeds for matching" $ do+      let dk = DerivedKey (BS.replicate 32 0)+          hmac = computeHmac dk "payloads" "assocdata"+      assertBool "verifyHmac should succeed" (verifyHmac hmac hmac)+  , testCase "verifyHmac fails for different" $ do+      let dk = DerivedKey (BS.replicate 32 0)+          hmac1 = computeHmac dk "payloads1" "assocdata"+          hmac2 = computeHmac dk "payloads2" "assocdata"+      assertBool "verifyHmac should fail" (not $ verifyHmac hmac1 hmac2)+  , testCase "verifyHmac fails for different lengths" $ do+      assertBool "verifyHmac should fail"+        (not $ verifyHmac "short" "different length")+  ]++-- Construct tests ------------------------------------------------------------++-- Test vectors from BOLT4 spec+hop1PubKeyHex :: BS.ByteString+hop1PubKeyHex =+  "0324653eac434488002cc06bbfb7f10fe18991e35f9fe4302dbea6d2353dc0ab1c"++hop2PubKeyHex :: BS.ByteString+hop2PubKeyHex =+  "027f31ebc5462c1fdce1b737ecff52d37d75dea43ce11c74d25aa297165faa2007"++hop3PubKeyHex :: BS.ByteString+hop3PubKeyHex =+  "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"++hop4PubKeyHex :: BS.ByteString+hop4PubKeyHex =+  "02edabbd16b41c8371b92ef2f04c1185b4f03b6dcd52ba9b78d9d7c89c8f221145"++-- Expected shared secrets from BOLT4 error test vectors (in route order)+hop1SharedSecretHex :: BS.ByteString+hop1SharedSecretHex =+  "a6519e98832a0b179f62123b3567c106db99ee37bef036e783263602f3488fae"++hop2SharedSecretHex :: BS.ByteString+hop2SharedSecretHex =+  "3a6b412548762f0dbccce5c7ae7bb8147d1caf9b5471c34120b30bc9c04891cc"++hop3SharedSecretHex :: BS.ByteString+hop3SharedSecretHex =+  "21e13c2d7cfe7e18836df50872466117a295783ab8aab0e7ecc8c725503ad02d"++hop4SharedSecretHex :: BS.ByteString+hop4SharedSecretHex =+  "b5756b9b542727dbafc6765a49488b023a725d631af688fc031217e90770c328"++constructTests :: TestTree+constructTests = testGroup "packet construction" [+    testConstructErrorCases+  , testSharedSecretComputation+  , testPacketStructure+  , testSingleHop+  ]++testConstructErrorCases :: TestTree+testConstructErrorCases = testGroup "error cases" [+    testCase "rejects invalid session key (too short)" $ do+      let result = construct (BS.replicate 31 0x41) [] ""+      case result of+        Left InvalidSessionKey -> return ()+        _ -> assertFailure "Expected InvalidSessionKey"+  , testCase "rejects invalid session key (too long)" $ do+      let result = construct (BS.replicate 33 0x41) [] ""+      case result of+        Left InvalidSessionKey -> return ()+        _ -> assertFailure "Expected InvalidSessionKey"+  , testCase "rejects empty route" $ do+      let result = construct sessionKey [] ""+      case result of+        Left EmptyRoute -> return ()+        _ -> assertFailure "Expected EmptyRoute"+  , testCase "rejects too many hops" $ do+      pub <- demand "parse_point" $+        Secp256k1.parse_point (fromHex hop0PubKeyHex)+      let emptyPayload = HopPayload Nothing Nothing Nothing Nothing+                           Nothing Nothing []+          hop = Hop pub emptyPayload+          hops = replicate 21 hop+          result = construct sessionKey hops ""+      case result of+        Left TooManyHops -> return ()+        _ -> assertFailure "Expected TooManyHops"+  ]++testSharedSecretComputation :: TestTree+testSharedSecretComputation =+  testCase "computes correct shared secrets (BOLT4 spec)" $ do+    pub0 <- demand "parse_point" $+      Secp256k1.parse_point (fromHex hop0PubKeyHex)+    pub1 <- demand "parse_point" $+      Secp256k1.parse_point (fromHex hop1PubKeyHex)+    pub2 <- demand "parse_point" $+      Secp256k1.parse_point (fromHex hop2PubKeyHex)+    pub3 <- demand "parse_point" $+      Secp256k1.parse_point (fromHex hop3PubKeyHex)+    pub4 <- demand "parse_point" $+      Secp256k1.parse_point (fromHex hop4PubKeyHex)+    let emptyPayload = HopPayload Nothing Nothing Nothing Nothing+                         Nothing Nothing []+        hops = [ Hop pub0 emptyPayload+               , Hop pub1 emptyPayload+               , Hop pub2 emptyPayload+               , Hop pub3 emptyPayload+               , Hop pub4 emptyPayload+               ]+        result = construct sessionKey hops ""+    case result of+      Left err -> assertFailure $ "construct failed: " ++ show err+      Right (_, secrets) -> case secrets of+        [SharedSecret ss0, SharedSecret ss1, SharedSecret ss2,+         SharedSecret ss3, SharedSecret ss4] -> do+          ss0 @?= fromHex hop0SharedSecretHex+          ss1 @?= fromHex hop1SharedSecretHex+          ss2 @?= fromHex hop2SharedSecretHex+          ss3 @?= fromHex hop3SharedSecretHex+          ss4 @?= fromHex hop4SharedSecretHex+        _ -> assertFailure "expected 5 shared secrets"++testPacketStructure :: TestTree+testPacketStructure = testCase "produces valid packet structure" $ do+  pub0 <- demand "parse_point" $+    Secp256k1.parse_point (fromHex hop0PubKeyHex)+  pub1 <- demand "parse_point" $+    Secp256k1.parse_point (fromHex hop1PubKeyHex)+  let emptyPayload = HopPayload Nothing Nothing Nothing Nothing+                       Nothing Nothing []+      hops = [Hop pub0 emptyPayload, Hop pub1 emptyPayload]+      result = construct sessionKey hops ""+  case result of+    Left err -> assertFailure $ "construct failed: " ++ show err+    Right (packet, _) -> do+      opVersion packet @?= versionByte+      BS.length (opEphemeralKey packet) @?= pubkeySize+      BS.length (opHopPayloads packet) @?= hopPayloadsSize+      BS.length (opHmac packet) @?= hmacSize+      sk <- demand "roll32" $ Secp256k1.roll32 sessionKey+      expectedPub <- demand "derive_pub" $+        Secp256k1.derive_pub sk+      let expectedPubBytes = Secp256k1.serialize_point expectedPub+      opEphemeralKey packet @?= expectedPubBytes++testSingleHop :: TestTree+testSingleHop = testCase "constructs single-hop packet" $ do+  pub0 <- demand "parse_point" $+    Secp256k1.parse_point (fromHex hop0PubKeyHex)+  let payload = HopPayload+        { hpAmtToForward = Just 1000+        , hpOutgoingCltv = Just 500000+        , hpShortChannelId = Nothing+        , hpPaymentData = Nothing+        , hpEncryptedData = Nothing+        , hpCurrentPathKey = Nothing+        , hpUnknownTlvs = []+        }+      hops = [Hop pub0 payload]+      result = construct sessionKey hops ""+  case result of+    Left err -> assertFailure $ "construct failed: " ++ show err+    Right (packet, secrets) -> do+      length secrets @?= 1+      -- Packet should be valid structure+      let encoded = encodeOnionPacket packet+      BS.length encoded @?= onionPacketSize+      -- Should decode back+      decoded <- demand "decodeOnionPacket" $+        decodeOnionPacket encoded+      decoded @?= packet++-- Process tests -------------------------------------------------------------++processTests :: TestTree+processTests = testGroup "packet processing" [+    testVersionValidation+  , testEphemeralKeyValidation+  , testHmacValidation+  , testProcessBasic+  ]++testVersionValidation :: TestTree+testVersionValidation = testGroup "version validation" [+    testCase "reject invalid version 0x01" $ do+      let packet = OnionPacket+            { opVersion = 0x01  -- Invalid, should be 0x00+            , opEphemeralKey = BS.replicate 33 0x02+            , opHopPayloads = BS.replicate 1300 0x00+            , opHmac = BS.replicate 32 0x00+            }+      case process sessionKey packet BS.empty of+        Left (InvalidVersion v) -> v @?= 0x01+        Left other -> assertFailure $ "expected InvalidVersion, got: "+          ++ show other+        Right _ -> assertFailure "expected rejection, got success"+  , testCase "reject invalid version 0xFF" $ do+      let packet = OnionPacket+            { opVersion = 0xFF+            , opEphemeralKey = BS.replicate 33 0x02+            , opHopPayloads = BS.replicate 1300 0x00+            , opHmac = BS.replicate 32 0x00+            }+      case process sessionKey packet BS.empty of+        Left (InvalidVersion v) -> v @?= 0xFF+        Left other -> assertFailure $ "expected InvalidVersion, got: "+          ++ show other+        Right _ -> assertFailure "expected rejection, got success"+  ]++testEphemeralKeyValidation :: TestTree+testEphemeralKeyValidation = testGroup "ephemeral key validation" [+    testCase "reject invalid ephemeral key (all zeros)" $ do+      let packet = OnionPacket+            { opVersion = 0x00+            , opEphemeralKey = BS.replicate 33 0x00  -- Invalid pubkey+            , opHopPayloads = BS.replicate 1300 0x00+            , opHmac = BS.replicate 32 0x00+            }+      case process sessionKey packet BS.empty of+        Left InvalidEphemeralKey -> return ()+        Left other -> assertFailure $ "expected InvalidEphemeralKey, got: "+          ++ show other+        Right _ -> assertFailure "expected rejection, got success"+  , testCase "reject malformed ephemeral key" $ do+      -- 0x04 prefix is for uncompressed keys, but we only have 33 bytes+      let packet = OnionPacket+            { opVersion = 0x00+            , opEphemeralKey = BS.pack (0x04 : replicate 32 0xAB)+            , opHopPayloads = BS.replicate 1300 0x00+            , opHmac = BS.replicate 32 0x00+            }+      case process sessionKey packet BS.empty of+        Left InvalidEphemeralKey -> return ()+        Left other -> assertFailure $ "expected InvalidEphemeralKey, got: "+          ++ show other+        Right _ -> assertFailure "expected rejection, got success"+  ]++testHmacValidation :: TestTree+testHmacValidation = testGroup "HMAC validation" [+    testCase "reject invalid HMAC" $ do+      -- Use a valid ephemeral key but wrong HMAC+      hop0PubKey <- demand "parse_point" $+        Secp256k1.parse_point (fromHex hop0PubKeyHex)+      let ephKeyBytes = Secp256k1.serialize_point hop0PubKey+          packet = OnionPacket+            { opVersion = 0x00+            , opEphemeralKey = ephKeyBytes+            , opHopPayloads = BS.replicate 1300 0x00+            , opHmac = BS.replicate 32 0xFF  -- Wrong HMAC+            }+      case process sessionKey packet BS.empty of+        Left HmacMismatch -> return ()+        Left other -> assertFailure $ "expected HmacMismatch, got: "+          ++ show other+        Right _ -> assertFailure "expected rejection, got success"+  ]++-- | Test basic packet processing with a properly constructed packet.+testProcessBasic :: TestTree+testProcessBasic = testGroup "basic processing" [+    testCase "process valid packet (final hop, all-zero next HMAC)" $ do+      -- Construct a valid packet for a final hop+      -- The hop payload needs to be properly formatted TLV+      hop0PubKey <- demand "parse_point" $+        Secp256k1.parse_point (fromHex hop0PubKeyHex)+      let ephKeyBytes = Secp256k1.serialize_point hop0PubKey+          hopPayloadTlv = encodeHopPayload HopPayload+            { hpAmtToForward = Just 1000+            , hpOutgoingCltv = Just 500000+            , hpShortChannelId = Nothing+            , hpPaymentData = Nothing+            , hpEncryptedData = Nothing+            , hpCurrentPathKey = Nothing+            , hpUnknownTlvs = []+            }+          payloadLen = BS.length hopPayloadTlv+          lenPrefix = encodeBigSize (fromIntegral payloadLen)+          payloadWithHmac = lenPrefix <> hopPayloadTlv+            <> BS.replicate 32 0x00+          padding = BS.replicate+            (1300 - BS.length payloadWithHmac) 0x00+          rawPayloads = payloadWithHmac <> padding+      ss <- demand "computeSharedSecret" $+        computeSharedSecret sessionKey hop0PubKey+      let rhoKey = deriveRho ss+          muKey = deriveMu ss+          stream = generateStream rhoKey 1300+          encryptedPayloads =+            BS.pack (BS.zipWith xor rawPayloads stream)+          correctHmac =+            computeHmac muKey encryptedPayloads BS.empty+          packet = OnionPacket+            { opVersion = 0x00+            , opEphemeralKey = ephKeyBytes+            , opHopPayloads = encryptedPayloads+            , opHmac = correctHmac+            }++      case process sessionKey packet BS.empty of+        Left err -> assertFailure $ "expected success, got: " ++ show err+        Right (Receive ri) -> do+          -- Verify we got the payload back+          hpAmtToForward (riPayload ri) @?= Just 1000+          hpOutgoingCltv (riPayload ri) @?= Just 500000+        Right (Forward _) -> assertFailure "expected Receive, got Forward"+  ]++-- 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+  ]++-- Blinding tests -----------------------------------------------------------++-- Test data setup++testSeed :: BS.ByteString+testSeed = BS.pack [1..32]++makeSecKey :: Word8 -> BS.ByteString+makeSecKey seed = BS.pack $ replicate 31 0x00 ++ [seed]++makePubKey :: Word8 -> Maybe Secp256k1.Projective+makePubKey seed = do+  sk <- Secp256k1.roll32 (makeSecKey seed)+  Secp256k1.derive_pub sk++testNodeSecKey1, testNodeSecKey2, testNodeSecKey3 :: BS.ByteString+testNodeSecKey1 = makeSecKey 0x11+testNodeSecKey2 = makeSecKey 0x22+testNodeSecKey3 = makeSecKey 0x33++testNodePubKey1, testNodePubKey2, testNodePubKey3 :: Secp256k1.Projective+testNodePubKey1 = case makePubKey 0x11 of+  Just pk -> pk+  Nothing -> error "testNodePubKey1: invalid key"+testNodePubKey2 = case makePubKey 0x22 of+  Just pk -> pk+  Nothing -> error "testNodePubKey2: invalid key"+testNodePubKey3 = case makePubKey 0x33 of+  Just pk -> pk+  Nothing -> error "testNodePubKey3: invalid key"++testSharedSecretBS :: SharedSecret+testSharedSecretBS = SharedSecret (BS.pack [0x42..0x61])++emptyHopData :: BlindedHopData+emptyHopData = BlindedHopData+  Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++sampleHopData :: BlindedHopData+sampleHopData = BlindedHopData+  { bhdPadding = Nothing+  , bhdShortChannelId = Just (ShortChannelId 700000 1234 0)+  , bhdNextNodeId = Nothing+  , bhdPathId = Just (BS.pack [0x42, 0x42])+  , bhdNextPathKeyOverride = Nothing+  , bhdPaymentRelay = Just (PaymentRelay 40 1000 500)+  , bhdPaymentConstraints = Just (PaymentConstraints 144 1000000)+  , bhdAllowedFeatures = Nothing+  }++hopDataWithNextNode :: BlindedHopData+hopDataWithNextNode = emptyHopData+  { bhdNextNodeId = Just (Secp256k1.serialize_point testNodePubKey2) }++-- 1. Key Derivation Tests --------------------------------------------------++blindingKeyDerivationTests :: TestTree+blindingKeyDerivationTests = testGroup "key derivation" [+    testCase "deriveBlindingRho produces 32 bytes" $ do+      let DerivedKey rho = deriveBlindingRho testSharedSecretBS+      BS.length rho @?= 32++  , testCase "deriveBlindingRho is deterministic" $ do+      let rho1 = deriveBlindingRho testSharedSecretBS+          rho2 = deriveBlindingRho testSharedSecretBS+      rho1 @?= rho2++  , testCase "deriveBlindingRho differs for different secrets" $ do+      let ss1 = SharedSecret (BS.replicate 32 0x00)+          ss2 = SharedSecret (BS.replicate 32 0x01)+          rho1 = deriveBlindingRho ss1+          rho2 = deriveBlindingRho ss2+      assertBool "rho values should differ" (rho1 /= rho2)++  , testCase "deriveBlindedNodeId produces 33 bytes" $ do+      case deriveBlindedNodeId testSharedSecretBS testNodePubKey1 of+        Nothing -> assertFailure "deriveBlindedNodeId returned Nothing"+        Just blindedId -> BS.length blindedId @?= 33++  , testCase "deriveBlindedNodeId is deterministic" $ do+      let result1 = deriveBlindedNodeId testSharedSecretBS testNodePubKey1+          result2 = deriveBlindedNodeId testSharedSecretBS testNodePubKey1+      result1 @?= result2++  , testCase "deriveBlindedNodeId differs for different nodes" $ do+      let result1 = deriveBlindedNodeId testSharedSecretBS testNodePubKey1+          result2 = deriveBlindedNodeId testSharedSecretBS testNodePubKey2+      assertBool "blinded node IDs should differ" (result1 /= result2)+  ]++-- 2. Ephemeral Key Iteration Tests -----------------------------------------++-- | Derive the public key for testSeed+testSeedPubKey :: Secp256k1.Projective+testSeedPubKey = case Secp256k1.roll32 testSeed of+  Nothing -> error "testSeedPubKey: invalid seed"+  Just sk -> case Secp256k1.derive_pub sk of+    Nothing -> error "testSeedPubKey: invalid key"+    Just pk -> pk++blindingEphemeralKeyTests :: TestTree+blindingEphemeralKeyTests = testGroup "ephemeral key iteration" [+    testCase "nextEphemeral produces valid keys" $ do+      -- Use matching secret/public key pair+      case nextEphemeral testSeed testSeedPubKey testSharedSecretBS of+        Nothing -> assertFailure "nextEphemeral returned Nothing"+        Just (newSecKey, newPubKey) -> do+          BS.length newSecKey @?= 32+          let serialized = Secp256k1.serialize_point newPubKey+          BS.length serialized @?= 33++  , testCase "nextEphemeral: new secret key derives new public key" $ do+      -- Use matching secret/public key pair+      case nextEphemeral testSeed testSeedPubKey testSharedSecretBS of+        Nothing -> assertFailure "nextEphemeral returned Nothing"+        Just (newSecKey, newPubKey) -> do+          sk <- demand "roll32" $ Secp256k1.roll32 newSecKey+          derivedPub <- demand "derive_pub" $+            Secp256k1.derive_pub sk+          derivedPub @?= newPubKey++  , testCase "nextEphemeral is deterministic" $ do+      let result1 = nextEphemeral testSeed testSeedPubKey testSharedSecretBS+          result2 = nextEphemeral testSeed testSeedPubKey testSharedSecretBS+      result1 @?= result2++  , testCase "nextEphemeral differs for different shared secrets" $ do+      let ss1 = SharedSecret (BS.replicate 32 0xAA)+          ss2 = SharedSecret (BS.replicate 32 0xBB)+          result1 = nextEphemeral testSeed testSeedPubKey ss1+          result2 = nextEphemeral testSeed testSeedPubKey ss2+      assertBool "results should differ" (result1 /= result2)+  ]++-- 3. TLV Encoding/Decoding Tests -------------------------------------------++blindingTlvTests :: TestTree+blindingTlvTests = testGroup "TLV encoding/decoding" [+    testCase "roundtrip: empty hop data" $ do+      let encoded = encodeBlindedHopData emptyHopData+          decoded = decodeBlindedHopData encoded+      decoded @?= Just emptyHopData++  , testCase "roundtrip: sample hop data" $ do+      let encoded = encodeBlindedHopData sampleHopData+          decoded = decodeBlindedHopData encoded+      decoded @?= Just sampleHopData++  , testCase "roundtrip: hop data with next node ID" $ do+      let encoded = encodeBlindedHopData hopDataWithNextNode+          decoded = decodeBlindedHopData encoded+      decoded @?= Just hopDataWithNextNode++  , testCase "roundtrip: hop data with padding" $ do+      let hopData = emptyHopData { bhdPadding = Just (BS.replicate 16 0x00) }+          encoded = encodeBlindedHopData hopData+          decoded = decodeBlindedHopData encoded+      decoded @?= Just hopData++  , testCase "PaymentRelay encoding/decoding" $ do+      let relay = PaymentRelay 40 1000 500+          hopData = emptyHopData { bhdPaymentRelay = Just relay }+          encoded = encodeBlindedHopData hopData+          decoded = decodeBlindedHopData encoded+      case decoded of+        Nothing -> assertFailure "decodeBlindedHopData returned Nothing"+        Just hd -> bhdPaymentRelay hd @?= Just relay++  , testCase "PaymentConstraints encoding/decoding" $ do+      let constraints = PaymentConstraints 144 1000000+          hopData = emptyHopData { bhdPaymentConstraints = Just constraints }+          encoded = encodeBlindedHopData hopData+          decoded = decodeBlindedHopData encoded+      case decoded of+        Nothing -> assertFailure "decodeBlindedHopData returned Nothing"+        Just hd -> bhdPaymentConstraints hd @?= Just constraints++  , testCase "decode empty bytestring returns empty hop data" $ do+      let decoded = decodeBlindedHopData BS.empty+      decoded @?= Just emptyHopData+  ]++-- 4. Encryption/Decryption Tests -------------------------------------------++blindingEncryptionTests :: TestTree+blindingEncryptionTests = testGroup "encryption/decryption" [+    testCase "roundtrip: encrypt then decrypt" $ do+      let rho = deriveBlindingRho testSharedSecretBS+          encrypted = encryptHopData rho sampleHopData+          decrypted = decryptHopData rho encrypted+      decrypted @?= Just sampleHopData++  , testCase "roundtrip: empty hop data" $ do+      let rho = deriveBlindingRho testSharedSecretBS+          encrypted = encryptHopData rho emptyHopData+          decrypted = decryptHopData rho encrypted+      decrypted @?= Just emptyHopData++  , testCase "decryption with wrong key fails" $ do+      let rho1 = deriveBlindingRho testSharedSecretBS+          rho2 = deriveBlindingRho (SharedSecret (BS.replicate 32 0xFF))+          encrypted = encryptHopData rho1 sampleHopData+          decrypted = decryptHopData rho2 encrypted+      assertBool "decryption should fail or produce garbage"+        (decrypted /= Just sampleHopData)++  , testCase "encrypt is deterministic" $ do+      let rho = deriveBlindingRho testSharedSecretBS+          encrypted1 = encryptHopData rho sampleHopData+          encrypted2 = encryptHopData rho sampleHopData+      encrypted1 @?= encrypted2+  ]++-- 5. createBlindedPath Tests -----------------------------------------------++blindingCreatePathTests :: TestTree+blindingCreatePathTests = testGroup "createBlindedPath" [+    testCase "create path with 2 hops" $ do+      let nodes = [(testNodePubKey1, emptyHopData),+                   (testNodePubKey2, sampleHopData)]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $ "createBlindedPath failed: " ++ show err+        Right path -> do+          length (bpBlindedHops path) @?= 2+          let serialized = Secp256k1.serialize_point (bpBlindingKey path)+          BS.length serialized @?= 33++  , testCase "create path with 3 hops" $ do+      let nodes = [ (testNodePubKey1, emptyHopData)+                  , (testNodePubKey2, hopDataWithNextNode)+                  , (testNodePubKey3, sampleHopData)+                  ]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $ "createBlindedPath failed: " ++ show err+        Right path -> length (bpBlindedHops path) @?= 3++  , testCase "all blinded node IDs are 33 bytes" $ do+      let nodes = [ (testNodePubKey1, emptyHopData)+                  , (testNodePubKey2, emptyHopData)+                  , (testNodePubKey3, emptyHopData)+                  ]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $ "createBlindedPath failed: " ++ show err+        Right path -> do+          let blindedIds = map bhBlindedNodeId (bpBlindedHops path)+          mapM_ (\bid -> BS.length bid @?= 33) blindedIds++  , testCase "empty path returns EmptyPath error" $ do+      case createBlindedPath testSeed [] of+        Left EmptyPath -> return ()+        Left err -> assertFailure $ "Expected EmptyPath, got: " ++ show err+        Right _ -> assertFailure "Expected error, got success"++  , testCase "invalid seed returns InvalidSeed error" $ do+      let invalidSeed = BS.pack [1..16]+          nodes = [(testNodePubKey1, emptyHopData)]+      case createBlindedPath invalidSeed nodes of+        Left InvalidSeed -> return ()+        Left err -> assertFailure $ "Expected InvalidSeed, got: " ++ show err+        Right _ -> assertFailure "Expected error, got success"++  , testCase "createBlindedPath is deterministic" $ do+      let nodes = [(testNodePubKey1, emptyHopData),+                   (testNodePubKey2, sampleHopData)]+          result1 = createBlindedPath testSeed nodes+          result2 = createBlindedPath testSeed nodes+      result1 @?= result2+  ]++-- 6. processBlindedHop Tests -----------------------------------------------++blindingProcessHopTests :: TestTree+blindingProcessHopTests = testGroup "processBlindedHop" [+    testCase "process first hop decrypts correctly" $ do+      let nodes = [(testNodePubKey1, sampleHopData),+                   (testNodePubKey2, emptyHopData)]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $ "createBlindedPath failed: " ++ show err+        Right path -> case bpBlindedHops path of+          firstHop : _ -> do+            let pathKey = bpBlindingKey path+            case processBlindedHop testNodeSecKey1 pathKey+                   (bhEncryptedData firstHop) of+              Left err -> assertFailure $+                "processBlindedHop failed: " ++ show err+              Right (decryptedData, _) ->+                decryptedData @?= sampleHopData+          [] -> assertFailure "expected non-empty hops"++  , testCase "process hop chain correctly" $ do+      let nodes = [ (testNodePubKey1, emptyHopData)+                  , (testNodePubKey2, sampleHopData)+                  , (testNodePubKey3, hopDataWithNextNode)+                  ]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $ "createBlindedPath failed: " ++ show err+        Right path -> case bpBlindedHops path of+          [hop1, hop2, hop3] -> do+            let pathKey1 = bpBlindingKey path+            case processBlindedHop testNodeSecKey1 pathKey1+                   (bhEncryptedData hop1) of+              Left err -> assertFailure $+                "processBlindedHop hop1 failed: " ++ show err+              Right (data1, pathKey2) -> do+                data1 @?= emptyHopData+                case processBlindedHop testNodeSecKey2 pathKey2+                       (bhEncryptedData hop2) of+                  Left err -> assertFailure $+                    "processBlindedHop hop2 failed: "+                      ++ show err+                  Right (data2, pathKey3) -> do+                    data2 @?= sampleHopData+                    case processBlindedHop testNodeSecKey3+                           pathKey3+                           (bhEncryptedData hop3) of+                      Left err -> assertFailure $+                        "processBlindedHop hop3 failed: "+                          ++ show err+                      Right (data3, _) ->+                        data3 @?= hopDataWithNextNode+          _ -> assertFailure "expected 3 blinded hops"++  , testCase "process hop with wrong node key fails" $ do+      let nodes = [(testNodePubKey1, sampleHopData)]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $+          "createBlindedPath failed: " ++ show err+        Right path -> case bpBlindedHops path of+          firstHop : _ -> do+            let pathKey = bpBlindingKey path+            case processBlindedHop testNodeSecKey2 pathKey+                   (bhEncryptedData firstHop) of+              Left _ -> return ()+              Right (decryptedData, _) ->+                assertBool "should not decrypt correctly"+                  (decryptedData /= sampleHopData)+          [] -> assertFailure "expected non-empty hops"++  , testCase "next path key is valid point" $ do+      let nodes = [(testNodePubKey1, emptyHopData),+                   (testNodePubKey2, emptyHopData)]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $+          "createBlindedPath failed: " ++ show err+        Right path -> case bpBlindedHops path of+          firstHop : _ -> do+            let pathKey = bpBlindingKey path+            case processBlindedHop testNodeSecKey1 pathKey+                   (bhEncryptedData firstHop) of+              Left err -> assertFailure $+                "processBlindedHop failed: " ++ show err+              Right (_, nextPathKey) -> do+                let serialized =+                      Secp256k1.serialize_point nextPathKey+                BS.length serialized @?= 33+          [] -> assertFailure "expected non-empty hops"++  , testCase "next_path_key_override is used when present" $ do+      let overrideKey = Secp256k1.serialize_point testNodePubKey3+          hopDataWithOverride' = emptyHopData+            { bhdNextPathKeyOverride = Just overrideKey }+          nodes = [(testNodePubKey1, hopDataWithOverride'),+                   (testNodePubKey2, emptyHopData)]+      case createBlindedPath testSeed nodes of+        Left err -> assertFailure $+          "createBlindedPath failed: " ++ show err+        Right path -> case bpBlindedHops path of+          firstHop : _ -> do+            let pathKey = bpBlindingKey path+            case processBlindedHop testNodeSecKey1 pathKey+                   (bhEncryptedData firstHop) of+              Left err -> assertFailure $+                "processBlindedHop failed: " ++ show err+              Right (decryptedData, nextPathKey) -> do+                bhdNextPathKeyOverride decryptedData+                  @?= Just overrideKey+                nextPathKey @?= testNodePubKey3+          [] -> assertFailure "expected non-empty hops"+  ]