commit 0b9fe954c950237b4d9fd3df076ca08282442572
parent ae0154f96d5c6f866723e18ce1c71314104dcd4c
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 14:55:32 +0400
Merge branch 'impl/modernize': 0.1.0 API
Prepares ppad-bolt3 0.1.0 against lightning/bolts@1aadb719 (the spec
copy in etc/ is updated), ppad-bolt1 0.1.0 and ppad-tx 0.2.0.
API (breaking throughout; only Lightning.Protocol.BOLT3 is exposed):
- bolt1's abstract types and bounded amounts replace bolt3's Pubkey,
Point and amount re-exports; role newtypes wrap bolt1's Point.
Types with invariants are abstract; every type has NFData.
- CommitmentFormat (StaticRemotekey | Anchors) replaces
ChannelFeatures. zero_fee_commitments is not supported (README).
- CommitmentContext is owner-relative: build_commitment_tx orders the
payment basepoints for the obscured commitment number by
cc_is_funder. It fails rather than build an output-less transaction.
- OutputType carries the HTLC an output pays; build_htlc_tx picks
HTLC-timeout or HTLC-success by direction and fails if the fee
exceeds the amount.
- Separate legacy and option_simple_close closing builders with
spec-shaped inputs (signer's dust limit and optional omission of its
output; closer pays, explicit output choice, zero-value OP_RETURN
outputs that are never trimmed).
- to_remote scripts split into witness script and scriptPubKey;
witness functions append the witness script; HTLC transaction input
witnesses and remote_htlc_sighash (SIGHASH_SINGLE|ANYONECANPAY under
anchors).
- Seed, SecretIndex and bolt1's PerCommitmentSecret for the shachain;
an abstract SecretStore with redacted Show and
secret_store/un_secret_store for persistence;
commitment_secret_index.
- derive_commitment_keys, derive_privkey and derive_revocationprivkey
(constant-time arithmetic modulo the group order, tested against
Appendices C and E).
- encode_tx is encode_commitment_tx; Validate, Decode, Encode,
Internal and the redundant derivation, witness-encoding and
trimming functions are removed.
Tests use the public API and cover every Appendix B-F vector plus the
spec's witnesses, closing transactions, accepter-side obscuring, key
derivation properties and the rejection paths. Benchmarks force their
results and use a filled secret store. README and CHANGELOG are
written for the release; version 0.1.0.
Diffstat:
21 files changed, 3433 insertions(+), 4359 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -3,13 +3,16 @@
Haskell implementation of BOLT #3 (Lightning Network transactions).
Specification: https://github.com/lightning/bolts/blob/master/03-transactions.md
+(implemented as of lightning/bolts@1aadb719; copy in `etc/03-transactions.md`).
## Project Structure
-- `lib/` - library source (Lightning.Protocol.BOLT3)
-- `test/` - tests (tasty + tasty-hunit)
+- `lib/` - library source (public API: Lightning.Protocol.BOLT3;
+ submodules are internal)
+- `test/` - tests (tasty, tasty-hunit, tasty-quickcheck), public API only;
+ spec vectors in `test/Vectors.hs`
- `bench/` - benchmarks (criterion for timing, weigh for allocations)
-- `etc/` - reference materials (BOLT spec)
+- `etc/` - reference materials (BOLT spec, pinned upstream commit)
- `flake.nix` - nix flake for dependency and build management
- `ppad-bolt3.cabal` - cabal package definition
- `CLAUDE.md` / `AGENTS.md` - keep these in sync
@@ -38,6 +41,9 @@ Use ppad libraries (github.com/ppad-tech, git.ppad.tech) liberally.
Use only minimal external dependencies. Prefer GHC's core/boot libraries
(base, bytestring, primitive, etc.).
+Current dependencies: ppad-bolt1, ppad-ripemd160, ppad-secp256k1,
+ppad-sha256, ppad-tx.
+
**Ask for explicit confirmation before adding any library outside of:**
- GHC boot/core libraries
- ppad-* libraries
@@ -139,6 +145,4 @@ When planning work:
The flake.nix follows ppad conventions:
- Uses ppad-nixpkgs as base
- Follows references to avoid duplication
-- Supports LLVM backend via cabal flag
- Provides devShell with ghc, cabal, cc, llvm
-
diff --git a/CHANGELOG b/CHANGELOG
@@ -0,0 +1,69 @@
+# Changelog
+
+- 0.1.0 (UNRELEASED)
+ * A substantial rewrite, with breaking changes throughout:
+
+ * Ports to ppad-bolt1 0.1.0 and ppad-tx 0.2.0. Amounts, points,
+ hashes and per-commitment secrets are bolt1's types (amounts are
+ bounded, with checked arithmetic); bolt3's Pubkey is merged into
+ bolt1's Point, wrapped in role newtypes (RevocationPubkey, etc.).
+
+ * The API is exported from Lightning.Protocol.BOLT3 alone, with
+ snake_case names. Types with invariants (CommitmentNumber,
+ SecretIndex, Seed, Seckey, SecretStore) are abstract, and every
+ type has an NFData instance.
+
+ * ChannelFeatures is replaced by CommitmentFormat (StaticRemotekey
+ or Anchors).
+
+ * CommitmentContext is owner-relative throughout: the payment
+ basepoints are ordered for the obscured commitment number by
+ cc_is_funder. build_commitment_tx fails rather than produce a
+ transaction without outputs.
+
+ * OutputType carries the HTLC an output pays. build_htlc_tx replaces
+ build_htlc_timeout_tx and build_htlc_success_tx, choosing by HTLC
+ direction, and fails if the fee exceeds the amount.
+
+ * Closing transactions have separate builders with spec-shaped
+ inputs: build_legacy_closing_tx applies the signer's dust limit to
+ both outputs and can omit the signer's output; build_closing_tx
+ (option_simple_close) charges the closer, takes an explicit choice
+ of outputs, and gives OP_RETURN outputs amount zero.
+
+ * to_remote_script is split into to_remote_witness_script and
+ to_remote_script_pubkey. Witness functions append the witness
+ script and take typed keys; funding_witness orders signatures by
+ pubkey. Adds htlc_success_witness, htlc_timeout_witness and
+ remote_htlc_sighash.
+
+ * Per-commitment secrets use Seed, SecretIndex and bolt1's
+ PerCommitmentSecret. SecretStore is abstract, with a redacted
+ Show instance and secret_store/un_secret_store for persistence.
+ Adds commitment_secret_index.
+
+ * Adds derive_commitment_keys, derive_privkey and
+ derive_revocationprivkey.
+
+ * Renames encode_tx to encode_commitment_tx, and documents the
+ encoders as producing unsigned, witness-free serializations.
+
+ * Removes the Validate, Decode, Encode and Internal modules, the
+ role-specific key derivation functions, encode_tx_for_signing,
+ encode_witness, encode_funding_witness, has_anchors, sort_outputs,
+ trimmed_htlcs, untrimmed_htlcs, derive_secret, the HTLC output
+ script aliases, the weight constants and unused record fields.
+
+ * Fixes insert_secret, which discarded the entries needed to derive
+ older secrets and accepted invalid secret sequences.
+
+ * Fixes closing transactions, which used each party's dust limit in
+ legacy closes, and charged the funder and paid OP_RETURN outputs in
+ option_simple_close.
+
+ * Rejects key derivations yielding the point at infinity.
+
+ * Tests cover every BOLT #3 Appendix B-F vector.
+
+- 0.0.1 (2026-04-18)
+ * Initial release.
diff --git a/CLAUDE.md b/CLAUDE.md
@@ -3,13 +3,16 @@
Haskell implementation of BOLT #3 (Lightning Network transactions).
Specification: https://github.com/lightning/bolts/blob/master/03-transactions.md
+(implemented as of lightning/bolts@1aadb719; copy in `etc/03-transactions.md`).
## Project Structure
-- `lib/` - library source (Lightning.Protocol.BOLT3)
-- `test/` - tests (tasty + tasty-hunit)
+- `lib/` - library source (public API: Lightning.Protocol.BOLT3;
+ submodules are internal)
+- `test/` - tests (tasty, tasty-hunit, tasty-quickcheck), public API only;
+ spec vectors in `test/Vectors.hs`
- `bench/` - benchmarks (criterion for timing, weigh for allocations)
-- `etc/` - reference materials (BOLT spec)
+- `etc/` - reference materials (BOLT spec, pinned upstream commit)
- `flake.nix` - nix flake for dependency and build management
- `ppad-bolt3.cabal` - cabal package definition
- `CLAUDE.md` / `AGENTS.md` - keep these in sync
@@ -38,6 +41,9 @@ Use ppad libraries (github.com/ppad-tech, git.ppad.tech) liberally.
Use only minimal external dependencies. Prefer GHC's core/boot libraries
(base, bytestring, primitive, etc.).
+Current dependencies: ppad-bolt1, ppad-ripemd160, ppad-secp256k1,
+ppad-sha256, ppad-tx.
+
**Ask for explicit confirmation before adding any library outside of:**
- GHC boot/core libraries
- ppad-* libraries
@@ -139,6 +145,4 @@ When planning work:
The flake.nix follows ppad conventions:
- Uses ppad-nixpkgs as base
- Follows references to avoid duplication
-- Supports LLVM backend via cabal flag
- Provides devShell with ghc, cabal, cc, llvm
-
diff --git a/README.md b/README.md
@@ -4,10 +4,15 @@
[](https://docs.ppad.tech/bolt3)
-A pure Haskell implementation of [BOLT #3][bolt3] (Lightning Network
-Bitcoin transaction and script formats), including commitment
-transactions, HTLC transactions, closing transactions, per-commitment
-key derivation, and secret storage.
+A pure Haskell implementation of [BOLT #3][bolt3], the Lightning
+Network's Bitcoin transaction and script formats: commitment, HTLC and
+closing transactions, their output scripts and witnesses,
+per-commitment key derivation, and per-commitment secret generation and
+storage.
+
+Amounts, points and secrets use the types of [ppad-bolt1][bolt1], and
+transactions convert to [ppad-tx][tx] for txids, sighashes and
+serialization.
## Usage
@@ -15,42 +20,102 @@ A sample GHCi session:
```
> :set -XOverloadedStrings
- >
+ > import qualified Bitcoin.Prim.Tx as BT
> import qualified Data.ByteString as BS
- > import qualified Data.ByteString.Base16 as B16
+ > import qualified Lightning.Protocol.BOLT1 as BOLT1
> import Lightning.Protocol.BOLT3
>
- > -- key derivation (BOLT #3 Appendix E test vector)
- > let basepoint = Point (B16.decodeLenient "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2")
- > let perCommitment = PerCommitmentPoint (Point (B16.decodeLenient "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"))
- > let Just (Pubkey derived) = derive_pubkey basepoint perCommitment
- > B16.encode derived
- "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"
+ > -- per-commitment secrets come from a seed; secrets aren't shown
+ > let Just sd = seed (BS.replicate 32 0xff)
+ > let Just cn = commitment_number 0
+ > let i = commitment_secret_index cn
+ > let secret = generate_from_seed sd i
+ > secret
+ PerCommitmentSecret <redacted>
>
- > -- secret generation (BOLT #3 Appendix D test vector)
- > let seed = BS.replicate 32 0xFF
- > B16.encode (generate_from_seed seed 281474976710655)
- "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"
+ > -- the peer keeps revealed secrets in compact storage
+ > let Just store = insert_secret secret i empty_secret_store
+ > fmap (== secret) (derive_old_secret i store)
+ Just True
>
- > -- fee calculation
- > let feerate = FeeratePerKw 5000
- > let features = ChannelFeatures { cf_option_anchors = False }
- > commitment_fee feerate features 2
- Satoshi 5340
+ > -- the commitment's per-commitment point, and a private key for it
+ > let Just pcp = derive_per_commitment_point secret
+ > let Just base = seckey (BS.pack [1 .. 32])
+ > derive_privkey base pcp
+ Just (Seckey <redacted>)
>
- > -- HTLC trimming
- > let dust = DustLimit (Satoshi 546)
- > htlc_trim_threshold dust feerate features HTLCOffered
+ > -- fees and HTLC trimming
+ > commitment_fee (FeeratePerKw 5000) StaticRemotekey 2
+ Satoshi 5340
+ > let Just dust = fmap DustLimit (BOLT1.satoshi 546)
+ > htlc_trim_threshold dust (FeeratePerKw 5000) StaticRemotekey HTLCOffered
Satoshi 3861
+ >
+ > -- an option_simple_close transaction: the closer pays the fee, and
+ > -- its OP_RETURN output has amount zero
+ > let Just txid = BT.mkTxId (BS.replicate 32 0x01)
+ > let Just [closer, closee] = traverse BOLT1.milli_satoshi [6000000, 4000000]
+ > let Just fee = BOLT1.satoshi 500
+ > let p2wpkh = Script . BS.append "\x00\x14" . BS.replicate 20
+ :{
+ ghci| let close = ClosingContext {
+ ghci| clc_funding_outpoint = BT.OutPoint txid 0
+ ghci| , clc_closer_msat = closer
+ ghci| , clc_closee_msat = closee
+ ghci| , clc_closer_script = Script "\x6a"
+ ghci| , clc_closee_script = p2wpkh 0x22
+ ghci| , clc_fee = fee
+ ghci| , clc_locktime = Locktime 0
+ ghci| , clc_outputs = CloserAndCloseeOutputs
+ ghci| }
+ ghci| :}
+ > let Just tx = build_closing_tx close
+ > fmap clo_value (cltx_outputs tx)
+ Satoshi 0 :| [Satoshi 4000]
+ > BS.length (encode_closing_tx tx)
+ 92
```
## Documentation
-Haddocks are hosted at [docs.ppad.tech/bolt3][hadoc].
+Haddocks (API documentation, etc.) are hosted at
+[docs.ppad.tech/bolt3](https://docs.ppad.tech/bolt3).
+
+## Specification
+
+This library implements BOLT #3 as of lightning/bolts commit
+[1aadb719][spec] (2026-09-21); a copy lives in `etc/`. Every test
+vector in Appendices B through F is checked byte for byte.
+
+Not implemented:
+
+* `zero_fee_commitments` (version 3 commitment and HTLC transactions,
+ the `shared_anchor` P2A output, and Appendix H). Only the
+ `option_static_remotekey` and `option_anchors` commitment formats are
+ supported.
+* Funding transaction construction (including Appendix G's dual-funded
+ vectors): the library provides the funding output's script and
+ witness only.
+
+The library builds unsigned transactions; signatures are made with
+[ppad-secp256k1][secp] over sighashes from ppad-tx. Spending
+transactions for on-chain resolution belong to BOLT #5.
+
+## Performance
+
+The aim is best-in-class performance for pure Haskell code. Run the
+benchmarks with:
+
+```
+$ cabal bench
+```
## Security
-This is a pre-release version and makes no security guarantees whatsoever.
+This library has received no security audit. Secret material (seeds,
+secret keys, per-commitment secrets and their storage) is kept out of
+`Show` output, and private-key derivation uses constant-time
+arithmetic.
## Development
@@ -64,12 +129,15 @@ $ nix develop
Then do e.g.:
```
-$ cabal build
-$ cabal test
-$ cabal bench
+$ cabal repl ppad-bolt3
```
+to get a REPL for the main library.
+
[bolt3]: https://github.com/lightning/bolts/blob/master/03-transactions.md
+[bolt1]: https://git.ppad.tech/bolt1
+[tx]: https://git.ppad.tech/tx
+[secp]: https://git.ppad.tech/secp256k1
+[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
-[hadoc]: https://docs.ppad.tech/bolt3
diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Fixtures (
+ Fixtures(..)
+ , fixtures
+ , tex
+ ) where
+
+import qualified Bitcoin.Prim.Tx as BT
+import Control.DeepSeq (NFData, force)
+import Control.Exception (evaluate)
+import Control.Monad (foldM)
+import qualified Crypto.Curve.Secp256k1 as S
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import GHC.Generics (Generic)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT3
+
+-- | Shared wNAF context.
+tex :: S.Context
+tex = S.precompute
+{-# NOINLINE tex #-}
+
+data Fixtures = Fixtures
+ { fx_secret :: !BOLT1.PerCommitmentSecret
+ , fx_seed :: !Seed
+ , fx_basepoint :: !BOLT1.Point
+ , fx_pcp :: !PerCommitmentPoint
+ , fx_rbp :: !RevocationBasepoint
+ , fx_seckey :: !Seckey
+ , fx_local_bps :: !Basepoints
+ , fx_remote_bps :: !Basepoints
+ , fx_local_fund :: !FundingPubkey
+ , fx_remote_fund :: !FundingPubkey
+ , fx_store :: !SecretStore
+ , fx_store_next :: !(SecretIndex, BOLT1.PerCommitmentSecret)
+ , fx_store_oldest :: !SecretIndex
+ , fx_ctx_simple :: !CommitmentContext
+ , fx_ctx_htlcs :: !CommitmentContext
+ , fx_ctx_anchors :: !CommitmentContext
+ , fx_commit :: !CommitmentTx
+ , fx_htlc_ctx :: !HTLCContext
+ , fx_htlc_tx :: !HTLCTx
+ , fx_closing :: !ClosingContext
+ , fx_legacy :: !LegacyClosingContext
+ , fx_closing_tx :: !ClosingTx
+ } deriving Generic
+
+instance NFData Fixtures
+
+hex :: BS.ByteString -> Maybe BS.ByteString
+hex = B16.decode
+
+pt :: BS.ByteString -> Maybe BOLT1.Point
+pt h = hex h >>= BOLT1.point
+
+-- | Benchmark fixtures, from the BOLT #3 Appendix C parameters, fully
+-- evaluated.
+fixtures :: IO Fixtures
+fixtures = maybe (fail "invalid fixtures") (evaluate . force) build
+
+build :: Maybe Fixtures
+build = do
+ secret <- BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])
+ sd <- seed (BS.replicate 32 0xff)
+ basepoint <- pt
+ "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"
+ pcp <- PerCommitmentPoint <$> pt
+ "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
+ sk <- seckey (BS.pack [0 .. 31])
+
+ local_pay <- pt
+ "034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa"
+ remote_pay <- pt
+ "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"
+ local_delayed <- pt
+ "023c72addb4fdf09af94f0c94d7fe92a386a7e70cf8a1d85916386bb2535c7b1b1"
+ remote_rev <- pt
+ "02466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27"
+ local_fund <- FundingPubkey <$> pt
+ "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"
+ remote_fund <- FundingPubkey <$> pt
+ "030e9f7b623d2ccc7c9bd44d66d5ce21ce504c0acf6385a132cec6d3c39fa711c1"
+ let local_bps = Basepoints (RevocationBasepoint local_pay)
+ (PaymentBasepoint local_pay) (DelayedPaymentBasepoint local_delayed)
+ (HtlcBasepoint local_pay)
+ remote_bps = Basepoints (RevocationBasepoint remote_rev)
+ (PaymentBasepoint remote_pay) (DelayedPaymentBasepoint remote_pay)
+ (HtlcBasepoint remote_pay)
+ keys <- derive_commitment_keys local_bps local_fund remote_bps remote_fund
+ pcp
+
+ -- a store holding the 2^14 - 1 most recent secrets; the next index has
+ -- 14 trailing zeros, so inserting it checks every lower bucket
+ let n = 16383 :: Int
+ idxs <- traverse secret_index (take n [0xFFFFFFFFFFFF, 0xFFFFFFFFFFFE ..])
+ store <- foldM (\st i -> insert_secret (generate_from_seed sd i) i st)
+ empty_secret_store idxs
+ next <- secret_index (0xFFFFFFFFFFFF - fromIntegral n)
+ oldest <- secret_index 0xFFFFFFFFFFFF
+
+ txid <- hex
+ "8984484a580b825b9972d7adb15050b3ab624ccd731946b3eeddb92f4e7ef6be"
+ let outpoint = BT.OutPoint (BT.TxId (BS.reverse txid)) 0
+ cn <- commitment_number 42
+ dust <- DustLimit <$> BOLT1.satoshi 546
+ to_local <- BOLT1.milli_satoshi 6988000000
+ to_remote <- BOLT1.milli_satoshi 3000000000
+ htlcs <- traverse htlc
+ [ (HTLCReceived, 1000000, 500, 0x00), (HTLCReceived, 2000000, 501, 0x01)
+ , (HTLCOffered, 2000000, 502, 0x02), (HTLCOffered, 3000000, 503, 0x03)
+ , (HTLCReceived, 4000000, 504, 0x04) ]
+ let ctx_simple = CommitmentContext
+ { cc_funding_outpoint = outpoint
+ , cc_commitment_number = cn
+ , cc_local_payment_bp = PaymentBasepoint local_pay
+ , cc_remote_payment_bp = PaymentBasepoint remote_pay
+ , cc_to_self_delay = ToSelfDelay 144
+ , cc_dust_limit = dust
+ , cc_feerate = FeeratePerKw 15000
+ , cc_format = StaticRemotekey
+ , cc_is_funder = True
+ , cc_to_local_msat = to_local
+ , cc_to_remote_msat = to_remote
+ , cc_htlcs = []
+ , cc_keys = keys
+ }
+ ctx_htlcs = ctx_simple { cc_feerate = FeeratePerKw 644
+ , cc_htlcs = htlcs }
+ ctx_anchors = ctx_htlcs { cc_format = Anchors }
+ commit <- build_commitment_tx ctx_htlcs
+ htlc_out <- case htlcs of
+ (h : _) -> Just h
+ [] -> Nothing
+ let htlc_ctx = HTLCContext
+ { hc_commitment_txid = BT.txid (commitment_to_tx commit)
+ , hc_output_index = 0
+ , hc_htlc = htlc_out
+ , hc_to_self_delay = ToSelfDelay 144
+ , hc_feerate = FeeratePerKw 644
+ , hc_format = StaticRemotekey
+ , hc_revocation_pubkey = ck_revocation_pubkey keys
+ , hc_local_delayed = ck_local_delayed keys
+ }
+ htlc_tx <- build_htlc_tx htlc_ctx
+
+ fee <- BOLT1.satoshi 1000
+ let p2wpkh b = Script (BS.pack [0x00, 0x14] <> BS.replicate 20 b)
+ closing = ClosingContext
+ { clc_funding_outpoint = outpoint
+ , clc_closer_msat = to_local
+ , clc_closee_msat = to_remote
+ , clc_closer_script = p2wpkh 0x11
+ , clc_closee_script = p2wpkh 0x22
+ , clc_fee = fee
+ , clc_locktime = Locktime 0
+ , clc_outputs = CloserAndCloseeOutputs
+ }
+ legacy = LegacyClosingContext
+ { lcc_funding_outpoint = outpoint
+ , lcc_local_msat = to_local
+ , lcc_remote_msat = to_remote
+ , lcc_local_script = p2wpkh 0x11
+ , lcc_remote_script = p2wpkh 0x22
+ , lcc_dust_limit = dust
+ , lcc_fee = fee
+ , lcc_is_funder = True
+ , lcc_omit_local = False
+ }
+ closing_tx <- build_closing_tx closing
+
+ pure Fixtures
+ { fx_secret = secret
+ , fx_seed = sd
+ , fx_basepoint = basepoint
+ , fx_pcp = pcp
+ , fx_rbp = RevocationBasepoint basepoint
+ , fx_seckey = sk
+ , fx_local_bps = local_bps
+ , fx_remote_bps = remote_bps
+ , fx_local_fund = local_fund
+ , fx_remote_fund = remote_fund
+ , fx_store = store
+ , fx_store_next = (next, generate_from_seed sd next)
+ , fx_store_oldest = oldest
+ , fx_ctx_simple = ctx_simple
+ , fx_ctx_htlcs = ctx_htlcs
+ , fx_ctx_anchors = ctx_anchors
+ , fx_commit = commit
+ , fx_htlc_ctx = htlc_ctx
+ , fx_htlc_tx = htlc_tx
+ , fx_closing = closing
+ , fx_legacy = legacy
+ , fx_closing_tx = closing_tx
+ }
+ where
+ htlc (dir, amt, expiry, b) = do
+ a <- BOLT1.milli_satoshi amt
+ ph <- BOLT1.payment_hash (SHA256.hash (BS.replicate 32 b))
+ pure (HTLC dir a ph (CltvExpiry expiry))
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -1,478 +1,82 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Main where
-import qualified Crypto.Curve.Secp256k1 as S
-import Control.DeepSeq (NFData(..))
import Criterion.Main
-import Data.Word (Word64)
-import qualified Data.ByteString as BS
+import Fixtures
import Lightning.Protocol.BOLT3
-import Lightning.Protocol.BOLT3.Types
- ( Pubkey(..), Point(..)
- , PaymentHash(..), PerCommitmentPoint(..)
- , PerCommitmentSecret(..)
- , CommitmentNumber(..)
- )
-
--- NFData instances for benchmarking
--- (Satoshi, MilliSatoshi, Point, PaymentHash, PerCommitmentSecret
--- derive NFData via ppad-bolt1)
-
-instance NFData Pubkey where
- rnf (Pubkey x) = rnf x
-
-instance NFData PerCommitmentPoint where
- rnf (PerCommitmentPoint x) = rnf x
-
-instance NFData RevocationPubkey where
- rnf (RevocationPubkey x) = rnf x
-
-instance NFData RevocationBasepoint where
- rnf (RevocationBasepoint x) = rnf x
-
-instance NFData ChannelFeatures where
- rnf (ChannelFeatures x) = rnf x
-
-instance NFData FeeratePerKw where
- rnf (FeeratePerKw x) = rnf x
-
-instance NFData DustLimit where
- rnf (DustLimit x) = rnf x
-
-instance NFData CltvExpiry where
- rnf (CltvExpiry x) = rnf x
-
-instance NFData HTLCDirection where
- rnf HTLCOffered = ()
- rnf HTLCReceived = ()
-
-instance NFData HTLC where
- rnf (HTLC d a h c) = rnf d `seq` rnf a `seq` rnf h `seq` rnf c
-
--- Transaction types
-instance NFData CommitmentTx where
- rnf (CommitmentTx v l i s o f) =
- rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f
-
-instance NFData HTLCTx where
- rnf (HTLCTx v l i s ov os) =
- rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os
-
-instance NFData ClosingTx where
- rnf (ClosingTx v l i s o f) =
- rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f
-
--- Output types
-instance NFData TxOutput where
- rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t
-
-instance NFData OutputType where
- rnf OutputToLocal = ()
- rnf OutputToRemote = ()
- rnf OutputLocalAnchor = ()
- rnf OutputRemoteAnchor = ()
- rnf (OutputOfferedHTLC e) = rnf e
- rnf (OutputReceivedHTLC e) = rnf e
-
--- Primitives
-instance NFData Script where
- rnf (Script bs) = rnf bs
-
-
-instance NFData Sequence where
- rnf (Sequence x) = rnf x
-
-instance NFData Locktime where
- rnf (Locktime x) = rnf x
-
-instance NFData ToSelfDelay where
- rnf (ToSelfDelay x) = rnf x
-
-instance NFData CommitmentNumber where
- rnf (CommitmentNumber x) = rnf x
-
--- Context types
-instance NFData CommitmentContext where
- rnf ctx = rnf (cc_funding_outpoint ctx) `seq`
- rnf (cc_commitment_number ctx) `seq`
- rnf (cc_htlcs ctx) `seq`
- rnf (cc_keys ctx)
-
-instance NFData CommitmentKeys where
- rnf keys = rnf (ck_revocation_pubkey keys) `seq`
- rnf (ck_local_delayed keys) `seq`
- rnf (ck_local_htlc keys) `seq`
- rnf (ck_remote_htlc keys)
-
-instance NFData HTLCContext where
- rnf ctx = rnf (hc_commitment_txid ctx) `seq`
- rnf (hc_htlc ctx)
-
-instance NFData ClosingContext where
- rnf ctx = rnf (clc_funding_outpoint ctx) `seq`
- rnf (clc_local_amount ctx) `seq`
- rnf (clc_remote_amount ctx)
-
--- Key types
-instance NFData LocalDelayedPubkey where
- rnf (LocalDelayedPubkey p) = rnf p
-
-instance NFData RemoteDelayedPubkey where
- rnf (RemoteDelayedPubkey p) = rnf p
-
-instance NFData LocalHtlcPubkey where
- rnf (LocalHtlcPubkey p) = rnf p
-
-instance NFData RemoteHtlcPubkey where
- rnf (RemoteHtlcPubkey p) = rnf p
-
-instance NFData LocalPubkey where
- rnf (LocalPubkey p) = rnf p
-
-instance NFData RemotePubkey where
- rnf (RemotePubkey p) = rnf p
-
-instance NFData PaymentBasepoint where
- rnf (PaymentBasepoint p) = rnf p
-
-instance NFData DelayedPaymentBasepoint where
- rnf (DelayedPaymentBasepoint p) = rnf p
-
-instance NFData HtlcBasepoint where
- rnf (HtlcBasepoint p) = rnf p
-
-instance NFData FundingPubkey where
- rnf (FundingPubkey p) = rnf p
-
--- Secret storage (SecretStore is a newtype over list)
-instance NFData SecretStore where
- rnf store = rnf (derive_old_secret 0 store)
-
--- Validation errors
-instance NFData ValidationError where
- rnf (InvalidVersion a b) = rnf a `seq` rnf b
- rnf (InvalidLocktime a) = rnf a
- rnf (InvalidSequence a) = rnf a
- rnf InvalidOutputOrdering = ()
- rnf (DustLimitViolation a b c) = rnf a `seq` rnf b `seq` rnf c
- rnf MissingAnchorOutput = ()
- rnf (InvalidAnchorValue a) = rnf a
- rnf (InvalidFee a b) = rnf a `seq` rnf b
- rnf (InvalidHTLCLocktime a b) = rnf a `seq` rnf b
- rnf (InvalidHTLCSequence a b) = rnf a `seq` rnf b
- rnf NoOutputs = ()
- rnf (TooManyOutputs a) = rnf a
-
--- | Precomputed wNAF context, built once and reused across the
--- apostrophe-suffixed benches. NOINLINE keeps it from being
--- re-created on every call site.
-tex :: S.Context
-tex = S.precompute
-{-# NOINLINE tex #-}
main :: IO ()
-main = defaultMain [
- bgroup "key derivation" [
- bench "derive_pubkey" $
- whnf (derive_pubkey basepoint) perCommitmentPoint
- , bench "derive_pubkey'" $
- whnf (derive_pubkey' tex basepoint) perCommitmentPoint
- , bench "derive_per_commitment_point" $
- whnf derive_per_commitment_point samplePcs
- , bench "derive_per_commitment_point'" $
- whnf (derive_per_commitment_point' tex)
- samplePcs
- , bench "derive_revocationpubkey" $
- whnf (derive_revocationpubkey revocationBasepoint) perCommitmentPoint
- ]
- , bgroup "secret generation" [
- bench "generate_from_seed (final node)" $
- whnf (generate_from_seed seed) 281474976710655
- , bench "generate_from_seed (first node)" $
- whnf (generate_from_seed seed) 0
- ]
- , bgroup "fee calculation" [
- bench "commitment_fee (no anchors, 0 htlcs)" $
- whnf (commitment_fee feerate noAnchors) 0
- , bench "commitment_fee (no anchors, 10 htlcs)" $
- whnf (commitment_fee feerate noAnchors) 10
- , bench "commitment_fee (anchors, 10 htlcs)" $
- whnf (commitment_fee feerate withAnchors) 10
- , bench "htlc_timeout_fee" $
- whnf (htlc_timeout_fee feerate) noAnchors
- , bench "htlc_success_fee" $
- whnf (htlc_success_fee feerate) noAnchors
- ]
- , bgroup "trimming" [
- bench "is_trimmed (offered, not trimmed)" $
- whnf (is_trimmed dust feerate noAnchors) htlcNotTrimmed
- , bench "is_trimmed (offered, trimmed)" $
- whnf (is_trimmed dust feerate noAnchors) htlcTrimmed
- , bench "htlc_trim_threshold (offered)" $
- whnf (htlc_trim_threshold dust feerate noAnchors) HTLCOffered
+main = do
+ fx <- fixtures
+ let (next_idx, next_secret) = fx_store_next fx
+ keys = ck fx
+ defaultMain [
+ bgroup "keys" [
+ bench "derive_per_commitment_point" $
+ nf derive_per_commitment_point (fx_secret fx)
+ , bench "derive_per_commitment_point'" $
+ nf (derive_per_commitment_point' tex) (fx_secret fx)
+ , bench "derive_pubkey" $
+ nf (derive_pubkey (fx_basepoint fx)) (fx_pcp fx)
+ , bench "derive_revocationpubkey" $
+ nf (derive_revocationpubkey (fx_rbp fx)) (fx_pcp fx)
+ , bench "derive_commitment_keys" $
+ nf (derive_commitment_keys (fx_local_bps fx) (fx_local_fund fx)
+ (fx_remote_bps fx) (fx_remote_fund fx)) (fx_pcp fx)
+ , bench "derive_commitment_keys'" $
+ nf (derive_commitment_keys' tex (fx_local_bps fx) (fx_local_fund fx)
+ (fx_remote_bps fx) (fx_remote_fund fx)) (fx_pcp fx)
+ , bench "derive_privkey" $
+ nf (derive_privkey (fx_seckey fx)) (fx_pcp fx)
+ , bench "derive_revocationprivkey" $
+ nf (derive_revocationprivkey (fx_seckey fx)) (fx_secret fx)
+ ]
+ , bgroup "secrets" [
+ bench "generate_from_seed (index 2^48 - 1)" $
+ nf (generate_from_seed (fx_seed fx)) (fx_store_oldest fx)
+ , bench "insert_secret (14 lower buckets)" $
+ nf (insert_secret next_secret next_idx) (fx_store fx)
+ , bench "derive_old_secret (index 2^48 - 1)" $
+ nf (derive_old_secret (fx_store_oldest fx)) (fx_store fx)
+ , bench "secret_store . un_secret_store" $
+ nf (secret_store . un_secret_store) (fx_store fx)
+ ]
+ , bgroup "scripts" [
+ bench "funding_script" $
+ nf (funding_script (fx_local_fund fx)) (fx_remote_fund fx)
+ , bench "to_local_script" $
+ nf (to_local_script (ck_revocation_pubkey keys) (ToSelfDelay 144))
+ (ck_local_delayed keys)
+ , bench "offered_htlc_script" $
+ nf (offered_htlc_script (ck_revocation_pubkey keys)
+ (ck_remote_htlc keys) (ck_local_htlc keys) (hash fx))
+ Anchors
+ , bench "received_htlc_script" $
+ nf (received_htlc_script (ck_revocation_pubkey keys)
+ (ck_remote_htlc keys) (ck_local_htlc keys) (hash fx)
+ (CltvExpiry 500))
+ Anchors
+ ]
+ , bgroup "transactions" [
+ bench "build_commitment_tx (no htlcs)" $
+ nf build_commitment_tx (fx_ctx_simple fx)
+ , bench "build_commitment_tx (5 htlcs)" $
+ nf build_commitment_tx (fx_ctx_htlcs fx)
+ , bench "build_commitment_tx (5 htlcs, anchors)" $
+ nf build_commitment_tx (fx_ctx_anchors fx)
+ , bench "encode_commitment_tx (5 htlcs)" $
+ nf encode_commitment_tx (fx_commit fx)
+ , bench "build_htlc_tx" $
+ nf build_htlc_tx (fx_htlc_ctx fx)
+ , bench "encode_htlc_tx" $
+ nf encode_htlc_tx (fx_htlc_tx fx)
+ , bench "build_closing_tx" $
+ nf build_closing_tx (fx_closing fx)
+ , bench "build_legacy_closing_tx" $
+ nf build_legacy_closing_tx (fx_legacy fx)
+ , bench "encode_closing_tx" $
+ nf encode_closing_tx (fx_closing_tx fx)
+ ]
]
- , bgroup "tx building" [
- bench "build_commitment_tx (0 htlcs, no anchors)" $
- whnf build_commitment_tx (mkCommitmentContext htlcs0 noAnchors)
- , bench "build_commitment_tx (10 htlcs, no anchors)" $
- whnf build_commitment_tx (mkCommitmentContext htlcs10 noAnchors)
- , bench "build_commitment_tx (100 htlcs, no anchors)" $
- whnf build_commitment_tx (mkCommitmentContext htlcs100 noAnchors)
- , bench "build_commitment_tx (10 htlcs, anchors)" $
- whnf build_commitment_tx (mkCommitmentContext htlcs10 withAnchors)
- , bench "build_htlc_timeout_tx" $
- whnf build_htlc_timeout_tx sampleHtlcContext
- , bench "build_htlc_success_tx" $
- whnf build_htlc_success_tx sampleHtlcContext
- , bench "build_closing_tx" $
- whnf build_closing_tx sampleClosingContext
- ]
- , bgroup "script generation" [
- bench "funding_script" $
- whnf (funding_script (FundingPubkey samplePubkey1))
- (FundingPubkey samplePubkey2)
- , bench "to_local_script" $
- whnf (to_local_script (RevocationPubkey samplePubkey1)
- (ToSelfDelay 144))
- (LocalDelayedPubkey samplePubkey2)
- , bench "to_remote_script (no anchors)" $
- whnf (to_remote_script (RemotePubkey samplePubkey1)) noAnchors
- , bench "to_remote_script (anchors)" $
- whnf (to_remote_script (RemotePubkey samplePubkey1)) withAnchors
- , bench "anchor_script" $
- whnf anchor_script (FundingPubkey samplePubkey1)
- , bench "offered_htlc_script" $
- whnf (offered_htlc_script (RevocationPubkey samplePubkey1)
- (RemoteHtlcPubkey samplePubkey2)
- (LocalHtlcPubkey samplePubkey3)
- (PaymentHash $ BS.replicate 32 0))
- noAnchors
- , bench "received_htlc_script" $
- whnf (received_htlc_script (RevocationPubkey samplePubkey1)
- (RemoteHtlcPubkey samplePubkey2)
- (LocalHtlcPubkey samplePubkey3)
- (PaymentHash $ BS.replicate 32 0)
- (CltvExpiry 500000))
- noAnchors
- ]
- , bgroup "serialization" [
- env (pure $ build_commitment_tx $ mkCommitmentContext htlcs0 noAnchors)
- $ \tx -> bench "encode_tx (0 htlcs)" $ whnf encode_tx tx
- , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)
- $ \tx -> bench "encode_tx (10 htlcs)" $ whnf encode_tx tx
- , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs100 noAnchors)
- $ \tx -> bench "encode_tx (100 htlcs)" $ whnf encode_tx tx
- , bench "encode_htlc_tx" $
- whnf encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)
- , bench "encode_closing_tx" $
- whnf encode_closing_tx (build_closing_tx sampleClosingContext)
- ]
- , bgroup "parsing" [
- env (pure $ encodeTx0 htlcs0 noAnchors)
- $ \bs -> bench "decode_tx (0 htlcs)" $ whnf decode_tx bs
- , env (pure $ encodeTx0 htlcs10 noAnchors)
- $ \bs -> bench "decode_tx (10 htlcs)" $ whnf decode_tx bs
- , env (pure $ encodeTx0 htlcs100 noAnchors)
- $ \bs -> bench "decode_tx (100 htlcs)" $ whnf decode_tx bs
- ]
- , bgroup "validation" [
- env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)
- $ \tx -> bench "validate_commitment_tx (valid)" $
- whnf (validate_commitment_tx dust noAnchors) tx
- , env (pure $ build_htlc_timeout_tx sampleHtlcContext)
- $ \tx -> bench "validate_htlc_tx" $
- whnf validate_htlc_tx tx
- , env (pure $ build_closing_tx sampleClosingContext)
- $ \tx -> bench "validate_closing_tx" $
- whnf validate_closing_tx tx
- , env (pure $ ctx_outputs $ build_commitment_tx $
- mkCommitmentContext htlcs10 noAnchors)
- $ \outs -> bench "validate_output_ordering" $
- whnf validate_output_ordering outs
- ]
- , bgroup "secret storage" [
- bench "insert_secret (first)" $
- whnf (insert_secret (BS.replicate 32 0xFF) 281474976710655)
- empty_store
- , env setupFilledStore $ \store ->
- bench "derive_old_secret (recent)" $
- whnf (derive_old_secret 281474976710654) store
- , env setupFilledStore $ \store ->
- bench "derive_old_secret (old)" $
- whnf (derive_old_secret 281474976710600) store
- ]
- , bgroup "output sorting" [
- env (pure $ ctx_outputs $ build_commitment_tx $
- mkCommitmentContext htlcs10 noAnchors)
- $ \outs -> bench "sort_outputs (10)" $ nf sort_outputs outs
- , env (pure $ ctx_outputs $ build_commitment_tx $
- mkCommitmentContext htlcs100 noAnchors)
- $ \outs -> bench "sort_outputs (100)" $ nf sort_outputs outs
- ]
- ]
where
- -- Key derivation test data
- basepoint = Point $ BS.pack
- [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,
- 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,
- 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]
-
- perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack
- [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,
- 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,
- 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]
-
- revocationBasepoint = RevocationBasepoint $ Point $ BS.pack
- [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,
- 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,
- 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]
-
- samplePcs :: PerCommitmentSecret
- samplePcs =
- PerCommitmentSecret (BS.replicate 32 0x01)
-
- -- Secret generation test data
- seed = BS.replicate 32 0xFF
-
- -- Fee calculation test data
- feerate = FeeratePerKw 5000
- noAnchors = ChannelFeatures { cf_option_anchors = False }
- withAnchors = ChannelFeatures { cf_option_anchors = True }
-
- -- Trimming test data
- dust = DustLimit (Satoshi 546)
-
- htlcNotTrimmed = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 5000000
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
-
- htlcTrimmed = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 1000000
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
-
- -- Sample pubkeys
- samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey
- samplePubkey1 = Pubkey $ BS.pack
- [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,
- 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,
- 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]
- samplePubkey2 = Pubkey $ BS.pack
- [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,
- 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,
- 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]
- samplePubkey3 = samplePubkey1
-
- -- Helper to encode a commitment tx for decode benchmarks
- encodeTx0 :: [HTLC] -> ChannelFeatures -> BS.ByteString
- encodeTx0 htlcs features =
- case encode_tx (build_commitment_tx
- (mkCommitmentContext htlcs features)) of
- Nothing -> BS.empty
- Just bs -> bs
-
- -- Funding outpoint
- sampleFundingOutpoint :: OutPoint
- sampleFundingOutpoint = OutPoint (TxId $ BS.replicate 32 0x01) 0
-
- -- HTLC lists
- mkHtlc :: HTLCDirection -> Word64 -> Word64 -> HTLC
- mkHtlc dir amtMsat expiry = HTLC
- { htlc_direction = dir
- , htlc_amount_msat = MilliSatoshi amtMsat
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00)
- , htlc_cltv_expiry = CltvExpiry (fromIntegral expiry)
- }
-
- htlcs0, htlcs10, htlcs100 :: [HTLC]
- htlcs0 = []
- htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)
- (5000000 + i * 100000) (500000 + i)
- | i <- [0..9]]
- htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)
- (5000000 + i * 10000) (500000 + i)
- | i <- [0..99]]
-
- -- CommitmentKeys fixture
- sampleCommitmentKeys :: CommitmentKeys
- sampleCommitmentKeys = CommitmentKeys
- { ck_revocation_pubkey = RevocationPubkey samplePubkey1
- , ck_local_delayed = LocalDelayedPubkey samplePubkey1
- , ck_local_htlc = LocalHtlcPubkey samplePubkey1
- , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2
- , ck_local_payment = LocalPubkey samplePubkey1
- , ck_remote_payment = RemotePubkey samplePubkey2
- , ck_local_funding = FundingPubkey samplePubkey1
- , ck_remote_funding = FundingPubkey samplePubkey2
- }
-
- -- CommitmentContext builder
- mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext
- mkCommitmentContext htlcs features = CommitmentContext
- { cc_funding_outpoint = sampleFundingOutpoint
- , cc_commitment_number = CommitmentNumber 42
- , cc_local_payment_bp =
- PaymentBasepoint $ Point $ unPubkey samplePubkey1
- , cc_remote_payment_bp =
- PaymentBasepoint $ Point $ unPubkey samplePubkey2
- , cc_to_self_delay = ToSelfDelay 144
- , cc_dust_limit = DustLimit (Satoshi 546)
- , cc_feerate = FeeratePerKw 5000
- , cc_features = features
- , cc_is_funder = True
- , cc_to_local_msat = MilliSatoshi 500000000
- , cc_to_remote_msat = MilliSatoshi 500000000
- , cc_htlcs = htlcs
- , cc_keys = sampleCommitmentKeys
- }
-
- -- HTLC context
- sampleHtlcContext :: HTLCContext
- sampleHtlcContext = HTLCContext
- { hc_commitment_txid = TxId $ BS.replicate 32 0x01
- , hc_output_index = 0
- , hc_htlc = mkHtlc HTLCOffered 5000000 500000
- , hc_to_self_delay = ToSelfDelay 144
- , hc_feerate = FeeratePerKw 5000
- , hc_features = noAnchors
- , hc_revocation_pubkey = RevocationPubkey samplePubkey1
- , hc_local_delayed = LocalDelayedPubkey samplePubkey1
- }
-
- -- Closing context
- sampleClosingContext :: ClosingContext
- sampleClosingContext = ClosingContext
- { clc_funding_outpoint = sampleFundingOutpoint
- , clc_local_amount = Satoshi 500000
- , clc_remote_amount = Satoshi 500000
- , clc_local_script =
- Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x01
- , clc_remote_script =
- Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x02
- , clc_local_dust_limit = DustLimit (Satoshi 546)
- , clc_remote_dust_limit = DustLimit (Satoshi 546)
- , clc_fee = Satoshi 1000
- , clc_is_funder = True
- , clc_locktime = Locktime 0
- , clc_funding_script = funding_script (FundingPubkey samplePubkey1)
- (FundingPubkey samplePubkey2)
- }
-
- -- Setup for secret storage benchmarks
- setupFilledStore :: IO SecretStore
- setupFilledStore = do
- let secrets = [(generate_from_seed seed i, i)
- | i <- [281474976710655, 281474976710654 .. 281474976710600]]
- pure $! foldl insertOrFail empty_store secrets
- where
- insertOrFail store (sec, idx) =
- case insert_secret sec idx store of
- Just s -> s
- Nothing -> store
+ ck = cc_keys . fx_ctx_simple
+ hash = htlc_payment_hash . hc_htlc . fx_htlc_ctx
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -1,471 +1,53 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Main where
-import qualified Crypto.Curve.Secp256k1 as S
-import Control.DeepSeq (NFData(..))
-import qualified Data.ByteString as BS
-import Data.Word (Word32, Word64)
+import Fixtures
import Lightning.Protocol.BOLT3
-import Lightning.Protocol.BOLT3.Types
- ( Pubkey(..), Point(..)
- , PaymentHash(..), PerCommitmentPoint(..)
- , PerCommitmentSecret(..)
- , CommitmentNumber(..)
- )
import Weigh
--- | Precomputed wNAF context; reused across every apostrophe-
--- suffixed weigh entry.
-tex :: S.Context
-tex = S.precompute
-{-# NOINLINE tex #-}
-
--- NFData instances for weigh
--- (Satoshi, MilliSatoshi, Point, PaymentHash, PerCommitmentSecret
--- derive NFData via ppad-bolt1)
-
-instance NFData Pubkey where
- rnf (Pubkey x) = rnf x
-
-instance NFData PerCommitmentPoint where
- rnf (PerCommitmentPoint x) = rnf x
-
-instance NFData RevocationPubkey where
- rnf (RevocationPubkey x) = rnf x
-
-instance NFData RevocationBasepoint where
- rnf (RevocationBasepoint x) = rnf x
-
-instance NFData LocalDelayedPubkey where
- rnf (LocalDelayedPubkey p) = rnf p
-
-instance NFData RemoteDelayedPubkey where
- rnf (RemoteDelayedPubkey p) = rnf p
-
-instance NFData LocalHtlcPubkey where
- rnf (LocalHtlcPubkey p) = rnf p
-
-instance NFData RemoteHtlcPubkey where
- rnf (RemoteHtlcPubkey p) = rnf p
-
-instance NFData LocalPubkey where
- rnf (LocalPubkey p) = rnf p
-
-instance NFData RemotePubkey where
- rnf (RemotePubkey p) = rnf p
-
-instance NFData PaymentBasepoint where
- rnf (PaymentBasepoint p) = rnf p
-
-instance NFData DelayedPaymentBasepoint where
- rnf (DelayedPaymentBasepoint p) = rnf p
-
-instance NFData HtlcBasepoint where
- rnf (HtlcBasepoint p) = rnf p
-
-instance NFData FundingPubkey where
- rnf (FundingPubkey p) = rnf p
-
--- Channel features
-instance NFData ChannelFeatures where
- rnf (ChannelFeatures x) = rnf x
-
-instance NFData FeeratePerKw where
- rnf (FeeratePerKw x) = rnf x
-
-instance NFData DustLimit where
- rnf (DustLimit x) = rnf x
-
--- Hash types
-instance NFData CltvExpiry where
- rnf (CltvExpiry x) = rnf x
-
--- HTLC types
-instance NFData HTLCDirection where
- rnf HTLCOffered = ()
- rnf HTLCReceived = ()
-
-instance NFData HTLC where
- rnf (HTLC d a h c) = rnf d `seq` rnf a `seq` rnf h `seq` rnf c
-
--- Transaction types
-instance NFData CommitmentTx where
- rnf (CommitmentTx v l i s o f) =
- rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f
-
-instance NFData HTLCTx where
- rnf (HTLCTx v l i s ov os) =
- rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os
-
-instance NFData ClosingTx where
- rnf (ClosingTx v l i s o f) =
- rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f
-
--- Output types
-instance NFData TxOutput where
- rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t
-
-instance NFData OutputType where
- rnf OutputToLocal = ()
- rnf OutputToRemote = ()
- rnf OutputLocalAnchor = ()
- rnf OutputRemoteAnchor = ()
- rnf (OutputOfferedHTLC e) = rnf e
- rnf (OutputReceivedHTLC e) = rnf e
-
--- Primitives
-instance NFData Script where
- rnf (Script bs) = rnf bs
-
-
-instance NFData Sequence where
- rnf (Sequence x) = rnf x
-
-instance NFData Locktime where
- rnf (Locktime x) = rnf x
-
-instance NFData ToSelfDelay where
- rnf (ToSelfDelay x) = rnf x
-
-instance NFData CommitmentNumber where
- rnf (CommitmentNumber x) = rnf x
-
--- Context types
-instance NFData CommitmentContext where
- rnf ctx = rnf (cc_funding_outpoint ctx) `seq`
- rnf (cc_commitment_number ctx) `seq`
- rnf (cc_htlcs ctx) `seq`
- rnf (cc_keys ctx)
-
-instance NFData CommitmentKeys where
- rnf keys = rnf (ck_revocation_pubkey keys) `seq`
- rnf (ck_local_delayed keys) `seq`
- rnf (ck_local_htlc keys) `seq`
- rnf (ck_remote_htlc keys)
-
-instance NFData HTLCContext where
- rnf ctx = rnf (hc_commitment_txid ctx) `seq`
- rnf (hc_htlc ctx)
-
-instance NFData ClosingContext where
- rnf ctx = rnf (clc_funding_outpoint ctx) `seq`
- rnf (clc_local_amount ctx) `seq`
- rnf (clc_remote_amount ctx)
-
-instance NFData ValidationError where
- rnf (InvalidVersion e a) = rnf e `seq` rnf a
- rnf (InvalidLocktime lt) = rnf lt
- rnf (InvalidSequence sq) = rnf sq
- rnf InvalidOutputOrdering = ()
- rnf (DustLimitViolation i v d) = rnf i `seq` rnf v `seq` rnf d
- rnf MissingAnchorOutput = ()
- rnf (InvalidAnchorValue v) = rnf v
- rnf (InvalidFee e a) = rnf e `seq` rnf a
- rnf (InvalidHTLCLocktime e a) = rnf e `seq` rnf a
- rnf (InvalidHTLCSequence e a) = rnf e `seq` rnf a
- rnf NoOutputs = ()
- rnf (TooManyOutputs n) = rnf n
-
--- Secret store (opaque, use generic rnf on the list)
-instance NFData SecretStore where
- rnf ss = ss `seq` ()
-
main :: IO ()
-main = tex `seq` mainWith $ do
- -- 'tex' is forced before mainWith so the one-time wNAF
- -- precompute (~50 KB) doesn't get billed to whichever
- -- apostrophe-suffixed func happens to evaluate it first.
- setColumns [Case, Allocated, GCs, Max]
-
- -- Key derivation allocations
- func "derive_pubkey" (derive_pubkey basepoint) perCommitmentPoint
- func "derive_pubkey'"
- (derive_pubkey' tex basepoint) perCommitmentPoint
- func "derive_per_commitment_point"
- derive_per_commitment_point samplePcs
- func "derive_per_commitment_point'"
- (derive_per_commitment_point' tex) samplePcs
- func "derive_revocationpubkey"
- (derive_revocationpubkey revocationBasepoint) perCommitmentPoint
-
- -- Secret generation allocations
- func "generate_from_seed (final)" (generate_from_seed seed) 281474976710655
- func "generate_from_seed (first)" (generate_from_seed seed) 0
-
- -- Fee calculation allocations
- func "commitment_fee (0 htlcs)" (commitment_fee feerate noAnchors) 0
- func "commitment_fee (10 htlcs)" (commitment_fee feerate noAnchors) 10
- func "htlc_timeout_fee" (htlc_timeout_fee feerate) noAnchors
- func "htlc_success_fee" (htlc_success_fee feerate) noAnchors
-
- -- Trimming allocations
- func "is_trimmed (not trimmed)"
- (is_trimmed dust feerate noAnchors) htlcNotTrimmed
- func "is_trimmed (trimmed)"
- (is_trimmed dust feerate noAnchors) htlcTrimmed
- func "htlc_trim_threshold"
- (htlc_trim_threshold dust feerate noAnchors) HTLCOffered
-
- -- Transaction building allocations
- func "build_commitment_tx (0 htlcs, no anchors)"
- build_commitment_tx (mkCommitmentContext htlcs0 noAnchors)
- func "build_commitment_tx (10 htlcs, no anchors)"
- build_commitment_tx (mkCommitmentContext htlcs10 noAnchors)
- func "build_commitment_tx (100 htlcs, no anchors)"
- build_commitment_tx (mkCommitmentContext htlcs100 noAnchors)
- func "build_commitment_tx (10 htlcs, anchors)"
- build_commitment_tx (mkCommitmentContext htlcs10 withAnchors)
- func "build_htlc_timeout_tx"
- build_htlc_timeout_tx sampleHtlcContext
- func "build_htlc_success_tx"
- build_htlc_success_tx sampleHtlcContext
- func "build_closing_tx"
- build_closing_tx sampleClosingContext
-
- -- Script generation allocations
- func "funding_script"
- (funding_script (FundingPubkey samplePubkey1))
- (FundingPubkey samplePubkey2)
- func "to_local_script"
- (to_local_script (RevocationPubkey samplePubkey1)
- (ToSelfDelay 144))
- (LocalDelayedPubkey samplePubkey2)
- func "to_remote_script (no anchors)"
- (to_remote_script (RemotePubkey samplePubkey1)) noAnchors
- func "to_remote_script (anchors)"
- (to_remote_script (RemotePubkey samplePubkey1)) withAnchors
- func "anchor_script"
- anchor_script (FundingPubkey samplePubkey1)
- func "offered_htlc_script"
- (offered_htlc_script (RevocationPubkey samplePubkey1)
- (RemoteHtlcPubkey samplePubkey2)
- (LocalHtlcPubkey samplePubkey3)
- (PaymentHash $ BS.replicate 32 0))
- noAnchors
- func "received_htlc_script"
- (received_htlc_script (RevocationPubkey samplePubkey1)
- (RemoteHtlcPubkey samplePubkey2)
- (LocalHtlcPubkey samplePubkey3)
- (PaymentHash $ BS.replicate 32 0)
- (CltvExpiry 500000))
- noAnchors
-
- -- Serialization allocations
- func "encode_tx (0 htlcs)"
- encode_tx (build_commitment_tx $
- mkCommitmentContext htlcs0 noAnchors)
- func "encode_tx (10 htlcs)"
- encode_tx (build_commitment_tx $
- mkCommitmentContext htlcs10 noAnchors)
- func "encode_tx (100 htlcs)"
- encode_tx (build_commitment_tx $
- mkCommitmentContext htlcs100 noAnchors)
- func "encode_htlc_tx"
- encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)
- func "encode_closing_tx"
- encode_closing_tx (build_closing_tx sampleClosingContext)
-
- -- Parsing allocations
- func "decode_tx (0 htlcs)"
- decode_tx (encodeTx0 htlcs0 noAnchors)
- func "decode_tx (10 htlcs)"
- decode_tx (encodeTx0 htlcs10 noAnchors)
- func "decode_tx (100 htlcs)"
- decode_tx (encodeTx0 htlcs100 noAnchors)
-
- -- Validation allocations
- func "validate_commitment_tx (valid)"
- (validate_commitment_tx dust noAnchors)
- (build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)
- func "validate_htlc_tx"
- validate_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)
- func "validate_closing_tx"
- validate_closing_tx (build_closing_tx sampleClosingContext)
- func "validate_output_ordering"
- validate_output_ordering (ctx_outputs $ build_commitment_tx $
- mkCommitmentContext htlcs10 noAnchors)
-
- -- Secret storage allocations
- func "insert_secret (first)"
- (insert_secret (BS.replicate 32 0xFF) 281474976710655)
- empty_store
- func "derive_old_secret (recent)"
- (derive_old_secret 281474976710654)
- filledStore
- func "derive_old_secret (old)"
- (derive_old_secret 281474976710600)
- filledStore
-
- -- Output sorting allocations
- func "sort_outputs (10)"
- sort_outputs (ctx_outputs $ build_commitment_tx $
- mkCommitmentContext htlcs10 noAnchors)
- func "sort_outputs (100)"
- sort_outputs (ctx_outputs $ build_commitment_tx $
- mkCommitmentContext htlcs100 noAnchors)
-
- where
- -- Key derivation test data
- basepoint = Point $ BS.pack
- [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,
- 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,
- 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]
-
- perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack
- [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,
- 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,
- 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]
-
- revocationBasepoint = RevocationBasepoint $ Point $ BS.pack
- [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,
- 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,
- 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]
-
- samplePcs :: PerCommitmentSecret
- samplePcs =
- PerCommitmentSecret (BS.replicate 32 0x01)
-
- -- Secret generation test data
- seed = BS.replicate 32 0xFF
-
- -- Fee calculation test data
- feerate = FeeratePerKw 5000
- noAnchors = ChannelFeatures { cf_option_anchors = False }
- withAnchors = ChannelFeatures { cf_option_anchors = True }
-
- -- Trimming test data
- dust = DustLimit (Satoshi 546)
-
- htlcNotTrimmed = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 5000000
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
-
- htlcTrimmed = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 1000000
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
-
- -- Sample pubkeys
- samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey
- samplePubkey1 = Pubkey $ BS.pack
- [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,
- 0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,
- 0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]
- samplePubkey2 = Pubkey $ BS.pack
- [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,
- 0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,
- 0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]
- samplePubkey3 = samplePubkey1
-
- -- Helper to encode a commitment tx for decode benchmarks
- encodeTx0 :: [HTLC] -> ChannelFeatures -> BS.ByteString
- encodeTx0 htlcs features =
- case encode_tx (build_commitment_tx
- (mkCommitmentContext htlcs features)) of
- Nothing -> BS.empty
- Just bs -> bs
-
- -- Funding outpoint
- sampleFundingOutpoint :: OutPoint
- sampleFundingOutpoint = OutPoint (TxId $ BS.replicate 32 0x01) 0
-
- -- HTLC builder
- mkHtlc :: HTLCDirection -> Word64 -> Word32 -> HTLC
- mkHtlc dir amtMsat expiry = HTLC
- { htlc_direction = dir
- , htlc_amount_msat = MilliSatoshi amtMsat
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00)
- , htlc_cltv_expiry = CltvExpiry expiry
- }
-
- htlcs0, htlcs10, htlcs100 :: [HTLC]
- htlcs0 = []
- htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)
- (5000000 + i * 100000) (500000 + fromIntegral i)
- | i <- [0..9]]
- htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)
- (5000000 + i * 10000) (500000 + fromIntegral i)
- | i <- [0..99]]
-
- -- CommitmentKeys
- sampleCommitmentKeys :: CommitmentKeys
- sampleCommitmentKeys = CommitmentKeys
- { ck_revocation_pubkey = RevocationPubkey samplePubkey1
- , ck_local_delayed = LocalDelayedPubkey samplePubkey1
- , ck_local_htlc = LocalHtlcPubkey samplePubkey1
- , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2
- , ck_local_payment = LocalPubkey samplePubkey1
- , ck_remote_payment = RemotePubkey samplePubkey2
- , ck_local_funding = FundingPubkey samplePubkey1
- , ck_remote_funding = FundingPubkey samplePubkey2
- }
-
- -- CommitmentContext builder
- mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext
- mkCommitmentContext htlcs features = CommitmentContext
- { cc_funding_outpoint = sampleFundingOutpoint
- , cc_commitment_number = CommitmentNumber 42
- , cc_local_payment_bp = PaymentBasepoint $
- Point $ unPubkey samplePubkey1
- , cc_remote_payment_bp = PaymentBasepoint $
- Point $ unPubkey samplePubkey2
- , cc_to_self_delay = ToSelfDelay 144
- , cc_dust_limit = DustLimit (Satoshi 546)
- , cc_feerate = FeeratePerKw 5000
- , cc_features = features
- , cc_is_funder = True
- , cc_to_local_msat = MilliSatoshi 500000000
- , cc_to_remote_msat = MilliSatoshi 500000000
- , cc_htlcs = htlcs
- , cc_keys = sampleCommitmentKeys
- }
-
- -- HTLC context
- sampleHtlcContext :: HTLCContext
- sampleHtlcContext = HTLCContext
- { hc_commitment_txid = TxId $ BS.replicate 32 0x01
- , hc_output_index = 0
- , hc_htlc = mkHtlc HTLCOffered 5000000 500000
- , hc_to_self_delay = ToSelfDelay 144
- , hc_feerate = FeeratePerKw 5000
- , hc_features = noAnchors
- , hc_revocation_pubkey = RevocationPubkey samplePubkey1
- , hc_local_delayed = LocalDelayedPubkey samplePubkey1
- }
-
- -- Closing context
- sampleClosingContext :: ClosingContext
- sampleClosingContext = ClosingContext
- { clc_funding_outpoint = sampleFundingOutpoint
- , clc_local_amount = Satoshi 500000
- , clc_remote_amount = Satoshi 500000
- , clc_local_script = Script $
- BS.pack [0x00, 0x14] <> BS.replicate 20 0x01
- , clc_remote_script = Script $
- BS.pack [0x00, 0x14] <> BS.replicate 20 0x02
- , clc_local_dust_limit = DustLimit (Satoshi 546)
- , clc_remote_dust_limit = DustLimit (Satoshi 546)
- , clc_fee = Satoshi 1000
- , clc_is_funder = True
- , clc_locktime = Locktime 0
- , clc_funding_script = funding_script (FundingPubkey samplePubkey1)
- (FundingPubkey samplePubkey2)
- }
-
- -- Secret storage for benchmarks
- filledStore :: SecretStore
- filledStore = foldl insertOne empty_store [0..99]
- where
- insertOne store i =
- let idx = 281474976710655 - i
- sec = BS.replicate 32 (fromIntegral i)
- in case insert_secret sec idx store of
- Just s -> s
- Nothing -> store
+main = do
+ fx <- fixtures
+ let (next_idx, next_secret) = fx_store_next fx
+ mainWith $ do
+ wgroup "keys" $ do
+ func "derive_per_commitment_point" derive_per_commitment_point
+ (fx_secret fx)
+ func "derive_per_commitment_point'" (derive_per_commitment_point' tex)
+ (fx_secret fx)
+ func "derive_pubkey" (derive_pubkey (fx_basepoint fx)) (fx_pcp fx)
+ func "derive_revocationpubkey" (derive_revocationpubkey (fx_rbp fx))
+ (fx_pcp fx)
+ func "derive_commitment_keys"
+ (derive_commitment_keys (fx_local_bps fx) (fx_local_fund fx)
+ (fx_remote_bps fx) (fx_remote_fund fx))
+ (fx_pcp fx)
+ func "derive_commitment_keys'"
+ (derive_commitment_keys' tex (fx_local_bps fx) (fx_local_fund fx)
+ (fx_remote_bps fx) (fx_remote_fund fx))
+ (fx_pcp fx)
+ func "derive_privkey" (derive_privkey (fx_seckey fx)) (fx_pcp fx)
+ func "derive_revocationprivkey"
+ (derive_revocationprivkey (fx_seckey fx)) (fx_secret fx)
+ wgroup "secrets" $ do
+ func "generate_from_seed (index 2^48 - 1)"
+ (generate_from_seed (fx_seed fx)) (fx_store_oldest fx)
+ func "insert_secret (14 lower buckets)"
+ (insert_secret next_secret next_idx) (fx_store fx)
+ func "derive_old_secret (index 2^48 - 1)"
+ (derive_old_secret (fx_store_oldest fx)) (fx_store fx)
+ func "secret_store . un_secret_store"
+ (secret_store . un_secret_store) (fx_store fx)
+ wgroup "transactions" $ do
+ func "build_commitment_tx (no htlcs)" build_commitment_tx
+ (fx_ctx_simple fx)
+ func "build_commitment_tx (5 htlcs)" build_commitment_tx
+ (fx_ctx_htlcs fx)
+ func "build_commitment_tx (5 htlcs, anchors)" build_commitment_tx
+ (fx_ctx_anchors fx)
+ func "encode_commitment_tx (5 htlcs)" encode_commitment_tx
+ (fx_commit fx)
+ func "build_htlc_tx" build_htlc_tx (fx_htlc_ctx fx)
+ func "encode_htlc_tx" encode_htlc_tx (fx_htlc_tx fx)
+ func "build_closing_tx" build_closing_tx (fx_closing fx)
+ func "build_legacy_closing_tx" build_legacy_closing_tx (fx_legacy fx)
+ func "encode_closing_tx" encode_closing_tx (fx_closing_tx fx)
diff --git a/etc/03-transactions.md b/etc/03-transactions.md
@@ -13,6 +13,7 @@ This details the exact format of on-chain transactions, which both sides need to
* [`to_local` Output](#to_local-output)
* [`to_remote` Output](#to_remote-output)
* [`to_local_anchor` and `to_remote_anchor`](#to_local_anchor-and-to_remote_anchor-output-option_anchors)
+ * [`shared_anchor`](#shared_anchor-output-zero_fee_commitments)
* [Offered HTLC Outputs](#offered-htlc-outputs)
* [Received HTLC Outputs](#received-htlc-outputs)
* [Trimmed Outputs](#trimmed-outputs)
@@ -44,6 +45,7 @@ This details the exact format of on-chain transactions, which both sides need to
* [Appendix E: Key Derivation Test Vectors](#appendix-e-key-derivation-test-vectors)
* [Appendix F: Commitment and HTLC Transaction Test Vectors (anchors)](#appendix-f-commitment-and-htlc-transaction-test-vectors-anchors)
* [Appendix G: Dual Funded Transaction Test Vectors](#appendix-g-dual-funded-transaction-test-vectors)
+ * [Appendix H: Commitment and HTLC Transaction Test Vectors (zero-fee-commitments)](#appendix-h-commitment-and-htlc-transaction-test-vectors-zero-fee-commitments)
* [References](#references)
* [Authors](#authors)
@@ -80,7 +82,7 @@ A `<>` designates an empty vector as required for compliance with MINIMALIF-stan
## Commitment Transaction
-* version: 2
+* version: 3 when using `zero_fee_commitments`, otherwise 2
* locktime: upper 8 bits are 0x20, lower 24 bits are the lower 24 bits of the obscured commitment number
* txin count: 1
* `txin[0]` outpoint: `txid` and `output_index` from `funding_created` message
@@ -104,7 +106,9 @@ To allow an opportunity for penalty transactions, in case of a revoked commitmen
The reason for the separate transaction stage for HTLC outputs is so that HTLCs can timeout or be fulfilled even though they are within the `to_self_delay` delay.
Otherwise, the required minimum timeout on HTLCs is lengthened by this delay, causing longer timeouts for HTLCs traversing the network.
-The amounts for each output MUST be rounded down to whole satoshis. If this amount, minus the fees for the HTLC transaction, is less than the `dust_limit_satoshis` set by the owner of the commitment transaction, the output MUST NOT be produced (thus the funds add to fees).
+The amounts for each output MUST be rounded down to whole satoshis.
+If this amount, minus the fees for the HTLC transaction, is less than the `dust_limit_satoshis` set by the owner of the commitment transaction, the output MUST NOT be produced (thus the funds add to fees).
+If `zero_fee_commitments` is used, the amount may be partially added to the `shared_anchor` as detailed [here](#shared_anchor-output-zero_fee_commitments).
#### `to_local` Output
@@ -144,7 +148,7 @@ Otherwise, this output is a simple P2WPKH to `remotepubkey`.
#### `to_local_anchor` and `to_remote_anchor` Output (option_anchors)
This output can be spent by the local and remote nodes respectively to provide incentive to mine the transaction, using child-pays-for-parent. Both
-anchor outputs are always added, except for the case where there are no htlcs and one of the parties has a commitment output that is below the dust limit.
+anchor outputs are always added, except for the case where there are no htlcs and one of the parties has a commitment output that is below the dust limit.
In that case only an anchor is added for the commitment output that does materialize. This typically happens if the initiator closes right after opening
(no `to_remote` output).
@@ -171,9 +175,30 @@ After 16 blocks, anyone can sweep the anchor with witness:
<>
+#### `shared_anchor` Output (zero_fee_commitments)
+
+This output can be spent by anyone to provide incentive to mine the transaction, using child-pays-for-parent.
+This output is only added when the commitment transaction is using version 3 (`zero_fee_commitments`) and prevents pinning attacks on the commitment transaction.
+
+It is using the following standard P2A (pay-to-anchor) script:
+
+ OP_1 <0x4e73>
+
+The standard dust limit for this type of script is `240 sat`.
+However, if the parent transaction doesn't pay any on-chain fees, using values below this dust limit is allowed under the "ephemeral dust" rule.
+
+If the difference between the commitment transaction input and the sum of all other commitment transaction outputs is smaller than `240 sat`, we set the anchor amount to this value.
+This ensures that the commitment transaction doesn't pay any on-chain fees whenever the anchor amount is smaller than `240 sat`.
+
+Otherwise, we set the anchor amount to `240 sat`, and the remaining difference between the commitment transaction input and its outputs directly contributes to the transaction's mining fees (which is standard since the `shared_anchor` has reached its dust limit).
+
+Spending of the output requires the following (empty) witness:
+
+ <>
+
#### Offered HTLC Outputs
-This output sends funds to either an HTLC-timeout transaction after the HTLC-timeout or to the remote node using the payment preimage or the revocation key. The output is a P2WSH, with a witness script (no option_anchors):
+This output sends funds to either an HTLC-timeout transaction after the HTLC-timeout or to the remote node using the payment preimage or the revocation key. The output is a P2WSH, with a witness script (no `option_anchors`):
# To remote node with revocation key
OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL
@@ -280,60 +305,68 @@ To redeem the HTLC, the HTLC-success transaction is used as detailed below. This
### Trimmed Outputs
Each peer specifies a `dust_limit_satoshis` below which outputs should
-not be produced; these outputs that are not produced are termed "trimmed". A trimmed output is
-considered too small to be worth creating and is instead added
-to the commitment transaction fee. For HTLCs, it needs to be taken into
-account that the second-stage HTLC transaction may also be below the
-limit.
+not be produced; these outputs that are not produced are termed "trimmed".
+A trimmed output is considered too small to be worth creating: it is instead
+either added to the commitment transaction fee or, if `zero_fee_commitments`
+applies, to the [shared anchor output](#shared_anchor-output-zero_fee_commitments).
+
+For HTLCs, it needs to be taken into account that the second-stage HTLC
+transaction may also be below the limit. Note that when using `option_anchors`
+or `zero_fee_commitments`, HTLC transactions don't include a fee and thus
+don't contribute to trimming: setting a higher `dust_limit_satoshis` makes
+sense for those channels to ensure that outputs are economical to spend.
#### Requirements
-The base fee and anchor output values:
- - before the commitment transaction outputs are determined:
- - MUST be subtracted from the `to_local` or `to_remote`
- outputs, as specified in [Fee Calculation](#fee-calculation).
+Before the commitment transaction outputs are determined:
+ - the base fee MUST be subtracted from the `to_local` or `to_remote` output,
+ as specified in [Fee Calculation](#fee-calculation).
+ - if `option_anchors` applies:
+ - the `to_local_anchor` output value MUST be subtracted from the funder's output.
+ - the `to_remote_anchor` output value MUST be subtracted from the funder's output.
The commitment transaction:
- if the amount of the commitment transaction `to_local` output would be
-less than `dust_limit_satoshis` set by the transaction owner:
+ less than `dust_limit_satoshis` set by the transaction owner:
- MUST NOT contain that output.
- otherwise:
- MUST be generated as specified in [`to_local` Output](#to_local-output).
- if the amount of the commitment transaction `to_remote` output would be
-less than `dust_limit_satoshis` set by the transaction owner:
+ less than `dust_limit_satoshis` set by the transaction owner:
- MUST NOT contain that output.
- otherwise:
- MUST be generated as specified in [`to_remote` Output](#to_remote-output).
- for every offered HTLC:
- if the HTLC amount minus the HTLC-timeout fee would be less than
- `dust_limit_satoshis` set by the transaction owner:
+ `dust_limit_satoshis` set by the transaction owner:
- MUST NOT contain that output.
- otherwise:
- - MUST be generated as specified in
- [Offered HTLC Outputs](#offered-htlc-outputs).
+ - MUST be generated as specified in [Offered HTLC Outputs](#offered-htlc-outputs).
- for every received HTLC:
- if the HTLC amount minus the HTLC-success fee would be less than
- `dust_limit_satoshis` set by the transaction owner:
+ `dust_limit_satoshis` set by the transaction owner:
- MUST NOT contain that output.
- otherwise:
- - MUST be generated as specified in
- [Received HTLC Outputs](#received-htlc-outputs).
+ - MUST be generated as specified in [Received HTLC Outputs](#received-htlc-outputs).
+ - if `zero_fee_commitments` applies:
+ - MUST add a `shared_anchor` output with an amount computed as detailed in
+ [the `shared_anchor` section](#shared_anchor-output-zero_fee_commitments).
## HTLC-Timeout and HTLC-Success Transactions
These HTLC transactions are almost identical, except the HTLC-timeout transaction is timelocked. Both HTLC-timeout/HTLC-success transactions can be spent by a valid penalty transaction.
-* version: 2
+* version: 3 when using `zero_fee_commitments`, otherwise 2
* locktime: `0` for HTLC-success, `cltv_expiry` for HTLC-timeout
* txin count: 1
* `txin[0]` outpoint: `txid` of the commitment transaction and `output_index` of the matching HTLC output for the HTLC transaction
- * `txin[0]` sequence: `0` (set to `1` for `option_anchors`)
+ * `txin[0]` sequence: `1` for `option_anchors`, `0` otherwise
* `txin[0]` script bytes: `0`
* `txin[0]` witness stack: `0 <remotehtlcsig> <localhtlcsig> <payment_preimage>` for HTLC-success, `0 <remotehtlcsig> <localhtlcsig> <>` for HTLC-timeout
* txout count: 1
* `txout[0]` amount: the HTLC `amount_msat` divided by 1000 (rounding down) minus fees in satoshis (see [Fee Calculation](#fee-calculation))
* `txout[0]` script: version-0 P2WSH with witness script as shown below
-* if `option_anchors` applies to this commitment transaction, `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` is used as described in [BOLT #5](05-onchain.md#generation-of-htlc-transactions).
+* if `option_anchors` or `zero_fee_commitments` applies to this commitment transaction, `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` is used as described in [BOLT #5](05-onchain.md#generation-of-htlc-transactions).
The witness script for the output is:
@@ -434,7 +467,12 @@ Each node offering a signature:
The fee calculation for both commitment transactions and HTLC
transactions is based on the current `feerate_per_kw` and the
-*expected weight* of the transaction.
+*expected weight* of the transaction. Note that `feerate_per_kw`
+is set to `0` when using `zero_fee_commitments`: in that case
+the commitment transactions and HTLC transactions don't pay any
+fee, which must be paid using child-pays-for-parent (for the
+commitment transactions) or by adding inputs (for the HTLC
+transactions).
The actual and expected weights vary for several reasons:
@@ -459,24 +497,27 @@ This yields the following *expected weights* (details of the computation in [App
HTLC-success weight (no option_anchors): 703
HTLC-success weight (option_anchors): 706
-Note the reference to the "base fee" for a commitment transaction in the requirements below, which is what the funder pays. The actual fee may be higher than the amount calculated here, due to rounding and trimmed outputs.
+Note the reference to the "base fee" for a commitment transaction in the requirements below, which is what the funder pays.
+The actual fee may be higher than the amount calculated here, due to rounding and trimmed outputs.
#### Requirements
The fee for an HTLC-timeout transaction:
- - If `option_anchors` applies:
+ - If `option_anchors` or `zero_fee_commitments` applies:
1. MUST be 0.
- Otherwise, MUST be calculated to match:
1. Multiply `feerate_per_kw` by 663 and divide by 1000 (rounding down).
The fee for an HTLC-success transaction:
- - If `option_anchors` applies:
+ - If `option_anchors` or `zero_fee_commitments` applies:
1. MUST be 0.
- Otherwise, MUST be calculated to match:
1. Multiply `feerate_per_kw` by 703 and divide by 1000 (rounding down).
The base fee for a commitment transaction:
- - MUST be calculated to match:
+ - If `zero_fee_commitments` applies:
+ 1. MUST be 0.
+ - Otherwise, MUST be calculated to match:
1. Start with `weight` = 724 (1124 if `option_anchors` applies).
2. For each committed HTLC, if that output is not trimmed as specified in
[Trimmed Outputs](#trimmed-outputs), add 172 to `weight`.
@@ -516,16 +557,20 @@ outputs) is 7140 satoshi. The final fee may be even higher if the
### Fee Payment
-Base commitment transaction fees and amounts for `to_local_anchor` and `to_remote_anchor` outputs are extracted from the funder's amount;
-Restrictions to the commitment tx output for the funder in relation to the
-channel reserve apply as described in [BOLT #2](02-peer-protocol.md).
+Base commitment transaction fees and amounts for `to_local_anchor` and
+`to_remote_anchor` outputs are extracted from the funder's amount.
+
+When using `zero_fee_commitments`, the `shared_anchor` output amount is
+taken from [trimmed outputs](#trimmed-outputs), as detailed in the
+[`shared_anchor` section](#shared_anchor-output-zero_fee_commitments).
Note that after the fee amount is subtracted from the to-funder output,
that output may be below `dust_limit_satoshis`, and thus will also
-contribute to fees.
+contribute to fees (or, if `zero_fee_commitments` applies, to the
+`shared_anchor`).
A node:
- - if the resulting fee rate is too low:
+ - if `zero_fee_commitments` is not used and the resulting fee rate is too low:
- MAY send a `warning` and close the connection, or send an
`error` and fail the channel.
@@ -550,6 +595,7 @@ Bitcoin Core defines the following dust thresholds:
- pay to script hash (p2sh): 540 satoshis
- pay to witness pubkey hash (p2wpkh): 294 satoshis
- pay to witness script hash (p2wsh): 330 satoshis
+- pay to anchor (p2a): 240 satoshis
- unknown segwit versions: 354 satoshis
- `OP_RETURN` outputs: these are never dust
@@ -559,6 +605,20 @@ is explained in the following sections.
In all these sections, the calculations are done with a feerate of 3000 sat/kB
as per Bitcoin Core's implementation.
+Note that since the introduction of `option_anchors`, the second-stage HTLC
+transaction's weight is not taken into account when deciding whether outputs
+should be included in the commitment transaction or not. It thus makes sense
+to use a `dust_limit_satoshis` that takes into account the cost of those
+second-stage HTLC transactions, to ensure that outputs added to the commitment
+transaction can actually be claimed on-chain, otherwise they may pollute the
+utxo set indefinitely. At a minimum, nodes should allow their peer to use a
+`dust_limit_satoshis` that is higher than the values defined by Bitcoin Core.
+We cannot predict future feerates, so this will not always work and can still
+result in HTLC outputs that are unspendable if the on-chain fees are too high.
+We cannot use very large `dust_limit_satoshis` values either since it would
+create too much dust exposure in the commitment transaction (more details
+[here](/02-peer-protocol.md#bounding-exposure-to-trimmed-in-flight-htlcs-max_dust_htlc_exposure_msat)).
+
### Pay to pubkey hash (p2pkh)
A p2pkh output is 34 bytes:
@@ -650,26 +710,28 @@ given that peer's `dust_limit_satoshis`, the current `feerate_per_kw`,
the amounts due to each peer (`to_local` and `to_remote`), and all
committed HTLCs:
-1. Initialize the commitment transaction input and locktime, as specified
- in [Commitment Transaction](#commitment-transaction).
-1. Calculate which committed HTLCs need to be trimmed (see [Trimmed Outputs](#trimmed-outputs)).
-2. Calculate the base [commitment transaction fee](#fee-calculation).
-3. Subtract this base fee from the funder (either `to_local` or `to_remote`).
-If `option_anchors` applies to the commitment transaction,
-also subtract two times the fixed anchor size of 330 sats from the funder
-(either `to_local` or `to_remote`).
-4. For every offered HTLC, if it is not trimmed, add an
- [offered HTLC output](#offered-htlc-outputs).
-5. For every received HTLC, if it is not trimmed, add an
- [received HTLC output](#received-htlc-outputs).
-6. If the `to_local` amount is greater or equal to `dust_limit_satoshis`,
- add a [`to_local` output](#to_local-output).
-7. If the `to_remote` amount is greater or equal to `dust_limit_satoshis`,
- add a [`to_remote` output](#to_remote-output).
-8. If `option_anchors` applies to the commitment transaction:
- * if `to_local` exists or there are untrimmed HTLCs, add a [`to_local_anchor` output](#to_local_anchor-and-to_remote_anchor-output-option_anchors)
- * if `to_remote` exists or there are untrimmed HTLCs, add a [`to_remote_anchor` output](#to_local_anchor-and-to_remote_anchor-output-option_anchors)
-9. Sort the outputs into [BIP 69+CLTV order](#transaction-output-ordering).
+* Initialize the commitment transaction input and locktime, as specified
+ in [Commitment Transaction](#commitment-transaction).
+* Calculate which committed HTLCs need to be trimmed (see [Trimmed Outputs](#trimmed-outputs)).
+* Calculate the base [commitment transaction fee](#fee-calculation).
+* Subtract this base fee from the funder (either `to_local` or `to_remote`).
+ If `option_anchors` applies to the commitment transaction,
+ also subtract two times the fixed anchor size of 330 sats from the funder
+ (either `to_local` or `to_remote`).
+* For every offered HTLC, if it is not trimmed, add an
+ [offered HTLC output](#offered-htlc-outputs).
+* For every received HTLC, if it is not trimmed, add a
+ [received HTLC output](#received-htlc-outputs).
+* If the `to_local` amount is greater or equal to `dust_limit_satoshis`,
+ add a [`to_local` output](#to_local-output).
+* If the `to_remote` amount is greater or equal to `dust_limit_satoshis`,
+ add a [`to_remote` output](#to_remote-output).
+* If `option_anchors` applies to the commitment transaction:
+ * if `to_local` exists or there are untrimmed HTLCs, add a [`to_local_anchor` output](#to_local_anchor-and-to_remote_anchor-output-option_anchors).
+ * if `to_remote` exists or there are untrimmed HTLCs, add a [`to_remote_anchor` output](#to_local_anchor-and-to_remote_anchor-output-option_anchors).
+* If `zero_fee_commitments` applies to the commitment transaction:
+ * add a [`shared_anchor` output](#shared_anchor-output-zero_fee_commitments).
+* Sort the outputs into [BIP 69+CLTV order](#transaction-output-ordering).
# Keys
@@ -906,7 +968,6 @@ Multiplying non-witness data by 4 results in a weight of:
overall_weight = funding_transaction_weight + witness_weight
-
## Expected Weight of the Commitment Transaction
The *expected weight* of a commitment transaction is calculated as follows:
@@ -1154,9 +1215,9 @@ Multiplying non-witness data by 4 results in a weight of 376. Adding
the witness data for each case (285 or 288 + 2 for HTLC-timeout, 324 or 327 + 2 for
HTLC-success) results in weights of:
- 663 (HTLC-timeout) (666 with option_anchors))
- 703 (HTLC-success) (706 with option_anchors))
- - (really 702 and 705, but we use these numbers for historical reasons)
+ 663 (HTLC-timeout) (666 with option_anchors)
+ 703 (HTLC-success) (706 with option_anchors)
+ - (really 702 and 705, but we use these numbers for historical reasons)
# Appendix B: Funding Transaction Test Vectors
@@ -2360,6 +2421,12 @@ Note locktime is set to 120.
02000000000102b932b0669cd0394d0d5bcc27e01ab8c511f1662a6799925b346c0cf18fca03430200000000fdffffffb932b0669cd0394d0d5bcc27e01ab8c511f1662a6799925b346c0cf18fca03430000000000fdffffff03e5effa02000000001600141ca1cca8855bad6bc1ea5436edd8cff10b7e448b1cf0fa020000000016001444cb0c39f93ecc372b5851725bd29d865d333b100084d71700000000220020297b92c238163e820b82486084634b4846b86a3c658d87b9384192e6bea98ec50247304402207de9ba56bb9f641372e805782575ee840a899e61021c8b1572b3ec1d5b5950e9022069e9ba998915dae193d3c25cb89b5e64370e6a3a7755e7f31cf6d7cbc2a49f6d0121034695f5b7864c580bf11f9f8cb1a94eb336f2ce9ef872d2ae1a90ee276c772484022068656c6c6f2074686572652c2074686973206973206120626974636f6e2121212782012088a820add57dfe5277079d069ca4ad4893c96de91f88ffb981fdc6a2a34d5336c66aff8778000000
```
+# Appendix H: Commitment and HTLC Transaction Test Vectors (zero-fee-commitments)
+
+Test vectors [are provided](./bolt03/zero-fee-commitments-test.json) that detail commitment and HTLC
+transactions created using `zero_fee_commitments` in various scenarios. All parameters are provided
+to ensure that implementations generate exactly the same signed transactions.
+
# References
# Authors
diff --git a/flake.lock b/flake.lock
@@ -217,16 +217,19 @@
"nixpkgs"
],
"ppad-base16": "ppad-base16",
+ "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"
},
@@ -236,6 +239,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-fixed": {
"inputs": {
"flake-utils": [
@@ -496,11 +530,11 @@
]
},
"locked": {
- "lastModified": 1783709517,
- "narHash": "sha256-iNne+qla9/ntt62Z+i9HR4QH99l/tUZCTD8i45sX0iY=",
+ "lastModified": 1791624263,
+ "narHash": "sha256-IJAffs2Cx/IjSTpNPubVlrzHLqRLUFu6XQp9yRIRbdU=",
"ref": "master",
- "rev": "0654d3f60af6e63109bf05224d15905fc5b70fc1",
- "revCount": 31,
+ "rev": "65a561493940b59c5415b4b1409b4e32dae5c08f",
+ "revCount": 33,
"type": "git",
"url": "git://git.ppad.tech/tx.git"
},
@@ -521,6 +555,7 @@
"nixpkgs"
],
"ppad-bolt1": "ppad-bolt1",
+ "ppad-bolt9": "ppad-bolt9",
"ppad-nixpkgs": "ppad-nixpkgs",
"ppad-ripemd160": "ppad-ripemd160",
"ppad-secp256k1": "ppad-secp256k1",
diff --git a/flake.nix b/flake.nix
@@ -12,6 +12,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-sha256 = {
type = "git";
@@ -44,7 +51,7 @@
};
outputs = { self, nixpkgs, flake-utils, ppad-nixpkgs
- , ppad-bolt1, ppad-sha256, ppad-secp256k1
+ , ppad-bolt1, ppad-bolt9, ppad-sha256, ppad-secp256k1
, ppad-ripemd160, ppad-tx }:
flake-utils.lib.eachDefaultSystem (system:
let
@@ -74,10 +81,7 @@
[ llvm clang ];
bolt1 = ppad-bolt1.packages.${system}.default;
- bolt1-llvm =
- hlib.addBuildTools
- (hlib.enableCabalFlag bolt1 "llvm")
- [ llvm clang ];
+ bolt9 = ppad-bolt9.packages.${system}.default;
tx = ppad-tx.packages.${system}.default;
tx-llvm =
@@ -86,7 +90,8 @@
[ llvm clang ];
hpkgs = pkgs.haskell.packages.ghc910.extend (new: old: {
- ppad-bolt1 = bolt1-llvm;
+ ppad-bolt1 = bolt1;
+ ppad-bolt9 = bolt9;
ppad-sha256 = sha256-llvm;
ppad-secp256k1 = secp256k1-llvm;
ppad-ripemd160 = ripemd160-llvm;
diff --git a/lib/Lightning/Protocol/BOLT3.hs b/lib/Lightning/Protocol/BOLT3.hs
@@ -6,176 +6,135 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Bitcoin transaction formats for the Lightning Network, per
--- [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md).
+-- Bitcoin transaction and script formats for the Lightning Network, per
+-- [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md)
+-- (commitment, HTLC and closing transactions, their output scripts and
+-- witnesses, per-commitment key derivation, and per-commitment secret
+-- generation and storage).
--
--- = Overview
---
--- This library implements the transaction and script formats defined in
--- BOLT #3, including:
---
--- * Commitment transactions with to_local, to_remote, anchor, and HTLC
--- outputs
--- * HTLC-timeout and HTLC-success second-stage transactions
--- * Closing transactions (legacy and option_simple_close)
--- * Per-commitment key derivation and secret storage
--- * Transaction serialization and parsing
--- * Stateless validation
---
--- = Quick Start
---
--- @
--- import Lightning.Protocol.BOLT3
---
--- -- Build a commitment transaction
--- let ctx = CommitmentContext { ... }
--- tx = build_commitment_tx ctx
---
--- -- Serialize for signing
--- let bytes = encode_tx tx
---
--- -- Validate the transaction
--- case validate_commitment_tx dustLimit features tx of
--- Right () -> putStrLn "Valid"
--- Left err -> print err
--- @
---
--- = Modules
---
--- * "Lightning.Protocol.BOLT3.Types" - Core types (Satoshi, Pubkey, HTLC,
--- etc.)
--- * "Lightning.Protocol.BOLT3.Keys" - Per-commitment key derivation and
--- secret storage
--- * "Lightning.Protocol.BOLT3.Scripts" - Witness script templates (funding,
--- to_local, HTLC, anchor)
--- * "Lightning.Protocol.BOLT3.Tx" - Transaction assembly
--- * "Lightning.Protocol.BOLT3.Encode" - Transaction serialization
--- * "Lightning.Protocol.BOLT3.Decode" - Transaction parsing
--- * "Lightning.Protocol.BOLT3.Validate" - Stateless validation
+-- Amounts, points, hashes and per-commitment secrets are the types of
+-- ppad-bolt1's "Lightning.Protocol.BOLT1"; transactions convert to
+-- ppad-tx's "Bitcoin.Prim.Tx" for txids, sighashes and serialization.
+-- The @option_static_remotekey@ and @option_anchors@ commitment formats
+-- are supported ('CommitmentFormat').
module Lightning.Protocol.BOLT3 (
- -- * Types
- -- ** Monetary amounts
- Satoshi(..)
- , MilliSatoshi(..)
- , msatToSat
- , satToMsat
-
- -- ** Keys and points
- , Pubkey
- , unPubkey
- , pubkey
- , Seckey
- , unSeckey
- , seckey
- , Point
- , unPoint
- , point
-
- -- ** Hashes
- , PaymentHash
- , unPaymentHash
- , paymentHash
- , PaymentPreimage
- , unPaymentPreimage
- , paymentPreimage
+ -- * Commitment transactions
+ CommitmentContext(..)
+ , CommitmentFormat(..)
+ , CommitmentTx(..)
+ , CommitmentOutput(..)
+ , OutputType(..)
+ , build_commitment_tx
- -- ** Transaction primitives
- , TxId(..)
- , mkTxId
- , OutPoint(..)
- , Sequence(..)
- , Locktime(..)
+ -- ** HTLCs
+ , HTLC(..)
+ , HTLCDirection(..)
-- ** Channel parameters
, CommitmentNumber
- , unCommitmentNumber
, commitment_number
+ , un_commitment_number
, next_commitment_number
, ToSelfDelay(..)
, CltvExpiry(..)
, DustLimit(..)
, FeeratePerKw(..)
+ , Locktime(..)
+ , Sequence(..)
- -- ** HTLC types
- , HTLC(..)
- , HTLCDirection(..)
+ -- ** Fees and trimming
+ , commitment_fee
+ , htlc_timeout_fee
+ , htlc_success_fee
+ , htlc_trim_threshold
+ , is_trimmed
+ , anchor_output_value
+
+ -- * HTLC transactions
+ , HTLCContext(..)
+ , HTLCTx(..)
+ , build_htlc_tx
+
+ -- * Closing transactions
+ , ClosingTx(..)
+ , ClosingOutput(..)
+ , ClosingContext(..)
+ , ClosingOutputs(..)
+ , build_closing_tx
+ , LegacyClosingContext(..)
+ , build_legacy_closing_tx
+
+ -- ** Dust thresholds
+ , dust_p2pkh
+ , dust_p2sh
+ , dust_p2wpkh
+ , dust_p2wsh
+
+ -- * Serialization
+ , commitment_to_tx
+ , htlc_to_tx
+ , closing_to_tx
+ , encode_commitment_tx
+ , encode_htlc_tx
+ , encode_closing_tx
- -- ** Basepoints
+ -- * Keys
+ -- ** Basepoints and per-commitment points
, Basepoints(..)
- , PerCommitmentPoint(..)
- , PerCommitmentSecret
- , unPerCommitmentSecret
- , perCommitmentSecret
, RevocationBasepoint(..)
, PaymentBasepoint(..)
, DelayedPaymentBasepoint(..)
, HtlcBasepoint(..)
+ , PerCommitmentPoint(..)
+ , derive_per_commitment_point
+ , derive_per_commitment_point'
- -- ** Derived keys
- , LocalPubkey(..)
- , RemotePubkey(..)
+ -- ** Public keys
+ , CommitmentKeys(..)
+ , derive_commitment_keys
+ , derive_commitment_keys'
+ , RevocationPubkey(..)
, LocalDelayedPubkey(..)
- , RemoteDelayedPubkey(..)
, LocalHtlcPubkey(..)
, RemoteHtlcPubkey(..)
- , RevocationPubkey(..)
+ , RemotePubkey(..)
, FundingPubkey(..)
-
- -- ** Script and witness
- , Script(..)
- , Witness(..)
-
- -- ** Channel features
- , ChannelFeatures(..)
- , has_anchors
-
- -- ** Constants
- , commitment_weight_no_anchors
- , commitment_weight_anchors
- , htlc_timeout_weight_no_anchors
- , htlc_timeout_weight_anchors
- , htlc_success_weight_no_anchors
- , htlc_success_weight_anchors
- , htlc_output_weight
- , dust_p2pkh
- , dust_p2sh
- , dust_p2wpkh
- , dust_p2wsh
- , anchor_output_value
-
- -- * Key derivation
- , derive_per_commitment_point
- , derive_per_commitment_point'
, derive_pubkey
- , derive_pubkey'
- , derive_localpubkey
- , derive_localpubkey'
- , derive_local_htlcpubkey
- , derive_local_htlcpubkey'
- , derive_remote_htlcpubkey
- , derive_remote_htlcpubkey'
- , derive_local_delayedpubkey
- , derive_local_delayedpubkey'
- , derive_remote_delayedpubkey
- , derive_remote_delayedpubkey'
, derive_revocationpubkey
- -- ** Secret generation
+ -- ** Private keys
+ , Seckey
+ , seckey
+ , un_seckey
+ , derive_privkey
+ , derive_revocationprivkey
+
+ -- * Per-commitment secrets
+ , Seed
+ , seed
+ , un_seed
+ , SecretIndex
+ , secret_index
+ , un_secret_index
+ , commitment_secret_index
, generate_from_seed
- , derive_secret
- -- ** Secret storage
- , SecretStore(..)
- , SecretEntry(..)
- , empty_store
+ -- ** Storage
+ , SecretStore
+ , empty_secret_store
, insert_secret
, derive_old_secret
+ , secret_store
+ , un_secret_store
- -- ** Commitment number
+ -- ** Commitment number obscuring
, obscured_commitment_number
- -- * Scripts
+ -- * Scripts and witnesses
+ , Script(..)
+ , to_p2wsh
+
-- ** Funding output
, funding_script
, funding_witness
@@ -186,7 +145,8 @@ module Lightning.Protocol.BOLT3 (
, to_local_witness_revoke
-- ** to_remote output
- , to_remote_script
+ , to_remote_witness_script
+ , to_remote_script_pubkey
, to_remote_witness
-- ** Anchor outputs
@@ -194,105 +154,23 @@ module Lightning.Protocol.BOLT3 (
, anchor_witness_owner
, anchor_witness_anyone
- -- ** Offered HTLC
+ -- ** Offered HTLC outputs
, offered_htlc_script
, offered_htlc_witness_preimage
, offered_htlc_witness_revoke
- -- ** Received HTLC
+ -- ** Received HTLC outputs
, received_htlc_script
, received_htlc_witness_timeout
, received_htlc_witness_revoke
- -- ** HTLC output (same as to_local)
- , htlc_output_script
- , htlc_output_witness_spend
- , htlc_output_witness_revoke
-
- -- ** P2WSH helpers
- , to_p2wsh
- , witness_script_hash
-
- -- * Transaction assembly
- -- ** Commitment transactions
- , CommitmentTx(..)
- , CommitmentContext(..)
- , CommitmentKeys(..)
- , build_commitment_tx
-
- -- ** HTLC transactions
- , HTLCTx(..)
- , HTLCContext(..)
- , build_htlc_timeout_tx
- , build_htlc_success_tx
-
- -- ** Closing transactions
- , ClosingTx(..)
- , ClosingContext(..)
- , build_closing_tx
- , build_legacy_closing_tx
-
- -- ** Transaction outputs
- , TxOutput(..)
- , OutputType(..)
-
- -- ** Fee calculation
- , commitment_fee
- , commitment_weight
- , htlc_timeout_fee
- , htlc_success_fee
-
- -- ** Trimming
- , htlc_trim_threshold
- , is_trimmed
- , trimmed_htlcs
- , untrimmed_htlcs
-
- -- ** Output ordering
- , sort_outputs
-
- -- * Conversion to ppad-tx
- , commitment_to_tx
- , htlc_to_tx
- , closing_to_tx
-
- -- * Serialization
- , encode_tx
- , encode_htlc_tx
- , encode_closing_tx
- , encode_tx_for_signing
- , encode_witness
- , encode_funding_witness
-
- -- * Parsing
- , BT.Tx(..)
- , BT.TxIn(..)
- , BT.TxOut(BT.TxOut)
- , BT.from_bytes
- , decode_tx
-
- -- * Validation
- , ValidationError(..)
- , validate_commitment_tx
- , validate_commitment_locktime
- , validate_commitment_sequence
- , validate_htlc_tx
- , validate_htlc_timeout_tx
- , validate_htlc_success_tx
- , validate_closing_tx
- , validate_legacy_closing_tx
- , validate_output_ordering
- , validate_dust_limits
- , validate_anchor_outputs
- , validate_commitment_fee
- , validate_htlc_fee
+ -- ** HTLC transaction inputs
+ , htlc_success_witness
+ , htlc_timeout_witness
+ , remote_htlc_sighash
) where
-import qualified Bitcoin.Prim.Tx as BT
-import Lightning.Protocol.BOLT3.Types
import Lightning.Protocol.BOLT3.Keys
import Lightning.Protocol.BOLT3.Scripts
import Lightning.Protocol.BOLT3.Tx
-import Lightning.Protocol.BOLT3.Encode
-import Lightning.Protocol.BOLT3.Decode
-import Lightning.Protocol.BOLT3.Validate
+import Lightning.Protocol.BOLT3.Types
diff --git a/lib/Lightning/Protocol/BOLT3/Decode.hs b/lib/Lightning/Protocol/BOLT3/Decode.hs
@@ -1,27 +0,0 @@
-{-# OPTIONS_HADDOCK prune #-}
-
--- |
--- Module: Lightning.Protocol.BOLT3.Decode
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Parsing for BOLT #3 transactions.
---
--- Delegates to ppad-tx for transaction decoding.
-
-module Lightning.Protocol.BOLT3.Decode (
- decode_tx
- ) where
-
-import qualified Bitcoin.Prim.Tx as BT
-import qualified Data.ByteString as BS
-
--- | Decode a raw Bitcoin transaction from bytes.
---
--- Handles both legacy and SegWit transaction formats.
---
--- >>> decode_tx rawTxBytes
--- Just (Tx {...})
-decode_tx :: BS.ByteString -> Maybe BT.Tx
-decode_tx = BT.from_bytes
diff --git a/lib/Lightning/Protocol/BOLT3/Encode.hs b/lib/Lightning/Protocol/BOLT3/Encode.hs
@@ -1,102 +0,0 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
-
--- |
--- Module: Lightning.Protocol.BOLT3.Encode
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Serialization for BOLT #3 transactions and scripts.
---
--- Delegates to ppad-tx for transaction encoding.
-
-module Lightning.Protocol.BOLT3.Encode (
- -- * Transaction serialization
- encode_tx
- , encode_htlc_tx
- , encode_closing_tx
- , encode_tx_for_signing
-
- -- * Witness serialization
- , encode_witness
- , encode_funding_witness
- ) where
-
-import qualified Bitcoin.Prim.Tx as BT
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as BSB
-import Data.Word (Word64)
-import Lightning.Protocol.BOLT3.Types
-import Lightning.Protocol.BOLT3.Tx
-
--- transaction encoding --------------------------------------------------------
-
--- | Encode a commitment transaction (SegWit format).
---
--- Returns 'Nothing' if the transaction has no outputs.
-encode_tx :: CommitmentTx -> Maybe BS.ByteString
-encode_tx = fmap BT.to_bytes . commitment_to_tx
-
--- | Encode an HTLC transaction (SegWit format).
-encode_htlc_tx :: HTLCTx -> BS.ByteString
-encode_htlc_tx = BT.to_bytes . htlc_to_tx
-
--- | Encode a closing transaction (SegWit format).
---
--- Returns 'Nothing' if the transaction has no outputs.
-encode_closing_tx :: ClosingTx -> Maybe BS.ByteString
-encode_closing_tx = fmap BT.to_bytes . closing_to_tx
-
--- | Encode a commitment transaction for signing (stripped
--- format, no witness).
---
--- Returns 'Nothing' if the transaction has no outputs.
-encode_tx_for_signing
- :: CommitmentTx -> Maybe BS.ByteString
-encode_tx_for_signing =
- fmap BT.to_bytes_legacy . commitment_to_tx
-
--- witness encoding ------------------------------------------------------------
-
--- | Encode a witness stack.
---
--- Format: varint item count, then for each item:
--- varint length followed by item data.
-encode_witness :: Witness -> BS.ByteString
-encode_witness (Witness !items) =
- BT.to_strict $
- put_varint (fromIntegral (length items))
- <> foldMap put_item items
- where
- put_item :: BS.ByteString -> BSB.Builder
- put_item !bs =
- put_varint (fromIntegral (BS.length bs))
- <> BSB.byteString bs
-
--- | Encode a varint to a 'BSB.Builder'.
-put_varint :: Word64 -> BSB.Builder
-put_varint !n
- | n < 0xFD = BSB.word8 (fromIntegral n)
- | n <= 0xFFFF =
- BSB.word8 0xFD <> BSB.word16LE (fromIntegral n)
- | n <= 0xFFFFFFFF =
- BSB.word8 0xFE <> BSB.word32LE (fromIntegral n)
- | otherwise =
- BSB.word8 0xFF <> BSB.word64LE n
-{-# INLINE put_varint #-}
-
--- | Encode a funding witness (2-of-2 multisig).
---
--- The witness stack is: @0 <sig1> <sig2> <witnessScript>@
---
--- Signatures must be ordered to match pubkey order in the
--- funding script.
-encode_funding_witness
- :: BS.ByteString -- ^ Signature for lesser pubkey
- -> BS.ByteString -- ^ Signature for greater pubkey
- -> Script -- ^ The funding witness script
- -> BS.ByteString
-encode_funding_witness !sig1 !sig2 (Script !ws) =
- encode_witness
- (Witness [BS.empty, sig1, sig2, ws])
diff --git a/lib/Lightning/Protocol/BOLT3/Internal.hs b/lib/Lightning/Protocol/BOLT3/Internal.hs
@@ -1,56 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-
--- |
--- Module: Lightning.Protocol.BOLT3.Internal
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Internal definitions for BOLT #3.
---
--- This module exports unsafe constructors that bypass
--- validation. Use only in tests or trusted internal code.
-
-module Lightning.Protocol.BOLT3.Internal (
- -- * Unsafe constructors (bypass validation)
- unsafePubkey
- , unsafeSeckey
- , unsafeCommitmentNumber
- , unsafeSequence
- , unsafeLocktime
- ) where
-
-import qualified Data.ByteString as BS
-import Data.Word (Word32, Word64)
-import Lightning.Protocol.BOLT3.Types
-
--- | Construct a 'Pubkey' without length validation.
---
--- For test use only.
-unsafePubkey :: BS.ByteString -> Pubkey
-unsafePubkey = Pubkey
-
--- | Construct a 'Seckey' without length validation.
---
--- For test use only.
-unsafeSeckey :: BS.ByteString -> Seckey
-unsafeSeckey = Seckey
-
--- | Construct a 'CommitmentNumber' without range
--- validation.
---
--- For test use only.
-unsafeCommitmentNumber :: Word64 -> CommitmentNumber
-unsafeCommitmentNumber = CommitmentNumber
-
--- | Construct a 'Sequence' directly.
---
--- For test use only.
-unsafeSequence :: Word32 -> Sequence
-unsafeSequence = Sequence
-
--- | Construct a 'Locktime' directly.
---
--- For test use only.
-unsafeLocktime :: Word32 -> Locktime
-unsafeLocktime = Locktime
diff --git a/lib/Lightning/Protocol/BOLT3/Keys.hs b/lib/Lightning/Protocol/BOLT3/Keys.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -8,532 +8,624 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Per-commitment key derivation per BOLT #3.
---
--- Implements key derivation formulas:
---
--- @
--- pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G
--- revocationpubkey = revocation_basepoint * SHA256(revocation_basepoint
--- || per_commitment_point)
--- + per_commitment_point * SHA256(per_commitment_point
--- || revocation_basepoint)
--- @
+-- Key derivation, per-commitment secrets and commitment number
+-- obscuring, per BOLT #3.
module Lightning.Protocol.BOLT3.Keys (
- -- * Per-commitment point derivation
+ -- * Per-commitment points
derive_per_commitment_point
, derive_per_commitment_point'
- -- * Key derivation
+ -- * Public keys
, derive_pubkey
- , derive_pubkey'
- , derive_localpubkey
- , derive_localpubkey'
- , derive_local_htlcpubkey
- , derive_local_htlcpubkey'
- , derive_remote_htlcpubkey
- , derive_remote_htlcpubkey'
- , derive_local_delayedpubkey
- , derive_local_delayedpubkey'
- , derive_remote_delayedpubkey
- , derive_remote_delayedpubkey'
-
- -- * Revocation key derivation
, derive_revocationpubkey
+ , CommitmentKeys(..)
+ , derive_commitment_keys
+ , derive_commitment_keys'
- -- * Per-commitment secret generation
- , generate_from_seed
- , derive_secret
+ -- * Private keys
+ , derive_privkey
+ , derive_revocationprivkey
- -- * Per-commitment secret storage
- , SecretStore(..)
- , SecretEntry(..)
- , empty_store
+ -- * Per-commitment secrets
+ , generate_from_seed
+ , SecretStore
+ , empty_secret_store
, insert_secret
, derive_old_secret
+ , secret_store
+ , un_secret_store
-- * Commitment number obscuring
, obscured_commitment_number
) where
-import Data.Bits ((.&.), xor, shiftL, testBit, complementBit)
+import Control.DeepSeq (NFData(..))
+import qualified Crypto.Curve.Secp256k1 as S
+import qualified Crypto.Hash.SHA256 as SHA256
+import Data.Bits ((.&.), (.|.), complement, complementBit, shiftL, shiftR,
+ testBit, xor)
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Unsafe as BU
import Data.Word (Word64)
import GHC.Generics (Generic)
-import qualified Crypto.Curve.Secp256k1 as S
-import qualified Crypto.Hash.SHA256 as SHA256
+import Lightning.Protocol.BOLT1 (Point, PerCommitmentSecret)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT3.Types
--- Per-commitment point derivation ----------------------------------------
+-- points ---------------------------------------------------------------------
+
+-- Serialize a secp256k1 point, failing on the point at infinity.
+to_point :: S.Projective -> Maybe Point
+to_point p
+ | p == S._CURVE_ZERO = Nothing
+ | otherwise = case BOLT1.point (S.serialize_point p) of
+ Just pt -> Just pt
+ Nothing -> internal_error
+{-# INLINE to_point #-}
+
+-- per-commitment points ------------------------------------------------------
--- | Derive the per-commitment point from a per-commitment secret.
+-- | Derive the per-commitment point from a per-commitment secret:
--
--- @per_commitment_point = per_commitment_secret * G@
+-- @per_commitment_point = per_commitment_secret * G@
--
--- >>> let secret = PerCommitmentSecret (BS.replicate 32 0x01)
--- >>> derive_per_commitment_point secret
--- Just (PerCommitmentPoint ...)
+-- Fails if the secret is not a valid secp256k1 secret key.
+--
+-- >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])
+-- >>> let Just (PerCommitmentPoint p) = derive_per_commitment_point s
+-- >>> B16.encode (BOLT1.un_point p)
+-- "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
derive_per_commitment_point
:: PerCommitmentSecret
-> Maybe PerCommitmentPoint
-derive_per_commitment_point (PerCommitmentSecret sec) = do
- sk <- S.parse_int256 sec
+derive_per_commitment_point s = do
+ sk <- S.parse_int256 (BOLT1.un_per_commitment_secret s)
pk <- S.derive_pub sk
- let !bs = S.serialize_point pk
- pure $! PerCommitmentPoint (Point bs)
-{-# INLINE derive_per_commitment_point #-}
+ PerCommitmentPoint <$> to_point pk
--- | As 'derive_per_commitment_point', but takes a precomputed
--- secp256k1 'S.Context' so the @G@-base scalar mult uses wNAF.
--- Caller threads a single context across many calls.
---
--- >>> let !tex = S.precompute
--- >>> derive_per_commitment_point' tex secret
--- Just (PerCommitmentPoint ...)
+-- | As 'derive_per_commitment_point', but uses a precomputed
+-- 'S.Context' to speed up the scalar multiplication.
derive_per_commitment_point'
:: S.Context
-> PerCommitmentSecret
-> Maybe PerCommitmentPoint
-derive_per_commitment_point' tex (PerCommitmentSecret sec) = do
- sk <- S.parse_int256 sec
+derive_per_commitment_point' tex s = do
+ sk <- S.parse_int256 (BOLT1.un_per_commitment_secret s)
pk <- S.derive_pub' tex sk
- let !bs = S.serialize_point pk
- pure $! PerCommitmentPoint (Point bs)
-{-# INLINE derive_per_commitment_point' #-}
+ PerCommitmentPoint <$> to_point pk
--- Key derivation ---------------------------------------------------------
+-- public keys ----------------------------------------------------------------
--- | Derive a pubkey from a basepoint and per-commitment point.
---
--- @pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G@
+-- | Derive a per-commitment public key from a basepoint:
--
--- This is the general derivation formula used for localpubkey,
--- local_htlcpubkey, remote_htlcpubkey, local_delayedpubkey, and
--- remote_delayedpubkey.
+-- @pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G@
--
--- >>> derive_pubkey basepoint per_commitment_point
--- Just (Pubkey ...)
-derive_pubkey
- :: Point -- ^ basepoint
- -> PerCommitmentPoint -- ^ per_commitment_point
- -> Maybe Pubkey
-derive_pubkey (Point basepointBs) (PerCommitmentPoint (Point pcpBs)) = do
- basepoint <- S.parse_point basepointBs
- -- SHA256(per_commitment_point || basepoint)
- let !h = SHA256.hash (pcpBs <> basepointBs)
- -- Treat hash as scalar and multiply by G
- tweak <- S.parse_int256 h
- tweakPoint <- S.derive_pub tweak
- -- Add basepoint + tweak*G
- let !result = S.add basepoint tweakPoint
- !bs = S.serialize_point result
- pure $! Pubkey bs
-{-# INLINE derive_pubkey #-}
-
--- | As 'derive_pubkey', but takes a precomputed secp256k1
--- 'S.Context'. The @tweak * G@ multiplication uses wNAF; this is
--- the highest-leverage variant since 'derive_pubkey' fires five
--- times per commitment-key derivation.
+-- This gives @local_htlcpubkey@, @remote_htlcpubkey@,
+-- @local_delayedpubkey@ and the like, depending on the basepoint;
+-- 'derive_commitment_keys' derives all of a commitment's keys at
+-- once.
--
--- >>> let !tex = S.precompute
--- >>> derive_pubkey' tex basepoint per_commitment_point
--- Just (Pubkey ...)
-derive_pubkey'
- :: S.Context
- -> Point -- ^ basepoint
- -> PerCommitmentPoint -- ^ per_commitment_point
- -> Maybe Pubkey
-derive_pubkey'
- tex
- (Point basepointBs)
- (PerCommitmentPoint (Point pcpBs)) = do
- basepoint <- S.parse_point basepointBs
- let !h = SHA256.hash (pcpBs <> basepointBs)
- tweak <- S.parse_int256 h
- tweakPoint <- S.derive_pub' tex tweak
- let !result = S.add basepoint tweakPoint
- !bs = S.serialize_point result
- pure $! Pubkey bs
-{-# INLINE derive_pubkey' #-}
-
--- | Derive localpubkey from payment_basepoint and per_commitment_point.
+-- Fails if the basepoint is not on the curve.
--
--- >>> derive_localpubkey payment_basepoint per_commitment_point
--- Just (LocalPubkey ...)
-derive_localpubkey
- :: PaymentBasepoint
- -> PerCommitmentPoint
- -> Maybe LocalPubkey
-derive_localpubkey (PaymentBasepoint pt) pcp =
- LocalPubkey <$> derive_pubkey pt pcp
-{-# INLINE derive_localpubkey #-}
-
--- | As 'derive_localpubkey', but uses 'derive_pubkey'' internally
--- (wNAF-accelerated).
-derive_localpubkey'
- :: S.Context
- -> PaymentBasepoint
- -> PerCommitmentPoint
- -> Maybe LocalPubkey
-derive_localpubkey' tex (PaymentBasepoint pt) pcp =
- LocalPubkey <$> derive_pubkey' tex pt pcp
-{-# INLINE derive_localpubkey' #-}
-
--- | Derive local_htlcpubkey from htlc_basepoint and per_commitment_point.
---
--- >>> derive_local_htlcpubkey htlc_basepoint per_commitment_point
--- Just (LocalHtlcPubkey ...)
-derive_local_htlcpubkey
- :: HtlcBasepoint
- -> PerCommitmentPoint
- -> Maybe LocalHtlcPubkey
-derive_local_htlcpubkey (HtlcBasepoint pt) pcp =
- LocalHtlcPubkey <$> derive_pubkey pt pcp
-{-# INLINE derive_local_htlcpubkey #-}
-
--- | As 'derive_local_htlcpubkey', wNAF variant.
-derive_local_htlcpubkey'
- :: S.Context
- -> HtlcBasepoint
- -> PerCommitmentPoint
- -> Maybe LocalHtlcPubkey
-derive_local_htlcpubkey' tex (HtlcBasepoint pt) pcp =
- LocalHtlcPubkey <$> derive_pubkey' tex pt pcp
-{-# INLINE derive_local_htlcpubkey' #-}
-
--- | Derive remote_htlcpubkey from htlc_basepoint and per_commitment_point.
---
--- >>> derive_remote_htlcpubkey htlc_basepoint per_commitment_point
--- Just (RemoteHtlcPubkey ...)
-derive_remote_htlcpubkey
- :: HtlcBasepoint
- -> PerCommitmentPoint
- -> Maybe RemoteHtlcPubkey
-derive_remote_htlcpubkey (HtlcBasepoint pt) pcp =
- RemoteHtlcPubkey <$> derive_pubkey pt pcp
-{-# INLINE derive_remote_htlcpubkey #-}
-
--- | As 'derive_remote_htlcpubkey', wNAF variant.
-derive_remote_htlcpubkey'
- :: S.Context
- -> HtlcBasepoint
- -> PerCommitmentPoint
- -> Maybe RemoteHtlcPubkey
-derive_remote_htlcpubkey' tex (HtlcBasepoint pt) pcp =
- RemoteHtlcPubkey <$> derive_pubkey' tex pt pcp
-{-# INLINE derive_remote_htlcpubkey' #-}
+-- >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])
+-- >>> let Just pcp = derive_per_commitment_point s
+-- >>> let Just b = BOLT1.per_commitment_secret (BS.pack [0 .. 31])
+-- >>> let Just (PerCommitmentPoint bp) = derive_per_commitment_point b
+-- >>> fmap (B16.encode . BOLT1.un_point) (derive_pubkey bp pcp)
+-- Just "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"
+derive_pubkey :: Point -> PerCommitmentPoint -> Maybe Point
+derive_pubkey = derive_pubkey_with mul_g
+{-# INLINE derive_pubkey #-}
--- | Derive local_delayedpubkey from delayed_payment_basepoint and
--- per_commitment_point.
---
--- >>> derive_local_delayedpubkey delayed_payment_basepoint per_commitment_point
--- Just (LocalDelayedPubkey ...)
-derive_local_delayedpubkey
- :: DelayedPaymentBasepoint
- -> PerCommitmentPoint
- -> Maybe LocalDelayedPubkey
-derive_local_delayedpubkey (DelayedPaymentBasepoint pt) pcp =
- LocalDelayedPubkey <$> derive_pubkey pt pcp
-{-# INLINE derive_local_delayedpubkey #-}
+-- Multiply the generator by a 32-byte scalar.
+mul_g :: BS.ByteString -> Maybe S.Projective
+mul_g bs = S.derive_pub =<< S.parse_int256 bs
+{-# INLINE mul_g #-}
--- | As 'derive_local_delayedpubkey', wNAF variant.
-derive_local_delayedpubkey'
- :: S.Context
- -> DelayedPaymentBasepoint
- -> PerCommitmentPoint
- -> Maybe LocalDelayedPubkey
-derive_local_delayedpubkey' tex (DelayedPaymentBasepoint pt) pcp =
- LocalDelayedPubkey <$> derive_pubkey' tex pt pcp
-{-# INLINE derive_local_delayedpubkey' #-}
-
--- | Derive remote_delayedpubkey from delayed_payment_basepoint and
--- per_commitment_point.
---
--- >>> derive_remote_delayedpubkey delayed_payment_basepoint pcp
--- Just (RemoteDelayedPubkey ...)
-derive_remote_delayedpubkey
- :: DelayedPaymentBasepoint
- -> PerCommitmentPoint
- -> Maybe RemoteDelayedPubkey
-derive_remote_delayedpubkey (DelayedPaymentBasepoint pt) pcp =
- RemoteDelayedPubkey <$> derive_pubkey pt pcp
-{-# INLINE derive_remote_delayedpubkey #-}
+-- As 'mul_g', using a precomputed context.
+mul_g' :: S.Context -> BS.ByteString -> Maybe S.Projective
+mul_g' tex bs = S.derive_pub' tex =<< S.parse_int256 bs
+{-# INLINE mul_g' #-}
--- | As 'derive_remote_delayedpubkey', wNAF variant.
-derive_remote_delayedpubkey'
- :: S.Context
- -> DelayedPaymentBasepoint
+derive_pubkey_with
+ :: (BS.ByteString -> Maybe S.Projective)
+ -> Point
-> PerCommitmentPoint
- -> Maybe RemoteDelayedPubkey
-derive_remote_delayedpubkey' tex (DelayedPaymentBasepoint pt) pcp =
- RemoteDelayedPubkey <$> derive_pubkey' tex pt pcp
-{-# INLINE derive_remote_delayedpubkey' #-}
-
--- Revocation key derivation ----------------------------------------------
-
--- Note: no @derive_revocationpubkey'@ is provided. The two scalar
--- mults inside this function are general (basepoint * scalar, not
--- @G * scalar@), so the wNAF table built by 'S.precompute' — which
--- stores multiples of the generator — doesn't apply.
-
--- | Derive revocationpubkey from revocation_basepoint and
--- per_commitment_point.
---
--- @
--- revocationpubkey = revocation_basepoint
--- * SHA256(revocation_basepoint || per_commitment_point)
--- + per_commitment_point
--- * SHA256(per_commitment_point || revocation_basepoint)
--- @
---
--- >>> derive_revocationpubkey revocation_basepoint per_commitment_point
--- Just (RevocationPubkey ...)
+ -> Maybe Point
+derive_pubkey_with mul bp (PerCommitmentPoint pcp) = do
+ let !bp_bs = BOLT1.un_point bp
+ base <- S.parse_point bp_bs
+ t <- mul (SHA256.hash (BOLT1.un_point pcp <> bp_bs))
+ to_point (S.add base t)
+{-# INLINE derive_pubkey_with #-}
+
+-- | Derive a commitment's @revocationpubkey@ from the revocation
+-- basepoint of the party that will hold the revocation key, and the
+-- commitment owner's per-commitment point:
+--
+-- @
+-- revocationpubkey =
+-- revocation_basepoint
+-- * SHA256(revocation_basepoint || per_commitment_point)
+-- + per_commitment_point
+-- * SHA256(per_commitment_point || revocation_basepoint)
+-- @
+--
+-- Fails if either point is not on the curve.
+--
+-- >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])
+-- >>> let Just pcp = derive_per_commitment_point s
+-- >>> let Just b = BOLT1.per_commitment_secret (BS.pack [0 .. 31])
+-- >>> let Just (PerCommitmentPoint p) = derive_per_commitment_point b
+-- >>> let Just r = derive_revocationpubkey (RevocationBasepoint p) pcp
+-- >>> (\(RevocationPubkey k) -> B16.encode (BOLT1.un_point k)) r
+-- "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0"
derive_revocationpubkey
:: RevocationBasepoint
-> PerCommitmentPoint
-> Maybe RevocationPubkey
derive_revocationpubkey
- (RevocationBasepoint (Point rbpBs))
- (PerCommitmentPoint (Point pcpBs)) = do
- rbp <- S.parse_point rbpBs
- pcp <- S.parse_point pcpBs
- -- SHA256(revocation_basepoint || per_commitment_point)
- let !h1 = SHA256.hash (rbpBs <> pcpBs)
- -- SHA256(per_commitment_point || revocation_basepoint)
- let !h2 = SHA256.hash (pcpBs <> rbpBs)
- -- Multiply points by their respective scalars
- s1 <- S.parse_int256 h1
- s2 <- S.parse_int256 h2
- p1 <- S.mul rbp s1 -- revocation_basepoint * h1
- p2 <- S.mul pcp s2 -- per_commitment_point * h2
- -- Add the two points
- let !result = S.add p1 p2
- !bs = S.serialize_point result
- pure $! RevocationPubkey (Pubkey bs)
-{-# INLINE derive_revocationpubkey #-}
-
--- Per-commitment secret generation ---------------------------------------
-
--- | Generate the I'th per-commitment secret from a seed.
---
--- Implements the generate_from_seed algorithm from BOLT #3:
---
--- @
--- generate_from_seed(seed, I):
--- P = seed
--- for B in 47 down to 0:
--- if B set in I:
--- flip(B) in P
--- P = SHA256(P)
--- return P
--- @
---
--- >>> generate_from_seed seed 281474976710655
--- <32-byte secret>
-generate_from_seed
- :: BS.ByteString -- ^ seed (32 bytes)
- -> Word64 -- ^ index I (max 2^48 - 1)
- -> BS.ByteString -- ^ per-commitment secret (32 bytes)
-generate_from_seed seed idx = go 47 seed where
- go :: Int -> BS.ByteString -> BS.ByteString
- go !b !p
- | b < 0 = p
- | testBit idx b =
- let !p' = flip_bit b p
- !p'' = SHA256.hash p'
- in go (b - 1) p''
- | otherwise = go (b - 1) p
-{-# INLINE generate_from_seed #-}
-
--- | Derive a secret from a base secret.
---
--- This is a generalization of generate_from_seed used for efficient
--- secret storage. Given a base secret whose index has bits..47 the same
--- as target index I, derive the I'th secret.
---
--- @
--- derive_secret(base, bits, I):
--- P = base
--- for B in bits - 1 down to 0:
--- if B set in I:
--- flip(B) in P
--- P = SHA256(P)
--- return P
--- @
-derive_secret
- :: BS.ByteString -- ^ base secret
- -> Int -- ^ bits (number of trailing bits to process)
- -> Word64 -- ^ target index I
- -> BS.ByteString -- ^ derived secret
-derive_secret base bits idx = go (bits - 1) base where
- go :: Int -> BS.ByteString -> BS.ByteString
- go !b !p
- | b < 0 = p
- | testBit idx b =
- let !p' = flip_bit b p
- !p'' = SHA256.hash p'
- in go (b - 1) p''
- | otherwise = go (b - 1) p
-{-# INLINE derive_secret #-}
-
--- | Flip bit B in a 32-byte bytestring.
---
--- "flip(B)" alternates the (B mod 8) bit of the (B div 8) byte.
+ (RevocationBasepoint rbp)
+ (PerCommitmentPoint pcp) = do
+ let !rbp_bs = BOLT1.un_point rbp
+ !pcp_bs = BOLT1.un_point pcp
+ r <- S.parse_point rbp_bs
+ p <- S.parse_point pcp_bs
+ s1 <- S.parse_int256 (SHA256.hash (rbp_bs <> pcp_bs))
+ s2 <- S.parse_int256 (SHA256.hash (pcp_bs <> rbp_bs))
+ p1 <- S.mul r s1
+ p2 <- S.mul p s2
+ RevocationPubkey <$> to_point (S.add p1 p2)
+
+-- | The keys a commitment transaction's scripts use.
+data CommitmentKeys = CommitmentKeys
+ { ck_revocation_pubkey :: !RevocationPubkey
+ , ck_local_delayed :: !LocalDelayedPubkey
+ , ck_local_htlc :: !LocalHtlcPubkey
+ , ck_remote_htlc :: !RemoteHtlcPubkey
+ , ck_remote_payment :: !RemotePubkey
+ , ck_local_funding :: !FundingPubkey
+ , ck_remote_funding :: !FundingPubkey
+ } deriving (Eq, Show, Generic)
+
+instance NFData CommitmentKeys
+
+-- | Derive the keys for a commitment transaction from both parties'
+-- basepoints and funding pubkeys, and the commitment owner's
+-- per-commitment point.
+--
+-- The owner is the "local" party: its delayed and HTLC basepoints
+-- give @local_delayedpubkey@ and @local_htlcpubkey@, while the other
+-- party's revocation and HTLC basepoints give @revocationpubkey@ and
+-- @remote_htlcpubkey@. As every supported 'CommitmentFormat' uses
+-- @option_static_remotekey@, @remotepubkey@ is the other party's
+-- @payment_basepoint@.
+--
+-- Fails if a basepoint it derives a key from, or the per-commitment
+-- point, is not on the curve.
+derive_commitment_keys
+ :: Basepoints -- ^ the owner's basepoints
+ -> FundingPubkey -- ^ the owner's funding pubkey
+ -> Basepoints -- ^ the other party's basepoints
+ -> FundingPubkey -- ^ the other party's funding pubkey
+ -> PerCommitmentPoint -- ^ the owner's per-commitment point
+ -> Maybe CommitmentKeys
+derive_commitment_keys = derive_commitment_keys_with mul_g
+
+-- | As 'derive_commitment_keys', but uses a precomputed 'S.Context'
+-- to speed up the scalar multiplications.
+derive_commitment_keys'
+ :: S.Context
+ -> Basepoints
+ -> FundingPubkey
+ -> Basepoints
+ -> FundingPubkey
+ -> PerCommitmentPoint
+ -> Maybe CommitmentKeys
+derive_commitment_keys' tex = derive_commitment_keys_with (mul_g' tex)
+
+derive_commitment_keys_with
+ :: (BS.ByteString -> Maybe S.Projective)
+ -> Basepoints
+ -> FundingPubkey
+ -> Basepoints
+ -> FundingPubkey
+ -> PerCommitmentPoint
+ -> Maybe CommitmentKeys
+derive_commitment_keys_with mul local local_fund remote remote_fund pcp = do
+ let DelayedPaymentBasepoint local_delayed_bp = bp_delayed_payment local
+ HtlcBasepoint local_htlc_bp = bp_htlc local
+ HtlcBasepoint remote_htlc_bp = bp_htlc remote
+ PaymentBasepoint remote_payment_bp = bp_payment remote
+ revocation <- derive_revocationpubkey (bp_revocation remote) pcp
+ delayed <- derive_pubkey_with mul local_delayed_bp pcp
+ local_htlc <- derive_pubkey_with mul local_htlc_bp pcp
+ remote_htlc <- derive_pubkey_with mul remote_htlc_bp pcp
+ pure CommitmentKeys
+ { ck_revocation_pubkey = revocation
+ , ck_local_delayed = LocalDelayedPubkey delayed
+ , ck_local_htlc = LocalHtlcPubkey local_htlc
+ , ck_remote_htlc = RemoteHtlcPubkey remote_htlc
+ , ck_remote_payment = RemotePubkey remote_payment_bp
+ , ck_local_funding = local_fund
+ , ck_remote_funding = remote_fund
+ }
+
+-- private keys ---------------------------------------------------------------
+
+-- | Derive the private key for a per-commitment public key from its
+-- basepoint secret:
+--
+-- @privkey = basepoint_secret + SHA256(per_commitment_point || basepoint)@
+--
+-- where @basepoint = basepoint_secret * G@. The result is the secret
+-- key for @'derive_pubkey' basepoint per_commitment_point@.
+--
+-- The arithmetic on the secret is constant-time. Fails (with
+-- negligible probability) if the result is zero.
+--
+-- >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])
+-- >>> let Just pcp = derive_per_commitment_point s
+-- >>> let Just k = seckey (BS.pack [0 .. 31])
+-- >>> fmap (B16.encode . un_seckey) (derive_privkey k pcp)
+-- Just "cbced912d3b21bf196a766651e436aff192362621ce317704ea2f75d87e7be0f"
+derive_privkey :: Seckey -> PerCommitmentPoint -> Maybe Seckey
+derive_privkey (Seckey sk_bs) (PerCommitmentPoint pcp) = do
+ sk <- S.parse_int256 sk_bs
+ bp <- to_point =<< S.derive_pub sk
+ let !h = SHA256.hash (BOLT1.un_point pcp <> BOLT1.un_point bp)
+ !r = add_mod_n (w4 sk_bs) (reduce_n (w4 h))
+ to_seckey r
+
+-- | Derive a commitment's @revocationprivkey@ from the revocation
+-- basepoint secret and the commitment's (revealed) per-commitment
+-- secret:
+--
+-- @
+-- revocationprivkey =
+-- revocation_basepoint_secret
+-- * SHA256(revocation_basepoint || per_commitment_point)
+-- + per_commitment_secret
+-- * SHA256(per_commitment_point || revocation_basepoint)
+-- @
+--
+-- The result is the secret key for the 'derive_revocationpubkey'
+-- of the corresponding points.
+--
+-- The arithmetic on the secrets is constant-time. Fails if the
+-- per-commitment secret is not a valid secret key, or (with
+-- negligible probability) if the result is zero.
+--
+-- >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])
+-- >>> let Just k = seckey (BS.pack [0 .. 31])
+-- >>> fmap (B16.encode . un_seckey) (derive_revocationprivkey k s)
+-- Just "d09ffff62ddb2297ab000cc85bcb4283fdeb6aa052affbc9dddcf33b61078110"
+derive_revocationprivkey
+ :: Seckey -- ^ revocation basepoint secret
+ -> PerCommitmentSecret -- ^ per-commitment secret
+ -> Maybe Seckey
+derive_revocationprivkey (Seckey rbs_bs) pcs = do
+ let !pcs_bs = BOLT1.un_per_commitment_secret pcs
+ rbs <- S.parse_int256 rbs_bs
+ ps <- S.parse_int256 pcs_bs
+ rbp <- to_point =<< S.derive_pub rbs
+ pcp <- to_point =<< S.derive_pub ps
+ let !rbp_bs = BOLT1.un_point rbp
+ !pcp_bs = BOLT1.un_point pcp
+ !h1 = reduce_n (w4 (SHA256.hash (rbp_bs <> pcp_bs)))
+ !h2 = reduce_n (w4 (SHA256.hash (pcp_bs <> rbp_bs)))
+ !r = add_mod_n (mul_mod_n (w4 rbs_bs) h1) (mul_mod_n (w4 pcs_bs) h2)
+ to_seckey r
+
+-- constant-time arithmetic modulo the secp256k1 group order ------------------
+
+-- A 256-bit integer as four 64-bit limbs, least significant first.
+data W4 = W4
+ {-# UNPACK #-} !Word64
+ {-# UNPACK #-} !Word64
+ {-# UNPACK #-} !Word64
+ {-# UNPACK #-} !Word64
+
+-- The secp256k1 group order n.
+_N :: W4
+_N = W4 0xBFD25E8CD0364141 0xBAAEDCE6AF48A03B
+ 0xFFFFFFFFFFFFFFFE 0xFFFFFFFFFFFFFFFF
+
+-- Read 32 big-endian bytes (the length is checked by the caller).
+w4 :: BS.ByteString -> W4
+w4 bs = W4 (limb 24) (limb 16) (limb 8) (limb 0) where
+ limb :: Int -> Word64
+ limb o = go 0 0 where
+ go !acc !i
+ | i == 8 = acc
+ | otherwise =
+ go ((acc `shiftL` 8) .|. fromIntegral (BU.unsafeIndex bs (o + i)))
+ (i + 1)
+
+-- Write 32 big-endian bytes.
+unw4 :: W4 -> BS.ByteString
+unw4 (W4 a b c d) = BSL.toStrict . BSB.toLazyByteString $
+ BSB.word64BE d <> BSB.word64BE c <> BSB.word64BE b <> BSB.word64BE a
+
+-- A valid secret key from a result in [0, n), failing on zero.
+to_seckey :: W4 -> Maybe Seckey
+to_seckey r@(W4 a b c d)
+ | (a .|. b .|. c .|. d) == 0 = Nothing
+ | otherwise = Just (Seckey (unw4 r))
+
+-- a + b + c, for a carry c in {0, 1}; returns the sum and carry out.
+adc :: Word64 -> Word64 -> Word64 -> (Word64, Word64)
+adc a b c =
+ let !s = a + b + c
+ !o = ((a .&. b) .|. ((a .|. b) .&. complement s)) `shiftR` 63
+ in (s, o)
+{-# INLINE adc #-}
+
+-- a - b - c, for a borrow c in {0, 1}; returns the difference and
+-- borrow out.
+sbb :: Word64 -> Word64 -> Word64 -> (Word64, Word64)
+sbb a b c =
+ let !s = a - b - c
+ !o = ((complement a .&. b) .|. (complement (a `xor` b) .&. s))
+ `shiftR` 63
+ in (s, o)
+{-# INLINE sbb #-}
+
+add4 :: W4 -> W4 -> (W4, Word64)
+add4 (W4 a0 a1 a2 a3) (W4 b0 b1 b2 b3) =
+ let !(s0, c0) = adc a0 b0 0
+ !(s1, c1) = adc a1 b1 c0
+ !(s2, c2) = adc a2 b2 c1
+ !(s3, c3) = adc a3 b3 c2
+ in (W4 s0 s1 s2 s3, c3)
+{-# INLINE add4 #-}
+
+sub4 :: W4 -> W4 -> (W4, Word64)
+sub4 (W4 a0 a1 a2 a3) (W4 b0 b1 b2 b3) =
+ let !(s0, c0) = sbb a0 b0 0
+ !(s1, c1) = sbb a1 b1 c0
+ !(s2, c2) = sbb a2 b2 c1
+ !(s3, c3) = sbb a3 b3 c2
+ in (W4 s0 s1 s2 s3, c3)
+{-# INLINE sub4 #-}
+
+-- x if the bit is 1, y if it is 0.
+select :: Word64 -> W4 -> W4 -> W4
+select bit (W4 x0 x1 x2 x3) (W4 y0 y1 y2 y3) =
+ let !m = negate bit
+ f x y = (x .&. m) .|. (y .&. complement m)
+ in W4 (f x0 y0) (f x1 y1) (f x2 y2) (f x3 y3)
+{-# INLINE select #-}
+
+-- x mod n, for any 256-bit x (one subtraction suffices, as 2^256 < 2n).
+reduce_n :: W4 -> W4
+reduce_n x =
+ let !(t, borrow) = sub4 x _N
+ in select borrow x t
+
+-- a + b mod n, for a, b < n.
+add_mod_n :: W4 -> W4 -> W4
+add_mod_n a b =
+ let !(s, carry) = add4 a b
+ !(t, borrow) = sub4 s _N
+ in select (carry .|. (borrow `xor` 1)) t s
+
+-- a * b mod n, for a, b < n, by double-and-add over all 256 bits of b.
+mul_mod_n :: W4 -> W4 -> W4
+mul_mod_n a (W4 b0 b1 b2 b3) = go (255 :: Int) (W4 0 0 0 0) where
+ go !i !acc
+ | i < 0 = acc
+ | otherwise =
+ let !d = add_mod_n acc acc
+ !bit = (limb (i `shiftR` 6) `shiftR` (i .&. 63)) .&. 1
+ in go (i - 1) (select bit (add_mod_n d a) d)
+ limb :: Int -> Word64
+ limb j = case j of
+ 0 -> b0
+ 1 -> b1
+ 2 -> b2
+ _ -> b3
+
+-- per-commitment secrets -----------------------------------------------------
+
+-- Wrap a 32-byte value as a per-commitment secret.
+to_secret :: BS.ByteString -> PerCommitmentSecret
+to_secret bs = case BOLT1.per_commitment_secret bs of
+ Just s -> s
+ Nothing -> internal_error
+{-# INLINE to_secret #-}
+
+-- Flip bit b (< 256) of a 32-byte value: the (b mod 8) bit of the
+-- (b div 8) byte.
flip_bit :: Int -> BS.ByteString -> BS.ByteString
flip_bit b bs =
- let !byteIdx = b `div` 8
- !bitIdx = b `mod` 8
- !len = BS.length bs
- in if byteIdx >= len
- then bs
- else
- let !prefix = BS.take byteIdx bs
- !byte = BS.index bs byteIdx
- !byte' = complementBit byte bitIdx
- !suffix = BS.drop (byteIdx + 1) bs
- in prefix <> BS.singleton byte' <> suffix
+ let !(pre, post) = BS.splitAt (b `shiftR` 3) bs
+ in case BS.uncons post of
+ Just (h, t) -> pre <> BS.cons (complementBit h (b .&. 7)) t
+ Nothing -> bs
{-# INLINE flip_bit #-}
--- Per-commitment secret storage ------------------------------------------
-
--- | Entry in the secret store: (bucket, index, secret).
-data SecretEntry = SecretEntry
- { se_bucket :: {-# UNPACK #-} !Int
- , se_index :: {-# UNPACK #-} !Word64
- , se_secret :: !BS.ByteString
- } deriving (Eq, Show, Generic)
-
--- | Compact storage for per-commitment secrets.
---
--- Stores up to 49 (value, index) pairs, allowing efficient derivation
--- of any previously-received secret. This is possible because for a
--- given secret on a 2^X boundary, all secrets up to the next 2^X
--- boundary can be derived from it.
-newtype SecretStore = SecretStore { unSecretStore :: [SecretEntry] }
- deriving (Eq, Show, Generic)
-
--- | Empty secret store.
-empty_store :: SecretStore
-empty_store = SecretStore []
-{-# INLINE empty_store #-}
-
--- | Determine which bucket to store a secret in based on its index.
---
--- Counts trailing zeros in the index. Returns 0-47 for normal indices,
--- or 48 if index is 0 (the seed).
-where_to_put_secret :: Word64 -> Int
-where_to_put_secret idx = go 0 where
+-- The spec's derive_secret: the secret for index i, from a base
+-- secret whose index agrees with i in bits 47 down to 'bits'.
+derive_secret :: BS.ByteString -> Int -> Word64 -> BS.ByteString
+derive_secret base bits i = go (bits - 1) base where
+ go !b !p
+ | b < 0 = p
+ | testBit i b = go (b - 1) (SHA256.hash (flip_bit b p))
+ | otherwise = go (b - 1) p
+
+-- | Generate the per-commitment secret with a given index from a seed,
+-- per BOLT #3's @generate_from_seed@.
+--
+-- >>> let Just s = seed (BS.replicate 32 0xff)
+-- >>> let Just i = secret_index 281474976710655
+-- >>> B16.encode (BOLT1.un_per_commitment_secret (generate_from_seed s i))
+-- "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"
+generate_from_seed :: Seed -> SecretIndex -> PerCommitmentSecret
+generate_from_seed (Seed s) (SecretIndex i) = to_secret (derive_secret s 48 i)
+
+-- | Compact storage for the per-commitment secrets received from a
+-- peer, per BOLT #3's "Efficient Per-commitment Secret Storage".
+--
+-- Holds at most 49 secrets, from which every secret received so far
+-- can be derived. This is secret material: its 'Show' instance is
+-- redacted, and it has no 'Eq' instance.
+newtype SecretStore = SecretStore [Entry]
+
+-- A stored secret: its bucket (the number of trailing zeros of its
+-- index), index, and value. Kept in ascending bucket order.
+data Entry = Entry
+ {-# UNPACK #-} !Int
+ {-# UNPACK #-} !Word64
+ !BS.ByteString
+
+instance Show SecretStore where
+ showsPrec d _ = showParen (d > 10) $
+ showString "SecretStore <redacted>"
+
+instance NFData SecretStore where
+ rnf (SecretStore es) = rnf_entries es where
+ rnf_entries [] = ()
+ rnf_entries (Entry _ _ s : rest) = rnf s `seq` rnf_entries rest
+
+-- | The empty 'SecretStore'.
+empty_secret_store :: SecretStore
+empty_secret_store = SecretStore []
+
+-- The bucket for an index: its number of trailing zeros (48 for 0).
+bucket_of :: Word64 -> Int
+bucket_of i = go 0 where
go !b
- | b > 47 = 48 -- index 0, this is the seed
- | testBit idx b = b
- | otherwise = go (b + 1)
-{-# INLINE where_to_put_secret #-}
-
--- | Insert a secret into the store, validating against existing secrets.
---
--- Implements insert_secret from BOLT #3: the secret is checked against
--- every known secret in a lower bucket, then replaces the entry in its
--- own bucket. Entries in all other buckets are kept, so that every
--- previously-inserted secret remains derivable via 'derive_old_secret'.
--- Entries are kept in ascending bucket order.
---
--- Returns Nothing if the secret is not 32 bytes, if the index is not
--- below 2^48, or if a known secret doesn't derive correctly from the
--- new one (indicating the secrets weren't generated from the same
--- seed).
---
--- >>> insert_secret secret 281474976710655 empty_store
--- Just (SecretStore ...)
+ | b > 47 = 48
+ | testBit i b = b
+ | otherwise = go (b + 1)
+
+-- Whether a secret at index j in bucket b can derive index i.
+can_derive :: Int -> Word64 -> Word64 -> Bool
+can_derive b j i = i .&. complement ((1 `shiftL` b) - 1) == j
+{-# INLINE can_derive #-}
+
+-- | Add a newly received per-commitment secret to the store, per
+-- BOLT #3's @insert_secret@.
+--
+-- Fails if a stored secret cannot be derived from the new one, i.e.
+-- if the secrets were not generated from the same seed (or were not
+-- received in order).
+--
+-- >>> let Just s = seed (BS.replicate 32 0xff)
+-- >>> let Just i = secret_index 281474976710655
+-- >>> let secret = generate_from_seed s i
+-- >>> let Just st = insert_secret secret i empty_secret_store
+-- >>> fmap (== secret) (derive_old_secret i st)
+-- Just True
insert_secret
- :: BS.ByteString -- ^ secret (32 bytes)
- -> Word64 -- ^ index (max 2^48 - 1)
- -> SecretStore -- ^ current store
+ :: PerCommitmentSecret
+ -> SecretIndex
+ -> SecretStore
-> Maybe SecretStore
-insert_secret secret idx (SecretStore known)
- | BS.length secret /= 32 = Nothing
- | idx > 0xFFFFFFFFFFFF = Nothing
+insert_secret pcs (SecretIndex i) (SecretStore known)
| all derives known = Just $! SecretStore (put known)
- | otherwise = Nothing
+ | otherwise = Nothing
where
- !bucket = where_to_put_secret idx
- !entry = SecretEntry bucket idx secret
+ !s = BOLT1.un_per_commitment_secret pcs
+ !b = bucket_of i
+ !e = Entry b i s
- -- known secrets in lower buckets must derive from the new one
- derives (SecretEntry b knownIdx knownSecret)
- | b < bucket = derive_secret secret bucket knownIdx == knownSecret
+ -- every secret in a lower bucket must derive from the new one
+ derives (Entry kb ki ks)
+ | kb < b = to_secret (derive_secret s b ki) == to_secret ks
| otherwise = True
- -- replace this bucket's entry, preserving ascending bucket order
- put [] = [entry]
- put (e : es) = case compare (se_bucket e) bucket of
- LT -> e : put es
- EQ -> entry : es
- GT -> entry : e : es
-{-# INLINE insert_secret #-}
+ -- replace this bucket's entry, keeping ascending bucket order
+ put [] = [e]
+ put (k@(Entry kb _ _) : ks) = case compare kb b of
+ LT -> k : put ks
+ EQ -> e : ks
+ GT -> e : k : ks
--- | Derive a previously-received secret from the store.
---
--- Iterates over known secrets to find one whose index is a prefix of
--- the target index, then derives the target secret from it.
---
--- >>> derive_old_secret 281474976710654 store
--- Just <32-byte secret>
+-- | Derive a previously received per-commitment secret from the
+-- store. Fails if the index has not been received.
derive_old_secret
- :: Word64 -- ^ target index
- -> SecretStore -- ^ store
- -> Maybe BS.ByteString
-derive_old_secret targetIdx (SecretStore known) = go known where
- go :: [SecretEntry] -> Maybe BS.ByteString
+ :: SecretIndex
+ -> SecretStore
+ -> Maybe PerCommitmentSecret
+derive_old_secret (SecretIndex i) (SecretStore known) = go known where
go [] = Nothing
- go (SecretEntry bucket knownIdx knownSecret : rest) =
- -- Mask off the non-zero prefix of the index using the entry's bucket
- let !mask = complement ((1 `shiftL` bucket) - 1)
- in if (targetIdx .&. mask) == knownIdx
- then Just $! derive_secret knownSecret bucket targetIdx
- else go rest
-
- complement :: Word64 -> Word64
- complement x = x `xor` 0xFFFFFFFFFFFFFFFF
-{-# INLINE derive_old_secret #-}
-
--- Commitment number obscuring --------------------------------------------
-
--- | Calculate the obscured commitment number.
---
--- The 48-bit commitment number is obscured by XOR with the lower 48 bits
--- of SHA256(payment_basepoint from open_channel
--- || payment_basepoint from accept_channel).
---
--- >>> obscured_commitment_number local_payment_bp remote_payment_bp cn
--- <obscured value>
+ go (Entry b j s : rest)
+ | can_derive b j i = Just $! to_secret (derive_secret s b i)
+ | otherwise = go rest
+
+-- | Rebuild a 'SecretStore' from its entries, e.g. as produced by
+-- 'un_secret_store'.
+--
+-- Fails if two entries share a bucket (i.e. their indices have the
+-- same number of trailing zeros), or if an entry contradicts another
+-- from which it can be derived.
+secret_store
+ :: [(SecretIndex, PerCommitmentSecret)]
+ -> Maybe SecretStore
+secret_store = go [] where
+ go acc [] = Just (SecretStore acc)
+ go acc ((SecretIndex i, pcs) : rest) = do
+ let !e = Entry (bucket_of i) i (BOLT1.un_per_commitment_secret pcs)
+ acc' <- place e acc
+ go acc' rest
+
+ -- insert in ascending bucket order, checking consistency with the
+ -- entries already placed
+ place e@(Entry b i s) es
+ | all (consistent e) es = put es
+ | otherwise = Nothing
+ where
+ put [] = Just [e]
+ put (k@(Entry kb _ _) : ks) = case compare kb b of
+ LT -> (k :) <$> put ks
+ EQ -> Nothing
+ GT -> Just (e : k : ks)
+ consistent _ (Entry kb ki ks)
+ | kb > b && can_derive kb ki i =
+ to_secret (derive_secret ks kb i) == to_secret s
+ | kb < b && can_derive b i ki =
+ to_secret (derive_secret s b ki) == to_secret ks
+ | otherwise = True
+
+-- | The entries of a 'SecretStore', for persistence; see
+-- 'secret_store'.
+un_secret_store :: SecretStore -> [(SecretIndex, PerCommitmentSecret)]
+un_secret_store (SecretStore es) =
+ [ (SecretIndex i, to_secret s) | Entry _ i s <- es ]
+
+-- commitment number obscuring ------------------------------------------------
+
+-- | Obscure a commitment number, by XOR with the lower 48 bits of
+--
+-- @SHA256(payment_basepoint from open_channel
+-- || payment_basepoint from accept_channel)@
+--
+-- As XOR is an involution, applying this to an obscured number
+-- recovers the commitment number. ('build_commitment_tx' obscures
+-- the commitment number itself.)
+--
+-- >>> let pay h = fmap PaymentBasepoint (BOLT1.point =<< B16.decode h)
+-- >>> let o1 = "034f355bdcb7cc0af728ef3cceb9615d9068"
+-- >>> let Just o = pay (o1 <> "4bb5b2ca5f859ab0f0b704075871aa")
+-- >>> let a1 = "032c0b7cf95324a07d05398b240174dc0c2b"
+-- >>> let Just a = pay (a1 <> "e444d96b159aa6c7f7b1e668680991")
+-- >>> fmap (obscured_commitment_number o a) (commitment_number 42)
+-- Just 48035859142974
obscured_commitment_number
:: PaymentBasepoint -- ^ opener's payment_basepoint
-> PaymentBasepoint -- ^ accepter's payment_basepoint
- -> CommitmentNumber -- ^ commitment number (48-bit)
- -> Word64 -- ^ obscured commitment number
+ -> CommitmentNumber
+ -> Word64
obscured_commitment_number
- (PaymentBasepoint (Point openerBs))
- (PaymentBasepoint (Point accepterBs))
- (CommitmentNumber cn) =
- let !h = SHA256.hash (openerBs <> accepterBs)
- -- Extract lower 48 bits (6 bytes) from the hash
- !lower48 = extractLower48 h
- -- Mask commitment number to 48 bits
- !cn48 = cn .&. 0xFFFFFFFFFFFF
- in cn48 `xor` lower48
-{-# INLINE obscured_commitment_number #-}
-
--- | Extract lower 48 bits from a 32-byte hash.
---
--- Takes bytes 26-31 (last 6 bytes) and interprets as big-endian Word64.
-extractLower48 :: BS.ByteString -> Word64
-extractLower48 h =
- let !b0 = fromIntegral (BS.index h 26) `shiftL` 40
- !b1 = fromIntegral (BS.index h 27) `shiftL` 32
- !b2 = fromIntegral (BS.index h 28) `shiftL` 24
- !b3 = fromIntegral (BS.index h 29) `shiftL` 16
- !b4 = fromIntegral (BS.index h 30) `shiftL` 8
- !b5 = fromIntegral (BS.index h 31)
- in b0 + b1 + b2 + b3 + b4 + b5
-{-# INLINE extractLower48 #-}
+ (PaymentBasepoint opener)
+ (PaymentBasepoint accepter)
+ cn =
+ let !h = SHA256.hash (BOLT1.un_point opener <> BOLT1.un_point accepter)
+ !mask = BS.foldl' (\acc x -> (acc `shiftL` 8) .|. fromIntegral x) 0
+ (BS.drop 26 h)
+ in un_commitment_number cn `xor` mask
diff --git a/lib/Lightning/Protocol/BOLT3/Scripts.hs b/lib/Lightning/Protocol/BOLT3/Scripts.hs
@@ -1,6 +1,5 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module: Lightning.Protocol.BOLT3.Scripts
@@ -8,17 +7,7 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Script templates for BOLT #3 transaction outputs.
---
--- Includes witness scripts for:
---
--- * Funding output (2-of-2 multisig)
--- * to_local output (revocable with CSV delay)
--- * to_remote output (P2WPKH or anchored)
--- * Anchor outputs
--- * Offered HTLC outputs
--- * Received HTLC outputs
--- * HTLC-timeout/success output (revocable with delay)
+-- Scripts and witnesses for BOLT #3 transaction outputs.
module Lightning.Protocol.BOLT3.Scripts (
-- * Funding output
@@ -31,7 +20,8 @@ module Lightning.Protocol.BOLT3.Scripts (
, to_local_witness_revoke
-- * to_remote output
- , to_remote_script
+ , to_remote_witness_script
+ , to_remote_script_pubkey
, to_remote_witness
-- * Anchor outputs
@@ -39,639 +29,475 @@ module Lightning.Protocol.BOLT3.Scripts (
, anchor_witness_owner
, anchor_witness_anyone
- -- * Offered HTLC output
+ -- * Offered HTLC outputs
, offered_htlc_script
, offered_htlc_witness_preimage
, offered_htlc_witness_revoke
- -- * Received HTLC output
+ -- * Received HTLC outputs
, received_htlc_script
, received_htlc_witness_timeout
, received_htlc_witness_revoke
- -- * HTLC-timeout/success output (same as to_local)
- , htlc_output_script
- , htlc_output_witness_spend
- , htlc_output_witness_revoke
+ -- * HTLC transaction inputs
+ , htlc_success_witness
+ , htlc_timeout_witness
+ , remote_htlc_sighash
- -- * P2WSH helpers
+ -- * P2WSH
, to_p2wsh
- , witness_script_hash
) where
+import Bitcoin.Prim.Tx (Witness(..))
+import Bitcoin.Prim.Tx.Sighash (SighashType(..))
+import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
+import qualified Crypto.Hash.SHA256 as SHA256
import Data.Bits ((.&.), shiftR)
-import Data.Word (Word8, Word16, Word32)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
-import qualified Crypto.Hash.SHA256 as SHA256
-import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
+import Data.Word (Word8, Word16, Word32)
+import Lightning.Protocol.BOLT1 (Point, PaymentPreimage)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT3.Types
--- opcodes ---------------------------------------------------------------------
-
--- | OP_0 / OP_FALSE (0x00)
-op_0 :: Word8
-op_0 = 0x00
+-- opcodes --------------------------------------------------------------------
--- | OP_PUSHDATA for 1-75 bytes just uses the length as opcode
--- For data <=75 bytes, opcode is just the length
-
--- | OP_IF (0x63)
-op_if :: Word8
-op_if = 0x63
+op_0, op_1, op_2, op_16 :: Word8
+op_0 = 0x00
+op_1 = 0x51
+op_2 = 0x52
+op_16 = 0x60
--- | OP_NOTIF (0x64)
-op_notif :: Word8
+op_if, op_notif, op_else, op_endif, op_drop, op_dup, op_ifdup :: Word8
+op_if = 0x63
op_notif = 0x64
-
--- | OP_ELSE (0x67)
-op_else :: Word8
-op_else = 0x67
-
--- | OP_ENDIF (0x68)
-op_endif :: Word8
+op_else = 0x67
op_endif = 0x68
-
--- | OP_DROP (0x75)
-op_drop :: Word8
-op_drop = 0x75
-
--- | OP_DUP (0x76)
-op_dup :: Word8
-op_dup = 0x76
-
--- | OP_SWAP (0x7c)
-op_swap :: Word8
-op_swap = 0x7c
-
--- | OP_SIZE (0x82)
-op_size :: Word8
-op_size = 0x82
-
--- | OP_EQUAL (0x87)
-op_equal :: Word8
-op_equal = 0x87
-
--- | OP_EQUALVERIFY (0x88)
-op_equalverify :: Word8
-op_equalverify = 0x88
-
--- | OP_IFDUP (0x73)
-op_ifdup :: Word8
op_ifdup = 0x73
+op_drop = 0x75
+op_dup = 0x76
--- | OP_HASH160 (0xa9)
-op_hash160 :: Word8
-op_hash160 = 0xa9
-
--- | OP_CHECKSIG (0xac)
-op_checksig :: Word8
-op_checksig = 0xac
+op_swap, op_size, op_equal, op_equalverify, op_hash160 :: Word8
+op_swap = 0x7c
+op_size = 0x82
+op_equal = 0x87
+op_equalverify = 0x88
+op_hash160 = 0xa9
--- | OP_CHECKSIGVERIFY (0xad)
-op_checksigverify :: Word8
+op_checksig, op_checksigverify, op_checkmultisig :: Word8
+op_checksig = 0xac
op_checksigverify = 0xad
+op_checkmultisig = 0xae
--- | OP_CHECKMULTISIG (0xae)
-op_checkmultisig :: Word8
-op_checkmultisig = 0xae
-
--- | OP_CHECKLOCKTIMEVERIFY (0xb1)
-op_checklocktimeverify :: Word8
+op_checklocktimeverify, op_checksequenceverify :: Word8
op_checklocktimeverify = 0xb1
-
--- | OP_CHECKSEQUENCEVERIFY (0xb2)
-op_checksequenceverify :: Word8
op_checksequenceverify = 0xb2
--- | OP_1 (0x51)
-op_1 :: Word8
-op_1 = 0x51
+-- helpers --------------------------------------------------------------------
--- | OP_2 (0x52)
-op_2 :: Word8
-op_2 = 0x52
+op :: Word8 -> BSB.Builder
+op = BSB.word8
+{-# INLINE op #-}
--- | OP_16 (0x60)
-op_16 :: Word8
-op_16 = 0x60
+-- Push data of at most 75 bytes (all pushes here are keys, hashes or
+-- short numbers).
+push :: BS.ByteString -> BSB.Builder
+push bs = BSB.word8 (fromIntegral (BS.length bs)) <> BSB.byteString bs
+{-# INLINE push #-}
--- helpers ---------------------------------------------------------------------
+push_point :: Point -> BSB.Builder
+push_point = push . BOLT1.un_point
+{-# INLINE push_point #-}
--- | Push a bytestring onto the stack (handles length encoding).
---
--- For data <= 75 bytes, the length itself is the opcode.
-push_data :: BS.ByteString -> BSB.Builder
-push_data !bs
- | len <= 75 = BSB.word8 (fromIntegral len) <> BSB.byteString bs
- | len <= 255 = BSB.word8 0x4c <> BSB.word8 (fromIntegral len)
- <> BSB.byteString bs
- | len <= 65535 = BSB.word8 0x4d <> BSB.word16LE (fromIntegral len)
- <> BSB.byteString bs
- | otherwise = BSB.word8 0x4e <> BSB.word32LE (fromIntegral len)
- <> BSB.byteString bs
+-- Push a non-negative number, minimally encoded.
+push_num :: Word32 -> BSB.Builder
+push_num n
+ | n == 0 = op op_0
+ | n <= 16 = op (0x50 + fromIntegral n)
+ | otherwise = push (BS.pack (signed (le n)))
where
- !len = BS.length bs
-{-# INLINE push_data #-}
-
--- | Encode a Word16 as minimal script number (for CSV delays).
-push_csv_delay :: Word16 -> BSB.Builder
-push_csv_delay !n
- | n == 0 = BSB.word8 op_0
- | n <= 16 = BSB.word8 (0x50 + fromIntegral n)
- | n <= 0x7f = push_data (BS.singleton (fromIntegral n))
- | n <= 0x7fff = push_data (BS.pack [lo, hi])
- | otherwise = push_data (BS.pack [lo, hi, 0x00]) -- need sign byte
- where
- !lo = fromIntegral (n .&. 0xff)
- !hi = fromIntegral ((n `shiftR` 8) .&. 0xff)
-{-# INLINE push_csv_delay #-}
-
--- | Encode a Word32 as minimal script number (for CLTV).
-push_cltv :: Word32 -> BSB.Builder
-push_cltv !n
- | n == 0 = BSB.word8 op_0
- | n <= 16 = BSB.word8 (0x50 + fromIntegral n)
- | otherwise = push_data (encode_scriptnum n)
- where
- encode_scriptnum :: Word32 -> BS.ByteString
- encode_scriptnum 0 = BS.empty
- encode_scriptnum !v =
- let -- Build bytes little-endian (LSB first)
- go :: Word32 -> [Word8]
- go 0 = []
- go !x = fromIntegral (x .&. 0xff) : go (x `shiftR` 8)
- !bytes = go v
- -- If MSB has high bit set, need 0x00 suffix for positive numbers
- !result = case reverse bytes of
- [] -> bytes
- (msb:_) | msb .&. 0x80 /= 0 -> bytes ++ [0x00]
- _ -> bytes
- in BS.pack result
-{-# INLINE push_cltv #-}
-
--- | Build script from builder.
-build_script :: BSB.Builder -> Script
-build_script = Script . BSL.toStrict . BSB.toLazyByteString
-{-# INLINE build_script #-}
-
--- | HASH160 = RIPEMD160(SHA256(x))
+ -- little-endian magnitude
+ le :: Word32 -> [Word8]
+ le !x
+ | x == 0 = []
+ | otherwise = fromIntegral (x .&. 0xff) : le (x `shiftR` 8)
+
+ -- append a sign byte if the top bit is set
+ signed bs = case reverse bs of
+ (h : _) | h .&. 0x80 /= 0 -> bs <> [0x00]
+ _ -> bs
+
+push_delay :: Word16 -> BSB.Builder
+push_delay = push_num . fromIntegral
+{-# INLINE push_delay #-}
+
+script :: BSB.Builder -> Script
+script = Script . BSL.toStrict . BSB.toLazyByteString
+{-# INLINE script #-}
+
hash160 :: BS.ByteString -> BS.ByteString
hash160 = RIPEMD160.hash . SHA256.hash
{-# INLINE hash160 #-}
--- P2WSH helpers ---------------------------------------------------------------
+-- Append a witness script to a witness stack.
+with_script :: [BS.ByteString] -> Script -> Witness
+with_script items (Script s) = Witness (items <> [s])
+{-# INLINE with_script #-}
--- | Compute SHA256 hash of a witness script.
---
--- >>> witness_script_hash (Script "some_script")
--- <32-byte SHA256 hash>
-witness_script_hash :: Script -> BS.ByteString
-witness_script_hash (Script !s) = SHA256.hash s
-{-# INLINE witness_script_hash #-}
+-- P2WSH ----------------------------------------------------------------------
--- | Convert a witness script to P2WSH scriptPubKey.
---
--- P2WSH format: OP_0 <32-byte-hash>
---
--- >>> to_p2wsh some_witness_script
--- Script "\x00\x20<32-byte-hash>"
+-- | The P2WSH scriptPubKey for a witness script:
+-- @0 \<SHA256(script)\>@.
to_p2wsh :: Script -> Script
-to_p2wsh !script =
- let !h = witness_script_hash script
- in build_script (BSB.word8 op_0 <> push_data h)
-{-# INLINE to_p2wsh #-}
+to_p2wsh (Script s) = script (op op_0 <> push (SHA256.hash s))
--- funding output --------------------------------------------------------------
+-- funding output -------------------------------------------------------------
--- | Funding output witness script (2-of-2 multisig).
---
--- Script: @2 <pubkey1> <pubkey2> 2 OP_CHECKMULTISIG@
+-- | The funding output's witness script:
--
--- Where pubkey1 is lexicographically lesser.
+-- @2 \<pubkey1\> \<pubkey2\> 2 OP_CHECKMULTISIG@
--
--- >>> funding_script pk1 pk2
--- Script "R!<pk_lesser>!<pk_greater>R\xae"
+-- where @pubkey1@ is the lexicographically lesser of the two funding
+-- pubkeys. The argument order doesn't matter.
funding_script :: FundingPubkey -> FundingPubkey -> Script
-funding_script (FundingPubkey (Pubkey !pk1)) (FundingPubkey (Pubkey !pk2)) =
- let (!lesser, !greater) = if pk1 <= pk2 then (pk1, pk2) else (pk2, pk1)
- in build_script $
- BSB.word8 op_2
- <> push_data lesser
- <> push_data greater
- <> BSB.word8 op_2
- <> BSB.word8 op_checkmultisig
-
--- | Witness for spending funding output.
---
--- Witness: @0 <sig1> <sig2>@
---
--- Signatures ordered to match pubkey order in script.
---
--- >>> funding_witness sig1 sig2
--- Witness ["", sig1, sig2]
-funding_witness :: BS.ByteString -> BS.ByteString -> Witness
-funding_witness !sig1 !sig2 = Witness [BS.empty, sig1, sig2]
-
--- to_local output -------------------------------------------------------------
-
--- | to_local witness script (revocable with CSV delay).
---
--- Script:
---
--- @
--- OP_IF
--- <revocationpubkey>
--- OP_ELSE
--- <to_self_delay>
--- OP_CHECKSEQUENCEVERIFY
--- OP_DROP
--- <local_delayedpubkey>
--- OP_ENDIF
--- OP_CHECKSIG
--- @
---
--- >>> to_local_script revpk delay localpk
--- Script "c!<revpk>g<delay>\xb2u!<localpk>h\xac"
+funding_script (FundingPubkey a) (FundingPubkey b) =
+ let (lo, hi) = if a <= b then (a, b) else (b, a)
+ in script $
+ op op_2 <> push_point lo <> push_point hi
+ <> op op_2 <> op op_checkmultisig
+
+-- | The witness spending the funding output, given each party's
+-- funding pubkey and signature (DER-encoded, with sighash byte):
+--
+-- @0 \<signature_for_pubkey1\> \<signature_for_pubkey2\> \<script\>@
+--
+-- The signatures are ordered to match the pubkeys in
+-- 'funding_script', so the argument order doesn't matter.
+funding_witness
+ :: FundingPubkey -> BS.ByteString
+ -> FundingPubkey -> BS.ByteString
+ -> Witness
+funding_witness pa@(FundingPubkey a) sa pb@(FundingPubkey b) sb =
+ let (s1, s2) = if a <= b then (sa, sb) else (sb, sa)
+ in with_script [BS.empty, s1, s2] (funding_script pa pb)
+
+-- to_local output ------------------------------------------------------------
+
+-- | The @to_local@ output's witness script:
+--
+-- @
+-- OP_IF
+-- \<revocationpubkey\>
+-- OP_ELSE
+-- \<to_self_delay\> OP_CHECKSEQUENCEVERIFY OP_DROP
+-- \<local_delayedpubkey\>
+-- OP_ENDIF
+-- OP_CHECKSIG
+-- @
+--
+-- HTLC-success and HTLC-timeout transaction outputs use the same
+-- script.
to_local_script
:: RevocationPubkey
-> ToSelfDelay
-> LocalDelayedPubkey
-> Script
to_local_script
- (RevocationPubkey (Pubkey !revpk))
- (ToSelfDelay !delay)
- (LocalDelayedPubkey (Pubkey !localpk)) =
- build_script $
- BSB.word8 op_if
- <> push_data revpk
- <> BSB.word8 op_else
- <> push_csv_delay delay
- <> BSB.word8 op_checksequenceverify
- <> BSB.word8 op_drop
- <> push_data localpk
- <> BSB.word8 op_endif
- <> BSB.word8 op_checksig
-
--- | Witness for delayed spend of to_local output.
---
--- Input nSequence must be set to to_self_delay.
---
--- Witness: @<local_delayedsig> <>@
---
--- >>> to_local_witness_spend sig
--- Witness [sig, ""]
-to_local_witness_spend :: BS.ByteString -> Witness
-to_local_witness_spend !sig = Witness [sig, BS.empty]
-
--- | Witness for revocation spend of to_local output.
---
--- Witness: @<revocation_sig> 1@
---
--- >>> to_local_witness_revoke sig
--- Witness [sig, "\x01"]
-to_local_witness_revoke :: BS.ByteString -> Witness
-to_local_witness_revoke !sig = Witness [sig, BS.singleton 0x01]
-
--- to_remote output ------------------------------------------------------------
-
--- | to_remote witness script.
---
--- With option_anchors:
---
--- @
--- <remotepubkey> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY
--- @
---
--- Without option_anchors: P2WPKH (just the pubkey hash).
---
--- >>> to_remote_script pk (ChannelFeatures True)
--- Script "!<pk>\xadQ\xb2"
-to_remote_script :: RemotePubkey -> ChannelFeatures -> Script
-to_remote_script (RemotePubkey (Pubkey !pk)) !features
- | has_anchors features =
- -- Anchors: script with 1-block CSV
- build_script $
- push_data pk
- <> BSB.word8 op_checksigverify
- <> BSB.word8 op_1
- <> BSB.word8 op_checksequenceverify
- | otherwise =
- -- No anchors: P2WPKH (OP_0 <20-byte-hash>)
- let !h = hash160 pk
- in build_script (BSB.word8 op_0 <> push_data h)
-
--- | Witness for spending to_remote output.
---
--- With option_anchors (P2WSH), input nSequence must be 1.
--- Witness: @<remote_sig>@ (witness script appended by caller)
---
--- Without option_anchors (P2WPKH):
--- Witness: @<remote_sig> <remotepubkey>@
---
--- >>> to_remote_witness sig pk (ChannelFeatures False)
--- Witness [sig, pk]
-to_remote_witness :: BS.ByteString -> RemotePubkey -> ChannelFeatures -> Witness
-to_remote_witness !sig (RemotePubkey (Pubkey !pk)) !features
- | has_anchors features = Witness [sig]
- | otherwise = Witness [sig, pk]
-
--- anchor outputs --------------------------------------------------------------
-
--- | Anchor output witness script.
---
--- Script:
---
--- @
--- <funding_pubkey> OP_CHECKSIG OP_IFDUP
--- OP_NOTIF
--- OP_16 OP_CHECKSEQUENCEVERIFY
--- OP_ENDIF
--- @
---
--- >>> anchor_script fundpk
--- Script "!<fundpk>\xac\x73d`\xb2h"
+ (RevocationPubkey rev)
+ (ToSelfDelay delay)
+ (LocalDelayedPubkey delayed) = script $
+ op op_if
+ <> push_point rev
+ <> op op_else
+ <> push_delay delay
+ <> op op_checksequenceverify
+ <> op op_drop
+ <> push_point delayed
+ <> op op_endif
+ <> op op_checksig
+
+-- | The witness for the owner's delayed spend of a @to_local@ (or
+-- HTLC transaction) output, given its witness script:
+--
+-- @\<local_delayedsig\> \<\> \<script\>@
+--
+-- The spending input's @nSequence@ must be @to_self_delay@.
+to_local_witness_spend :: BS.ByteString -> Script -> Witness
+to_local_witness_spend sig = with_script [sig, BS.empty]
+
+-- | The witness for the revocation spend of a @to_local@ (or HTLC
+-- transaction) output, given its witness script:
+--
+-- @\<revocation_sig\> 1 \<script\>@
+to_local_witness_revoke :: BS.ByteString -> Script -> Witness
+to_local_witness_revoke sig = with_script [sig, BS.singleton 0x01]
+
+-- to_remote output -----------------------------------------------------------
+
+-- | The @to_remote@ output's witness script under 'Anchors':
+--
+-- @\<remotepubkey\> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY@
+--
+-- (Under 'StaticRemotekey' the output is P2WPKH, with no witness
+-- script; see 'to_remote_script_pubkey'.)
+to_remote_witness_script :: RemotePubkey -> Script
+to_remote_witness_script (RemotePubkey pk) = script $
+ push_point pk
+ <> op op_checksigverify
+ <> op op_1
+ <> op op_checksequenceverify
+
+-- | The @to_remote@ output's scriptPubKey: P2WPKH to @remotepubkey@
+-- under 'StaticRemotekey', and P2WSH of 'to_remote_witness_script'
+-- under 'Anchors'.
+to_remote_script_pubkey :: RemotePubkey -> CommitmentFormat -> Script
+to_remote_script_pubkey pk@(RemotePubkey p) fmt = case fmt of
+ StaticRemotekey -> script (op op_0 <> push (hash160 (BOLT1.un_point p)))
+ Anchors -> to_p2wsh (to_remote_witness_script pk)
+
+-- | The witness spending a @to_remote@ output: @\<remote_sig\>
+-- \<remotepubkey\>@ (P2WPKH) under 'StaticRemotekey', and
+-- @\<remote_sig\> \<script\>@ under 'Anchors', where the spending
+-- input's @nSequence@ must be 1.
+to_remote_witness
+ :: BS.ByteString -> RemotePubkey -> CommitmentFormat -> Witness
+to_remote_witness sig pk@(RemotePubkey p) fmt = case fmt of
+ StaticRemotekey -> Witness [sig, BOLT1.un_point p]
+ Anchors -> with_script [sig] (to_remote_witness_script pk)
+
+-- anchor outputs -------------------------------------------------------------
+
+-- | An anchor output's witness script, for the funding pubkey of the
+-- party it belongs to:
+--
+-- @
+-- \<funding_pubkey\> OP_CHECKSIG OP_IFDUP
+-- OP_NOTIF
+-- OP_16 OP_CHECKSEQUENCEVERIFY
+-- OP_ENDIF
+-- @
anchor_script :: FundingPubkey -> Script
-anchor_script (FundingPubkey (Pubkey !pk)) =
- build_script $
- push_data pk
- <> BSB.word8 op_checksig
- <> BSB.word8 op_ifdup
- <> BSB.word8 op_notif
- <> BSB.word8 op_16
- <> BSB.word8 op_checksequenceverify
- <> BSB.word8 op_endif
-
--- | Witness for owner to spend anchor output.
---
--- Witness: @<sig>@
---
--- >>> anchor_witness_owner sig
--- Witness [sig]
-anchor_witness_owner :: BS.ByteString -> Witness
-anchor_witness_owner !sig = Witness [sig]
-
--- | Witness for anyone to sweep anchor output after 16 blocks.
---
--- Witness: @<>@
---
--- >>> anchor_witness_anyone
--- Witness [""]
-anchor_witness_anyone :: Witness
-anchor_witness_anyone = Witness [BS.empty]
-
--- offered HTLC output ---------------------------------------------------------
-
--- | Offered HTLC witness script.
---
--- Without option_anchors:
---
--- @
--- OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL
--- OP_IF
--- OP_CHECKSIG
--- OP_ELSE
--- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL
--- OP_NOTIF
--- OP_DROP 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG
--- OP_ELSE
--- OP_HASH160 <RIPEMD160(payment_hash)> OP_EQUALVERIFY
--- OP_CHECKSIG
--- OP_ENDIF
--- OP_ENDIF
--- @
---
--- With option_anchors, adds @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ before
--- final OP_ENDIF.
+anchor_script (FundingPubkey pk) = script $
+ push_point pk
+ <> op op_checksig
+ <> op op_ifdup
+ <> op op_notif
+ <> op op_16
+ <> op op_checksequenceverify
+ <> op op_endif
+
+-- | The witness for an anchor's owner to spend it:
+-- @\<sig\> \<script\>@.
+anchor_witness_owner :: BS.ByteString -> FundingPubkey -> Witness
+anchor_witness_owner sig pk = with_script [sig] (anchor_script pk)
+
+-- | The witness for anyone to sweep an anchor, 16 blocks after the
+-- commitment transaction confirms: @\<\> \<script\>@.
+anchor_witness_anyone :: FundingPubkey -> Witness
+anchor_witness_anyone pk = with_script [BS.empty] (anchor_script pk)
+
+-- offered HTLC outputs -------------------------------------------------------
+
+-- csv suffix for anchors HTLC scripts
+htlc_csv :: CommitmentFormat -> BSB.Builder
+htlc_csv fmt = case fmt of
+ StaticRemotekey -> mempty
+ Anchors -> op op_1 <> op op_checksequenceverify <> op op_drop
+{-# INLINE htlc_csv #-}
+
+-- | An offered HTLC output's witness script:
+--
+-- @
+-- OP_DUP OP_HASH160 \<RIPEMD160(SHA256(revocationpubkey))\> OP_EQUAL
+-- OP_IF
+-- OP_CHECKSIG
+-- OP_ELSE
+-- \<remote_htlcpubkey\> OP_SWAP OP_SIZE 32 OP_EQUAL
+-- OP_NOTIF
+-- OP_DROP 2 OP_SWAP \<local_htlcpubkey\> 2 OP_CHECKMULTISIG
+-- OP_ELSE
+-- OP_HASH160 \<RIPEMD160(payment_hash)\> OP_EQUALVERIFY
+-- OP_CHECKSIG
+-- OP_ENDIF
+-- OP_ENDIF
+-- @
+--
+-- Under 'Anchors', @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ precedes the
+-- final @OP_ENDIF@.
offered_htlc_script
:: RevocationPubkey
-> RemoteHtlcPubkey
-> LocalHtlcPubkey
- -> PaymentHash
- -> ChannelFeatures
+ -> BOLT1.PaymentHash
+ -> CommitmentFormat
-> Script
offered_htlc_script
- (RevocationPubkey (Pubkey !revpk))
- (RemoteHtlcPubkey (Pubkey !remotepk))
- (LocalHtlcPubkey (Pubkey !localpk))
- (PaymentHash !ph)
- !features =
- let !revpk_hash = hash160 revpk
- !payment_hash160 = RIPEMD160.hash ph
- !csv_suffix = if has_anchors features
- then BSB.word8 op_1
- <> BSB.word8 op_checksequenceverify
- <> BSB.word8 op_drop
- else mempty
- in build_script $
- -- OP_DUP OP_HASH160 <revpk_hash> OP_EQUAL
- BSB.word8 op_dup
- <> BSB.word8 op_hash160
- <> push_data revpk_hash
- <> BSB.word8 op_equal
- -- OP_IF OP_CHECKSIG
- <> BSB.word8 op_if
- <> BSB.word8 op_checksig
- -- OP_ELSE
- <> BSB.word8 op_else
- -- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL
- <> push_data remotepk
- <> BSB.word8 op_swap
- <> BSB.word8 op_size
- <> push_data (BS.singleton 32)
- <> BSB.word8 op_equal
- -- OP_NOTIF
- <> BSB.word8 op_notif
- -- OP_DROP 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG
- <> BSB.word8 op_drop
- <> BSB.word8 op_2
- <> BSB.word8 op_swap
- <> push_data localpk
- <> BSB.word8 op_2
- <> BSB.word8 op_checkmultisig
- -- OP_ELSE
- <> BSB.word8 op_else
- -- OP_HASH160 <payment_hash160> OP_EQUALVERIFY OP_CHECKSIG
- <> BSB.word8 op_hash160
- <> push_data payment_hash160
- <> BSB.word8 op_equalverify
- <> BSB.word8 op_checksig
- -- OP_ENDIF
- <> BSB.word8 op_endif
- -- CSV suffix for anchors
- <> csv_suffix
- -- OP_ENDIF
- <> BSB.word8 op_endif
-
--- | Witness for remote node to claim offered HTLC with preimage.
---
--- With option_anchors, input nSequence must be 1.
---
--- Witness: @<remotehtlcsig> <payment_preimage>@
---
--- >>> offered_htlc_witness_preimage sig preimage
--- Witness [sig, preimage]
+ (RevocationPubkey rev)
+ (RemoteHtlcPubkey remote)
+ (LocalHtlcPubkey local)
+ ph
+ fmt = script $
+ op op_dup <> op op_hash160
+ <> push (hash160 (BOLT1.un_point rev))
+ <> op op_equal
+ <> op op_if
+ <> op op_checksig
+ <> op op_else
+ <> push_point remote <> op op_swap <> op op_size
+ <> push (BS.singleton 32) <> op op_equal
+ <> op op_notif
+ <> op op_drop <> op op_2 <> op op_swap
+ <> push_point local <> op op_2 <> op op_checkmultisig
+ <> op op_else
+ <> op op_hash160
+ <> push (RIPEMD160.hash (BOLT1.un_payment_hash ph))
+ <> op op_equalverify <> op op_checksig
+ <> op op_endif
+ <> htlc_csv fmt
+ <> op op_endif
+
+-- | The witness for the remote party to claim an offered HTLC output
+-- with the payment preimage, given its witness script:
+--
+-- @\<remotehtlcsig\> \<payment_preimage\> \<script\>@
+--
+-- Under 'Anchors' the spending input's @nSequence@ must be 1.
offered_htlc_witness_preimage
- :: BS.ByteString -> PaymentPreimage -> Witness
-offered_htlc_witness_preimage !sig (PaymentPreimage !preimage) =
- Witness [sig, preimage]
-
--- | Witness for revocation spend of offered HTLC.
---
--- Witness: @<revocation_sig> <revocationpubkey>@
---
--- >>> offered_htlc_witness_revoke sig revpk
--- Witness [sig, revpk]
-offered_htlc_witness_revoke :: BS.ByteString -> Pubkey -> Witness
-offered_htlc_witness_revoke !sig (Pubkey !revpk) = Witness [sig, revpk]
-
--- received HTLC output --------------------------------------------------------
-
--- | Received HTLC witness script.
---
--- Without option_anchors:
---
--- @
--- OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL
--- OP_IF
--- OP_CHECKSIG
--- OP_ELSE
--- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL
--- OP_IF
--- OP_HASH160 <RIPEMD160(payment_hash)> OP_EQUALVERIFY
--- 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG
--- OP_ELSE
--- OP_DROP <cltv_expiry> OP_CHECKLOCKTIMEVERIFY OP_DROP
--- OP_CHECKSIG
--- OP_ENDIF
--- OP_ENDIF
--- @
---
--- With option_anchors, adds @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ before
--- final OP_ENDIF.
+ :: BS.ByteString -> PaymentPreimage -> Script -> Witness
+offered_htlc_witness_preimage sig pre =
+ with_script [sig, BOLT1.un_payment_preimage pre]
+
+-- | The witness for the revocation spend of an offered HTLC output,
+-- given its witness script:
+--
+-- @\<revocation_sig\> \<revocationpubkey\> \<script\>@
+offered_htlc_witness_revoke
+ :: BS.ByteString -> RevocationPubkey -> Script -> Witness
+offered_htlc_witness_revoke sig (RevocationPubkey rev) =
+ with_script [sig, BOLT1.un_point rev]
+
+-- received HTLC outputs ------------------------------------------------------
+
+-- | A received HTLC output's witness script:
+--
+-- @
+-- OP_DUP OP_HASH160 \<RIPEMD160(SHA256(revocationpubkey))\> OP_EQUAL
+-- OP_IF
+-- OP_CHECKSIG
+-- OP_ELSE
+-- \<remote_htlcpubkey\> OP_SWAP OP_SIZE 32 OP_EQUAL
+-- OP_IF
+-- OP_HASH160 \<RIPEMD160(payment_hash)\> OP_EQUALVERIFY
+-- 2 OP_SWAP \<local_htlcpubkey\> 2 OP_CHECKMULTISIG
+-- OP_ELSE
+-- OP_DROP \<cltv_expiry\> OP_CHECKLOCKTIMEVERIFY OP_DROP
+-- OP_CHECKSIG
+-- OP_ENDIF
+-- OP_ENDIF
+-- @
+--
+-- Under 'Anchors', @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ precedes the
+-- final @OP_ENDIF@.
received_htlc_script
:: RevocationPubkey
-> RemoteHtlcPubkey
-> LocalHtlcPubkey
- -> PaymentHash
+ -> BOLT1.PaymentHash
-> CltvExpiry
- -> ChannelFeatures
+ -> CommitmentFormat
-> Script
received_htlc_script
- (RevocationPubkey (Pubkey !revpk))
- (RemoteHtlcPubkey (Pubkey !remotepk))
- (LocalHtlcPubkey (Pubkey !localpk))
- (PaymentHash !ph)
- (CltvExpiry !expiry)
- !features =
- let !revpk_hash = hash160 revpk
- !payment_hash160 = RIPEMD160.hash ph
- !csv_suffix = if has_anchors features
- then BSB.word8 op_1
- <> BSB.word8 op_checksequenceverify
- <> BSB.word8 op_drop
- else mempty
- in build_script $
- -- OP_DUP OP_HASH160 <revpk_hash> OP_EQUAL
- BSB.word8 op_dup
- <> BSB.word8 op_hash160
- <> push_data revpk_hash
- <> BSB.word8 op_equal
- -- OP_IF OP_CHECKSIG
- <> BSB.word8 op_if
- <> BSB.word8 op_checksig
- -- OP_ELSE
- <> BSB.word8 op_else
- -- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL
- <> push_data remotepk
- <> BSB.word8 op_swap
- <> BSB.word8 op_size
- <> push_data (BS.singleton 32)
- <> BSB.word8 op_equal
- -- OP_IF
- <> BSB.word8 op_if
- -- OP_HASH160 <payment_hash160> OP_EQUALVERIFY
- <> BSB.word8 op_hash160
- <> push_data payment_hash160
- <> BSB.word8 op_equalverify
- -- 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG
- <> BSB.word8 op_2
- <> BSB.word8 op_swap
- <> push_data localpk
- <> BSB.word8 op_2
- <> BSB.word8 op_checkmultisig
- -- OP_ELSE
- <> BSB.word8 op_else
- -- OP_DROP <cltv_expiry> OP_CHECKLOCKTIMEVERIFY OP_DROP OP_CHECKSIG
- <> BSB.word8 op_drop
- <> push_cltv expiry
- <> BSB.word8 op_checklocktimeverify
- <> BSB.word8 op_drop
- <> BSB.word8 op_checksig
- -- OP_ENDIF
- <> BSB.word8 op_endif
- -- CSV suffix for anchors
- <> csv_suffix
- -- OP_ENDIF
- <> BSB.word8 op_endif
-
--- | Witness for remote node to timeout received HTLC.
---
--- With option_anchors, input nSequence must be 1.
---
--- Witness: @<remotehtlcsig> <>@
---
--- >>> received_htlc_witness_timeout sig
--- Witness [sig, ""]
-received_htlc_witness_timeout :: BS.ByteString -> Witness
-received_htlc_witness_timeout !sig = Witness [sig, BS.empty]
-
--- | Witness for revocation spend of received HTLC.
---
--- Witness: @<revocation_sig> <revocationpubkey>@
---
--- >>> received_htlc_witness_revoke sig revpk
--- Witness [sig, revpk]
-received_htlc_witness_revoke :: BS.ByteString -> Pubkey -> Witness
-received_htlc_witness_revoke !sig (Pubkey !revpk) = Witness [sig, revpk]
-
--- HTLC-timeout/success output -------------------------------------------------
-
--- | HTLC output witness script (same structure as to_local).
---
--- Used for HTLC-timeout and HTLC-success transaction outputs.
---
--- Script:
---
--- @
--- OP_IF
--- <revocationpubkey>
--- OP_ELSE
--- <to_self_delay>
--- OP_CHECKSEQUENCEVERIFY
--- OP_DROP
--- <local_delayedpubkey>
--- OP_ENDIF
--- OP_CHECKSIG
--- @
-htlc_output_script
- :: RevocationPubkey
- -> ToSelfDelay
- -> LocalDelayedPubkey
- -> Script
-htlc_output_script = to_local_script
-
--- | Witness for delayed spend of HTLC output.
---
--- Input nSequence must be set to to_self_delay.
---
--- Witness: @<local_delayedsig> 0@
-htlc_output_witness_spend :: BS.ByteString -> Witness
-htlc_output_witness_spend = to_local_witness_spend
-
--- | Witness for revocation spend of HTLC output.
---
--- Witness: @<revocationsig> 1@
-htlc_output_witness_revoke :: BS.ByteString -> Witness
-htlc_output_witness_revoke = to_local_witness_revoke
+ (RevocationPubkey rev)
+ (RemoteHtlcPubkey remote)
+ (LocalHtlcPubkey local)
+ ph
+ (CltvExpiry expiry)
+ fmt = script $
+ op op_dup <> op op_hash160
+ <> push (hash160 (BOLT1.un_point rev))
+ <> op op_equal
+ <> op op_if
+ <> op op_checksig
+ <> op op_else
+ <> push_point remote <> op op_swap <> op op_size
+ <> push (BS.singleton 32) <> op op_equal
+ <> op op_if
+ <> op op_hash160
+ <> push (RIPEMD160.hash (BOLT1.un_payment_hash ph))
+ <> op op_equalverify
+ <> op op_2 <> op op_swap <> push_point local
+ <> op op_2 <> op op_checkmultisig
+ <> op op_else
+ <> op op_drop <> push_num expiry
+ <> op op_checklocktimeverify <> op op_drop
+ <> op op_checksig
+ <> op op_endif
+ <> htlc_csv fmt
+ <> op op_endif
+
+-- | The witness for the remote party to time out a received HTLC
+-- output, given its witness script:
+--
+-- @\<remotehtlcsig\> \<\> \<script\>@
+--
+-- Under 'Anchors' the spending input's @nSequence@ must be 1.
+received_htlc_witness_timeout :: BS.ByteString -> Script -> Witness
+received_htlc_witness_timeout sig = with_script [sig, BS.empty]
+
+-- | The witness for the revocation spend of a received HTLC output,
+-- given its witness script:
+--
+-- @\<revocation_sig\> \<revocationpubkey\> \<script\>@
+received_htlc_witness_revoke
+ :: BS.ByteString -> RevocationPubkey -> Script -> Witness
+received_htlc_witness_revoke sig (RevocationPubkey rev) =
+ with_script [sig, BOLT1.un_point rev]
+
+-- HTLC transaction inputs ----------------------------------------------------
+
+-- | The witness for an HTLC-success transaction's input, given both
+-- HTLC signatures, the payment preimage and the received HTLC
+-- output's witness script:
+--
+-- @0 \<remotehtlcsig\> \<localhtlcsig\> \<payment_preimage\> \<script\>@
+--
+-- See 'remote_htlc_sighash' for the signatures' sighash types.
+htlc_success_witness
+ :: BS.ByteString -- ^ remotehtlcsig
+ -> BS.ByteString -- ^ localhtlcsig
+ -> PaymentPreimage
+ -> Script -- ^ the received HTLC output's witness script
+ -> Witness
+htlc_success_witness remote local pre =
+ with_script [BS.empty, remote, local, BOLT1.un_payment_preimage pre]
+
+-- | The witness for an HTLC-timeout transaction's input, given both
+-- HTLC signatures and the offered HTLC output's witness script:
+--
+-- @0 \<remotehtlcsig\> \<localhtlcsig\> \<\> \<script\>@
+--
+-- See 'remote_htlc_sighash' for the signatures' sighash types.
+htlc_timeout_witness
+ :: BS.ByteString -- ^ remotehtlcsig
+ -> BS.ByteString -- ^ localhtlcsig
+ -> Script -- ^ the offered HTLC output's witness script
+ -> Witness
+htlc_timeout_witness remote local =
+ with_script [BS.empty, remote, local, BS.empty]
+
+-- | The sighash type of @remotehtlcsig@: the signature on an
+-- HTLC-success or HTLC-timeout transaction that the commitment's
+-- non-owner sends in @commitment_signed@.
+--
+-- Under 'Anchors' it is @SIGHASH_SINGLE|SIGHASH_ANYONECANPAY@, so
+-- that the owner can add inputs and outputs to pay the (otherwise
+-- zero) fee; under 'StaticRemotekey' it is @SIGHASH_ALL@. The
+-- owner's own signature, @localhtlcsig@, always uses @SIGHASH_ALL@.
+--
+-- >>> remote_htlc_sighash Anchors
+-- SIGHASH_SINGLE_ANYONECANPAY
+remote_htlc_sighash :: CommitmentFormat -> SighashType
+remote_htlc_sighash fmt = case fmt of
+ StaticRemotekey -> SIGHASH_ALL
+ Anchors -> SIGHASH_SINGLE_ANYONECANPAY
diff --git a/lib/Lightning/Protocol/BOLT3/Tx.hs b/lib/Lightning/Protocol/BOLT3/Tx.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -8,667 +8,562 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Transaction assembly for BOLT #3.
---
--- Constructs:
---
--- * Commitment transactions
--- * HTLC-timeout transactions
--- * HTLC-success transactions
--- * Closing transactions
+-- Commitment, HTLC and closing transactions, per BOLT #3.
module Lightning.Protocol.BOLT3.Tx (
- -- * Commitment transaction
- CommitmentTx(..)
- , CommitmentContext(..)
- , CommitmentKeys(..)
+ -- * Commitment transactions
+ CommitmentContext(..)
+ , CommitmentTx(..)
+ , CommitmentOutput(..)
+ , OutputType(..)
, build_commitment_tx
-- * HTLC transactions
- , HTLCTx(..)
, HTLCContext(..)
- , build_htlc_timeout_tx
- , build_htlc_success_tx
+ , HTLCTx(..)
+ , build_htlc_tx
- -- * Closing transaction
+ -- * Closing transactions
, ClosingTx(..)
+ , ClosingOutput(..)
, ClosingContext(..)
+ , ClosingOutputs(..)
, build_closing_tx
+ , LegacyClosingContext(..)
, build_legacy_closing_tx
- -- * Conversion to ppad-tx
- , commitment_to_tx
- , htlc_to_tx
- , closing_to_tx
-
- -- * Transaction outputs
- , TxOutput(..)
- , OutputType(..)
-
- -- * Fee calculation
+ -- * Fees
, commitment_fee
, htlc_timeout_fee
, htlc_success_fee
- , commitment_weight
-- * Trimming
- , is_trimmed
- , trimmed_htlcs
- , untrimmed_htlcs
, htlc_trim_threshold
+ , is_trimmed
- -- * Output ordering
- , sort_outputs
+ -- * Serialization
+ , commitment_to_tx
+ , htlc_to_tx
+ , closing_to_tx
+ , encode_commitment_tx
+ , encode_htlc_tx
+ , encode_closing_tx
) where
+import Bitcoin.Prim.Tx (OutPoint(..), TxId)
import qualified Bitcoin.Prim.Tx as BT
-import Data.Bits ((.&.), (.|.), shiftL, shiftR)
+import Control.DeepSeq (NFData)
+import Data.Bits ((.&.), (.|.), shiftR)
import qualified Data.ByteString as BS
import Data.List (sortBy)
-import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (fromMaybe)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
+import Lightning.Protocol.BOLT1 (Satoshi, MilliSatoshi)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT3.Keys
import Lightning.Protocol.BOLT3.Scripts
import Lightning.Protocol.BOLT3.Types
--- transaction outputs ---------------------------------------------------------
+-- commitment transactions ----------------------------------------------------
--- | Type of output in a commitment transaction.
+-- | What a commitment transaction output pays.
data OutputType
= OutputToLocal
| OutputToRemote
| OutputLocalAnchor
| OutputRemoteAnchor
- | OutputOfferedHTLC {-# UNPACK #-} !CltvExpiry
- | OutputReceivedHTLC {-# UNPACK #-} !CltvExpiry
+ | OutputHTLC !HTLC
+ -- ^ an offered or received HTLC (per its 'htlc_direction')
deriving (Eq, Show, Generic)
--- | A transaction output with value, script, and type information.
-data TxOutput = TxOutput
- { txout_value :: {-# UNPACK #-} !Satoshi
- , txout_script :: !Script
- , txout_type :: !OutputType
- } deriving (Eq, Show, Generic)
+instance NFData OutputType
--- commitment transaction ------------------------------------------------------
-
--- | Derived keys needed for commitment transaction outputs.
-data CommitmentKeys = CommitmentKeys
- { ck_revocation_pubkey :: !RevocationPubkey
- , ck_local_delayed :: !LocalDelayedPubkey
- , ck_local_htlc :: !LocalHtlcPubkey
- , ck_remote_htlc :: !RemoteHtlcPubkey
- , ck_local_payment :: !LocalPubkey
- , ck_remote_payment :: !RemotePubkey
- , ck_local_funding :: !FundingPubkey
- , ck_remote_funding :: !FundingPubkey
+-- | A commitment transaction output.
+data CommitmentOutput = CommitmentOutput
+ { co_value :: {-# UNPACK #-} !Satoshi
+ , co_script :: !Script -- ^ scriptPubKey
+ , co_type :: !OutputType
} deriving (Eq, Show, Generic)
--- | Context for building a commitment transaction.
+instance NFData CommitmentOutput
+
+-- | The parameters of a commitment transaction, from the point of view
+-- of its owner (the "local" party, whose outputs are delayed).
data CommitmentContext = CommitmentContext
- { cc_funding_outpoint :: !OutPoint
- , cc_commitment_number :: !CommitmentNumber
- , cc_local_payment_bp :: !PaymentBasepoint
- , cc_remote_payment_bp :: !PaymentBasepoint
- , cc_to_self_delay :: !ToSelfDelay
- , cc_dust_limit :: !DustLimit
- , cc_feerate :: !FeeratePerKw
- , cc_features :: !ChannelFeatures
- , cc_is_funder :: !Bool
- , cc_to_local_msat :: !MilliSatoshi
- , cc_to_remote_msat :: !MilliSatoshi
- , cc_htlcs :: ![HTLC]
- , cc_keys :: !CommitmentKeys
+ { cc_funding_outpoint :: {-# UNPACK #-} !OutPoint
+ , cc_commitment_number :: {-# UNPACK #-} !CommitmentNumber
+ , cc_local_payment_bp :: !PaymentBasepoint
+ -- ^ the owner's @payment_basepoint@
+ , cc_remote_payment_bp :: !PaymentBasepoint
+ -- ^ the other party's @payment_basepoint@
+ , cc_to_self_delay :: {-# UNPACK #-} !ToSelfDelay
+ -- ^ the delay on the owner's outputs (set by the other party)
+ , cc_dust_limit :: {-# UNPACK #-} !DustLimit
+ -- ^ the owner's @dust_limit_satoshis@
+ , cc_feerate :: {-# UNPACK #-} !FeeratePerKw
+ , cc_format :: !CommitmentFormat
+ , cc_is_funder :: !Bool
+ -- ^ whether the owner opened the channel, and so pays the fee
+ , cc_to_local_msat :: {-# UNPACK #-} !MilliSatoshi
+ , cc_to_remote_msat :: {-# UNPACK #-} !MilliSatoshi
+ , cc_htlcs :: ![HTLC]
+ , cc_keys :: !CommitmentKeys
} deriving (Eq, Show, Generic)
--- | A commitment transaction.
+instance NFData CommitmentContext
+
+-- | An unsigned commitment transaction.
data CommitmentTx = CommitmentTx
- { ctx_version :: {-# UNPACK #-} !Word32
- , ctx_locktime :: !Locktime
- , ctx_input_outpoint :: !OutPoint
- , ctx_input_sequence :: !Sequence
- , ctx_outputs :: ![TxOutput]
- , ctx_funding_script :: !Script
+ { ctx_version :: {-# UNPACK #-} !Word32
+ , ctx_locktime :: {-# UNPACK #-} !Locktime
+ , ctx_input_outpoint :: {-# UNPACK #-} !OutPoint
+ , ctx_input_sequence :: {-# UNPACK #-} !Sequence
+ , ctx_outputs :: !(NonEmpty CommitmentOutput)
+ -- ^ in BIP69+CLTV order
+ , ctx_funding_script :: !Script
+ -- ^ the funding output's witness script, which signatures commit
+ -- to
} deriving (Eq, Show, Generic)
--- | Build a commitment transaction.
+instance NFData CommitmentTx
+
+-- | Build a commitment transaction, per BOLT #3's "Commitment
+-- Transaction Construction":
--
--- Follows the algorithm from BOLT #3:
+-- * the locktime and input sequence encode the obscured commitment
+-- number (the payment basepoints are ordered by 'cc_is_funder');
+-- * HTLCs whose amount, less the HTLC transaction fee, is below the
+-- dust limit are trimmed;
+-- * the base fee (and under 'Anchors', both anchors) are taken from
+-- the funder's output, which is left at zero if it can't cover
+-- them;
+-- * @to_local@ and @to_remote@ outputs below the dust limit are
+-- omitted, and under 'Anchors' each party's anchor is added if its
+-- output, or any HTLC output, exists;
+-- * outputs are sorted by value, scriptPubKey and CLTV expiry.
--
--- 1. Initialize input and locktime with obscured commitment number
--- 2. Calculate which HTLCs are trimmed
--- 3. Calculate base fee and subtract from funder
--- 4. Add untrimmed HTLC outputs
--- 5. Add to_local output if above dust
--- 6. Add to_remote output if above dust
--- 7. Add anchor outputs if option_anchors
--- 8. Sort outputs per BIP69+CLTV
-build_commitment_tx :: CommitmentContext -> CommitmentTx
-build_commitment_tx ctx =
- let !obscured = obscured_commitment_number
- (cc_local_payment_bp ctx)
- (cc_remote_payment_bp ctx)
- (cc_commitment_number ctx)
-
- -- Locktime: upper 8 bits are 0x20, lower 24 bits are lower 24 of obscured
- !locktime = Locktime $
- (0x20 `shiftL` 24) .|. (fromIntegral obscured .&. 0x00FFFFFF)
-
- -- Sequence: upper 8 bits are 0x80, lower 24 bits are upper 24 of obscured
- !inputSeq = Sequence $
- (0x80 `shiftL` 24) .|.
- (fromIntegral (obscured `shiftR` 24) .&. 0x00FFFFFF)
-
- -- Funding script for witness
- !fundingScript = funding_script
- (ck_local_funding $ cc_keys ctx)
- (ck_remote_funding $ cc_keys ctx)
-
- -- Calculate untrimmed HTLCs
- !untrimmedHtlcs = untrimmed_htlcs
- (cc_dust_limit ctx)
- (cc_feerate ctx)
- (cc_features ctx)
- (cc_htlcs ctx)
-
- -- Calculate base fee
- !baseFee = commitment_fee
- (cc_feerate ctx)
- (cc_features ctx)
- (fromIntegral $ length untrimmedHtlcs)
-
- -- Anchor cost if applicable
- !anchorCost = if has_anchors (cc_features ctx)
- then 2 * anchor_output_value
- else Satoshi 0
-
- -- Subtract fees and anchors from funder
- !totalDeduction = baseFee + anchorCost
- !(toLocalSat, toRemoteSat) = if cc_is_funder ctx
- then
- let !local = msatToSat (cc_to_local_msat ctx)
- !deducted = if unSatoshi local >= unSatoshi totalDeduction
- then Satoshi (unSatoshi local - unSatoshi totalDeduction)
- else Satoshi 0
- in (deducted, msatToSat (cc_to_remote_msat ctx))
- else
- let !remote = msatToSat (cc_to_remote_msat ctx)
- !deducted = if unSatoshi remote >= unSatoshi totalDeduction
- then Satoshi (unSatoshi remote - unSatoshi totalDeduction)
- else Satoshi 0
- in (msatToSat (cc_to_local_msat ctx), deducted)
-
- !dustLimit = unDustLimit (cc_dust_limit ctx)
-
- -- Build HTLC outputs
- !htlcOutputs = map (htlcOutput ctx) untrimmedHtlcs
-
- -- Build to_local output if above dust
- !toLocalOutput =
- if unSatoshi toLocalSat >= unSatoshi dustLimit
- then
- let !script = to_p2wsh $ to_local_script
- (ck_revocation_pubkey $ cc_keys ctx)
- (cc_to_self_delay ctx)
- (ck_local_delayed $ cc_keys ctx)
- in [TxOutput toLocalSat script OutputToLocal]
- else []
-
- -- Build to_remote output if above dust
- !toRemoteOutput =
- if unSatoshi toRemoteSat >= unSatoshi dustLimit
- then
- let !script = if has_anchors (cc_features ctx)
- then to_p2wsh $ to_remote_script
- (ck_remote_payment $ cc_keys ctx)
- (cc_features ctx)
- else to_remote_script
- (ck_remote_payment $ cc_keys ctx)
- (cc_features ctx)
- in [TxOutput toRemoteSat script OutputToRemote]
- else []
-
- -- Build anchor outputs if option_anchors
- !hasUntrimmedHtlcs = not (null untrimmedHtlcs)
- !toLocalExists = not (null toLocalOutput)
- !toRemoteExists = not (null toRemoteOutput)
-
- !localAnchorOutput =
- if has_anchors (cc_features ctx) &&
- (toLocalExists || hasUntrimmedHtlcs)
- then
- let !script = to_p2wsh $ anchor_script
- (ck_local_funding $ cc_keys ctx)
- in [TxOutput anchor_output_value script OutputLocalAnchor]
- else []
-
- !remoteAnchorOutput =
- if has_anchors (cc_features ctx) &&
- (toRemoteExists || hasUntrimmedHtlcs)
- then
- let !script = to_p2wsh $ anchor_script
- (ck_remote_funding $ cc_keys ctx)
- in [TxOutput anchor_output_value script OutputRemoteAnchor]
- else []
-
- -- Combine and sort all outputs
- !allOutputs = toLocalOutput ++ toRemoteOutput ++
- localAnchorOutput ++ remoteAnchorOutput ++
- htlcOutputs
- !sortedOutputs = sort_outputs allOutputs
-
- in CommitmentTx
- { ctx_version = 2
- , ctx_locktime = locktime
- , ctx_input_outpoint = cc_funding_outpoint ctx
- , ctx_input_sequence = inputSeq
- , ctx_outputs = sortedOutputs
- , ctx_funding_script = fundingScript
- }
-{-# INLINE build_commitment_tx #-}
-
--- | Build an HTLC output for commitment transaction.
-htlcOutput :: CommitmentContext -> HTLC -> TxOutput
-htlcOutput ctx htlc =
- let !amountSat = msatToSat (htlc_amount_msat htlc)
- !keys = cc_keys ctx
- !features = cc_features ctx
- !expiry = htlc_cltv_expiry htlc
- in case htlc_direction htlc of
- HTLCOffered ->
- let !script = to_p2wsh $ offered_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- features
- in TxOutput amountSat script (OutputOfferedHTLC expiry)
- HTLCReceived ->
- let !script = to_p2wsh $ received_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- expiry
- features
- in TxOutput amountSat script (OutputReceivedHTLC expiry)
-{-# INLINE htlcOutput #-}
-
--- HTLC transactions -----------------------------------------------------------
-
--- | Context for building HTLC transactions.
+-- Fails if the transaction would have no outputs.
+build_commitment_tx :: CommitmentContext -> Maybe CommitmentTx
+build_commitment_tx ctx = do
+ outputs <- NE.nonEmpty . sort_outputs $
+ to_local <> to_remote <> local_anchor <> remote_anchor <> htlcs
+ pure CommitmentTx
+ { ctx_version = 2
+ , ctx_locktime =
+ Locktime (0x20000000 .|. (fromIntegral obscured .&. 0xFFFFFF))
+ , ctx_input_outpoint = cc_funding_outpoint ctx
+ , ctx_input_sequence =
+ Sequence
+ (0x80000000 .|. (fromIntegral (obscured `shiftR` 24) .&. 0xFFFFFF))
+ , ctx_outputs = outputs
+ , ctx_funding_script =
+ funding_script (ck_local_funding keys) (ck_remote_funding keys)
+ }
+ where
+ !keys = cc_keys ctx
+ !fmt = cc_format ctx
+ !rate = cc_feerate ctx
+ !dust = cc_dust_limit ctx
+ DustLimit dust_sat = dust
+
+ (!opener, !accepter)
+ | cc_is_funder ctx = (cc_local_payment_bp ctx, cc_remote_payment_bp ctx)
+ | otherwise = (cc_remote_payment_bp ctx, cc_local_payment_bp ctx)
+ !obscured =
+ obscured_commitment_number opener accepter (cc_commitment_number ctx)
+
+ untrimmed = filter (not . is_trimmed dust rate fmt) (cc_htlcs ctx)
+
+ !fee = commitment_fee rate fmt (fromIntegral (length untrimmed))
+ !deduction = case fmt of
+ StaticRemotekey -> fee
+ Anchors ->
+ fromMaybe BOLT1.max_satoshi (BOLT1.add_sat fee (sat 660))
+ deduct s = fromMaybe (sat 0) (BOLT1.sub_sat s deduction)
+
+ !local_sat = BOLT1.msat_to_sat (cc_to_local_msat ctx)
+ !remote_sat = BOLT1.msat_to_sat (cc_to_remote_msat ctx)
+ (!to_local_sat, !to_remote_sat)
+ | cc_is_funder ctx = (deduct local_sat, remote_sat)
+ | otherwise = (local_sat, deduct remote_sat)
+
+ to_local =
+ [ CommitmentOutput to_local_sat
+ (to_p2wsh (to_local_script (ck_revocation_pubkey keys)
+ (cc_to_self_delay ctx) (ck_local_delayed keys)))
+ OutputToLocal
+ | to_local_sat >= dust_sat ]
+
+ to_remote =
+ [ CommitmentOutput to_remote_sat
+ (to_remote_script_pubkey (ck_remote_payment keys) fmt)
+ OutputToRemote
+ | to_remote_sat >= dust_sat ]
+
+ has_htlcs = not (null untrimmed)
+ anchor pk ty = CommitmentOutput anchor_output_value
+ (to_p2wsh (anchor_script pk)) ty
+
+ local_anchor = case fmt of
+ Anchors | not (null to_local) || has_htlcs ->
+ [anchor (ck_local_funding keys) OutputLocalAnchor]
+ _ -> []
+
+ remote_anchor = case fmt of
+ Anchors | not (null to_remote) || has_htlcs ->
+ [anchor (ck_remote_funding keys) OutputRemoteAnchor]
+ _ -> []
+
+ htlcs = fmap htlc_output untrimmed
+
+ htlc_output h =
+ let !script = case htlc_direction h of
+ HTLCOffered -> offered_htlc_script
+ (ck_revocation_pubkey keys) (ck_remote_htlc keys)
+ (ck_local_htlc keys) (htlc_payment_hash h) fmt
+ HTLCReceived -> received_htlc_script
+ (ck_revocation_pubkey keys) (ck_remote_htlc keys)
+ (ck_local_htlc keys) (htlc_payment_hash h)
+ (htlc_cltv_expiry h) fmt
+ in CommitmentOutput (BOLT1.msat_to_sat (htlc_amount_msat h))
+ (to_p2wsh script) (OutputHTLC h)
+
+-- BIP69+CLTV order: value, then scriptPubKey, then (for HTLCs) CLTV
+-- expiry.
+sort_outputs :: [CommitmentOutput] -> [CommitmentOutput]
+sort_outputs = sortBy cmp where
+ cmp a b = compare (co_value a) (co_value b)
+ <> compare (co_script a) (co_script b)
+ <> compare (cltv (co_type a)) (cltv (co_type b))
+ cltv t = case t of
+ OutputHTLC h -> Just (htlc_cltv_expiry h)
+ _ -> Nothing
+
+-- HTLC transactions ----------------------------------------------------------
+
+-- | The parameters of an HTLC-success or HTLC-timeout transaction,
+-- spending an HTLC output of the owner's commitment transaction.
data HTLCContext = HTLCContext
- { hc_commitment_txid :: !TxId
- , hc_output_index :: {-# UNPACK #-} !Word32
- , hc_htlc :: !HTLC
- , hc_to_self_delay :: !ToSelfDelay
- , hc_feerate :: !FeeratePerKw
- , hc_features :: !ChannelFeatures
- , hc_revocation_pubkey :: !RevocationPubkey
- , hc_local_delayed :: !LocalDelayedPubkey
+ { hc_commitment_txid :: !TxId
+ , hc_output_index :: {-# UNPACK #-} !Word32
+ , hc_htlc :: !HTLC
+ , hc_to_self_delay :: {-# UNPACK #-} !ToSelfDelay
+ , hc_feerate :: {-# UNPACK #-} !FeeratePerKw
+ , hc_format :: !CommitmentFormat
+ , hc_revocation_pubkey :: !RevocationPubkey
+ , hc_local_delayed :: !LocalDelayedPubkey
} deriving (Eq, Show, Generic)
--- | An HTLC transaction (timeout or success).
+instance NFData HTLCContext
+
+-- | An unsigned HTLC-success or HTLC-timeout transaction.
data HTLCTx = HTLCTx
- { htx_version :: {-# UNPACK #-} !Word32
- , htx_locktime :: !Locktime
- , htx_input_outpoint :: !OutPoint
- , htx_input_sequence :: !Sequence
- , htx_output_value :: !Satoshi
- , htx_output_script :: !Script
+ { htx_version :: {-# UNPACK #-} !Word32
+ , htx_locktime :: {-# UNPACK #-} !Locktime
+ , htx_input_outpoint :: {-# UNPACK #-} !OutPoint
+ , htx_input_sequence :: {-# UNPACK #-} !Sequence
+ , htx_output_value :: {-# UNPACK #-} !Satoshi
+ , htx_output_script :: !Script
} deriving (Eq, Show, Generic)
--- | Internal helper for HTLC transaction construction.
---
--- Both HTLC-timeout and HTLC-success transactions share the same
--- structure, differing only in locktime and fee calculation.
-build_htlc_tx_common
- :: HTLCContext
- -> Locktime -- ^ Transaction locktime
- -> Satoshi -- ^ Fee to subtract from output
- -> HTLCTx
-build_htlc_tx_common ctx locktime fee =
- let !amountSat = msatToSat (htlc_amount_msat $ hc_htlc ctx)
- !outputValue = if unSatoshi amountSat >= unSatoshi fee
- then Satoshi (unSatoshi amountSat - unSatoshi fee)
- else Satoshi 0
- !inputSeq = if has_anchors (hc_features ctx)
- then Sequence 1
- else Sequence 0
- !outpoint = OutPoint (hc_commitment_txid ctx) (hc_output_index ctx)
- !outputScript = to_p2wsh $ htlc_output_script
- (hc_revocation_pubkey ctx)
- (hc_to_self_delay ctx)
- (hc_local_delayed ctx)
- in HTLCTx
- { htx_version = 2
- , htx_locktime = locktime
- , htx_input_outpoint = outpoint
- , htx_input_sequence = inputSeq
- , htx_output_value = outputValue
- , htx_output_script = outputScript
- }
-{-# INLINE build_htlc_tx_common #-}
-
--- | Build an HTLC-timeout transaction.
---
--- * locktime: cltv_expiry
--- * sequence: 0 (or 1 with option_anchors)
--- * output: to_local style script with revocation and delayed paths
-build_htlc_timeout_tx :: HTLCContext -> HTLCTx
-build_htlc_timeout_tx ctx =
- let !fee = htlc_timeout_fee (hc_feerate ctx) (hc_features ctx)
- !locktime = Locktime (unCltvExpiry $ htlc_cltv_expiry $ hc_htlc ctx)
- in build_htlc_tx_common ctx locktime fee
-{-# INLINE build_htlc_timeout_tx #-}
-
--- | Build an HTLC-success transaction.
+instance NFData HTLCTx
+
+-- | Build the second-stage transaction for an HTLC output of the
+-- owner's commitment transaction: HTLC-timeout (locktime
+-- @cltv_expiry@) for an offered HTLC, and HTLC-success (locktime 0)
+-- for a received one.
--
--- * locktime: 0
--- * sequence: 0 (or 1 with option_anchors)
--- * output: to_local style script with revocation and delayed paths
-build_htlc_success_tx :: HTLCContext -> HTLCTx
-build_htlc_success_tx ctx =
- let !fee = htlc_success_fee (hc_feerate ctx) (hc_features ctx)
- in build_htlc_tx_common ctx (Locktime 0) fee
-{-# INLINE build_htlc_success_tx #-}
-
--- closing transaction ---------------------------------------------------------
-
--- | Context for building closing transactions.
-data ClosingContext = ClosingContext
- { clc_funding_outpoint :: !OutPoint
- , clc_local_amount :: !Satoshi
- , clc_remote_amount :: !Satoshi
- , clc_local_script :: !Script
- , clc_remote_script :: !Script
- , clc_local_dust_limit :: !DustLimit
- , clc_remote_dust_limit :: !DustLimit
- , clc_fee :: !Satoshi
- , clc_is_funder :: !Bool
- , clc_locktime :: !Locktime
- , clc_funding_script :: !Script
+-- The output pays the HTLC amount, less the HTLC transaction fee
+-- (zero under 'Anchors'), to the 'to_local_script' of the owner's
+-- keys. Fails if the fee exceeds the amount (such an HTLC is always
+-- trimmed).
+build_htlc_tx :: HTLCContext -> Maybe HTLCTx
+build_htlc_tx ctx = do
+ value <- BOLT1.sub_sat (BOLT1.msat_to_sat (htlc_amount_msat h)) fee
+ pure HTLCTx
+ { htx_version = 2
+ , htx_locktime = locktime
+ , htx_input_outpoint =
+ OutPoint (hc_commitment_txid ctx) (hc_output_index ctx)
+ , htx_input_sequence = case fmt of
+ StaticRemotekey -> Sequence 0
+ Anchors -> Sequence 1
+ , htx_output_value = value
+ , htx_output_script = to_p2wsh $ to_local_script
+ (hc_revocation_pubkey ctx) (hc_to_self_delay ctx)
+ (hc_local_delayed ctx)
+ }
+ where
+ !h = hc_htlc ctx
+ !fmt = hc_format ctx
+ (!fee, !locktime) = case htlc_direction h of
+ HTLCOffered ->
+ let CltvExpiry e = htlc_cltv_expiry h
+ in (htlc_timeout_fee (hc_feerate ctx) fmt, Locktime e)
+ HTLCReceived ->
+ (htlc_success_fee (hc_feerate ctx) fmt, Locktime 0)
+
+-- closing transactions -------------------------------------------------------
+
+-- | A closing transaction output.
+data ClosingOutput = ClosingOutput
+ { clo_value :: {-# UNPACK #-} !Satoshi
+ , clo_script :: !Script -- ^ scriptPubKey
} deriving (Eq, Show, Generic)
--- | A closing transaction.
+instance NFData ClosingOutput
+
+-- | An unsigned closing transaction.
data ClosingTx = ClosingTx
- { cltx_version :: {-# UNPACK #-} !Word32
- , cltx_locktime :: !Locktime
- , cltx_input_outpoint :: !OutPoint
- , cltx_input_sequence :: !Sequence
- , cltx_outputs :: ![TxOutput]
- , cltx_funding_script :: !Script
+ { cltx_version :: {-# UNPACK #-} !Word32
+ , cltx_locktime :: {-# UNPACK #-} !Locktime
+ , cltx_input_outpoint :: {-# UNPACK #-} !OutPoint
+ , cltx_input_sequence :: {-# UNPACK #-} !Sequence
+ , cltx_outputs :: !(NonEmpty ClosingOutput)
+ -- ^ in BIP69 order
+ } deriving (Eq, Show, Generic)
+
+instance NFData ClosingTx
+
+-- | Which outputs an @option_simple_close@ closing transaction has,
+-- matching the signature fields of @closing_complete@.
+data ClosingOutputs
+ = CloserOutputOnly
+ | CloseeOutputOnly
+ | CloserAndCloseeOutputs
+ deriving (Eq, Show, Generic)
+
+instance NFData ClosingOutputs
+
+-- | The parameters of an @option_simple_close@ closing transaction,
+-- as given by a @closing_complete@ message.
+data ClosingContext = ClosingContext
+ { clc_funding_outpoint :: {-# UNPACK #-} !OutPoint
+ , clc_closer_msat :: {-# UNPACK #-} !MilliSatoshi
+ -- ^ the closer's final balance
+ , clc_closee_msat :: {-# UNPACK #-} !MilliSatoshi
+ -- ^ the closee's final balance
+ , clc_closer_script :: !Script
+ , clc_closee_script :: !Script
+ , clc_fee :: {-# UNPACK #-} !Satoshi
+ , clc_locktime :: {-# UNPACK #-} !Locktime
+ , clc_outputs :: !ClosingOutputs
} deriving (Eq, Show, Generic)
--- | Build a closing transaction (option_simple_close).
+instance NFData ClosingContext
+
+-- | Build an @option_simple_close@ closing transaction (BOLT #3's
+-- "Closing Transaction"), for @closing_complete@ and @closing_sig@.
--
--- * locktime: from closing_complete message
--- * sequence: 0xFFFFFFFD
--- * outputs: sorted per BIP69
-build_closing_tx :: ClosingContext -> ClosingTx
-build_closing_tx ctx =
- let -- Subtract fee from closer
- !(localAmt, remoteAmt) = if clc_is_funder ctx
- then
- let !deducted = if unSatoshi (clc_local_amount ctx) >=
- unSatoshi (clc_fee ctx)
- then Satoshi (unSatoshi (clc_local_amount ctx) -
- unSatoshi (clc_fee ctx))
- else Satoshi 0
- in (deducted, clc_remote_amount ctx)
- else
- let !deducted = if unSatoshi (clc_remote_amount ctx) >=
- unSatoshi (clc_fee ctx)
- then Satoshi (unSatoshi (clc_remote_amount ctx) -
- unSatoshi (clc_fee ctx))
- else Satoshi 0
- in (clc_local_amount ctx, deducted)
-
- -- Build outputs, omitting dust
- !localOutput =
- if unSatoshi localAmt >= unSatoshi (unDustLimit $ clc_local_dust_limit ctx)
- then [TxOutput localAmt (clc_local_script ctx) OutputToLocal]
- else []
-
- !remoteOutput =
- if unSatoshi remoteAmt >= unSatoshi (unDustLimit $ clc_remote_dust_limit ctx)
- then [TxOutput remoteAmt (clc_remote_script ctx) OutputToRemote]
- else []
-
- !allOutputs = localOutput ++ remoteOutput
- !sortedOutputs = sort_outputs allOutputs
-
- in ClosingTx
- { cltx_version = 2
- , cltx_locktime = clc_locktime ctx
- , cltx_input_outpoint = clc_funding_outpoint ctx
- , cltx_input_sequence = Sequence 0xFFFFFFFD
- , cltx_outputs = sortedOutputs
- , cltx_funding_script = clc_funding_script ctx
- }
-{-# INLINE build_closing_tx #-}
-
--- | Build a legacy closing transaction (closing_signed).
+-- The closer pays the fee: its output is its balance, rounded down
+-- to whole satoshis, less the fee. An output whose scriptPubKey
+-- starts with @OP_RETURN@ has amount 0. Only the chosen outputs are
+-- included, and none is trimmed. Fails if the fee exceeds the
+-- closer's balance.
+build_closing_tx :: ClosingContext -> Maybe ClosingTx
+build_closing_tx ctx = do
+ closer_sat <-
+ BOLT1.sub_sat (BOLT1.msat_to_sat (clc_closer_msat ctx)) (clc_fee ctx)
+ let !closer = output closer_sat (clc_closer_script ctx)
+ !closee = output (BOLT1.msat_to_sat (clc_closee_msat ctx))
+ (clc_closee_script ctx)
+ pure ClosingTx
+ { cltx_version = 2
+ , cltx_locktime = clc_locktime ctx
+ , cltx_input_outpoint = clc_funding_outpoint ctx
+ , cltx_input_sequence = Sequence 0xFFFFFFFD
+ , cltx_outputs = case clc_outputs ctx of
+ CloserOutputOnly -> closer :| []
+ CloseeOutputOnly -> closee :| []
+ CloserAndCloseeOutputs -> sort_closing (closer :| [closee])
+ }
+ where
+ output amt spk@(Script s) = case BS.uncons s of
+ Just (0x6a, _) -> ClosingOutput (sat 0) spk
+ _ -> ClosingOutput amt spk
+
+-- | The parameters of a legacy closing transaction (for
+-- @closing_signed@), from the point of view of the node producing
+-- the signature (the "local" party).
+data LegacyClosingContext = LegacyClosingContext
+ { lcc_funding_outpoint :: {-# UNPACK #-} !OutPoint
+ , lcc_local_msat :: {-# UNPACK #-} !MilliSatoshi
+ , lcc_remote_msat :: {-# UNPACK #-} !MilliSatoshi
+ , lcc_local_script :: !Script
+ , lcc_remote_script :: !Script
+ , lcc_dust_limit :: {-# UNPACK #-} !DustLimit
+ -- ^ the signer's @dust_limit_satoshis@
+ , lcc_fee :: {-# UNPACK #-} !Satoshi
+ , lcc_is_funder :: !Bool
+ -- ^ whether the signer funded the channel, and so pays the fee
+ , lcc_omit_local :: !Bool
+ -- ^ whether the signer eliminates its own output
+ } deriving (Eq, Show, Generic)
+
+instance NFData LegacyClosingContext
+
+-- | Build a legacy closing transaction (BOLT #3's "Legacy Closing
+-- Transaction"), for @closing_signed@.
--
--- * locktime: 0
--- * sequence: 0xFFFFFFFF
--- * outputs: sorted per BIP69
-build_legacy_closing_tx :: ClosingContext -> ClosingTx
-build_legacy_closing_tx ctx =
- let !result = build_closing_tx ctx
- { clc_locktime = Locktime 0 }
- in result { cltx_input_sequence = Sequence 0xFFFFFFFF }
-{-# INLINE build_legacy_closing_tx #-}
-
--- fee calculation -------------------------------------------------------------
-
--- | Calculate the base commitment transaction fee.
+-- Balances are rounded down to whole satoshis and the fee is taken
+-- from the funder's output. Outputs below the signer's dust limit
+-- are removed, as is the signer's own output if 'lcc_omit_local' is
+-- set. Fails if the fee exceeds the funder's balance, or if no
+-- output remains.
+build_legacy_closing_tx :: LegacyClosingContext -> Maybe ClosingTx
+build_legacy_closing_tx ctx = do
+ let !local_sat = BOLT1.msat_to_sat (lcc_local_msat ctx)
+ !remote_sat = BOLT1.msat_to_sat (lcc_remote_msat ctx)
+ DustLimit dust = lcc_dust_limit ctx
+ (l, r) <-
+ if lcc_is_funder ctx
+ then fmap (\x -> (x, remote_sat)) (BOLT1.sub_sat local_sat fee)
+ else fmap (\x -> (local_sat, x)) (BOLT1.sub_sat remote_sat fee)
+ outputs <- NE.nonEmpty $
+ [ ClosingOutput l (lcc_local_script ctx)
+ | not (lcc_omit_local ctx), l >= dust ]
+ <> [ ClosingOutput r (lcc_remote_script ctx) | r >= dust ]
+ pure ClosingTx
+ { cltx_version = 2
+ , cltx_locktime = Locktime 0
+ , cltx_input_outpoint = lcc_funding_outpoint ctx
+ , cltx_input_sequence = Sequence 0xFFFFFFFF
+ , cltx_outputs = sort_closing outputs
+ }
+ where
+ !fee = lcc_fee ctx
+
+-- BIP69 order: value, then scriptPubKey.
+sort_closing :: NonEmpty ClosingOutput -> NonEmpty ClosingOutput
+sort_closing = NE.sortBy $ \a b ->
+ compare (clo_value a) (clo_value b) <> compare (clo_script a) (clo_script b)
+
+-- fees -----------------------------------------------------------------------
+
+-- feerate * weight / 1000, saturating at 21 million BTC.
+weight_fee :: FeeratePerKw -> Integer -> Satoshi
+weight_fee (FeeratePerKw rate) weight =
+ let !f = toInteger rate * weight `quot` 1000
+ in if f > toInteger (BOLT1.un_satoshi BOLT1.max_satoshi)
+ then BOLT1.max_satoshi
+ else sat (fromInteger f)
+
+-- | The base fee of a commitment transaction with a given number of
+-- untrimmed HTLC outputs:
--
--- @fee = feerate_per_kw * weight / 1000@
+-- @feerate_per_kw * (724 + 172 * num_htlcs) / 1000@
--
--- where @weight = base_weight + 172 * num_htlcs@
-commitment_fee :: FeeratePerKw -> ChannelFeatures -> Word64 -> Satoshi
-commitment_fee feerate features numHtlcs =
- let !weight = commitment_weight features numHtlcs
- !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000
- in Satoshi fee
-{-# INLINE commitment_fee #-}
-
--- | Calculate commitment transaction weight.
+-- with a base weight of 1124 rather than 724 under 'Anchors'.
--
--- @weight = base + 172 * num_htlcs@
-commitment_weight :: ChannelFeatures -> Word64 -> Word64
-commitment_weight features numHtlcs =
- let !base = if has_anchors features
- then commitment_weight_anchors
- else commitment_weight_no_anchors
- in base + htlc_output_weight * numHtlcs
-{-# INLINE commitment_weight #-}
-
--- | Calculate HTLC-timeout transaction fee.
+-- >>> commitment_fee (FeeratePerKw 5000) StaticRemotekey 2
+-- Satoshi 5340
+commitment_fee :: FeeratePerKw -> CommitmentFormat -> Word64 -> Satoshi
+commitment_fee rate fmt n = weight_fee rate (base + 172 * toInteger n) where
+ base = case fmt of
+ StaticRemotekey -> 724
+ Anchors -> 1124
+
+-- | The fee of an HTLC-timeout transaction: @feerate_per_kw * 663 /
+-- 1000@, or zero under 'Anchors'.
--
--- With option_anchors, fee is 0 (CPFP).
--- Otherwise, @fee = feerate_per_kw * 663 / 1000@
-htlc_timeout_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi
-htlc_timeout_fee feerate features
- | has_anchors features = Satoshi 0
- | otherwise =
- let !weight = htlc_timeout_weight_no_anchors
- !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000
- in Satoshi fee
-{-# INLINE htlc_timeout_fee #-}
-
--- | Calculate HTLC-success transaction fee.
+-- >>> htlc_timeout_fee (FeeratePerKw 5000) StaticRemotekey
+-- Satoshi 3315
+htlc_timeout_fee :: FeeratePerKw -> CommitmentFormat -> Satoshi
+htlc_timeout_fee rate fmt = case fmt of
+ StaticRemotekey -> weight_fee rate 663
+ Anchors -> sat 0
+
+-- | The fee of an HTLC-success transaction: @feerate_per_kw * 703 /
+-- 1000@, or zero under 'Anchors'.
--
--- With option_anchors, fee is 0 (CPFP).
--- Otherwise, @fee = feerate_per_kw * 703 / 1000@
-htlc_success_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi
-htlc_success_fee feerate features
- | has_anchors features = Satoshi 0
- | otherwise =
- let !weight = htlc_success_weight_no_anchors
- !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000
- in Satoshi fee
-{-# INLINE htlc_success_fee #-}
-
--- trimming --------------------------------------------------------------------
-
--- | Calculate the trim threshold for an HTLC.
+-- >>> htlc_success_fee (FeeratePerKw 5000) StaticRemotekey
+-- Satoshi 3515
+htlc_success_fee :: FeeratePerKw -> CommitmentFormat -> Satoshi
+htlc_success_fee rate fmt = case fmt of
+ StaticRemotekey -> weight_fee rate 703
+ Anchors -> sat 0
+
+-- trimming -------------------------------------------------------------------
+
+-- | The amount below which an HTLC in a given direction is trimmed:
+-- the dust limit plus the fee of its HTLC transaction.
--
--- An HTLC is trimmed if:
--- @amount < dust_limit + htlc_tx_fee@
+-- >>> let Just d = fmap DustLimit (BOLT1.satoshi 546)
+-- >>> htlc_trim_threshold d (FeeratePerKw 5000) StaticRemotekey HTLCOffered
+-- Satoshi 3861
htlc_trim_threshold
:: DustLimit
-> FeeratePerKw
- -> ChannelFeatures
+ -> CommitmentFormat
-> HTLCDirection
-> Satoshi
-htlc_trim_threshold dust feerate features direction =
- let !dustVal = unDustLimit dust
- !htlcFee = case direction of
- HTLCOffered -> htlc_timeout_fee feerate features
- HTLCReceived -> htlc_success_fee feerate features
- in Satoshi (unSatoshi dustVal + unSatoshi htlcFee)
-{-# INLINE htlc_trim_threshold #-}
-
--- | Check if an HTLC should be trimmed.
---
--- An HTLC is trimmed if its amount minus the HTLC tx fee is below
--- the dust limit.
-is_trimmed :: DustLimit -> FeeratePerKw -> ChannelFeatures -> HTLC -> Bool
-is_trimmed dust feerate features htlc =
- let !threshold = htlc_trim_threshold dust feerate features
- (htlc_direction htlc)
- !amountSat = msatToSat (htlc_amount_msat htlc)
- in unSatoshi amountSat < unSatoshi threshold
-{-# INLINE is_trimmed #-}
-
--- | Filter HTLCs that are trimmed.
-trimmed_htlcs
- :: DustLimit
- -> FeeratePerKw
- -> ChannelFeatures
- -> [HTLC]
- -> [HTLC]
-trimmed_htlcs dust feerate features =
- filter (is_trimmed dust feerate features)
-{-# INLINE trimmed_htlcs #-}
-
--- | Filter HTLCs that are not trimmed.
-untrimmed_htlcs
- :: DustLimit
- -> FeeratePerKw
- -> ChannelFeatures
- -> [HTLC]
- -> [HTLC]
-untrimmed_htlcs dust feerate features =
- filter (not . is_trimmed dust feerate features)
-{-# INLINE untrimmed_htlcs #-}
-
--- conversion to ppad-tx -------------------------------------------------------
-
--- | Convert a 'TxOutput' to a ppad-tx 'BT.TxOut'.
-toTxOut :: TxOutput -> BT.TxOut
-toTxOut o = BT.TxOut
- { BT.txout_value =
- unSatoshi (txout_value o)
- , BT.txout_script_pubkey =
- unScript (txout_script o)
+htlc_trim_threshold (DustLimit dust) rate fmt dir =
+ let !fee = case dir of
+ HTLCOffered -> htlc_timeout_fee rate fmt
+ HTLCReceived -> htlc_success_fee rate fmt
+ in fromMaybe BOLT1.max_satoshi (BOLT1.add_sat dust fee)
+
+-- | Whether an HTLC is trimmed from a commitment transaction: whether
+-- its amount, rounded down to whole satoshis, is below
+-- 'htlc_trim_threshold'.
+is_trimmed :: DustLimit -> FeeratePerKw -> CommitmentFormat -> HTLC -> Bool
+is_trimmed dust rate fmt h =
+ BOLT1.msat_to_sat (htlc_amount_msat h)
+ < htlc_trim_threshold dust rate fmt (htlc_direction h)
+
+-- serialization --------------------------------------------------------------
+
+unsigned_tx
+ :: Word32 -> Locktime -> OutPoint -> Sequence -> NonEmpty BT.TxOut
+ -> BT.Tx
+unsigned_tx version (Locktime lt) prevout (Sequence sq) outs = BT.Tx
+ { BT.tx_version = version
+ , BT.tx_inputs = BT.TxIn prevout BS.empty sq :| []
+ , BT.tx_outputs = outs
+ , BT.tx_witnesses = []
+ , BT.tx_locktime = lt
}
-{-# INLINE toTxOut #-}
--- | Convert a commitment transaction to a ppad-tx 'BT.Tx'.
---
--- Returns 'Nothing' if the transaction has no outputs.
-commitment_to_tx :: CommitmentTx -> Maybe BT.Tx
-commitment_to_tx ctx = do
- outs <- nonEmpty (map toTxOut (ctx_outputs ctx))
- let !input = BT.TxIn
- { BT.txin_prevout = ctx_input_outpoint ctx
- , BT.txin_script_sig = BS.empty
- , BT.txin_sequence =
- unSequence (ctx_input_sequence ctx)
- }
- pure $! BT.Tx
- { BT.tx_version = ctx_version ctx
- , BT.tx_inputs = input :| []
- , BT.tx_outputs = outs
- , BT.tx_witnesses = []
- , BT.tx_locktime = unLocktime (ctx_locktime ctx)
- }
-
--- | Convert an HTLC transaction to a ppad-tx 'BT.Tx'.
+txout :: Satoshi -> Script -> BT.TxOut
+txout v (Script s) = BT.TxOut (BOLT1.un_satoshi v) s
+{-# INLINE txout #-}
+
+-- | The unsigned commitment transaction as a ppad-tx 'BT.Tx' (with no
+-- witnesses), e.g. for computing its txid or sighashes.
+commitment_to_tx :: CommitmentTx -> BT.Tx
+commitment_to_tx c = unsigned_tx (ctx_version c) (ctx_locktime c)
+ (ctx_input_outpoint c) (ctx_input_sequence c)
+ (fmap (\o -> txout (co_value o) (co_script o)) (ctx_outputs c))
+
+-- | The unsigned HTLC transaction as a ppad-tx 'BT.Tx'.
htlc_to_tx :: HTLCTx -> BT.Tx
-htlc_to_tx htx =
- let !input = BT.TxIn
- { BT.txin_prevout = htx_input_outpoint htx
- , BT.txin_script_sig = BS.empty
- , BT.txin_sequence =
- unSequence (htx_input_sequence htx)
- }
- !output = BT.TxOut
- { BT.txout_value =
- unSatoshi (htx_output_value htx)
- , BT.txout_script_pubkey =
- unScript (htx_output_script htx)
- }
- in BT.Tx
- { BT.tx_version = htx_version htx
- , BT.tx_inputs = input :| []
- , BT.tx_outputs = output :| []
- , BT.tx_witnesses = []
- , BT.tx_locktime = unLocktime (htx_locktime htx)
- }
-
--- | Convert a closing transaction to a ppad-tx 'BT.Tx'.
---
--- Returns 'Nothing' if the transaction has no outputs.
-closing_to_tx :: ClosingTx -> Maybe BT.Tx
-closing_to_tx ctx = do
- outs <- nonEmpty (map toTxOut (cltx_outputs ctx))
- let !input = BT.TxIn
- { BT.txin_prevout = cltx_input_outpoint ctx
- , BT.txin_script_sig = BS.empty
- , BT.txin_sequence =
- unSequence (cltx_input_sequence ctx)
- }
- pure $! BT.Tx
- { BT.tx_version = cltx_version ctx
- , BT.tx_inputs = input :| []
- , BT.tx_outputs = outs
- , BT.tx_witnesses = []
- , BT.tx_locktime = unLocktime (cltx_locktime ctx)
- }
-
--- output ordering -------------------------------------------------------------
-
--- | Sort outputs per BOLT #3 ordering.
---
--- Outputs are sorted by:
--- 1. Value (smallest first)
--- 2. ScriptPubKey (lexicographic)
--- 3. CLTV expiry (for HTLCs)
-sort_outputs :: [TxOutput] -> [TxOutput]
-sort_outputs = sortBy compareOutputs
-{-# INLINE sort_outputs #-}
-
--- | Compare two outputs for ordering.
-compareOutputs :: TxOutput -> TxOutput -> Ordering
-compareOutputs o1 o2 =
- case compare (txout_value o1) (txout_value o2) of
- EQ -> case compare (unScript $ txout_script o1)
- (unScript $ txout_script o2) of
- EQ -> compareCltvExpiry (txout_type o1) (txout_type o2)
- other -> other
- other -> other
-{-# INLINE compareOutputs #-}
-
--- | Compare CLTV expiry for HTLC outputs.
-compareCltvExpiry :: OutputType -> OutputType -> Ordering
-compareCltvExpiry (OutputOfferedHTLC e1) (OutputOfferedHTLC e2) = compare e1 e2
-compareCltvExpiry (OutputReceivedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2
-compareCltvExpiry (OutputOfferedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2
-compareCltvExpiry (OutputReceivedHTLC e1) (OutputOfferedHTLC e2) = compare e1 e2
-compareCltvExpiry _ _ = EQ
-{-# INLINE compareCltvExpiry #-}
+htlc_to_tx h = unsigned_tx (htx_version h) (htx_locktime h)
+ (htx_input_outpoint h) (htx_input_sequence h)
+ (txout (htx_output_value h) (htx_output_script h) :| [])
+
+-- | The unsigned closing transaction as a ppad-tx 'BT.Tx'.
+closing_to_tx :: ClosingTx -> BT.Tx
+closing_to_tx c = unsigned_tx (cltx_version c) (cltx_locktime c)
+ (cltx_input_outpoint c) (cltx_input_sequence c)
+ (fmap (\o -> txout (clo_value o) (clo_script o)) (cltx_outputs c))
+
+-- | Serialize an unsigned commitment transaction, without witness
+-- data. This is the form whose double-SHA256 is the txid; it is not
+-- what segwit signatures commit to (see ppad-tx's
+-- @Bitcoin.Prim.Tx.Sighash@). To broadcast, attach the witness to
+-- 'commitment_to_tx' and serialize with ppad-tx.
+encode_commitment_tx :: CommitmentTx -> BS.ByteString
+encode_commitment_tx = BT.to_bytes_legacy . commitment_to_tx
+
+-- | Serialize an unsigned HTLC transaction, without witness data (cf.
+-- 'encode_commitment_tx').
+encode_htlc_tx :: HTLCTx -> BS.ByteString
+encode_htlc_tx = BT.to_bytes_legacy . htlc_to_tx
+
+-- | Serialize an unsigned closing transaction, without witness data
+-- (cf. 'encode_commitment_tx').
+encode_closing_tx :: ClosingTx -> BS.ByteString
+encode_closing_tx = BT.to_bytes_legacy . closing_to_tx
diff --git a/lib/Lightning/Protocol/BOLT3/Types.hs b/lib/Lightning/Protocol/BOLT3/Types.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -8,366 +8,404 @@
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
--- Core types for BOLT #3 transaction and script formats.
+-- Types for BOLT #3 transaction and script formats.
module Lightning.Protocol.BOLT3.Types (
- -- * Monetary amounts (re-exported from BOLT1)
- Satoshi(..)
- , MilliSatoshi(..)
- , msatToSat
- , satToMsat
-
- -- * Keys and points
- , Pubkey(..)
- , pubkey
+ -- * Points and keys
+ PerCommitmentPoint(..)
+ , RevocationBasepoint(..)
+ , PaymentBasepoint(..)
+ , DelayedPaymentBasepoint(..)
+ , HtlcBasepoint(..)
+ , Basepoints(..)
+ , RevocationPubkey(..)
+ , LocalDelayedPubkey(..)
+ , LocalHtlcPubkey(..)
+ , RemoteHtlcPubkey(..)
+ , RemotePubkey(..)
+ , FundingPubkey(..)
, Seckey(..)
, seckey
- , Point(..)
- , point
- , unPoint
-
- -- * Hashes (re-exported from BOLT1)
- , PaymentHash(..)
- , paymentHash
- , unPaymentHash
- , PaymentPreimage(..)
- , paymentPreimage
- , unPaymentPreimage
-
- -- * Transaction primitives
- , TxId(..)
- , mkTxId
- , OutPoint(..)
- , Sequence(..)
- , Locktime(..)
+ , un_seckey
+
+ -- * Per-commitment secrets
+ , Seed(..)
+ , seed
+ , un_seed
+ , SecretIndex(..)
+ , secret_index
+ , un_secret_index
+ , commitment_secret_index
-- * Channel parameters
, CommitmentNumber(..)
, commitment_number
+ , un_commitment_number
, next_commitment_number
, ToSelfDelay(..)
, CltvExpiry(..)
, DustLimit(..)
, FeeratePerKw(..)
+ , Locktime(..)
+ , Sequence(..)
+ , CommitmentFormat(..)
- -- * HTLC types
+ -- * HTLCs
, HTLC(..)
, HTLCDirection(..)
- -- * Basepoints
- , Basepoints(..)
- , PerCommitmentPoint(..)
- , PerCommitmentSecret(..)
- , perCommitmentSecret
- , unPerCommitmentSecret
- , RevocationBasepoint(..)
- , PaymentBasepoint(..)
- , DelayedPaymentBasepoint(..)
- , HtlcBasepoint(..)
-
- -- * Derived keys
- , LocalPubkey(..)
- , RemotePubkey(..)
- , LocalDelayedPubkey(..)
- , RemoteDelayedPubkey(..)
- , LocalHtlcPubkey(..)
- , RemoteHtlcPubkey(..)
- , RevocationPubkey(..)
- , FundingPubkey(..)
-
- -- * Script
+ -- * Scripts
, Script(..)
- -- * Witness (re-exported from ppad-tx)
- , Witness(..)
-
- -- * Channel options
- , ChannelFeatures(..)
- , has_anchors
-
- -- * Transaction weights (constants)
- , commitment_weight_no_anchors
- , commitment_weight_anchors
- , htlc_timeout_weight_no_anchors
- , htlc_timeout_weight_anchors
- , htlc_success_weight_no_anchors
- , htlc_success_weight_anchors
- , htlc_output_weight
-
- -- * Dust thresholds (constants)
+ -- * Dust thresholds
, dust_p2pkh
, dust_p2sh
, dust_p2wpkh
, dust_p2wsh
, anchor_output_value
+
+ -- * Internal
+ , sat
+ , internal_error
) where
-import Bitcoin.Prim.Tx (TxId(..), mkTxId, OutPoint(..), Witness(..))
-import Data.Word (Word16, Word32, Word64)
+import Control.DeepSeq (NFData(..))
+import qualified Crypto.Curve.Secp256k1 as S
import qualified Data.ByteString as BS
+import Data.Word (Word16, Word32, Word64)
import GHC.Generics (Generic)
-import Lightning.Protocol.BOLT1.Prim
- ( Satoshi(..), MilliSatoshi(..)
- , satToMsat, msatToSat
- , Point(..), point, unPoint
- , PaymentHash(..), paymentHash, unPaymentHash
- , PaymentPreimage(..), paymentPreimage, unPaymentPreimage
- , PerCommitmentSecret(..), perCommitmentSecret
- , unPerCommitmentSecret
- )
-
--- keys and points -------------------------------------------------------------
-
--- | Compressed public key (33 bytes).
-newtype Pubkey = Pubkey { unPubkey :: BS.ByteString }
- deriving (Eq, Ord, Show, Generic)
+import Lightning.Protocol.BOLT1 (Point, Satoshi, MilliSatoshi, PaymentHash)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
--- | Parse a 33-byte compressed public key.
---
--- Returns Nothing if the input is not exactly 33 bytes.
---
--- >>> pubkey (BS.replicate 33 0x02)
--- Just (Pubkey ...)
--- >>> pubkey (BS.replicate 32 0x02)
--- Nothing
-pubkey :: BS.ByteString -> Maybe Pubkey
-pubkey bs
- | BS.length bs == 33 = Just (Pubkey bs)
- | otherwise = Nothing
-{-# INLINE pubkey #-}
-
--- | Secret key (32 bytes).
-newtype Seckey = Seckey { unSeckey :: BS.ByteString }
- deriving (Eq, Generic)
-
--- Don't show secret keys
-instance Show Seckey where
- show _ = "Seckey <redacted>"
+-- internal ------------------------------------------------------------------
--- | Parse a 32-byte secret key.
---
--- Returns Nothing if the input is not exactly 32 bytes.
-seckey :: BS.ByteString -> Maybe Seckey
-seckey bs
- | BS.length bs == 32 = Just (Seckey bs)
- | otherwise = Nothing
-{-# INLINE seckey #-}
+-- Abort on a state that the surrounding code rules out.
+internal_error :: a
+internal_error = error "ppad-bolt3: internal error, please report a bug!"
+{-# NOINLINE internal_error #-}
--- transaction primitives ------------------------------------------------------
+-- A 'Satoshi' amount known to be at most 21 million BTC (a constant,
+-- or a value bounded by construction).
+sat :: Word64 -> Satoshi
+sat w = case BOLT1.satoshi w of
+ Just s -> s
+ Nothing -> internal_error
+{-# INLINE sat #-}
--- | Transaction input sequence number.
-newtype Sequence = Sequence { unSequence :: Word32 }
- deriving (Eq, Ord, Show, Generic)
+-- points and keys ------------------------------------------------------------
--- | Transaction locktime.
-newtype Locktime = Locktime { unLocktime :: Word32 }
+-- | A per-commitment point, from which a commitment's keys are
+-- derived.
+newtype PerCommitmentPoint = PerCommitmentPoint Point
deriving (Eq, Ord, Show, Generic)
--- channel parameters ----------------------------------------------------------
+instance NFData PerCommitmentPoint
--- | 48-bit commitment number.
-newtype CommitmentNumber = CommitmentNumber
- { unCommitmentNumber :: Word64 }
+-- | A @revocation_basepoint@.
+newtype RevocationBasepoint = RevocationBasepoint Point
deriving (Eq, Ord, Show, Generic)
--- | Parse a 48-bit commitment number.
---
--- Returns Nothing if the value exceeds 2^48 - 1.
-commitment_number :: Word64 -> Maybe CommitmentNumber
-commitment_number n
- | n <= 281474976710655 = Just (CommitmentNumber n)
- | otherwise = Nothing
-{-# INLINE commitment_number #-}
+instance NFData RevocationBasepoint
--- | Increment a commitment number by one.
---
--- Returns Nothing if the result would exceed 2^48 - 1.
---
--- >>> fmap next_commitment_number (commitment_number 0)
--- Just (Just (CommitmentNumber {unCommitmentNumber = 1}))
--- >>> fmap next_commitment_number (commitment_number 281474976710655)
--- Just Nothing
-next_commitment_number
- :: CommitmentNumber -> Maybe CommitmentNumber
-next_commitment_number (CommitmentNumber n)
- | n < 281474976710655 = Just (CommitmentNumber (n + 1))
- | otherwise = Nothing
-{-# INLINE next_commitment_number #-}
-
--- | CSV delay for to_local outputs.
-newtype ToSelfDelay = ToSelfDelay { unToSelfDelay :: Word16 }
+-- | A @payment_basepoint@.
+newtype PaymentBasepoint = PaymentBasepoint Point
deriving (Eq, Ord, Show, Generic)
--- | CLTV expiry for HTLCs.
-newtype CltvExpiry = CltvExpiry { unCltvExpiry :: Word32 }
- deriving (Eq, Ord, Show, Generic)
-
--- | Dust limit threshold.
-newtype DustLimit = DustLimit { unDustLimit :: Satoshi }
- deriving (Eq, Ord, Show, Generic)
+instance NFData PaymentBasepoint
--- | Fee rate in satoshis per 1000 weight units.
-newtype FeeratePerKw = FeeratePerKw { unFeeratePerKw :: Word32 }
+-- | A @delayed_payment_basepoint@.
+newtype DelayedPaymentBasepoint = DelayedPaymentBasepoint Point
deriving (Eq, Ord, Show, Generic)
--- HTLC types ------------------------------------------------------------------
+instance NFData DelayedPaymentBasepoint
--- | Direction of an HTLC from the commitment tx owner's perspective.
-data HTLCDirection
- = HTLCOffered -- ^ We offered this HTLC (outgoing)
- | HTLCReceived -- ^ We received this HTLC (incoming)
+-- | An @htlc_basepoint@.
+newtype HtlcBasepoint = HtlcBasepoint Point
deriving (Eq, Ord, Show, Generic)
--- | HTLC output details.
-data HTLC = HTLC
- { htlc_direction :: !HTLCDirection
- , htlc_amount_msat :: {-# UNPACK #-} !MilliSatoshi
- , htlc_payment_hash :: {-# UNPACK #-} !PaymentHash
- , htlc_cltv_expiry :: {-# UNPACK #-} !CltvExpiry
+instance NFData HtlcBasepoint
+
+-- | The four basepoints a party announces in @open_channel@ or
+-- @accept_channel@.
+data Basepoints = Basepoints
+ { bp_revocation :: !RevocationBasepoint
+ , bp_payment :: !PaymentBasepoint
+ , bp_delayed_payment :: !DelayedPaymentBasepoint
+ , bp_htlc :: !HtlcBasepoint
} deriving (Eq, Show, Generic)
--- basepoints ------------------------------------------------------------------
+instance NFData Basepoints
--- | Per-commitment point (used to derive keys).
-newtype PerCommitmentPoint = PerCommitmentPoint
- { unPerCommitmentPoint :: Point }
+-- | A commitment's @revocationpubkey@.
+newtype RevocationPubkey = RevocationPubkey Point
deriving (Eq, Ord, Show, Generic)
--- | Revocation basepoint.
-newtype RevocationBasepoint = RevocationBasepoint
- { unRevocationBasepoint :: Point }
- deriving (Eq, Ord, Show, Generic)
+instance NFData RevocationPubkey
--- | Payment basepoint.
-newtype PaymentBasepoint = PaymentBasepoint
- { unPaymentBasepoint :: Point }
+-- | A commitment's @local_delayedpubkey@: the owner's key for its
+-- delayed outputs.
+newtype LocalDelayedPubkey = LocalDelayedPubkey Point
deriving (Eq, Ord, Show, Generic)
--- | Delayed payment basepoint.
-newtype DelayedPaymentBasepoint = DelayedPaymentBasepoint
- { unDelayedPaymentBasepoint :: Point }
- deriving (Eq, Ord, Show, Generic)
+instance NFData LocalDelayedPubkey
--- | HTLC basepoint.
-newtype HtlcBasepoint = HtlcBasepoint
- { unHtlcBasepoint :: Point }
+-- | A commitment's @local_htlcpubkey@: the owner's HTLC key.
+newtype LocalHtlcPubkey = LocalHtlcPubkey Point
deriving (Eq, Ord, Show, Generic)
--- | Collection of all basepoints for one party.
-data Basepoints = Basepoints
- { bp_revocation :: !RevocationBasepoint
- , bp_payment :: !PaymentBasepoint
- , bp_delayed_payment :: !DelayedPaymentBasepoint
- , bp_htlc :: !HtlcBasepoint
- } deriving (Eq, Show, Generic)
+instance NFData LocalHtlcPubkey
+
+-- | A commitment's @remote_htlcpubkey@: the other party's HTLC key.
+newtype RemoteHtlcPubkey = RemoteHtlcPubkey Point
+ deriving (Eq, Ord, Show, Generic)
--- derived keys ----------------------------------------------------------------
+instance NFData RemoteHtlcPubkey
--- | Local pubkey.
-newtype LocalPubkey = LocalPubkey { unLocalPubkey :: Pubkey }
+-- | A commitment's @remotepubkey@: the other party's
+-- @payment_basepoint@, which its @to_remote@ output pays.
+newtype RemotePubkey = RemotePubkey Point
deriving (Eq, Ord, Show, Generic)
--- | Remote pubkey.
-newtype RemotePubkey = RemotePubkey
- { unRemotePubkey :: Pubkey }
+instance NFData RemotePubkey
+
+-- | A @funding_pubkey@.
+newtype FundingPubkey = FundingPubkey Point
deriving (Eq, Ord, Show, Generic)
--- | Local delayed pubkey.
-newtype LocalDelayedPubkey = LocalDelayedPubkey
- { unLocalDelayedPubkey :: Pubkey }
+instance NFData FundingPubkey
+
+-- | A secp256k1 secret key: 32 bytes encoding an integer in
+-- [1, n), for n the group order.
+--
+-- This is secret material: its 'Show' instance is redacted, and it
+-- has no 'Eq' instance.
+newtype Seckey = Seckey BS.ByteString
+
+instance Show Seckey where
+ showsPrec d _ = showParen (d > 10) $ showString "Seckey <redacted>"
+
+instance NFData Seckey where
+ rnf (Seckey bs) = rnf bs
+
+-- | Construct a 'Seckey' from 32 big-endian bytes. Fails unless the
+-- bytes encode an integer in [1, n).
+--
+-- >>> fmap (BS.length . un_seckey) (seckey (BS.replicate 32 0x01))
+-- Just 32
+-- >>> seckey (BS.replicate 32 0x00)
+-- Nothing
+-- >>> seckey (BS.replicate 32 0xff)
+-- Nothing
+seckey :: BS.ByteString -> Maybe Seckey
+seckey bs = do
+ w <- S.parse_int256 bs
+ if S.ge w
+ then Just (Seckey bs)
+ else Nothing
+
+-- | The bytes of a 'Seckey'.
+un_seckey :: Seckey -> BS.ByteString
+un_seckey (Seckey bs) = bs
+{-# INLINE un_seckey #-}
+
+-- per-commitment secrets -----------------------------------------------------
+
+-- | The 32-byte seed from which a party generates its per-commitment
+-- secrets.
+--
+-- This is secret material: its 'Show' instance is redacted, and it
+-- has no 'Eq' instance.
+newtype Seed = Seed BS.ByteString
+
+instance Show Seed where
+ showsPrec d _ = showParen (d > 10) $ showString "Seed <redacted>"
+
+instance NFData Seed where
+ rnf (Seed bs) = rnf bs
+
+-- | Construct a 'Seed' from exactly 32 bytes.
+--
+-- >>> fmap (BS.length . un_seed) (seed (BS.replicate 32 0xff))
+-- Just 32
+-- >>> seed (BS.replicate 31 0xff)
+-- Nothing
+seed :: BS.ByteString -> Maybe Seed
+seed bs
+ | BS.length bs == 32 = Just (Seed bs)
+ | otherwise = Nothing
+{-# INLINE seed #-}
+
+-- | The bytes of a 'Seed'.
+un_seed :: Seed -> BS.ByteString
+un_seed (Seed bs) = bs
+{-# INLINE un_seed #-}
+
+-- | The 48-bit index /I/ of a per-commitment secret. Secrets are
+-- used from index 2^48 - 1 downwards.
+newtype SecretIndex = SecretIndex Word64
deriving (Eq, Ord, Show, Generic)
--- | Remote delayed pubkey.
-newtype RemoteDelayedPubkey = RemoteDelayedPubkey
- { unRemoteDelayedPubkey :: Pubkey }
+instance NFData SecretIndex
+
+-- | Construct a 'SecretIndex'. Fails at or above 2^48.
+--
+-- >>> secret_index 281474976710655
+-- Just (SecretIndex 281474976710655)
+-- >>> secret_index 281474976710656
+-- Nothing
+secret_index :: Word64 -> Maybe SecretIndex
+secret_index w
+ | w <= 0xFFFFFFFFFFFF = Just (SecretIndex w)
+ | otherwise = Nothing
+{-# INLINE secret_index #-}
+
+-- | The value of a 'SecretIndex'.
+un_secret_index :: SecretIndex -> Word64
+un_secret_index (SecretIndex w) = w
+{-# INLINE un_secret_index #-}
+
+-- | The index of the per-commitment secret for a commitment number:
+-- 2^48 - 1 - n.
+--
+-- >>> fmap commitment_secret_index (commitment_number 0)
+-- Just (SecretIndex 281474976710655)
+commitment_secret_index :: CommitmentNumber -> SecretIndex
+commitment_secret_index (CommitmentNumber n) = SecretIndex (0xFFFFFFFFFFFF - n)
+{-# INLINE commitment_secret_index #-}
+
+-- channel parameters ---------------------------------------------------------
+
+-- | A 48-bit commitment number.
+newtype CommitmentNumber = CommitmentNumber Word64
deriving (Eq, Ord, Show, Generic)
--- | Local HTLC pubkey.
-newtype LocalHtlcPubkey = LocalHtlcPubkey
- { unLocalHtlcPubkey :: Pubkey }
+instance NFData CommitmentNumber
+
+-- | Construct a 'CommitmentNumber'. Fails at or above 2^48.
+--
+-- >>> commitment_number 42
+-- Just (CommitmentNumber 42)
+-- >>> commitment_number 281474976710656
+-- Nothing
+commitment_number :: Word64 -> Maybe CommitmentNumber
+commitment_number n
+ | n <= 0xFFFFFFFFFFFF = Just (CommitmentNumber n)
+ | otherwise = Nothing
+{-# INLINE commitment_number #-}
+
+-- | The value of a 'CommitmentNumber'.
+un_commitment_number :: CommitmentNumber -> Word64
+un_commitment_number (CommitmentNumber n) = n
+{-# INLINE un_commitment_number #-}
+
+-- | The next commitment number. Fails past 2^48 - 1.
+--
+-- >>> commitment_number 0 >>= next_commitment_number
+-- Just (CommitmentNumber 1)
+-- >>> commitment_number 281474976710655 >>= next_commitment_number
+-- Nothing
+next_commitment_number :: CommitmentNumber -> Maybe CommitmentNumber
+next_commitment_number (CommitmentNumber n)
+ | n < 0xFFFFFFFFFFFF = Just (CommitmentNumber (n + 1))
+ | otherwise = Nothing
+{-# INLINE next_commitment_number #-}
+
+-- | The CSV delay (@to_self_delay@) on a commitment owner's outputs.
+newtype ToSelfDelay = ToSelfDelay Word16
deriving (Eq, Ord, Show, Generic)
--- | Remote HTLC pubkey.
-newtype RemoteHtlcPubkey = RemoteHtlcPubkey
- { unRemoteHtlcPubkey :: Pubkey }
+instance NFData ToSelfDelay
+
+-- | An HTLC's absolute CLTV expiry.
+newtype CltvExpiry = CltvExpiry Word32
deriving (Eq, Ord, Show, Generic)
--- | Revocation pubkey.
-newtype RevocationPubkey = RevocationPubkey
- { unRevocationPubkey :: Pubkey }
+instance NFData CltvExpiry
+
+-- | A @dust_limit_satoshis@ threshold.
+newtype DustLimit = DustLimit Satoshi
deriving (Eq, Ord, Show, Generic)
--- | Funding pubkey (used in 2-of-2 multisig).
-newtype FundingPubkey = FundingPubkey
- { unFundingPubkey :: Pubkey }
+instance NFData DustLimit
+
+-- | A fee rate, in satoshis per 1000 weight units.
+newtype FeeratePerKw = FeeratePerKw Word32
deriving (Eq, Ord, Show, Generic)
--- script ----------------------------------------------------------------------
+instance NFData FeeratePerKw
--- | Bitcoin script (serialized).
-newtype Script = Script { unScript :: BS.ByteString }
+-- | A transaction locktime.
+newtype Locktime = Locktime Word32
deriving (Eq, Ord, Show, Generic)
--- channel options -------------------------------------------------------------
+instance NFData Locktime
--- | Channel feature flags relevant to BOLT #3.
-data ChannelFeatures = ChannelFeatures
- { cf_option_anchors :: !Bool
- } deriving (Eq, Show, Generic)
+-- | A transaction input's sequence number.
+newtype Sequence = Sequence Word32
+ deriving (Eq, Ord, Show, Generic)
--- | Check if option_anchors is enabled.
-has_anchors :: ChannelFeatures -> Bool
-has_anchors = cf_option_anchors
-{-# INLINE has_anchors #-}
+instance NFData Sequence
+
+-- | The commitment format a channel uses, as fixed by its
+-- @channel_type@.
+data CommitmentFormat
+ = StaticRemotekey
+ -- ^ @option_static_remotekey@ without anchors: @to_remote@ is
+ -- P2WPKH and HTLC transactions pay their own fees.
+ | Anchors
+ -- ^ @option_anchors@: two anchor outputs, a CSV-locked
+ -- @to_remote@, and zero-fee HTLC transactions.
+ deriving (Eq, Ord, Show, Generic)
--- transaction weights (constants from spec) -----------------------------------
+instance NFData CommitmentFormat
--- | Base commitment tx weight without option_anchors.
-commitment_weight_no_anchors :: Word64
-commitment_weight_no_anchors = 724
+-- HTLCs ----------------------------------------------------------------------
--- | Base commitment tx weight with option_anchors.
-commitment_weight_anchors :: Word64
-commitment_weight_anchors = 1124
+-- | The direction of an HTLC, from the commitment owner's point of
+-- view.
+data HTLCDirection
+ = HTLCOffered -- ^ offered by the owner
+ | HTLCReceived -- ^ received by the owner
+ deriving (Eq, Ord, Show, Generic)
--- | HTLC-timeout tx weight without option_anchors.
-htlc_timeout_weight_no_anchors :: Word64
-htlc_timeout_weight_no_anchors = 663
+instance NFData HTLCDirection
--- | HTLC-timeout tx weight with option_anchors.
-htlc_timeout_weight_anchors :: Word64
-htlc_timeout_weight_anchors = 666
+-- | An HTLC committed to a commitment transaction.
+data HTLC = HTLC
+ { htlc_direction :: !HTLCDirection
+ , htlc_amount_msat :: {-# UNPACK #-} !MilliSatoshi
+ , htlc_payment_hash :: !PaymentHash
+ , htlc_cltv_expiry :: {-# UNPACK #-} !CltvExpiry
+ } deriving (Eq, Show, Generic)
+
+instance NFData HTLC
--- | HTLC-success tx weight without option_anchors.
-htlc_success_weight_no_anchors :: Word64
-htlc_success_weight_no_anchors = 703
+-- scripts --------------------------------------------------------------------
--- | HTLC-success tx weight with option_anchors.
-htlc_success_weight_anchors :: Word64
-htlc_success_weight_anchors = 706
+-- | A serialized Bitcoin script.
+newtype Script = Script BS.ByteString
+ deriving (Eq, Ord, Show, Generic)
--- | Weight added per HTLC output in commitment tx.
-htlc_output_weight :: Word64
-htlc_output_weight = 172
+instance NFData Script
--- dust thresholds (constants from Bitcoin Core) -------------------------------
+-- dust thresholds ------------------------------------------------------------
--- | P2PKH dust threshold (546 satoshis).
+-- | Bitcoin Core's P2PKH dust threshold (546 satoshis).
dust_p2pkh :: Satoshi
-dust_p2pkh = Satoshi 546
+dust_p2pkh = sat 546
--- | P2SH dust threshold (540 satoshis).
+-- | Bitcoin Core's P2SH dust threshold (540 satoshis).
dust_p2sh :: Satoshi
-dust_p2sh = Satoshi 540
+dust_p2sh = sat 540
--- | P2WPKH dust threshold (294 satoshis).
+-- | Bitcoin Core's P2WPKH dust threshold (294 satoshis).
dust_p2wpkh :: Satoshi
-dust_p2wpkh = Satoshi 294
+dust_p2wpkh = sat 294
--- | P2WSH dust threshold (330 satoshis).
+-- | Bitcoin Core's P2WSH dust threshold (330 satoshis).
dust_p2wsh :: Satoshi
-dust_p2wsh = Satoshi 330
+dust_p2wsh = sat 330
--- | Fixed anchor output value (330 satoshis).
+-- | The value of each anchor output (330 satoshis).
anchor_output_value :: Satoshi
-anchor_output_value = Satoshi 330
+anchor_output_value = sat 330
diff --git a/lib/Lightning/Protocol/BOLT3/Validate.hs b/lib/Lightning/Protocol/BOLT3/Validate.hs
@@ -1,359 +0,0 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveGeneric #-}
-
--- |
--- Module: Lightning.Protocol.BOLT3.Validate
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Stateless validation for BOLT #3 transactions.
---
--- Provides validation for:
---
--- * Commitment transaction structure and outputs
--- * HTLC transaction structure
--- * Closing transaction structure
--- * Output ordering per BIP69+CLTV
--- * Dust limit compliance
-
-module Lightning.Protocol.BOLT3.Validate (
- -- * Validation errors
- ValidationError(..)
-
- -- * Commitment transaction validation
- , validate_commitment_tx
- , validate_commitment_locktime
- , validate_commitment_sequence
-
- -- * HTLC transaction validation
- , validate_htlc_tx
- , validate_htlc_timeout_tx
- , validate_htlc_success_tx
-
- -- * Closing transaction validation
- , validate_closing_tx
- , validate_legacy_closing_tx
-
- -- * Output validation
- , validate_output_ordering
- , validate_dust_limits
- , validate_anchor_outputs
-
- -- * Fee validation
- , validate_commitment_fee
- , validate_htlc_fee
- ) where
-
-import Data.Bits ((.&.), shiftR)
-import Data.Word (Word32, Word64)
-import GHC.Generics (Generic)
-import Lightning.Protocol.BOLT3.Types
-import Lightning.Protocol.BOLT3.Tx
-
--- validation errors -----------------------------------------------------------
-
--- | Errors that can occur during validation.
-data ValidationError
- = InvalidVersion {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
- -- ^ Expected version, actual version
- | InvalidLocktime {-# UNPACK #-} !Word32
- -- ^ Invalid locktime format
- | InvalidSequence {-# UNPACK #-} !Word32
- -- ^ Invalid sequence format
- | InvalidOutputOrdering
- -- ^ Outputs not in BIP69+CLTV order
- | DustLimitViolation {-# UNPACK #-} !Int !Satoshi !Satoshi
- -- ^ Output index, actual value, dust limit
- | MissingAnchorOutput
- -- ^ Expected anchor output not present
- | InvalidAnchorValue {-# UNPACK #-} !Satoshi
- -- ^ Anchor value not 330 satoshis
- | InvalidFee {-# UNPACK #-} !Satoshi {-# UNPACK #-} !Satoshi
- -- ^ Expected fee, actual fee
- | InvalidHTLCLocktime {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
- -- ^ Expected locktime, actual locktime
- | InvalidHTLCSequence {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
- -- ^ Expected sequence, actual sequence
- | NoOutputs
- -- ^ Transaction has no outputs
- | TooManyOutputs {-# UNPACK #-} !Int
- -- ^ More outputs than expected
- deriving (Eq, Show, Generic)
-
--- commitment transaction validation -------------------------------------------
-
--- | Validate a commitment transaction.
---
--- Checks:
---
--- * Version is 2
--- * Locktime format (upper 8 bits = 0x20)
--- * Sequence format (upper 8 bits = 0x80)
--- * Output ordering per BIP69+CLTV
--- * Dust limit compliance
--- * Anchor outputs if option_anchors
-validate_commitment_tx
- :: DustLimit
- -> ChannelFeatures
- -> CommitmentTx
- -> Either ValidationError ()
-validate_commitment_tx dust features tx = do
- -- Version must be 2
- validateVersion 2 (ctx_version tx)
- -- Locktime format
- validate_commitment_locktime (ctx_locktime tx)
- -- Sequence format
- validate_commitment_sequence (ctx_input_sequence tx)
- -- Output ordering
- validate_output_ordering (ctx_outputs tx)
- -- Dust limits
- validate_dust_limits dust (ctx_outputs tx)
- -- Anchors if applicable
- if has_anchors features
- then validate_anchor_outputs (ctx_outputs tx)
- else pure ()
-{-# INLINE validate_commitment_tx #-}
-
--- | Validate commitment transaction locktime format.
---
--- Upper 8 bits must be 0x20.
-validate_commitment_locktime :: Locktime -> Either ValidationError ()
-validate_commitment_locktime (Locktime lt) =
- let !upper = (lt `shiftR` 24) .&. 0xFF
- in if upper == 0x20
- then Right ()
- else Left (InvalidLocktime lt)
-{-# INLINE validate_commitment_locktime #-}
-
--- | Validate commitment transaction sequence format.
---
--- Upper 8 bits must be 0x80.
-validate_commitment_sequence :: Sequence -> Either ValidationError ()
-validate_commitment_sequence (Sequence sq) =
- let !upper = (sq `shiftR` 24) .&. 0xFF
- in if upper == 0x80
- then Right ()
- else Left (InvalidSequence sq)
-{-# INLINE validate_commitment_sequence #-}
-
--- HTLC transaction validation -------------------------------------------------
-
--- | Validate an HTLC transaction (timeout or success).
---
--- Checks:
---
--- * Version is 2
--- * Single output
-validate_htlc_tx :: HTLCTx -> Either ValidationError ()
-validate_htlc_tx tx = do
- validateVersion 2 (htx_version tx)
- pure ()
-{-# INLINE validate_htlc_tx #-}
-
--- | Validate an HTLC-timeout transaction.
---
--- Checks:
---
--- * Base HTLC validation
--- * Locktime equals HTLC cltv_expiry
--- * Sequence is 0 (or 1 with option_anchors)
-validate_htlc_timeout_tx
- :: ChannelFeatures
- -> CltvExpiry
- -> HTLCTx
- -> Either ValidationError ()
-validate_htlc_timeout_tx features expiry tx = do
- validate_htlc_tx tx
- -- Locktime must be cltv_expiry
- let !expectedLt = unCltvExpiry expiry
- !actualLt = unLocktime (htx_locktime tx)
- if expectedLt == actualLt
- then pure ()
- else Left (InvalidHTLCLocktime expectedLt actualLt)
- -- Sequence
- let !expectedSeq = if has_anchors features then 1 else 0
- !actualSeq = unSequence (htx_input_sequence tx)
- if expectedSeq == actualSeq
- then pure ()
- else Left (InvalidHTLCSequence expectedSeq actualSeq)
-{-# INLINE validate_htlc_timeout_tx #-}
-
--- | Validate an HTLC-success transaction.
---
--- Checks:
---
--- * Base HTLC validation
--- * Locktime is 0
--- * Sequence is 0 (or 1 with option_anchors)
-validate_htlc_success_tx
- :: ChannelFeatures
- -> HTLCTx
- -> Either ValidationError ()
-validate_htlc_success_tx features tx = do
- validate_htlc_tx tx
- -- Locktime must be 0
- let !actualLt = unLocktime (htx_locktime tx)
- if actualLt == 0
- then pure ()
- else Left (InvalidHTLCLocktime 0 actualLt)
- -- Sequence
- let !expectedSeq = if has_anchors features then 1 else 0
- !actualSeq = unSequence (htx_input_sequence tx)
- if expectedSeq == actualSeq
- then pure ()
- else Left (InvalidHTLCSequence expectedSeq actualSeq)
-{-# INLINE validate_htlc_success_tx #-}
-
--- closing transaction validation ----------------------------------------------
-
--- | Validate a closing transaction (option_simple_close).
---
--- Checks:
---
--- * Version is 2
--- * Sequence is 0xFFFFFFFD
--- * At least one output
--- * Output ordering per BIP69
-validate_closing_tx :: ClosingTx -> Either ValidationError ()
-validate_closing_tx tx = do
- validateVersion 2 (cltx_version tx)
- let !actualSeq = unSequence (cltx_input_sequence tx)
- if actualSeq == 0xFFFFFFFD
- then pure ()
- else Left (InvalidSequence actualSeq)
- validateOutputCount (cltx_outputs tx)
- validate_output_ordering (cltx_outputs tx)
-{-# INLINE validate_closing_tx #-}
-
--- | Validate a legacy closing transaction (closing_signed).
---
--- Checks:
---
--- * Version is 2
--- * Locktime is 0
--- * Sequence is 0xFFFFFFFF
--- * At least one output
--- * Output ordering per BIP69
-validate_legacy_closing_tx :: ClosingTx -> Either ValidationError ()
-validate_legacy_closing_tx tx = do
- validateVersion 2 (cltx_version tx)
- let !actualLt = unLocktime (cltx_locktime tx)
- if actualLt == 0
- then pure ()
- else Left (InvalidLocktime actualLt)
- let !actualSeq = unSequence (cltx_input_sequence tx)
- if actualSeq == 0xFFFFFFFF
- then pure ()
- else Left (InvalidSequence actualSeq)
- validateOutputCount (cltx_outputs tx)
- validate_output_ordering (cltx_outputs tx)
-{-# INLINE validate_legacy_closing_tx #-}
-
--- output validation -----------------------------------------------------------
-
--- | Validate output ordering per BIP69+CLTV.
---
--- Outputs must be sorted by:
--- 1. Value (smallest first)
--- 2. ScriptPubKey (lexicographic)
--- 3. CLTV expiry (for HTLC outputs)
-validate_output_ordering :: [TxOutput] -> Either ValidationError ()
-validate_output_ordering outputs =
- let !sorted = sort_outputs outputs
- in if outputs == sorted
- then Right ()
- else Left InvalidOutputOrdering
-{-# INLINE validate_output_ordering #-}
-
--- | Validate that no output violates dust limits.
-validate_dust_limits
- :: DustLimit
- -> [TxOutput]
- -> Either ValidationError ()
-validate_dust_limits dust = go 0 where
- !limit = unDustLimit dust
- go !_ [] = Right ()
- go !idx (out:rest) =
- let !val = txout_value out
- in case txout_type out of
- -- Anchors have fixed value, don't check against dust limit
- OutputLocalAnchor -> go (idx + 1) rest
- OutputRemoteAnchor -> go (idx + 1) rest
- -- All other outputs must be above dust
- _ -> if unSatoshi val >= unSatoshi limit
- then go (idx + 1) rest
- else Left (DustLimitViolation idx val limit)
-{-# INLINE validate_dust_limits #-}
-
--- | Validate anchor outputs are present and correctly valued.
-validate_anchor_outputs :: [TxOutput] -> Either ValidationError ()
-validate_anchor_outputs outputs =
- let !anchors = filter isAnchor outputs
- in if null anchors
- then Left MissingAnchorOutput
- else validateAnchorValues anchors
- where
- isAnchor out = case txout_type out of
- OutputLocalAnchor -> True
- OutputRemoteAnchor -> True
- _ -> False
-
- validateAnchorValues [] = Right ()
- validateAnchorValues (a:as) =
- let !val = txout_value a
- in if val == anchor_output_value
- then validateAnchorValues as
- else Left (InvalidAnchorValue val)
-{-# INLINE validate_anchor_outputs #-}
-
--- fee validation --------------------------------------------------------------
-
--- | Validate commitment transaction fee.
---
--- Checks that the fee matches the expected calculation.
-validate_commitment_fee
- :: FeeratePerKw
- -> ChannelFeatures
- -> Word64 -- ^ Number of untrimmed HTLCs
- -> Satoshi -- ^ Actual fee
- -> Either ValidationError ()
-validate_commitment_fee feerate features numHtlcs actualFee =
- let !expectedFee = commitment_fee feerate features numHtlcs
- in if actualFee == expectedFee
- then Right ()
- else Left (InvalidFee expectedFee actualFee)
-{-# INLINE validate_commitment_fee #-}
-
--- | Validate HTLC transaction fee.
-validate_htlc_fee
- :: FeeratePerKw
- -> ChannelFeatures
- -> HTLCDirection
- -> Satoshi -- ^ Actual fee
- -> Either ValidationError ()
-validate_htlc_fee feerate features direction actualFee =
- let !expectedFee = case direction of
- HTLCOffered -> htlc_timeout_fee feerate features
- HTLCReceived -> htlc_success_fee feerate features
- in if actualFee == expectedFee
- then Right ()
- else Left (InvalidFee expectedFee actualFee)
-{-# INLINE validate_htlc_fee #-}
-
--- helpers ---------------------------------------------------------------------
-
--- | Validate transaction version.
-validateVersion :: Word32 -> Word32 -> Either ValidationError ()
-validateVersion expected actual =
- if expected == actual
- then Right ()
- else Left (InvalidVersion expected actual)
-{-# INLINE validateVersion #-}
-
--- | Validate that transaction has at least one output.
-validateOutputCount :: [TxOutput] -> Either ValidationError ()
-validateOutputCount [] = Left NoOutputs
-validateOutputCount _ = Right ()
-{-# INLINE validateOutputCount #-}
diff --git a/ppad-bolt3.cabal b/ppad-bolt3.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ppad-bolt3
-version: 0.0.1
+version: 0.1.0
synopsis: Bitcoin transaction formats per BOLT #3
license: MIT
license-file: LICENSE
@@ -8,10 +8,10 @@ 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:
- Bitcoin transaction formats for the Lightning Network, per
+ Bitcoin transaction and script formats for the Lightning Network, per
[BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md).
source-repository head
@@ -25,22 +25,20 @@ library
-Wall
exposed-modules:
Lightning.Protocol.BOLT3
- Lightning.Protocol.BOLT3.Decode
- Lightning.Protocol.BOLT3.Encode
- Lightning.Protocol.BOLT3.Internal
+ other-modules:
Lightning.Protocol.BOLT3.Keys
Lightning.Protocol.BOLT3.Scripts
Lightning.Protocol.BOLT3.Tx
Lightning.Protocol.BOLT3.Types
- Lightning.Protocol.BOLT3.Validate
build-depends:
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
- , ppad-bolt1 >= 0.0.1 && < 0.1
+ , deepseq >= 1.4 && < 1.6
+ , ppad-bolt1 >= 0.1 && < 0.2
, ppad-ripemd160 >= 0.1.4 && < 0.2
- , ppad-secp256k1 >= 0.5.4 && < 0.6
+ , ppad-secp256k1 >= 0.5.7 && < 0.6
, ppad-sha256 >= 0.3.2 && < 0.4
- , ppad-tx >= 0.1 && < 0.2
+ , ppad-tx >= 0.2 && < 0.3
test-suite bolt3-tests
type: exitcode-stdio-1.0
@@ -51,14 +49,15 @@ test-suite bolt3-tests
Vectors
ghc-options:
- -rtsopts -Wall -O2
+ -rtsopts -Wall
build-depends:
base
, bytestring
, ppad-base16
+ , ppad-bolt1
, ppad-bolt3
- , ppad-secp256k1 >= 0.5.4 && < 0.6
+ , ppad-secp256k1
, ppad-sha256
, ppad-tx
, QuickCheck
@@ -71,32 +70,41 @@ benchmark bolt3-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-base16
+ , ppad-bolt1
, ppad-bolt3
- , ppad-secp256k1 >= 0.5.4 && < 0.6
+ , ppad-secp256k1
+ , ppad-sha256
+ , ppad-tx
benchmark bolt3-weigh
type: exitcode-stdio-1.0
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-base16
+ , ppad-bolt1
, ppad-bolt3
- , ppad-secp256k1 >= 0.5.4 && < 0.6
+ , ppad-secp256k1
+ , ppad-sha256
+ , ppad-tx
, weigh
-
diff --git a/test/Main.hs b/test/Main.hs
@@ -3,66 +3,49 @@
module Main where
import qualified Bitcoin.Prim.Tx as BT
-import Control.Monad (foldM)
+import qualified Bitcoin.Prim.Tx.Sighash as Sighash
+import Control.Monad (foldM, forM_)
import qualified Crypto.Curve.Secp256k1 as S
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 Data.List.NonEmpty as NE
import Data.Maybe (isJust, isNothing)
-import Data.Word (Word32, Word64)
+import Data.Word (Word8, Word64)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT3
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
-import Lightning.Protocol.BOLT3
-import Lightning.Protocol.BOLT3.Types
- ( Pubkey(..), Point(..)
- , PaymentHash(..), PerCommitmentPoint(..)
- , PerCommitmentSecret(..)
- )
import Vectors
--- Module-level wNAF context. Built once; reused across every
--- equivalence test below. Mirrors how downstream callers should use
--- it.
+-- Shared wNAF context.
tex :: S.Context
tex = S.precompute
{-# NOINLINE tex #-}
main :: IO ()
main = defaultMain $ testGroup "ppad-bolt3" [
- testGroup "Key derivation" [
- keyDerivationTests
- ]
- , testGroup "Secret generation" [
- secretGenerationTests
- ]
- , testGroup "Secret storage" [
- secretStorageTests
- ]
- , testGroup "Funding transaction" [
- fundingTests
- ]
- , testGroup "Commitment and HTLC transactions" [
- testGroup "BOLT #3 Appendix C" $
- fmap (commitVectorTests False) appendix_c
- , testGroup "BOLT #3 Appendix F (anchors)" $
- fmap (commitVectorTests True) appendix_f
- ]
- , testGroup "Fee calculation" [
- feeCalculationTests
- ]
- , testGroup "Trimming" [
- trimmingTests
- ]
- , testGroup "Smart constructors" [
- smartConstructorTests
- ]
- , testGroup "Properties" [
- propertyTests
- ]
+ keyTests
+ , secretGenerationTests
+ , secretStorageTests
+ , fundingTests
+ , testGroup "Commitment and HTLC transactions (Appendix C)" $
+ fmap (commitVectorTests StaticRemotekey) appendix_c
+ , testGroup "Commitment and HTLC transactions (Appendix F)" $
+ fmap (commitVectorTests Anchors) appendix_f
+ , commitmentTests
+ , htlcTxTests
+ , closingTests
+ , scriptTests
+ , feeTests
+ , constructorTests
+ , propertyTests
]
+-- helpers --------------------------------------------------------------------
+
-- | Decode a hex literal, failing the enclosing test on bad input.
hex :: BS.ByteString -> IO BS.ByteString
hex h = case B16.decode h of
@@ -73,154 +56,275 @@ hex h = case B16.decode h of
need :: String -> Maybe a -> IO a
need msg = maybe (assertFailure msg) pure
--- Key derivation test vectors from Appendix E ---------------------------------
-
-keyDerivationTests :: TestTree
-keyDerivationTests = testGroup "BOLT #3 Appendix E" [
- testCase "derive_pubkey" $ do
- basepoint <- Point <$> hex
- "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"
- perCommitmentPoint <- PerCommitmentPoint . Point <$> hex
- "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
+pt :: BS.ByteString -> IO BOLT1.Point
+pt h = hex h >>= need ("invalid point " ++ show h) . BOLT1.point
+
+sat :: Word64 -> IO BOLT1.Satoshi
+sat = need "invalid satoshi amount" . BOLT1.satoshi
+
+msat :: Word64 -> IO BOLT1.MilliSatoshi
+msat = need "invalid millisatoshi amount" . BOLT1.milli_satoshi
+
+sk :: BS.ByteString -> IO Seckey
+sk h = hex h >>= need ("invalid secret key " ++ show h) . seckey
+
+pcsecret :: BS.ByteString -> IO BOLT1.PerCommitmentSecret
+pcsecret h = hex h >>= need "invalid secret" . BOLT1.per_commitment_secret
+
+idx :: Word64 -> IO SecretIndex
+idx = need "invalid secret index" . secret_index
+
+unpoint :: BOLT1.Point -> BS.ByteString
+unpoint = BOLT1.un_point
+
+unsecret :: BOLT1.PerCommitmentSecret -> BS.ByteString
+unsecret = BOLT1.un_per_commitment_secret
+
+-- | The compressed public key of a secret key.
+pubkey_of :: Seckey -> Maybe BS.ByteString
+pubkey_of k = do
+ w <- S.parse_int256 (un_seckey k)
+ S.serialize_point <$> S.derive_pub w
+
+-- Appendix E, and the internal values of Appendix C --------------------------
+
+e_base_secret, e_per_commitment_secret, e_base_point,
+ e_per_commitment_point :: BS.ByteString
+e_base_secret =
+ "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f"
+e_per_commitment_secret =
+ "1f1e1d1c1b1a191817161514131211100f0e0d0c0b0a09080706050403020100"
+e_base_point =
+ "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"
+e_per_commitment_point =
+ "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
+
+-- | Appendix C's (commented) derivation inputs.
+c_local_delayed_payment_basepoint_secret, c_local_delayed_payment_basepoint,
+ c_remote_revocation_basepoint, c_local_per_commitment_point,
+ c_local_delayed_privkey :: BS.ByteString
+c_local_delayed_payment_basepoint_secret =
+ "3333333333333333333333333333333333333333333333333333333333333333"
+c_local_delayed_payment_basepoint =
+ "023c72addb4fdf09af94f0c94d7fe92a386a7e70cf8a1d85916386bb2535c7b1b1"
+c_remote_revocation_basepoint =
+ "02466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27"
+c_local_per_commitment_point =
+ "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
+c_local_delayed_privkey =
+ "adf3464ce9c2f230fd2582fda4c6965e4993ca5524e8c9580e3df0cf226981ad"
+
+keyTests :: TestTree
+keyTests = testGroup "Key derivation (Appendix E)" [
+ testCase "per_commitment_point from per_commitment_secret" $ do
+ s <- pcsecret e_per_commitment_secret
+ expected <- hex e_per_commitment_point
+ PerCommitmentPoint p <- need "derive_per_commitment_point"
+ (derive_per_commitment_point s)
+ unpoint p @?= expected
+ PerCommitmentPoint p' <- need "derive_per_commitment_point'"
+ (derive_per_commitment_point' tex s)
+ unpoint p' @?= expected
+
+ , testCase "localpubkey from basepoint and per_commitment_point" $ do
+ bp <- pt e_base_point
+ pcp <- PerCommitmentPoint <$> pt e_per_commitment_point
expected <- hex
"0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"
- case derive_pubkey basepoint perCommitmentPoint of
- Nothing -> assertFailure "derive_pubkey returned Nothing"
- Just (Pubkey pk) -> pk @?= expected
-
- , testCase "derive_pubkey' matches vector" $ do
- basepoint <- Point <$> hex
- "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"
- perCommitmentPoint <- PerCommitmentPoint . Point <$> hex
- "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
+ fmap unpoint (derive_pubkey bp pcp) @?= Just expected
+
+ , testCase "localprivkey from basepoint secret" $ do
+ bs <- sk e_base_secret
+ pcp <- PerCommitmentPoint <$> pt e_per_commitment_point
expected <- hex
- "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"
- case derive_pubkey' tex basepoint perCommitmentPoint of
- Nothing -> assertFailure "derive_pubkey' returned Nothing"
- Just (Pubkey pk) -> pk @?= expected
-
- , testCase "derive_revocationpubkey" $ do
- revocationBasepoint <- RevocationBasepoint . Point <$> hex
- "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"
- perCommitmentPoint <- PerCommitmentPoint . Point <$> hex
- "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
+ "cbced912d3b21bf196a766651e436aff192362621ce317704ea2f75d87e7be0f"
+ fmap un_seckey (derive_privkey bs pcp) @?= Just expected
+
+ , testCase "revocationpubkey from basepoint and per_commitment_point" $ do
+ rbp <- RevocationBasepoint <$> pt e_base_point
+ pcp <- PerCommitmentPoint <$> pt e_per_commitment_point
expected <- hex
"02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0"
- case derive_revocationpubkey revocationBasepoint perCommitmentPoint of
- Nothing -> assertFailure "derive_revocationpubkey returned Nothing"
- Just (RevocationPubkey (Pubkey pk)) -> pk @?= expected
+ fmap (\(RevocationPubkey p) -> unpoint p)
+ (derive_revocationpubkey rbp pcp) @?= Just expected
- , testCase "derive_per_commitment_point" $ do
- secret <- PerCommitmentSecret <$> hex
- "1f1e1d1c1b1a191817161514131211100f0e0d0c0b0a09080706050403020100"
+ , testCase "revocationprivkey from secrets" $ do
+ rbs <- sk e_base_secret
+ pcs <- pcsecret e_per_commitment_secret
expected <- hex
- "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
- PerCommitmentPoint (Point pcp) <-
- need "derive_per_commitment_point returned Nothing"
- (derive_per_commitment_point secret)
- pcp @?= expected
-
- , testCase "derive_per_commitment_point' matches vector" $ do
- secret <- PerCommitmentSecret <$> hex
- "1f1e1d1c1b1a191817161514131211100f0e0d0c0b0a09080706050403020100"
- expected <- hex
- "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"
- PerCommitmentPoint (Point pcp) <-
- need "derive_per_commitment_point' returned Nothing"
- (derive_per_commitment_point' tex secret)
- pcp @?= expected
- ]
+ "d09ffff62ddb2297ab000cc85bcb4283fdeb6aa052affbc9dddcf33b61078110"
+ fmap un_seckey (derive_revocationprivkey rbs pcs) @?= Just expected
+
+ , testCase "Appendix C local_delayed_privkey" $ do
+ bs <- sk c_local_delayed_payment_basepoint_secret
+ pcp <- PerCommitmentPoint <$> pt c_local_per_commitment_point
+ expected <- hex c_local_delayed_privkey
+ fmap un_seckey (derive_privkey bs pcp) @?= Just expected
+ -- whose public key is Appendix C's local_delayedpubkey
+ expected_pub <- hex c_local_delayedpubkey
+ (pubkey_of =<< derive_privkey bs pcp) @?= Just expected_pub
+
+ , testCase "Appendix C commitment keys from basepoints" $ do
+ keys <- vectorKeys
+ pcp <- PerCommitmentPoint <$> pt c_local_per_commitment_point
+ local_bp <- pt c_local_payment_basepoint
+ remote_bp <- pt c_remote_payment_basepoint
+ local_delayed_bp <- pt c_local_delayed_payment_basepoint
+ remote_rev_bp <- pt c_remote_revocation_basepoint
+ let local = Basepoints
+ { bp_revocation = RevocationBasepoint local_bp
+ , bp_payment = PaymentBasepoint local_bp
+ , bp_delayed_payment =
+ DelayedPaymentBasepoint local_delayed_bp
+ , bp_htlc = HtlcBasepoint local_bp
+ }
+ remote = Basepoints
+ { bp_revocation = RevocationBasepoint remote_rev_bp
+ , bp_payment = PaymentBasepoint remote_bp
+ , bp_delayed_payment = DelayedPaymentBasepoint remote_bp
+ , bp_htlc = HtlcBasepoint remote_bp
+ }
+ derived = derive_commitment_keys local (ck_local_funding keys)
+ remote (ck_remote_funding keys) pcp
+ derived @?= Just keys
+ derive_commitment_keys' tex local (ck_local_funding keys)
+ remote (ck_remote_funding keys) pcp @?= Just keys
+
+ , testCase "rejects a basepoint off the curve" $ do
+ bad <- pt
+ "020000000000000000000000000000000000000000000000000000000000000000"
+ pcp <- PerCommitmentPoint <$> pt e_per_commitment_point
+ isNothing (derive_pubkey bad pcp) @?= True
+ isNothing (derive_revocationpubkey (RevocationBasepoint bad) pcp)
+ @?= True
--- Secret generation test vectors from Appendix D ------------------------------
+ , testCase "rejects a per_commitment_point off the curve" $ do
+ rbp <- RevocationBasepoint <$> pt e_base_point
+ bad <- PerCommitmentPoint <$> pt
+ "020000000000000000000000000000000000000000000000000000000000000000"
+ isNothing (derive_revocationpubkey rbp bad) @?= True
-secretGenerationTests :: TestTree
-secretGenerationTests = testGroup "BOLT #3 Appendix D - Generation" [
- testCase "generate_from_seed 0 final node" $ do
- seed <- hex
+ , testCase "rejects an invalid per_commitment_secret" $ do
+ zero <- pcsecret
"0000000000000000000000000000000000000000000000000000000000000000"
- expected <- hex
- "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148"
- let i = 281474976710655
- generate_from_seed seed i @?= expected
-
- , testCase "generate_from_seed FF final node" $ do
- seed <- hex
- "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"
- expected <- hex
- "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"
- let i = 281474976710655
- generate_from_seed seed i @?= expected
+ big <- pcsecret
+ "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"
+ rbs <- sk e_base_secret
+ isNothing (derive_per_commitment_point zero) @?= True
+ isNothing (derive_per_commitment_point big) @?= True
+ isNothing (derive_per_commitment_point' tex big) @?= True
+ isNothing (derive_revocationprivkey rbs zero) @?= True
+ isNothing (derive_revocationprivkey rbs big) @?= True
+ ]
- , testCase "generate_from_seed FF alternate bits 1" $ do
- seed <- hex
- "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"
- expected <- hex
- "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528"
- let i = 0xaaaaaaaaaaa
- generate_from_seed seed i @?= expected
+-- Appendix D: generation -----------------------------------------------------
- , testCase "generate_from_seed FF alternate bits 2" $ do
- seed <- hex
- "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"
- expected <- hex
- "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31"
- let i = 0x555555555555
- generate_from_seed seed i @?= expected
-
- , testCase "generate_from_seed 01 last nontrivial node" $ do
- seed <- hex
- "0101010101010101010101010101010101010101010101010101010101010101"
- expected <- hex
- "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c"
- let i = 1
- generate_from_seed seed i @?= expected
+secretGenerationTests :: TestTree
+secretGenerationTests = testGroup "Secret generation (Appendix D)" [
+ gen "generate_from_seed 0 final node"
+ "0000000000000000000000000000000000000000000000000000000000000000"
+ 281474976710655
+ "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148"
+ , gen "generate_from_seed FF final node"
+ "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"
+ 281474976710655
+ "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"
+ , gen "generate_from_seed FF alternate bits 1"
+ "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"
+ 0xaaaaaaaaaaa
+ "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528"
+ , gen "generate_from_seed FF alternate bits 2"
+ "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"
+ 0x555555555555
+ "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31"
+ , gen "generate_from_seed 01 last nontrivial node"
+ "0101010101010101010101010101010101010101010101010101010101010101"
+ 1
+ "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c"
+ , testCase "commitment_secret_index" $ do
+ cn <- need "commitment_number" (commitment_number 42)
+ un_secret_index (commitment_secret_index cn) @?= 0xFFFFFFFFFFFF - 42
]
+ where
+ gen name s i expected = testCase name $ do
+ sd <- hex s >>= need "seed" . seed
+ ix <- idx i
+ e <- hex expected
+ unsecret (generate_from_seed sd ix) @?= e
--- Secret storage test vectors from Appendix D ---------------------------------
+-- Appendix D: storage --------------------------------------------------------
secretStorageTests :: TestTree
-secretStorageTests = testGroup "BOLT #3 Appendix D - Storage" $
+secretStorageTests = testGroup "Secret storage (Appendix D)" $
fmap storageVectorTest appendix_d_storage
++ [
testCase "derive_old_secret after each correct insert" $ do
- steps <- case filter isCorrect appendix_d_storage of
- (v : _) -> pure (sv_steps v)
- [] -> assertFailure "missing correct sequence vector"
- known <- traverse (\st -> (,) (ss_index st) <$> hex (ss_secret st))
- steps
- -- after each insert, every index inserted so far is derivable
- let step (store, seen) (i, sec) = do
- store' <- case insert_secret sec i store of
- Just st -> pure st
- Nothing -> assertFailure
- ("rejected correct secret at I=" ++ show i)
- let seen' = (i, sec) : seen
- mapM_ (\(j, s) ->
- assertEqual
- ("after I=" ++ show i ++ ", derive_old_secret "
- ++ show j)
- (Just s) (derive_old_secret j store'))
- seen'
+ known <- correctSequence
+ let step (store, seen) (i, s) = do
+ store' <- need ("rejected correct secret at I=" ++ show i)
+ (insert_secret s i store)
+ let seen' = (i, s) : seen
+ forM_ seen' $ \(j, t) ->
+ assertEqual
+ ("after I=" ++ show i ++ ", derive_old_secret " ++ show j)
+ (Just (unsecret t))
+ (fmap unsecret (derive_old_secret j store'))
pure (store', seen')
- (store, _) <- foldM step (empty_store, []) known
+ (store, _) <- foldM step (empty_secret_store, []) known
-- the next index has not been received
- assertEqual "derive_old_secret of unreceived index"
- Nothing (derive_old_secret 281474976710647 store)
-
- , testCase "insert_secret rejects 31-byte secret" $
- isNothing (insert_secret (BS.replicate 31 0) maxCommitNum empty_store)
- @?= True
- , testCase "insert_secret rejects 33-byte secret" $
- isNothing (insert_secret (BS.replicate 33 0) maxCommitNum empty_store)
- @?= True
- , testCase "insert_secret rejects index 2^48" $
- isNothing
- (insert_secret (BS.replicate 32 0) (maxCommitNum + 1) empty_store)
- @?= True
- , testCase "insert_secret accepts index 2^48-1" $
- isJust (insert_secret (BS.replicate 32 0) maxCommitNum empty_store)
- @?= True
+ next <- idx 281474976710647
+ isNothing (derive_old_secret next store) @?= True
+
+ , testCase "un_secret_store/secret_store round trip" $ do
+ known <- correctSequence
+ store <- need "insert" (foldM (\st (i, s) -> insert_secret s i st)
+ empty_secret_store known)
+ store' <- need "secret_store" (secret_store (un_secret_store store))
+ forM_ known $ \(i, s) ->
+ fmap unsecret (derive_old_secret i store') @?= Just (unsecret s)
+ -- entry order doesn't matter
+ store'' <- need "secret_store (reversed)"
+ (secret_store (reverse (un_secret_store store)))
+ forM_ known $ \(i, s) ->
+ fmap unsecret (derive_old_secret i store'') @?= Just (unsecret s)
+
+ , testCase "secret_store rejects a repeated bucket" $ do
+ known <- correctSequence
+ case known of
+ ((i0, s0) : _ : (i2, s2) : _) ->
+ -- indices 2^48-1 and 2^48-3 both have no trailing zeros
+ isNothing (secret_store [(i0, s0), (i2, s2)]) @?= True
+ _ -> assertFailure "short sequence"
+
+ , testCase "secret_store rejects contradictory entries" $ do
+ known <- correctSequence
+ bad <- pcsecret
+ "0000000000000000000000000000000000000000000000000000000000000000"
+ case known of
+ ((i0, _) : (i1, s1) : _) ->
+ -- index 2^48-1 is derivable from index 2^48-2
+ isNothing (secret_store [(i0, bad), (i1, s1)]) @?= True
+ _ -> assertFailure "short sequence"
+
+ , testCase "Show is redacted" $ do
+ known <- correctSequence
+ store <- need "insert" (foldM (\st (i, s) -> insert_secret s i st)
+ empty_secret_store known)
+ show store @?= "SecretStore <redacted>"
+ sd <- need "seed" (seed (BS.replicate 32 0xff))
+ show sd @?= "Seed <redacted>"
+ k <- sk e_base_secret
+ show k @?= "Seckey <redacted>"
]
+
+-- | The spec's correct storage sequence, as (index, secret) pairs.
+correctSequence :: IO [(SecretIndex, BOLT1.PerCommitmentSecret)]
+correctSequence = do
+ steps <- case filter isCorrect appendix_d_storage of
+ (v : _) -> pure (sv_steps v)
+ [] -> assertFailure "missing correct sequence vector"
+ traverse (\st -> (,) <$> idx (ss_index st) <*> pcsecret (ss_secret st))
+ steps
where
isCorrect v = sv_name v == "insert_secret correct sequence"
@@ -228,12 +332,13 @@ secretStorageTests = testGroup "BOLT #3 Appendix D - Storage" $
-- accepted or rejected exactly as the spec says.
storageVectorTest :: StorageVector -> TestTree
storageVectorTest (StorageVector name steps) =
- testCase name (go empty_store steps)
+ testCase name (go empty_secret_store steps)
where
go _ [] = pure ()
go store (StorageStep i ok s : rest) = do
- sec <- hex s
- case (insert_secret sec i store, ok) of
+ sec <- pcsecret s
+ ix <- idx i
+ case (insert_secret sec ix store, ok) of
(Just store', True) -> go store' rest
(Nothing, False) -> go store rest
(Just _, False) ->
@@ -241,542 +346,677 @@ storageVectorTest (StorageVector name steps) =
(Nothing, True) ->
assertFailure ("rejected correct secret at I=" ++ show i)
--- Funding transaction test vectors from Appendix B ----------------------------
+-- Appendix B -----------------------------------------------------------------
fundingTests :: TestTree
-fundingTests = testGroup "BOLT #3 Appendix B" [
+fundingTests = testGroup "Funding transaction (Appendix B)" [
testCase "funding witness script" $ do
(lpk, rpk) <- fundingPubkeys
wscript <- hex b_funding_wscript
- unScript (funding_script lpk rpk) @?= wscript
- unScript (funding_script rpk lpk) @?= wscript
+ funding_script lpk rpk @?= Script wscript
+ funding_script rpk lpk @?= Script wscript
, testCase "funding output" $ do
(lpk, rpk) <- fundingPubkeys
tx <- hex b_funding_tx >>= decodeTx
txid <- hex b_funding_txid
- BT.txid tx @?= TxId (BS.reverse txid)
+ BT.txid tx @?= BT.TxId (BS.reverse txid)
case drop (fromIntegral b_funding_output) (NE.toList (BT.tx_outputs tx))
of
(BT.TxOut value spk : _) -> do
value @?= b_funding_satoshis
- spk @?= unScript (to_p2wsh (funding_script lpk rpk))
+ Script spk @?= to_p2wsh (funding_script lpk rpk)
[] -> assertFailure "missing funding output"
]
where
fundingPubkeys = do
- lpk <- FundingPubkey . Pubkey <$> hex b_local_funding_pubkey
- rpk <- FundingPubkey . Pubkey <$> hex b_remote_funding_pubkey
+ lpk <- FundingPubkey <$> pt b_local_funding_pubkey
+ rpk <- FundingPubkey <$> pt b_remote_funding_pubkey
pure (lpk, rpk)
--- Commitment and HTLC transaction test vectors from Appendices C and F --------
+-- Appendices C and F ---------------------------------------------------------
-- | Decode a serialized transaction, failing the test on bad input.
decodeTx :: BS.ByteString -> IO BT.Tx
decodeTx = need "undecodable transaction" . BT.from_bytes
--- | Decode a hex transaction from the spec and strip its witnesses,
--- giving the unsigned serialization that the builders produce.
-unsignedTx :: BS.ByteString -> IO BS.ByteString
-unsignedTx h = BT.to_bytes_legacy <$> (hex h >>= decodeTx)
+-- | The single input's witness stack of a spec transaction.
+witnessOf :: BT.Tx -> IO [BS.ByteString]
+witnessOf tx = case BT.tx_witnesses tx of
+ [BT.Witness items] -> pure items
+ _ -> assertFailure "expected one witness"
-- | A test HTLC from the Appendix C parameters.
testHtlc :: Int -> IO HTLC
testHtlc i = case drop i c_htlcs of
(TestHtlc offered amt expiry pre : _) -> do
preimage <- hex pre
+ amount <- msat amt
+ ph <- need "payment hash" (BOLT1.payment_hash (SHA256.hash preimage))
pure HTLC
- { htlc_direction = if offered then HTLCOffered else HTLCReceived
- , htlc_amount_msat = MilliSatoshi amt
- , htlc_payment_hash = PaymentHash (SHA256.hash preimage)
- , htlc_cltv_expiry = CltvExpiry expiry
+ { htlc_direction = if offered then HTLCOffered else HTLCReceived
+ , htlc_amount_msat = amount
+ , htlc_payment_hash = ph
+ , htlc_cltv_expiry = CltvExpiry expiry
}
[] -> assertFailure ("no test HTLC #" ++ show i)
+testPreimage :: Int -> IO BOLT1.PaymentPreimage
+testPreimage i = case drop i c_htlcs of
+ (TestHtlc _ _ _ pre : _) ->
+ hex pre >>= need "preimage" . BOLT1.payment_preimage
+ [] -> assertFailure ("no test HTLC #" ++ show i)
+
-- | Commitment keys from the Appendix C parameters, which Appendix F
--- shares.
+-- shares. The vectors use the payment basepoints as HTLC
+-- basepoints; to_remote pays the remote payment basepoint.
vectorKeys :: IO CommitmentKeys
vectorKeys = do
- revocation <- pk c_local_revocation_pubkey
- delayed <- pk c_local_delayedpubkey
- localHtlc <- pk c_local_htlcpubkey
- remoteHtlc <- pk c_remote_htlcpubkey
- remotePayment <- pk c_remote_payment_basepoint
- localFunding <- pk c_local_funding_pubkey
- remoteFunding <- pk c_remote_funding_pubkey
+ revocation <- pt c_local_revocation_pubkey
+ delayed <- pt c_local_delayedpubkey
+ local_htlc <- pt c_local_htlcpubkey
+ remote_htlc <- pt c_remote_htlcpubkey
+ remote_payment <- pt c_remote_payment_basepoint
+ local_funding <- pt c_local_funding_pubkey
+ remote_funding <- pt c_remote_funding_pubkey
pure CommitmentKeys
{ ck_revocation_pubkey = RevocationPubkey revocation
- , ck_local_delayed = LocalDelayedPubkey delayed
- , ck_local_htlc = LocalHtlcPubkey localHtlc
- , ck_remote_htlc = RemoteHtlcPubkey remoteHtlc
- -- the vectors use the payment basepoints as htlc basepoints, so
- -- localpubkey equals local_htlcpubkey
- , ck_local_payment = LocalPubkey localHtlc
- -- to_remote pays P2WPKH(remote_payment_basepoint)
- , ck_remote_payment = RemotePubkey remotePayment
- , ck_local_funding = FundingPubkey localFunding
- , ck_remote_funding = FundingPubkey remoteFunding
+ , ck_local_delayed = LocalDelayedPubkey delayed
+ , ck_local_htlc = LocalHtlcPubkey local_htlc
+ , ck_remote_htlc = RemoteHtlcPubkey remote_htlc
+ , ck_remote_payment = RemotePubkey remote_payment
+ , ck_local_funding = FundingPubkey local_funding
+ , ck_remote_funding = FundingPubkey remote_funding
}
- where
- pk = fmap Pubkey . hex
+
+vectorOutpoint :: IO BT.OutPoint
+vectorOutpoint = do
+ txid <- hex c_funding_txid
+ pure (BT.OutPoint (BT.TxId (BS.reverse txid)) c_funding_output_index)
-- | The commitment context for a vector: local's commitment, with local
-- as the opener.
-vectorContext :: Bool -> CommitVector -> IO CommitmentContext
-vectorContext anchors v = do
+vectorContext :: CommitmentFormat -> CommitVector -> IO CommitmentContext
+vectorContext fmt v = do
keys <- vectorKeys
- fundingTxid <- hex c_funding_txid
- localBp <- PaymentBasepoint . Point <$> hex c_local_payment_basepoint
- remoteBp <- PaymentBasepoint . Point <$> hex c_remote_payment_basepoint
- cn <- need "invalid commitment number"
- (commitment_number c_commitment_number)
+ outpoint <- vectorOutpoint
+ local_bp <- PaymentBasepoint <$> pt c_local_payment_basepoint
+ remote_bp <- PaymentBasepoint <$> pt c_remote_payment_basepoint
+ cn <- need "commitment number" (commitment_number c_commitment_number)
htlcs <- traverse testHtlc (cv_htlcs v)
+ dust <- DustLimit <$> sat (cv_dust_limit_sat v)
+ to_local <- msat (cv_to_local_msat v)
+ to_remote <- msat (cv_to_remote_msat v)
pure CommitmentContext
- { cc_funding_outpoint =
- OutPoint (TxId (BS.reverse fundingTxid)) c_funding_output_index
+ { cc_funding_outpoint = outpoint
, cc_commitment_number = cn
- , cc_local_payment_bp = localBp
- , cc_remote_payment_bp = remoteBp
- , cc_to_self_delay = ToSelfDelay c_local_delay
- , cc_dust_limit = DustLimit (Satoshi (cv_dust_limit_sat v))
- , cc_feerate = FeeratePerKw (cv_feerate_per_kw v)
- , cc_features = ChannelFeatures { cf_option_anchors = anchors }
- , cc_is_funder = True
- , cc_to_local_msat = MilliSatoshi (cv_to_local_msat v)
- , cc_to_remote_msat = MilliSatoshi (cv_to_remote_msat v)
- , cc_htlcs = htlcs
- , cc_keys = keys
+ , cc_local_payment_bp = local_bp
+ , cc_remote_payment_bp = remote_bp
+ , cc_to_self_delay = ToSelfDelay c_local_delay
+ , cc_dust_limit = dust
+ , cc_feerate = FeeratePerKw (cv_feerate_per_kw v)
+ , cc_format = fmt
+ , cc_is_funder = True
+ , cc_to_local_msat = to_local
+ , cc_to_remote_msat = to_remote
+ , cc_htlcs = htlcs
+ , cc_keys = keys
}
-- | Assert that the commitment tx and each HTLC tx of a vector match
--- the spec's, with witnesses stripped.
-commitVectorTests :: Bool -> CommitVector -> TestTree
-commitVectorTests anchors v = testGroup (cv_name v) $
+-- the spec's, with witnesses stripped, and that the spec's witnesses
+-- are those the witness functions build.
+commitVectorTests :: CommitmentFormat -> CommitVector -> TestTree
+commitVectorTests fmt v = testGroup (cv_name v) $
testCase "commitment tx" (do
- ctx <- vectorContext anchors v
- expected <- unsignedTx (cv_commit_tx v)
- encode_tx (build_commitment_tx ctx) @?= Just expected)
+ ctx <- vectorContext fmt v
+ spec <- hex (cv_commit_tx v) >>= decodeTx
+ commit <- need "no commitment tx" (build_commitment_tx ctx)
+ encode_commitment_tx commit @?= BT.to_bytes_legacy spec
+ -- the funding witness, with its signatures in either order
+ w <- witnessOf spec
+ case w of
+ [_, s1, s2, _] -> do
+ let keys = cc_keys ctx
+ lpk = ck_local_funding keys
+ rpk = ck_remote_funding keys
+ funding_witness lpk s1 rpk s2 @?= BT.Witness w
+ funding_witness rpk s2 lpk s1 @?= BT.Witness w
+ _ -> assertFailure "unexpected funding witness")
: fmap htlcTxTest (cv_htlc_txs v)
where
htlcTxTest (HtlcTxVector kind i out raw) =
testCase (kindName kind ++ " for htlc #" ++ show i
++ " (output " ++ show out ++ ")") $ do
- ctx <- vectorContext anchors v
- commit <- need "empty commitment tx"
- (commitment_to_tx (build_commitment_tx ctx))
- htlc <- testHtlc i
- expected <- unsignedTx raw
+ ctx <- vectorContext fmt v
+ commit <- need "no commitment tx" (build_commitment_tx ctx)
+ expected_htlc <- testHtlc i
+ -- the output names its HTLC
+ htlc <- case drop (fromIntegral out) (NE.toList (ctx_outputs commit))
+ of
+ (CommitmentOutput _ _ (OutputHTLC h) : _) -> pure h
+ _ -> assertFailure "not an HTLC output"
+ htlc @?= expected_htlc
let keys = cc_keys ctx
hctx = HTLCContext
- { hc_commitment_txid = BT.txid commit
- , hc_output_index = out
- , hc_htlc = htlc
- , hc_to_self_delay = cc_to_self_delay ctx
- , hc_feerate = cc_feerate ctx
- , hc_features = cc_features ctx
+ { hc_commitment_txid = BT.txid (commitment_to_tx commit)
+ , hc_output_index = out
+ , hc_htlc = htlc
+ , hc_to_self_delay = cc_to_self_delay ctx
+ , hc_feerate = cc_feerate ctx
+ , hc_format = fmt
, hc_revocation_pubkey = ck_revocation_pubkey keys
- , hc_local_delayed = ck_local_delayed keys
+ , hc_local_delayed = ck_local_delayed keys
}
- encode_htlc_tx (build kind hctx) @?= expected
+ spec <- hex raw >>= decodeTx
+ htx <- need "no htlc tx" (build_htlc_tx hctx)
+ encode_htlc_tx htx @?= BT.to_bytes_legacy spec
+ -- the input witness
+ w <- witnessOf spec
+ let rev = ck_revocation_pubkey keys
+ rh = ck_remote_htlc keys
+ lh = ck_local_htlc keys
+ ph = htlc_payment_hash htlc
+ case (kind, w) of
+ (HtlcSuccess, [_, rsig, lsig, _, _]) -> do
+ pre <- testPreimage i
+ let ws = received_htlc_script rev rh lh ph
+ (htlc_cltv_expiry htlc) fmt
+ htlc_success_witness rsig lsig pre ws @?= BT.Witness w
+ sighashes rsig lsig
+ (HtlcTimeout, [_, rsig, lsig, _, _]) -> do
+ let ws = offered_htlc_script rev rh lh ph fmt
+ htlc_timeout_witness rsig lsig ws @?= BT.Witness w
+ sighashes rsig lsig
+ _ -> assertFailure "unexpected htlc witness"
+
+ -- the remote signature uses remote_htlc_sighash, the local one
+ -- SIGHASH_ALL
+ sighashes rsig lsig = do
+ let flag = fromIntegral . Sighash.encode_sighash
+ fmap snd (BS.unsnoc rsig) @?= Just (flag (remote_htlc_sighash fmt))
+ fmap snd (BS.unsnoc lsig) @?= Just (flag Sighash.SIGHASH_ALL)
kindName HtlcSuccess = "htlc-success tx"
kindName HtlcTimeout = "htlc-timeout tx"
- build HtlcSuccess = build_htlc_success_tx
- build HtlcTimeout = build_htlc_timeout_tx
-
--- Fee calculation tests -------------------------------------------------------
-
-feeCalculationTests :: TestTree
-feeCalculationTests = testGroup "Fee calculation" [
- testCase "commitment_fee no anchors, 0 htlcs" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- fee = commitment_fee feerate features 0
- fee @?= Satoshi 3620 -- 5000 * 724 / 1000 = 3620
-
- , testCase "commitment_fee no anchors, 2 htlcs" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- fee = commitment_fee feerate features 2
- -- weight = 724 + 172*2 = 1068
- -- fee = 5000 * 1068 / 1000 = 5340
- fee @?= Satoshi 5340
-
- , testCase "commitment_fee with anchors, 0 htlcs" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = True }
- fee = commitment_fee feerate features 0
- -- 5000 * 1124 / 1000 = 5620
- fee @?= Satoshi 5620
-
- , testCase "htlc_timeout_fee no anchors" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- fee = htlc_timeout_fee feerate features
- -- 5000 * 663 / 1000 = 3315
- fee @?= Satoshi 3315
-
- , testCase "htlc_success_fee no anchors" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- fee = htlc_success_fee feerate features
- -- 5000 * 703 / 1000 = 3515
- fee @?= Satoshi 3515
-
- , testCase "htlc_timeout_fee with anchors is 0" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = True }
- fee = htlc_timeout_fee feerate features
- fee @?= Satoshi 0
-
- , testCase "htlc_success_fee with anchors is 0" $ do
- let feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = True }
- fee = htlc_success_fee feerate features
- fee @?= Satoshi 0
+-- commitment transactions ----------------------------------------------------
+
+simpleVector :: IO CommitVector
+simpleVector = case appendix_c of
+ (v : _) -> pure v
+ [] -> assertFailure "missing Appendix C vectors"
+
+commitmentTests :: TestTree
+commitmentTests = testGroup "Commitment transactions" [
+ testCase "obscured_commitment_number (Appendix C)" $ do
+ o <- PaymentBasepoint <$> pt c_local_payment_basepoint
+ a <- PaymentBasepoint <$> pt c_remote_payment_basepoint
+ cn <- need "commitment_number" (commitment_number 42)
+ obscured_commitment_number o a cn @?= 0x2bb038521914 `xor` 42
+
+ , testCase "obscured commitment number from the accepter's side" $ do
+ v <- simpleVector
+ opener_ctx <- vectorContext StaticRemotekey v
+ spec <- hex (cv_commit_tx v) >>= decodeTx
+ -- the accepter's (remote's) commitment, with the owner-relative
+ -- payment basepoints swapped and the owner not the funder
+ let accepter_ctx = opener_ctx
+ { cc_local_payment_bp = cc_remote_payment_bp opener_ctx
+ , cc_remote_payment_bp = cc_local_payment_bp opener_ctx
+ , cc_is_funder = False
+ }
+ commit <- need "no commitment tx" (build_commitment_tx accepter_ctx)
+ let Locktime lt = ctx_locktime commit
+ Sequence sq = ctx_input_sequence commit
+ lt @?= BT.tx_locktime spec
+ [sq] @?= fmap BT.txin_sequence (NE.toList (BT.tx_inputs spec))
+ -- the obscured number is 0x2bb038521914 ^ 42
+ let obscured = 0x2bb038521914 `xor` 42 :: Word64
+ lt @?= 0x20000000 + fromIntegral (obscured `mod` 0x1000000)
+ sq @?= 0x80000000 + fromIntegral (obscured `div` 0x1000000)
+
+ , testCase "fee taken from the remote output when it funds" $ do
+ v <- simpleVector
+ ctx <- vectorContext StaticRemotekey v
+ commit <- need "no commitment tx" (build_commitment_tx ctx
+ { cc_is_funder = False })
+ -- the 10860 sat base fee comes from to_remote's 3000000 sat
+ let values = [ (co_type o, BOLT1.un_satoshi (co_value o))
+ | o <- NE.toList (ctx_outputs commit) ]
+ values @?= [(OutputToRemote, 2989140), (OutputToLocal, 7000000)]
+
+ , testCase "no outputs" $ do
+ v <- simpleVector
+ ctx <- vectorContext Anchors v
+ zero <- msat 0
+ isNothing (build_commitment_tx ctx
+ { cc_to_local_msat = zero, cc_to_remote_msat = zero })
+ @?= True
+
+ , testCase "anchors: only the anchor of a materialized output" $ do
+ v <- simpleVector
+ ctx <- vectorContext Anchors v
+ zero <- msat 0
+ commit <- need "no commitment tx" (build_commitment_tx ctx
+ { cc_to_remote_msat = zero })
+ fmap co_type (NE.toList (ctx_outputs commit))
+ @?= [OutputLocalAnchor, OutputToLocal]
]
--- Trimming tests --------------------------------------------------------------
-
-trimmingTests :: TestTree
-trimmingTests = testGroup "HTLC trimming" [
- testCase "offered HTLC above threshold not trimmed" $ do
- let dust = DustLimit (Satoshi 546)
- feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- htlc = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 5000000 -- 5000 sats
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
- -- threshold = 546 + 3315 = 3861
- -- 5000 > 3861, so not trimmed
- is_trimmed dust feerate features htlc @?= False
-
- , testCase "offered HTLC below threshold is trimmed" $ do
- let dust = DustLimit (Satoshi 546)
- feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- htlc = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 1000000 -- 1000 sats
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
+-- HTLC transactions ----------------------------------------------------------
+
+htlcTxTests :: TestTree
+htlcTxTests = testGroup "HTLC transactions" [
+ testCase "fee exceeding the amount" $ do
+ keys <- vectorKeys
+ outpoint <- vectorOutpoint
+ h <- testHtlc 2 -- offered, 2000 sat
+ let ctx = HTLCContext
+ { hc_commitment_txid = BT.op_txid outpoint
+ , hc_output_index = 0
+ , hc_htlc = h
+ , hc_to_self_delay = ToSelfDelay 144
+ , hc_feerate = FeeratePerKw 5000 -- fee 3315
+ , hc_format = StaticRemotekey
+ , hc_revocation_pubkey = ck_revocation_pubkey keys
+ , hc_local_delayed = ck_local_delayed keys
}
- -- threshold = 546 + 3315 = 3861
- -- 1000 < 3861, so trimmed
- is_trimmed dust feerate features htlc @?= True
-
- , testCase "received HTLC above threshold not trimmed" $ do
- let dust = DustLimit (Satoshi 546)
- feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- htlc = HTLC
- { htlc_direction = HTLCReceived
- , htlc_amount_msat = MilliSatoshi 7000000 -- 7000 sats
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
- -- threshold = 546 + 3515 = 4061
- -- 7000 > 4061, so not trimmed
- is_trimmed dust feerate features htlc @?= False
-
- , testCase "received HTLC below threshold is trimmed" $ do
- let dust = DustLimit (Satoshi 546)
- feerate = FeeratePerKw 5000
- features = ChannelFeatures { cf_option_anchors = False }
- htlc = HTLC
- { htlc_direction = HTLCReceived
- , htlc_amount_msat = MilliSatoshi 800000 -- 800 sats
- , htlc_payment_hash = PaymentHash (BS.replicate 32 0)
- , htlc_cltv_expiry = CltvExpiry 500000
- }
- -- threshold = 546 + 3515 = 4061
- -- 800 < 4061, so trimmed
- is_trimmed dust feerate features htlc @?= True
+ isNothing (build_htlc_tx ctx) @?= True
+ -- zero-fee under anchors
+ htx <- need "anchors htlc tx" (build_htlc_tx ctx { hc_format = Anchors })
+ BOLT1.un_satoshi (htx_output_value htx) @?= 2000
+ htx_input_sequence htx @?= Sequence 1
+ htx_locktime htx @?= Locktime 502
]
--- Smart constructor tests -----------------------------------------------------
-
-smartConstructorTests :: TestTree
-smartConstructorTests = testGroup "validation" [
- -- 33-byte types
- testCase "pubkey accepts 33 bytes" $ do
- let bs = BS.replicate 33 0x02
- isJust (pubkey bs) @?= True
- , testCase "pubkey rejects 32 bytes" $ do
- let bs = BS.replicate 32 0x02
- isNothing (pubkey bs) @?= True
- , testCase "pubkey rejects 34 bytes" $ do
- let bs = BS.replicate 34 0x02
- isNothing (pubkey bs) @?= True
- , testCase "point accepts 33 bytes" $ do
- let bs = BS.replicate 33 0x03
- isJust (point bs) @?= True
- , testCase "point rejects 32 bytes" $ do
- let bs = BS.replicate 32 0x03
- isNothing (point bs) @?= True
-
- -- 32-byte types
- , testCase "seckey accepts 32 bytes" $ do
- let bs = BS.replicate 32 0x01
- isJust (seckey bs) @?= True
- , testCase "seckey rejects 31 bytes" $ do
- let bs = BS.replicate 31 0x01
- isNothing (seckey bs) @?= True
- , testCase "seckey rejects 33 bytes" $ do
- let bs = BS.replicate 33 0x01
- isNothing (seckey bs) @?= True
- , testCase "mkTxId accepts 32 bytes" $ do
- let bs = BS.replicate 32 0x00
- isJust (mkTxId bs) @?= True
- , testCase "mkTxId rejects 31 bytes" $ do
- let bs = BS.replicate 31 0x00
- isNothing (mkTxId bs) @?= True
- , testCase "paymentHash accepts 32 bytes" $ do
- let bs = BS.replicate 32 0xab
- isJust (paymentHash bs) @?= True
- , testCase "paymentHash rejects 33 bytes" $ do
- let bs = BS.replicate 33 0xab
- isNothing (paymentHash bs) @?= True
- , testCase "paymentPreimage accepts 32 bytes" $ do
- let bs = BS.replicate 32 0xcd
- isJust (paymentPreimage bs) @?= True
- , testCase "paymentPreimage rejects 31 bytes" $ do
- let bs = BS.replicate 31 0xcd
- isNothing (paymentPreimage bs) @?= True
- , testCase "perCommitmentSecret accepts 32 bytes" $ do
- let bs = BS.replicate 32 0xef
- isJust (perCommitmentSecret bs) @?= True
- , testCase "perCommitmentSecret rejects 33 bytes" $ do
- let bs = BS.replicate 33 0xef
- isNothing (perCommitmentSecret bs) @?= True
-
- -- 48-bit commitment number
- , testCase "commitment_number accepts 0" $ do
- isJust (commitment_number 0) @?= True
- , testCase "commitment_number accepts 2^48-1" $ do
- isJust (commitment_number 281474976710655) @?= True
- , testCase "commitment_number rejects 2^48" $ do
- isNothing (commitment_number 281474976710656) @?= True
- , testCase "commitment_number rejects maxBound Word64" $ do
- isNothing (commitment_number maxBound) @?= True
-
- -- next_commitment_number
- , testCase "next_commitment_number 0 -> 1" $
- case commitment_number 0 of
- Nothing -> assertFailure "commitment_number 0"
- Just cn0 -> case next_commitment_number cn0 of
- Nothing -> assertFailure "next failed"
- Just cn1 -> unCommitmentNumber cn1 @?= 1
- , testCase "next_commitment_number (2^48-2) -> (2^48-1)" $
- case commitment_number 281474976710654 of
- Nothing -> assertFailure "commitment_number"
- Just cn -> case next_commitment_number cn of
- Nothing -> assertFailure "next failed"
- Just cn' ->
- unCommitmentNumber cn' @?= 281474976710655
- , testCase "next_commitment_number (2^48-1) -> Nothing" $
- case commitment_number 281474976710655 of
- Nothing -> assertFailure "commitment_number"
- Just cn ->
- isNothing (next_commitment_number cn) @?= True
+-- closing transactions -------------------------------------------------------
+
+p2wpkh :: Word8 -> Script
+p2wpkh b = Script (BS.pack [0x00, 0x14] <> BS.replicate 20 b)
+
+closingValues :: ClosingTx -> [(Word64, Script)]
+closingValues c =
+ [ (BOLT1.un_satoshi (clo_value o), clo_script o)
+ | o <- NE.toList (cltx_outputs c) ]
+
+closingTests :: TestTree
+closingTests = testGroup "Closing transactions" [
+ testGroup "legacy" [
+ testCase "fee from the funder, outputs in BIP69 order" $ do
+ ctx <- legacy 6000500 4000999 546 1000 True False
+ c <- need "no closing tx" (build_legacy_closing_tx ctx)
+ closingValues c @?= [(4000, remote_spk), (5000, local_spk)]
+ cltx_locktime c @?= Locktime 0
+ cltx_input_sequence c @?= Sequence 0xFFFFFFFF
+ cltx_version c @?= 2
+
+ , testCase "fee from the remote output when it funds" $ do
+ ctx <- legacy 6000000 4000000 546 1000 False False
+ c <- need "no closing tx" (build_legacy_closing_tx ctx)
+ closingValues c @?= [(3000, remote_spk), (6000, local_spk)]
+
+ , testCase "the signer's dust limit applies to both outputs" $ do
+ ctx <- legacy 100000000 600000 1000 500 True False
+ c <- need "no closing tx" (build_legacy_closing_tx ctx)
+ closingValues c @?= [(99500, local_spk)]
+
+ , testCase "the signer may omit its own output" $ do
+ ctx <- legacy 6000000 4000000 546 1000 True True
+ c <- need "no closing tx" (build_legacy_closing_tx ctx)
+ closingValues c @?= [(4000, remote_spk)]
+
+ , testCase "fee exceeding the funder's balance" $ do
+ ctx <- legacy 999999 4000000 546 1000 True False
+ isNothing (build_legacy_closing_tx ctx) @?= True
+
+ , testCase "no outputs" $ do
+ ctx <- legacy 500000 500000 546 0 True False
+ isNothing (build_legacy_closing_tx ctx) @?= True
+ ]
+
+ , testGroup "option_simple_close" [
+ testCase "closer pays the fee, outputs in BIP69 order" $ do
+ ctx <- simple 10000999 5000000 500 CloserAndCloseeOutputs
+ c <- need "no closing tx" (build_closing_tx ctx)
+ closingValues c @?= [(5000, remote_spk), (9500, local_spk)]
+ cltx_locktime c @?= Locktime 800000
+ cltx_input_sequence c @?= Sequence 0xFFFFFFFD
+ cltx_version c @?= 2
+
+ , testCase "closer output only" $ do
+ ctx <- simple 10000000 5000000 500 CloserOutputOnly
+ c <- need "no closing tx" (build_closing_tx ctx)
+ closingValues c @?= [(9500, local_spk)]
+
+ , testCase "closee output only" $ do
+ ctx <- simple 10000000 5000000 500 CloseeOutputOnly
+ c <- need "no closing tx" (build_closing_tx ctx)
+ closingValues c @?= [(5000, remote_spk)]
+
+ , testCase "OP_RETURN outputs have amount zero and are kept" $ do
+ ctx <- simple 10000000 5000000 500 CloserAndCloseeOutputs
+ let op_return = Script (BS.pack [0x6a, 0x01, 0x00])
+ c <- need "no closing tx" (build_closing_tx ctx
+ { clc_closer_script = op_return })
+ closingValues c @?= [(0, op_return), (5000, remote_spk)]
+ c' <- need "no closing tx" (build_closing_tx ctx
+ { clc_closee_script = op_return })
+ closingValues c' @?= [(0, op_return), (9500, local_spk)]
+
+ , testCase "dust outputs are not trimmed" $ do
+ ctx <- simple 10000000 100000 500 CloserAndCloseeOutputs
+ c <- need "no closing tx" (build_closing_tx ctx)
+ closingValues c @?= [(100, remote_spk), (9500, local_spk)]
+
+ , testCase "fee exceeding the closer's balance" $ do
+ ctx <- simple 499999 5000000 500 CloseeOutputOnly
+ isNothing (build_closing_tx ctx) @?= True
+ ]
+ ]
+ where
+ local_spk = p2wpkh 0x11
+ remote_spk = p2wpkh 0x22
+
+ legacy l r dust fee funder omit = do
+ outpoint <- vectorOutpoint
+ lm <- msat l
+ rm <- msat r
+ d <- DustLimit <$> sat dust
+ f <- sat fee
+ pure LegacyClosingContext
+ { lcc_funding_outpoint = outpoint
+ , lcc_local_msat = lm
+ , lcc_remote_msat = rm
+ , lcc_local_script = local_spk
+ , lcc_remote_script = remote_spk
+ , lcc_dust_limit = d
+ , lcc_fee = f
+ , lcc_is_funder = funder
+ , lcc_omit_local = omit
+ }
+
+ simple closer closee fee outs = do
+ outpoint <- vectorOutpoint
+ cm <- msat closer
+ em <- msat closee
+ f <- sat fee
+ pure ClosingContext
+ { clc_funding_outpoint = outpoint
+ , clc_closer_msat = cm
+ , clc_closee_msat = em
+ , clc_closer_script = local_spk
+ , clc_closee_script = remote_spk
+ , clc_fee = f
+ , clc_locktime = Locktime 800000
+ , clc_outputs = outs
+ }
+
+-- scripts --------------------------------------------------------------------
+
+scriptTests :: TestTree
+scriptTests = testGroup "Scripts and witnesses" [
+ testCase "to_remote scriptPubKeys" $ do
+ pk <- RemotePubkey <$> pt c_remote_payment_basepoint
+ let Script ws = to_remote_witness_script pk
+ -- <remotepubkey> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY
+ BS.length ws @?= 37
+ BS.drop 34 ws @?= BS.pack [0xad, 0x51, 0xb2]
+ to_remote_script_pubkey pk Anchors @?= to_p2wsh (Script ws)
+ -- P2WPKH, as in Appendix C's to_remote output
+ v <- simpleVector
+ spec <- hex (cv_commit_tx v) >>= decodeTx
+ let p2wpkhs = [ spk | BT.TxOut _ spk <- NE.toList (BT.tx_outputs spec)
+ , BS.length spk == 22 ]
+ [to_remote_script_pubkey pk StaticRemotekey] @?= fmap Script p2wpkhs
+
+ , testCase "to_remote witnesses" $ do
+ pk@(RemotePubkey p) <- RemotePubkey <$> pt c_remote_payment_basepoint
+ to_remote_witness "sig" pk StaticRemotekey
+ @?= BT.Witness ["sig", unpoint p]
+ let Script ws = to_remote_witness_script pk
+ to_remote_witness "sig" pk Anchors @?= BT.Witness ["sig", ws]
+
+ , testCase "to_local witnesses" $ do
+ keys <- vectorKeys
+ let s@(Script ws) = to_local_script (ck_revocation_pubkey keys)
+ (ToSelfDelay 144) (ck_local_delayed keys)
+ to_local_witness_spend "sig" s @?= BT.Witness ["sig", "", ws]
+ to_local_witness_revoke "sig" s @?= BT.Witness ["sig", "\x01", ws]
+
+ , testCase "anchor witnesses" $ do
+ keys <- vectorKeys
+ let fpk = ck_local_funding keys
+ Script ws = anchor_script fpk
+ anchor_witness_owner "sig" fpk @?= BT.Witness ["sig", ws]
+ anchor_witness_anyone fpk @?= BT.Witness ["", ws]
+
+ , testCase "HTLC output witnesses" $ do
+ keys <- vectorKeys
+ h <- testHtlc 2
+ pre <- testPreimage 2
+ let rev@(RevocationPubkey rp) = ck_revocation_pubkey keys
+ off@(Script ows) = offered_htlc_script rev (ck_remote_htlc keys)
+ (ck_local_htlc keys) (htlc_payment_hash h) Anchors
+ rcv@(Script rws) = received_htlc_script rev (ck_remote_htlc keys)
+ (ck_local_htlc keys) (htlc_payment_hash h) (htlc_cltv_expiry h)
+ Anchors
+ offered_htlc_witness_preimage "sig" pre off
+ @?= BT.Witness ["sig", BOLT1.un_payment_preimage pre, ows]
+ offered_htlc_witness_revoke "sig" rev off
+ @?= BT.Witness ["sig", unpoint rp, ows]
+ received_htlc_witness_timeout "sig" rcv
+ @?= BT.Witness ["sig", "", rws]
+ received_htlc_witness_revoke "sig" rev rcv
+ @?= BT.Witness ["sig", unpoint rp, rws]
+
+ , testCase "remote_htlc_sighash" $ do
+ remote_htlc_sighash StaticRemotekey @?= Sighash.SIGHASH_ALL
+ remote_htlc_sighash Anchors @?= Sighash.SIGHASH_SINGLE_ANYONECANPAY
+
+ , testCase "CSV delays and CLTV expiries are minimally encoded" $ do
+ keys <- vectorKeys
+ h <- testHtlc 0
+ let rev = ck_revocation_pubkey keys
+ delayed = ck_local_delayed keys
+ delay d = let Script s = to_local_script rev (ToSelfDelay d) delayed
+ in BS.take 4 (BS.drop 36 s)
+ expiry e =
+ let Script s = received_htlc_script rev (ck_remote_htlc keys)
+ (ck_local_htlc keys) (htlc_payment_hash h) (CltvExpiry e)
+ StaticRemotekey
+ in BS.take 5 (BS.drop 130 s)
+ delay 16 @?= BS.pack [0x60, 0xb2, 0x75, 0x21]
+ delay 17 @?= BS.pack [0x01, 0x11, 0xb2, 0x75]
+ delay 0x80 @?= BS.pack [0x02, 0x80, 0x00, 0xb2]
+ delay 0x8000 @?= BS.pack [0x03, 0x00, 0x80, 0x00]
+ expiry 500 @?= BS.pack [0x02, 0xf4, 0x01, 0xb1, 0x75]
+ expiry 0x800000 @?= BS.pack [0x04, 0x00, 0x00, 0x80, 0x00]
]
--- Property tests -------------------------------------------------------
+-- fees and trimming ----------------------------------------------------------
+
+feeTests :: TestTree
+feeTests = testGroup "Fees and trimming (BOLT #3 fee example)" [
+ testCase "HTLC transaction fees" $ do
+ fmap BOLT1.un_satoshi
+ [ htlc_timeout_fee rate StaticRemotekey
+ , htlc_success_fee rate StaticRemotekey
+ , htlc_timeout_fee rate Anchors
+ , htlc_success_fee rate Anchors ]
+ @?= [3315, 3515, 0, 0]
+
+ , testCase "trim thresholds" $ do
+ d <- DustLimit <$> sat 546
+ fmap (BOLT1.un_satoshi . htlc_trim_threshold d rate StaticRemotekey)
+ [HTLCOffered, HTLCReceived] @?= [3861, 4061]
+
+ , testCase "trimmed HTLCs and base fee" $ do
+ d <- DustLimit <$> sat 546
+ hs <- sequence
+ [ example HTLCOffered 5000000, example HTLCOffered 1000000
+ , example HTLCReceived 7000000, example HTLCReceived 800000 ]
+ fmap (is_trimmed d rate StaticRemotekey) hs
+ @?= [False, True, False, True]
+ BOLT1.un_satoshi (commitment_fee rate StaticRemotekey 2) @?= 5340
+ BOLT1.un_satoshi (commitment_fee rate Anchors 0) @?= 5620
+
+ , testCase "commitment fee saturates" $
+ commitment_fee (FeeratePerKw maxBound) StaticRemotekey maxBound
+ @?= BOLT1.max_satoshi
+ ]
+ where
+ rate = FeeratePerKw 5000
+ example dir amt = do
+ a <- msat amt
+ ph <- need "payment hash" (BOLT1.payment_hash (BS.replicate 32 0))
+ pure (HTLC dir a ph (CltvExpiry 500))
--- | Maximum valid commitment number (2^48 - 1).
-maxCommitNum :: Word64
-maxCommitNum = 281474976710655
+-- smart constructors ---------------------------------------------------------
+
+constructorTests :: TestTree
+constructorTests = testGroup "Smart constructors" [
+ testCase "commitment_number" $ do
+ isJust (commitment_number 0) @?= True
+ isJust (commitment_number 0xFFFFFFFFFFFF) @?= True
+ isNothing (commitment_number 0x1000000000000) @?= True
+ , testCase "next_commitment_number" $ do
+ cn <- need "commitment_number" (commitment_number 0xFFFFFFFFFFFE)
+ fmap un_commitment_number (next_commitment_number cn)
+ @?= Just 0xFFFFFFFFFFFF
+ top <- need "commitment_number" (commitment_number 0xFFFFFFFFFFFF)
+ isNothing (next_commitment_number top) @?= True
+ , testCase "secret_index" $ do
+ isJust (secret_index 0xFFFFFFFFFFFF) @?= True
+ isNothing (secret_index 0x1000000000000) @?= True
+ , testCase "seed" $ do
+ isJust (seed (BS.replicate 32 0)) @?= True
+ isNothing (seed (BS.replicate 31 0)) @?= True
+ isNothing (seed (BS.replicate 33 0)) @?= True
+ , testCase "seckey" $ do
+ isJust (seckey (BS.replicate 32 0x01)) @?= True
+ isNothing (seckey (BS.replicate 31 0x01)) @?= True
+ isNothing (seckey (BS.replicate 32 0x00)) @?= True
+ -- the group order n is out of range, n - 1 in range
+ n <- hex
+ "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141"
+ n1 <- hex
+ "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140"
+ isNothing (seckey n) @?= True
+ isJust (seckey n1) @?= True
+ ]
+
+-- properties -----------------------------------------------------------------
propertyTests :: TestTree
-propertyTests = testGroup "invariants" [
- testProperty "commitment_number validates 48-bit"
- propCommitmentNumberRange
- , testProperty "next_commitment_number stays valid"
- propNextCommitmentNumber
- , testProperty "trimmed/untrimmed partition"
- propTrimPartition
- , testProperty "commitment_fee increases with HTLCs"
- propFeeMonotonic
- , testProperty "insert_secret keeps every inserted secret derivable"
- propSecretStoreDerivable
- , testProperty "derive_per_commitment_point' ≡ derive_per_commitment_point"
- propDerivePcpEquiv
- , testProperty "derive_pubkey' ≡ derive_pubkey"
- propDerivePubkeyEquiv
- , testProperty "derive_localpubkey' ≡ derive_localpubkey"
- propDeriveLocalEquiv
- , testProperty "derive_local_htlcpubkey' ≡ derive_local_htlcpubkey"
- propDeriveLocalHtlcEquiv
- , testProperty "derive_remote_htlcpubkey' ≡ derive_remote_htlcpubkey"
- propDeriveRemoteHtlcEquiv
- , testProperty "derive_local_delayedpubkey' ≡ derive_local_delayedpubkey"
- propDeriveLocalDelEquiv
- , testProperty "derive_remote_delayedpubkey' ≡ derive_remote_delayedpubkey"
- propDeriveRemoteDelEquiv
+propertyTests = testGroup "Properties" [
+ testProperty "derive_privkey matches derive_pubkey" propPrivkey
+ , testProperty "derive_revocationprivkey matches derive_revocationpubkey"
+ propRevocationPrivkey
+ , testProperty "derive_per_commitment_point' = derive_per_commitment_point"
+ propPcpWnaf
+ , testProperty "derive_commitment_keys' = derive_commitment_keys"
+ propCommitmentKeysWnaf
+ , testProperty "every inserted secret is derivable, before and after \
+ \a round trip through un_secret_store" propSecretStore
+ , testProperty "commitment_number accepts exactly 48-bit values"
+ propCommitmentNumber
+ , testProperty "commitment_secret_index counts down from 2^48 - 1"
+ propSecretIndex
]
--- | Random 32-byte secret, then derive a basepoint and per-commit
--- point from it. Returns (basepoint, pcp). Using derived points
--- keeps us on the curve without having to generate valid points
--- directly.
-genPointPair :: Gen (Point, PerCommitmentPoint)
-genPointPair = do
- sk1 <- vectorOf 32 (choose (0, 255 :: Int))
- sk2 <- vectorOf 32 (choose (0, 255 :: Int))
- let bs1 = BS.pack (fmap fromIntegral sk1)
- bs2 = BS.pack (fmap fromIntegral sk2)
- mkPt b = case S.parse_int256 b of
- Nothing -> Nothing
- Just w -> S.serialize_point <$> S.derive_pub w
- case (mkPt bs1, mkPt bs2) of
- (Just p1, Just p2) ->
- pure (Point p1, PerCommitmentPoint (Point p2))
- _ -> genPointPair -- ~negligible retry; sk=0 or sk>=q
-
-propDerivePcpEquiv :: Property
-propDerivePcpEquiv =
- forAll (vectorOf 32 (choose (0, 255 :: Int))) $ \sk ->
- let bs = BS.pack (fmap fromIntegral sk)
- sec = PerCommitmentSecret bs
- in derive_per_commitment_point' tex sec
- === derive_per_commitment_point sec
-
-propDerivePubkeyEquiv :: Property
-propDerivePubkeyEquiv =
- forAll genPointPair $ \(bp, pcp) ->
- derive_pubkey' tex bp pcp === derive_pubkey bp pcp
-
-propDeriveLocalEquiv :: Property
-propDeriveLocalEquiv =
- forAll genPointPair $ \(bp, pcp) ->
- let pbp = PaymentBasepoint bp
- in derive_localpubkey' tex pbp pcp
- === derive_localpubkey pbp pcp
-
-propDeriveLocalHtlcEquiv :: Property
-propDeriveLocalHtlcEquiv =
- forAll genPointPair $ \(bp, pcp) ->
- let hbp = HtlcBasepoint bp
- in derive_local_htlcpubkey' tex hbp pcp
- === derive_local_htlcpubkey hbp pcp
-
-propDeriveRemoteHtlcEquiv :: Property
-propDeriveRemoteHtlcEquiv =
- forAll genPointPair $ \(bp, pcp) ->
- let hbp = HtlcBasepoint bp
- in derive_remote_htlcpubkey' tex hbp pcp
- === derive_remote_htlcpubkey hbp pcp
-
-propDeriveLocalDelEquiv :: Property
-propDeriveLocalDelEquiv =
- forAll genPointPair $ \(bp, pcp) ->
- let dbp = DelayedPaymentBasepoint bp
- in derive_local_delayedpubkey' tex dbp pcp
- === derive_local_delayedpubkey dbp pcp
-
-propDeriveRemoteDelEquiv :: Property
-propDeriveRemoteDelEquiv =
- forAll genPointPair $ \(bp, pcp) ->
- let dbp = DelayedPaymentBasepoint bp
- in derive_remote_delayedpubkey' tex dbp pcp
- === derive_remote_delayedpubkey dbp pcp
+genBytes :: Int -> Gen BS.ByteString
+genBytes n = BS.pack <$> vectorOf n arbitrary
+
+-- | A random valid secret key.
+genSeckey :: Gen Seckey
+genSeckey = do
+ bs <- genBytes 32
+ maybe genSeckey pure (seckey bs)
+
+-- | A random point (as the public key of a random secret key).
+genPoint :: Gen BOLT1.Point
+genPoint = do
+ k <- genSeckey
+ case pubkey_of k >>= BOLT1.point of
+ Just p -> pure p
+ Nothing -> genPoint
+
+genSecret :: Gen BOLT1.PerCommitmentSecret
+genSecret = do
+ k <- genSeckey
+ maybe genSecret pure (BOLT1.per_commitment_secret (un_seckey k))
+
+genBasepoints :: Gen Basepoints
+genBasepoints = Basepoints
+ <$> fmap RevocationBasepoint genPoint
+ <*> fmap PaymentBasepoint genPoint
+ <*> fmap DelayedPaymentBasepoint genPoint
+ <*> fmap HtlcBasepoint genPoint
+
+propPrivkey :: Property
+propPrivkey = forAll genSeckey $ \k -> forAll genPoint $ \p ->
+ let pcp = PerCommitmentPoint p
+ bp = pubkey_of k >>= BOLT1.point
+ in (pubkey_of =<< derive_privkey k pcp)
+ === fmap unpoint (bp >>= \b -> derive_pubkey b pcp)
+
+propRevocationPrivkey :: Property
+propRevocationPrivkey = forAll genSeckey $ \k -> forAll genSecret $ \s ->
+ let rbp = fmap RevocationBasepoint (pubkey_of k >>= BOLT1.point)
+ pcp = derive_per_commitment_point s
+ expected = do
+ r <- rbp
+ c <- pcp
+ RevocationPubkey p <- derive_revocationpubkey r c
+ pure (unpoint p)
+ in (pubkey_of =<< derive_revocationprivkey k s) === expected
+
+propPcpWnaf :: Property
+propPcpWnaf = forAll genSecret $ \s ->
+ derive_per_commitment_point' tex s === derive_per_commitment_point s
+
+propCommitmentKeysWnaf :: Property
+propCommitmentKeysWnaf =
+ forAll genBasepoints $ \l -> forAll genBasepoints $ \r ->
+ forAll genPoint $ \lf -> forAll genPoint $ \rf -> forAll genPoint $ \p ->
+ let args f = f l (FundingPubkey lf) r (FundingPubkey rf)
+ (PerCommitmentPoint p)
+ in args (derive_commitment_keys' tex) === args derive_commitment_keys
-- | After inserting a prefix of a correct sequence (descending from
--- 2^48-1, all from one seed), every inserted index is derivable and
--- the store's buckets are strictly ascending.
-propSecretStoreDerivable :: Property
-propSecretStoreDerivable =
- forAll (vectorOf 32 (choose (0, 255 :: Int))) $ \sd ->
- forAll (choose (1, 1024)) $ \n ->
- let seed = BS.pack (fmap fromIntegral sd)
- idxs = take n [maxCommitNum, maxCommitNum - 1 ..]
- secret = generate_from_seed seed
- insert st i = st >>= insert_secret (secret i) i
- in case foldl insert (Just empty_store) idxs of
- Nothing -> counterexample "insert_secret rejected" False
- Just store ->
- let buckets = fmap se_bucket (unSecretStore store)
- in conjoin
- [ counterexample "buckets not ascending"
- (and (zipWith (<) buckets (drop 1 buckets)))
- , conjoin
- [ counterexample ("index " ++ show i)
- (derive_old_secret i store === Just (secret i))
- | i <- idxs ]
- ]
-
--- | commitment_number accepts values in [0, 2^48-1] and
--- rejects values >= 2^48.
-propCommitmentNumberRange :: Property
-propCommitmentNumberRange =
- forAll (choose (0, maxBound)) $ \n ->
- case commitment_number n of
- Just cn -> n <= maxCommitNum
- && unCommitmentNumber cn == n
- Nothing -> n > maxCommitNum
-
--- | If cn is a valid commitment number below the max,
--- next_commitment_number yields a valid successor.
-propNextCommitmentNumber :: Property
-propNextCommitmentNumber =
- forAll (choose (0, maxCommitNum)) $ \n ->
- case commitment_number n of
- Nothing -> False
- Just cn
- | n < maxCommitNum ->
- case next_commitment_number cn of
- Nothing -> False
- Just cn' ->
- unCommitmentNumber cn' == n + 1
- | otherwise ->
- isNothing (next_commitment_number cn)
-
--- | trimmed_htlcs and untrimmed_htlcs partition the
--- input list: every HTLC is in exactly one set and
--- trimmed HTLCs have amount below the threshold.
-propTrimPartition :: Property
-propTrimPartition =
- forAll (choose (1 :: Word32, 50000)) $ \feeW ->
- forAll (choose (1, 20)) $ \numHtlcs ->
- forAll (vectorOf numHtlcs genHTLC) $ \htlcs ->
- let dust = DustLimit (Satoshi 546)
- feerate = FeeratePerKw feeW
- features = ChannelFeatures
- { cf_option_anchors = False }
- trimmed = trimmed_htlcs
- dust feerate features htlcs
- untrimmed = untrimmed_htlcs
- dust feerate features htlcs
- in length trimmed + length untrimmed
- == length htlcs
-
--- | commitment_fee is monotonically non-decreasing in
--- the number of HTLCs.
-propFeeMonotonic :: Property
-propFeeMonotonic =
- forAll (choose (1 :: Word32, 50000)) $ \feeW ->
- forAll (choose (0, 100)) $ \n ->
- let feerate = FeeratePerKw feeW
- features = ChannelFeatures
- { cf_option_anchors = False }
- fee0 = commitment_fee feerate features n
- fee1 = commitment_fee feerate features (n + 1)
- in fee1 >= fee0
-
--- | Generate a random HTLC.
-genHTLC :: Gen HTLC
-genHTLC = do
- dir <- elements [HTLCOffered, HTLCReceived]
- amt <- choose (0, 10000000)
- cltv <- choose (0, 1000000)
- pure HTLC
- { htlc_direction = dir
- , htlc_amount_msat = MilliSatoshi amt
- , htlc_payment_hash = PaymentHash
- (BS.replicate 32 0x00)
- , htlc_cltv_expiry = CltvExpiry cltv
- }
+-- 2^48-1, all from one seed), every inserted index is derivable, and
+-- stays so after a round trip through the store's entries.
+propSecretStore :: Property
+propSecretStore =
+ forAll (genBytes 32) $ \sd ->
+ forAll (choose (1, 600)) $ \n ->
+ case seed sd of
+ Nothing -> counterexample "seed" False
+ Just s ->
+ let idxs = [ i | Just i <- fmap secret_index
+ (take n [0xFFFFFFFFFFFF, 0xFFFFFFFFFFFE ..]) ]
+ secret = generate_from_seed s
+ insert st i = st >>= insert_secret (secret i) i
+ derivable st = conjoin
+ [ fmap unsecret (derive_old_secret i st)
+ === Just (unsecret (secret i))
+ | i <- idxs ]
+ in case foldl insert (Just empty_secret_store) idxs of
+ Nothing -> counterexample "insert_secret rejected" False
+ Just store -> case secret_store (un_secret_store store) of
+ Nothing -> counterexample "secret_store rejected" False
+ Just store' -> derivable store .&&. derivable store'
+
+propCommitmentNumber :: Property
+propCommitmentNumber = forAll (choose (0, maxBound)) $ \n ->
+ case commitment_number n of
+ Just cn -> n <= 0xFFFFFFFFFFFF && un_commitment_number cn == n
+ Nothing -> n > 0xFFFFFFFFFFFF
+
+propSecretIndex :: Property
+propSecretIndex = forAll (choose (0, 0xFFFFFFFFFFFF)) $ \n ->
+ case commitment_number n of
+ Nothing -> counterexample "commitment_number" False
+ Just cn ->
+ un_secret_index (commitment_secret_index cn) === 0xFFFFFFFFFFFF - n
