commit bba3bab650ff572546b91c3d3330203a259331a5
parent 568a16319d667b7ccdfcf0c4a8dcf19a963039be
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 14:53:56 +0400
lib: port to ppad-bolt1 0.1 and redesign the public API
Expose a single public module, Lightning.Protocol.BOLT4, built on the
types and TLV machinery of ppad-bolt1 and ppad-bolt9:
- secret keys (SecretKey, exactly 32 bytes in [1, n - 1]) and shared
secrets are abstract, with redacted Show and constant-time Eq; derived
keys and blinding factors are internal, so keystream generation can't
be fed a bad key
- points are bolt1 Points at the API boundary; amounts are bolt1
MilliSatoshis; allowed_features is a bolt9 FeatureVector
- the private BigSize, TLV, truncated-integer and SCID codecs are gone;
HopPayload and BlindedHopData decode with bolt1's TLV stream, reject
unknown even types and keep unknown odd ones, and payment_metadata
and total_amount_msat are typed fields
- process takes the path_key received with an onion, derives the
blinded private key, decrypts encrypted_recipient_data (with path_key
or current_path_key) and returns its contents and the next path key;
the HMAC check is constant time
- failures are a typed sum of every failure code in the spec (adding
required_channel_feature_missing, unknown_next_peer and
invalid_onion_blinding, dropping invalid_realm), with an escape hatch
for unknown codes and derivable flags
- unwrap_error reports the hop whose HMAC matches even when its failure
message is malformed
- NFData instances for every public type
Diffstat:
10 files changed, 1639 insertions(+), 2007 deletions(-)
diff --git a/lib/Lightning/Protocol/BOLT4.hs b/lib/Lightning/Protocol/BOLT4.hs
@@ -1,5 +1,4 @@
{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE PatternSynonyms #-}
-- |
-- Module: Lightning.Protocol.BOLT4
@@ -7,84 +6,147 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- BOLT4 onion routing for the Lightning Network.
+-- Onion routing for the Lightning Network, per BOLT #4
+-- (<https://github.com/lightning/bolts/blob/master/04-onion-routing.md>):
+-- onion construction and processing, returning errors, and route
+-- blinding.
--
--- This module re-exports the public interface from submodules.
+-- The examples below assume:
+--
+-- >>> :set -XOverloadedStrings
+-- >>> import qualified Data.ByteString as BS
+-- >>> import qualified Lightning.Protocol.BOLT1 as BOLT1
+-- >>> import Lightning.Protocol.BOLT4
+--
+-- Construct a two-hop onion:
+--
+-- >>> let Just session = secret_key (BS.replicate 32 0x41)
+-- >>> let Just alice = secret_key (BS.replicate 32 0x42)
+-- >>> let Just bob = secret_key (BS.replicate 32 0x43)
+-- >>> let Just scid = BOLT1.short_channel_id 800000 1 0
+-- >>> let Just amt = BOLT1.milli_satoshi 100000
+-- >>> :{
+-- let alice_payload = empty_hop_payload {
+-- hp_amt_to_forward = Just amt
+-- , hp_outgoing_cltv_value = Just 800040
+-- , hp_short_channel_id = Just scid
+-- }
+-- bob_payload = empty_hop_payload {
+-- hp_amt_to_forward = Just amt
+-- , hp_outgoing_cltv_value = Just 800000
+-- }
+-- route = [ Hop (public_key alice) alice_payload
+-- , Hop (public_key bob) bob_payload ]
+-- payment_hash = BS.replicate 32 0xff
+-- :}
+-- >>> let Right (onion, secrets) = construct session route payment_hash
+--
+-- Process it at each hop:
+--
+-- >>> let Right (Forward fwd) = process alice onion payment_hash Nothing
+-- >>> hp_short_channel_id (fwd_payload fwd) == Just scid
+-- True
+-- >>> let next = fwd_next_packet fwd
+-- >>> let Right (Receive rcv) = process bob next payment_hash Nothing
+-- >>> hp_outgoing_cltv_value (rcv_payload rcv)
+-- Just 800000
+--
+-- Fail at the final hop, wrap the error at the first, and attribute it
+-- at the origin:
+--
+-- >>> let tlvs = BOLT1.empty_tlv_stream
+-- >>> let failure = FailureMessage TemporaryNodeFailure tlvs
+-- >>> let Right err = construct_error (rcv_shared_secret rcv) failure
+-- >>> let returned = wrap_error (fwd_shared_secret fwd) err
+-- >>> unwrap_error secrets returned == Attributed 1 failure
+-- True
module Lightning.Protocol.BOLT4 (
- -- * Re-exports
- module Lightning.Protocol.BOLT4.Blinding
- , module Lightning.Protocol.BOLT4.Codec
- , module Lightning.Protocol.BOLT4.Prim
+ -- * Keys
+ SecretKey
+ , secret_key
+ , public_key
+ , SharedSecret
+ , shared_secret
+ , un_shared_secret
- -- * Fixed-size newtypes
+ -- * Onion packets
+ , OnionPacket(..)
+ , HopPayloads
+ , hop_payloads
+ , un_hop_payloads
, Hmac32
, hmac32
- , unHmac32
- , HopPayloads
- , hopPayloads
- , unHopPayloads
- , PaymentSecret
- , paymentSecret
- , unPaymentSecret
+ , un_hmac32
+ , encode_onion_packet
+ , decode_onion_packet
- -- * Packet types
- , OnionPacket(..)
+ -- * Hop payloads
, HopPayload(..)
- , ShortChannelId(..)
- , shortChannelId
- , scidBlockHeight
- , scidTxIndex
- , scidOutputIndex
- , scidWord64
+ , empty_hop_payload
, PaymentData(..)
- , TlvRecord(..)
+ , PaymentSecret
+ , payment_secret
+ , un_payment_secret
+ , encode_hop_payload
+ , decode_hop_payload
- -- * 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
+ -- * Constructing onions
+ , Hop(..)
+ , construct
+ , ConstructError(..)
- -- * Processing results
+ -- * Processing onions
+ , process
, ProcessResult(..)
, ForwardInfo(..)
, ReceiveInfo(..)
+ , BlindedInfo(..)
+ , ProcessError(..)
+
+ -- * Route blinding
+ , BlindedPath(..)
+ , BlindedHop(..)
+ , create_blinded_path
+ , BlindingError(..)
+ , decrypt_recipient_data
+ , BlindedHopData(..)
+ , empty_blinded_hop_data
+ , PaymentRelay(..)
+ , PaymentConstraints(..)
+ , encode_blinded_hop_data
+ , decode_blinded_hop_data
+
+ -- * Failure messages
+ , FailureMessage(..)
+ , Failure(..)
+ , OnionHash
+ , onion_hash
+ , un_onion_hash
+ , failure_code
+ , is_badonion
+ , is_perm
+ , is_node
+ , is_update
+ , encode_failure_message
+ , decode_failure_message
+
+ -- * Returning errors
+ , ErrorPacket(..)
+ , construct_error
+ , wrap_error
+ , unwrap_error
+ , Attribution(..)
- -- * Constants
- , onionPacketSize
- , hopPayloadsSize
- , hmacSize
- , pubkeySize
- , versionByte
- , maxPayloadSize
+ -- * Encoding errors
+ , DecodeError(..)
+ , EncodeError(..)
) where
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
diff --git a/lib/Lightning/Protocol/BOLT4/Blinding.hs b/lib/Lightning/Protocol/BOLT4/Blinding.hs
@@ -1,6 +1,5 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module: Lightning.Protocol.BOLT4.Blinding
@@ -8,395 +7,137 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Route blinding for BOLT4 onion routing.
+-- Route blinding.
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
+ BlindingError(..)
+ , create_blinded_path
+ , decrypt_recipient_data
+ , unblind
) where
+import Control.DeepSeq (NFData)
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 GHC.Generics (Generic)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
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)
+import Lightning.Protocol.BOLT4.Prim
+import Lightning.Protocol.BOLT4.Types
--- | 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.
+-- | Why a blinded route could not be created.
data BlindingError
- = InvalidSeed
- | EmptyPath
- | InvalidNodeKey Int
- | DecryptionFailed
- | InvalidPathKey
- deriving (Eq, Show)
-
--- Key derivation ------------------------------------------------------------
-
--- | Derive rho key for encrypting hop data.
+ = EmptyPath
+ -- ^ the route has no hops
+ | InvalidNodeId {-# UNPACK #-} !Int
+ -- ^ the node id of the hop with this index is not a valid point
+ | InvalidHopData {-# UNPACK #-} !Int !EncodeError
+ -- ^ the data of the hop with this index can't be encoded
+ deriving (Eq, Show, Generic)
+
+instance NFData BlindingError
+
+-- | Create a blinded route to oneself, given a seed for the route's
+-- ephemeral keys (which must be fresh and random for every route) and
+-- each node's id and data, from the introduction node to oneself.
--
--- @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@
---
--- Returns 'Nothing' if the secret key is not 32 bytes.
-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)
- | BS.length secKey /= 32 = Nothing
- | otherwise = 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.
---
--- Returns 'Nothing' if encryption fails (e.g. the key is not 32
--- bytes).
-encryptHopData :: DerivedKey -> BlindedHopData -> Maybe 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 _ -> Nothing
- Right (!ciphertext, !mac) -> Just (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.
---
--- Fails on unknown even TLV types; unknown odd types are skipped.
-decodeBlindedHopData :: BS.ByteString -> Maybe BlindedHopData
-decodeBlindedHopData !bs = do
- tlvs <- decodeTlvStream bs
- parseBlindedHopData tlvs
-
-parseBlindedHopData :: [TlvRecord] -> Maybe BlindedHopData
-parseBlindedHopData = go emptyHopData
+-- >>> let Just seed = secret_key (BS.replicate 32 0x01)
+-- >>> let Just me = secret_key (BS.replicate 32 0x45)
+-- >>> let dat = empty_blinded_hop_data { bhd_path_id = Just "deadbeef" }
+-- >>> let Right path = create_blinded_path seed [(public_key me, dat)]
+-- >>> bp_first_node_id path == public_key me
+-- True
+-- >>> length (bp_hops path)
+-- 1
+create_blinded_path
+ :: SecretKey
+ -> [(BOLT1.Point, BlindedHopData)]
+ -> Either BlindingError BlindedPath
+create_blinded_path seed nodes = case nodes of
+ [] -> Left EmptyPath
+ (intro, _) : _ -> do
+ hops <- go (sk_bytes seed) (sk_pub seed) (zip [0 ..] nodes)
+ pure (BlindedPath intro (public_key seed) hops)
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
- _ | even typ -> Nothing
- | otherwise -> go bhd rest
-
--- 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.
+ go _ _ [] = Right []
+ go e epub ((i, (nid, dat)) : rest) = do
+ let note = maybe (Left (InvalidNodeId i)) Right
+ node <- note (from_point nid)
+ ss <- note (ecdh e node)
+ bid <- note (blind_pub node (blinded_node_tweak ss) >>= to_point)
+ plain <- either (Left . InvalidHopData i) Right
+ (encode_blinded_hop_data dat)
+ enc <- maybe (Left (InvalidHopData i FieldTooLong)) Right
+ (encrypt (derive_rho ss) plain)
+ let hop = BlindedHop bid enc
+ case rest of
+ [] -> Right [hop]
+ _ -> do
+ let bf = blinding_factor epub ss
+ e' <- note (blind_scalar e bf)
+ epub' <- note (blind_pub epub bf)
+ (hop :) <$> go e' epub' rest
+
+-- | Decrypt the @encrypted_recipient_data@ received by a node in a
+-- blinded route, given the node's private key and the path key it
+-- received.
--
--- 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)
- encData <- maybe (Left (InvalidNodeKey idx)) Right
- (encryptHopData rho hopData)
- let !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.
+-- Returns the decrypted data and the path key for the next node (the
+-- data's @next_path_key_override@, if present).
+-- 'Lightning.Protocol.BOLT4.process' does this for payment onions.
--
--- 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 #-}
+-- >>> let Just seed = secret_key (BS.replicate 32 0x01)
+-- >>> let Just me = secret_key (BS.replicate 32 0x45)
+-- >>> let dat = empty_blinded_hop_data { bhd_path_id = Just "deadbeef" }
+-- >>> let Right path = create_blinded_path seed [(public_key me, dat)]
+-- >>> let [hop] = bp_hops path
+-- >>> let pk = bp_first_path_key path
+-- >>> let Right info = decrypt_recipient_data me pk (bh_encrypted_data hop)
+-- >>> bhd_path_id (bi_data info)
+-- Just "deadbeef"
+decrypt_recipient_data
+ :: SecretKey
+ -> BOLT1.Point
+ -> BS.ByteString
+ -> Either ProcessError BlindedInfo
+decrypt_recipient_data sk pk enc = do
+ e <- maybe (Left InvalidPathKey) Right (from_point pk)
+ ss <- maybe (Left InvalidPathKey) Right (ecdh (sk_bytes sk) e)
+ unblind ss e enc
+
+-- Decrypt encrypted_recipient_data, given the shared secret with the path
+-- key, and the path key.
+unblind
+ :: SharedSecret
+ -> Secp256k1.Projective
+ -> BS.ByteString
+ -> Either ProcessError BlindedInfo
+unblind ss e enc = do
+ plain <- maybe (Left InvalidRecipientData) Right
+ (decrypt (derive_rho ss) enc)
+ dat <- either (const (Left InvalidRecipientData)) Right
+ (decode_blinded_hop_data plain)
+ next <- case bhd_next_path_key_override dat of
+ Just o -> Right o
+ Nothing -> maybe (Left InvalidPathKey) Right
+ (blind_pub e (blinding_factor e ss) >>= to_point)
+ pure (BlindedInfo dat next)
+
+-- ChaCha20-Poly1305 with an all-zero nonce and no associated data; the
+-- tag follows the ciphertext. Fails only on counter overflow.
+encrypt :: DerivedKey -> BS.ByteString -> Maybe BS.ByteString
+encrypt k plain =
+ case AEAD.encrypt BS.empty (un_derived_key k) (BS.replicate 12 0) plain of
+ Right (c, t) -> Just (c <> t)
+ Left _ -> Nothing
+
+decrypt :: DerivedKey -> BS.ByteString -> Maybe BS.ByteString
+decrypt k enc
+ | BS.length enc < 16 = Nothing
+ | otherwise =
+ let (c, t) = BS.splitAt (BS.length enc - 16) enc
+ in case AEAD.decrypt BS.empty (un_derived_key k) (BS.replicate 12 0)
+ (c, t) of
+ Right p -> Just p
+ Left _ -> Nothing
diff --git a/lib/Lightning/Protocol/BOLT4/Codec.hs b/lib/Lightning/Protocol/BOLT4/Codec.hs
@@ -1,6 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module: Lightning.Protocol.BOLT4.Codec
@@ -8,433 +6,346 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Serialization and deserialization for BOLT4 types.
+-- Encodings of the BOLT #4 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
+ encode_onion_packet
+ , decode_onion_packet
+ , encode_hop_payload
+ , decode_hop_payload
+ , encode_blinded_hop_data
+ , decode_blinded_hop_data
+ , encode_failure_message
+ , decode_failure_message
) where
-import Data.Bits (shiftL)
+import Data.Bifunctor (first)
import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as B
-import qualified Data.ByteString.Lazy as BL
-import Data.Maybe (fromMaybe)
-import Data.Word (Word16, Word32, Word64)
+import Data.Maybe (catMaybes)
+import Data.Word (Word16, Word64)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT4.Types
+import qualified Lightning.Protocol.BOLT9 as BOLT9
--- BigSize encoding ---------------------------------------------------------
+-- onion packets --------------------------------------------------------------
--- | Encode integer as BigSize.
+-- | Encode an 'OnionPacket' (1366 bytes).
--
--- * 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
- -- compare in Word64 so that large lengths cannot wrap
- if len > fromIntegral (BS.length r2)
- then Nothing
- else do
- let !len' = fromIntegral len
- !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 (unHopPayloads payloads) <>
- B.byteString (unHmac32 mac)
-{-# INLINE encodeOnionPacket #-}
-
--- | Parse OnionPacket from 1366 bytes.
-decodeOnionPacket :: BS.ByteString -> Maybe OnionPacket
-decodeOnionPacket !bs
- | BS.length bs /= onionPacketSize = Nothing
- | otherwise = do
- let !ver = BS.index bs 0
- !eph = BS.take pubkeySize (BS.drop 1 bs)
- !payloadsRaw = BS.take hopPayloadsSize
- (BS.drop (1 + pubkeySize) bs)
- !macRaw = BS.drop
- (1 + pubkeySize + hopPayloadsSize) bs
- hp <- hopPayloads payloadsRaw
- hm <- hmac32 macRaw
- Just (OnionPacket ver eph hp hm)
-{-# INLINE decodeOnionPacket #-}
-
--- | Encode HopPayload to bytes (without length prefix).
-encodeHopPayload :: HopPayload -> BS.ByteString
-encodeHopPayload !hp = encodeTlvStream (buildTlvs hp)
+-- >>> let Just pk = BOLT1.point (BS.cons 0x02 (BS.replicate 32 0x01))
+-- >>> let Just hp = hop_payloads (BS.replicate 1300 0)
+-- >>> let Just mac = hmac32 (BS.replicate 32 0)
+-- >>> BS.length (encode_onion_packet (OnionPacket 0 pk hp mac))
+-- 1366
+encode_onion_packet :: OnionPacket -> BS.ByteString
+encode_onion_packet (OnionPacket v k hp mac) = BS.concat
+ [BS.singleton v, BOLT1.un_point k, un_hop_payloads hp, un_hmac32 mac]
+
+-- | Decode an 'OnionPacket' from exactly 1366 bytes. The public key must
+-- carry a compressed-encoding prefix; the version byte is not checked
+-- (see 'Lightning.Protocol.BOLT4.process').
+--
+-- >>> decode_onion_packet (BS.replicate 1365 0)
+-- Left InvalidLength
+decode_onion_packet :: BS.ByteString -> Either DecodeError OnionPacket
+decode_onion_packet bs = case BS.uncons bs of
+ Just (v, rest) | BS.length bs == 1366 -> do
+ let (k, r0) = BS.splitAt 33 rest
+ (hp, mac) = BS.splitAt 1300 r0
+ pk <- maybe (Left InvalidPoint) Right (BOLT1.point k)
+ pure (OnionPacket v pk (HopPayloads hp) (Hmac32 mac))
+ _ -> Left InvalidLength
+
+-- TLV helpers ----------------------------------------------------------------
+
+-- encode typed records with extra ones, none of which may have a known
+-- type
+encode_tlvs
+ :: [Word64]
+ -> [BOLT1.TlvRecord]
+ -> BOLT1.TlvStream
+ -> Either EncodeError BS.ByteString
+encode_tlvs known typed extra
+ | any ((`elem` known) . BOLT1.tlv_type) ex = Left ConflictingTlv
+ | otherwise = case BOLT1.tlv_stream (typed ++ ex) of
+ Nothing -> Left ConflictingTlv
+ Just s -> Right (BOLT1.encode_tlv_stream s)
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.
+ ex = BOLT1.un_tlv_stream extra
+
+record :: Word64 -> (a -> BS.ByteString) -> Maybe a -> Maybe BOLT1.TlvRecord
+record t f = fmap (BOLT1.TlvRecord t . f)
+
+-- decode a TLV stream with the given known types
+decode_tlvs :: [Word64] -> BS.ByteString -> Either DecodeError BOLT1.TlvStream
+decode_tlvs known =
+ first InvalidTlvStream . BOLT1.decode_tlv_stream (`elem` known)
+
+-- parse the value of a record, if present
+field
+ :: Word64
+ -> (BS.ByteString -> Maybe a)
+ -> BOLT1.TlvStream
+ -> Either DecodeError (Maybe a)
+field t p s = case BOLT1.lookup_tlv t s of
+ Nothing -> Right Nothing
+ Just v -> maybe (Left (InvalidTlvValue t)) (Right . Just) (p v)
+
+-- the unknown records of a stream
+extra_tlvs :: [Word64] -> BOLT1.TlvStream -> BOLT1.TlvStream
+extra_tlvs known = BOLT1.filter_tlv_stream (`notElem` known)
+
+-- a decoder that must consume its whole input
+whole
+ :: (BS.ByteString -> Maybe (a, BS.ByteString))
+ -> BS.ByteString
+ -> Maybe a
+whole d bs = case d bs of
+ Just (a, r) | BS.null r -> Just a
+ _ -> Nothing
+
+encode_tu_msat :: BOLT1.MilliSatoshi -> BS.ByteString
+encode_tu_msat = BOLT1.encode_tu64 . BOLT1.un_milli_satoshi
+
+decode_tu_msat :: BS.ByteString -> Maybe BOLT1.MilliSatoshi
+decode_tu_msat v = BOLT1.decode_tu64 v >>= BOLT1.milli_satoshi
+
+-- hop payloads ---------------------------------------------------------------
+
+hop_payload_types :: [Word64]
+hop_payload_types = [2, 4, 6, 8, 10, 12, 16, 18]
+
+-- | Encode a 'HopPayload' as a @payload@ TLV stream (without its length
+-- prefix). Fails if 'hp_extra' has a record of a known type.
--
--- Fails on unknown even TLV types. Types 16 (payment_metadata) and 18
--- (total_amount_msat) are accepted and kept, with unknown odd types,
--- in 'hpUnknownTlvs'.
-decodeHopPayload :: BS.ByteString -> Maybe HopPayload
-decodeHopPayload !bs = do
- tlvs <- decodeTlvStream bs
- parseHopPayload tlvs
-
-parseHopPayload :: [TlvRecord] -> Maybe HopPayload
-parseHopPayload = go emptyHop
+-- >>> let hp = empty_hop_payload { hp_outgoing_cltv_value = Just 144 }
+-- >>> encode_hop_payload hp
+-- Right "\EOT\SOH\144"
+encode_hop_payload :: HopPayload -> Either EncodeError BS.ByteString
+encode_hop_payload hp = encode_tlvs hop_payload_types typed (hp_extra hp)
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
- _ | even typ && typ /= 16 && typ /= 18 -> Nothing
- | otherwise ->
- go hp { hpUnknownTlvs = TlvRecord typ val : hpUnknownTlvs hp }
- rest
-
--- ShortChannelId -----------------------------------------------------------
-
--- | Encode ShortChannelId to 8 bytes big-endian.
-encodeShortChannelId :: ShortChannelId -> BS.ByteString
-encodeShortChannelId !sci = toStrict (B.word64BE (scidWord64 sci))
-{-# INLINE encodeShortChannelId #-}
-
--- | Decode ShortChannelId from 8 bytes big-endian.
-decodeShortChannelId :: BS.ByteString -> Maybe ShortChannelId
-decodeShortChannelId !bs
- | BS.length bs /= 8 = Nothing
- | otherwise =
- let !w = (fromIntegral (BS.index bs 0) `shiftL` 56)
- + (fromIntegral (BS.index bs 1) `shiftL` 48)
- + (fromIntegral (BS.index bs 2) `shiftL` 40)
- + (fromIntegral (BS.index bs 3) `shiftL` 32)
- + (fromIntegral (BS.index bs 4) `shiftL` 24)
- + (fromIntegral (BS.index bs 5) `shiftL` 16)
- + (fromIntegral (BS.index bs 6) `shiftL` 8)
- + fromIntegral (BS.index bs 7) :: Word64
- in Just (ShortChannelId w)
-{-# INLINE decodeShortChannelId #-}
-
--- Failure messages ---------------------------------------------------------
-
--- | Encode failure message.
+ typed = catMaybes
+ [ record 2 encode_tu_msat (hp_amt_to_forward hp)
+ , record 4 BOLT1.encode_tu32 (hp_outgoing_cltv_value hp)
+ , record 6 BOLT1.encode_short_channel_id (hp_short_channel_id hp)
+ , record 8 encode_payment_data (hp_payment_data hp)
+ , record 10 id (hp_encrypted_data hp)
+ , record 12 BOLT1.un_point (hp_current_path_key hp)
+ , record 16 id (hp_payment_metadata hp)
+ , record 18 encode_tu_msat (hp_total_amount_msat hp)
+ ]
+
+-- | Decode a @payload@ TLV stream (without its length prefix). Fails on
+-- a malformed stream, an unknown even type, or a malformed known
+-- record.
--
--- Format: u16 failure_code || data || optional TLV stream. The data
--- must already be laid out as the failure code requires.
-encodeFailureMessage :: FailureMessage -> BS.ByteString
-encodeFailureMessage (FailureMessage (FailureCode !code) !dat !tlvs) =
- toStrict $
- B.word16BE code <>
- B.byteString dat <>
- B.byteString (encodeTlvStream tlvs)
-{-# INLINE encodeFailureMessage #-}
-
--- | Decode failure message.
+-- >>> fmap hp_outgoing_cltv_value (decode_hop_payload "\EOT\SOH\144")
+-- Right (Just 144)
+-- >>> decode_hop_payload "\DC4\NUL"
+-- Left (InvalidTlvStream (TlvUnknownEvenType 20))
+decode_hop_payload :: BS.ByteString -> Either DecodeError HopPayload
+decode_hop_payload bs = do
+ s <- decode_tlvs hop_payload_types bs
+ HopPayload
+ <$> field 2 decode_tu_msat s
+ <*> field 4 BOLT1.decode_tu32 s
+ <*> field 6 (whole BOLT1.decode_short_channel_id) s
+ <*> field 8 decode_payment_data s
+ <*> field 10 Just s
+ <*> field 12 BOLT1.point s
+ <*> field 16 Just s
+ <*> field 18 decode_tu_msat s
+ <*> pure (extra_tlvs hop_payload_types s)
+
+encode_payment_data :: PaymentData -> BS.ByteString
+encode_payment_data (PaymentData s t) = un_payment_secret s <> encode_tu_msat t
+
+decode_payment_data :: BS.ByteString -> Maybe PaymentData
+decode_payment_data v = do
+ let (s, t) = BS.splitAt 32 v
+ PaymentData <$> payment_secret s <*> decode_tu_msat t
+
+-- blinded hop data -----------------------------------------------------------
+
+blinded_hop_data_types :: [Word64]
+blinded_hop_data_types = [1, 2, 4, 6, 8, 10, 12, 14]
+
+-- | Encode 'BlindedHopData' as an @encrypted_data_tlv@ stream. Fails if
+-- 'bhd_extra' has a record of a known type.
+encode_blinded_hop_data :: BlindedHopData -> Either EncodeError BS.ByteString
+encode_blinded_hop_data d =
+ encode_tlvs blinded_hop_data_types typed (bhd_extra d)
+ where
+ typed = catMaybes
+ [ record 1 id (bhd_padding d)
+ , record 2 BOLT1.encode_short_channel_id (bhd_short_channel_id d)
+ , record 4 BOLT1.un_point (bhd_next_node_id d)
+ , record 6 id (bhd_path_id d)
+ , record 8 BOLT1.un_point (bhd_next_path_key_override d)
+ , record 10 encode_payment_relay (bhd_payment_relay d)
+ , record 12 encode_payment_constraints (bhd_payment_constraints d)
+ , record 14 BOLT9.render (bhd_allowed_features d)
+ ]
+
+-- | Decode an @encrypted_data_tlv@ stream. Fails on a malformed stream,
+-- an unknown even type, or a malformed known record.
--
--- For known failure codes the data is split off according to the
--- code's layout, and any remaining bytes are parsed as a TLV stream.
--- Remaining bytes that are not a valid TLV stream are ignored. For
--- unknown failure codes all bytes after the code are returned as data.
+-- >>> fmap bhd_path_id (decode_blinded_hop_data "\ACK\apath id")
+-- Right (Just "path id")
+decode_blinded_hop_data :: BS.ByteString -> Either DecodeError BlindedHopData
+decode_blinded_hop_data bs = do
+ s <- decode_tlvs blinded_hop_data_types bs
+ BlindedHopData
+ <$> field 1 Just s
+ <*> field 2 (whole BOLT1.decode_short_channel_id) s
+ <*> field 4 BOLT1.point s
+ <*> field 6 Just s
+ <*> field 8 BOLT1.point s
+ <*> field 10 decode_payment_relay s
+ <*> field 12 decode_payment_constraints s
+ <*> field 14 (Just . BOLT9.parse) s
+ <*> pure (extra_tlvs blinded_hop_data_types s)
+
+encode_payment_relay :: PaymentRelay -> BS.ByteString
+encode_payment_relay (PaymentRelay c p b) =
+ BOLT1.encode_u16 c <> BOLT1.encode_u32 p <> BOLT1.encode_tu32 b
+
+decode_payment_relay :: BS.ByteString -> Maybe PaymentRelay
+decode_payment_relay v = do
+ (c, r0) <- BOLT1.decode_u16 v
+ (p, r1) <- BOLT1.decode_u32 r0
+ PaymentRelay c p <$> BOLT1.decode_tu32 r1
+
+encode_payment_constraints :: PaymentConstraints -> BS.ByteString
+encode_payment_constraints (PaymentConstraints c m) =
+ BOLT1.encode_u32 c <> encode_tu_msat m
+
+decode_payment_constraints :: BS.ByteString -> Maybe PaymentConstraints
+decode_payment_constraints v = do
+ (c, r) <- BOLT1.decode_u32 v
+ PaymentConstraints c <$> decode_tu_msat r
+
+-- failure messages -----------------------------------------------------------
+
+-- | Encode a 'FailureMessage': the failure code, its data and the TLV
+-- stream. Fails if a @channel_update@ exceeds 65535 bytes.
--
--- Returns 'Nothing' if the input is shorter than the failure code or
--- than the data its code requires.
-decodeFailureMessage :: BS.ByteString -> Maybe FailureMessage
-decodeFailureMessage !bs = do
- (hi, r0) <- BS.uncons bs
- (lo, rest) <- BS.uncons r0
- let !code = FailureCode (fromIntegral hi `shiftL` 8 + fromIntegral lo)
- dlen <- failureDataLen code rest
- let (!dat, !extra) = BS.splitAt dlen rest
- !tlvs = if BS.null extra
- then []
- else fromMaybe [] (decodeTlvStream extra)
- Just (FailureMessage code dat tlvs)
-
--- | Length of the data that a failure code requires, given the bytes
--- following the code.
-failureDataLen :: FailureCode -> BS.ByteString -> Maybe Int
-failureDataLen !code !bs = case code of
- InvalidRealm -> fixed 0
- TemporaryNodeFailure -> fixed 0
- PermanentNodeFailure -> fixed 0
- RequiredNodeFeatureMissing -> fixed 0
- InvalidOnionVersion -> fixed 32
- InvalidOnionHmac -> fixed 32
- InvalidOnionKey -> fixed 32
- TemporaryChannelFailure -> update 0
- PermanentChannelFailure -> fixed 0
- FailureCode 0x4009 -> fixed 0 -- req. channel feature
- FailureCode 0x400A -> fixed 0 -- unknown_next_peer
- AmountBelowMinimum -> update 8
- FeeInsufficient -> update 8
- IncorrectCltvExpiry -> update 4
- ExpiryTooSoon -> update 0
- IncorrectOrUnknownPaymentDetails -> fixed 12
- FinalIncorrectCltvExpiry -> fixed 4
- FinalIncorrectHtlcAmount -> fixed 8
- ChannelDisabled -> update 2
- ExpiryTooFar -> fixed 0
- InvalidOnionPayload -> do
- (_, r) <- decodeBigSize bs
- fixed (BS.length bs - BS.length r + 2)
- MppTimeout -> fixed 0
- FailureCode 0xC018 -> fixed 32 -- invalid_onion_blinding
- _ -> Just (BS.length bs)
- where
- fixed :: Int -> Maybe Int
- fixed !n
- | BS.length bs >= n = Just n
- | otherwise = Nothing
-
- -- n bytes of fields, then u16 len and a len-byte channel_update
- update :: Int -> Maybe Int
- update !n = do
- (hi, r) <- BS.uncons (BS.drop n bs)
- (lo, _) <- BS.uncons r
- let !len = fromIntegral hi * 256 + fromIntegral lo :: Int
- fixed (n + 2 + len)
-
--- 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)
+-- >>> let tlvs = BOLT1.empty_tlv_stream
+-- >>> encode_failure_message (FailureMessage TemporaryNodeFailure tlvs)
+-- Right " \STX"
+encode_failure_message :: FailureMessage -> Either EncodeError BS.ByteString
+encode_failure_message (FailureMessage f tlvs) = do
+ body <- encode_failure f
+ pure (BOLT1.encode_u16 (failure_code f) <> body
+ <> BOLT1.encode_tlv_stream tlvs)
+
+encode_failure :: Failure -> Either EncodeError BS.ByteString
+encode_failure f = case f of
+ TemporaryNodeFailure -> Right mempty
+ PermanentNodeFailure -> Right mempty
+ RequiredNodeFeatureMissing -> Right mempty
+ InvalidOnionVersion h -> Right (un_onion_hash h)
+ InvalidOnionHmac h -> Right (un_onion_hash h)
+ InvalidOnionKey h -> Right (un_onion_hash h)
+ TemporaryChannelFailure u -> update u
+ PermanentChannelFailure -> Right mempty
+ RequiredChannelFeatureMissing -> Right mempty
+ UnknownNextPeer -> Right mempty
+ AmountBelowMinimum m u -> (msat m <>) <$> update u
+ FeeInsufficient m u -> (msat m <>) <$> update u
+ IncorrectCltvExpiry c u -> (BOLT1.encode_u32 c <>) <$> update u
+ ExpiryTooSoon u -> update u
+ IncorrectOrUnknownPaymentDetails m h -> Right (msat m <> BOLT1.encode_u32 h)
+ FinalIncorrectCltvExpiry c -> Right (BOLT1.encode_u32 c)
+ FinalIncorrectHtlcAmount m -> Right (msat m)
+ ChannelDisabled d u -> (BOLT1.encode_u16 d <>) <$> update u
+ ExpiryTooFar -> Right mempty
+ InvalidOnionPayload Nothing -> Right mempty
+ InvalidOnionPayload (Just (t, o)) ->
+ Right (BOLT1.encode_bigsize t <> BOLT1.encode_u16 o)
+ MppTimeout -> Right mempty
+ InvalidOnionBlinding h -> Right (un_onion_hash h)
+ UnknownFailure _ d -> Right d
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)
+ msat = BOLT1.encode_milli_satoshi
+ update = maybe (Left FieldTooLong) Right . BOLT1.encode_u16_prefixed
+
+-- | Decode a failure message.
+--
+-- Per BOLT #4, bytes following a failure's data are ignored unless
+-- they form a valid TLV stream (which, as no failure TLV types are
+-- defined, may hold only odd types). The data of an unknown failure
+-- code is every byte following it.
+--
+-- >>> fmap fm_failure (decode_failure_message " \STX")
+-- Right TemporaryNodeFailure
+-- >>> decode_failure_message "\DLE\r"
+-- Left (InvalidFailureData 4109)
+decode_failure_message :: BS.ByteString -> Either DecodeError FailureMessage
+decode_failure_message bs = case BOLT1.decode_u16 bs of
+ Nothing -> Left InvalidLength
+ Just (c, rest) -> case decode_failure c rest of
+ Nothing -> Left (InvalidFailureData c)
+ Just (f, extra) ->
+ let tlvs = either (const BOLT1.empty_tlv_stream) id
+ (BOLT1.decode_tlv_stream (const False) extra)
+ in Right (FailureMessage f tlvs)
+
+decode_failure :: Word16 -> BS.ByteString -> Maybe (Failure, BS.ByteString)
+decode_failure c bs = case c of
+ 0x2002 -> plain TemporaryNodeFailure
+ 0x6002 -> plain PermanentNodeFailure
+ 0x6003 -> plain RequiredNodeFeatureMissing
+ 0xc004 -> hashed InvalidOnionVersion
+ 0xc005 -> hashed InvalidOnionHmac
+ 0xc006 -> hashed InvalidOnionKey
+ 0x1007 -> do
+ (u, r) <- update bs
+ pure (TemporaryChannelFailure u, r)
+ 0x4008 -> plain PermanentChannelFailure
+ 0x4009 -> plain RequiredChannelFeatureMissing
+ 0x400a -> plain UnknownNextPeer
+ 0x100b -> do
+ (m, r0) <- BOLT1.decode_milli_satoshi bs
+ (u, r1) <- update r0
+ pure (AmountBelowMinimum m u, r1)
+ 0x100c -> do
+ (m, r0) <- BOLT1.decode_milli_satoshi bs
+ (u, r1) <- update r0
+ pure (FeeInsufficient m u, r1)
+ 0x100d -> do
+ (e, r0) <- BOLT1.decode_u32 bs
+ (u, r1) <- update r0
+ pure (IncorrectCltvExpiry e u, r1)
+ 0x100e -> do
+ (u, r) <- update bs
+ pure (ExpiryTooSoon u, r)
+ 0x400f -> do
+ (m, r0) <- BOLT1.decode_milli_satoshi bs
+ (h, r1) <- BOLT1.decode_u32 r0
+ pure (IncorrectOrUnknownPaymentDetails m h, r1)
+ 0x0012 -> do
+ (e, r) <- BOLT1.decode_u32 bs
+ pure (FinalIncorrectCltvExpiry e, r)
+ 0x0013 -> do
+ (m, r) <- BOLT1.decode_milli_satoshi bs
+ pure (FinalIncorrectHtlcAmount m, r)
+ 0x1014 -> do
+ (d, r0) <- BOLT1.decode_u16 bs
+ (u, r1) <- update r0
+ pure (ChannelDisabled d u, r1)
+ 0x0015 -> plain ExpiryTooFar
+ 0x4016 -> Just $ case BOLT1.decode_bigsize bs of
+ Just (t, r0) | Just (o, r1) <- BOLT1.decode_u16 r0 ->
+ (InvalidOnionPayload (Just (t, o)), r1)
+ _ -> (InvalidOnionPayload Nothing, bs)
+ 0x0017 -> plain MppTimeout
+ 0xc018 -> hashed InvalidOnionBlinding
+ _ -> Just (UnknownFailure c bs, BS.empty)
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) =
- unPaymentSecret secret <> encodeWord64TU total
-{-# INLINE encodePaymentData #-}
-
--- | Decode PaymentData.
-decodePaymentData :: BS.ByteString -> Maybe PaymentData
-decodePaymentData !bs
- | BS.length bs < 32 = Nothing
- | otherwise = do
- ps <- paymentSecret (BS.take 32 bs)
- let !rest = BS.drop 32 bs
- total <- decodeWord64TU rest
- Just (PaymentData ps total)
-{-# INLINE decodePaymentData #-}
+ plain f = Just (f, bs)
+ hashed g
+ | BS.length bs < 32 = Nothing
+ | otherwise =
+ let (h, r) = BS.splitAt 32 bs
+ in Just (g (OnionHash h), r)
+ update = BOLT1.decode_u16_prefixed
diff --git a/lib/Lightning/Protocol/BOLT4/Construct.hs b/lib/Lightning/Protocol/BOLT4/Construct.hs
@@ -1,6 +1,6 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module: Lightning.Protocol.BOLT4.Construct
@@ -8,221 +8,165 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Onion packet construction for BOLT4.
+-- Onion packet construction.
module Lightning.Protocol.BOLT4.Construct (
- -- * Types
Hop(..)
- , Error(..)
-
- -- * Packet construction
+ , ConstructError(..)
, construct
) where
-import Data.Bits (xor)
+import Control.DeepSeq (NFData)
import qualified Crypto.Curve.Secp256k1 as Secp256k1
import qualified Data.ByteString as BS
-import Lightning.Protocol.BOLT4.Codec
-import Lightning.Protocol.BOLT4.Internal
+import qualified Data.List as L
+import GHC.Generics (Generic)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT4.Codec (encode_hop_payload)
import Lightning.Protocol.BOLT4.Prim
import Lightning.Protocol.BOLT4.Types
--- | Route information for a single hop.
+-- | A hop of a route: the public key the hop's onion layer is encrypted
+-- to (its node id, or its blinded node id in a blinded route), and its
+-- payload.
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
- | InvalidHopPayload !Int -- ^ hop index of a payload under 2 bytes
- deriving (Eq, Show)
+ { hop_pubkey :: !BOLT1.Point
+ , hop_payload :: !HopPayload
+ } deriving (Eq, Show, Generic)
--- | Maximum number of hops in a route.
-maxHops :: Int
-maxHops = 20
-{-# INLINE maxHops #-}
+instance NFData Hop
--- | Construct an onion packet for a payment route.
+-- | Why an onion packet could not be constructed.
+data ConstructError
+ = EmptyRoute
+ -- ^ the route has no hops
+ | TooManyHops
+ -- ^ the route has more than 20 hops
+ | InvalidHopPubKey {-# UNPACK #-} !Int
+ -- ^ the public key of the hop with this index is not a valid point
+ | InvalidHopPayload {-# UNPACK #-} !Int
+ -- ^ the payload of the hop with this index can't be encoded, or
+ -- encodes to fewer than 2 bytes
+ | PayloadsTooLarge {-# UNPACK #-} !Int
+ -- ^ the hops' payloads, with their length prefixes and HMACs, take
+ -- this many bytes, more than the 1300 available
+ deriving (Eq, Show, Generic)
+
+instance NFData ConstructError
+
+-- | Construct an onion packet for a route, given a session key (which
+-- must be fresh and random for every onion), the route's hops from
+-- the first to the final one, and the associated data (the payment
+-- hash, for a payment).
--
--- Takes a session key (32 bytes random), list of hops, and associated
--- data (typically payment_hash).
+-- Returns the packet and the shared secret of each hop, in route
+-- order; keep the latter to attribute returned errors with
+-- 'Lightning.Protocol.BOLT4.unwrap_error'.
--
--- Returns the onion packet and list of shared secrets (for error
--- attribution).
+-- >>> let Just session = secret_key (BS.replicate 32 0x41)
+-- >>> let Just node = secret_key (BS.replicate 32 0x42)
+-- >>> let Just amt = BOLT1.milli_satoshi 1000
+-- >>> :{
+-- let payload = empty_hop_payload {
+-- hp_amt_to_forward = Just amt
+-- , hp_outgoing_cltv_value = Just 800000
+-- }
+-- route = [Hop (public_key node) payload]
+-- :}
+-- >>> let Right (pkt, sss) = construct session route (BS.replicate 32 0)
+-- >>> BS.length (encode_onion_packet pkt)
+-- 1366
+-- >>> length sss
+-- 1
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
+ :: SecretKey
+ -> [Hop]
+ -> BS.ByteString
+ -> Either ConstructError (OnionPacket, [SharedSecret])
+construct sk hops ad
+ | null hops = Left EmptyRoute
+ | length hops > 20 = 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 (receivers reject lengths 0 and 1)
- let payloadBytes = map (encodeHopPayload . hopPayload) hops
- payloadSizes = map payloadShiftSize payloadBytes
- totalSize = sum payloadSizes
- case [ i | (i, p) <- zip [0 ..] payloadBytes, BS.length p < 2 ] of
- i : _ -> Left (InvalidHopPayload i)
- [] -> pure ()
- if totalSize > hopPayloadsSize
- then Left (PayloadTooLarge totalSize)
+ pubs <- traverse parse_pub ihops
+ pls <- traverse encode_pl ihops
+ let sizes = map shift_size pls
+ total = sum sizes
+ if total > 1300
+ then Left (PayloadsTooLarge total)
else do
- -- Generate each hop's rho stream (2 * 1300 bytes)
- rhoStreams <- traverse rhoStream (zip [0 ..] secrets)
-
- -- Generate filler using streams for all but final hop
- let numHops = length hops
- streamsExceptFinal = take (numHops - 1) rhoStreams
- sizesExceptFinal = take (numHops - 1) payloadSizes
- filler = generateFiller streamsExceptFinal sizesExceptFinal
-
- -- Initialize hop_payloads with deterministic padding
- initialPayloads <- maybe (Left InvalidSessionKey) Right
- (generateStream (derivePad (SharedSecret sessionKey))
- hopPayloadsSize)
-
- -- Wrap payloads in reverse order (final hop first)
- let (finalPayloads, finalHmac) = wrapAllHops secrets
- rhoStreams payloadBytes filler assocData initialPayloads
+ sss <- shared_secrets (sk_bytes sk) (sk_pub sk) (zip [0 ..] pubs)
+ let streams = map (\ss -> keystream (derive_rho ss) 2600) sss
+ n = length hops
+ fill = filler (take (n - 1) streams) (take (n - 1) sizes)
+ start = keystream (derive_pad sk) 1300
+ (body, mac) = wrap ad fill start
+ (reverse (zip3 sss streams pls))
+ pkt = OnionPacket 0 (public_key sk) (HopPayloads body)
+ (Hmac32 mac)
+ pure (pkt, sss)
+ where
+ ihops = zip [0 ..] hops
- -- Build the final packet
- let ephPubBytes = Secp256k1.serialize_point ephPub
- packet = OnionPacket
- { opVersion = versionByte
- , opEphemeralKey = ephPubBytes
- , opHopPayloads = unsafeHopPayloads finalPayloads
- , opHmac = unsafeHmac32 finalHmac
- }
+ parse_pub (i, h) =
+ maybe (Left (InvalidHopPubKey i)) Right (from_point (hop_pubkey h))
- Right (packet, secrets)
- where
- rhoStream (i, ss) = maybe (Left (InvalidHopPubKey i)) Right
- (generateStream (deriveRho ss) (2 * hopPayloadsSize))
+ encode_pl (i, h) = case encode_hop_payload (hop_payload h) of
+ Right p | BS.length p >= 2 -> Right p
+ _ -> Left (InvalidHopPayload i)
--- | 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 #-}
+-- bytes a payload takes in hop_payloads: length prefix, payload and HMAC
+shift_size :: BS.ByteString -> Int
+shift_size p =
+ let !l = BS.length p
+ in BS.length (BOLT1.encode_bigsize (fromIntegral l)) + l + 32
--- | Compute shared secrets for all hops.
-computeAllSecrets
+-- the shared secret of each hop, blinding the ephemeral key pair after
+-- each one
+shared_secrets
:: BS.ByteString
-> Secp256k1.Projective
- -> [Secp256k1.Projective]
- -> Either Error ([SharedSecret], Secp256k1.Projective)
-computeAllSecrets !initSec !initPub = go initSec initPub 0 []
+ -> [(Int, Secp256k1.Projective)]
+ -> Either ConstructError [SharedSecret]
+shared_secrets _ _ [] = Right []
+shared_secrets e epub ((i, pub) : rest) = do
+ ss <- note (ecdh e pub)
+ case rest of
+ [] -> Right [ss]
+ _ -> do
+ let bf = blinding_factor epub ss
+ e' <- note (blind_scalar e bf)
+ epub' <- note (blind_pub epub bf)
+ (ss :) <$> shared_secrets e' epub' rest
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
+ note = maybe (Left (InvalidHopPubKey i)) Right
--- | Generate filler bytes from the hops' 2600-byte rho streams.
---
--- At each hop the filler, extended by that hop's shift size, is XORed
--- with the hop's rho stream starting at 1300 minus the length of the
--- filler before extension.
-generateFiller :: [BS.ByteString] -> [Int] -> BS.ByteString
-generateFiller !streams !sizes = go BS.empty streams sizes
+-- the filler, from the 2600-byte rho streams and shift sizes of all
+-- hops but the final one
+filler :: [BS.ByteString] -> [Int] -> BS.ByteString
+filler streams sizes = L.foldl' step BS.empty (zip streams sizes)
where
- go !filler [] [] = filler
- go !filler (stream:sts) (sz:szs) =
- let !extended = filler <> BS.replicate sz 0
- !streamOffset = hopPayloadsSize - BS.length filler
- !streamPart = BS.take (BS.length extended)
- (BS.drop streamOffset stream)
- !newFiller = xorBytes extended streamPart
- in go newFiller sts szs
- go !filler _ _ = filler
-{-# INLINE generateFiller #-}
-
--- | Wrap all hops in reverse order.
-wrapAllHops
- :: [SharedSecret]
- -> [BS.ByteString]
- -> [BS.ByteString]
- -> BS.ByteString
+ step f (s, n) =
+ let !ext = f <> BS.replicate n 0
+ !off = 1300 - BS.length f
+ in xor_bytes ext (BS.take (BS.length ext) (BS.drop off s))
+
+-- wrap the hops' payloads, given (shared secret, rho stream, payload)
+-- from the final hop to the first, returning hop_payloads and the HMAC
+wrap
+ :: BS.ByteString
-> BS.ByteString
-> BS.ByteString
+ -> [(SharedSecret, BS.ByteString, BS.ByteString)]
-> (BS.ByteString, BS.ByteString)
-wrapAllHops !secrets !streams !payloads !filler !assocData !initPayloads =
- let !paired = reverse (zip3 secrets streams payloads)
- !numHops = length paired
- !initHmac = BS.replicate hmacSize 0
- in go numHops initPayloads initHmac paired
+wrap ad fill = go True (BS.replicate 32 0)
where
- go !_ !hpBuf !hmac [] = (hpBuf, hmac)
- go !remaining !hpBuf !hmac ((ss, stream, payload):rest) =
- let !isLastHop = remaining ==
- length (reverse (zip secrets payloads))
- (!newPayloads, !newHmac) =
- wrapHop ss stream payload hmac hpBuf
- assocData filler isLastHop
- in go (remaining - 1) newPayloads newHmac rest
-
--- | Wrap a single hop's payload, given its shared secret and rho
--- stream.
-wrapHop
- :: SharedSecret
- -> BS.ByteString
- -> BS.ByteString
- -> BS.ByteString
- -> BS.ByteString
- -> BS.ByteString
- -> BS.ByteString
- -> Bool
- -> (BS.ByteString, BS.ByteString)
-wrapHop !ss !stream !payload !hmac !hpBuf !assocData !filler !isFinalHop =
- let !payloadLen = BS.length payload
- !lenBytes = encodeBigSize (fromIntegral payloadLen)
- !shiftSize = BS.length lenBytes + payloadLen + hmacSize
- !shifted = BS.take (hopPayloadsSize - shiftSize) hpBuf
- !prepended = lenBytes <> payload <> hmac <> shifted
- !obfuscated = xorBytes prepended (BS.take hopPayloadsSize 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 !hpBuf !filler =
- let !fillerLen = BS.length filler
- !prefix = BS.take (hopPayloadsSize - fillerLen) hpBuf
- 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 #-}
+ go _ !mac !buf [] = (buf, mac)
+ go final !mac !buf ((ss, stream, pl) : rest) =
+ let !len = BOLT1.encode_bigsize (fromIntegral (BS.length pl))
+ !n = BS.length len + BS.length pl + 32
+ !shifted = BS.concat [len, pl, mac, BS.take (1300 - n) buf]
+ !obf = xor_bytes shifted stream
+ !buf' | final = BS.take (1300 - BS.length fill) obf <> fill
+ | otherwise = obf
+ !mac' = hmac (derive_mu ss) (buf' <> ad)
+ in go False mac' buf' rest
diff --git a/lib/Lightning/Protocol/BOLT4/Error.hs b/lib/Lightning/Protocol/BOLT4/Error.hs
@@ -1,6 +1,5 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module: Lightning.Protocol.BOLT4.Error
@@ -8,222 +7,115 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Error packet construction and unwrapping for BOLT4 onion routing.
---
--- Failing nodes construct error packets that are wrapped at each
--- intermediate hop on the return path. The origin node unwraps
--- layers to attribute the error to a specific hop.
+-- Returning errors: construction, wrapping and attribution of return
+-- packets.
module Lightning.Protocol.BOLT4.Error (
- -- * Types
ErrorPacket(..)
- , AttributionResult(..)
- , minErrorPacketSize
-
- -- * Error construction (failing node)
- , constructError
-
- -- * Error forwarding (intermediate node)
- , wrapError
-
- -- * Error unwrapping (origin node)
- , unwrapError
+ , Attribution(..)
+ , construct_error
+ , wrap_error
+ , unwrap_error
) where
-import Data.Bits (xor)
+import Control.DeepSeq (NFData)
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 GHC.Generics (Generic)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT4.Codec
import Lightning.Protocol.BOLT4.Prim
-import Lightning.Protocol.BOLT4.Types (FailureMessage)
+import Lightning.Protocol.BOLT4.Types
--- | Wrapped error packet ready for return to origin.
+-- | An obfuscated return packet (the @reason@ of @update_fail_htlc@).
newtype ErrorPacket = ErrorPacket BS.ByteString
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
--- | 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 of @failure_len + pad_len@ in a return packet (256 bytes
--- per spec). A return packet is therefore at least 32 + 2 + 256 + 2
--- = 292 bytes.
-minErrorPacketSize :: Int
-minErrorPacketSize = 256
-{-# INLINE minErrorPacketSize #-}
+instance NFData ErrorPacket
--- 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.
---
--- Returns 'Nothing' if the obfuscation stream cannot be generated.
-constructError
- :: SharedSecret -- ^ from packet processing
- -> FailureMessage -- ^ failure details
- -> Maybe ErrorPacket
-constructError !ss !failure = do
- let !um = deriveUm ss
- !ammag = deriveAmmag ss
- !inner = buildErrorMessage um failure
- ErrorPacket <$> obfuscateError ammag inner
-{-# INLINE constructError #-}
-
--- | Wrap an existing error packet for forwarding back.
---
--- Each intermediate node wraps the error with its own layer.
---
--- Returns 'Nothing' if the obfuscation stream cannot be generated.
-wrapError
- :: SharedSecret -- ^ this node's shared secret
- -> ErrorPacket -- ^ error from downstream
- -> Maybe ErrorPacket
-wrapError !ss (ErrorPacket !packet) =
- let !ammag = deriveAmmag ss
- in ErrorPacket <$> obfuscateError ammag packet
-{-# 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
- in case deobfuscateError ammag packet of
- Nothing -> UnknownOrigin packet
- Just deobfuscated
- | verifyErrorHmac um deobfuscated ->
- case parseErrorMessage (BS.drop 32 deobfuscated) of
- Just msg -> Attributed idx msg
- Nothing -> UnknownOrigin deobfuscated
- | otherwise -> go (idx + 1) deobfuscated rest
-
--- Internal functions ---------------------------------------------------------
-
--- | Build the inner error message structure.
+-- | The origin of a return packet, as found by 'unwrap_error'.
+data Attribution
+ = Attributed {-# UNPACK #-} !Int !FailureMessage
+ -- ^ the hop with this index (from 0, in route order) returned the
+ -- failure
+ | MalformedFailure {-# UNPACK #-} !Int
+ -- ^ the hop with this index returned the packet, but its failure
+ -- message can't be decoded
+ | UnknownOrigin
+ -- ^ no hop's HMAC matches
+ deriving (Eq, Show, Generic)
+
+instance NFData Attribution
+
+-- | Construct a return packet at the failing node, given the shared
+-- secret from processing the onion and the failure.
--
--- Format: HMAC (32) || len (2) || message || pad_len (2) || padding
+-- The failure message is padded so that its length plus that of the
+-- padding is at least 256 bytes. Fails if the failure message can't
+-- be encoded, or exceeds 65535 bytes.
--
--- The padding brings len + pad_len up to 256, as the spec recommends;
--- longer messages are not padded.
-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
- !padLen = max 0 (minErrorPacketSize - msgLen)
- !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.
+-- >>> let Just ss = shared_secret (BS.replicate 32 0x01)
+-- >>> let fm = FailureMessage TemporaryNodeFailure BOLT1.empty_tlv_stream
+-- >>> let Right (ErrorPacket pkt) = construct_error ss fm
+-- >>> BS.length pkt
+-- 292
+construct_error
+ :: SharedSecret
+ -> FailureMessage
+ -> Either EncodeError ErrorPacket
+construct_error ss fm = do
+ msg <- encode_failure_message fm
+ let len = BS.length msg
+ if len > 65535
+ then Left FieldTooLong
+ else do
+ let pad = max 0 (256 - len)
+ body = BS.concat
+ [ BOLT1.encode_u16 (fromIntegral len), msg
+ , BOLT1.encode_u16 (fromIntegral pad), BS.replicate pad 0 ]
+ mac = hmac (derive_um ss) body
+ pure (wrap_error ss (ErrorPacket (mac <> body)))
+
+-- | Wrap a return packet from downstream at an intermediate node, given
+-- the shared secret from processing the onion.
--
--- XORs the entire packet with pseudo-random stream.
-obfuscateError
- :: DerivedKey -- ^ ammag key
- -> BS.ByteString -- ^ error packet
- -> Maybe BS.ByteString -- ^ obfuscated packet
-obfuscateError !ammag !packet = do
- stream <- generateStream ammag (BS.length packet)
- pure $! xorBytes packet stream
-{-# INLINE obfuscateError #-}
-
--- | Remove one layer of obfuscation from error packet.
+-- >>> let Just ss = shared_secret (BS.replicate 32 0x01)
+-- >>> wrap_error ss (wrap_error ss (ErrorPacket "packet"))
+-- ErrorPacket "packet"
+wrap_error :: SharedSecret -> ErrorPacket -> ErrorPacket
+wrap_error ss (ErrorPacket p) =
+ ErrorPacket (xor_bytes p (keystream (derive_ammag ss) (BS.length p)))
+
+-- | Find the origin of a return packet at the origin node, given the
+-- shared secrets from 'Lightning.Protocol.BOLT4.construct', in route
+-- order.
--
--- XOR is its own inverse, so same as obfuscation.
-deobfuscateError
- :: DerivedKey -- ^ ammag key
- -> BS.ByteString -- ^ obfuscated packet
- -> Maybe 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)
+-- >>> let Just ss0 = shared_secret (BS.replicate 32 0x01)
+-- >>> let Just ss1 = shared_secret (BS.replicate 32 0x02)
+-- >>> let fm = FailureMessage TemporaryNodeFailure BOLT1.empty_tlv_stream
+-- >>> let Right pkt = construct_error ss1 fm
+-- >>> unwrap_error [ss0, ss1] (wrap_error ss0 pkt) == Attributed 1 fm
+-- True
+-- >>> unwrap_error [ss0] (wrap_error ss0 pkt)
+-- UnknownOrigin
+unwrap_error :: [SharedSecret] -> ErrorPacket -> Attribution
+unwrap_error = go 0
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 #-}
+ go _ [] _ = UnknownOrigin
+ go i (ss : rest) p =
+ let ErrorPacket q = wrap_error ss p
+ (mac, body) = BS.splitAt 32 q
+ in if ct_eq mac (hmac (derive_um ss) body)
+ then either (const (MalformedFailure i)) (Attributed i)
+ (failure_message body)
+ else go (i + 1) rest (ErrorPacket q)
+
+-- The failure message of a return packet (after its HMAC).
+failure_message :: BS.ByteString -> Either DecodeError FailureMessage
+failure_message body = case BOLT1.decode_u16 body of
+ Just (len, r0)
+ | BS.length r0 >= fromIntegral len
+ , let (msg, r1) = BS.splitAt (fromIntegral len) r0
+ , Just (pad, r2) <- BOLT1.decode_u16 r1
+ , BS.length r2 >= fromIntegral pad
+ -> decode_failure_message msg
+ _ -> Left InvalidLength
diff --git a/lib/Lightning/Protocol/BOLT4/Internal.hs b/lib/Lightning/Protocol/BOLT4/Internal.hs
@@ -1,40 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-
--- |
--- Module: Lightning.Protocol.BOLT4.Internal
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Internal definitions for BOLT4.
---
--- This module exports unsafe constructors that bypass
--- validation. Use only in tests or trusted internal code.
-
-module Lightning.Protocol.BOLT4.Internal (
- -- * Unsafe constructors
- unsafeHmac32
- , unsafeHopPayloads
- , unsafePaymentSecret
- ) where
-
-import qualified Data.ByteString as BS
-import Lightning.Protocol.BOLT4.Types
-
--- | Construct an 'Hmac32' without length validation.
---
--- For test use only.
-unsafeHmac32 :: BS.ByteString -> Hmac32
-unsafeHmac32 = Hmac32
-
--- | Construct a 'HopPayloads' without length validation.
---
--- For test use only.
-unsafeHopPayloads :: BS.ByteString -> HopPayloads
-unsafeHopPayloads = HopPayloads
-
--- | Construct a 'PaymentSecret' without length validation.
---
--- For test use only.
-unsafePaymentSecret :: BS.ByteString -> PaymentSecret
-unsafePaymentSecret = PaymentSecret
diff --git a/lib/Lightning/Protocol/BOLT4/Prim.hs b/lib/Lightning/Protocol/BOLT4/Prim.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -8,221 +8,251 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Low-level cryptographic primitives for BOLT4 onion routing.
+-- Keys, secrets and the cryptographic primitives of BOLT #4.
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
+ -- * Secret keys
+ SecretKey
+ , secret_key
+ , public_key
+ , sk_bytes
+ , sk_pub
+
+ -- * Shared secrets
+ , SharedSecret
+ , shared_secret
+ , un_shared_secret
+ , ecdh
+
+ -- * Derived keys
+ , DerivedKey
+ , un_derived_key
+ , derive_rho
+ , derive_mu
+ , derive_um
+ , derive_ammag
+ , derive_pad
+
+ -- * Blinding
+ , blinding_factor
+ , blinded_node_tweak
+ , blind_pub
+ , blind_scalar
+
+ -- * Points
+ , to_point
+ , from_point
+
+ -- * Streams and MACs
+ , keystream
+ , hmac
+ , ct_eq
+ , xor_bytes
) where
+import Control.DeepSeq (NFData(..))
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 Lightning.Protocol.BOLT1 as BOLT1
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 ------------------------------------------------------------
+-- secret keys ----------------------------------------------------------------
--- | Derive rho key for obfuscation stream generation.
+-- | A secp256k1 secret key: a session key, a node's private key, or the
+-- seed of a blinded path.
--
--- @rho = HMAC-SHA256(key="rho", data=shared_secret)@
-deriveRho :: SharedSecret -> DerivedKey
-deriveRho = deriveKey "rho"
-{-# INLINE deriveRho #-}
-
--- | Derive mu key for HMAC computation.
+-- This is secret material: its 'Show' instance is redacted and it
+-- has no 'Eq' instance.
+data SecretKey = SecretKey
+ !BS.ByteString -- the key
+ !Secp256k1.Projective -- its public key
+ !BOLT1.Point -- its serialized public key
+
+instance Show SecretKey where
+ showsPrec d _ = showParen (d > 10) $
+ showString "SecretKey <redacted>"
+
+instance NFData SecretKey where
+ rnf (SecretKey k p q) = rnf k `seq` p `seq` rnf q
+
+-- | Construct a 'SecretKey' from exactly 32 big-endian bytes encoding an
+-- integer in [1, n - 1], where n is the secp256k1 group order.
--
--- @mu = HMAC-SHA256(key="mu", data=shared_secret)@
-deriveMu :: SharedSecret -> DerivedKey
-deriveMu = deriveKey "mu"
-{-# INLINE deriveMu #-}
-
--- | Derive um key for return error HMAC.
+-- >>> secret_key (BS.replicate 32 0x41)
+-- Just (SecretKey <redacted>)
+-- >>> secret_key (BS.replicate 32 0x00)
+-- Nothing
+-- >>> secret_key (BS.replicate 31 0x41)
+-- Nothing
+secret_key :: BS.ByteString -> Maybe SecretKey
+secret_key bs
+ | BS.length bs /= 32 = Nothing
+ | otherwise = do
+ pub <- Secp256k1.derive_pub (Secp256k1.unsafe_roll32 bs)
+ pt <- to_point pub
+ pure $! SecretKey bs pub pt
+
+-- | The public key of a 'SecretKey'.
--
--- @um = HMAC-SHA256(key="um", data=shared_secret)@
-deriveUm :: SharedSecret -> DerivedKey
-deriveUm = deriveKey "um"
-{-# INLINE deriveUm #-}
+-- >>> let Just sk = secret_key (BS.replicate 32 0x41)
+-- >>> BS.length (BOLT1.un_point (public_key sk))
+-- 33
+public_key :: SecretKey -> BOLT1.Point
+public_key (SecretKey _ _ p) = p
+{-# INLINE public_key #-}
--- | Derive pad key for filler generation.
---
--- @pad = HMAC-SHA256(key="pad", data=shared_secret)@
-derivePad :: SharedSecret -> DerivedKey
-derivePad = deriveKey "pad"
-{-# INLINE derivePad #-}
+sk_bytes :: SecretKey -> BS.ByteString
+sk_bytes (SecretKey k _ _) = k
+{-# INLINE sk_bytes #-}
+
+sk_pub :: SecretKey -> Secp256k1.Projective
+sk_pub (SecretKey _ p _) = p
+{-# INLINE sk_pub #-}
+
+-- shared secrets -------------------------------------------------------------
--- | Derive ammag key for error obfuscation.
+-- | A 32-byte shared secret, established between the origin of an onion
+-- and one of its hops.
--
--- @ammag = HMAC-SHA256(key="ammag", data=shared_secret)@
-deriveAmmag :: SharedSecret -> DerivedKey
-deriveAmmag = deriveKey "ammag"
-{-# INLINE deriveAmmag #-}
+-- This is secret material: its 'Show' instance is redacted and its
+-- 'Eq' instance runs in constant time.
+newtype SharedSecret = SharedSecret BS.ByteString
--- 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 #-}
+instance Eq SharedSecret where
+ SharedSecret a == SharedSecret b = ct_eq a b
--- Shared secret computation -------------------------------------------------
+instance Show SharedSecret where
+ showsPrec d _ = showParen (d > 10) $
+ showString "SharedSecret <redacted>"
--- | 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.
+instance NFData SharedSecret where
+ rnf (SharedSecret bs) = rnf bs
+
+-- | Construct a 'SharedSecret' from exactly 32 bytes (e.g. to restore one
+-- that was stored with 'un_shared_secret').
--
--- Returns 'Nothing' if ChaCha20 fails (e.g. the key is not 32 bytes).
-generateStream
- :: DerivedKey -- ^ rho or ammag key
- -> Int -- ^ desired length
- -> Maybe BS.ByteString
-generateStream (DerivedKey !key) !len =
- let !nonce = BS.replicate 12 0
- !zeros = BS.replicate len 0
- in either (const Nothing) Just
- (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 #-}
+-- >>> let Just ss = shared_secret (BS.replicate 32 0x01)
+-- >>> BS.length (un_shared_secret ss)
+-- 32
+-- >>> shared_secret "too short"
+-- Nothing
+shared_secret :: BS.ByteString -> Maybe SharedSecret
+shared_secret bs
+ | BS.length bs == 32 = Just (SharedSecret bs)
+ | otherwise = Nothing
+{-# INLINE shared_secret #-}
+
+-- | The bytes of a 'SharedSecret'.
+un_shared_secret :: SharedSecret -> BS.ByteString
+un_shared_secret (SharedSecret bs) = bs
+{-# INLINE un_shared_secret #-}
+
+-- | ECDH per BOLT #4: SHA256 of the compressed product of a point and a
+-- 32-byte scalar. Fails if the scalar is not in [1, n - 1].
+ecdh :: BS.ByteString -> Secp256k1.Projective -> Maybe SharedSecret
+ecdh k pub = do
+ pt <- Secp256k1.mul pub (Secp256k1.unsafe_roll32 k)
+ pure $! SharedSecret (SHA256.hash (Secp256k1.serialize_point pt))
+
+-- derived keys ---------------------------------------------------------------
+
+-- A 32-byte key derived from a shared secret.
+newtype DerivedKey = DerivedKey BS.ByteString
+
+un_derived_key :: DerivedKey -> BS.ByteString
+un_derived_key (DerivedKey k) = k
+{-# INLINE un_derived_key #-}
+
+derive :: BS.ByteString -> BS.ByteString -> DerivedKey
+derive label ss =
+ let SHA256.MAC k = SHA256.hmac label ss
+ in DerivedKey k
+{-# INLINE derive #-}
+
+derive_rho :: SharedSecret -> DerivedKey
+derive_rho (SharedSecret ss) = derive "rho" ss
+
+derive_mu :: SharedSecret -> DerivedKey
+derive_mu (SharedSecret ss) = derive "mu" ss
+
+derive_um :: SharedSecret -> DerivedKey
+derive_um (SharedSecret ss) = derive "um" ss
+
+derive_ammag :: SharedSecret -> DerivedKey
+derive_ammag (SharedSecret ss) = derive "ammag" ss
+
+-- The pad key is derived from the session key itself.
+derive_pad :: SecretKey -> DerivedKey
+derive_pad (SecretKey k _ _) = derive "pad" k
+
+-- blinding -------------------------------------------------------------------
+
+-- SHA256(E || ss), the factor by which ephemeral keys are blinded.
+blinding_factor :: Secp256k1.Projective -> SharedSecret -> BS.ByteString
+blinding_factor e (SharedSecret ss) =
+ SHA256.hash (Secp256k1.serialize_point e <> ss)
+
+-- HMAC256("blinded_node_id", ss), the factor by which node ids are
+-- blinded in a blinded route.
+blinded_node_tweak :: SharedSecret -> BS.ByteString
+blinded_node_tweak (SharedSecret ss) =
+ let SHA256.MAC t = SHA256.hmac "blinded_node_id" ss
+ in t
+
+-- Multiply a point by a 32-byte factor.
+blind_pub
+ :: Secp256k1.Projective -> BS.ByteString -> Maybe Secp256k1.Projective
+blind_pub p t = Secp256k1.mul p (Secp256k1.unsafe_roll32 t)
+
+-- Multiply a 32-byte scalar by a 32-byte factor, mod n. Fails if the
+-- product is zero.
+blind_scalar :: BS.ByteString -> BS.ByteString -> Maybe BS.ByteString
+blind_scalar k t =
+ let !r = S.retr (S.mul (S.to (Secp256k1.unsafe_roll32 k))
+ (S.to (Secp256k1.unsafe_roll32 t)))
+ in if Secp256k1.ge r
+ then Just $! Secp256k1.unroll32 r
+ else Nothing
+
+-- points ---------------------------------------------------------------------
+
+to_point :: Secp256k1.Projective -> Maybe BOLT1.Point
+to_point = BOLT1.point . Secp256k1.serialize_point
+{-# INLINE to_point #-}
+
+from_point :: BOLT1.Point -> Maybe Secp256k1.Projective
+from_point = Secp256k1.parse_point . BOLT1.un_point
+{-# INLINE from_point #-}
+
+-- streams and MACs -----------------------------------------------------------
+
+-- The ChaCha20 keystream of the given length under a derived key, with
+-- an all-zero nonce. The cipher fails only for a key or nonce of the
+-- wrong length, or past 256 GiB of output, none of which can occur
+-- here; the empty result in that case truncates any output XORed with
+-- it, rather than leaving it unencrypted.
+keystream :: DerivedKey -> Int -> BS.ByteString
+keystream (DerivedKey k) n =
+ case ChaCha.cipher k 0 (BS.replicate 12 0) (BS.replicate n 0) of
+ Right s -> s
+ Left _ -> BS.empty
+
+-- HMAC-SHA256 under a derived key.
+hmac :: DerivedKey -> BS.ByteString -> BS.ByteString
+hmac (DerivedKey k) m =
+ let SHA256.MAC h = SHA256.hmac k m
+ in h
+{-# INLINE hmac #-}
+
+-- Constant-time equality (variable-time only in the lengths).
+ct_eq :: BS.ByteString -> BS.ByteString -> Bool
+ct_eq a b = SHA256.MAC a == SHA256.MAC b
+{-# INLINE ct_eq #-}
+
+-- XOR, truncated to the shorter input.
+xor_bytes :: BS.ByteString -> BS.ByteString -> BS.ByteString
+xor_bytes = BS.packZipWith xor
+{-# INLINE xor_bytes #-}
diff --git a/lib/Lightning/Protocol/BOLT4/Process.hs b/lib/Lightning/Protocol/BOLT4/Process.hs
@@ -1,7 +1,5 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module: Lightning.Protocol.BOLT4.Process
@@ -9,233 +7,159 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Onion packet processing for BOLT4.
+-- Onion packet processing.
module Lightning.Protocol.BOLT4.Process (
- -- * Processing
- process
-
- -- * Rejection reasons
- , RejectReason(..)
+ ProcessResult(..)
+ , ForwardInfo(..)
+ , ReceiveInfo(..)
+ , process
) where
-import Data.Bits (xor)
+import Control.DeepSeq (NFData)
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.Internal
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT4.Blinding (unblind)
+import Lightning.Protocol.BOLT4.Codec (decode_hop_payload)
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
+-- | The result of processing an onion packet.
+data ProcessResult
+ = Forward !ForwardInfo
+ -- ^ forward the onion to the next hop
+ | Receive !ReceiveInfo
+ -- ^ this node is the onion's final hop
deriving (Eq, Show, Generic)
--- | Process an incoming onion packet.
+instance NFData ProcessResult
+
+-- | What a forwarding node learns from an onion.
+data ForwardInfo = ForwardInfo
+ { fwd_payload :: !HopPayload
+ -- ^ this node's payload
+ , fwd_blinded :: !(Maybe BlindedInfo)
+ -- ^ the decrypted @encrypted_recipient_data@ and next path key, in
+ -- a blinded route
+ , fwd_next_packet :: !OnionPacket
+ -- ^ the onion for the next hop
+ , fwd_shared_secret :: !SharedSecret
+ -- ^ the shared secret, to wrap returned errors with
+ } deriving (Eq, Show, Generic)
+
+instance NFData ForwardInfo
+
+-- | What the final node learns from an onion.
+data ReceiveInfo = ReceiveInfo
+ { rcv_payload :: !HopPayload
+ -- ^ this node's payload
+ , rcv_blinded :: !(Maybe BlindedInfo)
+ -- ^ the decrypted @encrypted_recipient_data@, in a blinded route
+ , rcv_shared_secret :: !SharedSecret
+ -- ^ the shared secret, to construct errors with
+ } deriving (Eq, Show, Generic)
+
+instance NFData ReceiveInfo
+
+-- | Process an onion packet, given this node's private key, the packet,
+-- its associated data (the payment hash, for a payment), and the
+-- @path_key@ received with it (in @update_add_htlc@), if any.
+--
+-- In a blinded route, the onion is encrypted to this node's blinded
+-- node id: given a @path_key@, the matching private key is derived
+-- from it. The @encrypted_recipient_data@ in the payload is decrypted
+-- with the @path_key@, or, at the introduction node, with the
+-- payload's @current_path_key@; a path key without
+-- @encrypted_recipient_data@, or both kinds of path key, are
+-- rejected.
--
--- Takes the receiving node's private key, the incoming packet, and
--- associated data (typically the payment hash).
+-- The payload is otherwise returned as is. The caller must apply the
+-- remaining reader requirements of BOLT #4: the presence of the
+-- fields required for forwarding or receiving, the HTLC amount and
+-- expiry checks (in a blinded route, against @payment_relay@ and
+-- @payment_constraints@), @allowed_features@, the rule that
+-- @encrypted_recipient_data@ hold only one of @short_channel_id@ and
+-- @next_node_id@, and the rejection of replayed HMACs.
--
--- Returns either a rejection reason or the processing result
--- (forward to next hop or receive at final destination).
+-- >>> let Just session = secret_key (BS.replicate 32 0x41)
+-- >>> let Just node = secret_key (BS.replicate 32 0x42)
+-- >>> let pl = empty_hop_payload { hp_outgoing_cltv_value = Just 144 }
+-- >>> let ad = BS.replicate 32 0
+-- >>> let Right (pkt, _) = construct session [Hop (public_key node) pl] ad
+-- >>> let Right (Receive info) = process node pkt ad Nothing
+-- >>> hp_outgoing_cltv_value (rcv_payload info)
+-- Just 144
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
- decrypted <- case decryptPayloads rhoKey
- (unHopPayloads (opHopPayloads packet)) of
- Nothing -> Left InvalidEphemeralKey
- Just d -> Right d
-
- -- Step 7: Extract payload
- (payloadBytes, nextHmac, remaining) <-
- extractPayload decrypted
-
- -- Step 8: Parse payload TLV
- hp <- case decodeHopPayload payloadBytes of
- Nothing -> Left (InvalidPayload "failed to decode TLV")
- Just h -> Right h
-
- -- Step 9: Check if final hop
- if isFinalHop nextHmac
- then Right $! Receive $! ReceiveInfo
- { riPayload = hp
- , riSharedSecret = ss
- }
+ :: SecretKey
+ -> OnionPacket
+ -> BS.ByteString
+ -> Maybe BOLT1.Point
+ -> Either ProcessError ProcessResult
+process sk pkt ad mpk = do
+ let ver = onion_version pkt
+ if ver /= 0 then Left (InvalidVersion ver) else Right ()
+ eph <- note InvalidPublicKey (from_point (onion_public_key pkt))
+ -- with a path_key, the onion is encrypted to the blinded node id
+ blinding <- traverse path_secret mpk
+ key <- case blinding of
+ Nothing -> Right (sk_bytes sk)
+ Just (_, bss) ->
+ note InvalidPathKey (blind_scalar (sk_bytes sk) (blinded_node_tweak bss))
+ ss <- note InvalidPublicKey (ecdh key eph)
+ let payloads = un_hop_payloads (onion_hop_payloads pkt)
+ mac = hmac (derive_mu ss) (payloads <> ad)
+ if ct_eq mac (un_hmac32 (onion_hmac pkt))
+ then Right ()
+ else Left HmacMismatch
+ let plain = xor_bytes (payloads <> BS.replicate 1300 0)
+ (keystream (derive_rho ss) 2600)
+ (pl, next_mac, rest) <- split_payload plain
+ hp <- either (Left . InvalidPayload) Right (decode_hop_payload pl)
+ binfo <- case (hp_encrypted_data hp, blinding, hp_current_path_key hp) of
+ (Nothing, Nothing, Nothing) -> Right Nothing
+ (Nothing, _, _) -> Left UnexpectedPathKey
+ (Just _, Just _, Just _) -> Left UnexpectedPathKey
+ (Just _, Nothing, Nothing) -> Left MissingPathKey
+ (Just enc, Just (e, bss), Nothing) -> Just <$> unblind bss e enc
+ (Just enc, Nothing, Just cpk) -> do
+ (e, bss) <- path_secret cpk
+ Just <$> unblind bss e enc
+ if BS.all (== 0) next_mac
+ then Right (Receive (ReceiveInfo hp binfo ss))
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 = hp
- , fiSharedSecret = ss
- }
-
--- | 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)
- -> Maybe BS.ByteString
- -- ^ decrypted (2600 bytes, first 1300 useful)
-decryptPayloads !rhoKey !payloads = do
- let !streamLen = 2 * hopPayloadsSize -- 2600 bytes
- stream <- generateStream rhoKey streamLen
- -- Extend payloads with zeros for the shift operation
- let !extended = payloads <> BS.replicate hopPayloadsSize 0
- pure $! 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.
---
--- The length prefix, payload and next HMAC must fit in the 1300-byte
--- hop_payloads region, so that at least 1300 bytes remain for the
--- next hop.
-extractPayload
+ eph' <- note InvalidPublicKey
+ (blind_pub eph (blinding_factor eph ss) >>= to_point)
+ let next = OnionPacket 0 eph' (HopPayloads rest) (Hmac32 next_mac)
+ Right (Forward (ForwardInfo hp binfo next ss))
+ where
+ note :: ProcessError -> Maybe a -> Either ProcessError a
+ note e = maybe (Left e) Right
+
+ -- a path key, and its shared secret with this node
+ path_secret
+ :: BOLT1.Point
+ -> Either ProcessError (Secp256k1.Projective, SharedSecret)
+ path_secret pk = do
+ e <- note InvalidPathKey (from_point pk)
+ bss <- note InvalidPathKey (ecdh (sk_bytes sk) e)
+ Right (e, bss)
+
+-- Split the decrypted 2600-byte buffer into the payload, the next HMAC
+-- and the next hop_payloads. The length prefix, payload and HMAC must
+-- fit in the 1300-byte hop_payloads.
+split_payload
:: BS.ByteString
- -> Either RejectReason
- (BS.ByteString, BS.ByteString, BS.ByteString)
- -- ^ (payload_bytes, next_hmac, remaining_hop_payloads)
-extractPayload !decrypted = do
- -- Parse length prefix
- (len64, afterLen) <- case decodeBigSize decrypted of
- Nothing -> Left (InvalidPayload "invalid length prefix")
- Just r -> Right r
-
- -- Validate length (in Word64, before converting to Int)
- let !prefixLen = BS.length decrypted - BS.length afterLen
- !maxLen = hopPayloadsSize - prefixLen - hmacSize
- if len64 > fromIntegral maxLen
- then Left (InvalidPayload "payload length exceeds hop_payloads")
- else if len64 < 2
- then Left (InvalidPayload "payload length below 2")
- else pure ()
-
- -- Extract payload bytes
- let !len = fromIntegral len64 :: Int
- !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. Already "shifted" by 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
- (unHopPayloads (opHopPayloads packet))
- assocData
- in verifyHmac (unHmac32 (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
- -> 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 = unsafeHopPayloads newPayloads
- , opHmac = unsafeHmac32 nextHmac
- }
-
--- | Check if this is the final hop.
---
--- Final hop is indicated by next_hmac being all zeros.
-isFinalHop :: BS.ByteString -> Bool
-isFinalHop !hm = hm == BS.replicate hmacSize 0
-{-# INLINE isFinalHop #-}
+ -> Either ProcessError (BS.ByteString, BS.ByteString, BS.ByteString)
+split_payload plain = case BOLT1.decode_bigsize plain of
+ Nothing -> Left InvalidPayloadLength
+ Just (len, r0)
+ | len < 2 -> Left InvalidPayloadLength
+ | len > fromIntegral (1300 - prefix - 32) -> Left InvalidPayloadLength
+ | otherwise ->
+ let (pl, r1) = BS.splitAt (fromIntegral len) r0
+ (mac, r2) = BS.splitAt 32 r1
+ in Right (pl, mac, BS.take 1300 r2)
+ where
+ prefix = BS.length plain - BS.length r0
diff --git a/lib/Lightning/Protocol/BOLT4/Types.hs b/lib/Lightning/Protocol/BOLT4/Types.hs
@@ -1,7 +1,5 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE PatternSynonyms #-}
-- |
-- Module: Lightning.Protocol.BOLT4.Types
@@ -9,341 +7,501 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Core data types for BOLT4 onion routing.
+-- Data types for BOLT #4.
module Lightning.Protocol.BOLT4.Types (
- -- * Fixed-size newtypes
- Hmac32(..)
- , hmac32
- , unHmac32
+ -- * Onion packets
+ OnionPacket(..)
, HopPayloads(..)
- , hopPayloads
- , unHopPayloads
- , PaymentSecret(..)
- , paymentSecret
- , unPaymentSecret
+ , hop_payloads
+ , un_hop_payloads
+ , Hmac32(..)
+ , hmac32
+ , un_hmac32
- -- * Packet types
- , OnionPacket(..)
+ -- * Hop payloads
, HopPayload(..)
- , ShortChannelId(..)
- , shortChannelId
- , scidBlockHeight
- , scidTxIndex
- , scidOutputIndex
- , scidWord64
+ , empty_hop_payload
, PaymentData(..)
- , TlvRecord(..)
-
- -- * Error types
+ , PaymentSecret(..)
+ , payment_secret
+ , un_payment_secret
+
+ -- * Route blinding
+ , BlindedPath(..)
+ , BlindedHop(..)
+ , BlindedHopData(..)
+ , empty_blinded_hop_data
+ , PaymentRelay(..)
+ , PaymentConstraints(..)
+ , BlindedInfo(..)
+
+ -- * Failure messages
, 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
+ , Failure(..)
+ , OnionHash(..)
+ , onion_hash
+ , un_onion_hash
+ , failure_code
+ , is_badonion
+ , is_perm
+ , is_node
+ , is_update
+
+ -- * Errors
+ , DecodeError(..)
+ , EncodeError(..)
+ , ProcessError(..)
) where
-import Data.Bits ((.&.), (.|.))
+import Control.DeepSeq (NFData(..))
+import Data.Bits ((.&.))
import qualified Data.ByteString as BS
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Generics (Generic)
-import Lightning.Protocol.BOLT1.Prim
- ( ShortChannelId(..), shortChannelId
- , scidBlockHeight, scidTxIndex, scidOutputIndex, scidWord64
- )
-import Lightning.Protocol.BOLT4.Prim (SharedSecret)
-
--- Fixed-size newtypes -------------------------------------------------------
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import qualified Lightning.Protocol.BOLT4.Prim as P
+import qualified Lightning.Protocol.BOLT9 as BOLT9
--- | 32-byte HMAC value.
-newtype Hmac32 = Hmac32 BS.ByteString
- deriving (Eq, Show, Generic)
+-- onion packets --------------------------------------------------------------
--- | Construct an 'Hmac32' from a 32-byte 'BS.ByteString'.
---
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-hmac32 :: BS.ByteString -> Maybe Hmac32
-hmac32 !bs
- | BS.length bs == 32 = Just (Hmac32 bs)
- | otherwise = Nothing
-{-# INLINE hmac32 #-}
+-- | An onion packet (@onion_packet@): 1366 bytes on the wire.
+data OnionPacket = OnionPacket
+ { onion_version :: {-# UNPACK #-} !Word8
+ -- ^ the version byte; 0 in this version of the protocol
+ , onion_public_key :: !BOLT1.Point
+ -- ^ the ephemeral public key
+ , onion_hop_payloads :: !HopPayloads
+ -- ^ the obfuscated hop payloads
+ , onion_hmac :: !Hmac32
+ -- ^ the HMAC authenticating the packet
+ } deriving (Eq, Show, Generic)
--- | Extract the raw bytes from an 'Hmac32'.
-unHmac32 :: Hmac32 -> BS.ByteString
-unHmac32 (Hmac32 bs) = bs
-{-# INLINE unHmac32 #-}
+instance NFData OnionPacket
--- | 1300-byte hop payloads section.
+-- | The 1300-byte @hop_payloads@ field of an onion packet.
newtype HopPayloads = HopPayloads BS.ByteString
deriving (Eq, Show, Generic)
--- | Construct a 'HopPayloads' from a 1300-byte 'BS.ByteString'.
+instance NFData HopPayloads
+
+-- | Construct 'HopPayloads' from exactly 1300 bytes.
--
--- Returns 'Nothing' if the input is not exactly 1300 bytes.
-hopPayloads :: BS.ByteString -> Maybe HopPayloads
-hopPayloads !bs
- | BS.length bs == hopPayloadsSize = Just (HopPayloads bs)
- | otherwise = Nothing
-{-# INLINE hopPayloads #-}
-
--- | Extract the raw bytes from 'HopPayloads'.
-unHopPayloads :: HopPayloads -> BS.ByteString
-unHopPayloads (HopPayloads bs) = bs
-{-# INLINE unHopPayloads #-}
-
--- | 32-byte payment secret.
-newtype PaymentSecret = PaymentSecret BS.ByteString
+-- >>> let Just hp = hop_payloads (BS.replicate 1300 0)
+-- >>> BS.length (un_hop_payloads hp)
+-- 1300
+-- >>> hop_payloads (BS.replicate 1299 0)
+-- Nothing
+hop_payloads :: BS.ByteString -> Maybe HopPayloads
+hop_payloads bs
+ | BS.length bs == 1300 = Just (HopPayloads bs)
+ | otherwise = Nothing
+{-# INLINE hop_payloads #-}
+
+-- | The bytes of 'HopPayloads'.
+un_hop_payloads :: HopPayloads -> BS.ByteString
+un_hop_payloads (HopPayloads bs) = bs
+{-# INLINE un_hop_payloads #-}
+
+-- | A 32-byte HMAC.
+newtype Hmac32 = Hmac32 BS.ByteString
deriving (Eq, Show, Generic)
--- | Construct a 'PaymentSecret' from a 32-byte 'BS.ByteString'.
+instance NFData Hmac32
+
+-- | Construct an 'Hmac32' from exactly 32 bytes.
--
--- Returns 'Nothing' if the input is not exactly 32 bytes.
-paymentSecret :: BS.ByteString -> Maybe PaymentSecret
-paymentSecret !bs
- | BS.length bs == 32 = Just (PaymentSecret bs)
- | otherwise = Nothing
-{-# INLINE paymentSecret #-}
+-- >>> fmap (BS.length . un_hmac32) (hmac32 (BS.replicate 32 0))
+-- Just 32
+-- >>> hmac32 "too short"
+-- Nothing
+hmac32 :: BS.ByteString -> Maybe Hmac32
+hmac32 bs
+ | BS.length bs == 32 = Just (Hmac32 bs)
+ | otherwise = Nothing
+{-# INLINE hmac32 #-}
--- | Extract the raw bytes from a 'PaymentSecret'.
-unPaymentSecret :: PaymentSecret -> BS.ByteString
-unPaymentSecret (PaymentSecret bs) = bs
-{-# INLINE unPaymentSecret #-}
+-- | The bytes of an 'Hmac32'.
+un_hmac32 :: Hmac32 -> BS.ByteString
+un_hmac32 (Hmac32 bs) = bs
+{-# INLINE un_hmac32 #-}
--- Packet types -------------------------------------------------------------
+-- hop payloads ---------------------------------------------------------------
--- | Complete onion packet (1366 bytes).
-data OnionPacket = OnionPacket
- { opVersion :: {-# UNPACK #-} !Word8
- , opEphemeralKey :: !BS.ByteString -- ^ 33 bytes, compressed pubkey
- , opHopPayloads :: !HopPayloads -- ^ 1300 bytes
- , opHmac :: !Hmac32 -- ^ 32 bytes
- } deriving (Eq, Show, Generic)
-
--- | Parsed hop payload after decryption.
+-- | A hop's @payload@ TLV stream.
+--
+-- Each known record has a typed field. 'hp_extra' holds the remaining
+-- records: decoding fills it with the unknown odd records (unknown even
+-- records are rejected), and encoding accepts any record in it whose
+-- type isn't one of the known ones.
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] -- ^ 16, 18 and unknown odd
- } deriving (Eq, Show, Generic)
-
--- | Payment data for final hop (TLV type 8).
-data PaymentData = PaymentData
- { pdPaymentSecret :: !PaymentSecret -- ^ 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
+ { hp_amt_to_forward :: !(Maybe BOLT1.MilliSatoshi)
+ -- ^ type 2: @amt_to_forward@
+ , hp_outgoing_cltv_value :: !(Maybe Word32)
+ -- ^ type 4: @outgoing_cltv_value@
+ , hp_short_channel_id :: !(Maybe BOLT1.ShortChannelId)
+ -- ^ type 6: @short_channel_id@
+ , hp_payment_data :: !(Maybe PaymentData)
+ -- ^ type 8: @payment_data@
+ , hp_encrypted_data :: !(Maybe BS.ByteString)
+ -- ^ type 10: @encrypted_recipient_data@
+ , hp_current_path_key :: !(Maybe BOLT1.Point)
+ -- ^ type 12: @current_path_key@
+ , hp_payment_metadata :: !(Maybe BS.ByteString)
+ -- ^ type 16: @payment_metadata@
+ , hp_total_amount_msat :: !(Maybe BOLT1.MilliSatoshi)
+ -- ^ type 18: @total_amount_msat@
+ , hp_extra :: !BOLT1.TlvStream
+ -- ^ other records
} deriving (Eq, Show, Generic)
--- Error types --------------------------------------------------------------
+instance NFData HopPayload
--- | Failure message from intermediate or final node.
-data FailureMessage = FailureMessage
- { fmCode :: {-# UNPACK #-} !FailureCode
- , fmData :: !BS.ByteString
- , fmTlvs :: ![TlvRecord]
+-- | The empty 'HopPayload', to be updated with record syntax.
+--
+-- >>> let Just amt = BOLT1.milli_satoshi 1000
+-- >>> let hp = empty_hop_payload { hp_amt_to_forward = Just amt }
+-- >>> encode_hop_payload hp
+-- Right "\STX\STX\ETX\232"
+empty_hop_payload :: HopPayload
+empty_hop_payload = HopPayload
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ BOLT1.empty_tlv_stream
+
+-- | The @payment_data@ record of a final hop's payload.
+data PaymentData = PaymentData
+ { pd_payment_secret :: !PaymentSecret
+ , pd_total_msat :: !BOLT1.MilliSatoshi
} deriving (Eq, Show, Generic)
--- | 2-byte failure code with flag bits.
-newtype FailureCode = FailureCode Word16
- deriving (Eq, Show)
+instance NFData PaymentData
--- Flag bits
+-- | A 32-byte payment secret.
+--
+-- Its 'Show' instance is redacted and its 'Eq' instance runs in
+-- constant time.
+newtype PaymentSecret = PaymentSecret BS.ByteString
--- | BADONION flag (0x8000): error was in parsing the onion.
-pattern BADONION :: Word16
-pattern BADONION = 0x8000
+instance Eq PaymentSecret where
+ PaymentSecret a == PaymentSecret b = P.ct_eq a b
--- | PERM flag (0x4000): permanent failure, do not retry.
-pattern PERM :: Word16
-pattern PERM = 0x4000
+instance Show PaymentSecret where
+ showsPrec d _ = showParen (d > 10) $
+ showString "PaymentSecret <redacted>"
--- | NODE flag (0x2000): node failure rather than channel.
-pattern NODE :: Word16
-pattern NODE = 0x2000
+instance NFData PaymentSecret where
+ rnf (PaymentSecret bs) = rnf bs
--- | UPDATE flag (0x1000): channel update is attached.
-pattern UPDATE :: Word16
-pattern UPDATE = 0x1000
+-- | Construct a 'PaymentSecret' from exactly 32 bytes.
+--
+-- >>> payment_secret (BS.replicate 32 0x01)
+-- Just (PaymentSecret <redacted>)
+-- >>> payment_secret (BS.replicate 16 0x01)
+-- Nothing
+payment_secret :: BS.ByteString -> Maybe PaymentSecret
+payment_secret bs
+ | BS.length bs == 32 = Just (PaymentSecret bs)
+ | otherwise = Nothing
+{-# INLINE payment_secret #-}
+
+-- | The bytes of a 'PaymentSecret'.
+un_payment_secret :: PaymentSecret -> BS.ByteString
+un_payment_secret (PaymentSecret bs) = bs
+{-# INLINE un_payment_secret #-}
+
+-- route blinding -------------------------------------------------------------
+
+-- | A blinded route (@blinded_path@), as created by a recipient.
+data BlindedPath = BlindedPath
+ { bp_first_node_id :: !BOLT1.Point
+ -- ^ the (unblinded) introduction node
+ , bp_first_path_key :: !BOLT1.Point
+ -- ^ the path key for the introduction node
+ , bp_hops :: ![BlindedHop]
+ -- ^ the blinded hops, starting with the introduction node
+ } deriving (Eq, Show, Generic)
--- Common failure codes
+instance NFData BlindedPath
--- | Invalid realm byte in onion.
-pattern InvalidRealm :: FailureCode
-pattern InvalidRealm = FailureCode 0x4001 -- PERM .|. 1
+-- | A hop of a blinded route (@blinded_path_hop@).
+data BlindedHop = BlindedHop
+ { bh_blinded_node_id :: !BOLT1.Point
+ -- ^ the hop's blinded node id
+ , bh_encrypted_data :: !BS.ByteString
+ -- ^ the hop's @encrypted_recipient_data@
+ } deriving (Eq, Show, Generic)
--- | Temporary node failure.
-pattern TemporaryNodeFailure :: FailureCode
-pattern TemporaryNodeFailure = FailureCode 0x2002 -- NODE .|. 2
+instance NFData BlindedHop
--- | Permanent node failure.
-pattern PermanentNodeFailure :: FailureCode
-pattern PermanentNodeFailure = FailureCode 0x6002 -- PERM .|. NODE .|. 2
+-- | The @encrypted_data_tlv@ stream carried, encrypted, in a hop's
+-- @encrypted_recipient_data@.
+--
+-- 'bhd_extra' plays the same role as 'hp_extra' in 'HopPayload'.
+data BlindedHopData = BlindedHopData
+ { bhd_padding :: !(Maybe BS.ByteString)
+ -- ^ type 1: @padding@
+ , bhd_short_channel_id :: !(Maybe BOLT1.ShortChannelId)
+ -- ^ type 2: @short_channel_id@
+ , bhd_next_node_id :: !(Maybe BOLT1.Point)
+ -- ^ type 4: @next_node_id@
+ , bhd_path_id :: !(Maybe BS.ByteString)
+ -- ^ type 6: @path_id@
+ , bhd_next_path_key_override :: !(Maybe BOLT1.Point)
+ -- ^ type 8: @next_path_key_override@
+ , bhd_payment_relay :: !(Maybe PaymentRelay)
+ -- ^ type 10: @payment_relay@
+ , bhd_payment_constraints :: !(Maybe PaymentConstraints)
+ -- ^ type 12: @payment_constraints@
+ , bhd_allowed_features :: !(Maybe BOLT9.FeatureVector)
+ -- ^ type 14: @allowed_features@
+ , bhd_extra :: !BOLT1.TlvStream
+ -- ^ other records
+ } deriving (Eq, Show, Generic)
--- | Required node feature missing.
-pattern RequiredNodeFeatureMissing :: FailureCode
-pattern RequiredNodeFeatureMissing = FailureCode 0x6003 -- PERM .|. NODE .|. 3
+instance NFData BlindedHopData
--- | Invalid onion version.
-pattern InvalidOnionVersion :: FailureCode
-pattern InvalidOnionVersion = FailureCode 0xC004 -- BADONION .|. PERM .|. 4
+-- | The empty 'BlindedHopData', to be updated with record syntax.
+--
+-- >>> let bhd = empty_blinded_hop_data { bhd_path_id = Just "path id" }
+-- >>> encode_blinded_hop_data bhd
+-- Right "\ACK\apath id"
+empty_blinded_hop_data :: BlindedHopData
+empty_blinded_hop_data = BlindedHopData
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ BOLT1.empty_tlv_stream
+
+-- | The @payment_relay@ record of 'BlindedHopData'.
+data PaymentRelay = PaymentRelay
+ { pr_cltv_expiry_delta :: {-# UNPACK #-} !Word16
+ , pr_fee_proportional_millionths :: {-# UNPACK #-} !Word32
+ , pr_fee_base_msat :: {-# UNPACK #-} !Word32
+ } deriving (Eq, Show, Generic)
--- | Invalid HMAC in onion.
-pattern InvalidOnionHmac :: FailureCode
-pattern InvalidOnionHmac = FailureCode 0xC005 -- BADONION .|. PERM .|. 5
+instance NFData PaymentRelay
--- | Invalid ephemeral key in onion.
-pattern InvalidOnionKey :: FailureCode
-pattern InvalidOnionKey = FailureCode 0xC006 -- BADONION .|. PERM .|. 6
+-- | The @payment_constraints@ record of 'BlindedHopData'.
+data PaymentConstraints = PaymentConstraints
+ { pc_max_cltv_expiry :: {-# UNPACK #-} !Word32
+ , pc_htlc_minimum_msat :: !BOLT1.MilliSatoshi
+ } deriving (Eq, Show, Generic)
--- | Temporary channel failure.
-pattern TemporaryChannelFailure :: FailureCode
-pattern TemporaryChannelFailure = FailureCode 0x1007 -- UPDATE .|. 7
+instance NFData PaymentConstraints
--- | Permanent channel failure.
-pattern PermanentChannelFailure :: FailureCode
-pattern PermanentChannelFailure = FailureCode 0x4008 -- PERM .|. 8
+-- | What a node in a blinded route learns from its
+-- @encrypted_recipient_data@.
+data BlindedInfo = BlindedInfo
+ { bi_data :: !BlindedHopData
+ -- ^ the decrypted @encrypted_data_tlv@
+ , bi_next_path_key :: !BOLT1.Point
+ -- ^ the @path_key@ to send to the next node
+ } deriving (Eq, Show, Generic)
--- | Amount below minimum for channel.
-pattern AmountBelowMinimum :: FailureCode
-pattern AmountBelowMinimum = FailureCode 0x100B -- UPDATE .|. 11
+instance NFData BlindedInfo
--- | Fee insufficient.
-pattern FeeInsufficient :: FailureCode
-pattern FeeInsufficient = FailureCode 0x100C -- UPDATE .|. 12
+-- failure messages -----------------------------------------------------------
--- | Incorrect CLTV expiry.
-pattern IncorrectCltvExpiry :: FailureCode
-pattern IncorrectCltvExpiry = FailureCode 0x100D -- UPDATE .|. 13
+-- | A failure message (@failuremsg@): a failure, followed by an optional
+-- TLV stream.
+data FailureMessage = FailureMessage
+ { fm_failure :: !Failure
+ , fm_tlvs :: !BOLT1.TlvStream
+ } deriving (Eq, Show, Generic)
--- | Expiry too soon.
-pattern ExpiryTooSoon :: FailureCode
-pattern ExpiryTooSoon = FailureCode 0x100E -- UPDATE .|. 14
+instance NFData FailureMessage
--- | Payment details incorrect or unknown.
-pattern IncorrectOrUnknownPaymentDetails :: FailureCode
-pattern IncorrectOrUnknownPaymentDetails = FailureCode 0x400F -- PERM .|. 15
+-- | A failure: a failure code and its data.
+--
+-- A @channel_update@ field holds the raw bytes of the update; it is
+-- empty when the update is omitted.
+data Failure
+ = TemporaryNodeFailure
+ -- ^ NODE|2
+ | PermanentNodeFailure
+ -- ^ PERM|NODE|2
+ | RequiredNodeFeatureMissing
+ -- ^ PERM|NODE|3
+ | InvalidOnionVersion !OnionHash
+ -- ^ BADONION|PERM|4: @sha256_of_onion@
+ | InvalidOnionHmac !OnionHash
+ -- ^ BADONION|PERM|5: @sha256_of_onion@
+ | InvalidOnionKey !OnionHash
+ -- ^ BADONION|PERM|6: @sha256_of_onion@
+ | TemporaryChannelFailure !BS.ByteString
+ -- ^ UPDATE|7: @channel_update@
+ | PermanentChannelFailure
+ -- ^ PERM|8
+ | RequiredChannelFeatureMissing
+ -- ^ PERM|9
+ | UnknownNextPeer
+ -- ^ PERM|10
+ | AmountBelowMinimum !BOLT1.MilliSatoshi !BS.ByteString
+ -- ^ UPDATE|11: @htlc_msat@, @channel_update@
+ | FeeInsufficient !BOLT1.MilliSatoshi !BS.ByteString
+ -- ^ UPDATE|12: @htlc_msat@, @channel_update@
+ | IncorrectCltvExpiry {-# UNPACK #-} !Word32 !BS.ByteString
+ -- ^ UPDATE|13: @cltv_expiry@, @channel_update@
+ | ExpiryTooSoon !BS.ByteString
+ -- ^ UPDATE|14: @channel_update@
+ | IncorrectOrUnknownPaymentDetails !BOLT1.MilliSatoshi
+ {-# UNPACK #-} !Word32
+ -- ^ PERM|15: @htlc_msat@, @height@
+ | FinalIncorrectCltvExpiry {-# UNPACK #-} !Word32
+ -- ^ 18: @cltv_expiry@
+ | FinalIncorrectHtlcAmount !BOLT1.MilliSatoshi
+ -- ^ 19: @incoming_htlc_amt@
+ | ChannelDisabled {-# UNPACK #-} !Word16 !BS.ByteString
+ -- ^ UPDATE|20: @disabled_flags@, @channel_update@
+ | ExpiryTooFar
+ -- ^ 21
+ | InvalidOnionPayload !(Maybe (Word64, Word16))
+ -- ^ PERM|22: the optional @type@ and @offset@
+ | MppTimeout
+ -- ^ 23
+ | InvalidOnionBlinding !OnionHash
+ -- ^ BADONION|PERM|24: @sha256_of_onion@
+ | UnknownFailure {-# UNPACK #-} !Word16 !BS.ByteString
+ -- ^ a failure code not defined above, and the bytes following it
+ deriving (Eq, Show, Generic)
--- | Final incorrect CLTV expiry.
-pattern FinalIncorrectCltvExpiry :: FailureCode
-pattern FinalIncorrectCltvExpiry = FailureCode 18 -- 0x12
+instance NFData Failure
--- | Final incorrect HTLC amount.
-pattern FinalIncorrectHtlcAmount :: FailureCode
-pattern FinalIncorrectHtlcAmount = FailureCode 19 -- 0x13
+-- | A 32-byte @sha256_of_onion@.
+newtype OnionHash = OnionHash BS.ByteString
+ deriving (Eq, Show, Generic)
--- | Channel disabled.
-pattern ChannelDisabled :: FailureCode
-pattern ChannelDisabled = FailureCode 0x1014 -- UPDATE .|. 20
+instance NFData OnionHash
--- | Expiry too far.
-pattern ExpiryTooFar :: FailureCode
-pattern ExpiryTooFar = FailureCode 21 -- 0x15
+-- | Construct an 'OnionHash' from exactly 32 bytes.
+--
+-- >>> fmap (BS.length . un_onion_hash) (onion_hash (BS.replicate 32 0))
+-- Just 32
+onion_hash :: BS.ByteString -> Maybe OnionHash
+onion_hash bs
+ | BS.length bs == 32 = Just (OnionHash bs)
+ | otherwise = Nothing
+{-# INLINE onion_hash #-}
+
+-- | The bytes of an 'OnionHash'.
+un_onion_hash :: OnionHash -> BS.ByteString
+un_onion_hash (OnionHash bs) = bs
+{-# INLINE un_onion_hash #-}
+
+-- | The @failure_code@ of a 'Failure'.
+--
+-- >>> failure_code TemporaryNodeFailure
+-- 8194
+-- >>> failure_code (UnknownFailure 0x1234 mempty)
+-- 4660
+failure_code :: Failure -> Word16
+failure_code f = case f of
+ TemporaryNodeFailure -> 0x2002
+ PermanentNodeFailure -> 0x6002
+ RequiredNodeFeatureMissing -> 0x6003
+ InvalidOnionVersion _ -> 0xc004
+ InvalidOnionHmac _ -> 0xc005
+ InvalidOnionKey _ -> 0xc006
+ TemporaryChannelFailure _ -> 0x1007
+ PermanentChannelFailure -> 0x4008
+ RequiredChannelFeatureMissing -> 0x4009
+ UnknownNextPeer -> 0x400a
+ AmountBelowMinimum _ _ -> 0x100b
+ FeeInsufficient _ _ -> 0x100c
+ IncorrectCltvExpiry _ _ -> 0x100d
+ ExpiryTooSoon _ -> 0x100e
+ IncorrectOrUnknownPaymentDetails _ _ -> 0x400f
+ FinalIncorrectCltvExpiry _ -> 0x0012
+ FinalIncorrectHtlcAmount _ -> 0x0013
+ ChannelDisabled _ _ -> 0x1014
+ ExpiryTooFar -> 0x0015
+ InvalidOnionPayload _ -> 0x4016
+ MppTimeout -> 0x0017
+ InvalidOnionBlinding _ -> 0xc018
+ UnknownFailure c _ -> c
+
+-- | Is the BADONION flag (0x8000) set: was the onion unparsable?
+--
+-- >>> is_badonion TemporaryNodeFailure
+-- False
+is_badonion :: Failure -> Bool
+is_badonion f = failure_code f .&. 0x8000 /= 0
+{-# INLINE is_badonion #-}
--- | Invalid onion payload.
-pattern InvalidOnionPayload :: FailureCode
-pattern InvalidOnionPayload = FailureCode 0x4016 -- PERM .|. 22
+-- | Is the PERM flag (0x4000) set: is the failure permanent?
+--
+-- >>> is_perm PermanentNodeFailure
+-- True
+is_perm :: Failure -> Bool
+is_perm f = failure_code f .&. 0x4000 /= 0
+{-# INLINE is_perm #-}
--- | MPP timeout.
-pattern MppTimeout :: FailureCode
-pattern MppTimeout = FailureCode 23 -- 0x17
+-- | Is the NODE flag (0x2000) set: is it a node (not channel) failure?
+--
+-- >>> is_node TemporaryNodeFailure
+-- True
+is_node :: Failure -> Bool
+is_node f = failure_code f .&. 0x2000 /= 0
+{-# INLINE is_node #-}
+
+-- | Is the UPDATE flag (0x1000) set: was a channel forwarding parameter
+-- violated?
+--
+-- >>> is_update (ExpiryTooSoon mempty)
+-- True
+is_update :: Failure -> Bool
+is_update f = failure_code f .&. 0x1000 /= 0
+{-# INLINE is_update #-}
+
+-- errors ---------------------------------------------------------------------
+
+-- | Why a decoder failed.
+data DecodeError
+ = InvalidLength
+ -- ^ the input has the wrong length
+ | InvalidPoint
+ -- ^ a point lacks a compressed-encoding prefix
+ | InvalidTlvStream !BOLT1.TlvError
+ -- ^ the TLV stream is malformed, or has an unknown even type
+ | InvalidTlvValue {-# UNPACK #-} !Word64
+ -- ^ the value of the record of this type is malformed
+ | InvalidFailureData {-# UNPACK #-} !Word16
+ -- ^ the data of a failure with this code is malformed
+ deriving (Eq, Show, Generic)
--- Processing results -------------------------------------------------------
+instance NFData DecodeError
--- | Result of processing an onion packet.
-data ProcessResult
- = Forward !ForwardInfo -- ^ Forward to next hop
- | Receive !ReceiveInfo -- ^ Final destination reached
+-- | Why an encoder failed.
+data EncodeError
+ = ConflictingTlv
+ -- ^ an extra TLV record has the type of a known record
+ | FieldTooLong
+ -- ^ a length-prefixed field exceeds its maximum length
deriving (Eq, Show, Generic)
--- | Information for forwarding to next hop.
-data ForwardInfo = ForwardInfo
- { fiNextPacket :: !OnionPacket
- , fiPayload :: !HopPayload
- , fiSharedSecret :: !SharedSecret -- ^ For error attribution
- } deriving (Eq, Show, Generic)
-
--- | Information for receiving at final destination.
-data ReceiveInfo = ReceiveInfo
- { riPayload :: !HopPayload
- , riSharedSecret :: !SharedSecret
- } deriving (Eq, Show, Generic)
+instance NFData EncodeError
+
+-- | Why an onion packet was rejected.
+data ProcessError
+ = InvalidVersion {-# UNPACK #-} !Word8
+ -- ^ the version byte is not 0
+ | InvalidPublicKey
+ -- ^ the ephemeral public key is not a valid point
+ | HmacMismatch
+ -- ^ the packet's HMAC is wrong
+ | InvalidPayloadLength
+ -- ^ the payload length is malformed, below 2, or past the end of
+ -- @hop_payloads@
+ | InvalidPayload !DecodeError
+ -- ^ the payload is not a valid @payload@ TLV stream
+ | InvalidPathKey
+ -- ^ the path key is not a valid point
+ | UnexpectedPathKey
+ -- ^ a path key was given with no @encrypted_recipient_data@, or
+ -- both a @path_key@ and a @current_path_key@ were given
+ | MissingPathKey
+ -- ^ @encrypted_recipient_data@ was given with no path key
+ | InvalidRecipientData
+ -- ^ the @encrypted_recipient_data@ doesn't decrypt to a valid
+ -- @encrypted_data_tlv@ stream
+ 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
+instance NFData ProcessError
diff --git a/ppad-bolt4.cabal b/ppad-bolt4.cabal
@@ -1,18 +1,20 @@
cabal-version: 3.0
name: ppad-bolt4
-version: 0.0.1
-synopsis: BOLT4 (onion routing) for Lightning Network
+version: 0.1.0
+synopsis: Onion routing per BOLT #4
license: MIT
license-file: LICENSE
author: Jared Tobin
maintainer: jared@ppad.tech
category: Cryptography
build-type: Simple
-tested-with: GHC == 9.10.3
+tested-with: GHC == { 9.10.3 }
extra-doc-files: CHANGELOG
description:
- A pure Haskell implementation of BOLT4 (onion routing) from
- the Lightning Network protocol specification.
+ Onion routing for the Lightning Network, per BOLT #4
+ (<https://github.com/lightning/bolts/blob/master/04-onion-routing.md>):
+ onion construction and processing, returning errors, and route
+ blinding.
source-repository head
type: git
@@ -22,26 +24,28 @@ library
default-language: Haskell2010
hs-source-dirs: lib
ghc-options:
- -Wall
+ -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.Internal
- Lightning.Protocol.BOLT4.Prim
- Lightning.Protocol.BOLT4.Process
- Lightning.Protocol.BOLT4.Types
+ Lightning.Protocol.BOLT4
+ other-modules:
+ 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-bolt1 >= 0.0.1 && < 0.1
- , ppad-chacha >= 0.2 && < 0.3
+ , bytestring >= 0.11.1 && < 0.13
+ , deepseq >= 1.4 && < 1.6
+ , ppad-aead >= 0.3.6 && < 0.4
+ , ppad-bolt1 >= 0.1 && < 0.2
+ , ppad-bolt9 >= 0.1 && < 0.2
+ , ppad-chacha >= 0.3 && < 0.4
, ppad-fixed >= 0.2 && < 0.3
- , ppad-secp256k1 >= 0.5 && < 0.6
- , ppad-sha256 >= 0.3 && < 0.4
+ , ppad-secp256k1 >= 0.5.8 && < 0.6
+ , ppad-sha256 >= 0.3.2 && < 0.4
test-suite bolt4-tests
type: exitcode-stdio-1.0
@@ -50,12 +54,15 @@ test-suite bolt4-tests
main-is: Main.hs
other-modules: Vectors
ghc-options:
- -rtsopts -Wall -O2
+ -rtsopts -Wall
build-depends:
base
, bytestring
, ppad-base16
+ , ppad-bolt1
, ppad-bolt4
+ , ppad-bolt9
+ , ppad-chacha
, ppad-secp256k1
, ppad-sha256
, tasty
@@ -68,12 +75,13 @@ benchmark bolt4-bench
hs-source-dirs: bench
main-is: Main.hs
ghc-options:
- -rtsopts -O2 -Wall -fno-warn-orphans
+ -rtsopts -O2 -Wall
build-depends:
base
, bytestring
, criterion
, deepseq
+ , ppad-bolt1
, ppad-bolt4
benchmark bolt4-weigh
@@ -82,9 +90,11 @@ benchmark bolt4-weigh
hs-source-dirs: bench
main-is: Weight.hs
ghc-options:
- -rtsopts -O2 -Wall -fno-warn-orphans
+ -rtsopts -O2 -Wall
build-depends:
base
, bytestring
+ , deepseq
+ , ppad-bolt1
, ppad-bolt4
, weigh
