diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +# Changelog + +- 0.0.1 (UNRELEASED) + * Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Criterion.Main + +main :: IO () +main = defaultMain [ + ] diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Weigh + +main :: IO () +main = mainWith (pure ()) diff --git a/lib/Lightning/Protocol/BOLT4.hs b/lib/Lightning/Protocol/BOLT4.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module: Lightning.Protocol.BOLT4 +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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 diff --git a/lib/Lightning/Protocol/BOLT4/Blinding.hs b/lib/Lightning/Protocol/BOLT4/Blinding.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Blinding.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Lightning/Protocol/BOLT4/Codec.hs b/lib/Lightning/Protocol/BOLT4/Codec.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Codec.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Lightning/Protocol/BOLT4/Construct.hs b/lib/Lightning/Protocol/BOLT4/Construct.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Construct.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Lightning/Protocol/BOLT4/Error.hs b/lib/Lightning/Protocol/BOLT4/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Error.hs @@ -0,0 +1,223 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Lightning.Protocol.BOLT4.Error +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Error packet construction and unwrapping for BOLT4 onion routing. +-- +-- Failing nodes construct error packets that are wrapped at each +-- intermediate hop on the return path. The origin node unwraps +-- layers to attribute the error to a specific hop. + +module Lightning.Protocol.BOLT4.Error ( + -- * Types + ErrorPacket(..) + , AttributionResult(..) + , minErrorPacketSize + + -- * Error construction (failing node) + , constructError + + -- * Error forwarding (intermediate node) + , wrapError + + -- * Error unwrapping (origin node) + , unwrapError + ) where + +import Data.Bits (xor) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BL +import qualified Crypto.Hash.SHA256 as SHA256 +import Data.Word (Word8, Word16) +import Lightning.Protocol.BOLT4.Codec (encodeFailureMessage, decodeFailureMessage) +import Lightning.Protocol.BOLT4.Prim +import Lightning.Protocol.BOLT4.Types (FailureMessage) + +-- | Wrapped error packet ready for return to origin. +newtype ErrorPacket = ErrorPacket BS.ByteString + deriving (Eq, Show) + +-- | Result of error attribution. +data AttributionResult + = Attributed {-# UNPACK #-} !Int !FailureMessage + -- ^ (hop index, failure) + | UnknownOrigin !BS.ByteString + -- ^ Could not attribute to any hop + deriving (Eq, Show) + +-- | Minimum error packet size (256 bytes per spec). +minErrorPacketSize :: Int +minErrorPacketSize = 256 +{-# INLINE minErrorPacketSize #-} + +-- Error construction --------------------------------------------------------- + +-- | Construct an error packet at a failing node. +-- +-- Takes the shared secret (from processing) and failure message, +-- and wraps it for return to origin. +constructError + :: SharedSecret -- ^ from packet processing + -> FailureMessage -- ^ failure details + -> ErrorPacket +constructError !ss !failure = + let !um = deriveUm ss + !ammag = deriveAmmag ss + !inner = buildErrorMessage um failure + !obfuscated = obfuscateError ammag inner + in ErrorPacket obfuscated +{-# INLINE constructError #-} + +-- | Wrap an existing error packet for forwarding back. +-- +-- Each intermediate node wraps the error with its own layer. +wrapError + :: SharedSecret -- ^ this node's shared secret + -> ErrorPacket -- ^ error from downstream + -> ErrorPacket +wrapError !ss (ErrorPacket !packet) = + let !ammag = deriveAmmag ss + !wrapped = obfuscateError ammag packet + in ErrorPacket wrapped +{-# INLINE wrapError #-} + +-- Error unwrapping ----------------------------------------------------------- + +-- | Attempt to attribute an error to a specific hop. +-- +-- Takes the shared secrets from original packet construction +-- (in order from first hop to final) and the error packet. +-- +-- Tries each hop's keys until HMAC verifies, revealing origin. +unwrapError + :: [SharedSecret] -- ^ secrets from construction, in route order + -> ErrorPacket -- ^ received error + -> AttributionResult +unwrapError secrets (ErrorPacket !initialPacket) = go 0 initialPacket secrets + where + go :: Int -> BS.ByteString -> [SharedSecret] -> AttributionResult + go !_ !packet [] = UnknownOrigin packet + go !idx !packet (ss:rest) = + let !ammag = deriveAmmag ss + !um = deriveUm ss + !deobfuscated = deobfuscateError ammag packet + in if verifyErrorHmac um deobfuscated + then case parseErrorMessage (BS.drop 32 deobfuscated) of + Just msg -> Attributed idx msg + Nothing -> UnknownOrigin deobfuscated + else go (idx + 1) deobfuscated rest + +-- Internal functions --------------------------------------------------------- + +-- | Build the inner error message structure. +-- +-- Format: HMAC (32) || len (2) || message || pad_len (2) || padding +-- Total must be >= 256 bytes. +buildErrorMessage + :: DerivedKey -- ^ um key + -> FailureMessage -- ^ failure to encode + -> BS.ByteString -- ^ complete message with HMAC +buildErrorMessage (DerivedKey !umKey) !failure = + let !encoded = encodeFailureMessage failure + !msgLen = BS.length encoded + -- Total payload: len(2) + msg + pad_len(2) + padding = 256 - 32 = 224 + -- padding = 224 - 2 - msgLen - 2 = 220 - msgLen + !padLen = max 0 (minErrorPacketSize - 32 - 2 - msgLen - 2) + !padding = BS.replicate padLen 0 + -- Build: len || message || pad_len || padding + !payload = toStrict $ + B.word16BE (fromIntegral msgLen) <> + B.byteString encoded <> + B.word16BE (fromIntegral padLen) <> + B.byteString padding + -- HMAC over the payload + SHA256.MAC !hmac = SHA256.hmac umKey payload + in hmac <> payload +{-# INLINE buildErrorMessage #-} + +-- | Obfuscate error packet with ammag stream. +-- +-- XORs the entire packet with pseudo-random stream. +obfuscateError + :: DerivedKey -- ^ ammag key + -> BS.ByteString -- ^ error packet + -> BS.ByteString -- ^ obfuscated packet +obfuscateError !ammag !packet = + let !stream = generateStream ammag (BS.length packet) + in xorBytes packet stream +{-# INLINE obfuscateError #-} + +-- | Remove one layer of obfuscation from error packet. +-- +-- XOR is its own inverse, so same as obfuscation. +deobfuscateError + :: DerivedKey -- ^ ammag key + -> BS.ByteString -- ^ obfuscated packet + -> BS.ByteString -- ^ deobfuscated packet +deobfuscateError = obfuscateError +{-# INLINE deobfuscateError #-} + +-- | Verify error HMAC after deobfuscation. +verifyErrorHmac + :: DerivedKey -- ^ um key + -> BS.ByteString -- ^ deobfuscated packet (HMAC || rest) + -> Bool +verifyErrorHmac (DerivedKey !umKey) !packet + | BS.length packet < 32 = False + | otherwise = + let !receivedHmac = BS.take 32 packet + !payload = BS.drop 32 packet + SHA256.MAC !computedHmac = SHA256.hmac umKey payload + in constantTimeEq receivedHmac computedHmac +{-# INLINE verifyErrorHmac #-} + +-- | Parse error message from deobfuscated packet (after HMAC). +parseErrorMessage + :: BS.ByteString -- ^ packet after HMAC (len || msg || pad_len || pad) + -> Maybe FailureMessage +parseErrorMessage !bs + | BS.length bs < 4 = Nothing + | otherwise = + let !msgLen = fromIntegral (word16BE (BS.take 2 bs)) + in if BS.length bs < 2 + msgLen + then Nothing + else decodeFailureMessage (BS.take msgLen (BS.drop 2 bs)) +{-# INLINE parseErrorMessage #-} + +-- Helper functions ----------------------------------------------------------- + +-- | XOR two ByteStrings of equal length. +xorBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString +xorBytes !a !b = BS.pack $ BS.zipWith xor a b +{-# INLINE xorBytes #-} + +-- | Constant-time equality comparison. +constantTimeEq :: BS.ByteString -> BS.ByteString -> Bool +constantTimeEq !a !b + | BS.length a /= BS.length b = False + | otherwise = go 0 (BS.zip a b) + where + go :: Word8 -> [(Word8, Word8)] -> Bool + go !acc [] = acc == 0 + go !acc ((x, y):rest) = go (acc `xor` (x `xor` y)) rest +{-# INLINE constantTimeEq #-} + +-- | Decode big-endian Word16. +word16BE :: BS.ByteString -> Word16 +word16BE !bs = + let !b0 = fromIntegral (BS.index bs 0) :: Word16 + !b1 = fromIntegral (BS.index bs 1) :: Word16 + in (b0 * 256) + b1 +{-# INLINE word16BE #-} + +-- | Convert Builder to strict ByteString. +toStrict :: B.Builder -> BS.ByteString +toStrict = BL.toStrict . B.toLazyByteString +{-# INLINE toStrict #-} diff --git a/lib/Lightning/Protocol/BOLT4/Prim.hs b/lib/Lightning/Protocol/BOLT4/Prim.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Prim.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Lightning/Protocol/BOLT4/Process.hs b/lib/Lightning/Protocol/BOLT4/Process.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Process.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Lightning/Protocol/BOLT4/Types.hs b/lib/Lightning/Protocol/BOLT4/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Lightning/Protocol/BOLT4/Types.hs @@ -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 +-- +-- 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 diff --git a/ppad-bolt4.cabal b/ppad-bolt4.cabal new file mode 100644 --- /dev/null +++ b/ppad-bolt4.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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" + ]