commit 9c7c325a8a3c0f6396f8192ce0156542689c9714
parent 8e4f8f54e8877fce725267ff84718053c300f400
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 15:06:11 +0400
Merge impl/modernize: 0.1.0 API
Port ppad-bolt4 to ppad-bolt1 0.1, ppad-bolt9 and ppad-chacha 0.3, and
redesign its API for the 0.1.0 release (lightning/bolts@1aadb719).
- A single public module, Lightning.Protocol.BOLT4, with snake_case
names. Prim, Codec, Internal and the other submodules are internal;
derived keys and blinding factors are no longer reachable, so the
keystream can't be fed a bad key and wrap_error is total.
- bolt1 types throughout: Point at the API boundary, MilliSatoshi
amounts, ShortChannelId, and bolt1's TLV streams in place of the
private BigSize/TLV/truncated-integer/SCID codecs. allowed_features
is a bolt9 FeatureVector.
- Secret keys (SecretKey) must be 32 bytes encoding a valid scalar.
Secret keys, shared secrets and payment secrets are abstract with
redacted Show; shared and payment secrets compare in constant time,
as does the onion HMAC check.
- process takes the path_key received with an onion, derives the
blinded private key, and decrypts encrypted_recipient_data with
path_key or current_path_key, returning its contents and the next
path key; decrypt_recipient_data exposes the same for a single hop.
- HopPayload and BlindedHopData reject unknown even TLV types and keep
unknown odd ones; payment_metadata and total_amount_msat are typed.
- Failures are a typed sum of every failure code in the spec, with an
escape hatch for unknown codes and derivable flags. unwrap_error
reports the hop whose HMAC matches even for a malformed message.
- Tests use the public API only and assert onion-test.json,
onion-error-test.json, the Returning Errors trace,
route-blinding-test.json (now including Bob's and Eve's
encrypted_data) and blinded-payment-onion-test.json end to end, with
negative tests for each rejection rule and round-trip properties.
- NFData instances, criterion and weigh benchmarks, README, CHANGELOG
and the pinned spec copy in etc/.
Not implemented (see README): attributable failures, onion messages,
the 32 KiB return packet cap, dummy unwrap rounds, the blinded_path
wire encoding.
Diffstat:
20 files changed, 3676 insertions(+), 4319 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -1,10 +1,12 @@
# ppad-bolt4
-A pure Haskell implementation of BOLT4 (onion routing) from the
-Lightning Network specification.
+A pure Haskell implementation of BOLT #4 (onion routing) from the
+Lightning Network specification, as of lightning/bolts@1aadb719 (copy
+in `etc/04-onion-routing.md`).
-The implementation consists of the ppad-bolt4 library, a test suite,
-and benchmarks (for time and space).
+The implementation consists of the ppad-bolt4 library (public API:
+Lightning.Protocol.BOLT4; the submodules are internal), a test suite
+(public API only), and benchmarks (for time and space).
## build
diff --git a/CHANGELOG b/CHANGELOG
@@ -1,4 +1,52 @@
# Changelog
-- 0.0.1 (UNRELEASED)
+- 0.1.0 (UNRELEASED)
+ * A substantial rewrite, with breaking changes throughout:
+
+ * The API is exported from Lightning.Protocol.BOLT4 alone, and uses
+ snake_case names (e.g. construct, process, construct_error,
+ create_blinded_path). The Prim, Codec and Internal modules are
+ no longer exposed.
+
+ * Fundamental types come from ppad-bolt1: points are Points,
+ amounts are MilliSatoshis, short channel ids and TLV streams are
+ bolt1's. allowed_features is a ppad-bolt9 FeatureVector. The
+ private BigSize, TLV and truncated-integer codecs are gone.
+
+ * Secret keys (SecretKey) must be exactly 32 bytes encoding a valid
+ scalar. Secret keys, shared secrets and payment secrets are
+ abstract, with redacted Show instances; shared and payment
+ secrets compare in constant time.
+
+ * process takes the path_key received with an onion, derives the
+ blinded private key, decrypts encrypted_recipient_data (using
+ path_key or current_path_key) and returns its contents and the
+ next path key.
+
+ * Hop payloads and encrypted_data_tlv streams reject unknown even
+ types and keep unknown odd ones, so re-encoding is exact.
+ payment_metadata and total_amount_msat are typed fields.
+
+ * Failures are a typed sum of every failure code in the spec, with
+ an escape hatch for unknown codes; invalid_realm is gone, and
+ required_channel_feature_missing, unknown_next_peer and
+ invalid_onion_blinding are new.
+
+ * unwrap_error reports the hop whose HMAC matches even when its
+ failure message is malformed. wrap_error is total, and
+ construct_error fails only on an unencodable failure message.
+
+ * Fixes onion construction for routes of three or more hops, the
+ framing and padding of failure messages, and decoding of payload
+ lengths past the end of hop_payloads, overlong TLV lengths and
+ unknown even TLV types.
+
+ * The onion HMAC check is constant time.
+
+ * Tests now cover the onion, error, route blinding and blinded
+ payment test vectors of BOLT #4, through the public API.
+
+ * Adds NFData instances, and criterion and weigh benchmarks.
+
+- 0.0.1 (2026-04-18)
* Initial release.
diff --git a/README.md b/README.md
@@ -4,9 +4,9 @@
[](https://docs.ppad.tech/bolt4)
-A pure Haskell implementation of [BOLT #4][bolt4] (onion routing) from
-the Lightning Network protocol specification, including packet
-construction and processing, error handling, and route blinding.
+A pure Haskell implementation of Lightning Network onion routing,
+[BOLT #4][bolt4]: onion construction and processing, returning errors,
+and route blinding.
## Usage
@@ -14,56 +14,128 @@ A sample GHCi session:
```
> :set -XOverloadedStrings
- >
- > -- construct an onion packet for a 3-hop route
- > import qualified Crypto.Curve.Secp256k1 as Secp256k1
> import qualified Data.ByteString as BS
- > import qualified Lightning.Protocol.BOLT4.Construct as Construct
- > import qualified Lightning.Protocol.BOLT4.Process as Process
- > import Lightning.Protocol.BOLT4.Types
+ > import qualified Lightning.Protocol.BOLT1 as BOLT1
+ > import Lightning.Protocol.BOLT4
+ >
+ > -- keys (use a fresh random session key for every 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)
>
- > -- session key (32 bytes random, use CSPRNG in production)
- > let sessionKey = BS.replicate 32 0x41
+ > -- a two-hop route, paying bob through alice
+ > let Just amt = BOLT1.milli_satoshi 100000
+ > let Just scid = BOLT1.short_channel_id 800000 1 0
+ > let pay = empty_hop_payload { hp_amt_to_forward = Just amt }
+ > :{
+ ghci| let to_alice = Hop (public_key alice) pay {
+ ghci| hp_outgoing_cltv_value = Just 800040
+ ghci| , hp_short_channel_id = Just scid
+ ghci| }
+ ghci| to_bob = Hop (public_key bob) pay {
+ ghci| hp_outgoing_cltv_value = Just 800000
+ ghci| }
+ ghci| :}
+ > let hash = BS.replicate 32 0xff
+ > let Right (onion, secrets) = construct session [to_alice, to_bob] hash
+ > BS.length (encode_onion_packet onion)
+ 1366
>
- > -- node keys (in production, these come from the network)
- > let Just hop1Sec = Secp256k1.parse_integer (BS.replicate 32 0x01)
- > let Just hop1Pub = Secp256k1.mul Secp256k1._CURVE_G hop1Sec
+ > -- each hop peels off its layer
+ > let Right (Forward fwd) = process alice onion hash Nothing
+ > hp_short_channel_id (fwd_payload fwd)
+ Just (ShortChannelId 879609302220865536)
+ > let next = fwd_next_packet fwd
+ > let Right (Receive rcv) = process bob next hash Nothing
+ > hp_amt_to_forward (rcv_payload rcv)
+ Just (MilliSatoshi 100000)
>
- > -- build a minimal payload
- > let payload = emptyHopPayload { hpAmtToForward = Just 1000
- > , hpOutgoingCltv = Just 144 }
- > let hop = Construct.Hop hop1Pub payload
+ > -- bob fails the payment, alice wraps the error, and the sender
+ > -- attributes it to bob
+ > let failure = FailureMessage MppTimeout BOLT1.empty_tlv_stream
+ > let Right err = construct_error (rcv_shared_secret rcv) failure
+ > unwrap_error secrets (wrap_error (fwd_shared_secret fwd) err)
+ Attributed 1 (FailureMessage {fm_failure = MppTimeout,
+ fm_tlvs = TlvStream []})
>
- > -- construct packet (returns packet + shared secrets for error handling)
- > let assocData = BS.replicate 32 0x00 -- typically payment_hash
- > let Right (packet, secrets) = Construct.construct sessionKey [hop] assocData
+ > -- bob hands out a blinded route to himself
+ > let Just seed = secret_key (BS.replicate 32 0x01)
+ > let mine = empty_blinded_hop_data { bhd_path_id = Just "invoice 1" }
+ > let Right path = create_blinded_path seed [(public_key bob, mine)]
+ > let [hop] = bp_hops path
>
- > -- process at receiving node
- > let result = Process.process (BS.replicate 32 0x01) packet assocData
- > case result of
- > Right (Process.Receive info) -> print (riPayload info)
- > _ -> putStrLn "not final hop"
+ > -- the sender reaches the route's introduction node through alice
+ > :{
+ ghci| let blinded = Hop (bp_first_node_id path) pay {
+ ghci| hp_outgoing_cltv_value = Just 800000
+ ghci| , hp_total_amount_msat = Just amt
+ ghci| , hp_encrypted_data = Just (bh_encrypted_data hop)
+ ghci| , hp_current_path_key = Just (bp_first_path_key path)
+ ghci| }
+ ghci| :}
+ > let Right (onion', _) = construct session [to_alice, blinded] hash
+ > let Right (Forward fwd') = process alice onion' hash Nothing
+ > let next' = fwd_next_packet fwd'
+ > let Right (Receive rcv') = process bob next' hash Nothing
+ > fmap (bhd_path_id . bi_data) (rcv_blinded rcv')
+ Just (Just "invoice 1")
```
-## Modules
+Nodes further along a blinded route pass the `path_key` they received
+(`bi_next_path_key` of the previous hop) as the last argument of
+`process`, which then derives their blinded private key.
-The library is organized into the following modules:
+## Documentation
-* `Lightning.Protocol.BOLT4.Construct` - onion packet construction
-* `Lightning.Protocol.BOLT4.Process` - onion packet processing
-* `Lightning.Protocol.BOLT4.Error` - failure message handling
-* `Lightning.Protocol.BOLT4.Blinding` - route blinding support
-* `Lightning.Protocol.BOLT4.Types` - core data types
-* `Lightning.Protocol.BOLT4.Codec` - serialization (BigSize, TLV)
-* `Lightning.Protocol.BOLT4.Prim` - cryptographic primitives
+Haddocks (API documentation, etc.) are hosted at
+[docs.ppad.tech/bolt4](https://docs.ppad.tech/bolt4).
-## Documentation
+## Specification
+
+This library implements BOLT #4 as of lightning/bolts commit
+[1aadb719][spec] (2026-09-21); a copy lives in `etc/`. It is tested
+against the `onion-test.json`, `onion-error-test.json`,
+`route-blinding-test.json` and `blinded-payment-onion-test.json`
+vectors, and the 'Returning Errors' trace.
+
+Fundamental types and the TLV format come from [ppad-bolt1][bolt1];
+`allowed_features` is a [ppad-bolt9][bolt9] feature vector.
+
+Not implemented:
+
+* Attributable failures (`option_attribution_data`): the
+ `attribution_data` of `update_fail_htlc` and `update_fulfill_htlc`,
+ and HTLC hold times.
+* Onion messages (`onion_message_packet`, `onionmsg_tlv`).
+* The 32 KiB limit on return packets: `construct_error` doesn't enforce
+ it, and `wrap_error` doesn't truncate longer packets.
+* The origin node's dummy decryption rounds: `unwrap_error` stops at the
+ hop whose HMAC matches.
+* The `blinded_path` wire encoding, and the computation of a blinded
+ route's total fees and CLTV delta.
-Haddocks are hosted at [docs.ppad.tech/bolt4][hadoc].
+`process` enforces the onion decryption requirements and the path key
+rules of route blinding; the reader requirements that depend on the
+HTLC or the node's channels (required fields, amount and expiry checks,
+`payment_relay` and `payment_constraints`, `allowed_features`, replayed
+HMACs) are left to the caller.
+
+## Performance
+
+The aim is best-in-class performance for pure Haskell code. Run the
+benchmarks with:
+
+```
+$ cabal bench
+```
## Security
-This is a pre-release library that claims no security properties whatsoever.
+This library has received no security audit. Secret keys, shared
+secrets and payment secrets are abstract and kept out of `Show` output;
+shared and payment secrets compare in constant time, and `process`
+checks onion HMACs in constant time. Scalar multiplications involving
+secrets use ppad-secp256k1's constant-time implementation.
## Development
@@ -77,12 +149,14 @@ $ nix develop
Then do e.g.:
```
-$ cabal build
-$ cabal test
-$ cabal bench
+$ cabal repl ppad-bolt4
```
+to get a REPL for the main library.
+
[bolt4]: https://github.com/lightning/bolts/blob/master/04-onion-routing.md
-[hadoc]: https://docs.ppad.tech/bolt4
+[bolt1]: https://git.ppad.tech/bolt1
+[bolt9]: https://git.ppad.tech/bolt9
+[spec]: https://github.com/lightning/bolts/tree/1aadb719b4007c4cea0ba6e36b08c4fb53788dee
[nixos]: https://nixos.org/
[flake]: https://nixos.org/manual/nix/unstable/command-ref/new-cli/nix3-flake.html
diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Fixtures (
+ Fixtures(..)
+ , fixtures
+ ) where
+
+import Control.DeepSeq (NFData(..))
+import qualified Data.ByteString as BS
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT4
+
+data Fixtures = Fixtures {
+ fx_session :: !SecretKey
+ , fx_ad :: !BS.ByteString
+ , fx_route_1 :: ![Hop]
+ , fx_route_5 :: ![Hop]
+ , fx_route_20 :: ![Hop]
+ , fx_first_node :: !SecretKey
+ , fx_onion_5 :: !OnionPacket
+ , fx_onion_1 :: !OnionPacket
+ , fx_secrets_5 :: ![SharedSecret]
+ , fx_secret :: !SharedSecret
+ , fx_blinded_node :: !SecretKey
+ , fx_blinded_onion :: !OnionPacket
+ , fx_path_key :: !BOLT1.Point
+ , fx_path_seed :: !SecretKey
+ , fx_path_nodes :: ![(BOLT1.Point, BlindedHopData)]
+ , fx_encrypted :: !BS.ByteString
+ , fx_failure :: !FailureMessage
+ , fx_error :: !ErrorPacket
+ , fx_returned :: !ErrorPacket
+ , fx_onion_bytes :: !BS.ByteString
+ , fx_payload :: !HopPayload
+ , fx_payload_bytes :: !BS.ByteString
+ }
+
+instance NFData Fixtures where
+ rnf (Fixtures a b c d e f g h i j k l m n o p q r s t u v) =
+ rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f
+ `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq` rnf k
+ `seq` rnf l `seq` rnf m `seq` rnf n `seq` rnf o `seq` rnf p
+ `seq` rnf q `seq` rnf r `seq` rnf s `seq` rnf t `seq` rnf u
+ `seq` rnf v
+
+demand :: String -> Maybe a -> IO a
+demand msg = maybe (ioError (userError msg)) pure
+
+right :: Show e => String -> Either e a -> IO a
+right msg = either (ioError . userError . (msg ++) . (": " ++) . show) pure
+
+fixtures :: IO Fixtures
+fixtures = do
+ let key b = demand "secret_key" (secret_key (BS.replicate 32 b))
+ ad = BS.replicate 32 0x42
+ session <- key 0x41
+ nodes <- mapM key [1 .. 20]
+ amt <- demand "milli_satoshi" (BOLT1.milli_satoshi 100000)
+ scid <- demand "short_channel_id" (BOLT1.short_channel_id 800000 1 0)
+ ps <- demand "payment_secret" (payment_secret (BS.replicate 32 0xaa))
+ let fwd = empty_hop_payload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 800000
+ , hp_short_channel_id = Just scid
+ }
+ final = empty_hop_payload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 800000
+ , hp_payment_data = Just (PaymentData ps amt)
+ }
+ route n = [ Hop (public_key k) fwd | k <- take (n - 1) nodes ]
+ ++ [ Hop (public_key k) final
+ | k <- take 1 (drop (n - 1) nodes) ]
+ first_node <- demand "node" (safe_head nodes)
+ (onion_5, secrets_5) <- right "construct" (construct session (route 5) ad)
+ (onion_1, _) <- right "construct" (construct session (route 1) ad)
+
+ -- a blinded route through nodes 1 to 3, entered at node 0
+ seed <- key 0x55
+ let relay = empty_blinded_hop_data
+ { bhd_short_channel_id = Just scid
+ , bhd_payment_relay = Just (PaymentRelay 40 100 1000)
+ }
+ path_nodes = [ (public_key k, relay) | k <- take 2 (drop 1 nodes) ]
+ ++ [ (public_key k, empty_blinded_hop_data
+ { bhd_path_id = Just (BS.replicate 32 1) })
+ | k <- take 1 (drop 3 nodes) ]
+ path <- right "create_blinded_path" (create_blinded_path seed path_nodes)
+ hops <- case bp_hops path of
+ [h1, h2, h3] -> pure (h1, h2, h3)
+ _ -> ioError (userError "expected 3 blinded hops")
+ let (h1, h2, h3) = hops
+ bhop h pl = Hop (bh_blinded_node_id h)
+ pl { hp_encrypted_data = Just (bh_encrypted_data h) }
+ entry = Hop (public_key first_node) fwd
+ broute = [ entry
+ , Hop (bp_first_node_id path) empty_hop_payload
+ { hp_encrypted_data = Just (bh_encrypted_data h1)
+ , hp_current_path_key = Just (bp_first_path_key path) }
+ , bhop h2 empty_hop_payload
+ , bhop h3 empty_hop_payload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 800000
+ , hp_total_amount_msat = Just amt } ]
+ (bonion, _) <- right "construct" (construct session broute ad)
+ -- the onion received, with a path_key, by node 2
+ node1 <- demand "node" (safe_head (drop 1 nodes))
+ node2 <- demand "node" (safe_head (drop 2 nodes))
+ f0 <- forwarded (process first_node bonion ad Nothing)
+ f1 <- forwarded (process node1 (fwd_next_packet f0) ad Nothing)
+ b1 <- demand "blinded" (fwd_blinded f1)
+
+ -- node 4 fails a 5-hop payment
+ ss4 <- demand "secret" (safe_head (drop 4 secrets_5))
+ let failure = FailureMessage TemporaryNodeFailure BOLT1.empty_tlv_stream
+ err <- right "construct_error" (construct_error ss4 failure)
+ let returned = foldr wrap_error err (take 4 secrets_5)
+
+ payload_bytes <- right "encode_hop_payload" (encode_hop_payload final)
+ pure Fixtures {
+ fx_session = session
+ , fx_ad = ad
+ , fx_route_1 = route 1
+ , fx_route_5 = route 5
+ , fx_route_20 = route 20
+ , fx_first_node = first_node
+ , fx_onion_5 = onion_5
+ , fx_onion_1 = onion_1
+ , fx_secrets_5 = secrets_5
+ , fx_secret = ss4
+ , fx_blinded_node = node2
+ , fx_blinded_onion = fwd_next_packet f1
+ , fx_path_key = bi_next_path_key b1
+ , fx_path_seed = seed
+ , fx_path_nodes = path_nodes
+ , fx_encrypted = bh_encrypted_data h2
+ , fx_failure = failure
+ , fx_error = err
+ , fx_returned = returned
+ , fx_onion_bytes = encode_onion_packet onion_5
+ , fx_payload = final
+ , fx_payload_bytes = payload_bytes
+ }
+ where
+ safe_head xs = case xs of
+ x : _ -> Just x
+ [] -> Nothing
+ forwarded r = case r of
+ Right (Forward f) -> pure f
+ _ -> ioError (userError ("expected Forward: " ++ show r))
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -1,10 +1,55 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Main where
import Criterion.Main
+import Fixtures
+import Lightning.Protocol.BOLT4
main :: IO ()
main = defaultMain [
+ env fixtures $ \fx -> bgroup "ppad-bolt4" [
+ bgroup "construct" [
+ bench "1 hop" $
+ nf (construct (fx_session fx) (fx_route_1 fx)) (fx_ad fx)
+ , bench "5 hops" $
+ nf (construct (fx_session fx) (fx_route_5 fx)) (fx_ad fx)
+ , bench "20 hops" $
+ nf (construct (fx_session fx) (fx_route_20 fx)) (fx_ad fx)
+ ]
+ , bgroup "process" [
+ bench "forward" $
+ nf (process (fx_first_node fx) (fx_onion_5 fx) (fx_ad fx))
+ Nothing
+ , bench "receive" $
+ nf (process (fx_first_node fx) (fx_onion_1 fx) (fx_ad fx))
+ Nothing
+ , bench "forward (blinded)" $
+ nf (process (fx_blinded_node fx) (fx_blinded_onion fx) (fx_ad fx))
+ (Just (fx_path_key fx))
+ ]
+ , bgroup "returning errors" [
+ bench "construct_error" $
+ nf (construct_error (fx_secret fx)) (fx_failure fx)
+ , bench "wrap_error" $
+ nf (wrap_error (fx_secret fx)) (fx_error fx)
+ , bench "unwrap_error (hop 4 of 5)" $
+ nf (unwrap_error (fx_secrets_5 fx)) (fx_returned fx)
+ ]
+ , bgroup "route blinding" [
+ bench "create_blinded_path (3 hops)" $
+ nf (create_blinded_path (fx_path_seed fx)) (fx_path_nodes fx)
+ , bench "decrypt_recipient_data" $
+ nf (decrypt_recipient_data (fx_blinded_node fx) (fx_path_key fx))
+ (fx_encrypted fx)
+ ]
+ , bgroup "codecs" [
+ bench "encode_onion_packet" $
+ nf encode_onion_packet (fx_onion_5 fx)
+ , bench "decode_onion_packet" $
+ nf decode_onion_packet (fx_onion_bytes fx)
+ , bench "encode_hop_payload" $
+ nf encode_hop_payload (fx_payload fx)
+ , bench "decode_hop_payload" $
+ nf decode_hop_payload (fx_payload_bytes fx)
+ ]
+ ]
]
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -1,9 +1,38 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Main where
+import Fixtures
+import Lightning.Protocol.BOLT4
import Weigh
main :: IO ()
-main = mainWith (pure ())
+main = do
+ fx <- fixtures
+ mainWith $ do
+ wgroup "construct" $ do
+ func "1 hop" (construct (fx_session fx) (fx_route_1 fx)) (fx_ad fx)
+ func "5 hops" (construct (fx_session fx) (fx_route_5 fx)) (fx_ad fx)
+ func "20 hops" (construct (fx_session fx) (fx_route_20 fx)) (fx_ad fx)
+ wgroup "process" $ do
+ func "forward"
+ (process (fx_first_node fx) (fx_onion_5 fx) (fx_ad fx)) Nothing
+ func "receive"
+ (process (fx_first_node fx) (fx_onion_1 fx) (fx_ad fx)) Nothing
+ func "forward (blinded)"
+ (process (fx_blinded_node fx) (fx_blinded_onion fx) (fx_ad fx))
+ (Just (fx_path_key fx))
+ wgroup "returning errors" $ do
+ func "construct_error" (construct_error (fx_secret fx)) (fx_failure fx)
+ func "wrap_error" (wrap_error (fx_secret fx)) (fx_error fx)
+ func "unwrap_error (hop 4 of 5)"
+ (unwrap_error (fx_secrets_5 fx)) (fx_returned fx)
+ wgroup "route blinding" $ do
+ func "create_blinded_path (3 hops)"
+ (create_blinded_path (fx_path_seed fx)) (fx_path_nodes fx)
+ func "decrypt_recipient_data"
+ (decrypt_recipient_data (fx_blinded_node fx) (fx_path_key fx))
+ (fx_encrypted fx)
+ wgroup "codecs" $ do
+ func "encode_onion_packet" encode_onion_packet (fx_onion_5 fx)
+ func "decode_onion_packet" decode_onion_packet (fx_onion_bytes fx)
+ func "encode_hop_payload" encode_hop_payload (fx_payload fx)
+ func "decode_hop_payload" decode_hop_payload (fx_payload_bytes fx)
diff --git a/etc/04-onion-routing.md b/etc/04-onion-routing.md
@@ -63,6 +63,7 @@ A node:
* [Returning Errors](#returning-errors)
* [Failure Messages](#failure-messages)
* [Receiving Failure Codes](#receiving-failure-codes)
+ * [Successful Payments](#successful-payments)
* [Onion Messages](#onion-messages)
* [`max_htlc_cltv` Selection](#max_htlc_cltv-selection)
* [Test Vector](#test-vector)
@@ -98,6 +99,8 @@ There are a number of conventions adhered to throughout this document:
- Each hop in the route has a variable length `hop_payload`.
- The variable length `hop_payload` is prefixed with a `bigsize` encoding
the length in bytes, excluding the prefix and the trailing HMAC.
+ - These `hop_payload`s are used to build the combined payload in the packet,
+ also referred to as `hop_payloads` or the mix-header.
# Key Generation
@@ -334,8 +337,8 @@ The reader:
- incoming `amount_msat` - `fee` < `amt_to_forward` (where `fee` is the advertised fee as described in [BOLT #7](07-routing-gossip.md#htlc-fees))
- `cltv_expiry` - `cltv_expiry_delta` < `outgoing_cltv_value`
- If it is the final node:
- - MUST treat `total_msat` as if it were equal to `amt_to_forward` if it is not present.
- MUST return an error if:
+ - `total_msat` is not present
- incoming `amount_msat` < `amt_to_forward`.
- incoming `cltv_expiry` < `outgoing_cltv_value`.
- incoming `cltv_expiry` < `current_block_height` + `min_final_cltv_expiry_delta`.
@@ -754,7 +757,8 @@ public keys for `n_1` to `n_r` and generates a random 32-byte `sessionkey`.
Optionally, the sender may pass in _associated data_, i.e. data that the
packet commits to but that is not included in the packet itself. Associated
data will be included in the HMACs and must match the associated data provided
-during integrity verification at each hop.
+during integrity verification at each hop. The `payment_hash` is commonly used for
+this purpose.
To construct the onion, the sender initializes the ephemeral private key for the
first hop `ek_1` to the `sessionkey` and derives from it the corresponding
@@ -796,11 +800,12 @@ following operations:
- The _rho_-key and _mu_-key are generated using the hop's shared secret.
- `shift_size` is defined as the length of the `hop_payload` plus the bigsize encoding of the length and the length of that HMAC. Thus if the payload length is `l` then the `shift_size` is `1 + l + 32` for `l < 253`, otherwise `3 + l + 32` due to the bigsize encoding of `l`.
- - The `hop_payload` field is right-shifted by `shift_size` bytes, discarding the last `shift_size`
+ - The `hop_payloads` field is right-shifted by `shift_size` bytes, discarding the last `shift_size`
bytes that exceed its 1300-byte size.
- - The bigsize-serialized length, serialized `hop_payload` and `hmac` are copied into the following `shift_size` bytes.
- - The _rho_-key is used to generate 1300 bytes of pseudo-random byte stream
- which is then applied, with `XOR`, to the `hop_payloads` field.
+ - The bigsize-serialized length, serialized `hop_payload` and `hmac` are copied into the `shift_size` bytes as the
+ beginning of the mix-header.
+ - The _rho_-key is used to generate a 1300 byte pseudo-random stream
+ which is then applied, with `XOR`, to the `hop_payloads` field.
- If this is the last hop, i.e. the first iteration, then the tail of the
`hop_payloads` field is overwritten with the routing information `filler`.
- The next HMAC is computed (with the _mu_-key as HMAC-key) over the
@@ -816,6 +821,8 @@ the obfuscated `hop_payloads`.
The following Go code is an example implementation of the packet construction:
```Go
+const RoutingInfoSize int32 = 1300
+
func NewOnionPacket(paymentPath []*btcec.PublicKey, sessionKey *btcec.PrivateKey,
hopsData []HopData, assocData []byte) (*OnionPacket, error) {
@@ -849,17 +856,17 @@ func NewOnionPacket(paymentPath []*btcec.PublicKey, sessionKey *btcec.PrivateKey
}
// Generate the padding, called "filler strings" in the paper.
- filler := generateHeaderPadding("rho", numHops, hopDataSize, hopSharedSecrets)
+ filler := generateHeaderPadding(numHops, hopSharedSecrets)
// Allocate and initialize fields to zero-filled slices
- var mixHeader [routingInfoSize]byte
- var nextHmac [hmacSize]byte
+ var mixHeader [RoutingInfoSize]byte
+ var nextHmac [32]byte
- // Our starting packet needs to be filled out with random bytes, we
- // generate some deterministically using the session private key.
- paddingKey := generateKey("pad", sessionKey.Serialize())
- paddingBytes := generateCipherStream(paddingKey, routingInfoSize)
- copy(mixHeader[:], paddingBytes)
+ // Our starting packet needs to be filled out with random bytes, we
+ // generate some deterministically using the session private key.
+ paddingKey := generateKey("pad", sessionKey.Serialize())
+ paddingBytes := generateCipherStream(paddingKey, RoutingInfoSize)
+ copy(mixHeader[:], paddingBytes)
// Compute the routing information for each hop along with a
// MAC of the routing information using the shared key for that hop.
@@ -870,13 +877,13 @@ func NewOnionPacket(paymentPath []*btcec.PublicKey, sessionKey *btcec.PrivateKey
hopsData[i].HMAC = nextHmac
// Shift and obfuscate routing information
- streamBytes := generateCipherStream(rhoKey, numStreamBytes)
+ streamBytes := generateCipherStream(rhoKey, RoutingInfoSize)
rightShift(mixHeader[:], hopDataSize)
buf := &bytes.Buffer{}
hopsData[i].Encode(buf)
copy(mixHeader[:], buf.Bytes())
- xor(mixHeader[:], mixHeader[:], streamBytes[:routingInfoSize])
+ xor(mixHeader[:], mixHeader[:], streamBytes[:RoutingInfoSize])
// These need to be overwritten, so every node generates a correct padding
if i == numHops-1 {
@@ -985,35 +992,42 @@ obfuscating the added `0x00`-bytes at the end.
In order to compute the correct HMAC, the origin node has to pre-generate the
`hop_payloads` for each hop, including the incrementally obfuscated padding added
by each hop. This incrementally obfuscated padding is referred to as the
-`filler`.
+`filler`. Keep in mind that while the mix-header is generated in reverse-route order,
+the filler is generated in route order.
The following example code shows how the filler is generated in Go:
```Go
-func generateFiller(key string, numHops int, hopSize int, sharedSecrets [][sharedSecretSize]byte) []byte {
- fillerSize := uint((numMaxHops + 1) * hopSize)
+const (
+ // The mix-header in Lightning is a max of 1300 bytes
+ NumMaxHops int = 20
+ HopSize = 65
+)
+
+func generateFiller(numHops int, sharedSecrets [][sharedSecretSize]byte) []byte {
+ fillerSize := uint((NumMaxHops + 1) * HopSize)
filler := make([]byte, fillerSize)
// The last hop does not obfuscate, it's not forwarding anymore.
for i := 0; i < numHops-1; i++ {
// Left-shift the field
- copy(filler[:], filler[hopSize:])
+ copy(filler[:], filler[HopSize:])
// Zero-fill the last hop
- copy(filler[len(filler)-hopSize:], bytes.Repeat([]byte{0x00}, hopSize))
+ copy(filler[len(filler)-HopSize:], bytes.Repeat([]byte{0x00}, HopSize))
// Generate pseudo-random byte stream
- streamKey := generateKey(key, sharedSecrets[i])
+ streamKey := generateKey("rho", sharedSecrets[i])
streamBytes := generateCipherStream(streamKey, fillerSize)
// Obfuscate
xor(filler, filler, streamBytes)
}
- // Cut filler down to the correct length (numHops+1)*hopSize
+ // Cut filler down to the correct length (numHops+1)*HopSize
// bytes will be prepended by the packet generation.
- return filler[(numMaxHops-numHops+2)*hopSize:]
+ return filler[(NumMaxHops-numHops+2)*HopSize:]
}
```
@@ -1033,6 +1047,10 @@ besides the origin has access to the information required for its generation.
Note that these error messages are not reliable, as they are not placed on-chain
due to the possibility of hop failure.
+Return packets are limited to 32768 bytes (32 KiB), leaving room in `update_fail_htlc` for `attribution_data` and future
+extensions. Earlier versions permitted larger return packets, so intermediate nodes truncate them to their first 32768
+bytes instead of rejecting the corresponding message.
+
Intermediate hops store the shared secret from the forward path and reuse it to
authenticate and obfuscate any corresponding return packet during each hop.
In addition, each node locally stores data regarding its own sending peer in the
@@ -1118,6 +1136,7 @@ which is in turn applied to the `attribution_data` field using `XOR`.
### Requirements
The _erring node_:
+ - MUST construct the return packet such that its total length is no more than 32768 bytes (32 KiB).
- MUST set `pad` such that the `failure_len` plus `pad_len` is at least 256.
- SHOULD set `pad` such that the `failure_len` plus `pad_len` is equal to
256. Deviating from this may cause older nodes to be unable to parse the
@@ -1164,14 +1183,16 @@ packet. This is then stored as the `reason` field of the `update_htlc_fail` mess
### Requirements
-- if `option_attribution_data` is advertised:
- - if `path_key` is not set in the incoming `update_add_htlc`:
- - if `attribution_data` is received from downstream:
- - MUST transform `attribution_data` as described above
- - otherwise:
- - MUST instantiate an all-zeroes `attribution_data` block
- - MUST update `attribution_data` as described above
-- all nodes:
+The _intermediate node_:
+ - if the return packet received from downstream is longer than 32768 bytes:
+ - MUST truncate it to its first 32768 bytes before transforming the return packet or updating `attribution_data`
+ - if `option_attribution_data` is advertised:
+ - if `path_key` is not set in the incoming `update_add_htlc`:
+ - if `attribution_data` is received from downstream:
+ - MUST transform `attribution_data` as described above
+ - otherwise:
+ - MUST instantiate an all-zeroes `attribution_data` block
+ - MUST update `attribution_data` as described above
- MUST transform the return packet as described above.
- MUST return-forward the `update_htlc_fail` message
@@ -1457,19 +1478,12 @@ An _erring node_ MAY:
A _forwarding node_ MUST:
- if `path_key` is set in the incoming `update_add_htlc`:
- return an `invalid_onion_blinding` error.
- - if `current_path_key` is set in the onion payload and it is not the
- final node:
+ - if `current_path_key` is set in the onion payload:
- return an `invalid_onion_blinding` error.
- otherwise:
- select one of the above error codes when creating an error message.
A _forwarding node_ MAY, but a _final node_ MUST NOT:
- - if the onion `version` byte is unknown:
- - return an `invalid_onion_version` error.
- - if the onion HMAC is incorrect:
- - return an `invalid_onion_hmac` error.
- - if the ephemeral key in the onion is unparsable:
- - return an `invalid_onion_key` error.
- if during forwarding to its receiving peer, an otherwise unspecified,
transient error occurs in the outgoing channel (e.g. channel capacity reached,
too many in-flight HTLCs, etc.):
@@ -1504,7 +1518,15 @@ A _forwarding node_ MAY, but a _final node_ MUST NOT:
- report the current channel setting for the outgoing channel.
- return a `channel_disabled` error.
-An _intermediate hop_ MUST NOT, but the _final node_:
+A _forwarding node_ and a _final node_ MAY:
+ - if the onion `version` byte is unknown:
+ - return an `invalid_onion_version` error.
+ - if the onion HMAC is incorrect:
+ - return an `invalid_onion_hmac` error.
+ - if the ephemeral key in the onion is unparsable:
+ - return an `invalid_onion_key` error.
+
+A _forwarding node_ MUST NOT, but a _final node_ MUST:
- if the payment hash has already been paid:
- MAY treat the payment hash as unknown.
- MAY succeed in accepting the HTLC.
@@ -1583,11 +1605,97 @@ The _origin node_:
- MAY use the data specified in the various failure types for debugging
purposes.
-# Hold times for successful payments
+# Successful Payments
-The `update_fulfill_htlc` message contains an optional `attribution_data` field, similar to the one used in the failure
-case described above. The only difference is that there is no failure message that is covered by the HMACs. With
-attribution data, the sender can obtain hold times as reported and committed to by each hop along the payment path.
+The `update_fulfill_htlc` message contains an optional `attribution_data` field, identical to the one used in the
+failure case described above. With attribution data, the sender can obtain hold times as reported and committed to by
+each hop along the payment path.
+
+In addition, the final node can return data to the origin node in an optional `fulfillment_payload` field. It is the
+success counterpart of the failure message that an erring node returns in the `reason` field of `update_fail_htlc`. The
+final node builds the plaintext as a `fulfillment_payload_tlvs` [TLV stream](01-messaging.md#type-length-value-format):
+
+1. `tlv_stream`: `fulfillment_payload_tlvs`
+2. types:
+ 1. type: 1 (`padding`)
+ 2. data:
+ * [`...*byte`:`padding`]
+
+`padding` conceals the length of the conveyed data and is ignored by the origin. Apart from `padding`, no record types
+are defined yet.
+
+The final node generates a key using key type `fulfillment` and its shared secret with the origin node, then encrypts
+this plaintext with ChaCha20-Poly1305 using that key and an all-zero nonce, as for `encrypted_recipient_data` in route
+blinding. The ciphertext and its 16-byte tag are the `fulfillment_payload`. Each intermediate node then obfuscates the
+`fulfillment_payload` with its `ammag` key, exactly as it obfuscates a failure return packet; the final node does not,
+as the ciphertext is already confidential and forms the innermost layer. The
+`attribution_data` HMACs added by intermediate nodes, which already cover the hold times, now additionally cover the
+`fulfillment_payload`. For each intermediate HMAC, the covered fields are, in order: the `fulfillment_payload` as
+received from the downstream node, before the current node applies its own `ammag` obfuscation; the hold times; and the
+downstream HMACs. The final node's `attribution_data` HMACs do not cover the `fulfillment_payload`. With no payload
+present, there is nothing extra for intermediate nodes to cover. The final node still initializes and updates
+`attribution_data`, and the origin still verifies the final node's `attribution_data` HMACs for its reported hold time.
+
+A successful payment is relayed back with `update_fulfill_htlc`, so a `fulfillment_payload` propagates back through
+every hop, even a blinded path: a blinded final node can originate it, and blinded hops obfuscate and relay it. The
+origin can still recover it, because it shares a secret with every hop, blinded ones included, computed from each hop's
+public key (the blinded public key for a blinded hop) when it built the onion. Returning a `fulfillment_payload` is
+therefore not gated by the `path_key` condition that applies to `attribution_data`.
+
+The origin knows the number of hops in the path, so the final node is its last hop: the origin peels each intermediate
+hop's `ammag` obfuscation, including obfuscation for blinded hops whose blinded public keys it used when constructing
+the route, and decrypts the `fulfillment_payload` with the last hop's `fulfillment` key, one operation per hop. The
+origin verifies the final node's `attribution_data` HMACs without a `fulfillment_payload` input. For each intermediate
+hop, the origin removes that hop's `ammag` obfuscation from the `fulfillment_payload` and verifies the hop's
+`attribution_data` HMACs over the resulting `fulfillment_payload` bytes. A recipient that conceals its position with
+dummy hops in a blinded path must therefore originate the `fulfillment_payload` as though it were the last hop, applying
+the obfuscation for the concealed hops itself, so that this decoding succeeds without revealing its position.
+
+The two integrity checks cover different extents. The Poly1305 tag is verified end-to-end and detects tampering by any
+hop, blinded or not. The `attribution_data` HMACs are contributed only by hops with `path_key` not set, so they
+provide per-hop attribution where available, as in the failure case. This split is intentional: `attribution_data` is
+per-hop data for scoring path nodes, which the origin cannot do for blinded hops it cannot identify and whose hold times
+would aid de-anonymization, whereas a `fulfillment_payload` is end-to-end data that reveals nothing about the
+intermediate hops.
+
+Like return packets, `fulfillment_payload` is limited to 32768 bytes (32 KiB) to leave room for `attribution_data` and
+future extensions. Because `fulfillment_payload` was introduced with this limit, receiving a larger payload is a
+protocol violation as specified in [BOLT #2](02-peer-protocol.md#removing-an-htlc-update_fulfill_htlc-update_fail_htlc-and-update_fail_malformed_htlc).
+
+## Requirements
+
+`attribution_data` is initialized, transformed, updated and verified exactly as in the failure case.
+
+The _final node_:
+ - if `option_attribution_data` is advertised:
+ - MAY include a `fulfillment_payload`, even when reached through a blinded path
+ - if it includes a `fulfillment_payload`:
+ - MUST ensure the `fulfillment_payload` is no more than 32768 bytes (32 KiB)
+ - MUST set `fulfillment_payload_tlvs` to a serialized TLV stream
+ - MUST pad with `padding` such that the serialized `fulfillment_payload_tlvs` stream is at least 256 bytes and a
+ multiple of 256 bytes, excluding the 16-byte Poly1305 tag. The size calculation includes the type and length
+ bytes of the `padding` record; this can require padding to the next multiple of 256 bytes
+ - SHOULD pad such that the serialized `fulfillment_payload_tlvs` stream is exactly 256 bytes if possible
+ - MUST encrypt the plaintext with ChaCha20-Poly1305 as above
+ - MUST NOT include the `fulfillment_payload` in its `attribution_data` HMACs
+ - MUST still initialize and update `attribution_data` for its reported hold time
+
+An _intermediate node_:
+ - if it receives a `fulfillment_payload` from the downstream node:
+ - MUST obfuscate it with its `ammag` key and include it in the outgoing `update_fulfill_htlc`, as it transforms a
+ return packet
+ - MUST include the `fulfillment_payload` as received from the downstream node in its `attribution_data` HMACs
+
+The _origin node_:
+ - MUST recover a `fulfillment_payload` by peeling each intermediate hop's `ammag` obfuscation and decrypting it with
+ the last hop's `fulfillment` key
+ - MUST verify the final node's `attribution_data` HMACs as in the failure case, except that the HMAC input excludes
+ the `fulfillment_payload`, and process its reported hold time
+ - MUST remove an intermediate hop's `ammag` obfuscation from the `fulfillment_payload` before verifying that hop's
+ `attribution_data` HMACs over the resulting `fulfillment_payload` bytes
+ - MUST ignore a `fulfillment_payload` whose Poly1305 tag is invalid, or whose decrypted `fulfillment_payload_tlvs`
+ stream has malformed lengths, duplicate or unordered types, or unknown even types
+ - MUST ignore `padding` records in a valid `fulfillment_payload_tlvs` stream
# Onion Messages
@@ -1638,8 +1746,7 @@ The `onionmsg_tlv` itself is a TLV: an intermediate node expects an
using the `path_key` which it is handed along with the onion message.
Field numbers 64 and above are reserved for payloads for the final
-hop, though these are not explicitly refused by non-final hops (unless
-even, of course!).
+hop.
1. `tlv_stream`: `onionmsg_tlv`
2. types:
@@ -1690,7 +1797,10 @@ The writer:
The reader:
-- SHOULD accept onion messages from peers without an established channel.
+- if it advertises `option_onion_messages_only_channels`:
+ - MUST NOT accept onion messages from peers without an established channel.
+- otherwise:
+ - SHOULD accept onion messages from peers without an established channel.
- MAY rate-limit messages by dropping them.
- MUST decrypt `onion_message_packet` using an empty `associated_data`, and `path_key`, as described in [Onion Decryption](04-onion-routing.md#onion-decryption) to extract an `onionmsg_tlv`.
- If decryption fails, the result is not a valid `onionmsg_tlv`, or it contains unknown even types:
@@ -1732,6 +1842,19 @@ The reader:
#### Rationale
+Accepting onion messages from channelless peers is the baseline: a node that
+advertises `option_onion_messages` is expected to accept onion messages from
+any connected peer. This is a SHOULD rather than a MUST because acceptance
+is always best effort: a node may still drop messages due to rate-limiting.
+
+A node that wants to restrict acceptance to channel peers (e.g. to limit the
+DoS surface of free bandwidth/CPU for any node that can connect) advertises
+`option_onion_messages_only_channels` as an explicit opt-out. A restrictive
+node should not silently drop these messages while advertising only the
+baseline: it has to advertise the bit, which makes the bit a reliable signal.
+A sender can therefore detect it and simply not attempt a relay it knows will
+fail, rather than sending a message that is silently dropped.
+
Care must be taken that replies are only accepted using the exact
reply_path given, otherwise probing is possible. That means checking
both ways: non-replies don't use the reply path, and replies always
@@ -1842,7 +1965,8 @@ The following is an in-depth trace of an example of error message creation:
## Returning success
-A successful payment using the parameters above would result in the following attribution data values:
+A successful payment without a `fulfillment_payload` using the parameters above would result in the following
+attribution data values:
attribution data for node 4:
d77d0711b5f71d1d1be56bd88b3bb7ebc1792bb739ea7ebc1bc3b031b8bc2df3a50e25aeb99f47d7f7ab39e24187d3f4df9c4333463b053832ee9ac07274a5261b8b2a01fc09ce9ea7cd04d7b585dfb83299fb6570d71f793c1fcac0ef498766952c8c6840efa02a567d558a3cf6822b12476324b9b9efa03e5f8f26f81fa93daac46cbf00c98e69b6747cf69caaa2a71b025bd18830c4c54cd08f598cfde6197b3f2a951aba907c964c0f5d19a44e6d1d7279637321fa598adde927b3087d238f8b426ecde500d318617cdb7a56e6ce3520fc95be41a549973764e4dc483853ecc313947709f1b5199cb077d46e701fa633e11d3e13b03e9212c115ca6fa004b2f3dd912814693b705a561a06da54cdf603677a3abecdc22c7358c2de3cef771b366a568150aeecc86ad1990bb0f4e2865933b03ea0df87901bff467908273dc6cea31cbab0e2b8d398d10b001058c259ed221b7b55762f4c7e49c8c11a45a107b7a2c605c26dc5b0b10d719b1c844670102b2b6a36c43fe4753a78a483fc39166ae28420f112d50c10ee64ca69569a2f690712905236b7c2cb7ac8954f02922d2d918c56d42649261593c47b14b324a65038c3c5be8d3c403ce0c8f19299b1664bf077d7cf1636c4fb9685a8e58b7029fd0939fa07925a60bed339b23f973293598f595e75c8f9d455d7cebe4b5e23357c8bd47d66d6628b39427e37e0aecbabf46c11be6771f7136e108a143ae9bafba0fc47a51b6c7deef4cba54bae906398ee3162a41f2191ca386b628bde7e1dd63d1611aa01a95c456df337c763cb8c3a81a6013aa633739d8cd554c688102211725e6adad165adc1bcd429d020c51b4b25d2117e8bb27eb0cc7020f9070d4ad19ac31a76ebdf5f9246646aeadbfb9a3f1d75bd8237961e786302516a1a781780e8b73f58dc06f307e58bd0eb1d8f5c9111f01312974c1dc777a6a2d3834d8a2a40014e9818d0685cb3919f6b3b788ddc640b0ff9b1854d7098c7dd6f35196e902b26709640bc87935a3914869a807e8339281e9cedaaca99474c3e7bdd35050bb998ab4546f9900904e0e39135e861ff7862049269701081ebce32e4cca992c6967ff0fd239e38233eaf614af31e186635e9439ec5884d798f9174da6ff569d68ed5c092b78bd3f880f5e88a7a8ab36789e1b57b035fb6c32a6358f51f83e4e5f46220bcad072943df8bd9541a61b7dae8f30fa3dd5fb39b1fd9a0b8e802552b78d4ec306ecee15bfe6da14b29ba6d19ce5be4dd478bca74a52429cd5309d404655c3dec85c252
@@ -1859,6 +1983,45 @@ attribution data for node 1:
attribution data for node 0:
84986c936d26bfd3bb2d34d3ec62cfdb63e0032fdb3d9d75f3e5d456f73dffa7e35aab1db4f1bd3b98ff585caf004f656c51037a3f4e810d275f3f6aea0c8e3a125ebee5f374b6440bcb9bb2955ebf70c06d64090f9f6cf098200305f7f4305ba9e1350a0c3f7dab4ccf35b8399b9650d8e363bf83d3a0a09706433f0adae6562eb338b21ea6f21329b3775905e59187c325c9cbf589f5da5e915d9e5ad1d21aa1431f9bdc587185ed8b5d4928e697e67cc96bee6d5354e3764cede3f385588fa665310356b2b1e68f8bd30c75d395405614a40a587031ebd6ace60dfb7c6dd188b572bd8e3e9a47b06c2187b528c5ed35c32da5130a21cd881138a5fcac806858ce6c596d810a7492eb261bcc91cead1dae75075b950c2e81cecf7e5fdb2b51df005d285803201ce914dfbf3218383829a0caa8f15486dd801133f1ed7edec436730b0ec98f48732547927229ac80269fcdc5e4f4db264274e940178732b429f9f0e582c559f994a7cdfb76c93ffc39de91ff936316726cc561a6520d47b2cd487299a96322dadc463ef06127fc63902ff9cc4f265e2fbd9de3fa5e48b7b51aa0850580ef9f3b5ebb60c6c3216c5a75a93e82936113d9cad57ae4a94dd6481954a9bd1b5cff4ab29ca221fa2bf9b28a362c9661206f896fc7cec563fb80aa5eaccb26c09fa4ef7a981e63028a9c4dac12f82ccb5bea090d56bbb1a4c431e315d9a169299224a8dbd099fb67ea61dfc604edf8a18ee742550b636836bb552dabb28820221bf8546331f32b0c143c1c89310c4fa2e1e0e895ce1a1eb0f43278fdb528131a3e32bfffe0c6de9006418f5309cba773ca38b6ad8507cc59445ccc0257506ebc16a4c01d4cd97e03fcf7a2049fea0db28447858f73b8e9fe98b391b136c9dc510288630a1f0af93b26a8891b857bfe4b818af99a1e011e6dbaa53982d29cf74ae7dffef45545279f19931708ed3eede5e82280eab908e8eb80abff3f1f023ab66869297b40da8496861dc455ac3abe1efa8a6f9e2c4eda48025d43a486a3f26f269743eaa30d6f0e1f48db6287751358a41f5b07aee0f098862e3493731fe2697acce734f004907c6f11eef189424fee52cd30ad708707eaf2e441f52bcf3d0c5440c1742458653c0c8a27b5ade784d9e09c8b47f1671901a29360e7e5e94946b9c75752a1a8d599d2a3e14ac81b84d42115cd688c8383a64fc6e7e1dc5568bb4837358ebe63207a4067af66b2027ad2ce8fb7ae3a452d40723a51fdf9f9c9913e8029a222cf81d12ad41e58860d75deb6de30ad
+A successful payment with a `fulfillment_payload` using the same route parameters contains the following
+`fulfillment_payload_tlvs` records:
+
+ type = 1 (`padding`)
+ value = 245 zero bytes
+
+ type = 65537
+ value = 070809
+
+These two records serialize to 256 bytes: 247 bytes for the `padding` record and 9 bytes for the type `65537` record.
+With the 16-byte Poly1305 tag, this results in a 272-byte `fulfillment_payload`.
+
+The following are the `fulfillment_payload` and attribution data values at each hop:
+
+fulfillment payload for node 4:
+b5b1fed711469adc0da510494818ce54624b537e7a8aba4b190403d90439798a694bdca0d0d53c18487d9940664a8416eb855290621e186081b2222e279bfa6dcb1645a39c2cbc569ed66f8f9ed0c10d4dcbc61abe6685d558d5fb0ec104bf1d14ab1e42a4cf41f1950c3fd06574a8278f553382a78b2725f36559d6db7aeccd41569f88b3722c3535358915648bd2e82c53cbaaa14c34487a77799cc4650d5c2e2edece013cf4095ee99bc96e1a850fa3373538448bd6d5a1771f50ca39b2a4e85c7201be5bedd5fae801e5e99491e6fb1e76457c48094f347205d1170df06e2fa7128d0dfe7d24716fb621632b948f9ad9edba24fba9293906e193a7ca3c234cce42ca9470c08952be1dbd3dcc8452
+attribution data for node 4:
+d77d0711b5f71d1d1be56bd88b3bb7ebc1792bb739ea7ebc1bc3b031b8bc2df3a50e25aeb99f47d7f7ab39e24187d3f4df9c4333463b053832ee9ac07274a5261b8b2a01fc09ce9ea7cd04d7b585dfb83299fb6570d71f793c1fcac0ef498766952c8c6840efa02a567d558a3cf6822b12476324b9b9efa03e5f8f26f81fa93daac46cbf00c98e69b6747cf69caaa2a71b025bd18830c4c54cd08f598cfde6197b3f2a951aba907c964c0f5d19a44e6d1d7279637321fa598adde927b3087d238f8b426ecde500d318617cdb7a56e6ce3520fc95be41a549973764e4dc483853ecc313947709f1b5199cb077d46e701fa633e11d3e13b03e9212c115ca6fa004b2f3dd912814693b705a561a06da54cdf603677a3abecdc22c7358c2de3cef771b366a568150aeecc86ad1990bb0f4e2865933b03ea0df87901bff467908273dc6cea31cbab0e2b8d398d10b001058c259ed221b7b55762f4c7e49c8c11a45a107b7a2c605c26dc5b0b10d719b1c844670102b2b6a36c43fe4753a78a483fc39166ae28420f112d50c10ee64ca69569a2f690712905236b7c2cb7ac8954f02922d2d918c56d42649261593c47b14b324a65038c3c5be8d3c403ce0c8f19299b1664bf077d7cf1636c4fb9685a8e58b7029fd0939fa07925a60bed339b23f973293598f595e75c8f9d455d7cebe4b5e23357c8bd47d66d6628b39427e37e0aecbabf46c11be6771f7136e108a143ae9bafba0fc47a51b6c7deef4cba54bae906398ee3162a41f2191ca386b628bde7e1dd63d1611aa01a95c456df337c763cb8c3a81a6013aa633739d8cd554c688102211725e6adad165adc1bcd429d020c51b4b25d2117e8bb27eb0cc7020f9070d4ad19ac31a76ebdf5f9246646aeadbfb9a3f1d75bd8237961e786302516a1a781780e8b73f58dc06f307e58bd0eb1d8f5c9111f01312974c1dc777a6a2d3834d8a2a40014e9818d0685cb3919f6b3b788ddc640b0ff9b1854d7098c7dd6f35196e902b26709640bc87935a3914869a807e8339281e9cedaaca99474c3e7bdd35050bb998ab4546f9900904e0e39135e861ff7862049269701081ebce32e4cca992c6967ff0fd239e38233eaf614af31e186635e9439ec5884d798f9174da6ff569d68ed5c092b78bd3f880f5e88a7a8ab36789e1b57b035fb6c32a6358f51f83e4e5f46220bcad072943df8bd9541a61b7dae8f30fa3dd5fb39b1fd9a0b8e802552b78d4ec306ecee15bfe6da14b29ba6d19ce5be4dd478bca74a52429cd5309d404655c3dec85c252
+
+fulfillment payload for node 3:
+d4cd5f33730d592c4249f3e31233af0572bf729218ca375ddd8aa518b3fa466d6101f77904b013dd4ef3c912d9278edc09923288c1c6df3fb636053cb6a2fa4bf7e9d7500310a4fc819d4f26a0a03d4fd73c74ab281a2dcf2ec8bb56ecabb1a9884478a172348bf38ddf3dfd579d3c9393dd79a5650da2caedd41fd531fa4ec9f3a46bfc05df7244f30d115687eacc568395e83a165bfe1bc91073af0172e27488771c9fd7744b45c883d538e90bbbc627bcc428c5ebb71fee5877b7a6d23a198a544565dee2fb2ed736b69f8c7c696dd56fd48e88a24017306f74106a0898622abb24fbf6f3b534ff32ceda7d07d05800f9c32730fcb47a5a774cd464503936d2432e8b450ade0cdd14b2ea1bef2e71
+attribution data for node 3:
+1571e10db7f8aa9f8e7e99caaf9c892e106c817df1d8e3b7b0e39d1c48f631e473e17e205489dd7b3c634cac3be0825cbf01418cd46e83c24b8d9c207742db9a0f0e5bcd888086498159f08080ba7bf3bc5cfe92707ca5d3bc81720c889a034b89cf2d376a67c5d63651e3af267efb768a38f488eac2940cf5525e959599984c3cf56c1daaa92476de574582eba16f90b9a6a74f4aa5f1cdad2115c994a09565f9755940ec0665f9e5bc58cad6e523091f94d0bcd3c6c65ca1a5d401128dcc5e14f9108b32e660017c13de598bcf9d403710857cccb0fb9c2a81bfd66bc4552e1132afa3119203a4aaa1e8839c1dab8cbdcde7b527aca3f54bde651aa9f3f2178829cee3f1c0b9292758a40cc63bd998fcd0d3ed4bdcaf1023267b8f8e44130a63ad15f76145936552381eabb6d684c0a3af6ba8efcf207cebaea5b7acdbb63f8e7221102409d10c23f0514dc9f4d0efb2264161a193a999a23e992632710580a0d320f676d367b9190721194514457761af05207cdab2b6328b1b3767eacb36a7ef4f7bd2e16762d13df188e0898b7410f62459458712a44bf594ae662fd89eb300abb6952ff8ad40164f2bcd7f86db5c7650b654b79046de55d51aa8061ce35f867a3e8f5bf98ad920be827101c64fb871d86e53a4b3c0455bfac5784168218aa72cbee86d9c750a9fa63c363a8b43d7bf4b2762516706a306f0aa3be1ec788b5e13f8b24837e53ac414f211e11c7a093cd9653dfa5fba4e377c79adfa5e841e2ddb6afc054fc715c05ddc6c8fc3e1ee3406e1ffceb2df77dc2f02652614d1bfcfaddebaa53ba919c7051034e2c7b7cfaabdf89f26e7f8e3f956d205dfab747ad0cb505b85b54a68439621b25832cbc2898919d0cd7c0a64cfd235388982dd4dd68240cb668f57e1d2619a656ed326f8c92357ee0d9acead3c20008bc5f04ca8059b55d77861c6d04dfc57cfba57315075acbe1451c96cf28e1e328e142890248d18f53b5d3513ce574dea7156cf596fdb3d909095ec287651f9cf1bcdc791c5938a5dd9b47e84c004d24ab3ae74492c7e8dcc1da15f65324be2672947ec82074cac8ce2b925bc555facbbf1b55d63ea6fbea6a785c97d4caf2e1dad9551b7f66c31caae5ebc7c0047e892f201308fcf452c588be0e63d89152113d87bf0dbd01603b4cdc7f0b724b0714a9851887a01f709408882e18230fe810b9fafa58a666654576d8eba3005f07221f55a6193815a672e5db56204053bc4286fa3db38250396309fd28011b5708a26a2d76c4a333b69b6bfd272fb
+
+fulfillment payload for node 2:
+b584abb82973d6112d1474e8685a21253e4936c0b27e7f122c5443694d99bb263e1a8f9724f7cc7b50ce9e79cdbc63738a97bd0d31acee4d15143fea72d1d7dd44c0828a7e3f4fbdc178c2a05caf13fa0eedf325479052aa855aa955e22520fcfbafc5de47d52fc304d4da1b2ba2882861038fc79f6ff6eb0a600e17af44cf25941318a95cb47788e65a4430c9b30d38a2d4e291f3657e5b83712cebeac1f942d4d066f146505d227aefb995cdf098e2e8d82c9118859bf9b1477e3b5bccce02288082bb2e1ded74d94a3278d500298e0a91435a9f6304436a614cfe59e33283067be5bda617e6e094ce861a2c48e51f73ba9dcfab879c6a3a19fbe60697432bb5b04dbc401d53757c133ed01a5ad4ad
+attribution data for node 2:
+34e34397b8621ec2f2b54dbe6c14073e267324cd60b152bce76aec8729a6ddefb61bc263be4b57bd592aae604a32bea69afe6ef4a6b573c26b17d69381ec1fc9b5aa769d148f2f1f8b5377a73840bb6d40734019bf9dcbb731aeac3b1052e6703e8ffa550f2f3b6b40df0faa5bd67271a99a81e81265b567522733358a1c8a3b770d207ba8a22ba238abf056af11042474f4fd44bbb21e3ea8d978058a8cc67a11ad429f816de27a43dd69a3f1fe8ccf670fa081fd9d89af6079f7baf05c7f4bf318b2dcfe18f5bd8628795265f61cbf40b6efa757fc9242927c329f5e06ddbce3be8c1f5dd48a0370eb559f5dc181a09f2209da72f79ae6745992c803310d39f960e8ecf327aed706e4b3e2704eeb9b304dc0e0685f5dcd0389ec377bdba37610ad556a0e957a413a56339dd3c40817214bced5802beee2ee545bdd713208751added5fc0eb2bc89a5aa2decb18ee37dac39f22a33b60cc1a369d24de9f3d2d8b63c039e248806de4e36a47c7a0aed30edd30c3d62debdf1ad82bf7aedd7edec413850d91c261e12beec7ad1586a9ad25b2db62c58ca17119d61dcc4f3e5c4520c42a8e384a45d8659b338b3a08f9e123a1d3781f5fc97564ccff2c1d97f06fa0150cfa1e20eacabefb0c339ec109336d207cc63d9170752fc58314c43e6d4a528fd0975afa85f3aa186ff1b6b8cb12c97ed4ace295b0ef5f075f0217665b8bb180246b87982d10f43c9866b22878106f5214e99188781180478b07764a5e12876ddcb709e0a0a8dd42cf004c695c6fc1669a6fd0e4a1ca54b024d0d80eac492a9e5036501f36fb25b72a054189294955830e43c18e55668337c8c6733abb09fc2d4ade18d5a853a2b82f7b4d77151a64985004f1d9218f2945b63c56fdebd1e96a2a7e49fa70acb4c39873947b83c191c10e9a8f40f60f3ad5a2be47145c22ea59ed3f5f4e61cb069e875fb67142d281d784bf925cc286eacc2c43e94d08da4924b83e58dbf2e43fa625bdd620eba6d9ce960ff17d14ed1f2dbee7d08eceb540fdc75ff06dabc767267658fad8ce99e2a3236e46d2deedcb51c3c6f81589357edebac9772a70b3d910d83cd1b9ce6534a011e9fa557b891a23b5d88afcc0d9856c6dabeab25eea55e9a248182229e4927f268fe5431672fcce52f434ca3d27d1a2136bae5770bb36920df12fbc01d0e8165610efa04794f414c1417f1d4059435c5385bfe2de83ce0e238d6fd2dbd3c0487c69843298577bfa480fe2a16ab2a0e4bc712cd8b5a14871cda61c993b6835303d9043d7689a
+
+fulfillment payload for node 1:
+ba9463d72ce55bc83c9ccd70861ffdf8c5b1a9291be4d9257016ae3c6d3becc6765fe07333369e629ef7475898e535dda560281a4dcf2654362b0421e95aff38e8aeb1298787331bec87815490e534af8de7c85bdf537418fdb81464168cb7c2123ee4186fa6da7cb60583c8ff2ed07982b0ce3e690cb9ba99f186d416bb8adb7f020ea2ef2894bbc732fcd78d1a2c3f7983b85f8b039ae370e1dd062e6d2e6439c003a4d65a55102db383ef1ceb291cd057dfba81396959613104b894e5f4202218b86b3ac9e9cb7b4a10a06669d788fd7d8a9dd832d8996592d17593978d1a500fbe1943c57f004e41eeb3da28e114997aa3b6f183fa2af59b8ad67c1c2753beb5c5fe6f4733980225e8d40d0cfd95
+attribution data for node 1:
+74a4ea61339463642a2182758871b2ea724f31f531aa98d80f1c3043febca41d5ee52e8b1e127e61719a0d078db8909748d57839e58424b91f063c4fbc8a221bef261140e66a9b596ca6d420a973ad54651be4bf8728ba81adcb9a1d3ce3820cea24f2c6bfdde427edb7706dfd1e8e50c0ab544022275fd457fbd57555cfc85bbfbed6eb0f7a8ea04ebc1b40fc8d3f67402a01d169ed1448ed2e708e16a0fe2c1ab5055be446594036b5ecae456486addbebbd09ca3423d4c15e2afce6b40b545bfbf5859b6bf913e80bcec00e88cba671fee9770fdace16301fbb23b0eca85549ae0be1a96bda5167b6e5fb837edecd981b61e06858badb34ead1e93746ab5afd2bc10e95bffc4dc965de242db63eb8ec221cf57e2c77241fcfca70818a85a447b6fbcaaf4b2fc2135565cbfc03804aa11ad0ab0582e5d86590df2ecfd561dc6e1cdb08d3e10901312326a45fb0498a177319389809c6ba07a76cfad621e07b9af097730e94df92fbd311b2cb5da32c80ab5f14971b6d40f8e2ab202ac98bd8439790764a40bf309ea2205c1632610956495720030a25dc7118e0c868fdfa78c3e9ecce58215579a0581b3bafdb7dbbe53be9e904567fdc0ce1236aab5d22f1ebc18997e3ea83d362d891e04c5785fd5238326f767bce499209f8db211a50e1402160486e98e7235cf397dbb9ae19fd9b79ef589c821c6f99f28be33452405a003b33f4540fe0a41dfcc286f4d7cc10b70552ba7850869abadcd4bb7f256823face853633d6e2a999ac9fcd259c71d08e266db5d744e1909a62c0db673745ad9585949d108ab96640d2bc27fb4acac7fa8b170a30055a5ede90e004df9a44bdc29aeb4a6bec1e85dde1de6aaf01c6a5d12405d0bec22f49026cb23264f8c04b8401d3c2ab6f2e109948b6193b3bec27adfe19fb8afb8a92364d6fc5b219e8737d583e7ff3a4bcb75d53edda3bf3f52896ac36d8a877ad9f296ea6c045603fc62ac4ae41272bde85ef7c3b3fd3538aacfd5b025fefbe277c2906821ecb20e6f75ea479fa3280f9100fb0089203455c56b6bc775e5c2f0f58c63edd63fa3eec0b40da4b276d0d41da2ec0ead865a98d12bc694e23d8eaadd2b4d0ee88e9570c88fb878930f492e036d27998d593e47763927ff7eb80b188864a3846dd2238f7f95f4090ed399ae95deaeb37abca1cf37c397cc12189affb42dca46b4ff6988eb8c060691d155302d448f50ff70a794d97c0408f8cee9385d6a71fa412e36edcb22dbf433db9db4779f27b682ee17fc05e70c8e794b9f7f6d1
+
+fulfillment payload for node 0:
+8c0d9ee20671d1cdca98bb4c8dd5d490105b63021afcb90b22f33f1d9d6b7faafb86ec57ec4b56ad11e122bb0289403447a0b814ef8aefb90d2b0c3567501eb3570011ee96514db6050747a1d5cba50fe6e0c3e639d8208c549d61a502eab8772eceafeee940a586fc0ad92ce57773e307a5055604b9ea68c780617d6a797467d357d185fe9eb4279719d35faaab1105ab77299bd10f3504c439058720ed738a1c16756a44ba348bb193ec7d3dd9f11ac3d0cc1277ace098ed0ed8e25a01e83216a9c6a183a2659ddf2d971bc4a9b5ce776e1b07242a89a15026a3d208bbb8e3f91086f2785be68b5e4122f9d79583b883266ba6dfb4cf0c22737915dda898e1461651818c17f811f51f496f0842223c
+attribution data for node 0:
+84986c936d26bfd3bb2d34d3ec62cfdb63e0032fdb3d9d75f3e5d456f73dffa7e35aab1db4f1bd3b98ff585caf004f656c51037a3f4e810d275f3f6aea0c8e3a125ebee5f374b6440bcb9bb2955ebf706a8fd90a3bef40add4106d8c215290aafbc30881b17d68b6a7aac1b6ab52261df2fceef75d3a490862d4bab3aa510cfb8ca695b38c640b58bb8685db8bb57f93db49657ddda39d21d6074d9ecaa1ea0da6cc904e136dbb4c1ba9839a7fb8367c88662f7f573c82c2746d122cca96b2e7872a48e32c8adba45babdc57a9bca55720b1d2c922622fcf8f8a5ed7daae286484b701e69bd40554a4cc3418444ff7eb9982ecee020c8a92717f089ce1ab0ca00bb3a582253cd832a2f869703a2fadafd8261ebb93fde2a9f4f13dc8470436c3cd110bdcc7f5a1e9f9c743c8e55b50c45dac07e07a8e5c7416de895940fde032786594bbaa8a1147422bd5e926fea510408c249fb61164bf7bdbac53d9fb9704023314c332a865146893ad99743708c4a34a30a82fd8b756c561a6520d47b2cd487299a96322dadc463ef06127fc63902ff9cc4f265e2fbd9de3fa5e48b7b51aa0850580ef9f3b5ebb60c6c3216c5a75a93e82936113d9cad57ae4a94dd6481954a9bd1b5cff4ab29ca221fa2bf9b28a362c9661206f896fc7cec563fb80aa5eaccb26c09fa4ef7a981e63028a9c4dac12f82ccb5bea090d56bbb1a4c431e315d9a169299224a8dbd099fb67ea61dfc604edf8a18ee742550b636836bb552dabb28820221bf8546331f32b0c143c1c89310c4fa2e1e0e895ce1a1eb0f43278fdb528131a3e32bfffe0c6de9006418f5309cba773ca38b6ad8507cc59445ccc0257506ebc16a4c01d4cd97e03fcf7a2049fea0db28447858f73b8e9fe98b391b136c9dc510288630a1f0af93b26a8891b857bfe4b818af99a1e011e6dbaa53982d29cf74ae7dffef45545279f19931708ed3eede5e82280eab908e8eb80abff3f1f023ab66869297b40da8496861dc455ac3abe1efa8a6f9e2c4eda48025d43a486a3f26f269743eaa30d6f0e1f48db6287751358a41f5b07aee0f098862e3493731fe2697acce734f004907c6f11eef189424fee52cd30ad708707eaf2e441f52bcf3d0c5440c1742458653c0c8a27b5ade784d9e09c8b47f1671901a29360e7e5e94946b9c75752a1a8d599d2a3e14ac81b84d42115cd688c8383a64fc6e7e1dc5568bb4837358ebe63207a4067af66b2027ad2ce8fb7ae3a452d40723a51fdf9f9c9913e8029a222cf81d12ad41e58860d75deb6de30ad
+
# References
[sphinx]: http://www.cypherpunks.ca/~iang/pubs/Sphinx_Oakland09.pdf
diff --git a/flake.lock b/flake.lock
@@ -56,11 +56,11 @@
"ppad-poly1305": "ppad-poly1305"
},
"locked": {
- "lastModified": 1784320353,
- "narHash": "sha256-o4Ho+7HqzYmaoz1JUkBZHQ1Y+VF5N2icV6+O7qnUFJw=",
+ "lastModified": 1788706042,
+ "narHash": "sha256-+N5XTJmW3JMCfrSvGYg+G02VVW8DWFdbk9gTc9991x4=",
"ref": "master",
- "rev": "222189519730df4fc075ff9e23d2422e91a10ff4",
- "revCount": 38,
+ "rev": "00b03f80d8d71f802061a8af9d041c6891b87660",
+ "revCount": 44,
"type": "git",
"url": "git://git.ppad.tech/aead.git"
},
@@ -318,16 +318,19 @@
"nixpkgs"
],
"ppad-base16": "ppad-base16_3",
+ "ppad-bolt9": [
+ "ppad-bolt9"
+ ],
"ppad-nixpkgs": [
"ppad-nixpkgs"
]
},
"locked": {
- "lastModified": 1783709539,
- "narHash": "sha256-bXqV4/qYZFbZeG8PHlnr+PVyTZ3E0ZIi+mgCu49iamw=",
+ "lastModified": 1791625140,
+ "narHash": "sha256-DgMZKJlpLQcrNLSuzOM+bF2QQKsaVKigzSjkyOEockQ=",
"ref": "master",
- "rev": "507af14c14be9fbaa27992357aa25e40c443daee",
- "revCount": 33,
+ "rev": "b4b4b507bf0be00435a15c448ef2366ed0c22581",
+ "revCount": 43,
"type": "git",
"url": "git://git.ppad.tech/bolt1.git"
},
@@ -337,6 +340,37 @@
"url": "git://git.ppad.tech/bolt1.git"
}
},
+ "ppad-bolt9": {
+ "inputs": {
+ "flake-utils": [
+ "ppad-bolt9",
+ "ppad-nixpkgs",
+ "flake-utils"
+ ],
+ "nixpkgs": [
+ "ppad-bolt9",
+ "ppad-nixpkgs",
+ "nixpkgs"
+ ],
+ "ppad-nixpkgs": [
+ "ppad-nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1791624953,
+ "narHash": "sha256-DWafVJvu2LTXkAI/zH0Q0BqTrjLo0c7hyTvaW/9N0VM=",
+ "ref": "master",
+ "rev": "280946ab905a374c8c6d4a37678a4cc362551ab9",
+ "revCount": 39,
+ "type": "git",
+ "url": "git://git.ppad.tech/bolt9.git"
+ },
+ "original": {
+ "ref": "master",
+ "type": "git",
+ "url": "git://git.ppad.tech/bolt9.git"
+ }
+ },
"ppad-chacha": {
"inputs": {
"flake-utils": [
@@ -355,11 +389,11 @@
]
},
"locked": {
- "lastModified": 1783709359,
- "narHash": "sha256-Xl31mWwQfJcfztw5v1NeaUlYn2vAaSVcambpCeemT7I=",
+ "lastModified": 1788702071,
+ "narHash": "sha256-B0a9eLZBsHTrsr/SNyPhpiq1NzjvTFsb1Kdr1mRmxXM=",
"ref": "master",
- "rev": "2beeb81459bc33ad074321e9ced4ba3880edf747",
- "revCount": 36,
+ "rev": "46cb61870a875f2c4e1633bc4d2cba1ddffa461d",
+ "revCount": 41,
"type": "git",
"url": "git://git.ppad.tech/chacha.git"
},
@@ -695,6 +729,7 @@
"ppad-aead": "ppad-aead",
"ppad-base16": "ppad-base16_2",
"ppad-bolt1": "ppad-bolt1",
+ "ppad-bolt9": "ppad-bolt9",
"ppad-chacha": "ppad-chacha",
"ppad-fixed": "ppad-fixed_2",
"ppad-hmac-drbg": "ppad-hmac-drbg",
diff --git a/flake.nix b/flake.nix
@@ -14,6 +14,13 @@
url = "git://git.ppad.tech/bolt1.git";
ref = "master";
inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
+ inputs.ppad-bolt9.follows = "ppad-bolt9";
+ };
+ ppad-bolt9 = {
+ type = "git";
+ url = "git://git.ppad.tech/bolt9.git";
+ ref = "master";
+ inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
};
ppad-base16 = {
type = "git";
@@ -65,7 +72,7 @@
};
outputs = { self, nixpkgs, flake-utils, ppad-nixpkgs
- , ppad-aead, ppad-bolt1, ppad-base16, ppad-chacha
+ , ppad-aead, ppad-bolt1, ppad-bolt9, ppad-base16, ppad-chacha
, ppad-fixed, ppad-hmac-drbg, ppad-secp256k1
, ppad-sha256 }:
flake-utils.lib.eachDefaultSystem (system:
@@ -120,13 +127,11 @@
[ llvm clang ];
bolt1 = ppad-bolt1.packages.${system}.default;
- bolt1-llvm =
- hlib.addBuildTools
- (hlib.enableCabalFlag bolt1 "llvm")
- [ llvm clang ];
+ bolt9 = ppad-bolt9.packages.${system}.default;
hpkgs = pkgs.haskell.packages.ghc910.extend (new: old: {
- ppad-bolt1 = bolt1-llvm;
+ ppad-bolt1 = bolt1;
+ ppad-bolt9 = bolt9;
ppad-aead = aead-llvm;
ppad-base16 = base16-llvm;
ppad-chacha = chacha-llvm;
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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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 t'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
@@ -67,13 +74,15 @@ benchmark bolt4-bench
default-language: Haskell2010
hs-source-dirs: bench
main-is: Main.hs
+ other-modules: Fixtures
ghc-options:
- -rtsopts -O2 -Wall -fno-warn-orphans
+ -rtsopts -O2 -Wall
build-depends:
base
, bytestring
, criterion
, deepseq
+ , ppad-bolt1
, ppad-bolt4
benchmark bolt4-weigh
@@ -81,10 +90,13 @@ benchmark bolt4-weigh
default-language: Haskell2010
hs-source-dirs: bench
main-is: Weight.hs
+ other-modules: Fixtures
ghc-options:
- -rtsopts -O2 -Wall -fno-warn-orphans
+ -rtsopts -O2 -Wall
build-depends:
base
, bytestring
+ , deepseq
+ , ppad-bolt1
, ppad-bolt4
, weigh
diff --git a/test/Main.hs b/test/Main.hs
@@ -2,1706 +2,867 @@
module Main where
-import Control.Monad (foldM)
+import Control.Monad (forM_)
+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.ByteString.Base16 as B16
-import qualified Crypto.Curve.Secp256k1 as Secp256k1
-import qualified Crypto.Hash.SHA256 as SHA256
-import Data.List (nub, sort)
-import Data.Maybe (isJust)
-import Data.Word (Word8, Word16, Word32)
-import Lightning.Protocol.BOLT4.Blinding
-import Lightning.Protocol.BOLT4.Codec
-import Lightning.Protocol.BOLT4.Construct
-import Lightning.Protocol.BOLT4.Error
-import Lightning.Protocol.BOLT4.Internal
-import Lightning.Protocol.BOLT4.Prim
-import Lightning.Protocol.BOLT4.Process
-import Lightning.Protocol.BOLT4.Types
+import Data.List (nubBy)
+import Data.Word (Word8, Word16, Word32, Word64)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT4
+import qualified Lightning.Protocol.BOLT9 as BOLT9
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import qualified Vectors as V
--- | Demand a Just value in IO, failing the test on Nothing.
-demand :: String -> Maybe a -> IO a
-demand _ (Just a) = pure a
-demand msg Nothing = assertFailure msg
-
--- | Decode hex, failing the test on invalid input.
-unhex :: BS.ByteString -> IO BS.ByteString
-unhex = demand "invalid hex" . B16.decode
-
--- | Decode a hex-encoded public key, failing the test if invalid.
-unhexPoint :: BS.ByteString -> IO Secp256k1.Projective
-unhexPoint h = unhex h >>= demand "invalid point" . Secp256k1.parse_point
-
--- | Strip a BigSize length prefix, checking that it is exact.
-unprefix :: BS.ByteString -> IO BS.ByteString
-unprefix bs = do
- (len, body) <- demand "invalid length prefix" (decodeBigSize bs)
- assertEqual "length prefix" (fromIntegral len) (BS.length body)
- pure body
-
--- | Construct a ShortChannelId, failing if invalid.
-assertScid :: Word32 -> Word32 -> Word16
- -> IO ShortChannelId
-assertScid b t o = demand "shortChannelId" (shortChannelId b t o)
-
--- | Construct a ShortChannelId for test fixtures.
-mkScid :: Word32 -> Word32 -> Word16 -> ShortChannelId
-mkScid b t o = case shortChannelId b t o of
- Just s -> s
- Nothing -> error "mkScid: invalid test fixture"
-
main :: IO ()
main = defaultMain $ testGroup "ppad-bolt4" [
- testGroup "Prim" [
- primTests
- ]
- , testGroup "BigSize" [
- bigsizeTests
- , bigsizeRoundtripProp
- ]
- , testGroup "TLV" [
- tlvTests
- , tlvRejectionTests
- ]
- , testGroup "ShortChannelId" [
- sciTests
- ]
- , testGroup "OnionPacket" [
- onionPacketTests
- ]
- , testGroup "Construct" [
- constructTests
- ]
- , testGroup "Process" [
- processTests
- ]
- , testGroup "Error" [
- errorTests
- ]
- , testGroup "properties" [
- propertyTests
- ]
- , testGroup "Blinding" [
- blindingKeyDerivationTests
- , blindingEphemeralKeyTests
- , blindingTlvTests
- , blindingEncryptionTests
- , blindingCreatePathTests
- , blindingProcessHopTests
- ]
+ key_tests
+ , codec_tests
+ , failure_tests
+ , construct_tests
+ , process_tests
+ , blinding_tests
+ , error_tests
, testGroup "spec vectors" [
- onionVectorTests
- , errorVectorTests
- , traceVectorTests
- , routeBlindingTests
- , blindedPaymentTests
+ onion_vectors
+ , error_vectors
+ , trace_vectors
+ , route_blinding_vectors
+ , blinded_payment_vectors
]
- , testGroup "multi-hop" [
- multiHopTests
- ]
- ]
-
--- BigSize tests ------------------------------------------------------------
-
-bigsizeTests :: TestTree
-bigsizeTests = testGroup "boundary values" [
- testCase "0" $
- encodeBigSize 0 @?= BS.pack [0x00]
- , testCase "0xFC" $
- encodeBigSize 0xFC @?= BS.pack [0xFC]
- , testCase "0xFD" $
- encodeBigSize 0xFD @?= BS.pack [0xFD, 0x00, 0xFD]
- , testCase "0xFFFF" $
- encodeBigSize 0xFFFF @?= BS.pack [0xFD, 0xFF, 0xFF]
- , testCase "0x10000" $
- encodeBigSize 0x10000 @?=
- BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00]
- , testCase "0xFFFFFFFF" $
- encodeBigSize 0xFFFFFFFF @?=
- BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF]
- , testCase "0x100000000" $
- encodeBigSize 0x100000000 @?=
- BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01,
- 0x00, 0x00, 0x00, 0x00]
- , testCase "decode 0" $ do
- let result = decodeBigSize (BS.pack [0x00])
- result @?= Just (0, BS.empty)
- , testCase "decode 0xFC" $ do
- let result = decodeBigSize (BS.pack [0xFC])
- result @?= Just (0xFC, BS.empty)
- , testCase "decode 0xFD" $ do
- let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFD])
- result @?= Just (0xFD, BS.empty)
- , testCase "decode 0xFFFF" $ do
- let result = decodeBigSize (BS.pack [0xFD, 0xFF, 0xFF])
- result @?= Just (0xFFFF, BS.empty)
- , testCase "decode 0x10000" $ do
- let result = decodeBigSize $
- BS.pack [0xFE, 0x00, 0x01, 0x00, 0x00]
- result @?= Just (0x10000, BS.empty)
- , testCase "decode 0xFFFFFFFF" $ do
- let result = decodeBigSize $
- BS.pack [0xFE, 0xFF, 0xFF, 0xFF, 0xFF]
- result @?= Just (0xFFFFFFFF, BS.empty)
- , testCase "decode 0x100000000" $ do
- let result = decodeBigSize $
- BS.pack [0xFF, 0x00, 0x00, 0x00, 0x01,
- 0x00, 0x00, 0x00, 0x00]
- result @?= Just (0x100000000, BS.empty)
- , testCase "reject non-canonical 0xFD encoding" $ do
- let result = decodeBigSize (BS.pack [0xFD, 0x00, 0xFC])
- result @?= Nothing
- , testCase "reject non-canonical 0xFE encoding" $ do
- let result = decodeBigSize $
- BS.pack [0xFE, 0x00, 0x00, 0xFF, 0xFF]
- result @?= Nothing
- , testCase "bigSizeLen" $ do
- bigSizeLen 0 @?= 1
- bigSizeLen 0xFC @?= 1
- bigSizeLen 0xFD @?= 3
- bigSizeLen 0xFFFF @?= 3
- bigSizeLen 0x10000 @?= 5
- bigSizeLen 0xFFFFFFFF @?= 5
- bigSizeLen 0x100000000 @?= 9
- ]
-
-bigsizeRoundtripProp :: TestTree
-bigsizeRoundtripProp = testProperty "roundtrip" $ \n ->
- let encoded = encodeBigSize n
- decoded = decodeBigSize encoded
- in decoded == Just (n, BS.empty)
-
--- TLV tests ----------------------------------------------------------------
-
-tlvTests :: TestTree
-tlvTests = testGroup "encoding/decoding" [
- testCase "single record" $ do
- let rec = TlvRecord 2 (BS.pack [0x01, 0x02, 0x03])
- encoded = encodeTlv rec
- decoded = decodeTlv encoded
- decoded @?= Just (rec, BS.empty)
- , testCase "stream roundtrip" $ do
- let recs = [ TlvRecord 2 (BS.pack [0x01])
- , TlvRecord 4 (BS.pack [0x02, 0x03])
- , TlvRecord 100 (BS.pack [0x04, 0x05, 0x06])
- ]
- encoded = encodeTlvStream recs
- decoded = decodeTlvStream encoded
- decoded @?= Just recs
- , testCase "reject out-of-order types" $ do
- let rec1 = encodeTlv (TlvRecord 4 (BS.pack [0x01]))
- rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02]))
- badStream = rec1 <> rec2
- decoded = decodeTlvStream badStream
- decoded @?= Nothing
- , testCase "reject duplicate types" $ do
- let rec1 = encodeTlv (TlvRecord 2 (BS.pack [0x01]))
- rec2 = encodeTlv (TlvRecord 2 (BS.pack [0x02]))
- badStream = rec1 <> rec2
- decoded = decodeTlvStream badStream
- decoded @?= Nothing
- , testCase "empty stream" $ do
- let decoded = decodeTlvStream BS.empty
- decoded @?= Just []
- ]
-
-tlvRejectionTests :: TestTree
-tlvRejectionTests = testGroup "rejection" [
- testCase "length of 2^64 - 1" $ do
- let huge = BS.pack (0xff : replicate 8 0xff)
- decodeTlv (BS.singleton 0x01 <> huge <> BS.pack [0xaa, 0xbb])
- @?= Nothing
- decodeTlvStream (BS.singleton 0x01 <> huge <> BS.pack [0x03, 0x00])
- @?= Nothing
- decodeHopPayload
- (BS.singleton 0x02 <> huge <> BS.pack [0x04, 0x01, 0x07])
- @?= Nothing
- , testCase "hop payload: unknown even type" $
- decodeHopPayload (BS.pack [0x02, 0x01, 0x05, 0x0e, 0x01, 0x07])
- @?= Nothing
- , testCase "hop payload: unknown odd type is kept" $
- fmap hpUnknownTlvs
- (decodeHopPayload (BS.pack [0x02, 0x01, 0x05, 0x0f, 0x01, 0x07]))
- @?= Just [TlvRecord 15 (BS.singleton 0x07)]
- , testCase "hop payload: types 16 and 18 are accepted" $
- fmap hpUnknownTlvs
- (decodeHopPayload (BS.pack [0x10, 0x01, 0x01, 0x12, 0x01, 0x02]))
- @?= Just [ TlvRecord 16 (BS.singleton 0x01)
- , TlvRecord 18 (BS.singleton 0x02) ]
- , testCase "blinded hop data: unknown even type" $
- decodeBlindedHopData (BS.pack [0x10, 0x01, 0x00]) @?= Nothing
- , testCase "blinded hop data: unknown odd type is skipped" $
- decodeBlindedHopData (BS.pack [0x06, 0x01, 0x2a, 0xfd, 0x02, 0x31,
- 0x01, 0x00])
- @?= Just emptyHopData { bhdPathId = Just (BS.singleton 0x2a) }
- ]
-
--- ShortChannelId tests -----------------------------------------------------
-
-sciTests :: TestTree
-sciTests = testGroup "encoding/decoding" [
- testCase "known value" $ do
- sci <- assertScid 700000 1234 5
- let encoded = encodeShortChannelId sci
- BS.length encoded @?= 8
- let decoded = decodeShortChannelId encoded
- decoded @?= Just sci
- , testCase "maximum values" $ do
- sci <- assertScid 0xFFFFFF 0xFFFFFF 0xFFFF
- let encoded = encodeShortChannelId sci
- BS.length encoded @?= 8
- let decoded = decodeShortChannelId encoded
- decoded @?= Just sci
- , testCase "zero values" $ do
- sci <- assertScid 0 0 0
- let encoded = encodeShortChannelId sci
- expected = BS.pack [0, 0, 0, 0, 0, 0, 0, 0]
- encoded @?= expected
- let decoded = decodeShortChannelId encoded
- decoded @?= Just sci
- , testCase "reject wrong length" $ do
- let decoded =
- decodeShortChannelId (BS.pack [0, 1, 2, 3, 4, 5, 6])
- decoded @?= Nothing
- ]
-
--- OnionPacket tests --------------------------------------------------------
-
-onionPacketTests :: TestTree
-onionPacketTests = testGroup "encoding/decoding" [
- testCase "roundtrip" $ do
- let packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = BS.replicate 33 0xAB
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0xCD)
- , opHmac = unsafeHmac32 (BS.replicate 32 0xEF)
- }
- encoded = encodeOnionPacket packet
- BS.length encoded @?= onionPacketSize
- let decoded = decodeOnionPacket encoded
- decoded @?= Just packet
- , testCase "reject wrong size" $ do
- let decoded =
- decodeOnionPacket (BS.replicate 1000 0x00)
- decoded @?= Nothing
+ , properties
]
--- Prim tests ---------------------------------------------------------------
+-- helpers --------------------------------------------------------------------
-sessionKey :: BS.ByteString
-sessionKey = BS.replicate 32 0x41
-
-hop0PubKeyHex :: BS.ByteString
-hop0PubKeyHex =
- "02eec7245d6b7d2ccb30380bfbe2a3648cd7a942653f5aa340edcea1f283686619"
-
-hop0SharedSecretHex :: BS.ByteString
-hop0SharedSecretHex =
- "53eb63ea8a3fec3b3cd433b85cd62a4b145e1dda09391b348c4e1cd36a03ea66"
-
-hop0BlindingFactorHex :: BS.ByteString
-hop0BlindingFactorHex =
- "2ec2e5da605776054187180343287683aa6a51b4b1c04d6dd49c45d8cffb3c36"
-
-fromHex :: BS.ByteString -> BS.ByteString
-fromHex h = case B16.decode h of
- Just bs -> bs
- Nothing -> error "fromHex: invalid hex"
-
-primTests :: TestTree
-primTests = testGroup "cryptographic primitives" [
- testSharedSecret
- , testBlindingFactor
- , testKeyDerivation
- , testBlindPubKey
- , testGenerateStream
- , testHmacOperations
- ]
-
-testSharedSecret :: TestTree
-testSharedSecret =
- testCase "computeSharedSecret (BOLT4 spec hop 0)" $ do
- pubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- case computeSharedSecret sessionKey pubKey of
- Nothing ->
- assertFailure "computeSharedSecret returned Nothing"
- Just (SharedSecret computed) -> do
- let expected = fromHex hop0SharedSecretHex
- computed @?= expected
-
-testBlindingFactor :: TestTree
-testBlindingFactor =
- testCase "computeBlindingFactor (BOLT4 spec hop 0)" $ do
- sk <- demand "roll32" $ Secp256k1.roll32 sessionKey
- ephemPubKey <- demand "derive_pub" $
- Secp256k1.derive_pub sk
- nodePubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- case computeSharedSecret sessionKey nodePubKey of
- Nothing ->
- assertFailure "computeSharedSecret returned Nothing"
- Just sharedSecret -> do
- let BlindingFactor computed =
- computeBlindingFactor ephemPubKey sharedSecret
- expected = fromHex hop0BlindingFactorHex
- computed @?= expected
-
-testKeyDerivation :: TestTree
-testKeyDerivation = testGroup "key derivation" [
- testCase "deriveRho produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey rho = deriveRho ss
- BS.length rho @?= 32
- , testCase "deriveMu produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey mu = deriveMu ss
- BS.length mu @?= 32
- , testCase "deriveUm produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey um = deriveUm ss
- BS.length um @?= 32
- , testCase "derivePad produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey pad = derivePad ss
- BS.length pad @?= 32
- , testCase "deriveAmmag produces 32 bytes" $ do
- let ss = SharedSecret (BS.replicate 32 0)
- DerivedKey ammag = deriveAmmag ss
- BS.length ammag @?= 32
- , testCase "different key types produce different results" $ do
- let ss = SharedSecret (BS.replicate 32 0x42)
- DerivedKey rho = deriveRho ss
- DerivedKey mu = deriveMu ss
- DerivedKey um = deriveUm ss
- assertBool "rho /= mu" (rho /= mu)
- assertBool "mu /= um" (mu /= um)
- assertBool "rho /= um" (rho /= um)
- ]
-
-testBlindPubKey :: TestTree
-testBlindPubKey = testGroup "key blinding" [
- testCase "blindPubKey produces valid key" $ do
- sk <- demand "roll32" $ Secp256k1.roll32 sessionKey
- pubKey <- demand "derive_pub" $ Secp256k1.derive_pub sk
- let bf = BlindingFactor (fromHex hop0BlindingFactorHex)
- case blindPubKey pubKey bf of
- Nothing ->
- assertFailure "blindPubKey returned Nothing"
- Just _blinded -> return ()
- , testCase "blindSecKey produces valid key" $ do
- let bf = BlindingFactor (fromHex hop0BlindingFactorHex)
- case blindSecKey sessionKey bf of
- Nothing ->
- assertFailure "blindSecKey returned Nothing"
- Just _blinded -> return ()
- ]
-
-testGenerateStream :: TestTree
-testGenerateStream = testGroup "generateStream" [
- testCase "produces correct length" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- fmap BS.length (generateStream dk 100) @?= Just 100
- , testCase "1300-byte stream for hop_payloads" $ do
- let dk = DerivedKey (BS.replicate 32 0x42)
- fmap BS.length (generateStream dk 1300) @?= Just 1300
- , testCase "deterministic output" $ do
- let dk = DerivedKey (BS.replicate 32 0x55)
- stream1 = generateStream dk 64
- stream2 = generateStream dk 64
- stream1 @?= stream2
- , testCase "fails on a key that is not 32 bytes" $
- generateStream (DerivedKey "short") 16 @?= Nothing
- ]
-
-testHmacOperations :: TestTree
-testHmacOperations = testGroup "HMAC operations" [
- testCase "computeHmac produces 32 bytes" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- hm = computeHmac dk "payloads" "assocdata"
- BS.length hm @?= 32
- , testCase "verifyHmac succeeds for matching" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- hm = computeHmac dk "payloads" "assocdata"
- assertBool "verifyHmac should succeed"
- (verifyHmac hm hm)
- , testCase "verifyHmac fails for different" $ do
- let dk = DerivedKey (BS.replicate 32 0)
- hm1 = computeHmac dk "payloads1" "assocdata"
- hm2 = computeHmac dk "payloads2" "assocdata"
- assertBool "verifyHmac should fail"
- (not $ verifyHmac hm1 hm2)
- , testCase "verifyHmac fails for different lengths" $ do
- assertBool "verifyHmac should fail"
- (not $ verifyHmac "short" "different length")
- ]
-
--- Construct tests ----------------------------------------------------------
-
--- Test vectors from BOLT4 spec
-hop1PubKeyHex :: BS.ByteString
-hop1PubKeyHex =
- "0324653eac434488002cc06bbfb7f10fe18991e35f9fe4302dbea6d2353dc0ab1c"
-
-hop2PubKeyHex :: BS.ByteString
-hop2PubKeyHex =
- "027f31ebc5462c1fdce1b737ecff52d37d75dea43ce11c74d25aa297165faa2007"
-
-hop3PubKeyHex :: BS.ByteString
-hop3PubKeyHex =
- "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"
-
-hop4PubKeyHex :: BS.ByteString
-hop4PubKeyHex =
- "02edabbd16b41c8371b92ef2f04c1185b4f03b6dcd52ba9b78d9d7c89c8f221145"
-
--- Expected shared secrets from BOLT4 error test vectors
-hop1SharedSecretHex :: BS.ByteString
-hop1SharedSecretHex =
- "a6519e98832a0b179f62123b3567c106db99ee37bef036e783263602f3488fae"
-
-hop2SharedSecretHex :: BS.ByteString
-hop2SharedSecretHex =
- "3a6b412548762f0dbccce5c7ae7bb8147d1caf9b5471c34120b30bc9c04891cc"
-
-hop3SharedSecretHex :: BS.ByteString
-hop3SharedSecretHex =
- "21e13c2d7cfe7e18836df50872466117a295783ab8aab0e7ecc8c725503ad02d"
+demand :: String -> Maybe a -> IO a
+demand _ (Just a) = pure a
+demand msg Nothing = assertFailure msg
-hop4SharedSecretHex :: BS.ByteString
-hop4SharedSecretHex =
- "b5756b9b542727dbafc6765a49488b023a725d631af688fc031217e90770c328"
+right :: Show e => String -> Either e a -> IO a
+right _ (Right a) = pure a
+right msg (Left e) = assertFailure (msg ++ ": " ++ show e)
-constructTests :: TestTree
-constructTests = testGroup "packet construction" [
- testConstructErrorCases
- , testSharedSecretComputation
- , testPacketStructure
- , testSingleHop
- ]
+unhex :: BS.ByteString -> IO BS.ByteString
+unhex = demand "invalid hex" . B16.decode
-testConstructErrorCases :: TestTree
-testConstructErrorCases = testGroup "error cases" [
- testCase "rejects invalid session key (too short)" $ do
- let result = construct (BS.replicate 31 0x41) [] ""
- case result of
- Left InvalidSessionKey -> return ()
- _ -> assertFailure "Expected InvalidSessionKey"
- , testCase "rejects invalid session key (too long)" $ do
- let result = construct (BS.replicate 33 0x41) [] ""
- case result of
- Left InvalidSessionKey -> return ()
- _ -> assertFailure "Expected InvalidSessionKey"
- , testCase "rejects empty route" $ do
- let result = construct sessionKey [] ""
- case result of
- Left EmptyRoute -> return ()
- _ -> assertFailure "Expected EmptyRoute"
- , testCase "rejects too many hops" $ do
- pub <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let emptyPayload = HopPayload Nothing Nothing Nothing
- Nothing Nothing Nothing []
- hop = Hop pub emptyPayload
- hops = replicate 21 hop
- result = construct sessionKey hops ""
- case result of
- Left TooManyHops -> return ()
- _ -> assertFailure "Expected TooManyHops"
- , testCase "rejects an empty hop payload" $ do
- pub <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let emptyPayload = HopPayload Nothing Nothing Nothing
- Nothing Nothing Nothing []
- hops = [Hop pub minimalPayload, Hop pub emptyPayload]
- construct sessionKey hops "" @?= Left (InvalidHopPayload 1)
- ]
+hex_key :: BS.ByteString -> IO SecretKey
+hex_key h = unhex h >>= demand "invalid secret key" . secret_key
--- | A small, valid hop payload.
-minimalPayload :: HopPayload
-minimalPayload =
- HopPayload (Just 1000) (Just 500000) Nothing Nothing Nothing Nothing []
-
-testSharedSecretComputation :: TestTree
-testSharedSecretComputation =
- testCase "computes correct shared secrets (BOLT4 spec)" $ do
- pub0 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- pub1 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop1PubKeyHex)
- pub2 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop2PubKeyHex)
- pub3 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop3PubKeyHex)
- pub4 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop4PubKeyHex)
- let hops = [ Hop pub0 minimalPayload
- , Hop pub1 minimalPayload
- , Hop pub2 minimalPayload
- , Hop pub3 minimalPayload
- , Hop pub4 minimalPayload
- ]
- result = construct sessionKey hops ""
- case result of
- Left err ->
- assertFailure $ "construct failed: " ++ show err
- Right (_, secrets) -> case secrets of
- [SharedSecret ss0, SharedSecret ss1,
- SharedSecret ss2, SharedSecret ss3,
- SharedSecret ss4] -> do
- ss0 @?= fromHex hop0SharedSecretHex
- ss1 @?= fromHex hop1SharedSecretHex
- ss2 @?= fromHex hop2SharedSecretHex
- ss3 @?= fromHex hop3SharedSecretHex
- ss4 @?= fromHex hop4SharedSecretHex
- _ -> assertFailure "expected 5 shared secrets"
-
-testPacketStructure :: TestTree
-testPacketStructure =
- testCase "produces valid packet structure" $ do
- pub0 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- pub1 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop1PubKeyHex)
- let hops = [Hop pub0 minimalPayload,
- Hop pub1 minimalPayload]
- result = construct sessionKey hops ""
- case result of
- Left err ->
- assertFailure $ "construct failed: " ++ show err
- Right (packet, _) -> do
- opVersion packet @?= versionByte
- BS.length (opEphemeralKey packet) @?= pubkeySize
- BS.length (unHopPayloads (opHopPayloads packet))
- @?= hopPayloadsSize
- BS.length (unHmac32 (opHmac packet)) @?= hmacSize
- sk <- demand "roll32" $ Secp256k1.roll32 sessionKey
- expectedPub <- demand "derive_pub" $
- Secp256k1.derive_pub sk
- let expectedPubBytes =
- Secp256k1.serialize_point expectedPub
- opEphemeralKey packet @?= expectedPubBytes
-
-testSingleHop :: TestTree
-testSingleHop =
- testCase "constructs single-hop packet" $ do
- pub0 <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let payload = HopPayload
- { hpAmtToForward = Just 1000
- , hpOutgoingCltv = Just 500000
- , hpShortChannelId = Nothing
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
- }
- hops = [Hop pub0 payload]
- result = construct sessionKey hops ""
- case result of
- Left err ->
- assertFailure $ "construct failed: " ++ show err
- Right (packet, secrets) -> do
- length secrets @?= 1
- -- Packet should be valid structure
- let encoded = encodeOnionPacket packet
- BS.length encoded @?= onionPacketSize
- -- Should decode back
- decoded <- demand "decodeOnionPacket" $
- decodeOnionPacket encoded
- decoded @?= packet
-
--- Process tests -----------------------------------------------------------
-
-processTests :: TestTree
-processTests = testGroup "packet processing" [
- testVersionValidation
- , testEphemeralKeyValidation
- , testHmacValidation
- , testProcessBasic
- , testPayloadLength
- ]
+hex_point :: BS.ByteString -> IO BOLT1.Point
+hex_point h = unhex h >>= demand "invalid point" . BOLT1.point
-testVersionValidation :: TestTree
-testVersionValidation = testGroup "version validation" [
- testCase "reject invalid version 0x01" $ do
- let packet = OnionPacket
- { opVersion = 0x01
- , opEphemeralKey = BS.replicate 33 0x02
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left (InvalidVersion v) -> v @?= 0x01
- Left other ->
- assertFailure $ "expected InvalidVersion, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- , testCase "reject invalid version 0xFF" $ do
- let packet = OnionPacket
- { opVersion = 0xFF
- , opEphemeralKey = BS.replicate 33 0x02
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left (InvalidVersion v) -> v @?= 0xFF
- Left other ->
- assertFailure $ "expected InvalidVersion, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- ]
+hex_secret :: BS.ByteString -> IO SharedSecret
+hex_secret h = unhex h >>= demand "invalid shared secret" . shared_secret
-testEphemeralKeyValidation :: TestTree
-testEphemeralKeyValidation =
- testGroup "ephemeral key validation" [
- testCase "reject invalid ephemeral key (all zeros)" $ do
- let packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = BS.replicate 33 0x00
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left InvalidEphemeralKey -> return ()
- Left other ->
- assertFailure $
- "expected InvalidEphemeralKey, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- , testCase "reject malformed ephemeral key" $ do
- let packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey =
- BS.pack (0x04 : replicate 32 0xAB)
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0x00)
- }
- case process sessionKey packet BS.empty of
- Left InvalidEphemeralKey -> return ()
- Left other ->
- assertFailure $
- "expected InvalidEphemeralKey, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
- ]
+-- strip a BigSize length prefix, checking that it is exact
+unprefix :: BS.ByteString -> IO BS.ByteString
+unprefix bs = do
+ (len, body) <- demand "invalid length prefix" (BOLT1.decode_bigsize bs)
+ assertEqual "length prefix" (fromIntegral len) (BS.length body)
+ pure body
-testHmacValidation :: TestTree
-testHmacValidation = testGroup "HMAC validation" [
- testCase "reject invalid HMAC" $ do
- hop0PubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let ephKeyBytes =
- Secp256k1.serialize_point hop0PubKey
- packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = ephKeyBytes
- , opHopPayloads =
- unsafeHopPayloads (BS.replicate 1300 0x00)
- , opHmac =
- unsafeHmac32 (BS.replicate 32 0xFF)
- }
- case process sessionKey packet BS.empty of
- Left HmacMismatch -> return ()
- Left other ->
- assertFailure $ "expected HmacMismatch, got: "
- ++ show other
- Right _ ->
- assertFailure "expected rejection, got success"
+msat :: Word64 -> IO BOLT1.MilliSatoshi
+msat = demand "invalid amount" . BOLT1.milli_satoshi
+
+scid :: Word32 -> Word32 -> Word16 -> IO BOLT1.ShortChannelId
+scid b t o = demand "invalid scid" (BOLT1.short_channel_id b t o)
+
+tlvs :: [BOLT1.TlvRecord] -> IO BOLT1.TlvStream
+tlvs = demand "invalid tlv stream" . BOLT1.tlv_stream
+
+no_tlvs :: BOLT1.TlvStream
+no_tlvs = BOLT1.empty_tlv_stream
+
+key :: Word8 -> IO SecretKey
+key b = demand "invalid secret key" (secret_key (BS.replicate 32 b))
+
+ad :: BS.ByteString
+ad = BS.replicate 32 0x42
+
+-- a point with a valid prefix but not on the curve
+off_curve :: IO BOLT1.Point
+off_curve =
+ case [ p | x <- [0 .. 255 :: Word8]
+ , let bs = BS.cons 0x02 (BS.replicate 31 0 <> BS.singleton x)
+ , Secp256k1.parse_point bs == Nothing
+ , Just p <- [BOLT1.point bs] ] of
+ p : _ -> pure p
+ [] -> assertFailure "no off-curve point found"
+
+-- a payload with the given outgoing_cltv_value
+cltv_payload :: Word32 -> HopPayload
+cltv_payload c = empty_hop_payload { hp_outgoing_cltv_value = Just c }
+
+expect_process
+ :: ProcessError -> Either ProcessError ProcessResult -> Assertion
+expect_process e r = case r of
+ Left e' -> e' @?= e
+ Right _ -> assertFailure ("expected " ++ show e)
+
+forward :: Either ProcessError ProcessResult -> IO ForwardInfo
+forward r = case r of
+ Right (Forward f) -> pure f
+ Right (Receive _) -> assertFailure "expected Forward, got Receive"
+ Left e -> assertFailure ("process: " ++ show e)
+
+receive :: Either ProcessError ProcessResult -> IO ReceiveInfo
+receive r = case r of
+ Right (Receive i) -> pure i
+ Right (Forward _) -> assertFailure "expected Receive, got Forward"
+ Left e -> assertFailure ("process: " ++ show e)
+
+-- A single-hop onion, built independently of the library, whose
+-- decrypted hop_payloads is the given 1300-byte plaintext.
+raw_onion :: SecretKey -> BS.ByteString -> IO OnionPacket
+raw_onion node plain = do
+ let session = BS.replicate 32 0x77
+ e <- demand "session" (Secp256k1.parse_int256 session)
+ epub <- demand "session pub" (Secp256k1.derive_pub e)
+ n <- demand "node pub"
+ (Secp256k1.parse_point (BOLT1.un_point (public_key node)))
+ pt <- demand "ecdh" (Secp256k1.mul n e)
+ let ss = SHA256.hash (Secp256k1.serialize_point pt)
+ derive l = let SHA256.MAC k = SHA256.hmac l ss in k
+ stream <- right "chacha"
+ (ChaCha.cipher (derive "rho") 0 (BS.replicate 12 0)
+ (BS.replicate 1300 0))
+ let body = BS.packZipWith xor plain stream
+ SHA256.MAC mac = SHA256.hmac (derive "mu") (body <> ad)
+ pk <- demand "point" (BOLT1.point (Secp256k1.serialize_point epub))
+ OnionPacket 0 pk
+ <$> demand "hop_payloads" (hop_payloads body)
+ <*> demand "hmac" (hmac32 mac)
+
+-- pad a plaintext region to 1300 bytes
+pad1300 :: BS.ByteString -> BS.ByteString
+pad1300 bs = bs <> BS.replicate (1300 - BS.length bs) 0
+
+-- keys -----------------------------------------------------------------------
+
+key_tests :: TestTree
+key_tests = testGroup "keys" [
+ testCase "secret_key accepts 32-byte keys in range" $ do
+ _ <- key 0x01
+ sk <- demand "n - 1" . secret_key =<< unhex
+ "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140"
+ BS.length (BOLT1.un_point (public_key sk)) @?= 33
+ , testCase "secret_key rejects other lengths" $ do
+ assertNone (secret_key (BS.replicate 31 0x01))
+ assertNone (secret_key (BS.replicate 33 0x01))
+ assertNone (secret_key (BS.cons 0x00 (BS.replicate 32 0x01)))
+ assertNone (secret_key BS.empty)
+ , testCase "secret_key rejects zero and keys >= n" $ do
+ assertNone (secret_key (BS.replicate 32 0x00))
+ n <- unhex
+ "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141"
+ assertNone (secret_key n)
+ assertNone (secret_key (BS.replicate 32 0xff))
+ , testCase "public_key matches secp256k1" $ do
+ sk <- key 0x41
+ expected <- unhex V.onionPubKey0
+ BOLT1.un_point (public_key sk) @?= expected
+ , testCase "shared_secret requires 32 bytes" $ do
+ assertNone (shared_secret (BS.replicate 31 0))
+ assertNone (shared_secret (BS.replicate 33 0))
+ ss <- demand "ss" (shared_secret (BS.replicate 32 7))
+ un_shared_secret ss @?= BS.replicate 32 7
+ , testCase "shared secrets compare by value" $ do
+ a <- demand "a" (shared_secret (BS.replicate 32 7))
+ b <- demand "b" (shared_secret (BS.replicate 32 7))
+ c <- demand "c" (shared_secret (BS.cons 8 (BS.replicate 31 7)))
+ assertBool "equal" (a == b)
+ assertBool "not equal" (a /= c)
+ , testCase "secrets don't show their bytes" $ do
+ sk <- key 0x41
+ ss <- demand "ss" (shared_secret (BS.replicate 32 0x41))
+ ps <- demand "ps" (payment_secret (BS.replicate 32 0x41))
+ show sk @?= "SecretKey <redacted>"
+ show ss @?= "SharedSecret <redacted>"
+ show ps @?= "PaymentSecret <redacted>"
]
-
--- | Test basic packet processing with a properly constructed
--- packet.
-testProcessBasic :: TestTree
-testProcessBasic = testGroup "basic processing" [
- testCase "process valid packet (final hop)" $ do
- hop0PubKey <- demand "parse_point" $
- Secp256k1.parse_point (fromHex hop0PubKeyHex)
- let ephKeyBytes =
- Secp256k1.serialize_point hop0PubKey
- hopPayloadTlv = encodeHopPayload HopPayload
- { hpAmtToForward = Just 1000
- , hpOutgoingCltv = Just 500000
- , hpShortChannelId = Nothing
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
+ where
+ assertNone m = case m of
+ Nothing -> pure ()
+ Just _ -> assertFailure "expected Nothing"
+
+-- codecs ---------------------------------------------------------------------
+
+codec_tests :: TestTree
+codec_tests = testGroup "codecs" [
+ testCase "decode_onion_packet rejects other lengths" $ do
+ decode_onion_packet (BS.replicate 1365 0) @?= Left InvalidLength
+ decode_onion_packet (BS.replicate 1367 0) @?= Left InvalidLength
+ decode_onion_packet BS.empty @?= Left InvalidLength
+ , testCase "decode_onion_packet rejects a bad point prefix" $ do
+ let bs = BS.concat [ BS.singleton 0, BS.singleton 0x04
+ , BS.replicate 1364 0 ]
+ decode_onion_packet bs @?= Left InvalidPoint
+ , testCase "decode_onion_packet keeps the version byte" $ do
+ let bs = BS.concat [ BS.singleton 7, BS.singleton 0x02
+ , BS.replicate 1364 0 ]
+ pkt <- right "decode" (decode_onion_packet bs)
+ onion_version pkt @?= 7
+ encode_onion_packet pkt @?= bs
+ , testCase "smart constructors check lengths" $ do
+ hop_payloads (BS.replicate 1299 0) @?= Nothing
+ hop_payloads (BS.replicate 1301 0) @?= Nothing
+ hmac32 (BS.replicate 31 0) @?= Nothing
+ onion_hash (BS.replicate 33 0) @?= Nothing
+ case payment_secret (BS.replicate 31 0) of
+ Nothing -> pure ()
+ Just _ -> assertFailure "short payment secret"
+
+ , testCase "hop payload: all typed fields" $ do
+ amt <- msat 1000
+ tot <- msat 5000
+ s <- scid 1 2 3
+ ps <- demand "ps" (payment_secret (BS.replicate 32 0xaa))
+ pk <- hex_point V.onionPubKey0
+ ex <- tlvs [BOLT1.TlvRecord 19 "x"]
+ let hp = HopPayload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 500000
+ , hp_short_channel_id = Just s
+ , hp_payment_data = Just (PaymentData ps tot)
+ , hp_encrypted_data = Just "enc"
+ , hp_current_path_key = Just pk
+ , hp_payment_metadata = Just "meta"
+ , hp_total_amount_msat = Just tot
+ , hp_extra = ex
}
- payloadLen = BS.length hopPayloadTlv
- lenPrefix =
- encodeBigSize (fromIntegral payloadLen)
- payloadWithHmac = lenPrefix <> hopPayloadTlv
- <> BS.replicate 32 0x00
- padding = BS.replicate
- (1300 - BS.length payloadWithHmac) 0x00
- rawPayloads = payloadWithHmac <> padding
- ss <- demand "computeSharedSecret" $
- computeSharedSecret sessionKey hop0PubKey
- stream <- demand "generateStream" $
- generateStream (deriveRho ss) 1300
- let muKey = deriveMu ss
- encryptedPayloads =
- BS.pack (BS.zipWith xor rawPayloads stream)
- correctHmac =
- computeHmac muKey encryptedPayloads BS.empty
- packet = OnionPacket
- { opVersion = 0x00
- , opEphemeralKey = ephKeyBytes
- , opHopPayloads =
- unsafeHopPayloads encryptedPayloads
- , opHmac = unsafeHmac32 correctHmac
+ bs <- right "encode" (encode_hop_payload hp)
+ expected <- unhex $ BS.concat
+ [ "020203e8", "040307a120", "06080000010000020003"
+ , "0822", BS.concat (replicate 32 "aa"), "1388"
+ , "0a03656e63", "0c21", V.onionPubKey0, "10046d657461"
+ , "12021388", "130178" ]
+ bs @?= expected
+ decode_hop_payload bs @?= Right hp
+ , testCase "hop payload: zero values encode minimally" $ do
+ zero <- msat 0
+ let hp = empty_hop_payload { hp_amt_to_forward = Just zero
+ , hp_outgoing_cltv_value = Just 0 }
+ encode_hop_payload hp @?= Right "\STX\NUL\EOT\NUL"
+ decode_hop_payload "\STX\NUL\EOT\NUL" @?= Right hp
+ , testCase "hop payload: unknown odd types are kept" $ do
+ hp <- right "decode" (decode_hop_payload "\STX\SOH\SOH\ETX\NUL")
+ ex <- tlvs [BOLT1.TlvRecord 3 ""]
+ hp_extra hp @?= ex
+ encode_hop_payload hp @?= Right "\STX\SOH\SOH\ETX\NUL"
+ , testCase "hop payload: rejects unknown even types" $ do
+ decode_hop_payload "\DC4\NUL" @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 20))
+ decode_hop_payload "\SO\NUL" @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 14))
+ , testCase "hop payload: rejects malformed streams" $ do
+ decode_hop_payload "\EOT\SOH\SOH\STX\SOH\SOH" @?=
+ Left (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing)
+ decode_hop_payload "\STX\SOH\SOH\STX\SOH\SOH" @?=
+ Left (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing)
+ decode_hop_payload "\STX\ENQ\SOH" @?=
+ Left (InvalidTlvStream BOLT1.TlvTruncated)
+ decode_hop_payload "\STX\255\255\255\255\255\255\255\255\255" @?=
+ Left (InvalidTlvStream BOLT1.TlvTruncated)
+ decode_hop_payload "\253\NUL\STX\NUL" @?=
+ Left (InvalidTlvStream BOLT1.TlvNonMinimalBigSize)
+ , testCase "hop payload: rejects malformed values" $ do
+ -- non-minimal tu64 and tu32
+ decode_hop_payload "\STX\STX\NUL\SOH" @?= Left (InvalidTlvValue 2)
+ decode_hop_payload "\EOT\STX\NUL\SOH" @?= Left (InvalidTlvValue 4)
+ -- tu32 longer than 4 bytes
+ decode_hop_payload "\EOT\ENQ\SOH\SOH\SOH\SOH\SOH" @?=
+ Left (InvalidTlvValue 4)
+ -- amount above 21M BTC
+ decode_hop_payload "\STX\b\255\255\255\255\255\255\255\255" @?=
+ Left (InvalidTlvValue 2)
+ -- short_channel_id of 7 bytes
+ decode_hop_payload (BS.pack [6, 7] <> BS.replicate 7 0) @?=
+ Left (InvalidTlvValue 6)
+ -- payment_data with a 31-byte secret
+ decode_hop_payload (BS.pack [8, 31] <> BS.replicate 31 0) @?=
+ Left (InvalidTlvValue 8)
+ -- current_path_key of the wrong length or prefix
+ decode_hop_payload (BS.pack [12, 32] <> BS.replicate 32 2) @?=
+ Left (InvalidTlvValue 12)
+ decode_hop_payload (BS.pack [12, 33, 4] <> BS.replicate 32 2) @?=
+ Left (InvalidTlvValue 12)
+ -- total_amount_msat non-minimal
+ decode_hop_payload "\DC2\STX\NUL\SOH" @?= Left (InvalidTlvValue 18)
+ , testCase "hop payload: extra records may not have known types" $ do
+ ex <- tlvs [BOLT1.TlvRecord 16 "meta"]
+ encode_hop_payload empty_hop_payload { hp_extra = ex } @?=
+ Left ConflictingTlv
+ ex' <- tlvs [BOLT1.TlvRecord 2 "\SOH"]
+ encode_hop_payload (cltv_payload 1) { hp_extra = ex' } @?=
+ Left ConflictingTlv
+ , testCase "hop payload: extra records may have unknown even types" $ do
+ ex <- tlvs [BOLT1.TlvRecord 5482373484 (BS.replicate 32 1)]
+ bs <- right "encode" (encode_hop_payload (cltv_payload 1)
+ { hp_extra = ex })
+ decode_hop_payload bs @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 5482373484))
+
+ , testCase "blinded hop data: all typed fields" $ do
+ s <- scid 0 0 1729
+ pk <- hex_point V.rbDavePathKey
+ m <- msat 1500
+ ex <- tlvs [BOLT1.TlvRecord 561 "\DC24V"]
+ let d = BlindedHopData
+ { bhd_padding = Just (BS.replicate 3 0)
+ , bhd_short_channel_id = Just s
+ , bhd_next_node_id = Just pk
+ , bhd_path_id = Just "id"
+ , bhd_next_path_key_override = Just pk
+ , bhd_payment_relay = Just (PaymentRelay 36 150 10000)
+ , bhd_payment_constraints =
+ Just (PaymentConstraints 748005 m)
+ , bhd_allowed_features = Just (BOLT9.parse "\STX")
+ , bhd_extra = ex
}
-
- case process sessionKey packet BS.empty of
- Left err ->
- assertFailure $
- "expected success, got: " ++ show err
- Right (Receive ri) -> do
- hpAmtToForward (riPayload ri) @?= Just 1000
- hpOutgoingCltv (riPayload ri) @?= Just 500000
- Right (Forward _) ->
- assertFailure "expected Receive, got Forward"
- ]
-
--- | Encrypt 1300 bytes of plaintext hop_payloads into a packet for
--- the node with secret key 'sessionKey' (using its own public key
--- as the ephemeral key), with empty associated data.
-mkPacket :: BS.ByteString -> IO OnionPacket
-mkPacket plain = do
- pub <- demand "derive_pub"
- (Secp256k1.roll32 sessionKey >>= Secp256k1.derive_pub)
- ss <- demand "computeSharedSecret" (computeSharedSecret sessionKey pub)
- stream <- demand "generateStream" $
- generateStream (deriveRho ss) hopPayloadsSize
- let enc = BS.pack (BS.zipWith xor plain stream)
- mac = computeHmac (deriveMu ss) enc BS.empty
- hp <- demand "hopPayloads" (hopPayloads enc)
- hm <- demand "hmac32" (hmac32 mac)
- pure (OnionPacket versionByte (Secp256k1.serialize_point pub) hp hm)
-
--- | Pad (or truncate) plaintext hop_payloads to 1300 bytes.
-pad1300 :: BS.ByteString -> BS.ByteString
-pad1300 bs = BS.take hopPayloadsSize (bs <> BS.replicate hopPayloadsSize 0)
-
-assertInvalidPayload :: Either RejectReason ProcessResult -> Assertion
-assertInvalidPayload r = case r of
- Left (InvalidPayload _) -> pure ()
- Left e -> assertFailure ("expected InvalidPayload, got " ++ show e)
- Right _ -> assertFailure "expected rejection, got success"
-
-testPayloadLength :: TestTree
-testPayloadLength = testGroup "payload_length bounds" [
- testCase "rejects payload_length below 2" $ do
- pkt <- mkPacket (pad1300 (BS.pack [0x01, 0x02]))
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "rejects payload_length past hop_payloads" $ do
- -- payload_length 2000, covered by an odd TLV (type 257, length
- -- 1994) that runs into the zero-extension stream
- let prefix = BS.pack [0xfd, 0x07, 0xd0, 0xfd, 0x01, 0x01,
- 0xfd, 0x07, 0xca]
- pkt <- mkPacket (pad1300 prefix)
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "rejects payload_length of 2^64 - 1" $ do
- pkt <- mkPacket (pad1300 (BS.pack (0xff : replicate 8 0xff)))
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "rejects payload one byte too long" $ do
- -- 3-byte prefix + 1266-byte payload + 32-byte HMAC = 1301
- let tlv = BS.pack [0x01, 0xfd, 0x04, 0xee] <> BS.replicate 1262 0
- pkt <- mkPacket (pad1300 (encodeBigSize 1266 <> tlv))
- assertInvalidPayload (process sessionKey pkt BS.empty)
-
- , testCase "accepts the largest payload that fits" $ do
- -- 3-byte prefix + 1265-byte payload + 32-byte HMAC = 1300
- let val = BS.replicate 1261 0
- tlv = BS.pack [0x01, 0xfd, 0x04, 0xed] <> val
- pkt <- mkPacket (pad1300 (encodeBigSize 1265 <> tlv))
- case process sessionKey pkt BS.empty of
- Right (Receive ri) ->
- hpUnknownTlvs (riPayload ri) @?= [TlvRecord 1 val]
- Right (Forward _) -> assertFailure "expected Receive"
- Left e -> assertFailure ("expected success, got " ++ show e)
- ]
-
--- Error tests -------------------------------------------------------------
-
-errorTests :: TestTree
-errorTests = testGroup "error handling" [
- testErrorConstruction
- , testErrorRoundtrip
- , testMultiHopWrapping
- , testErrorAttribution
- , testFailureMessageParsing
- , testFailureMessageFraming
- ]
-
--- Shared secrets for testing (deterministic)
-testSecret1 :: SharedSecret
-testSecret1 = SharedSecret (BS.replicate 32 0x11)
-
-testSecret2 :: SharedSecret
-testSecret2 = SharedSecret (BS.replicate 32 0x22)
-
-testSecret3 :: SharedSecret
-testSecret3 = SharedSecret (BS.replicate 32 0x33)
-
-testSecret4 :: SharedSecret
-testSecret4 = SharedSecret (BS.replicate 32 0x44)
-
--- Simple failure message for testing (htlc_msat 1000, height 800000)
-testFailure :: FailureMessage
-testFailure = FailureMessage IncorrectOrUnknownPaymentDetails
- (BS.pack [0, 0, 0, 0, 0, 0, 0x03, 0xe8, 0, 0x0c, 0x35, 0x00]) []
-
--- | Minimal well-formed data for a failure code.
-failureData :: FailureCode -> BS.ByteString
-failureData c
- | c `elem` [InvalidOnionVersion, InvalidOnionHmac, InvalidOnionKey] =
- BS.replicate 32 0xab
- | c `elem` [TemporaryChannelFailure, ExpiryTooSoon] = BS.pack [0, 0]
- | c `elem` [AmountBelowMinimum, FeeInsufficient] =
- BS.replicate 8 0x01 <> BS.pack [0, 0]
- | c == IncorrectCltvExpiry = BS.replicate 4 0x01 <> BS.pack [0, 0]
- | c == ChannelDisabled = BS.pack [0, 1, 0, 0]
- | c == IncorrectOrUnknownPaymentDetails = BS.replicate 12 0x01
- | c == FinalIncorrectCltvExpiry = BS.replicate 4 0x01
- | c == FinalIncorrectHtlcAmount = BS.replicate 8 0x01
- | c == InvalidOnionPayload = BS.pack [0x02, 0x00, 0x05]
- | otherwise = BS.empty
-
--- | Read a big-endian u16 at an offset, failing the test if short.
-u16At :: Int -> BS.ByteString -> IO Int
-u16At off bs = case BS.unpack (BS.take 2 (BS.drop off bs)) of
- [hi, lo] -> pure (fromIntegral hi * 256 + fromIntegral lo)
- _ -> assertFailure "u16At: input too short"
-
--- | 'constructError', failing the test on Nothing.
-mkError :: SharedSecret -> FailureMessage -> IO ErrorPacket
-mkError ss fm = demand "constructError" (constructError ss fm)
-
--- | 'wrapError', failing the test on Nothing.
-wrapErr :: SharedSecret -> ErrorPacket -> IO ErrorPacket
-wrapErr ss pkt = demand "wrapError" (wrapError ss pkt)
-
--- | Strip the failing node's obfuscation from a return packet and
--- return (failure_len, pad_len, packet length).
-returnPacketLengths :: SharedSecret -> ErrorPacket -> IO (Int, Int, Int)
-returnPacketLengths ss pkt = do
- ErrorPacket raw <- wrapErr ss pkt
- failureLen <- u16At 32 raw
- padLen <- u16At (34 + failureLen) raw
- pure (failureLen, padLen, BS.length raw)
-
-testErrorConstruction :: TestTree
-testErrorConstruction = testGroup "error packet construction" [
- testCase "short message is padded to 256" $ do
- let failure = FailureMessage TemporaryNodeFailure BS.empty []
- errPacket <- mkError testSecret1 failure
- (fl, pl, size) <- returnPacketLengths testSecret1 errPacket
- fl @?= 2
- fl + pl @?= minErrorPacketSize
- size @?= 32 + 2 + fl + 2 + pl
- , testCase "long message is not truncated or padded" $ do
- let failure = FailureMessage TemporaryNodeFailure BS.empty
- [TlvRecord 1 (BS.replicate 300 0x00)]
- errPacket <- mkError testSecret1 failure
- (fl, pl, size) <- returnPacketLengths testSecret1 errPacket
- fl @?= 2 + 1 + 3 + 300
- pl @?= 0
- size @?= 32 + 2 + fl + 2
- ]
-
-testErrorRoundtrip :: TestTree
-testErrorRoundtrip =
- testCase "construct and unwrap roundtrip" $ do
- errPacket <- mkError testSecret1 testFailure
- let result = unwrapError [testSecret1] errPacket
- case result of
- Attributed idx msg -> do
- idx @?= 0
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
-
-testMultiHopWrapping :: TestTree
-testMultiHopWrapping = testGroup "multi-hop wrapping" [
- testCase "3-hop route, error from hop 2 (final)" $ do
- let secrets =
- [testSecret1, testSecret2, testSecret3]
- err0 <- mkError testSecret3 testFailure
- err1 <- wrapErr testSecret2 err0
- err2 <- wrapErr testSecret1 err1
- let result = unwrapError secrets err2
- case result of
- Attributed idx msg -> do
- idx @?= 2
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
-
- , testCase "4-hop route, error from hop 1" $ do
- let secrets = [testSecret1, testSecret2,
- testSecret3, testSecret4]
- err0 <- mkError testSecret2 testFailure
- err1 <- wrapErr testSecret1 err0
- let result = unwrapError secrets err1
- case result of
- Attributed idx msg -> do
- idx @?= 1
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
-
- , testCase "4-hop route, error from hop 0 (first)" $ do
- let secrets = [testSecret1, testSecret2,
- testSecret3, testSecret4]
- err0 <- mkError testSecret1 testFailure
- let result = unwrapError secrets err0
- case result of
- Attributed idx msg -> do
- idx @?= 0
- fmCode msg @?= IncorrectOrUnknownPaymentDetails
- UnknownOrigin _ ->
- assertFailure
- "Expected Attributed, got UnknownOrigin"
+ bs <- right "encode" (encode_blinded_hop_data d)
+ expected <- unhex $ BS.concat
+ [ "0103000000", "020800000000000006c1", "0421", V.rbDavePathKey
+ , "06026964", "0821", V.rbDavePathKey, "0a080024000000962710"
+ , "0c06000b69e505dc", "0e0102", "fd023103123456" ]
+ bs @?= expected
+ decode_blinded_hop_data bs @?= Right d
+ , testCase "blinded hop data: unknown types" $ do
+ decode_blinded_hop_data "\DLE\NUL" @?=
+ Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 16))
+ d <- right "decode" (decode_blinded_hop_data "\ETX\NUL")
+ ex <- tlvs [BOLT1.TlvRecord 3 ""]
+ bhd_extra d @?= ex
+ , testCase "blinded hop data: rejects malformed values" $ do
+ -- payment_relay shorter than its fixed fields
+ decode_blinded_hop_data "\n\ENQ\NUL\NUL\NUL\NUL\NUL" @?=
+ Left (InvalidTlvValue 10)
+ -- payment_relay with a non-minimal fee_base_msat
+ decode_blinded_hop_data "\n\a\NUL\NUL\NUL\NUL\NUL\NUL\NUL" @?=
+ Left (InvalidTlvValue 10)
+ -- payment_constraints shorter than its fixed fields
+ decode_blinded_hop_data "\f\ETX\NUL\NUL\NUL" @?=
+ Left (InvalidTlvValue 12)
+ -- next_node_id and next_path_key_override of the wrong length
+ decode_blinded_hop_data (BS.pack [4, 2, 2, 2]) @?=
+ Left (InvalidTlvValue 4)
+ decode_blinded_hop_data (BS.pack [8, 2, 2, 2]) @?=
+ Left (InvalidTlvValue 8)
+ -- short_channel_id of 9 bytes
+ decode_blinded_hop_data (BS.pack [2, 9] <> BS.replicate 9 0) @?=
+ Left (InvalidTlvValue 2)
+ , testCase "blinded hop data: extra records may not have known types" $ do
+ ex <- tlvs [BOLT1.TlvRecord 1 ""]
+ encode_blinded_hop_data empty_blinded_hop_data { bhd_extra = ex } @?=
+ Left ConflictingTlv
]
-testErrorAttribution :: TestTree
-testErrorAttribution = testGroup "error attribution" [
- testCase "wrong secrets gives UnknownOrigin" $ do
- err <- mkError testSecret1 testFailure
- let wrongSecrets = [testSecret2, testSecret3]
- result = unwrapError wrongSecrets err
- case result of
- UnknownOrigin _ -> return ()
- Attributed _ _ ->
- assertFailure
- "Expected UnknownOrigin with wrong secrets"
-
- , testCase "empty secrets gives UnknownOrigin" $ do
- err <- mkError testSecret1 testFailure
- let result = unwrapError [] err
- case result of
- UnknownOrigin _ -> return ()
- Attributed _ _ ->
- assertFailure
- "Expected UnknownOrigin with empty secrets"
-
- , testCase "correct attribution with multiple failures" $ do
- let failures =
- [ (TemporaryNodeFailure, testSecret1)
- , (PermanentNodeFailure, testSecret2)
- , (InvalidOnionHmac, testSecret3)
+-- failure messages -----------------------------------------------------------
+
+failure_tests :: TestTree
+failure_tests = testGroup "failure messages" [
+ testCase "encodings and codes of every failure" $ do
+ h <- demand "hash" (onion_hash (BS.replicate 32 0xab))
+ m <- msat 100
+ let hh = BS.concat (replicate 32 "ab")
+ cases =
+ [ (TemporaryNodeFailure, "2002")
+ , (PermanentNodeFailure, "6002")
+ , (RequiredNodeFeatureMissing, "6003")
+ , (InvalidOnionVersion h, "c004" <> hh)
+ , (InvalidOnionHmac h, "c005" <> hh)
+ , (InvalidOnionKey h, "c006" <> hh)
+ , (TemporaryChannelFailure "cu", "100700026375")
+ , (PermanentChannelFailure, "4008")
+ , (RequiredChannelFeatureMissing, "4009")
+ , (UnknownNextPeer, "400a")
+ , (AmountBelowMinimum m "", "100b00000000000000640000")
+ , (FeeInsufficient m "cu", "100c000000000000006400026375")
+ , (IncorrectCltvExpiry 800000 "", "100d000c35000000")
+ , (ExpiryTooSoon "", "100e0000")
+ , ( IncorrectOrUnknownPaymentDetails m 800000
+ , "400f0000000000000064000c3500" )
+ , (FinalIncorrectCltvExpiry 800000, "0012000c3500")
+ , (FinalIncorrectHtlcAmount m, "00130000000000000064")
+ , (ChannelDisabled 0 "", "101400000000")
+ , (ExpiryTooFar, "0015")
+ , (InvalidOnionPayload Nothing, "4016")
+ , (InvalidOnionPayload (Just (2, 7)), "401602 0007")
+ , (MppTimeout, "0017")
+ , (InvalidOnionBlinding h, "c018" <> hh)
+ , (UnknownFailure 0x0042 "data", "004264617461")
]
- mapM_ (\(code, secret) -> do
- let failure = FailureMessage code (failureData code) []
- err <- mkError secret failure
- let result = unwrapError [secret] err
- case result of
- Attributed 0 msg -> fmCode msg @?= code
- _ -> assertFailure $
- "Failed for code: " ++ show code
- ) failures
- ]
-
-testFailureMessageParsing :: TestTree
-testFailureMessageParsing =
- testGroup "failure message parsing" [
- testCase "code with data" $ do
- let failData = BS.pack [0, 0, 0, 0, 0, 0, 0x03, 0xe8, 0, 0]
- failure =
- FailureMessage AmountBelowMinimum failData []
- err <- mkError testSecret1 failure
- let result = unwrapError [testSecret1] err
- case result of
- Attributed 0 msg -> do
- fmCode msg @?= AmountBelowMinimum
- fmData msg @?= failData
- _ -> assertFailure "Expected Attributed"
-
- , testCase "various failure codes roundtrip" $ do
- let codes =
- [ InvalidRealm
- , TemporaryNodeFailure
- , PermanentNodeFailure
- , InvalidOnionHmac
- , TemporaryChannelFailure
- , IncorrectOrUnknownPaymentDetails
- ]
- mapM_ (\code -> do
- let failure = FailureMessage code (failureData code) []
- err <- mkError testSecret1 failure
- let result = unwrapError [testSecret1] err
- case result of
- Attributed 0 msg -> fmCode msg @?= code
- _ -> assertFailure $
- "Failed for code: " ++ show code
- ) codes
- ]
-
-testFailureMessageFraming :: TestTree
-testFailureMessageFraming = testGroup "failure message framing" [
- testCase "no length after the failure code" $ do
- encodeFailureMessage
- (FailureMessage TemporaryNodeFailure BS.empty [])
- @?= BS.pack [0x20, 0x02]
- encodeFailureMessage testFailure
- @?= BS.pack [ 0x40, 0x0f, 0, 0, 0, 0, 0, 0, 0x03, 0xe8
- , 0, 0x0c, 0x35, 0x00 ]
- , testCase "decodes spec-framed messages" $ do
- decodeFailureMessage (BS.pack [0x20, 0x02])
- @?= Just (FailureMessage TemporaryNodeFailure BS.empty [])
- decodeFailureMessage (encodeFailureMessage testFailure)
- @?= Just testFailure
- , testCase "splits data from the TLV stream by code" $ do
- let fm = FailureMessage FinalIncorrectHtlcAmount
- (BS.replicate 8 0x07) [TlvRecord 3 (BS.pack [1, 2])]
- decodeFailureMessage (encodeFailureMessage fm) @?= Just fm
- , testCase "channel_update length is honoured" $ do
- let fm = FailureMessage TemporaryChannelFailure
- (BS.pack [0, 3, 0xaa, 0xbb, 0xcc]) []
- decodeFailureMessage (encodeFailureMessage fm) @?= Just fm
- , testCase "ignores extra bytes" $
- decodeFailureMessage (BS.pack [0x20, 0x02, 0xff])
- @?= Just (FailureMessage TemporaryNodeFailure BS.empty [])
- , testCase "unknown code keeps the remainder as data" $
- decodeFailureMessage (BS.pack [0x20, 0x63, 0x01, 0x02])
- @?= Just (FailureMessage (FailureCode 0x2063)
- (BS.pack [0x01, 0x02]) [])
- , testCase "rejects truncated data" $ do
- decodeFailureMessage (BS.pack [0x40, 0x0f, 0, 0, 0]) @?= Nothing
- decodeFailureMessage (BS.pack [0x10, 0x07, 0, 2, 0xaa]) @?= Nothing
- decodeFailureMessage (BS.pack [0x20]) @?= Nothing
+ forM_ cases $ \(f, hx) -> do
+ bs <- unhex (BS.filter (/= 0x20) hx)
+ let fm = FailureMessage f no_tlvs
+ encode_failure_message fm @?= Right bs
+ decode_failure_message bs @?= Right fm
+ Just (failure_code f) @?= fmap fst (BOLT1.decode_u16 bs)
+ , testCase "flags" $ do
+ h <- demand "hash" (onion_hash (BS.replicate 32 0))
+ let flags f = (is_badonion f, is_perm f, is_node f, is_update f)
+ flags TemporaryNodeFailure @?= (False, False, True, False)
+ flags PermanentNodeFailure @?= (False, True, True, False)
+ flags (InvalidOnionBlinding h) @?= (True, True, False, False)
+ flags (ExpiryTooSoon "") @?= (False, False, False, True)
+ flags MppTimeout @?= (False, False, False, False)
+ flags (UnknownFailure 0xf000 "") @?= (True, True, True, True)
+ , testCase "spec example: incorrect_or_unknown_payment_details" $ do
+ bs <- unhex "400f0000000000000064000c3500"
+ m <- msat 100
+ decode_failure_message bs @?= Right
+ (FailureMessage (IncorrectOrUnknownPaymentDetails m 800000) no_tlvs)
+ , testCase "a trailing TLV stream is kept" $ do
+ ex <- tlvs [BOLT1.TlvRecord 34001 (BS.replicate 3 0x80)]
+ let fm = FailureMessage TemporaryNodeFailure ex
+ bs <- right "encode" (encode_failure_message fm)
+ bs @?= "\x20\x02\xfd\x84\xd1\x03\x80\x80\x80"
+ decode_failure_message bs @?= Right fm
+ , testCase "other trailing bytes are ignored" $ do
+ let ignored f bs = decode_failure_message bs @?=
+ Right (FailureMessage f no_tlvs)
+ ignored TemporaryNodeFailure "\x20\x02\xff"
+ -- an even type: not a valid stream without known types
+ ignored TemporaryNodeFailure "\x20\x02\x02\x00"
+ ignored (FinalIncorrectCltvExpiry 1) "\NUL\DC2\NUL\NUL\NUL\SOH\SOH"
+ , testCase "truncated data is rejected" $ do
+ decode_failure_message "" @?= Left InvalidLength
+ decode_failure_message "\x20" @?= Left InvalidLength
+ decode_failure_message "\xc0\x05\x00" @?=
+ Left (InvalidFailureData 0xc005)
+ decode_failure_message "\x10\x07\x00\x02\x00" @?=
+ Left (InvalidFailureData 0x1007)
+ decode_failure_message "\x40\x0f\x00\x00\x00\x00\x00\x00\x00\x64" @?=
+ Left (InvalidFailureData 0x400f)
+ decode_failure_message "\x00\x13\x00" @?=
+ Left (InvalidFailureData 0x0013)
+ decode_failure_message "\x10\x14\x00\x00\x00" @?=
+ Left (InvalidFailureData 0x1014)
+ , testCase "amounts above 21M BTC are rejected" $
+ decode_failure_message "\x00\x13\xff\xff\xff\xff\xff\xff\xff\xff" @?=
+ Left (InvalidFailureData 0x0013)
+ , testCase "unknown codes keep their data" $
+ decode_failure_message "\x12\x34\x01\x00" @?=
+ Right (FailureMessage (UnknownFailure 0x1234 "\x01\x00") no_tlvs)
+ , testCase "channel_update longer than 65535 bytes" $
+ encode_failure_message
+ (FailureMessage (ExpiryTooSoon (BS.replicate 65536 0)) no_tlvs)
+ @?= Left FieldTooLong
]
--- Blinding tests -----------------------------------------------------------
-
--- Test data setup
-
-testSeed :: BS.ByteString
-testSeed = BS.pack [1..32]
-
-makeSecKey :: Word8 -> BS.ByteString
-makeSecKey seed = BS.pack $ replicate 31 0x00 ++ [seed]
-
-makePubKey :: Word8 -> Maybe Secp256k1.Projective
-makePubKey seed = do
- sk <- Secp256k1.roll32 (makeSecKey seed)
- Secp256k1.derive_pub sk
-
-testNodeSecKey1, testNodeSecKey2,
- testNodeSecKey3 :: BS.ByteString
-testNodeSecKey1 = makeSecKey 0x11
-testNodeSecKey2 = makeSecKey 0x22
-testNodeSecKey3 = makeSecKey 0x33
-
-testNodePubKey1, testNodePubKey2,
- testNodePubKey3 :: Secp256k1.Projective
-testNodePubKey1 = case makePubKey 0x11 of
- Just pk -> pk
- Nothing -> error "testNodePubKey1: invalid key"
-testNodePubKey2 = case makePubKey 0x22 of
- Just pk -> pk
- Nothing -> error "testNodePubKey2: invalid key"
-testNodePubKey3 = case makePubKey 0x33 of
- Just pk -> pk
- Nothing -> error "testNodePubKey3: invalid key"
-
-testSharedSecretBS :: SharedSecret
-testSharedSecretBS = SharedSecret (BS.pack [0x42..0x61])
-
-emptyHopData :: BlindedHopData
-emptyHopData = BlindedHopData
- Nothing Nothing Nothing Nothing
- Nothing Nothing Nothing Nothing
-
-sampleHopData :: BlindedHopData
-sampleHopData = BlindedHopData
- { bhdPadding = Nothing
- , bhdShortChannelId = Just (mkScid 700000 1234 0)
- , bhdNextNodeId = Nothing
- , bhdPathId = Just (BS.pack [0x42, 0x42])
- , bhdNextPathKeyOverride = Nothing
- , bhdPaymentRelay = Just (PaymentRelay 40 1000 500)
- , bhdPaymentConstraints =
- Just (PaymentConstraints 144 1000000)
- , bhdAllowedFeatures = Nothing
- }
-
-hopDataWithNextNode :: BlindedHopData
-hopDataWithNextNode = emptyHopData
- { bhdNextNodeId =
- Just (Secp256k1.serialize_point testNodePubKey2)
- }
-
--- 1. Key Derivation Tests -------------------------------------------------
-
-blindingKeyDerivationTests :: TestTree
-blindingKeyDerivationTests = testGroup "key derivation" [
- testCase "deriveBlindingRho produces 32 bytes" $ do
- let DerivedKey rho =
- deriveBlindingRho testSharedSecretBS
- BS.length rho @?= 32
-
- , testCase "deriveBlindingRho is deterministic" $ do
- let rho1 = deriveBlindingRho testSharedSecretBS
- rho2 = deriveBlindingRho testSharedSecretBS
- rho1 @?= rho2
-
- , testCase "deriveBlindingRho differs for diff secrets" $ do
- let ss1 = SharedSecret (BS.replicate 32 0x00)
- ss2 = SharedSecret (BS.replicate 32 0x01)
- rho1 = deriveBlindingRho ss1
- rho2 = deriveBlindingRho ss2
- assertBool "rho values should differ" (rho1 /= rho2)
-
- , testCase "deriveBlindedNodeId produces 33 bytes" $ do
- case deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1 of
- Nothing ->
- assertFailure
- "deriveBlindedNodeId returned Nothing"
- Just blindedId -> BS.length blindedId @?= 33
-
- , testCase "deriveBlindedNodeId is deterministic" $ do
- let result1 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1
- result2 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1
- result1 @?= result2
-
- , testCase "deriveBlindedNodeId differs for diff nodes" $ do
- let result1 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey1
- result2 = deriveBlindedNodeId
- testSharedSecretBS testNodePubKey2
- assertBool "blinded node IDs should differ"
- (result1 /= result2)
- ]
-
--- 2. Ephemeral Key Iteration Tests ----------------------------------------
-
--- | Derive the public key for testSeed
-testSeedPubKey :: Secp256k1.Projective
-testSeedPubKey = case Secp256k1.roll32 testSeed of
- Nothing -> error "testSeedPubKey: invalid seed"
- Just sk -> case Secp256k1.derive_pub sk of
- Nothing -> error "testSeedPubKey: invalid key"
- Just pk -> pk
-
-blindingEphemeralKeyTests :: TestTree
-blindingEphemeralKeyTests =
- testGroup "ephemeral key iteration" [
- testCase "nextEphemeral produces valid keys" $ do
- case nextEphemeral
- testSeed testSeedPubKey testSharedSecretBS of
- Nothing ->
- assertFailure "nextEphemeral returned Nothing"
- Just (newSecKey, newPubKey) -> do
- BS.length newSecKey @?= 32
- let serialized =
- Secp256k1.serialize_point newPubKey
- BS.length serialized @?= 33
-
- , testCase "nextEphemeral: sec key derives pub key" $ do
- case nextEphemeral
- testSeed testSeedPubKey testSharedSecretBS of
- Nothing ->
- assertFailure "nextEphemeral returned Nothing"
- Just (newSecKey, newPubKey) -> do
- sk <- demand "roll32" $
- Secp256k1.roll32 newSecKey
- derivedPub <- demand "derive_pub" $
- Secp256k1.derive_pub sk
- derivedPub @?= newPubKey
-
- , testCase "nextEphemeral is deterministic" $ do
- let result1 = nextEphemeral
- testSeed testSeedPubKey
- testSharedSecretBS
- result2 = nextEphemeral
- testSeed testSeedPubKey
- testSharedSecretBS
- result1 @?= result2
-
- , testCase "nextEphemeral differs for diff secrets" $ do
- let ss1 = SharedSecret (BS.replicate 32 0xAA)
- ss2 = SharedSecret (BS.replicate 32 0xBB)
- result1 = nextEphemeral
- testSeed testSeedPubKey ss1
- result2 = nextEphemeral
- testSeed testSeedPubKey ss2
- assertBool "results should differ"
- (result1 /= result2)
-
- , testCase "nextEphemeral rejects a secret not of 32 bytes" $ do
- nextEphemeral (BS.singleton 0x07) testSeedPubKey testSharedSecretBS
- @?= Nothing
- nextEphemeral (BS.cons 0x00 testSeed) testSeedPubKey
- testSharedSecretBS @?= Nothing
- ]
-
--- 3. TLV Encoding/Decoding Tests -----------------------------------------
-
-blindingTlvTests :: TestTree
-blindingTlvTests = testGroup "TLV encoding/decoding" [
- testCase "roundtrip: empty hop data" $ do
- let encoded = encodeBlindedHopData emptyHopData
- decoded = decodeBlindedHopData encoded
- decoded @?= Just emptyHopData
-
- , testCase "roundtrip: sample hop data" $ do
- let encoded = encodeBlindedHopData sampleHopData
- decoded = decodeBlindedHopData encoded
- decoded @?= Just sampleHopData
-
- , testCase "roundtrip: hop data with next node ID" $ do
- let encoded = encodeBlindedHopData hopDataWithNextNode
- decoded = decodeBlindedHopData encoded
- decoded @?= Just hopDataWithNextNode
-
- , testCase "roundtrip: hop data with padding" $ do
- let hd = emptyHopData
- { bhdPadding = Just (BS.replicate 16 0x00) }
- encoded = encodeBlindedHopData hd
- decoded = decodeBlindedHopData encoded
- decoded @?= Just hd
-
- , testCase "PaymentRelay encoding/decoding" $ do
- let relay = PaymentRelay 40 1000 500
- hd = emptyHopData
- { bhdPaymentRelay = Just relay }
- encoded = encodeBlindedHopData hd
- decoded = decodeBlindedHopData encoded
- case decoded of
- Nothing ->
- assertFailure
- "decodeBlindedHopData returned Nothing"
- Just d -> bhdPaymentRelay d @?= Just relay
-
- , testCase "PaymentConstraints encoding/decoding" $ do
- let constraints = PaymentConstraints 144 1000000
- hd = emptyHopData
- { bhdPaymentConstraints = Just constraints }
- encoded = encodeBlindedHopData hd
- decoded = decodeBlindedHopData encoded
- case decoded of
- Nothing ->
- assertFailure
- "decodeBlindedHopData returned Nothing"
- Just d ->
- bhdPaymentConstraints d @?= Just constraints
-
- , testCase "decode empty bytestring" $ do
- let decoded = decodeBlindedHopData BS.empty
- decoded @?= Just emptyHopData
- ]
-
--- 4. Encryption/Decryption Tests ------------------------------------------
-
-blindingEncryptionTests :: TestTree
-blindingEncryptionTests =
- testGroup "encryption/decryption" [
- testCase "roundtrip: encrypt then decrypt" $ do
- let rho = deriveBlindingRho testSharedSecretBS
- encrypted <- demand "encryptHopData" $
- encryptHopData rho sampleHopData
- decryptHopData rho encrypted @?= Just sampleHopData
-
- , testCase "roundtrip: empty hop data" $ do
- let rho = deriveBlindingRho testSharedSecretBS
- encrypted <- demand "encryptHopData" $
- encryptHopData rho emptyHopData
- decryptHopData rho encrypted @?= Just emptyHopData
-
- , testCase "decryption with wrong key fails" $ do
- let rho1 = deriveBlindingRho testSharedSecretBS
- rho2 = deriveBlindingRho
- (SharedSecret (BS.replicate 32 0xFF))
- encrypted <- demand "encryptHopData" $
- encryptHopData rho1 sampleHopData
- assertBool "decryption should fail or produce garbage"
- (decryptHopData rho2 encrypted /= Just sampleHopData)
-
- , testCase "encrypt is deterministic" $ do
- let rho = deriveBlindingRho testSharedSecretBS
- encrypted1 = encryptHopData rho sampleHopData
- encrypted2 = encryptHopData rho sampleHopData
- encrypted1 @?= encrypted2
-
- , testCase "encrypt fails on a key that is not 32 bytes" $
- encryptHopData (DerivedKey "short") sampleHopData @?= Nothing
+-- construct ------------------------------------------------------------------
+
+construct_tests :: TestTree
+construct_tests = testGroup "construct" [
+ testCase "empty route" $ do
+ sk <- key 0x41
+ assertConstructError EmptyRoute (construct sk [] ad)
+ , testCase "more than 20 hops" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ let hop = Hop (public_key node) (cltv_payload 1)
+ assertConstructError TooManyHops (construct sk (replicate 21 hop) ad)
+ case construct sk (replicate 20 hop) ad of
+ Right (_, sss) -> length sss @?= 20
+ Left e -> assertFailure (show e)
+ , testCase "invalid hop public key" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ bad <- off_curve
+ let good = Hop (public_key node) (cltv_payload 1)
+ assertConstructError (InvalidHopPubKey 1)
+ (construct sk [good, Hop bad (cltv_payload 1), good] ad)
+ , testCase "payloads under 2 bytes" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ let good = Hop (public_key node) (cltv_payload 1)
+ assertConstructError (InvalidHopPayload 1)
+ (construct sk [good, Hop (public_key node) empty_hop_payload] ad)
+ , testCase "unencodable payload" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ ex <- tlvs [BOLT1.TlvRecord 4 "\SOH"]
+ let bad = Hop (public_key node) empty_hop_payload { hp_extra = ex }
+ assertConstructError (InvalidHopPayload 0) (construct sk [bad] ad)
+ , testCase "payloads over 1300 bytes" $ do
+ sk <- key 0x41
+ node <- key 0x42
+ -- a 1265-byte payload exactly fills hop_payloads
+ ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 1261 0)]
+ let full = Hop (public_key node) empty_hop_payload { hp_extra = ex }
+ case construct sk [full] ad of
+ Right _ -> pure ()
+ Left e -> assertFailure (show e)
+ ex' <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 1262 0)]
+ let over = Hop (public_key node) empty_hop_payload { hp_extra = ex' }
+ assertConstructError (PayloadsTooLarge 1301) (construct sk [over] ad)
+ let hops = replicate 2 (Hop (public_key node) (cltv_payload 1))
+ assertConstructError (PayloadsTooLarge 1372)
+ (construct sk (full : hops) ad)
]
-
--- 5. createBlindedPath Tests ----------------------------------------------
-
-blindingCreatePathTests :: TestTree
-blindingCreatePathTests = testGroup "createBlindedPath" [
- testCase "create path with 2 hops" $ do
- let nodes = [(testNodePubKey1, emptyHopData),
- (testNodePubKey2, sampleHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> do
- length (bpBlindedHops path) @?= 2
- let serialized =
- Secp256k1.serialize_point
- (bpBlindingKey path)
- BS.length serialized @?= 33
-
- , testCase "create path with 3 hops" $ do
- let nodes = [ (testNodePubKey1, emptyHopData)
- , (testNodePubKey2, hopDataWithNextNode)
- , (testNodePubKey3, sampleHopData)
- ]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path ->
- length (bpBlindedHops path) @?= 3
-
- , testCase "all blinded node IDs are 33 bytes" $ do
- let nodes = [ (testNodePubKey1, emptyHopData)
- , (testNodePubKey2, emptyHopData)
- , (testNodePubKey3, emptyHopData)
- ]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> do
- let blindedIds =
- map bhBlindedNodeId (bpBlindedHops path)
- mapM_ (\bid -> BS.length bid @?= 33) blindedIds
-
- , testCase "empty path returns EmptyPath error" $ do
- case createBlindedPath testSeed [] of
- Left EmptyPath -> return ()
- Left err ->
- assertFailure $
- "Expected EmptyPath, got: " ++ show err
- Right _ ->
- assertFailure "Expected error, got success"
-
- , testCase "invalid seed returns InvalidSeed error" $ do
- let invalidSeed = BS.pack [1..16]
- nodes = [(testNodePubKey1, emptyHopData)]
- case createBlindedPath invalidSeed nodes of
- Left InvalidSeed -> return ()
- Left err ->
- assertFailure $
- "Expected InvalidSeed, got: " ++ show err
- Right _ ->
- assertFailure "Expected error, got success"
-
- , testCase "createBlindedPath is deterministic" $ do
- let nodes = [(testNodePubKey1, emptyHopData),
- (testNodePubKey2, sampleHopData)]
- result1 = createBlindedPath testSeed nodes
- result2 = createBlindedPath testSeed nodes
- result1 @?= result2
+ where
+ assertConstructError e r = case r of
+ Left e' -> e' @?= e
+ Right _ -> assertFailure ("expected " ++ show e)
+
+-- process --------------------------------------------------------------------
+
+process_tests :: TestTree
+process_tests = testGroup "process" [
+ testCase "rejects versions other than 0" $ do
+ (node, pkt) <- simple_onion
+ expect_process (InvalidVersion 1)
+ (process node pkt { onion_version = 1 } ad Nothing)
+ , testCase "rejects a public key not on the curve" $ do
+ (node, pkt) <- simple_onion
+ bad <- off_curve
+ expect_process InvalidPublicKey
+ (process node pkt { onion_public_key = bad } ad Nothing)
+ , testCase "rejects a wrong HMAC" $ do
+ (node, pkt) <- simple_onion
+ flipped <- demand "flip" $
+ case BS.uncons (un_hop_payloads (onion_hop_payloads pkt)) of
+ Just (h, t) -> hop_payloads (BS.cons (h `xor` 1) t)
+ Nothing -> Nothing
+ expect_process HmacMismatch
+ (process node pkt { onion_hop_payloads = flipped } ad Nothing)
+ mac <- demand "mac" (hmac32 (BS.replicate 32 0))
+ expect_process HmacMismatch
+ (process node pkt { onion_hmac = mac } ad Nothing)
+ , testCase "rejects other associated data" $ do
+ (node, pkt) <- simple_onion
+ expect_process HmacMismatch
+ (process node pkt (BS.replicate 32 0) Nothing)
+ , testCase "rejects other node keys" $ do
+ (_, pkt) <- simple_onion
+ other <- key 0x44
+ expect_process HmacMismatch (process other pkt ad Nothing)
+ , testCase "rejects payload lengths 0 and 1" $ do
+ node <- key 0x42
+ p0 <- raw_onion node (pad1300 "\NUL")
+ expect_process InvalidPayloadLength (process node p0 ad Nothing)
+ p1 <- raw_onion node (pad1300 "\SOH\SOH")
+ expect_process InvalidPayloadLength (process node p1 ad Nothing)
+ , testCase "rejects a malformed length prefix" $ do
+ node <- key 0x42
+ p <- raw_onion node (pad1300 "\253\NUL\DLE")
+ expect_process InvalidPayloadLength (process node p ad Nothing)
+ , testCase "rejects payloads past the end of hop_payloads" $ do
+ node <- key 0x42
+ -- 3-byte prefix, 1265-byte payload and 32-byte HMAC fill it
+ let rec n = BS.concat [ "\SOH\253", BOLT1.encode_u16 n
+ , BS.replicate (fromIntegral n) 0 ]
+ ok <- raw_onion node (pad1300 ("\253\EOT\241" <> rec 1261))
+ _ <- receive (process node ok ad Nothing)
+ over <- raw_onion node (pad1300 ("\253\EOT\242" <> rec 1262))
+ expect_process InvalidPayloadLength (process node over ad Nothing)
+ -- a length reaching into the zero-extended stream
+ far <- raw_onion node (pad1300 ("\253\a\208" <> rec 1261))
+ expect_process InvalidPayloadLength (process node far ad Nothing)
+ huge <- raw_onion node
+ (pad1300 ("\255\128\NUL\NUL\NUL\NUL\NUL\NUL\NUL" <> rec 1))
+ expect_process InvalidPayloadLength (process node huge ad Nothing)
+ , testCase "rejects malformed payloads" $ do
+ node <- key 0x42
+ let bad pl = raw_onion node
+ (pad1300 (BOLT1.encode_bigsize (fromIntegral (BS.length pl))
+ <> pl))
+ p0 <- bad "\EOT\SOH\SOH\STX\SOH\SOH"
+ expect_process
+ (InvalidPayload (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing))
+ (process node p0 ad Nothing)
+ p1 <- bad "\DC4\NUL"
+ expect_process
+ (InvalidPayload (InvalidTlvStream (BOLT1.TlvUnknownEvenType 20)))
+ (process node p1 ad Nothing)
+ p2 <- bad "\STX\STX\NUL\SOH"
+ expect_process (InvalidPayload (InvalidTlvValue 2))
+ (process node p2 ad Nothing)
+ , testCase "the final hop receives" $ do
+ (node, pkt) <- simple_onion
+ info <- receive (process node pkt ad Nothing)
+ rcv_payload info @?= cltv_payload 144
+ rcv_blinded info @?= Nothing
+ , testCase "forwarded packets are well formed" $ do
+ sk <- key 0x41
+ a <- key 0x42
+ b <- key 0x43
+ (pkt, sss) <- right "construct" $ construct sk
+ [Hop (public_key a) (cltv_payload 1), Hop (public_key b)
+ (cltv_payload 2)] ad
+ fwd <- forward (process a pkt ad Nothing)
+ let next = fwd_next_packet fwd
+ onion_version next @?= 0
+ decode_onion_packet (encode_onion_packet next) @?= Right next
+ Just (fwd_shared_secret fwd) @?= safe_head sss
+ rcv <- receive (process b next ad Nothing)
+ rcv_payload rcv @?= cltv_payload 2
+ , testCase "path keys without encrypted_recipient_data" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ seed <- key 0x01
+ path <- right "path" $
+ create_blinded_path seed [(public_key alice, empty_blinded_hop_data)]
+ bid <- blinded_id path 0
+ let pk = bp_first_path_key path
+ -- a path_key, onion encrypted to the blinded id
+ (p0, _) <- right "construct" $
+ construct sk [Hop bid (cltv_payload 1)] ad
+ expect_process UnexpectedPathKey (process alice p0 ad (Just pk))
+ -- a current_path_key
+ let pl = (cltv_payload 1) { hp_current_path_key = Just pk }
+ (p1, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process UnexpectedPathKey (process alice p1 ad Nothing)
+ , testCase "both a path_key and a current_path_key" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ seed <- key 0x01
+ path <- right "path" $
+ create_blinded_path seed [(public_key alice, empty_blinded_hop_data)]
+ bid <- blinded_id path 0
+ enc <- blinded_data path 0
+ let pk = bp_first_path_key path
+ pl = empty_hop_payload { hp_encrypted_data = Just enc
+ , hp_current_path_key = Just pk }
+ (pkt, _) <- right "construct" $ construct sk [Hop bid pl] ad
+ expect_process UnexpectedPathKey (process alice pkt ad (Just pk))
+ , testCase "encrypted_recipient_data without a path key" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ let pl = empty_hop_payload { hp_encrypted_data = Just "data" }
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process MissingPathKey (process alice pkt ad Nothing)
+ , testCase "undecryptable encrypted_recipient_data" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ pk <- hex_point V.rbBobPathKey
+ let pl = empty_hop_payload { hp_encrypted_data = Just
+ (BS.replicate 40 0)
+ , hp_current_path_key = Just pk }
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process InvalidRecipientData (process alice pkt ad Nothing)
+ , testCase "invalid path keys" $ do
+ sk <- key 0x41
+ alice <- key 0x42
+ bad <- off_curve
+ let pl = empty_hop_payload { hp_encrypted_data = Just "data"
+ , hp_current_path_key = Just bad }
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key alice) pl] ad
+ expect_process InvalidPathKey (process alice pkt ad Nothing)
+ (pkt', _) <- right "construct" $
+ construct sk [Hop (public_key alice) (cltv_payload 1)] ad
+ expect_process InvalidPathKey (process alice pkt' ad (Just bad))
]
-
--- 6. processBlindedHop Tests ----------------------------------------------
-
-blindingProcessHopTests :: TestTree
-blindingProcessHopTests =
- testGroup "processBlindedHop" [
- testCase "process first hop decrypts correctly" $ do
- let nodes = [(testNodePubKey1, sampleHopData),
- (testNodePubKey2, emptyHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey (bhEncryptedData firstHop) of
- Left err -> assertFailure $
- "processBlindedHop failed: " ++ show err
- Right (decryptedData, _) ->
- decryptedData @?= sampleHopData
- [] -> assertFailure "expected non-empty hops"
-
- , testCase "process hop chain correctly" $ do
- let nodes =
- [ (testNodePubKey1, emptyHopData)
- , (testNodePubKey2, sampleHopData)
- , (testNodePubKey3, hopDataWithNextNode)
- ]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- [hop1, hop2, hop3] -> do
- let pathKey1 = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey1 (bhEncryptedData hop1) of
- Left err -> assertFailure $
- "processBlindedHop hop1 failed: "
- ++ show err
- Right (data1, pathKey2) -> do
- data1 @?= emptyHopData
- case processBlindedHop testNodeSecKey2
- pathKey2
- (bhEncryptedData hop2) of
- Left err -> assertFailure $
- "processBlindedHop hop2 failed: "
- ++ show err
- Right (data2, pathKey3) -> do
- data2 @?= sampleHopData
- case processBlindedHop
- testNodeSecKey3 pathKey3
- (bhEncryptedData hop3) of
- Left err -> assertFailure $
- "processBlindedHop hop3: "
- ++ show err
- Right (data3, _) ->
- data3 @?= hopDataWithNextNode
- _ -> assertFailure "expected 3 blinded hops"
-
- , testCase "process hop with wrong node key fails" $ do
- let nodes = [(testNodePubKey1, sampleHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey2
- pathKey (bhEncryptedData firstHop) of
- Left _ -> return ()
- Right (decryptedData, _) ->
- assertBool "should not decrypt correctly"
- (decryptedData /= sampleHopData)
- [] -> assertFailure "expected non-empty hops"
-
- , testCase "next path key is valid point" $ do
- let nodes = [(testNodePubKey1, emptyHopData),
- (testNodePubKey2, emptyHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey (bhEncryptedData firstHop) of
- Left err -> assertFailure $
- "processBlindedHop failed: " ++ show err
- Right (_, nextPK) -> do
- let serialized =
- Secp256k1.serialize_point nextPK
- BS.length serialized @?= 33
- [] -> assertFailure "expected non-empty hops"
-
- , testCase "next_path_key_override is used" $ do
- let overrideKey =
- Secp256k1.serialize_point testNodePubKey3
- hopDataWithOverride' = emptyHopData
- { bhdNextPathKeyOverride = Just overrideKey }
- nodes = [(testNodePubKey1, hopDataWithOverride'),
- (testNodePubKey2, emptyHopData)]
- case createBlindedPath testSeed nodes of
- Left err ->
- assertFailure $
- "createBlindedPath failed: " ++ show err
- Right path -> case bpBlindedHops path of
- firstHop : _ -> do
- let pathKey = bpBlindingKey path
- case processBlindedHop testNodeSecKey1
- pathKey (bhEncryptedData firstHop) of
- Left err -> assertFailure $
- "processBlindedHop failed: " ++ show err
- Right (decryptedData, nextPK) -> do
- bhdNextPathKeyOverride decryptedData
- @?= Just overrideKey
- nextPK @?= testNodePubKey3
- [] -> assertFailure "expected non-empty hops"
+ where
+ simple_onion = do
+ sk <- key 0x41
+ node <- key 0x42
+ (pkt, _) <- right "construct" $
+ construct sk [Hop (public_key node) (cltv_payload 144)] ad
+ pure (node, pkt)
+
+three :: [a] -> IO (a, a, a)
+three xs = case xs of
+ [a, b, c] -> pure (a, b, c)
+ _ -> assertFailure "expected three elements"
+
+safe_head :: [a] -> Maybe a
+safe_head xs = case xs of
+ x : _ -> Just x
+ [] -> Nothing
+
+safe_index :: [a] -> Int -> Maybe a
+safe_index xs i = safe_head (drop i xs)
+
+blinded_id :: BlindedPath -> Int -> IO BOLT1.Point
+blinded_id p i =
+ demand "blinded hop" (bh_blinded_node_id <$> safe_index (bp_hops p) i)
+
+blinded_data :: BlindedPath -> Int -> IO BS.ByteString
+blinded_data p i =
+ demand "blinded hop" (bh_encrypted_data <$> safe_index (bp_hops p) i)
+
+-- route blinding -------------------------------------------------------------
+
+blinding_tests :: TestTree
+blinding_tests = testGroup "route blinding" [
+ testCase "empty path" $ do
+ seed <- key 0x01
+ create_blinded_path seed [] @?= Left EmptyPath
+ , testCase "invalid node id" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ bad <- off_curve
+ create_blinded_path seed
+ [ (public_key alice, empty_blinded_hop_data)
+ , (bad, empty_blinded_hop_data) ]
+ @?= Left (InvalidNodeId 1)
+ , testCase "unencodable hop data" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ ex <- tlvs [BOLT1.TlvRecord 6 "id"]
+ create_blinded_path seed
+ [(public_key alice, empty_blinded_hop_data { bhd_extra = ex })]
+ @?= Left (InvalidHopData 0 ConflictingTlv)
+ , testCase "decrypt_recipient_data rejects bad input" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ bob <- key 0x43
+ path <- right "path" $
+ create_blinded_path seed [(public_key alice, empty_blinded_hop_data)]
+ enc <- blinded_data path 0
+ let pk = bp_first_path_key path
+ _ <- right "decrypt" (decrypt_recipient_data alice pk enc)
+ decrypt_recipient_data bob pk enc @?= Left InvalidRecipientData
+ decrypt_recipient_data alice pk (BS.take 15 enc) @?=
+ Left InvalidRecipientData
+ decrypt_recipient_data alice pk (BS.drop 1 enc) @?=
+ Left InvalidRecipientData
+ bad <- off_curve
+ decrypt_recipient_data alice bad enc @?= Left InvalidPathKey
+ , testCase "unknown even types in encrypted data are rejected" $ do
+ seed <- key 0x01
+ alice <- key 0x42
+ ex <- tlvs [BOLT1.TlvRecord 20 ""]
+ path <- right "path" $ create_blinded_path seed
+ [(public_key alice, empty_blinded_hop_data { bhd_extra = ex })]
+ enc <- blinded_data path 0
+ decrypt_recipient_data alice (bp_first_path_key path) enc @?=
+ Left InvalidRecipientData
+ , testCase "a payment through a blinded route" $ do
+ -- Carol creates a route Alice -> Bob -> Carol; Dave pays through it,
+ -- reaching Alice unblinded with current_path_key.
+ seed <- key 0x01
+ session <- key 0x02
+ alice <- key 0x42
+ bob <- key 0x43
+ carol <- key 0x44
+ s1 <- scid 1 1 1
+ s2 <- scid 2 2 2
+ m <- msat 1
+ let relay = Just (PaymentRelay 40 100 1000)
+ cons = Just (PaymentConstraints 900000 m)
+ alice_data = empty_blinded_hop_data
+ { bhd_short_channel_id = Just s1, bhd_payment_relay = relay
+ , bhd_payment_constraints = cons }
+ bob_data = empty_blinded_hop_data
+ { bhd_short_channel_id = Just s2, bhd_payment_relay = relay
+ , bhd_payment_constraints = cons }
+ carol_data = empty_blinded_hop_data
+ { bhd_path_id = Just "invoice" }
+ path <- right "path" $ create_blinded_path seed
+ [ (public_key alice, alice_data), (public_key bob, bob_data)
+ , (public_key carol, carol_data) ]
+ bp_first_node_id path @?= public_key alice
+ bp_first_path_key path @?= public_key seed
+ (e0, e1, e2) <- three =<< mapM (blinded_data path) [0, 1, 2]
+ (_, b1, b2) <- three =<< mapM (blinded_id path) [0, 1, 2]
+ amt <- msat 5000
+ let intro = empty_hop_payload
+ { hp_encrypted_data = Just e0
+ , hp_current_path_key = Just (bp_first_path_key path) }
+ final = empty_hop_payload
+ { hp_encrypted_data = Just e2, hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just 800000
+ , hp_total_amount_msat = Just amt }
+ route = [ Hop (public_key alice) intro
+ , Hop b1 empty_hop_payload { hp_encrypted_data = Just e1 }
+ , Hop b2 final ]
+ (pkt, sss) <- right "construct" (construct session route ad)
+ fa <- forward (process alice pkt ad Nothing)
+ ia <- demand "alice blinded" (fwd_blinded fa)
+ bi_data ia @?= alice_data
+ fb <- forward (process bob (fwd_next_packet fa) ad
+ (Just (bi_next_path_key ia)))
+ ib <- demand "bob blinded" (fwd_blinded fb)
+ bi_data ib @?= bob_data
+ rc <- receive (process carol (fwd_next_packet fb) ad
+ (Just (bi_next_path_key ib)))
+ ic <- demand "carol blinded" (rcv_blinded rc)
+ bi_data ic @?= carol_data
+ rcv_payload rc @?= final
+ [fwd_shared_secret fa, fwd_shared_secret fb, rcv_shared_secret rc]
+ @?= sss
+ -- the wrong path key yields the wrong blinded key
+ expect_process HmacMismatch
+ (process bob (fwd_next_packet fa) ad
+ (Just (bp_first_path_key path)))
]
--- Property tests ------------------------------------------------------------
-
-propertyTests :: TestTree
-propertyTests = testGroup "invariants" [
- testProperty "ShortChannelId encode/decode roundtrip"
- propScidRoundtrip
- , testProperty "HopPayload encode/decode roundtrip"
- propHopPayloadRoundtrip
- , testProperty "fixed-size newtypes validate length"
- propNewtypeValidation
- , testProperty "FailureMessage encode/decode roundtrip"
- propFailureMessageRoundtrip
+-- returning errors -----------------------------------------------------------
+
+error_tests :: TestTree
+error_tests = testGroup "returning errors" [
+ testCase "padding brings failure_len + pad_len to 256" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error ss fm)
+ let ErrorPacket raw = wrap_error ss pkt
+ BS.length raw @?= 32 + 2 + 2 + 2 + 254
+ BS.take 4 (BS.drop 32 raw) @?= "\NUL\STX\x20\x02"
+ BS.take 2 (BS.drop 36 raw) @?= "\NUL\254"
+ , testCase "long failure messages are not padded" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 300 0)]
+ let fm = FailureMessage TemporaryNodeFailure ex
+ ErrorPacket raw <- wrap_error ss <$>
+ right "construct_error" (construct_error ss fm)
+ BS.length raw @?= 32 + 2 + 306 + 2
+ BS.drop (32 + 2 + 306) raw @?= "\NUL\NUL"
+ , testCase "failure messages over 65535 bytes" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 65535 0)]
+ construct_error ss (FailureMessage TemporaryNodeFailure ex)
+ @?= Left FieldTooLong
+ , testCase "attributes the failing hop" $ do
+ sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b)))
+ [1 .. 5]
+ let fm = FailureMessage PermanentChannelFailure no_tlvs
+ forM_ (zip [0 ..] sss) $ \(i, ss) -> do
+ pkt <- right "construct_error" (construct_error ss fm)
+ let back = foldr wrap_error pkt (take i sss)
+ unwrap_error sss back @?= Attributed i fm
+ , testCase "reports the hop of a malformed failure" $ do
+ sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b)))
+ [1 .. 3]
+ ss2 <- demand "ss2" (safe_index sss 2)
+ -- incorrect_cltv_expiry with no data
+ let fm = FailureMessage (UnknownFailure 0x100d "") no_tlvs
+ pkt <- right "construct_error" (construct_error ss2 fm)
+ let back = foldr wrap_error pkt (take 2 sss)
+ unwrap_error sss back @?= MalformedFailure 2
+ , testCase "reports a malformed return packet" $ do
+ ss <- demand "ss" (shared_secret (BS.replicate 32 1))
+ -- a valid HMAC over a body whose failure_len overruns it
+ let body = "\SOH\NUL\x20\x02"
+ SHA256.MAC um = SHA256.hmac "um" (un_shared_secret ss)
+ SHA256.MAC mac = SHA256.hmac um body
+ pkt = wrap_error ss (ErrorPacket (mac <> body))
+ unwrap_error [ss] pkt @?= MalformedFailure 0
+ , testCase "unknown origin" $ do
+ sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b)))
+ [1 .. 3]
+ other <- demand "ss" (shared_secret (BS.replicate 32 9))
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error other fm)
+ unwrap_error sss pkt @?= UnknownOrigin
+ unwrap_error [] pkt @?= UnknownOrigin
+ unwrap_error sss (ErrorPacket "short") @?= UnknownOrigin
]
-propScidRoundtrip :: Property
-propScidRoundtrip =
- forAll (choose (0, 0xFFFFFF)) $ \bh ->
- forAll (choose (0, 0xFFFFFF)) $ \ti ->
- forAll arbitrary $ \oi ->
- case shortChannelId bh ti oi of
- Nothing -> False
- Just scid ->
- let encoded = encodeShortChannelId scid
- in decodeShortChannelId encoded == Just scid
-
-propHopPayloadRoundtrip :: Property
-propHopPayloadRoundtrip =
- forAll genHopPayload $ \hp ->
- let encoded = encodeHopPayload hp
- in decodeHopPayload encoded == Just hp
-
-genHopPayload :: Gen HopPayload
-genHopPayload = do
- amt <- oneof [pure Nothing, Just <$> arbitrary]
- cltv <- oneof [pure Nothing, Just <$> arbitrary]
- sci <- oneof [pure Nothing, genScid]
- pure HopPayload
- { hpAmtToForward = amt
- , hpOutgoingCltv = cltv
- , hpShortChannelId = sci
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
- }
- where
- genScid :: Gen (Maybe ShortChannelId)
- genScid = do
- bh <- choose (0, 0xFFFFFF)
- ti <- choose (0, 0xFFFFFF)
- oi <- arbitrary
- pure (shortChannelId bh ti oi)
-
-propNewtypeValidation :: NonNegative Int -> Property
-propNewtypeValidation (NonNegative n) = property $
- let len = n `mod` 2000
- bs = BS.replicate len 0x00
- h32 = hmac32 bs
- hp = hopPayloads bs
- ps = paymentSecret bs
- in (case h32 of
- Just _ -> len == 32
- Nothing -> len /= 32)
- &&
- (case hp of
- Just _ -> len == hopPayloadsSize
- Nothing -> len /= hopPayloadsSize)
- &&
- (case ps of
- Just _ -> len == 32
- Nothing -> len /= 32)
-
-propFailureMessageRoundtrip :: Property
-propFailureMessageRoundtrip =
- forAll genFailureMessage $ \fm ->
- let encoded = encodeFailureMessage fm
- in decodeFailureMessage encoded == Just fm
-
-genFailureMessage :: Gen FailureMessage
-genFailureMessage = do
- code <- elements
- [ InvalidRealm
- , TemporaryNodeFailure
- , PermanentNodeFailure
- , RequiredNodeFeatureMissing
- , InvalidOnionVersion
- , InvalidOnionHmac
- , InvalidOnionKey
- , TemporaryChannelFailure
- , PermanentChannelFailure
- , AmountBelowMinimum
- , FeeInsufficient
- , IncorrectCltvExpiry
- , ExpiryTooSoon
- , IncorrectOrUnknownPaymentDetails
- , FinalIncorrectCltvExpiry
- , FinalIncorrectHtlcAmount
- , ChannelDisabled
- , ExpiryTooFar
- , InvalidOnionPayload
- , MppTimeout
- ]
- dat <- genFailureData code
- ntlv <- choose (0, 3 :: Int)
- types <- (nub . sort) <$> vectorOf ntlv arbitrary
- tlvs <- mapM (\t -> do
- len <- choose (0, 20 :: Int)
- TlvRecord t . BS.pack <$> vectorOf len arbitrary) types
- pure (FailureMessage code dat tlvs)
-
--- | Random well-formed data for a failure code.
-genFailureData :: FailureCode -> Gen BS.ByteString
-genFailureData c
- | c `elem` [InvalidOnionVersion, InvalidOnionHmac, InvalidOnionKey] =
- bytes 32
- | c `elem` [TemporaryChannelFailure, ExpiryTooSoon] = update 0
- | c `elem` [AmountBelowMinimum, FeeInsufficient] = update 8
- | c == IncorrectCltvExpiry = update 4
- | c == ChannelDisabled = update 2
- | c == IncorrectOrUnknownPaymentDetails = bytes 12
- | c == FinalIncorrectCltvExpiry = bytes 4
- | c == FinalIncorrectHtlcAmount = bytes 8
- | c == InvalidOnionPayload = do
- typ <- arbitrary
- off <- bytes 2
- pure (encodeBigSize typ <> off)
- | otherwise = pure BS.empty
- where
- bytes n = BS.pack <$> vectorOf n arbitrary
- update n = do
- fields <- bytes n
- len <- choose (0, 300 :: Int)
- cu <- bytes len
- pure $ fields
- <> BS.pack [fromIntegral (len `div` 256), fromIntegral len]
- <> cu
-
--- Spec vectors: onion-test.json --------------------------------------------
-
--- | Shared secrets for the onion-test.json route (identical to those
--- listed in onion-error-test.json).
-onionSharedSecrets :: IO [BS.ByteString]
-onionSharedSecrets = mapM unhex
- [ V.errSharedSecret0, V.errSharedSecret1, V.errSharedSecret2
- , V.errSharedSecret3, V.errSharedSecret4 ]
+-- spec vectors: onion-test.json ----------------------------------------------
--- | (node key, node pubkey, payload without length prefix) per hop.
-onionVectorHops
- :: IO [(BS.ByteString, Secp256k1.Projective, BS.ByteString)]
-onionVectorHops = mapM hop
+onion_hops :: IO [(SecretKey, BOLT1.Point, BS.ByteString)]
+onion_hops = mapM hop
[ (V.onionNodeKey0, V.onionPubKey0, V.onionPayload0)
, (V.onionNodeKey1, V.onionPubKey1, V.onionPayload1)
, (V.onionNodeKey2, V.onionPubKey2, V.onionPayload2)
@@ -1709,585 +870,596 @@ onionVectorHops = mapM hop
, (V.onionNodeKey4, V.onionPubKey4, V.onionPayload4)
]
where
- hop (k, p, pl) = do
- key <- unhex k
- pub <- unhexPoint p
- body <- unhex pl >>= unprefix
- pure (key, pub, body)
-
--- | Next ephemeral key per spec: SHA256(E || ss) * E.
-nextEphemeralKey
- :: Secp256k1.Projective -> BS.ByteString -> Maybe Secp256k1.Projective
-nextEphemeralKey e ss = do
- tweak <- Secp256k1.roll32
- (SHA256.hash (Secp256k1.serialize_point e <> ss))
- Secp256k1.mul e tweak
-
--- | Process an onion hop by hop, checking each hop's payload and
--- shared secret, and that each forwarded packet is a well-formed
--- 1366-byte packet carrying the expected ephemeral key.
-peelOnion
- :: BS.ByteString
- -> [(BS.ByteString, BS.ByteString, BS.ByteString)]
- -- ^ (node key, expected payload, expected shared secret)
- -> Secp256k1.Projective
- -- ^ expected ephemeral key of the packet
- -> OnionPacket
- -> Assertion
-peelOnion _ [] _ _ = assertFailure "no hops"
-peelOnion ad ((key, body, ss) : rest) eph pkt = do
- opVersion pkt @?= versionByte
- opEphemeralKey pkt @?= Secp256k1.serialize_point eph
- case (process key pkt ad, rest) of
- (Left e, _) -> assertFailure ("process failed: " ++ show e)
- (Right (Receive ri), []) -> do
- encodeHopPayload (riPayload ri) @?= body
- riSharedSecret ri @?= SharedSecret ss
- (Right (Forward fi), _ : _) -> do
- encodeHopPayload (fiPayload fi) @?= body
- fiSharedSecret fi @?= SharedSecret ss
- let next = fiNextPacket fi
- bytes = encodeOnionPacket next
- BS.length bytes @?= onionPacketSize
- decodeOnionPacket bytes @?= Just next
- eph' <- demand "next ephemeral key" (nextEphemeralKey eph ss)
- peelOnion ad rest eph' next
- (Right (Receive _), _ : _) ->
- assertFailure "expected Forward, got Receive"
- (Right (Forward _), []) ->
- assertFailure "expected Receive, got Forward"
-
-onionVectorTests :: TestTree
-onionVectorTests = testGroup "onion-test.json" [
- testCase "construct reproduces the spec onion" $ do
- hops <- onionVectorHops
- sk <- unhex V.onionSessionKey
- ad <- unhex V.onionAssocData
+ hop (k, p, pl) = (,,) <$> hex_key k <*> hex_point p
+ <*> (unhex pl >>= unprefix)
+
+-- the shared secrets of the onion-test.json route, as listed in
+-- onion-error-test.json
+route_secrets :: IO [SharedSecret]
+route_secrets = mapM hex_secret
+ [ V.errSharedSecret0, V.errSharedSecret1, V.errSharedSecret2
+ , V.errSharedSecret3, V.errSharedSecret4 ]
+
+onion_vectors :: TestTree
+onion_vectors = testGroup "onion-test.json" [
+ testCase "construct reproduces the onion" $ do
+ hops <- onion_hops
+ sk <- hex_key V.onionSessionKey
+ assoc <- unhex V.onionAssocData
expected <- unhex V.onionPacket
- sss <- onionSharedSecrets
+ sss <- route_secrets
route <- mapM (\(_, pub, body) -> do
- hp <- demand "decodeHopPayload" (decodeHopPayload body)
- encodeHopPayload hp @?= body
+ hp <- right "decode_hop_payload" (decode_hop_payload body)
+ encode_hop_payload hp @?= Right body
pure (Hop pub hp)) hops
- case construct sk route ad of
- Left e -> assertFailure ("construct failed: " ++ show e)
- Right (pkt, secrets) -> do
- encodeOnionPacket pkt @?= expected
- secrets @?= map SharedSecret sss
-
- , testCase "process peels the spec onion at every hop" $ do
- hops <- onionVectorHops
- sk <- unhex V.onionSessionKey
- ad <- unhex V.onionAssocData
- sss <- onionSharedSecrets
- pkt <- unhex V.onionPacket >>=
- demand "decodeOnionPacket" . decodeOnionPacket
- e0 <- demand "session pubkey"
- (Secp256k1.roll32 sk >>= Secp256k1.derive_pub)
- let expect = zipWith (\(k, _, body) ss -> (k, body, ss)) hops sss
- peelOnion ad expect e0 pkt
+ (pkt, secrets) <- right "construct" (construct sk route assoc)
+ encode_onion_packet pkt @?= expected
+ secrets @?= sss
+ , testCase "process peels the onion at every hop" $ do
+ hops <- onion_hops
+ assoc <- unhex V.onionAssocData
+ sss <- route_secrets
+ pkt <- unhex V.onionPacket >>= right "decode" . decode_onion_packet
+ let go [] _ = assertFailure "no hops"
+ go [((k, _, body), ss)] p = do
+ r <- receive (process k p assoc Nothing)
+ encode_hop_payload (rcv_payload r) @?= Right body
+ rcv_shared_secret r @?= ss
+ go (((k, _, body), ss) : rest) p = do
+ f <- forward (process k p assoc Nothing)
+ encode_hop_payload (fwd_payload f) @?= Right body
+ fwd_shared_secret f @?= ss
+ fwd_blinded f @?= Nothing
+ go rest (fwd_next_packet f)
+ go (zip hops sss) pkt
]
--- Multi-hop construct/process ----------------------------------------------
-
--- | Construct an onion over a route of (node key, payload) pairs, then
--- process it at every hop, checking payloads and shared secrets.
-roundtripRoute :: BS.ByteString -> [(BS.ByteString, HopPayload)] -> Bool
-roundtripRoute sk route = case mapM mkHop route of
- Nothing -> False
- Just hops -> case construct sk hops ad of
- Left _ -> False
- Right (pkt, secrets) ->
- length secrets == length route && go (zip route secrets) pkt
- where
- ad = BS.replicate 32 0x42
- mkHop (k, hp) = do
- pub <- Secp256k1.roll32 k >>= Secp256k1.derive_pub
- pure (Hop pub hp)
- go [] _ = False
- go [((k, hp), ss)] pkt = case process k pkt ad of
- Right (Receive ri) -> riPayload ri == hp && riSharedSecret ri == ss
- _ -> False
- go (((k, hp), ss) : rest) pkt = case process k pkt ad of
- Right (Forward fi) ->
- fiPayload fi == hp
- && fiSharedSecret fi == ss
- && BS.length (encodeOnionPacket (fiNextPacket fi))
- == onionPacketSize
- && go rest (fiNextPacket fi)
- _ -> False
-
-multiHopTests :: TestTree
-multiHopTests = testGroup "construct then process" [
- testCase "routes of 1 to 20 hops" $
- mapM_ (\n -> do
- route <- mapM (\i -> do
- scid <- assertScid (700000 + i) i 1
- let hp = HopPayload
- { hpAmtToForward = Just (1000 * fromIntegral i)
- , hpOutgoingCltv = Just (500000 + i)
- , hpShortChannelId = Just scid
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = []
- }
- pure (BS.replicate 32 (fromIntegral i), hp)) [1 .. n]
- assertBool ("route of " ++ show n ++ " hops")
- (roundtripRoute sessionKey route)) [1 .. 20 :: Word32]
-
- , testProperty "random routes of 1 to 20 hops" $
- forAll (choose (1, 20)) $ \n ->
- forAll genSecKey $ \sk ->
- forAll (vectorOf n genSecKey) $ \keys ->
- forAll (vectorOf n (genRoutePayload n)) $ \pls ->
- roundtripRoute sk (zip keys pls)
- ]
-
--- | A valid 32-byte secret key.
-genSecKey :: Gen BS.ByteString
-genSecKey = (BS.pack <$> vectorOf 32 arbitrary) `suchThat` valid
- where
- valid k = isJust (Secp256k1.roll32 k >>= Secp256k1.derive_pub)
+-- spec vectors: onion-error-test.json ----------------------------------------
--- | A hop payload whose shift size fits n hops in 1300 bytes.
---
--- The fixed fields take at most 26 bytes; an odd TLV of type 65537
--- adds at most 8 bytes of framing plus its value. With a 3-byte
--- length prefix and 32-byte HMAC a hop then shifts at most 69 bytes
--- plus the value length.
-genRoutePayload :: Int -> Gen HopPayload
-genRoutePayload n = do
- amt <- arbitrary
- cltv <- arbitrary
- scid <- oneof [pure Nothing, genScid]
- let budget = hopPayloadsSize `div` n - 69
- extra <- if budget < 0
- then pure []
- else do
- len <- choose (0, budget)
- blob <- BS.pack <$> vectorOf len arbitrary
- pure [TlvRecord 65537 blob]
- pure HopPayload
- { hpAmtToForward = Just amt
- , hpOutgoingCltv = Just cltv
- , hpShortChannelId = scid
- , hpPaymentData = Nothing
- , hpEncryptedData = Nothing
- , hpCurrentPathKey = Nothing
- , hpUnknownTlvs = extra
- }
- where
- genScid :: Gen (Maybe ShortChannelId)
- genScid = do
- bh <- choose (0, 0xFFFFFF)
- ti <- choose (0, 0xFFFFFF)
- oi <- arbitrary
- pure (shortChannelId bh ti oi)
-
--- Spec vectors: onion-error-test.json --------------------------------------
-
--- | Shared secrets for hops 0 to 4, in route order.
-errorSharedSecrets :: IO [SharedSecret]
-errorSharedSecrets = map SharedSecret <$> onionSharedSecrets
-
--- | The failing node's (hop 4) shared secret, and those of the hops
--- that wrap its return packet, from hop 3 back to hop 0.
-errorWrappers :: IO (SharedSecret, [SharedSecret])
-errorWrappers = do
- sss <- errorSharedSecrets
+-- the failing node's shared secret, and those of the hops back to the
+-- origin, from hop 3 to hop 0
+error_wrappers :: IO (SharedSecret, [SharedSecret])
+error_wrappers = do
+ sss <- route_secrets
case reverse sss of
ss4 : rest -> pure (ss4, rest)
- [] -> assertFailure "no shared secrets"
-
-errorVectorTests :: TestTree
-errorVectorTests = testGroup "onion-error-test.json" [
- testCase "ammag and um keys" $ do
- sss <- errorSharedSecrets
- ammags <- mapM unhex
- [ V.errAmmagKey0, V.errAmmagKey1, V.errAmmagKey2
- , V.errAmmagKey3, V.errAmmagKey4 ]
- map deriveAmmag sss @?= map DerivedKey ammags
- (ss4, _) <- errorWrappers
- um4 <- unhex V.errUmKey4
- deriveUm ss4 @?= DerivedKey um4
-
- , testCase "failing node builds the spec return packet" $ do
- (ss4, _) <- errorWrappers
+ [] -> assertFailure "no shared secrets"
+
+error_vectors :: TestTree
+error_vectors = testGroup "onion-error-test.json" [
+ testCase "failure message" $ do
msg <- unhex V.errFailureMessage
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ encode_failure_message fm @?= Right msg
+ decode_failure_message msg @?= Right fm
+ , testCase "the failing node's return packet" $ do
+ (ss4, _) <- error_wrappers
payload <- unhex V.errPayload4
- fm <- demand "decodeFailureMessage" (decodeFailureMessage msg)
- fm @?= FailureMessage TemporaryNodeFailure BS.empty []
- encodeFailureMessage fm @?= msg
- -- removing hop 4's own obfuscation leaves hmac || payload
- ErrorPacket raw <- mkError ss4 fm >>= wrapErr ss4
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error ss4 fm)
+ -- removing hop 4's obfuscation leaves the HMAC and payload
+ let ErrorPacket raw = wrap_error ss4 pkt
BS.drop 32 raw @?= payload
-
- , testCase "wrapping at each hop yields the spec packet" $ do
- (ss4, wrappers) <- errorWrappers
+ , testCase "wrapping at each hop yields the returned packet" $ do
+ (ss4, wrappers) <- error_wrappers
expected <- unhex V.errPacket
- let fm = FailureMessage TemporaryNodeFailure BS.empty []
- initial <- mkError ss4 fm
- final <- foldM (flip wrapErr) initial wrappers
- final @?= ErrorPacket expected
-
- , testCase "origin attributes the spec packet to hop 4" $ do
- sss <- errorSharedSecrets
+ let fm = FailureMessage TemporaryNodeFailure no_tlvs
+ pkt <- right "construct_error" (construct_error ss4 fm)
+ foldl (flip wrap_error) pkt wrappers @?= ErrorPacket expected
+ , testCase "the origin attributes the packet to hop 4" $ do
+ sss <- route_secrets
pkt <- unhex V.errPacket
- unwrapError sss (ErrorPacket pkt)
- @?= Attributed 4 (FailureMessage TemporaryNodeFailure BS.empty [])
+ unwrap_error sss (ErrorPacket pkt) @?=
+ Attributed 4 (FailureMessage TemporaryNodeFailure no_tlvs)
]
--- Spec vectors: 'Returning Errors' trace -----------------------------------
+-- spec vectors: 'Returning Errors' trace -------------------------------------
--- | incorrect_or_unknown_payment_details with htlc_msat 100, height
--- 800000 and a 300-byte TLV of type 34001.
-traceFailure :: FailureMessage
-traceFailure = FailureMessage IncorrectOrUnknownPaymentDetails
- (BS.pack [0, 0, 0, 0, 0, 0, 0, 100, 0, 0x0c, 0x35, 0x00])
- [TlvRecord 34001 (BS.replicate 300 0x80)]
+trace_failure :: IO FailureMessage
+trace_failure = do
+ m <- msat 100
+ ex <- tlvs [BOLT1.TlvRecord 34001 (BS.replicate 300 0x80)]
+ pure (FailureMessage (IncorrectOrUnknownPaymentDetails m 800000) ex)
-traceVectorTests :: TestTree
-traceVectorTests = testGroup "returning errors trace" [
+trace_vectors :: TestTree
+trace_vectors = testGroup "returning errors trace" [
testCase "failure message encoding" $ do
+ fm <- trace_failure
-- the trace lists failuremsg || pad_len || pad
encoded <- unhex V.traceFailureMessage
- raw <- unhex V.traceRawPacket
- let msg = encodeFailureMessage traceFailure
- BS.take (BS.length msg) encoded @?= msg
- decodeFailureMessage msg @?= Just traceFailure
- failureLen <- u16At 32 raw
- failureLen @?= BS.length msg
- BS.take failureLen (BS.drop 34 raw) @?= msg
-
+ msg <- right "encode" (encode_failure_message fm)
+ BS.length msg @?= 320
+ BS.take 320 encoded @?= msg
+ decode_failure_message msg @?= Right fm
, testCase "each hop's packet matches the trace" $ do
- (ss4, wrappers) <- errorWrappers
+ (ss4, wrappers) <- error_wrappers
raw <- unhex V.traceRawPacket
expected <- mapM unhex
[ V.tracePacket4, V.tracePacket3, V.tracePacket2
, V.tracePacket1, V.tracePacket0 ]
- packets <- demand "wrapError" $ sequence $ drop 1 $
- scanl (\p ss -> p >>= wrapError ss) (Just (ErrorPacket raw))
- (ss4 : wrappers)
+ let packets = drop 1 $
+ scanl (flip wrap_error) (ErrorPacket raw) (ss4 : wrappers)
packets @?= map ErrorPacket expected
-
- , testCase "origin attributes the trace packet to hop 4" $ do
- sss <- errorSharedSecrets
+ , testCase "the origin attributes the packet to hop 4" $ do
+ fm <- trace_failure
+ sss <- route_secrets
pkt <- unhex V.tracePacket0
- unwrapError sss (ErrorPacket pkt) @?= Attributed 4 traceFailure
+ unwrap_error sss (ErrorPacket pkt) @?= Attributed 4 fm
]
--- Spec vectors: route-blinding-test.json -----------------------------------
-
--- | Blinded private key HMAC256("blinded_node_id", ss) * k, where
--- ss = ECDH(k, path_key). The library has no function for this, so
--- it is assembled from exported primitives.
-blindedPrivKey
- :: BS.ByteString -> Secp256k1.Projective -> Maybe BS.ByteString
-blindedPrivKey k pathKey = do
- SharedSecret ss <- computeSharedSecret k pathKey
- let SHA256.MAC tweak = SHA256.hmac "blinded_node_id" ss
- blindSecKey k (BlindingFactor tweak)
-
-rbBobData :: IO BlindedHopData
-rbBobData = do
- scid <- assertScid 0 0 1729
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 26 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 36 150 10000)
- , bhdPaymentConstraints = Just (PaymentConstraints 748005 1500)
- , bhdAllowedFeatures = Just BS.empty
+-- spec vectors: route-blinding-test.json -------------------------------------
+
+empty_features :: Maybe BOLT9.FeatureVector
+empty_features = Just (BOLT9.parse BS.empty)
+
+rb_bob_data :: IO BlindedHopData
+rb_bob_data = do
+ s <- scid 0 0 1729
+ m <- msat 1500
+ ex <- tlvs [BOLT1.TlvRecord 561 "\DC24V"]
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 26 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 36 150 10000)
+ , bhd_payment_constraints = Just (PaymentConstraints 748005 m)
+ , bhd_allowed_features = empty_features
+ , bhd_extra = ex
}
-rbCarolData :: IO BlindedHopData
-rbCarolData = do
- scid <- assertScid 0 0 1105
- override <- unhex V.rbDavePathKey
- pure emptyHopData
- { bhdShortChannelId = Just scid
- , bhdNextPathKeyOverride = Just override
- , bhdPaymentRelay = Just (PaymentRelay 48 100 500)
- , bhdPaymentConstraints = Just (PaymentConstraints 747969 1500)
- , bhdAllowedFeatures = Just BS.empty
+rb_carol_data :: IO BlindedHopData
+rb_carol_data = do
+ s <- scid 0 0 1105
+ m <- msat 1500
+ override <- hex_point V.rbDavePathKey
+ pure empty_blinded_hop_data
+ { bhd_short_channel_id = Just s
+ , bhd_next_path_key_override = Just override
+ , bhd_payment_relay = Just (PaymentRelay 48 100 500)
+ , bhd_payment_constraints = Just (PaymentConstraints 747969 m)
+ , bhd_allowed_features = empty_features
}
-rbDaveData :: IO BlindedHopData
-rbDaveData = do
- scid <- assertScid 0 0 561
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 35 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 144 250 0)
- , bhdPaymentConstraints = Just (PaymentConstraints 747921 1500)
- , bhdAllowedFeatures = Just BS.empty
+rb_dave_data :: IO BlindedHopData
+rb_dave_data = do
+ s <- scid 0 0 561
+ m <- msat 1500
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 35 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 144 250 0)
+ , bhd_payment_constraints = Just (PaymentConstraints 747921 m)
+ , bhd_allowed_features = empty_features
}
-rbEveData :: IO BlindedHopData
-rbEveData = pure emptyHopData
- { bhdPadding = Just (BS.replicate 26 0)
- , bhdPathId = Just (BS.pack [0xde, 0xad, 0xbe, 0xef])
- , bhdPaymentConstraints = Just (PaymentConstraints 747777 1500)
- , bhdAllowedFeatures = Just (BS.cons 0x02 (BS.replicate 14 0))
- }
+rb_eve_data :: IO BlindedHopData
+rb_eve_data = do
+ m <- msat 1500
+ ex <- tlvs [BOLT1.TlvRecord 65535 "\ACK\193"]
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 26 0)
+ , bhd_path_id = Just "\222\173\190\239"
+ , bhd_payment_constraints = Just (PaymentConstraints 747777 m)
+ , bhd_allowed_features =
+ Just (BOLT9.parse (BS.cons 0x02 (BS.replicate 14 0)))
+ , bhd_extra = ex
+ }
--- | A hop of route-blinding-test.json. 'rbUnknown' holds the unknown
--- odd TLVs that the hop's data carries in addition to 'rbData'.
+-- a hop of route-blinding-test.json
data RbHop = RbHop
- { rbData :: !BlindedHopData
- , rbUnknown :: ![TlvRecord]
- , rbNodeId :: !Secp256k1.Projective
- , rbTlvs :: !BS.ByteString
- , rbPathPrivKey :: !BS.ByteString
- , rbPathKey :: !Secp256k1.Projective
- , rbSharedSecret :: !BS.ByteString
- , rbRho :: !BS.ByteString
- , rbEncrypted :: !BS.ByteString
- , rbBlindedNodeId :: !BS.ByteString
- , rbNodeKey :: !BS.ByteString
- , rbBlindedKey :: !BS.ByteString
- , rbNextPathKey :: !Secp256k1.Projective
+ { rb_data :: !BlindedHopData
+ , rb_node_id :: !BOLT1.Point
+ , rb_tlvs :: !BS.ByteString
+ , rb_path_key :: !BOLT1.Point
+ , rb_encrypted :: !BS.ByteString
+ , rb_blinded_id :: !BOLT1.Point
+ , rb_node_key :: !SecretKey
+ , rb_next_path_key :: !BOLT1.Point
}
-rbHops :: IO (RbHop, RbHop, RbHop, RbHop)
-rbHops = do
- bob <- hop rbBobData [TlvRecord 561 (BS.pack [0x12, 0x34, 0x56])]
- ( V.rbBobNodeId, V.rbBobTlvs, V.rbBobPathPrivKey, V.rbBobPathKey
- , V.rbBobSharedSecret, V.rbBobRho, V.rbBobEncryptedData
- , V.rbBobBlindedNodeId )
- (V.rbBobNodeKey, V.rbBobBlindedPrivKey, V.rbBobNextPathKey)
- carol <- hop rbCarolData []
- ( V.rbCarolNodeId, V.rbCarolTlvs, V.rbCarolPathPrivKey
- , V.rbCarolPathKey, V.rbCarolSharedSecret, V.rbCarolRho
- , V.rbCarolEncryptedData, V.rbCarolBlindedNodeId )
- (V.rbCarolNodeKey, V.rbCarolBlindedPrivKey, V.rbCarolNextPathKey)
- dave <- hop rbDaveData []
- ( V.rbDaveNodeId, V.rbDaveTlvs, V.rbDavePathPrivKey, V.rbDavePathKey
- , V.rbDaveSharedSecret, V.rbDaveRho, V.rbDaveEncryptedData
- , V.rbDaveBlindedNodeId )
- (V.rbDaveNodeKey, V.rbDaveBlindedPrivKey, V.rbDaveNextPathKey)
- eve <- hop rbEveData [TlvRecord 65535 (BS.pack [0x06, 0xc1])]
- ( V.rbEveNodeId, V.rbEveTlvs, V.rbEvePathPrivKey, V.rbEvePathKey
- , V.rbEveSharedSecret, V.rbEveRho, V.rbEveEncryptedData
- , V.rbEveBlindedNodeId )
- (V.rbEveNodeKey, V.rbEveBlindedPrivKey, V.rbEveNextPathKey)
- pure (bob, carol, dave, eve)
+rb_hops :: IO [RbHop]
+rb_hops = sequence
+ [ hop rb_bob_data
+ ( V.rbBobNodeId, V.rbBobTlvs, V.rbBobPathKey
+ , V.rbBobEncryptedData, V.rbBobBlindedNodeId )
+ (V.rbBobNodeKey, V.rbBobNextPathKey)
+ , hop rb_carol_data
+ ( V.rbCarolNodeId, V.rbCarolTlvs, V.rbCarolPathKey
+ , V.rbCarolEncryptedData, V.rbCarolBlindedNodeId )
+ (V.rbCarolNodeKey, V.rbCarolNextPathKey)
+ , hop rb_dave_data
+ ( V.rbDaveNodeId, V.rbDaveTlvs, V.rbDavePathKey
+ , V.rbDaveEncryptedData, V.rbDaveBlindedNodeId )
+ (V.rbDaveNodeKey, V.rbDaveNextPathKey)
+ , hop rb_eve_data
+ ( V.rbEveNodeId, V.rbEveTlvs, V.rbEvePathKey
+ , V.rbEveEncryptedData, V.rbEveBlindedNodeId )
+ (V.rbEveNodeKey, V.rbEveNextPathKey)
+ ]
where
- hop mkData unknown (nid, tlvs, ppk, pk, ss, rho, enc, bid)
- (nk, bk, npk) =
- RbHop <$> mkData <*> pure unknown <*> unhexPoint nid
- <*> unhex tlvs <*> unhex ppk <*> unhexPoint pk <*> unhex ss
- <*> unhex rho <*> unhex enc <*> unhex bid <*> unhex nk
- <*> unhex bk <*> unhexPoint npk
-
-routeBlindingTests :: TestTree
-routeBlindingTests = testGroup "route-blinding-test.json" [
- testCase "encrypted_data_tlv encoding" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\h -> do
- -- unknown odd TLVs are the last records in the vectors
- encodeBlindedHopData (rbData h) <> encodeTlvStream (rbUnknown h)
- @?= rbTlvs h
- decodeBlindedHopData (rbTlvs h) @?= Just (rbData h))
- [bob, carol, dave, eve]
-
- , testCase "per-hop shared secret and rho" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\h -> do
- ss <- demand "computeSharedSecret" $
- computeSharedSecret (rbPathPrivKey h) (rbNodeId h)
- ss @?= SharedSecret (rbSharedSecret h)
- deriveBlindingRho ss @?= DerivedKey (rbRho h)
- deriveBlindedNodeId ss (rbNodeId h)
- @?= Just (rbBlindedNodeId h))
- [bob, carol, dave, eve]
-
- , testCase "nextEphemeral yields the next path key pair" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\(h, nxt) -> do
- let ss = SharedSecret (rbSharedSecret h)
- nextEphemeral (rbPathPrivKey h) (rbPathKey h) ss
- @?= Just (rbPathPrivKey nxt, rbPathKey nxt))
- [(bob, carol), (dave, eve)]
-
- , testCase "createBlindedPath (Bob -> Carol)" $ do
- (bob, carol, _, _) <- rbHops
- path <- either (assertFailure . show) pure $
- createBlindedPath (rbPathPrivKey bob)
- [(rbNodeId bob, rbData bob), (rbNodeId carol, rbData carol)]
- bpIntroductionNode path @?= rbNodeId bob
- bpBlindingKey path @?= rbPathKey bob
- case bpBlindedHops path of
- [b, c] -> do
- bhBlindedNodeId b @?= rbBlindedNodeId bob
- bhBlindedNodeId c @?= rbBlindedNodeId carol
- -- Bob's data in the vector carries an unknown TLV (561)
- -- that BlindedHopData cannot represent, so only Carol's
- -- encrypted_data can be reproduced.
- bhEncryptedData c @?= rbEncrypted carol
- _ -> assertFailure "expected 2 blinded hops"
-
- , testCase "createBlindedPath (Dave -> Eve)" $ do
- (_, _, dave, eve) <- rbHops
- path <- either (assertFailure . show) pure $
- createBlindedPath (rbPathPrivKey dave)
- [(rbNodeId dave, rbData dave), (rbNodeId eve, rbData eve)]
- bpIntroductionNode path @?= rbNodeId dave
- bpBlindingKey path @?= rbPathKey dave
- case bpBlindedHops path of
- [d, e] -> do
- bhBlindedNodeId d @?= rbBlindedNodeId dave
- bhBlindedNodeId e @?= rbBlindedNodeId eve
- -- Eve's data carries an unknown TLV (65535); see above.
- bhEncryptedData d @?= rbEncrypted dave
- _ -> assertFailure "expected 2 blinded hops"
-
- , testCase "unblinding at each hop" $ do
- (bob, carol, dave, eve) <- rbHops
- mapM_ (\h -> do
- case processBlindedHop (rbNodeKey h) (rbPathKey h)
- (rbEncrypted h) of
- Left e -> assertFailure ("processBlindedHop: " ++ show e)
- Right (dat, npk) -> do
- dat @?= rbData h
- npk @?= rbNextPathKey h
- blindedPrivKey (rbNodeKey h) (rbPathKey h)
- @?= Just (rbBlindedKey h))
- [bob, carol, dave, eve]
+ hop mk (nid, tl, pk, enc, bid) (nk, npk) =
+ RbHop <$> mk <*> hex_point nid <*> unhex tl <*> hex_point pk
+ <*> unhex enc <*> hex_point bid <*> hex_key nk
+ <*> hex_point npk
+
+route_blinding_vectors :: TestTree
+route_blinding_vectors = testGroup "route-blinding-test.json" [
+ testCase "encrypted_data_tlv encodings" $ do
+ hops <- rb_hops
+ forM_ hops $ \h -> do
+ encode_blinded_hop_data (rb_data h) @?= Right (rb_tlvs h)
+ decode_blinded_hop_data (rb_tlvs h) @?= Right (rb_data h)
+ , testCase "create_blinded_path reproduces the route" $ do
+ hops <- rb_hops
+ (bob, carol, dave, eve) <- case hops of
+ [b, c, d, e] -> pure (b, c, d, e)
+ _ -> assertFailure "expected 4 hops"
+ -- Bob creates Bob -> Carol, Eve creates Dave -> Eve
+ bob_seed <- hex_key V.rbBobPathPrivKey
+ dave_seed <- hex_key V.rbDavePathPrivKey
+ let check seed hs = do
+ path <- right "create_blinded_path" $ create_blinded_path seed
+ [ (rb_node_id h, rb_data h) | h <- hs ]
+ case hs of
+ h : _ -> do
+ bp_first_node_id path @?= rb_node_id h
+ bp_first_path_key path @?= rb_path_key h
+ [] -> assertFailure "no hops"
+ bp_hops path @?=
+ [ BlindedHop (rb_blinded_id h) (rb_encrypted h) | h <- hs ]
+ check bob_seed [bob, carol]
+ check dave_seed [dave, eve]
+ , testCase "each hop decrypts its data and next path key" $ do
+ hops <- rb_hops
+ forM_ hops $ \h -> do
+ info <- right "decrypt_recipient_data" $
+ decrypt_recipient_data (rb_node_key h) (rb_path_key h)
+ (rb_encrypted h)
+ bi_data info @?= rb_data h
+ encode_blinded_hop_data (bi_data info) @?= Right (rb_tlvs h)
+ -- Carol's next path key is her next_path_key_override
+ bi_next_path_key info @?= rb_next_path_key h
+ , testCase "each hop decrypts an onion to its blinded id" $ do
+ -- the onion is encrypted to blinded_node_id, so processing it
+ -- requires the blinded private key of the vector
+ hops <- rb_hops
+ session <- key 0x55
+ forM_ hops $ \h -> do
+ let pl = empty_hop_payload
+ { hp_encrypted_data = Just (rb_encrypted h) }
+ (pkt, sss) <- right "construct" $
+ construct session [Hop (rb_blinded_id h) pl] ad
+ r <- receive (process (rb_node_key h) pkt ad (Just (rb_path_key h)))
+ Just (rcv_shared_secret r) @?= safe_head sss
+ fmap bi_next_path_key (rcv_blinded r) @?= Just (rb_next_path_key h)
]
--- Spec vectors: blinded-payment-onion-test.json ----------------------------
-
-bpBobData :: IO BlindedHopData
-bpBobData = do
- scid <- assertScid 0 0 1
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 32 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 50 0 10000)
- , bhdPaymentConstraints = Just (PaymentConstraints 750150 50)
- , bhdAllowedFeatures = Just BS.empty
+-- spec vectors: blinded-payment-onion-test.json ------------------------------
+
+bp_bob_data :: IO BlindedHopData
+bp_bob_data = do
+ s <- scid 0 0 1
+ m <- msat 50
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 32 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 50 0 10000)
+ , bhd_payment_constraints = Just (PaymentConstraints 750150 m)
+ , bhd_allowed_features = empty_features
}
-bpCarolData :: IO BlindedHopData
-bpCarolData = do
- scid <- assertScid 0 0 2
- override <- unhex V.rbDavePathKey
- pure emptyHopData
- { bhdShortChannelId = Just scid
- , bhdNextPathKeyOverride = Just override
- , bhdPaymentRelay = Just (PaymentRelay 75 150 100)
- , bhdPaymentConstraints = Just (PaymentConstraints 750100 50)
- , bhdAllowedFeatures = Just BS.empty
+bp_carol_data :: IO BlindedHopData
+bp_carol_data = do
+ s <- scid 0 0 2
+ m <- msat 50
+ override <- hex_point V.rbDavePathKey
+ pure empty_blinded_hop_data
+ { bhd_short_channel_id = Just s
+ , bhd_next_path_key_override = Just override
+ , bhd_payment_relay = Just (PaymentRelay 75 150 100)
+ , bhd_payment_constraints = Just (PaymentConstraints 750100 m)
+ , bhd_allowed_features = empty_features
}
-bpDaveData :: IO BlindedHopData
-bpDaveData = do
- scid <- assertScid 0 0 3
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 34 0)
- , bhdShortChannelId = Just scid
- , bhdPaymentRelay = Just (PaymentRelay 25 100 0)
- , bhdPaymentConstraints = Just (PaymentConstraints 750025 50)
- , bhdAllowedFeatures = Just BS.empty
+bp_dave_data :: IO BlindedHopData
+bp_dave_data = do
+ s <- scid 0 0 3
+ m <- msat 50
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 34 0)
+ , bhd_short_channel_id = Just s
+ , bhd_payment_relay = Just (PaymentRelay 25 100 0)
+ , bhd_payment_constraints = Just (PaymentConstraints 750025 m)
+ , bhd_allowed_features = empty_features
}
-bpEveData :: IO BlindedHopData
-bpEveData = do
- pathId <- unhex "c9cf92f45ade68345bc20ae672e2012f4af487ed4415"
- pure emptyHopData
- { bhdPadding = Just (BS.replicate 28 0)
- , bhdPathId = Just pathId
- , bhdPaymentConstraints = Just (PaymentConstraints 750000 50)
- , bhdAllowedFeatures = Just BS.empty
+bp_eve_data :: IO BlindedHopData
+bp_eve_data = do
+ m <- msat 50
+ path_id <- unhex "c9cf92f45ade68345bc20ae672e2012f4af487ed4415"
+ pure empty_blinded_hop_data
+ { bhd_padding = Just (BS.replicate 28 0)
+ , bhd_path_id = Just path_id
+ , bhd_payment_constraints = Just (PaymentConstraints 750000 m)
+ , bhd_allowed_features = empty_features
}
--- | Per hop: (key the onion is encrypted to, onion received, payload
--- without length prefix).
-bpRoute :: IO [(BS.ByteString, Secp256k1.Projective, BS.ByteString,
- BS.ByteString)]
-bpRoute = do
- alice <- unhex V.onionNodeKey0
- bob <- unhex V.rbBobNodeKey
- -- Carol, Dave and Eve decrypt with their blinded private keys
- carol <- unhex V.rbCarolBlindedPrivKey
- dave <- unhex V.rbDaveBlindedPrivKey
- eve <- unhex V.rbEveBlindedPrivKey
- mapM (\(k, pub, onion, pl) -> do
- p <- unhexPoint pub
- o <- unhex onion
- body <- unhex pl >>= unprefix
- pure (k, p, o, body))
- [ (alice, V.bpAlicePubKey, V.bpAliceOnion, V.bpAlicePayload)
- , (bob, V.bpBobPubKey, V.bpBobOnion, V.bpBobPayload)
- , (carol, V.bpCarolPubKey, V.bpCarolOnion, V.bpCarolPayload)
- , (dave, V.bpDavePubKey, V.bpDaveOnion, V.bpDavePayload)
- , (eve, V.bpEvePubKey, V.bpEveOnion, V.bpEvePayload)
+-- per hop: node key, public key the onion is encrypted to, onion
+-- received, payload (without its length prefix)
+bp_route
+ :: IO [(SecretKey, BOLT1.Point, BS.ByteString, BS.ByteString)]
+bp_route = mapM hop
+ [ (V.onionNodeKey0, V.bpAlicePubKey, V.bpAliceOnion, V.bpAlicePayload)
+ , (V.rbBobNodeKey, V.bpBobPubKey, V.bpBobOnion, V.bpBobPayload)
+ , (V.rbCarolNodeKey, V.bpCarolPubKey, V.bpCarolOnion, V.bpCarolPayload)
+ , (V.rbDaveNodeKey, V.bpDavePubKey, V.bpDaveOnion, V.bpDavePayload)
+ , (V.rbEveNodeKey, V.bpEvePubKey, V.bpEveOnion, V.bpEvePayload)
]
-
-blindedPaymentTests :: TestTree
-blindedPaymentTests = testGroup "blinded-payment-onion-test.json" [
- testCase "construct reproduces the spec onion" $ do
- route <- bpRoute
- sk <- unhex V.bpSessionKey
- ad <- unhex V.bpAssocData
+ where
+ hop (k, p, o, pl) = (,,,) <$> hex_key k <*> hex_point p <*> unhex o
+ <*> (unhex pl >>= unprefix)
+
+blinded_payment_vectors :: TestTree
+blinded_payment_vectors = testGroup "blinded-payment-onion-test.json" [
+ testCase "construct reproduces the onion" $ do
+ route <- bp_route
+ sk <- hex_key V.bpSessionKey
+ assoc <- unhex V.bpAssocData
+ expected <- unhex V.bpAliceOnion
hops <- mapM (\(_, pub, _, body) -> do
- hp <- demand "decodeHopPayload" (decodeHopPayload body)
- encodeHopPayload hp @?= body
+ hp <- right "decode_hop_payload" (decode_hop_payload body)
+ encode_hop_payload hp @?= Right body
pure (Hop pub hp)) route
- expected <- unhex V.bpAliceOnion
- case construct sk hops ad of
- Left e -> assertFailure ("construct failed: " ++ show e)
- Right (pkt, _) -> encodeOnionPacket pkt @?= expected
-
- , testCase "each hop forwards the spec onion" $ do
- route <- bpRoute
- ad <- unhex V.bpAssocData
- let go [] = assertFailure "no hops"
- go ((k, _, onion, body) : rest) = do
- pkt <- demand "decodeOnionPacket" (decodeOnionPacket onion)
- case (process k pkt ad, rest) of
- (Left e, _) -> assertFailure ("process failed: " ++ show e)
- (Right (Forward fi), (_, _, next, _) : _) -> do
- encodeHopPayload (fiPayload fi) @?= body
- encodeOnionPacket (fiNextPacket fi) @?= next
- go rest
- (Right (Receive ri), []) ->
- encodeHopPayload (riPayload ri) @?= body
- (Right _, _) -> assertFailure "unexpected result"
- go route
-
- , testCase "blinded hops decrypt their data and next path key" $ do
- bobKey <- unhex V.rbBobNodeKey
- carolKey <- unhex V.rbCarolNodeKey
- daveKey <- unhex V.rbDaveNodeKey
- eveKey <- unhex V.rbEveNodeKey
- firstPathKey <- unhexPoint V.rbBobPathKey
- bobNext <- unhexPoint V.bpBobNextPathKey
- carolNext <- unhexPoint V.bpCarolNextPathKey
- daveNext <- unhexPoint V.bpDaveNextPathKey
- eveNext <- unhexPoint V.bpEveNextPathKey
- bobBody <- unhex V.bpBobPayload >>= unprefix
- bobHp <- demand "decodeHopPayload" (decodeHopPayload bobBody)
- hpCurrentPathKey bobHp @?= Just (Secp256k1.serialize_point firstPathKey)
- let encOf pl = do
- body <- unhex pl >>= unprefix
- hp <- demand "decodeHopPayload" (decodeHopPayload body)
- demand "encrypted_recipient_data" (hpEncryptedData hp)
- bobData <- bpBobData
- carolData <- bpCarolData
- daveData <- bpDaveData
- eveData <- bpEveData
- hops <- sequence
- [ (,,,,) bobKey firstPathKey <$> encOf V.bpBobPayload
- <*> pure bobData <*> pure bobNext
- , (,,,,) carolKey bobNext <$> encOf V.bpCarolPayload
- <*> pure carolData <*> pure carolNext
- , (,,,,) daveKey carolNext <$> encOf V.bpDavePayload
- <*> pure daveData <*> pure daveNext
- , (,,,,) eveKey daveNext <$> encOf V.bpEvePayload
- <*> pure eveData <*> pure eveNext
- ]
- mapM_ (\(k, pk, enc, dat, npk) ->
- processBlindedHop k pk enc @?= Right (dat, npk)) hops
+ (pkt, _) <- right "construct" (construct sk hops assoc)
+ encode_onion_packet pkt @?= expected
+ , testCase "the route's payloads" $ do
+ route <- bp_route
+ first_pk <- hex_point V.rbBobPathKey
+ s <- scid 0 0 10
+ (a0, a1, a2) <- three =<< mapM msat [110125, 100000, 150000]
+ payloads <- mapM (\(_, _, _, body) ->
+ right "decode_hop_payload" (decode_hop_payload body)) route
+ case payloads of
+ [alice, bob, carol, dave, eve] -> do
+ alice @?= empty_hop_payload
+ { hp_short_channel_id = Just s, hp_amt_to_forward = Just a0
+ , hp_outgoing_cltv_value = Just 749150 }
+ hp_current_path_key bob @?= Just first_pk
+ forM_ [bob, carol, dave] $ \hp -> do
+ assertBool "encrypted data" (hp_encrypted_data hp /= Nothing)
+ hp { hp_encrypted_data = Nothing
+ , hp_current_path_key = Nothing } @?= empty_hop_payload
+ eve { hp_encrypted_data = Nothing } @?= empty_hop_payload
+ { hp_amt_to_forward = Just a1, hp_total_amount_msat = Just a2
+ , hp_outgoing_cltv_value = Just 749000 }
+ _ -> assertFailure "expected 5 payloads"
+ , testCase "each hop processes its onion" $ do
+ route <- bp_route
+ assoc <- unhex V.bpAssocData
+ datas <- sequence [bp_bob_data, bp_carol_data, bp_dave_data,
+ bp_eve_data]
+ nexts <- mapM hex_point
+ [ V.bpBobNextPathKey, V.bpCarolNextPathKey, V.bpDaveNextPathKey
+ , V.bpEveNextPathKey ]
+ -- (hop, path_key received, expected blinded info)
+ let expect = zip3 route
+ (Nothing : Nothing : map Just (take 3 nexts))
+ (Nothing : map Just (zipWith BlindedInfo datas nexts))
+ go [] = assertFailure "no hops"
+ go [((k, _, onion, body), mpk, binfo)] = do
+ pkt <- right "decode" (decode_onion_packet onion)
+ r <- receive (process k pkt assoc mpk)
+ encode_hop_payload (rcv_payload r) @?= Right body
+ rcv_blinded r @?= binfo
+ go (((k, _, onion, body), mpk, binfo) : rest) = do
+ pkt <- right "decode" (decode_onion_packet onion)
+ f <- forward (process k pkt assoc mpk)
+ encode_hop_payload (fwd_payload f) @?= Right body
+ fwd_blinded f @?= binfo
+ forM_ (take 1 rest) $ \((_, _, next, _), _, _) ->
+ encode_onion_packet (fwd_next_packet f) @?= next
+ go rest
+ go expect
+ ]
+
+-- properties -----------------------------------------------------------------
+
+properties :: TestTree
+properties = testGroup "properties" [
+ testProperty "onion packets round-trip" $
+ forAll gen_onion $ \pkt ->
+ decode_onion_packet (encode_onion_packet pkt) === Right pkt
+ , testProperty "hop payloads round-trip" $
+ forAll gen_hop_payload $ \hp ->
+ fmap decode_hop_payload (encode_hop_payload hp) === Right (Right hp)
+ , testProperty "blinded hop data round-trips" $
+ forAll gen_blinded_hop_data $ \d ->
+ fmap decode_blinded_hop_data (encode_blinded_hop_data d)
+ === Right (Right d)
+ , testProperty "failure messages round-trip" $
+ forAll gen_failure_message $ \fm ->
+ fmap decode_failure_message (encode_failure_message fm)
+ === Right (Right fm)
+ , testProperty "wrap_error is an involution" $
+ forAll gen_secret $ \ss ->
+ forAll (gen_bytes 0 600) $ \bs ->
+ wrap_error ss (wrap_error ss (ErrorPacket bs)) === ErrorPacket bs
+ , testProperty "errors are attributed to the failing hop" $
+ forAll (choose (1, 20)) $ \n ->
+ forAll (vectorOf n gen_secret) $ \sss ->
+ forAll (choose (0, n - 1)) $ \i ->
+ forAll gen_failure_message $ \fm ->
+ case drop i sss of
+ ss : _ | Right pkt <- construct_error ss fm ->
+ unwrap_error sss (foldr wrap_error pkt (take i sss))
+ === Attributed i fm
+ _ -> property False
+ , testProperty "routes of 1 to 20 hops construct and process" $
+ forAll (choose (1, 20)) $ \n ->
+ forAll gen_key $ \sk ->
+ forAll (vectorOf n gen_key) $ \keys ->
+ forAll (vectorOf n (gen_route_payload n)) $ \pls ->
+ route_roundtrip sk (zip keys pls)
+ ]
+
+-- construct an onion over a route, then process it at every hop
+route_roundtrip :: SecretKey -> [(SecretKey, HopPayload)] -> Property
+route_roundtrip sk route =
+ case construct sk [Hop (public_key k) hp | (k, hp) <- route] ad of
+ Left e -> counterexample (show e) False
+ Right (pkt, sss) -> length sss === length route .&&. go route sss pkt
+ where
+ go [(k, hp)] [ss] pkt = case process k pkt ad Nothing of
+ Right (Receive r) ->
+ rcv_payload r === hp .&&. property (rcv_shared_secret r == ss)
+ other -> counterexample (show other) False
+ go ((k, hp) : rest) (ss : sss) pkt = case process k pkt ad Nothing of
+ Right (Forward f) ->
+ fwd_payload f === hp
+ .&&. property (fwd_shared_secret f == ss)
+ .&&. go rest sss (fwd_next_packet f)
+ other -> counterexample (show other) False
+ go _ _ _ = property False
+
+-- generators -----------------------------------------------------------------
+
+gen_bytes :: Int -> Int -> Gen BS.ByteString
+gen_bytes lo hi = do
+ n <- choose (lo, hi)
+ BS.pack <$> vectorOf n arbitrary
+
+gen_key :: Gen SecretKey
+gen_key = gen_bytes 32 32 `suchThatMap` secret_key
+
+gen_secret :: Gen SharedSecret
+gen_secret = gen_bytes 32 32 `suchThatMap` shared_secret
+
+gen_point :: Gen BOLT1.Point
+gen_point = do
+ prefix <- elements [0x02, 0x03]
+ x <- gen_bytes 32 32
+ pure (BS.cons prefix x) `suchThatMap` BOLT1.point
+
+gen_msat :: Gen BOLT1.MilliSatoshi
+gen_msat = oneof
+ [ choose (0, 0xffff), choose (0, BOLT1.un_milli_satoshi
+ BOLT1.max_milli_satoshi) ]
+ `suchThatMap` BOLT1.milli_satoshi
+
+gen_scid :: Gen BOLT1.ShortChannelId
+gen_scid = BOLT1.ShortChannelId <$> arbitrary
+
+gen_maybe :: Gen a -> Gen (Maybe a)
+gen_maybe g = oneof [pure Nothing, Just <$> g]
+
+-- extra records with odd types not in the given list
+gen_extra :: [Word64] -> Gen BOLT1.TlvStream
+gen_extra known = do
+ n <- choose (0, 3)
+ ts <- vectorOf n (oneof [choose (1, 300), choose (65536, 70000)])
+ recs <- mapM (\t -> BOLT1.TlvRecord t <$> gen_bytes 0 20)
+ [ t | t <- ts, odd t, t `notElem` known ]
+ let uniq = nubBy (\a b -> BOLT1.tlv_type a == BOLT1.tlv_type b) recs
+ pure uniq `suchThatMap` BOLT1.tlv_stream
+
+gen_onion :: Gen OnionPacket
+gen_onion = OnionPacket
+ <$> arbitrary
+ <*> gen_point
+ <*> (gen_bytes 1300 1300 `suchThatMap` hop_payloads)
+ <*> (gen_bytes 32 32 `suchThatMap` hmac32)
+
+gen_hop_payload :: Gen HopPayload
+gen_hop_payload = HopPayload
+ <$> gen_maybe gen_msat
+ <*> gen_maybe arbitrary
+ <*> gen_maybe gen_scid
+ <*> gen_maybe (PaymentData
+ <$> (gen_bytes 32 32 `suchThatMap` payment_secret)
+ <*> gen_msat)
+ <*> gen_maybe (gen_bytes 0 50)
+ <*> gen_maybe gen_point
+ <*> gen_maybe (gen_bytes 0 50)
+ <*> gen_maybe gen_msat
+ <*> gen_extra []
+
+gen_blinded_hop_data :: Gen BlindedHopData
+gen_blinded_hop_data = BlindedHopData
+ <$> gen_maybe (gen_bytes 0 40)
+ <*> gen_maybe gen_scid
+ <*> gen_maybe gen_point
+ <*> gen_maybe (gen_bytes 0 40)
+ <*> gen_maybe gen_point
+ <*> gen_maybe (PaymentRelay <$> arbitrary <*> arbitrary <*> arbitrary)
+ <*> gen_maybe (PaymentConstraints <$> arbitrary <*> gen_msat)
+ <*> gen_maybe (BOLT9.parse <$> gen_bytes 0 8)
+ <*> gen_extra [1]
+
+gen_failure_message :: Gen FailureMessage
+gen_failure_message = do
+ f <- gen_failure
+ ex <- case f of
+ -- these take every byte after the code, or may be ambiguous with a
+ -- TLV stream
+ UnknownFailure _ _ -> pure no_tlvs
+ InvalidOnionPayload Nothing -> pure no_tlvs
+ _ -> gen_extra []
+ pure (FailureMessage f ex)
+
+gen_failure :: Gen Failure
+gen_failure = oneof
+ [ pure TemporaryNodeFailure
+ , pure PermanentNodeFailure
+ , pure RequiredNodeFeatureMissing
+ , InvalidOnionVersion <$> hash
+ , InvalidOnionHmac <$> hash
+ , InvalidOnionKey <$> hash
+ , TemporaryChannelFailure <$> update
+ , pure PermanentChannelFailure
+ , pure RequiredChannelFeatureMissing
+ , pure UnknownNextPeer
+ , AmountBelowMinimum <$> gen_msat <*> update
+ , FeeInsufficient <$> gen_msat <*> update
+ , IncorrectCltvExpiry <$> arbitrary <*> update
+ , ExpiryTooSoon <$> update
+ , IncorrectOrUnknownPaymentDetails <$> gen_msat <*> arbitrary
+ , FinalIncorrectCltvExpiry <$> arbitrary
+ , FinalIncorrectHtlcAmount <$> gen_msat
+ , ChannelDisabled <$> arbitrary <*> update
+ , pure ExpiryTooFar
+ , InvalidOnionPayload <$> gen_maybe ((,) <$> arbitrary <*> arbitrary)
+ , pure MppTimeout
+ , InvalidOnionBlinding <$> hash
+ , UnknownFailure <$> (arbitrary `suchThat` unknown) <*> gen_bytes 0 20
]
+ where
+ hash = gen_bytes 32 32 `suchThatMap` onion_hash
+ update = gen_bytes 0 100
+ unknown c = c `notElem`
+ [ 0x2002, 0x6002, 0x6003, 0xc004, 0xc005, 0xc006, 0x1007, 0x4008
+ , 0x4009, 0x400a, 0x100b, 0x100c, 0x100d, 0x100e, 0x400f, 0x0012
+ , 0x0013, 0x1014, 0x0015, 0x4016, 0x0017, 0xc018 ]
+
+-- a payload whose shift size fits n hops in 1300 bytes
+--
+-- The typed fields take at most 26 bytes; an odd record of type 65537
+-- adds at most 8 bytes of framing plus its value. With a 3-byte length
+-- prefix and 32-byte HMAC a hop then shifts at most 69 bytes plus the
+-- value's length.
+gen_route_payload :: Int -> Gen HopPayload
+gen_route_payload n = do
+ amt <- gen_msat
+ cltv <- arbitrary
+ s <- gen_maybe gen_scid
+ let budget = 1300 `div` n - 69
+ ex <- if budget < 0
+ then pure no_tlvs
+ else do
+ v <- gen_bytes 0 budget
+ pure (BOLT1.TlvRecord 65537 v : [])
+ `suchThatMap` BOLT1.tlv_stream
+ pure empty_hop_payload
+ { hp_amt_to_forward = Just amt
+ , hp_outgoing_cltv_value = Just cltv
+ , hp_short_channel_id = s
+ , hp_extra = ex
+ }
