commit 98fd7c371aeb7c2152b33ff752533bcfe0f2f69e
parent 4908af86c5fa31f898655cfc2fad814f9f5515d2
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 15:32:09 +0400
Merge impl/modernize: port to the bolt1/bolt3 0.1.0 and tx 0.2.0 APIs
Ports ppad-bolt5 to ppad-bolt1 0.1.0, ppad-bolt3 0.1.0 and ppad-tx
0.2.0 and applies the shared bolt conventions, as version 0.1.0
(unreleased). The library's scope is being redesigned; this is a port,
not the redesign, and the README says so and lists the known gaps.
Library:
* Amounts, points and hashes are bolt1's types; ChannelFeatures is
replaced by bolt3's CommitmentFormat. ppad-bolt1 and deepseq are
new dependencies.
* The classifiers read each HTLC output's HTLC from bolt3's OutputHTLC
instead of rebuilding scripts and matching a caller-supplied HTLC
list, which they no longer take. classify_remote_commit_outputs
drops the features argument and classify_revoked_commit_outputs
the unused keys and features.
* spend_htlc_tx (Maybe) replaces spend_htlc_timeout and
spend_htlc_success, using bolt3's build_htlc_tx and htlc_to_tx in
place of the local htlc_tx_to_tx. The sweep builders share one
helper; spend_revoked_htlc_output is an alias, like
spend_htlc_output.
* Only Lightning.Protocol.BOLT5 is exposed; Internal is removed.
htlcOutputType and htlcOutputTypeWeight become htlc_output_type and
htlc_output_type_weight. NFData for every public type; spending_fee
saturates at 21 million BTC; Haddock coverage is 100%.
Tests keep the phase-1 safety net (Appendix C/F HTLC transactions,
real-witness preimage extraction, txid-based identification, shared
payment hashes, dust thresholds, anchor weights), now on the new API,
with checks on witness scripts and outpoints, bolt3-built witnesses
for extraction, bolt3's remote_htlc_sighash for the remote flag, and
negative tests for fee saturation and unbuildable HTLC txs. Trivial
properties are dropped.
Benchmarks are rewritten over Appendix C fixtures with nf, no orphan
instances and no partial functions, and cover classification,
identification, extraction and every spend builder.
Also: the spec copy is updated to lightning/bolts@1aadb719, CLAUDE.md
and AGENTS.md drop the false LLVM-flag claim, and the README example
is checked against the current API.
Diffstat:
17 files changed, 1959 insertions(+), 2197 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -4,13 +4,19 @@ Haskell implementation of BOLT #5 (Lightning Network on-chain transaction
handling).
Specification: https://github.com/lightning/bolts/blob/master/05-onchain.md
+(tracked as of lightning/bolts@1aadb719; copy in `etc/05-onchain.md`).
+
+The library's scope is being redesigned and it is not yet ready for
+release; see the README for what it does and doesn't cover.
## Project Structure
-- `lib/` - library source (Lightning.Protocol.BOLT5)
-- `test/` - tests (tasty + tasty-hunit)
+- `lib/` - library source (public API: Lightning.Protocol.BOLT5;
+ submodules are internal)
+- `test/` - tests (tasty, tasty-hunit, tasty-quickcheck), public API only;
+ BOLT #3 Appendix C/F vectors inline
- `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-bolt5.cabal` - cabal package definition
- `CLAUDE.md` / `AGENTS.md` - keep these in sync
@@ -45,6 +51,8 @@ Use only minimal external dependencies. Prefer GHC's core/boot libraries
- Test dependencies (tasty, QuickCheck, etc. for test-suite only)
- Benchmark dependencies (criterion, weigh for benchmark only)
+Current dependencies: ppad-bolt1, ppad-bolt3, ppad-sha256, ppad-tx.
+
## Code Style
### Performance
@@ -140,5 +148,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
@@ -1,4 +1,60 @@
# Changelog
-- 0.0.1 (UNRELEASED)
- * Initial release
+- 0.1.0 (UNRELEASED)
+ * The library's scope is being redesigned, and this version is not
+ yet ready for release (see the README for what it does and
+ doesn't cover).
+
+ * Ports to ppad-bolt1 0.1.0, ppad-bolt3 0.1.0 and ppad-tx 0.2.0, with
+ breaking changes:
+
+ * Amounts, points and hashes are bolt1's types (amounts are
+ bounded, with checked arithmetic), and ChannelFeatures is
+ replaced by bolt3's CommitmentFormat.
+
+ * The classifiers read each HTLC output's HTLC from bolt3's
+ OutputHTLC, and no longer take an HTLC list.
+ classify_remote_commit_outputs no longer takes the channel
+ features, and classify_revoked_commit_outputs takes only the
+ commitment and the revocation pubkey.
+
+ * spend_htlc_tx replaces spend_htlc_timeout and spend_htlc_success,
+ building the transaction with bolt3's build_htlc_tx, and fails
+ if bolt3 can't build it.
+
+ * The API is exported from Lightning.Protocol.BOLT5 alone, with
+ snake_case names (htlc_output_type, htlc_output_type_weight); the
+ Internal module is removed. Every public type has an NFData
+ instance.
+
+ * extract_preimage_offered and extract_preimage_htlc_success take
+ the HTLC's payment hash, and revoked_output_weight and
+ htlc_output_type_weight the commitment format.
+
+ * spending_fee saturates at 21 million BTC.
+
+ * Fixes preimage extraction, which never matched a real witness (one
+ ending in the witness script), and checks preimages against the
+ payment hash.
+
+ * Fixes identify_close, which compared an unsigned serialization with
+ the signed transaction found on chain; it compares txids.
+
+ * Fixes HTLC output classification, which matched outputs to HTLCs by
+ script alone, so that HTLCs sharing a payment hash were confused.
+
+ * Fixes the sighash type of the local signature on anchor-channel
+ HTLC transactions, which is SIGHASH_ALL.
+
+ * Sweeps no longer create outputs below the destination's dust
+ threshold, and anchor-channel HTLC penalty sweeps use the anchor
+ scripts' weights.
+
+ * Removes spend_revoked_batch and PenaltyContext, whose transaction
+ couldn't be signed.
+
+ * Tests check HTLC transactions and preimage extraction against the
+ BOLT #3 Appendix C and F vectors.
+
+- 0.0.1 (2026-04-18)
+ * Initial release.
diff --git a/CLAUDE.md b/CLAUDE.md
@@ -4,13 +4,19 @@ Haskell implementation of BOLT #5 (Lightning Network on-chain transaction
handling).
Specification: https://github.com/lightning/bolts/blob/master/05-onchain.md
+(tracked as of lightning/bolts@1aadb719; copy in `etc/05-onchain.md`).
+
+The library's scope is being redesigned and it is not yet ready for
+release; see the README for what it does and doesn't cover.
## Project Structure
-- `lib/` - library source (Lightning.Protocol.BOLT5)
-- `test/` - tests (tasty + tasty-hunit)
+- `lib/` - library source (public API: Lightning.Protocol.BOLT5;
+ submodules are internal)
+- `test/` - tests (tasty, tasty-hunit, tasty-quickcheck), public API only;
+ BOLT #3 Appendix C/F vectors inline
- `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-bolt5.cabal` - cabal package definition
- `CLAUDE.md` / `AGENTS.md` - keep these in sync
@@ -45,6 +51,8 @@ Use only minimal external dependencies. Prefer GHC's core/boot libraries
- Test dependencies (tasty, QuickCheck, etc. for test-suite only)
- Benchmark dependencies (criterion, weigh for benchmark only)
+Current dependencies: ppad-bolt1, ppad-bolt3, ppad-sha256, ppad-tx.
+
## Code Style
### Performance
@@ -140,5 +148,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,9 +4,50 @@
[](https://docs.ppad.tech/bolt5)
-A pure Haskell implementation of [BOLT #5][bolt5] (Lightning Network
-on-chain transaction handling), including logic for mutual close,
-unilateral close, and revoked transaction close scenarios.
+A pure Haskell implementation of parts of [BOLT #5][bolt5], the
+Lightning Network's rules for handling channel closes on chain.
+
+## Status
+
+**This library's scope is being redesigned, and it is not yet ready for
+release.** Its API will change.
+
+What it does:
+
+* Identifies our local or the remote's current commitment on chain, by
+ txid.
+* Classifies the outputs of local, remote and revoked commitment
+ transactions built by [ppad-bolt3][bolt3], reading each HTLC output's
+ HTLC from bolt3.
+* Extracts payment preimages from the witnesses of remote preimage
+ claims and HTLC-success transactions, checking them against the
+ payment hash.
+* Builds unsigned, single-input spending transactions: to_local sweeps
+ (delayed and revoked), HTLC-timeout and HTLC-success transactions
+ (via bolt3), direct HTLC spends from the remote commitment, revoked
+ HTLC sweeps, second-stage output sweeps and anchor spends. Sweeps
+ refuse to create outputs below the destination's dust threshold.
+* Provides the BOLT #5 Appendix A weights and fee calculation.
+
+What it doesn't do (known gaps):
+
+* Per-input signing data. A spending transaction describes one input
+ and the local signature only; there is no batched penalty
+ transaction.
+* Witness assembly. The caller signs and builds every witness with
+ bolt3's witness functions.
+* Classification of raw on-chain transactions. The classifiers take the
+ bolt3 commitment transaction for the state in question, which the
+ caller must rebuild (often impossible for a revoked state).
+* Revoked and mutual close detection. Only the current local and
+ remote commitments are recognised, and the resolutions for a revoked
+ commitment lack what's needed to build its spends (to_self_delay,
+ delayed pubkey, payment hashes).
+* Fee bumping. Anchor spends and anchor-channel HTLC transactions pay
+ no fee and can't take fee inputs, and penalty sweeps don't signal
+ replace-by-fee.
+* `zero_fee_commitments` (version 3 transactions and the shared P2A
+ anchor), and spending the anchor-channel to_remote output.
## Usage
@@ -14,56 +55,79 @@ A sample GHCi session:
```
> :set -XOverloadedStrings
- >
+ > import qualified Bitcoin.Prim.Tx as BT
+ > import qualified Crypto.Hash.SHA256 as SHA256
> import qualified Data.ByteString as BS
- > import qualified Lightning.Protocol.BOLT3 as BOLT3
- > import qualified Lightning.Protocol.BOLT5 as BOLT5
+ > import qualified Lightning.Protocol.BOLT1 as BOLT1
+ > import Lightning.Protocol.BOLT3
+ > import Lightning.Protocol.BOLT5
>
- > -- fee calculation using BOLT #5 Appendix A weight constants
- > let feerate = BOLT3.FeeratePerKw 5000
- > BOLT5.spending_fee feerate BOLT5.to_local_penalty_input_weight
- Satoshi 1620
- > BOLT5.spending_fee feerate BOLT5.penalty_tx_base_weight
- Satoshi 1070
+ > -- fees from the BOLT #5 Appendix A weights
+ > let feerate = FeeratePerKw 5000
+ > let weight = to_local_penalty_input_weight + penalty_tx_base_weight
+ > spending_fee feerate weight
+ Satoshi 2690
>
- > -- check if an HTLC has timed out at the current block height
- > let htlc = BOLT3.HTLC BOLT3.HTLCOffered (BOLT3.MilliSatoshi 50000000)
- > (BOLT3.PaymentHash (BS.replicate 32 0xAA))
- > (BOLT3.CltvExpiry 800000)
- > BOLT5.htlc_timed_out 799999 htlc
+ > -- whether an HTLC has timed out at a given block height
+ > let Just amt = BOLT1.milli_satoshi 50000000
+ > let Just hash = BOLT1.payment_hash (BS.replicate 32 0xaa)
+ > let htlc = HTLC HTLCOffered amt hash (CltvExpiry 800000)
+ > htlc_timed_out 799999 htlc
False
- > BOLT5.htlc_timed_out 800000 htlc
+ > htlc_timed_out 800000 htlc
True
>
- > -- extract a payment preimage from an offered HTLC witness
- > let preimage = BS.replicate 32 0xBB
- > let sig = BS.replicate 71 0xCC
- > let wit = BOLT3.Witness [sig, preimage]
- > BOLT5.extract_preimage_offered wit
- Just PaymentPreimage <redacted>
- >
- > -- construct an unsigned spending tx for a to_local output
- > let Just txid = BOLT3.mkTxId (BS.replicate 32 0x01)
- > let outpoint = BOLT3.OutPoint txid 0
- > let value = BOLT3.Satoshi 1000000
- > let revpk = BOLT3.RevocationPubkey (BOLT3.Pubkey (BS.replicate 33 0x02))
- > let delay = BOLT3.ToSelfDelay 144
- > let delayedpk = BOLT3.LocalDelayedPubkey (BOLT3.Pubkey (BS.replicate 33 0x03))
- > let dest = BOLT3.Script (BS.replicate 34 0x00)
- >
- > let stx = BOLT5.spend_to_local outpoint value revpk delay
- > delayedpk dest feerate
- > BOLT5.stx_sighash_type stx
+ > -- an unsigned sweep of our to_local output, valid after the delay
+ > let key b = BOLT1.point (BS.cons 0x02 (BS.replicate 32 b))
+ > let Just revpk = RevocationPubkey <$> key 0x01
+ > let Just delayedpk = LocalDelayedPubkey <$> key 0x02
+ > let Just txid = BT.mkTxId (BS.replicate 32 0x01)
+ > let Just value = BOLT1.satoshi 1000000
+ > let dest = Script ("\x00\x14" <> BS.replicate 20 0xcc)
+ > let delay = ToSelfDelay 144
+ > let op = BT.OutPoint txid 0
+ > let Just stx = spend_to_local op value revpk delay delayedpk dest feerate
+ > fmap BT.txout_value (BT.tx_outputs (stx_tx stx))
+ 997310 :| []
+ > fmap BT.txin_sequence (BT.tx_inputs (stx_tx stx))
+ 144 :| []
+ > stx_sighash_type stx
SIGHASH_ALL
+ > stx_input_script stx == to_local_script revpk delay delayedpk
+ True
+ >
+ > -- extract the preimage from the remote's claim of an offered HTLC
+ > let Just preimage = BOLT1.payment_preimage (BS.replicate 32 0xbb)
+ > let Just ph = BOLT1.payment_hash (SHA256.hash (BS.replicate 32 0xbb))
+ > let sig = BS.replicate 71 0xcc
+ > let wit = offered_htlc_witness_preimage sig preimage (Script "")
+ > extract_preimage_offered ph wit
+ Just (PaymentPreimage <redacted>)
+ > fmap (== preimage) (extract_preimage_offered ph wit)
+ Just True
+ > extract_preimage_offered hash wit
+ Nothing
```
## Documentation
-Haddocks are hosted at [docs.ppad.tech/bolt5][hadoc].
+Haddocks (API documentation, etc.) are hosted at
+[docs.ppad.tech/bolt5](https://docs.ppad.tech/bolt5).
+
+## Specification
+
+This library tracks BOLT #5 as of lightning/bolts commit
+[1aadb719][spec] (2026-09-21); a copy lives in `etc/`. BOLT #5
+publishes no test vectors beyond Appendix A's weights, which are
+checked; the tests also check HTLC transactions and preimage extraction
+against BOLT #3's Appendix C and F vectors.
+
+See [Status](#status) for what isn't implemented.
## Security
-This is a pre-release and makes no claims about security whatsoever.
+This library has received no security audit. It handles no secret
+material: it builds unsigned transactions and reads public witnesses.
## Development
@@ -77,12 +141,13 @@ $ nix develop
Then do e.g.:
```
-$ cabal build
-$ cabal test
-$ cabal bench
+$ cabal repl ppad-bolt5
```
+to get a REPL for the main library.
+
[bolt5]: https://github.com/lightning/bolts/blob/master/05-onchain.md
+[bolt3]: https://git.ppad.tech/bolt3
+[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/bolt5
diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Fixtures (
+ Fixtures(..)
+ , fixtures
+ ) where
+
+import qualified Bitcoin.Prim.Tx as BT
+import Control.DeepSeq (NFData, force)
+import Control.Exception (evaluate)
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString as BS
+import Data.Word (Word8, Word32, Word64)
+import GHC.Generics (Generic)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT3
+
+data Fixtures = Fixtures
+ { fx_keys :: !CommitmentKeys
+ , fx_commit :: !CommitmentTx
+ -- ^ BOLT #3 Appendix C commitment with five untrimmed HTLCs
+ , fx_other :: !CommitmentTx
+ -- ^ as 'fx_commit', with a different balance
+ , fx_raw :: !BS.ByteString
+ -- ^ serialized 'fx_commit'
+ , fx_outpoint :: !BT.OutPoint
+ , fx_value :: !BOLT1.Satoshi
+ , fx_anchor :: !BOLT1.Satoshi
+ , fx_dest :: !Script
+ , fx_feerate :: !FeeratePerKw
+ , fx_delay :: !ToSelfDelay
+ , fx_offered :: !HTLC
+ , fx_received :: !HTLC
+ , fx_htlc_ctx :: !HTLCContext
+ -- ^ for 'fx_offered'
+ , fx_hash :: !BOLT1.PaymentHash
+ -- ^ payment hash of 'fx_offered' and 'fx_received'
+ , fx_claim :: !BT.Witness
+ -- ^ remote preimage claim of an offered HTLC
+ , fx_success :: !BT.Witness
+ -- ^ HTLC-success transaction witness
+ } deriving Generic
+
+instance NFData Fixtures
+
+pt :: BS.ByteString -> Maybe BOLT1.Point
+pt h = unhex h >>= BOLT1.point
+
+-- | Decode a hex string.
+unhex :: BS.ByteString -> Maybe BS.ByteString
+unhex bs
+ | odd (BS.length bs) = Nothing
+ | otherwise = BS.pack <$> go (BS.unpack bs)
+ where
+ go (a:b:rest) = (:) <$> byte a b <*> go rest
+ go _ = Just []
+ byte a b = (\hi lo -> hi * 16 + lo) <$> nibble a <*> nibble b
+ nibble c
+ | c >= 0x30 && c <= 0x39 = Just (c - 0x30)
+ | c >= 0x61 && c <= 0x66 = Just (c - 0x57)
+ | otherwise = Nothing
+
+-- | 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
+ rev <- pt
+ "0212a140cd0c6539d07cd08dfe09984dec3251ea808b892efeac3ede9402bf2b19"
+ delayed <- pt
+ "03fd5960528dc152014952efdb702a88f71e3c1653b2314431701ec77e57fde83c"
+ local_htlc <- pt
+ "030d417a46946384f88d5f3337267c5e579765875dc4daca813e21734b140639e7"
+ remote_htlc <- pt
+ "0394854aa6eab5b2a8122cc726e9dded053a2184d88256816826d6231c068d4a5b"
+ local_pay <- pt
+ "034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa"
+ remote_pay <- pt
+ "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"
+ local_fund <- pt
+ "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"
+ remote_fund <- pt
+ "030e9f7b623d2ccc7c9bd44d66d5ce21ce504c0acf6385a132cec6d3c39fa711c1"
+ funding_txid <- BT.mkTxId =<< unhex
+ "bef67e4e2fb9ddeeb3461973cd4c62abb35050b1add772995b820b584a488489"
+ cn <- commitment_number 42
+ dust <- BOLT1.satoshi 546
+ value <- BOLT1.satoshi 100000
+ anchor <- BOLT1.satoshi 330
+ to_remote <- BOLT1.milli_satoshi 3000000000
+ h0 <- htlc HTLCReceived 1000000 500 0x00
+ h1 <- htlc HTLCReceived 2000000 501 0x01
+ h2 <- htlc HTLCOffered 2000000 502 0x02
+ h3 <- htlc HTLCOffered 3000000 503 0x03
+ h4 <- htlc HTLCReceived 4000000 504 0x04
+ preimage <- BOLT1.payment_preimage (BS.replicate 32 0x01)
+ let keys = CommitmentKeys
+ { ck_revocation_pubkey = RevocationPubkey rev
+ , ck_local_delayed = LocalDelayedPubkey delayed
+ , ck_local_htlc = LocalHtlcPubkey local_htlc
+ , ck_remote_htlc = RemoteHtlcPubkey remote_htlc
+ , ck_remote_payment = RemotePubkey remote_pay
+ , ck_local_funding = FundingPubkey local_fund
+ , ck_remote_funding = FundingPubkey remote_fund
+ }
+ ctx to_local = do
+ tl <- BOLT1.milli_satoshi to_local
+ pure CommitmentContext
+ { cc_funding_outpoint = BT.OutPoint funding_txid 0
+ , 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 = DustLimit dust
+ , cc_feerate = FeeratePerKw 0
+ , cc_format = StaticRemotekey
+ , cc_is_funder = True
+ , cc_to_local_msat = tl
+ , cc_to_remote_msat = to_remote
+ , cc_htlcs = [h0, h1, h2, h3, h4]
+ , cc_keys = keys
+ }
+ sig = BS.replicate 71 0xCC
+ script_of h = case htlc_direction h of
+ HTLCOffered -> offered_htlc_script (RevocationPubkey rev)
+ (RemoteHtlcPubkey remote_htlc) (LocalHtlcPubkey local_htlc)
+ (htlc_payment_hash h) StaticRemotekey
+ HTLCReceived -> received_htlc_script (RevocationPubkey rev)
+ (RemoteHtlcPubkey remote_htlc) (LocalHtlcPubkey local_htlc)
+ (htlc_payment_hash h) (htlc_cltv_expiry h) StaticRemotekey
+ offered = h2 { htlc_payment_hash = htlc_payment_hash h1 }
+ commit <- build_commitment_tx =<< ctx 6988000000
+ other <- build_commitment_tx =<< ctx 6987000000
+ pure Fixtures
+ { fx_keys = keys
+ , fx_commit = commit
+ , fx_other = other
+ , fx_raw = encode_commitment_tx commit
+ , fx_outpoint = BT.OutPoint funding_txid 1
+ , fx_value = value
+ , fx_anchor = anchor
+ , fx_dest = Script (BS.pack [0x00, 0x14] <> BS.replicate 20 0xCC)
+ , fx_feerate = FeeratePerKw 253
+ , fx_delay = ToSelfDelay 144
+ , fx_offered = offered
+ , fx_received = h1
+ , fx_htlc_ctx = HTLCContext
+ { hc_commitment_txid = funding_txid
+ , hc_output_index = 2
+ , hc_htlc = offered
+ , hc_to_self_delay = ToSelfDelay 144
+ , hc_feerate = FeeratePerKw 253
+ , hc_format = StaticRemotekey
+ , hc_revocation_pubkey = RevocationPubkey rev
+ , hc_local_delayed = LocalDelayedPubkey delayed
+ }
+ , fx_hash = htlc_payment_hash h1
+ , fx_claim =
+ offered_htlc_witness_preimage sig preimage (script_of offered)
+ , fx_success = htlc_success_witness sig sig preimage (script_of h1)
+ }
+ where
+ htlc :: HTLCDirection -> Word64 -> Word32 -> Word8 -> Maybe HTLC
+ 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,153 +1,69 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
module Main where
-import Bitcoin.Prim.Tx.Sighash (SighashType(..))
-import Control.DeepSeq (NFData(..))
import Criterion.Main
-import qualified Data.ByteString as BS
-import Lightning.Protocol.BOLT3 hiding
- (txout_value, txout_script)
+import Fixtures
+import Lightning.Protocol.BOLT3
import qualified Lightning.Protocol.BOLT5 as B5
--- NFData orphan instances for criterion -----------------------------
-
-instance NFData Script where
- rnf (Script bs) = rnf bs
-
-instance NFData Pubkey where
- rnf pk = rnf (unPubkey pk)
-
-instance NFData RevocationPubkey where
- rnf (RevocationPubkey x) = rnf x
-
-instance NFData LocalDelayedPubkey where
- rnf (LocalDelayedPubkey p) = rnf p
-
-instance NFData FundingPubkey where
- rnf (FundingPubkey p) = rnf p
-
-instance NFData FeeratePerKw where
- rnf (FeeratePerKw x) = rnf x
-
-instance NFData ToSelfDelay where
- rnf (ToSelfDelay 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
-
-instance NFData SighashType
-
-instance NFData B5.OutputResolution where
- rnf B5.Resolved = ()
- rnf (B5.Revoke rk) = rnf rk
- rnf _ = ()
-
-instance NFData B5.HTLCOutputType where
- rnf (B5.HTLCOfferedOutput e) = rnf e
- rnf (B5.HTLCReceivedOutput e) = rnf e
-
-instance NFData B5.UnresolvedOutput where
- rnf (B5.UnresolvedOutput op v t) =
- rnf op `seq` rnf v `seq` rnf t
-
-instance NFData B5.RevokedOutputType where
- rnf B5.RevokedToLocal = ()
- rnf (B5.RevokedHTLC h) = rnf h
-
-instance NFData B5.RevokedOutput where
- rnf (B5.RevokedOutput op v t) =
- rnf op `seq` rnf v `seq` rnf t
-
-instance NFData B5.SpendingTx where
- rnf (B5.SpendingTx tx scr val sh) =
- rnf tx `seq` rnf scr `seq` rnf val `seq` rnf sh
-
main :: IO ()
-main = defaultMain [
- spend_benchmarks
- , classify_benchmarks
- ]
-
--- fixtures -----------------------------------------------------------
-
-dummyPubkey :: Pubkey
-dummyPubkey = case pubkey (BS.pack (0x02 : replicate 32 0x01)) of
- Just pk -> pk
- Nothing -> error "impossible"
-
-dummyTxId :: TxId
-dummyTxId = case mkTxId (BS.replicate 32 0x00) of
- Just tid -> tid
- Nothing -> error "impossible"
-
-dummyOutPoint :: OutPoint
-dummyOutPoint = OutPoint dummyTxId 0
-
-dummyRevPk :: RevocationPubkey
-dummyRevPk = RevocationPubkey dummyPubkey
-
-dummyDelayedPk :: LocalDelayedPubkey
-dummyDelayedPk = LocalDelayedPubkey dummyPubkey
-
-dummyFundPk :: FundingPubkey
-dummyFundPk = FundingPubkey dummyPubkey
-
-dummyDest :: Script
-dummyDest = Script $ BS.pack [0x00, 0x14] <>
- BS.replicate 20 0xCC
-
-dummyFeerate :: FeeratePerKw
-dummyFeerate = FeeratePerKw 253
-
-dummyDelay :: ToSelfDelay
-dummyDelay = ToSelfDelay 144
-
--- benchmarks ---------------------------------------------------------
-
-spend_benchmarks :: Benchmark
-spend_benchmarks = bgroup "spend" [
- bench "spend_to_local" $
- nf (\v -> B5.spend_to_local
- dummyOutPoint v dummyRevPk dummyDelay
- dummyDelayedPk dummyDest dummyFeerate)
- (Satoshi 100000)
-
- , bench "spend_revoked_to_local" $
- nf (\v -> B5.spend_revoked_to_local
- dummyOutPoint v dummyRevPk dummyDelay
- dummyDelayedPk dummyDest dummyFeerate)
- (Satoshi 100000)
-
- , bench "spend_anchor_owner" $
- nf (\v -> B5.spend_anchor_owner
- dummyOutPoint v dummyFundPk dummyDest)
- (Satoshi 330)
-
- ]
-
-classify_benchmarks :: Benchmark
-classify_benchmarks = bgroup "classify" [
- bench "spending_fee" $
- nf (B5.spending_fee dummyFeerate) 538
-
- , bench "htlc_timed_out" $
- nf (B5.htlc_timed_out 500001)
- (HTLC HTLCOffered (MilliSatoshi 1000000)
- dummyPaymentHash (CltvExpiry 500000))
- ]
- where
- dummyPaymentHash = case paymentHash
- (BS.replicate 32 0xAA) of
- Just ph -> ph
- Nothing -> error "impossible"
+main = do
+ fx <- fixtures
+ let keys = fx_keys fx
+ revpk = ck_revocation_pubkey keys
+ delayed = ck_local_delayed keys
+ defaultMain [
+ bgroup "detect" [
+ bench "identify_close" $
+ nf (B5.identify_close (fx_other fx) (fx_commit fx)) (fx_raw fx)
+ , bench "classify_local_commit_outputs" $
+ nf (\c -> B5.classify_local_commit_outputs c keys (fx_delay fx)
+ StaticRemotekey)
+ (fx_commit fx)
+ , bench "classify_remote_commit_outputs" $
+ nf (\c -> B5.classify_remote_commit_outputs c keys) (fx_commit fx)
+ , bench "classify_revoked_commit_outputs" $
+ nf (\c -> B5.classify_revoked_commit_outputs c revpk)
+ (fx_commit fx)
+ , bench "extract_preimage_offered" $
+ nf (B5.extract_preimage_offered (fx_hash fx)) (fx_claim fx)
+ , bench "extract_preimage_htlc_success" $
+ nf (B5.extract_preimage_htlc_success (fx_hash fx)) (fx_success fx)
+ , bench "htlc_timed_out" $
+ nf (B5.htlc_timed_out 500001) (fx_offered fx)
+ ]
+ , bgroup "spend" [
+ bench "spend_to_local" $
+ nf (\v -> B5.spend_to_local (fx_outpoint fx) v revpk (fx_delay fx)
+ delayed (fx_dest fx) (fx_feerate fx))
+ (fx_value fx)
+ , bench "spend_htlc_tx" $
+ nf (B5.spend_htlc_tx (fx_htlc_ctx fx)) keys
+ , bench "spend_remote_htlc_timeout" $
+ nf (\v -> B5.spend_remote_htlc_timeout (fx_outpoint fx) v
+ (fx_received fx) keys StaticRemotekey (fx_dest fx)
+ (fx_feerate fx))
+ (fx_value fx)
+ , bench "spend_remote_htlc_preimage" $
+ nf (\v -> B5.spend_remote_htlc_preimage (fx_outpoint fx) v
+ (fx_offered fx) keys StaticRemotekey (fx_dest fx)
+ (fx_feerate fx))
+ (fx_value fx)
+ , bench "spend_revoked_to_local" $
+ nf (\v -> B5.spend_revoked_to_local (fx_outpoint fx) v revpk
+ (fx_delay fx) delayed (fx_dest fx) (fx_feerate fx))
+ (fx_value fx)
+ , bench "spend_revoked_htlc" $
+ nf (\v -> B5.spend_revoked_htlc (fx_outpoint fx) v
+ (B5.HTLCReceivedOutput (CltvExpiry 501)) revpk keys
+ StaticRemotekey (fx_hash fx) (fx_dest fx) (fx_feerate fx))
+ (fx_value fx)
+ , bench "spend_anchor_owner" $
+ nf (\v -> B5.spend_anchor_owner (fx_outpoint fx) v
+ (ck_local_funding keys) (fx_dest fx))
+ (fx_anchor fx)
+ ]
+ , bgroup "fees" [
+ bench "spending_fee" $
+ nf (B5.spending_fee (fx_feerate fx)) 538
+ ]
+ ]
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -1,121 +1,50 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
module Main where
-import Bitcoin.Prim.Tx.Sighash (SighashType(..))
-import Control.DeepSeq (NFData(..))
-import qualified Data.ByteString as BS
-import Lightning.Protocol.BOLT3 hiding
- (txout_value, txout_script)
+import Fixtures
+import Lightning.Protocol.BOLT3
import qualified Lightning.Protocol.BOLT5 as B5
import Weigh
--- NFData orphan instances for weigh ---------------------------------
-
-instance NFData Script where
- rnf (Script bs) = rnf bs
-
-instance NFData Pubkey where
- rnf pk = rnf (unPubkey pk)
-
-instance NFData RevocationPubkey where
- rnf (RevocationPubkey x) = rnf x
-
-instance NFData LocalDelayedPubkey where
- rnf (LocalDelayedPubkey p) = rnf p
-
-instance NFData FundingPubkey where
- rnf (FundingPubkey p) = rnf p
-
-instance NFData FeeratePerKw where
- rnf (FeeratePerKw x) = rnf x
-
-instance NFData ToSelfDelay where
- rnf (ToSelfDelay x) = rnf x
-
-instance NFData CltvExpiry where
- rnf (CltvExpiry x) = rnf x
-
-instance NFData SighashType
-
-instance NFData B5.OutputResolution where
- rnf B5.Resolved = ()
- rnf (B5.Revoke rk) = rnf rk
- rnf _ = ()
-
-instance NFData B5.HTLCOutputType where
- rnf (B5.HTLCOfferedOutput e) = rnf e
- rnf (B5.HTLCReceivedOutput e) = rnf e
-
-instance NFData B5.UnresolvedOutput where
- rnf (B5.UnresolvedOutput op v t) =
- rnf op `seq` rnf v `seq` rnf t
-
-instance NFData B5.RevokedOutputType where
- rnf B5.RevokedToLocal = ()
- rnf (B5.RevokedHTLC h) = rnf h
-
-instance NFData B5.RevokedOutput where
- rnf (B5.RevokedOutput op v t) =
- rnf op `seq` rnf v `seq` rnf t
-
-instance NFData B5.SpendingTx where
- rnf (B5.SpendingTx tx scr val sh) =
- rnf tx `seq` rnf scr `seq` rnf val `seq` rnf sh
-
-- note that 'weigh' doesn't work properly in a repl
main :: IO ()
-main = mainWith $ do
- spend_weights
-
--- fixtures -----------------------------------------------------------
-
-dummyPubkey :: Pubkey
-dummyPubkey = case pubkey (BS.pack (0x02 : replicate 32 0x01)) of
- Just pk -> pk
- Nothing -> error "impossible"
-
-dummyTxId :: TxId
-dummyTxId = case mkTxId (BS.replicate 32 0x00) of
- Just tid -> tid
- Nothing -> error "impossible"
-
-dummyOutPoint :: OutPoint
-dummyOutPoint = OutPoint dummyTxId 0
-
-dummyRevPk :: RevocationPubkey
-dummyRevPk = RevocationPubkey dummyPubkey
-
-dummyDelayedPk :: LocalDelayedPubkey
-dummyDelayedPk = LocalDelayedPubkey dummyPubkey
-
-dummyFundPk :: FundingPubkey
-dummyFundPk = FundingPubkey dummyPubkey
-
-dummyDest :: Script
-dummyDest = Script $ BS.pack [0x00, 0x14] <>
- BS.replicate 20 0xCC
-
-dummyFeerate :: FeeratePerKw
-dummyFeerate = FeeratePerKw 253
-
-dummyDelay :: ToSelfDelay
-dummyDelay = ToSelfDelay 144
-
--- weights ------------------------------------------------------------
-
-spend_weights :: Weigh ()
-spend_weights = wgroup "spend" $ do
- func "spend_to_local"
- (\v -> B5.spend_to_local
- dummyOutPoint v dummyRevPk dummyDelay
- dummyDelayedPk dummyDest dummyFeerate)
- (Satoshi 100000)
-
- func "spend_anchor_owner"
- (\v -> B5.spend_anchor_owner
- dummyOutPoint v dummyFundPk dummyDest)
- (Satoshi 330)
+main = do
+ fx <- fixtures
+ let keys = fx_keys fx
+ revpk = ck_revocation_pubkey keys
+ delayed = ck_local_delayed keys
+ mainWith $ do
+ wgroup "detect" $ do
+ func "identify_close"
+ (B5.identify_close (fx_other fx) (fx_commit fx)) (fx_raw fx)
+ func "classify_local_commit_outputs"
+ (\c -> B5.classify_local_commit_outputs c keys (fx_delay fx)
+ StaticRemotekey)
+ (fx_commit fx)
+ func "classify_remote_commit_outputs"
+ (\c -> B5.classify_remote_commit_outputs c keys) (fx_commit fx)
+ func "classify_revoked_commit_outputs"
+ (\c -> B5.classify_revoked_commit_outputs c revpk) (fx_commit fx)
+ func "extract_preimage_offered"
+ (B5.extract_preimage_offered (fx_hash fx)) (fx_claim fx)
+ func "extract_preimage_htlc_success"
+ (B5.extract_preimage_htlc_success (fx_hash fx)) (fx_success fx)
+ wgroup "spend" $ do
+ func "spend_to_local"
+ (\v -> B5.spend_to_local (fx_outpoint fx) v revpk (fx_delay fx)
+ delayed (fx_dest fx) (fx_feerate fx))
+ (fx_value fx)
+ func "spend_htlc_tx" (B5.spend_htlc_tx (fx_htlc_ctx fx)) keys
+ func "spend_remote_htlc_timeout"
+ (\v -> B5.spend_remote_htlc_timeout (fx_outpoint fx) v
+ (fx_received fx) keys StaticRemotekey (fx_dest fx)
+ (fx_feerate fx))
+ (fx_value fx)
+ func "spend_revoked_htlc"
+ (\v -> B5.spend_revoked_htlc (fx_outpoint fx) v
+ (B5.HTLCReceivedOutput (CltvExpiry 501)) revpk keys
+ StaticRemotekey (fx_hash fx) (fx_dest fx) (fx_feerate fx))
+ (fx_value fx)
+ func "spend_anchor_owner"
+ (\v -> B5.spend_anchor_owner (fx_outpoint fx) v
+ (ck_local_funding keys) (fx_dest fx))
+ (fx_anchor fx)
diff --git a/etc/05-onchain.md b/etc/05-onchain.md
@@ -41,6 +41,7 @@ encounters any of the above situations, on-chain.
* [Penalty Transactions Weight Calculation](#penalty-transactions-weight-calculation)
* [Generation of HTLC Transactions](#generation-of-htlc-transactions)
* [General Requirements](#general-requirements)
+ * [Limitations of v3 transactions](#limitations-of-v3-transactions)
* [Appendix A: Expected Weights](#appendix-a-expected-weights)
* [Expected Weight of the `to_local` Penalty Transaction Witness](#expected-weight-of-the-to-local-penalty-transaction-witness)
* [Expected Weight of the `offered_htlc` Penalty Transaction Witness](#expected-weight-of-the-offered-htlc-penalty-transaction-witness)
@@ -90,7 +91,7 @@ trigger any action.
# Commitment Transaction
The local and remote nodes each hold a *commitment transaction*. Each of these
-commitment transactions has up to six types of outputs:
+commitment transactions has up to seven types of outputs:
1. _local node's main output_: Zero or one output, to pay to the *local node's*
delayed_pubkey.
@@ -100,9 +101,10 @@ delayed_pubkey.
funding_pubkey.
4. _remote node's anchor output_: one output paying to the *remote node's*
funding_pubkey.
-5. _local node's offered HTLCs_: Zero or more pending payments (*HTLCs*), to pay
+5. _shared anchor_: one output spendable by anyone (pay-to-anchor).
+6. _local node's offered HTLCs_: Zero or more pending payments (*HTLCs*), to pay
the *remote node* in return for a payment preimage.
-6. _remote node's offered HTLCs_: Zero or more pending payments (*HTLCs*), to
+7. _remote node's offered HTLCs_: Zero or more pending payments (*HTLCs*), to
pay the *local node* in return for a payment preimage.
To incentivize the local and remote nodes to cooperate, an `OP_CHECKSEQUENCEVERIFY`
@@ -148,10 +150,14 @@ A node:
- otherwise:
- MUST broadcast the *last commitment transaction*, for which it has a
signature, to perform a *unilateral close*.
- - MUST spend any `to_local_anchor` output, providing sufficient fees as incentive to include the commitment transaction in a block.
- Special care must be taken when spending to a third-party, because this re-introduces the vulnerability that was
- addressed by adding the CSV delay to the non-anchor outputs.
- - SHOULD use [replace-by-fee](https://github.com/bitcoin/bips/blob/master/bip-0125.mediawiki) or other mechanism on the spending transaction if it proves insufficient for timely inclusion in a block.
+ - MUST spend any `to_local_anchor` or `shared_anchor` output, providing sufficient fees
+ as incentive to include the commitment transaction in a block. For `to_local_anchor`,
+ special care must be taken when spending to a third-party, because this re-introduces
+ the pinning vulnerability that was addressed by adding the CSV delay to the non-anchor
+ outputs.
+ - SHOULD use [replace-by-fee](https://github.com/bitcoin/bips/blob/master/bip-0125.mediawiki)
+ or other mechanism on the spending transaction if it proves insufficient for timely
+ inclusion in a block.
## Rationale
@@ -166,10 +172,10 @@ need not consume resources monitoring the channel state.
There exists a bias towards preferring mutual closes over unilateral closes,
because outputs of the former are unencumbered by a delay and are directly
spendable by wallets. In addition, mutual close fees tend to be less exaggerated
-than those of commitment transactions (or in the case of `option_anchors`,
-the commitment transaction may require a child transaction to cause it to be mined). So, the only reason not to use the
-signature from `closing_signed` would be if the fee offered was too small for
-it to be processed.
+than those of commitment transactions (or in the case of commitments using anchor
+outputs, the commitment transaction may require a child transaction to cause it
+to be mined). So, the only reason not to use the mutual close transaction would
+be if the fee offered was too small for it to be processed.
# Mutual Close Handling
@@ -279,8 +285,7 @@ The local HTLC-timeout transaction needs to be used to time out the HTLC (to
prevent the remote node fulfilling it and claiming the funds) before the
local node can back-fail any corresponding incoming HTLC, using
`update_fail_htlc` (presumably with reason `permanent_channel_failure`), as
-detailed in
-[BOLT #2](02-peer-protocol.md#forwarding-htlcs).
+detailed in [BOLT #2](02-peer-protocol.md#forwarding-htlcs).
If the incoming HTLC is also on-chain, a node must simply wait for it to
timeout: there is no way to signal early failure.
@@ -537,8 +542,13 @@ A local node:
using the revocation private key.
- SHOULD extract the payment preimage from the transaction input witness, if
it's not already known.
- - if `option_anchors` applies:
+ - if `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` is used for HTLC transactions
+ (i.e. `option_anchors` or `zero_fee_commitments` applies):
- MAY use a single transaction to *resolve* all the outputs.
+ - If `zero_fee_commitments` applies:
+ - MUST NOT exceed the 10kvB limit of v3 transactions, otherwise the
+ transaction may not reach miners (as explained in the section
+ about [v3 limitations](#limitations-of-v3-transactions) below).
- if confirmation doesn't happen before reaching `security_delay` blocks from
expiry:
- SHOULD *resolve* revoked outputs in their own, separate penalty transactions. A previous
@@ -554,8 +564,9 @@ A single transaction that resolves all the outputs will be under the
standard size limit because of the 483 HTLC-per-party limit (see
[BOLT #2](02-peer-protocol.md#the-open_channel-message)).
-Note: if `option_anchors` applies, the cheating node can pin spends of its
-HTLC-timeout/HTLC-success outputs thanks to SIGHASH_SINGLE malleability.
+Note: when `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` is used for HTLC transactions
+(i.e. `option_anchors` or `zero_fee_commitments`), the cheating node can pin
+spends of its HTLC-timeout/HTLC-success outputs.
Using a single penalty transaction for all revoked outputs is thus unsafe as it
could be blocked to propagate long enough for the _local node's `to_local` output_ 's
relative locktime to expire and the cheating party escaping the penalty on this
@@ -610,25 +621,25 @@ Note: even if the `to_remote` output is not swept, the resulting
# Generation of HTLC Transactions
-If `option_anchors` does not apply to the commitment transaction, then
-HTLC-timeout and HTLC-success transactions are complete transactions with
-(hopefully!) reasonable fees and must be used directly.
+If `option_anchors` and `zero_fee_commitments` do not apply, then HTLC-timeout
+and HTLC-success transactions are signed with `SIGHASH_ALL` and are complete
+transactions with (hopefully!) reasonable fees and must be used directly.
Otherwise, `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` MUST be used on the
-HTLC signatures received from the peer, as this allows HTLC transactions to be combined with
-other transactions. The local signature MUST use `SIGHASH_ALL`, otherwise
-anyone can attach additional inputs and outputs to the tx.
+HTLC signatures received from the peer, as this allows HTLC transactions to be
+combined with other transactions. The local signature MUST use `SIGHASH_ALL`,
+otherwise anyone can attach additional inputs and outputs to the tx.
-If `option_anchors` applies, then the HTLC-timeout and
-HTLC-success transactions are signed with the input and output having the same
-value. This means they have a zero fee and MUST be combined with other inputs
-to arrive at a reasonable fee.
+If `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` is used, then the HTLC-timeout and
+HTLC-success transactions are signed with the input and output having the
+same value. This means they have a zero fee and MUST be combined with other
+inputs to arrive at a reasonable fee.
## Requirements
A node which broadcasts an HTLC-success or HTLC-timeout transaction for a
commitment transaction:
- - if `option_anchors` applies:
+ - if `SIGHASH_SINGLE|SIGHASH_ANYONECANPAY` is used:
- MUST combine it with inputs contributing sufficient fee to ensure timely
inclusion in a block.
- MAY combine it with other transactions.
@@ -649,6 +660,20 @@ A node:
- Note: watching for mempool transactions should result in lower latency
HTLC redemptions.
+## Limitations of v3 transactions
+
+When `zero_fee_commitments` applies, we use v3 transactions, also known as
+TRUC transactions, which have different policy rules than v2 transactions.
+
+Implementers should read [BIP-431](https://github.com/bitcoin/bips/blob/master/bip-0431.mediawiki)
+to make sure they don't create transactions that aren't relayed by bitcoin
+nodes.
+
+The main limitation compared to v2 transactions (but not the only one) is
+that transactions are restricted to 10kvB (instead of 400kvB): when batching
+transactions (e.g. HTLC transactions), nodes MUST NOT exceed that limit,
+otherwise the transaction will not reach miners and funds may be at risk.
+
# Appendix A: Expected Weights
## Expected Weight of the `to_local` Penalty Transaction Witness
diff --git a/flake.lock b/flake.lock
@@ -37,21 +37,18 @@
"ppad-base16": {
"inputs": {
"flake-utils": [
- "ppad-bolt3",
"ppad-bolt1",
"ppad-base16",
"ppad-nixpkgs",
"flake-utils"
],
"nixpkgs": [
- "ppad-bolt3",
"ppad-bolt1",
"ppad-base16",
"ppad-nixpkgs",
"nixpkgs"
],
"ppad-nixpkgs": [
- "ppad-bolt3",
"ppad-bolt1",
"ppad-nixpkgs"
]
@@ -210,29 +207,29 @@
"ppad-bolt1": {
"inputs": {
"flake-utils": [
- "ppad-bolt3",
"ppad-bolt1",
"ppad-nixpkgs",
"flake-utils"
],
"nixpkgs": [
- "ppad-bolt3",
"ppad-bolt1",
"ppad-nixpkgs",
"nixpkgs"
],
"ppad-base16": "ppad-base16",
+ "ppad-bolt9": [
+ "ppad-bolt9"
+ ],
"ppad-nixpkgs": [
- "ppad-bolt3",
"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"
},
@@ -254,7 +251,15 @@
"ppad-nixpkgs",
"nixpkgs"
],
- "ppad-bolt1": "ppad-bolt1",
+ "ppad-bolt1": [
+ "ppad-bolt1"
+ ],
+ "ppad-bolt9": [
+ "ppad-bolt9"
+ ],
+ "ppad-fixed": [
+ "ppad-fixed"
+ ],
"ppad-nixpkgs": [
"ppad-nixpkgs"
],
@@ -272,11 +277,11 @@
]
},
"locked": {
- "lastModified": 1783709568,
- "narHash": "sha256-RA4jdJkMZatx9IZ6ri2XqQao24GQ1ZwxWH7ZKKSkJ14=",
+ "lastModified": 1791630066,
+ "narHash": "sha256-dEMBydCq9B3nZnpK97Na43IqT+c841nTdFPK5b/PoLw=",
"ref": "master",
- "rev": "523aa8b203c356019e543a4e01bba28450d35020",
- "revCount": 54,
+ "rev": "b6b3c35e24b99b2538475f27cff76d0556993160",
+ "revCount": 70,
"type": "git",
"url": "git://git.ppad.tech/bolt3.git"
},
@@ -286,31 +291,59 @@
"url": "git://git.ppad.tech/bolt3.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": [
- "ppad-secp256k1",
"ppad-fixed",
"ppad-nixpkgs",
"flake-utils"
],
"nixpkgs": [
- "ppad-secp256k1",
"ppad-fixed",
"ppad-nixpkgs",
"nixpkgs"
],
"ppad-nixpkgs": [
- "ppad-secp256k1",
"ppad-nixpkgs"
]
},
"locked": {
- "lastModified": 1780868194,
- "narHash": "sha256-Yd3J3gCNLE2vZVMMg1fD7aVpPySIbFqxtwskU6nD/mc=",
+ "lastModified": 1785603497,
+ "narHash": "sha256-rF8KdVJ+VwUT2bEfCLZMPc05rUclr0wN2uOTYvd3z7g=",
"ref": "master",
- "rev": "74ebe44f818353129c5ec973a55c8bc487e2fd7b",
- "revCount": 297,
+ "rev": "e303bda7578385f488c2f23baa2e1a6a2b0b2aaf",
+ "revCount": 305,
"type": "git",
"url": "git://git.ppad.tech/fixed.git"
},
@@ -430,7 +463,9 @@
"nixpkgs"
],
"ppad-base16": "ppad-base16_3",
- "ppad-fixed": "ppad-fixed",
+ "ppad-fixed": [
+ "ppad-fixed"
+ ],
"ppad-hmac-drbg": "ppad-hmac-drbg",
"ppad-nixpkgs": [
"ppad-nixpkgs"
@@ -441,11 +476,11 @@
"ppad-sha512": "ppad-sha512"
},
"locked": {
- "lastModified": 1783709454,
- "narHash": "sha256-6BknM38fe2vFwWWRsBeebTt+hKwaZL0ib89XqPO6Y6U=",
+ "lastModified": 1785605654,
+ "narHash": "sha256-VDNnKXmJIZZ/3u7Tf1rK93GR4x7OiAadqykhqCwkHb4=",
"ref": "master",
- "rev": "bc0d3792bcea0475ed2e4879747dbd0e0e6db3e7",
- "revCount": 266,
+ "rev": "fdb80d54b86c61bd1a15e2e8db351091d02c89ee",
+ "revCount": 280,
"type": "git",
"url": "git://git.ppad.tech/secp256k1.git"
},
@@ -546,11 +581,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"
},
@@ -570,7 +605,10 @@
"ppad-nixpkgs",
"nixpkgs"
],
+ "ppad-bolt1": "ppad-bolt1",
"ppad-bolt3": "ppad-bolt3",
+ "ppad-bolt9": "ppad-bolt9",
+ "ppad-fixed": "ppad-fixed",
"ppad-nixpkgs": "ppad-nixpkgs",
"ppad-ripemd160": "ppad-ripemd160",
"ppad-secp256k1": "ppad-secp256k1",
diff --git a/flake.nix b/flake.nix
@@ -13,12 +13,19 @@
ref = "master";
inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
};
+ ppad-fixed = {
+ type = "git";
+ url = "git://git.ppad.tech/fixed.git";
+ ref = "master";
+ inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
+ };
ppad-secp256k1 = {
type = "git";
url = "git://git.ppad.tech/secp256k1.git";
ref = "master";
inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
inputs.ppad-sha256.follows = "ppad-sha256";
+ inputs.ppad-fixed.follows = "ppad-fixed";
};
ppad-ripemd160 = {
type = "git";
@@ -33,11 +40,27 @@
inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
inputs.ppad-sha256.follows = "ppad-sha256";
};
+ ppad-bolt9 = {
+ type = "git";
+ url = "git://git.ppad.tech/bolt9.git";
+ ref = "master";
+ inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
+ };
+ ppad-bolt1 = {
+ type = "git";
+ url = "git://git.ppad.tech/bolt1.git";
+ ref = "master";
+ inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
+ inputs.ppad-bolt9.follows = "ppad-bolt9";
+ };
ppad-bolt3 = {
type = "git";
url = "git://git.ppad.tech/bolt3.git";
ref = "master";
inputs.ppad-nixpkgs.follows = "ppad-nixpkgs";
+ inputs.ppad-bolt1.follows = "ppad-bolt1";
+ inputs.ppad-bolt9.follows = "ppad-bolt9";
+ inputs.ppad-fixed.follows = "ppad-fixed";
inputs.ppad-sha256.follows = "ppad-sha256";
inputs.ppad-secp256k1.follows = "ppad-secp256k1";
inputs.ppad-ripemd160.follows = "ppad-ripemd160";
@@ -48,8 +71,8 @@
};
outputs = { self, nixpkgs, flake-utils, ppad-nixpkgs
- , ppad-sha256, ppad-secp256k1, ppad-ripemd160
- , ppad-tx, ppad-bolt3 }:
+ , ppad-sha256, ppad-fixed, ppad-secp256k1, ppad-ripemd160
+ , ppad-tx, ppad-bolt9, ppad-bolt1, ppad-bolt3 }:
flake-utils.lib.eachDefaultSystem (system:
let
lib = "ppad-bolt5";
@@ -65,6 +88,12 @@
(hlib.enableCabalFlag sha256 "llvm")
[ llvm clang ];
+ fixed = ppad-fixed.packages.${system}.default;
+ fixed-llvm =
+ hlib.addBuildTools
+ (hlib.enableCabalFlag fixed "llvm")
+ [ llvm clang ];
+
secp256k1 = ppad-secp256k1.packages.${system}.default;
secp256k1-llvm =
hlib.addBuildTools
@@ -83,13 +112,18 @@
(hlib.enableCabalFlag tx "llvm")
[ llvm clang ];
+ bolt9 = ppad-bolt9.packages.${system}.default;
+ bolt1 = ppad-bolt1.packages.${system}.default;
bolt3 = ppad-bolt3.packages.${system}.default;
hpkgs = pkgs.haskell.packages.ghc910.extend (new: old: {
ppad-sha256 = sha256-llvm;
+ ppad-fixed = fixed-llvm;
ppad-secp256k1 = secp256k1-llvm;
ppad-ripemd160 = ripemd160-llvm;
ppad-tx = tx-llvm;
+ ppad-bolt9 = bolt9;
+ ppad-bolt1 = bolt1;
ppad-bolt3 = bolt3;
${lib} = new.callCabal2nix lib ./. { };
});
diff --git a/lib/Lightning/Protocol/BOLT5.hs b/lib/Lightning/Protocol/BOLT5.hs
@@ -9,84 +9,50 @@
-- On-chain transaction handling for the Lightning Network, per
-- [BOLT #5](https://github.com/lightning/bolts/blob/master/05-onchain.md).
--
--- This module implements the logic for handling channel closures:
---
--- * Mutual close - cooperative closure agreed by both parties
--- * Unilateral close - one party publishes their commitment
--- transaction
--- * Revoked transaction close - penalty for publishing old state
+-- This library's scope is being redesigned, and it is not yet ready
+-- for release. It covers unilateral closes only partially: it
+-- identifies a local or remote commitment on chain, classifies its
+-- outputs, extracts preimages from HTLC spends, and builds unsigned,
+-- single-input spending transactions. It doesn't detect mutual or
+-- revoked closes, assemble witnesses, or attach fee inputs to anchor
+-- spends and zero-fee HTLC transactions.
--
-- = Design
--
--- This is a stateless toolkit of pure functions. The caller
--- manages channel state (which outputs are resolved, current
--- block height, etc.) and provides explicit inputs. Functions
--- produce unsigned 'SpendingTx' values; the caller signs and
--- assembles witnesses using bolt3 constructors.
+-- This is a stateless toolkit of pure functions. The caller manages
+-- channel state (which outputs are resolved, the current block
+-- height, etc.) and provides explicit inputs. Commitment
+-- transactions are those built by ppad-bolt3, and amounts are
+-- ppad-bolt1's. Functions produce unsigned t'SpendingTx' values; the
+-- caller signs them and assembles witnesses with bolt3's witness
+-- functions.
--
-- = Usage
--
-- @
+-- import qualified Lightning.Protocol.BOLT1 as BOLT1
-- import Lightning.Protocol.BOLT3
-- import Lightning.Protocol.BOLT5
--
--- -- Classify outputs of our local commitment
--- let outputs = classify_local_commit_outputs
--- commitTx keys delay features htlcs
+-- -- classify the outputs of our local commitment
+-- let outputs = classify_local_commit_outputs commit keys delay fmt
--
--- -- For each unresolved output, construct spending tx
+-- -- for each unresolved output, build a spending transaction
-- case uo_type output of
-- SpendToLocal delay revpk delayedpk ->
--- spend_to_local (uo_outpoint output)
--- (uo_value output) revpk delay delayedpk
--- destScript feerate
+-- spend_to_local (uo_outpoint output) (uo_value output)
+-- revpk delay delayedpk dest feerate
-- ...
-- @
module Lightning.Protocol.BOLT5 (
- -- * Types
- -- ** Close identification
- CloseType(..)
-
- -- ** Output classification
- , UnresolvedOutput(..)
- , OutputResolution(..)
-
- -- ** HTLC output type
- , HTLCOutputType(..)
- , htlcOutputType
- , htlcOutputTypeWeight
-
- -- ** Spending transactions
- , SpendingTx(..)
-
- -- ** Revoked outputs
- , RevokedOutput(..)
- , RevokedOutputType(..)
- , revoked_output_weight
-
- -- * Weight constants (Appendix A)
- , to_local_penalty_witness_weight
- , offered_htlc_penalty_witness_weight
- , accepted_htlc_penalty_witness_weight
- , offered_htlc_penalty_witness_weight_anchors
- , accepted_htlc_penalty_witness_weight_anchors
- , to_local_penalty_input_weight
- , offered_htlc_penalty_input_weight
- , accepted_htlc_penalty_input_weight
- , offered_htlc_penalty_input_weight_anchors
- , accepted_htlc_penalty_input_weight_anchors
- , to_remote_input_weight
- , penalty_tx_base_weight
- , max_standard_weight
-
- -- * Fee calculation
- , spending_fee
-
-- * Close identification
+ CloseType(..)
, identify_close
-- * Output classification
+ , UnresolvedOutput(..)
+ , OutputResolution(..)
, classify_local_commit_outputs
, classify_remote_commit_outputs
, classify_revoked_commit_outputs
@@ -98,11 +64,12 @@ module Lightning.Protocol.BOLT5 (
-- * Timeout check
, htlc_timed_out
- -- * Spending transaction construction
+ -- * Spending transactions
+ , SpendingTx(..)
+
-- ** Local commitment
, spend_to_local
- , spend_htlc_timeout
- , spend_htlc_success
+ , spend_htlc_tx
, spend_htlc_output
-- ** Remote commitment
@@ -117,8 +84,34 @@ module Lightning.Protocol.BOLT5 (
-- ** Anchor outputs
, spend_anchor_owner
, spend_anchor_anyone
+
+ -- * Revoked outputs
+ , HTLCOutputType(..)
+ , htlc_output_type
+ , RevokedOutput(..)
+ , RevokedOutputType(..)
+
+ -- * Weights (Appendix A)
+ , revoked_output_weight
+ , htlc_output_type_weight
+ , to_local_penalty_witness_weight
+ , offered_htlc_penalty_witness_weight
+ , accepted_htlc_penalty_witness_weight
+ , offered_htlc_penalty_witness_weight_anchors
+ , accepted_htlc_penalty_witness_weight_anchors
+ , to_local_penalty_input_weight
+ , offered_htlc_penalty_input_weight
+ , accepted_htlc_penalty_input_weight
+ , offered_htlc_penalty_input_weight_anchors
+ , accepted_htlc_penalty_input_weight_anchors
+ , to_remote_input_weight
+ , penalty_tx_base_weight
+ , max_standard_weight
+
+ -- * Fees
+ , spending_fee
) where
-import Lightning.Protocol.BOLT5.Types
import Lightning.Protocol.BOLT5.Detect
import Lightning.Protocol.BOLT5.Spend
+import Lightning.Protocol.BOLT5.Types
diff --git a/lib/Lightning/Protocol/BOLT5/Detect.hs b/lib/Lightning/Protocol/BOLT5/Detect.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
-- |
@@ -27,11 +27,14 @@ module Lightning.Protocol.BOLT5.Detect (
, htlc_timed_out
) where
+import Bitcoin.Prim.Tx (OutPoint(..), TxId, Witness(..))
import qualified Bitcoin.Prim.Tx as BT
import qualified Crypto.Hash.SHA256 as SHA256
-import Data.List (mapAccumL)
-import Data.Word (Word32)
import qualified Data.ByteString as BS
+import qualified Data.List.NonEmpty as NE
+import Data.Word (Word32)
+import Lightning.Protocol.BOLT1 (PaymentHash, PaymentPreimage)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT3
import Lightning.Protocol.BOLT5.Types
@@ -40,17 +43,16 @@ import Lightning.Protocol.BOLT5.Types
-- | Identify the type of channel close from a transaction that
-- spends the funding output.
--
--- Parses the on-chain transaction and compares its txid against
--- the txids of the known local and remote commitment
--- transactions. Comparing txids rather than bytes means the
--- signed (segwit) serialization found on chain matches the
--- unsigned commitment.
+-- Parses the on-chain transaction and compares its txid with the
+-- txids of the known local and remote commitment transactions.
+-- Comparing txids rather than bytes means the signed (segwit)
+-- serialization found on chain matches the unsigned commitment.
--
--- Returns 'Nothing' if the bytes don't parse as a transaction or
--- the transaction doesn't match either commitment. Mutual close
--- and revoked commitment detection require additional checks by
--- the caller (e.g. comparing closing tx format, checking a secret
--- store for older commitment numbers).
+-- Returns 'Nothing' if the bytes don't parse as a transaction or
+-- the transaction matches neither commitment. Mutual close and
+-- revoked commitment detection are left to the caller (e.g.
+-- comparing with the closing transaction, or checking a secret
+-- store for older commitment numbers).
identify_close
:: CommitmentTx
-- ^ Our local commitment tx.
@@ -59,31 +61,27 @@ identify_close
-> BS.ByteString
-- ^ Raw serialized transaction found on chain.
-> Maybe CloseType
-identify_close !localCommitTx !remoteCommitTx
- !onChainBytes =
- case BT.from_bytes onChainBytes of
- Nothing -> Nothing
- Just !onChainTx ->
- let !onChainTxid = Just (BT.txid onChainTx)
- in if commitment_txid localCommitTx == onChainTxid
- then Just LocalCommitClose
- else if commitment_txid remoteCommitTx == onChainTxid
- then Just RemoteCommitClose
- else Nothing
+identify_close !local !remote !bytes = do
+ !tx <- BT.from_bytes bytes
+ let !txid = BT.txid tx
+ if commitment_txid local == txid
+ then Just LocalCommitClose
+ else if commitment_txid remote == txid
+ then Just RemoteCommitClose
+ else Nothing
-- output classification ----------------------------------------------
--- | Classify outputs of our local commitment transaction.
+-- | Classify the outputs of our local commitment transaction.
--
--- Per BOLT #5: when we discover our local commitment on chain,
--- we must resolve each output. to_local requires a CSV-delayed
--- spend, to_remote is resolved by the commitment itself, HTLC
--- outputs need second-stage transactions, and anchors can be
--- spent immediately.
+-- Per BOLT #5: when our local commitment is on chain, we must
+-- resolve each output. to_local requires a CSV-delayed spend,
+-- to_remote is resolved by the commitment itself, HTLC outputs
+-- need second-stage transactions, and our anchor can be spent
+-- immediately.
--
--- An HTLC output is matched to the HTLC with the same direction,
--- script, amount and CLTV expiry, and each HTLC matches at most one
--- output.
+-- Each HTLC output's HTLC is read from its bolt3 'OutputHTLC', so
+-- the commitment must be the one bolt3 built for this state.
classify_local_commit_outputs
:: CommitmentTx
-- ^ Our local commitment transaction.
@@ -91,306 +89,166 @@ classify_local_commit_outputs
-- ^ Derived keys for this commitment.
-> ToSelfDelay
-- ^ Remote's to_self_delay (CSV delay for our outputs).
- -> ChannelFeatures
- -- ^ Channel feature flags.
- -> [HTLC]
- -- ^ HTLCs in this commitment.
+ -> CommitmentFormat
-> [UnresolvedOutput]
-classify_local_commit_outputs !commitTx !keys !delay
- !features !htlcs =
- case commitment_txid commitTx of
- Nothing -> []
- Just !txid ->
- let !outputs = ctx_outputs commitTx
- !revpk = ck_revocation_pubkey keys
- !delayedpk = ck_local_delayed keys
- classify cands (idx, out) =
- classifyLocalOutput txid revpk delayedpk
- delay features keys cands idx out
- in snd (mapAccumL classify
- (htlc_candidates keys features htlcs)
- (zip [0..] outputs))
-
--- | Classify a single output from a local commitment tx, removing
--- any matched HTLC from the candidates.
-classifyLocalOutput
- :: TxId
- -> RevocationPubkey
- -> LocalDelayedPubkey
- -> ToSelfDelay
- -> ChannelFeatures
- -> CommitmentKeys
- -> [(HTLC, Script)]
- -> Word32
- -> TxOutput
- -> ([(HTLC, Script)], UnresolvedOutput)
-classifyLocalOutput !txid !revpk !delayedpk !delay
- !features !keys !cands !idx !out =
- let !op = OutPoint txid idx
- !val = txout_value out
- !(rest, resolution) = case txout_type out of
- OutputToLocal ->
- (cands, SpendToLocal delay revpk delayedpk)
- OutputToRemote ->
- (cands, Resolved)
- OutputLocalAnchor ->
- (cands, AnchorSpend (ck_local_funding keys))
- OutputRemoteAnchor ->
- (cands, Resolved)
- OutputOfferedHTLC expiry ->
- case take_htlc HTLCOffered expiry out cands of
- (Just htlc, cands') ->
- (cands', SpendHTLCTimeout htlc keys features)
- (Nothing, cands') -> (cands', Resolved)
- OutputReceivedHTLC expiry ->
- case take_htlc HTLCReceived expiry out cands of
- (Just htlc, cands') ->
- (cands', SpendHTLCSuccess htlc keys features)
- (Nothing, cands') -> (cands', Resolved)
- in (rest, UnresolvedOutput op val resolution)
-
--- | Classify outputs of the remote commitment transaction.
---
--- Per BOLT #5: when we discover the remote commitment on chain,
--- there are no CSV delays on our outputs. We can spend offered
--- HTLCs directly after timeout, and received HTLCs directly
--- with the preimage.
---
--- HTLC outputs are matched as in 'classify_local_commit_outputs'.
+classify_local_commit_outputs !tx !keys !delay !fmt =
+ classify_outputs resolve tx
+ where
+ resolve t = case t of
+ OutputToLocal ->
+ SpendToLocal delay (ck_revocation_pubkey keys)
+ (ck_local_delayed keys)
+ OutputToRemote -> Resolved
+ OutputLocalAnchor -> AnchorSpend (ck_local_funding keys)
+ OutputRemoteAnchor -> Resolved
+ OutputHTLC h -> case htlc_direction h of
+ HTLCOffered -> SpendHTLCTimeout h keys fmt
+ HTLCReceived -> SpendHTLCSuccess h keys fmt
+
+-- | Classify the outputs of the remote commitment transaction.
+--
+-- Per BOLT #5: when the remote commitment is on chain, there are
+-- no CSV delays on our outputs. We can spend HTLCs we offered
+-- directly after timeout, and HTLCs we received directly with the
+-- preimage.
+--
+-- The commitment, its keys and its HTLCs are from the remote's
+-- point of view (as bolt3 builds the remote's commitment): an
+-- HTLC the remote offered is one we received.
classify_remote_commit_outputs
:: CommitmentTx
-- ^ The remote commitment transaction.
-> CommitmentKeys
- -- ^ Derived keys for this commitment (from remote's
- -- perspective, so local/remote are swapped).
- -> ChannelFeatures
- -- ^ Channel feature flags.
- -> [HTLC]
- -- ^ HTLCs in this commitment.
+ -- ^ Derived keys for this commitment (from the remote's point
+ -- of view, so local and remote are swapped).
-> [UnresolvedOutput]
-classify_remote_commit_outputs !commitTx !keys
- !features !htlcs =
- case commitment_txid commitTx of
- Nothing -> []
- Just !txid ->
- let !outputs = ctx_outputs commitTx
- classify cands (idx, out) =
- classifyRemoteOutput txid keys cands idx out
- in snd (mapAccumL classify
- (htlc_candidates keys features htlcs)
- (zip [0..] outputs))
-
--- | Classify a single output from a remote commitment tx, removing
--- any matched HTLC from the candidates.
-classifyRemoteOutput
- :: TxId
- -> CommitmentKeys
- -> [(HTLC, Script)]
- -> Word32
- -> TxOutput
- -> ([(HTLC, Script)], UnresolvedOutput)
-classifyRemoteOutput !txid !keys !cands !idx !out =
- let !op = OutPoint txid idx
- !val = txout_value out
- !(rest, resolution) = case txout_type out of
- OutputToLocal ->
- (cands, Resolved) -- Remote's to_local; not ours
- OutputToRemote ->
- (cands, Resolved) -- Our to_remote; resolved by commitment
- OutputLocalAnchor ->
- (cands, Resolved) -- Remote's anchor
- OutputRemoteAnchor ->
- (cands, AnchorSpend (ck_remote_funding keys))
- OutputOfferedHTLC expiry ->
- -- On remote's commit, their offered = our received.
- -- We can claim with preimage.
- case take_htlc HTLCOffered expiry out cands of
- (Just htlc, cands') ->
- (cands', SpendHTLCPreimageDirect htlc)
- (Nothing, cands') -> (cands', Resolved)
- OutputReceivedHTLC expiry ->
- -- On remote's commit, their received = our offered.
- -- We can claim after timeout.
- case take_htlc HTLCReceived expiry out cands of
- (Just htlc, cands') ->
- (cands', SpendHTLCTimeoutDirect htlc)
- (Nothing, cands') -> (cands', Resolved)
- in (rest, UnresolvedOutput op val resolution)
-
--- | Classify outputs of a revoked commitment transaction.
---
--- Per BOLT #5: when we discover a revoked commitment, we can
--- claim everything using the revocation key. to_local is spent
--- via revocation, HTLCs are spent via revocation, and we can
--- also optionally sweep to_remote.
+classify_remote_commit_outputs !tx !keys =
+ classify_outputs resolve tx
+ where
+ resolve t = case t of
+ OutputToLocal -> Resolved -- the remote's to_local
+ OutputToRemote -> Resolved -- ours; resolved by the commitment
+ OutputLocalAnchor -> Resolved -- the remote's anchor
+ OutputRemoteAnchor -> AnchorSpend (ck_remote_funding keys)
+ OutputHTLC h -> case htlc_direction h of
+ HTLCOffered -> SpendHTLCPreimageDirect h -- we received it
+ HTLCReceived -> SpendHTLCTimeoutDirect h -- we offered it
+
+-- | Classify the outputs of a revoked commitment transaction.
+--
+-- Per BOLT #5: when a revoked commitment is on chain, we can
+-- claim to_local and every HTLC output with the revocation key.
+-- to_remote (ours) and the anchors are marked 'Resolved'.
classify_revoked_commit_outputs
:: CommitmentTx
-- ^ The revoked commitment transaction.
- -> CommitmentKeys
- -- ^ Derived keys for the revoked commitment.
-> RevocationPubkey
-- ^ Revocation pubkey (derived from the revealed secret).
- -> ChannelFeatures
- -- ^ Channel feature flags.
- -> [HTLC]
- -- ^ HTLCs in the revoked commitment.
-> [UnresolvedOutput]
-classify_revoked_commit_outputs !commitTx !_keys
- !revpk !_features !_htlcs =
- case commitment_txid commitTx of
- Nothing -> []
- Just !txid ->
- let !outputs = ctx_outputs commitTx
- in zipWith (classifyRevokedOutput txid revpk)
- [0..] outputs
-
--- | Classify a single output from a revoked commitment tx.
-classifyRevokedOutput
- :: TxId
- -> RevocationPubkey
- -> Word32
- -> TxOutput
- -> UnresolvedOutput
-classifyRevokedOutput !txid !revpk !idx !out =
- let !op = OutPoint txid idx
- !val = txout_value out
- !resolution = case txout_type out of
- OutputToLocal ->
- Revoke revpk
- OutputToRemote ->
- Resolved -- Our funds; resolved by commitment
- OutputLocalAnchor ->
- Resolved -- Can be swept by anyone after 16 blocks
- OutputRemoteAnchor ->
- Resolved -- Our anchor
- OutputOfferedHTLC expiry ->
- RevokeHTLC revpk (HTLCOfferedOutput expiry)
- OutputReceivedHTLC expiry ->
- RevokeHTLC revpk (HTLCReceivedOutput expiry)
- in UnresolvedOutput op val resolution
+classify_revoked_commit_outputs !tx !revpk =
+ classify_outputs resolve tx
+ where
+ resolve t = case t of
+ OutputToLocal -> Revoke revpk
+ OutputToRemote -> Resolved
+ OutputLocalAnchor -> Resolved
+ OutputRemoteAnchor -> Resolved
+ OutputHTLC h -> RevokeHTLC revpk $ case htlc_direction h of
+ HTLCOffered -> HTLCOfferedOutput (htlc_cltv_expiry h)
+ HTLCReceived -> HTLCReceivedOutput (htlc_cltv_expiry h)
+
+-- | Pair each commitment output with its outpoint, value and
+-- resolution.
+classify_outputs
+ :: (OutputType -> OutputResolution)
+ -> CommitmentTx
+ -> [UnresolvedOutput]
+classify_outputs resolve tx =
+ zipWith classify [0..] (NE.toList (ctx_outputs tx))
+ where
+ !txid = commitment_txid tx
+ classify :: Word32 -> CommitmentOutput -> UnresolvedOutput
+ classify !idx !out = UnresolvedOutput
+ { uo_outpoint = OutPoint txid idx
+ , uo_value = co_value out
+ , uo_type = resolve (co_type out)
+ }
-- preimage extraction ------------------------------------------------
--- | Extract a payment preimage from an offered HTLC witness.
+-- | Extract a payment preimage from the witness of an input
+-- spending an offered HTLC output.
--
--- When the remote party claims an offered HTLC on our local
--- commitment, the witness contains the preimage. The witness
--- stack for a preimage claim is:
+-- When the remote party claims an offered HTLC on our local
+-- commitment, the witness (see bolt3's
+-- 'offered_htlc_witness_preimage') is:
--
--- @\<remotehtlcsig\> \<paymentPreimage\> \<witnessScript\>@
+-- @\<remotehtlcsig\> \<payment_preimage\> \<witness_script\>@
--
--- Returns the preimage only if it hashes to the given payment
--- hash. Any other spend of the output, e.g. by revocation, yields
--- 'Nothing'.
+-- Returns the preimage only if it hashes to the given payment
+-- hash. Any other spend of the output, e.g. by revocation, yields
+-- 'Nothing'.
extract_preimage_offered
:: PaymentHash
-- ^ Payment hash of the HTLC.
-> Witness
-- ^ Witness of the input spending the HTLC output.
-> Maybe PaymentPreimage
-extract_preimage_offered !ph (Witness items) =
- case items of
- [_sig, preimageBytes, _script] ->
- check_preimage ph preimageBytes
- _ -> Nothing
+extract_preimage_offered !ph (Witness items) = case items of
+ [_sig, preimage, _script] -> check_preimage ph preimage
+ _ -> Nothing
--- | Extract a payment preimage from an HTLC-success transaction
--- witness.
+-- | Extract a payment preimage from the witness of an HTLC-success
+-- transaction's input.
--
--- When the remote party uses an HTLC-success tx on their
--- commitment to claim a received HTLC, the witness contains the
--- preimage. The witness stack is:
+-- When the remote party claims an HTLC it received on its
+-- commitment with an HTLC-success transaction, the witness (see
+-- bolt3's 'htlc_success_witness') is:
--
--- @0 \<remotehtlcsig\> \<localhtlcsig\> \<paymentPreimage\>
--- \<witnessScript\>@
+-- @0 \<remotehtlcsig\> \<localhtlcsig\> \<payment_preimage\>
+-- \<witness_script\>@
--
--- Returns the preimage only if it hashes to the given payment
--- hash.
+-- Returns the preimage only if it hashes to the given payment
+-- hash.
extract_preimage_htlc_success
:: PaymentHash
-- ^ Payment hash of the HTLC.
-> Witness
-- ^ Witness of the HTLC-success transaction input.
-> Maybe PaymentPreimage
-extract_preimage_htlc_success !ph (Witness items) =
- case items of
- [_zero, _remoteSig, _localSig, preimageBytes, _script] ->
- check_preimage ph preimageBytes
- _ -> Nothing
+extract_preimage_htlc_success !ph (Witness items) = case items of
+ [_zero, _remote_sig, _local_sig, preimage, _script] ->
+ check_preimage ph preimage
+ _ -> Nothing
-- | Accept a candidate preimage only if it hashes to the payment
-- hash.
check_preimage :: PaymentHash -> BS.ByteString -> Maybe PaymentPreimage
check_preimage !ph !bs
- | SHA256.hash bs == unPaymentHash ph = paymentPreimage bs
+ | SHA256.hash bs == BOLT1.un_payment_hash ph = BOLT1.payment_preimage bs
| otherwise = Nothing
-- timeout check ------------------------------------------------------
--- | Check if an HTLC has timed out at the given block height.
+-- | Whether an HTLC has timed out at the given block height: whether
+-- the height is at least the HTLC's CLTV expiry.
--
--- An HTLC has timed out when the current block height is equal
--- to or greater than the HTLC's CLTV expiry.
+-- >>> let Just amt = BOLT1.milli_satoshi 1000000
+-- >>> let Just ph = BOLT1.payment_hash (BS.replicate 32 0xaa)
+-- >>> let htlc = HTLC HTLCOffered amt ph (CltvExpiry 800000)
+-- >>> htlc_timed_out 799999 htlc
+-- False
+-- >>> htlc_timed_out 800000 htlc
+-- True
htlc_timed_out :: Word32 -> HTLC -> Bool
-htlc_timed_out !currentHeight !htlc =
- currentHeight >= unCltvExpiry (htlc_cltv_expiry htlc)
+htlc_timed_out !height !htlc =
+ let CltvExpiry expiry = htlc_cltv_expiry htlc
+ in height >= expiry
{-# INLINE htlc_timed_out #-}
-- internal helpers ---------------------------------------------------
--- | Compute the txid of a commitment transaction.
---
--- Returns 'Nothing' if the commitment has no outputs.
-commitment_txid :: CommitmentTx -> Maybe TxId
-commitment_txid !tx = fmap BT.txid (commitment_to_tx tx)
-
--- | Pair each HTLC with the P2WSH script of its commitment output.
-htlc_candidates
- :: CommitmentKeys
- -> ChannelFeatures
- -> [HTLC]
- -> [(HTLC, Script)]
-htlc_candidates !keys !features = map (\htlc -> (htlc, script htlc))
- where
- script htlc = case htlc_direction htlc of
- HTLCOffered ->
- to_p2wsh $ offered_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- features
- HTLCReceived ->
- to_p2wsh $ received_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- (htlc_cltv_expiry htlc)
- features
-
--- | Find the HTLC for an HTLC output and remove it from the
--- candidates.
---
--- The HTLC must agree with the output on direction, script, amount
--- and CLTV expiry. The offered HTLC script doesn't commit to the
--- expiry and no HTLC script commits to the amount, so HTLCs sharing
--- a payment hash differ only in these. Removing the match ensures
--- no two outputs resolve to the same HTLC.
-take_htlc
- :: HTLCDirection
- -> CltvExpiry
- -- ^ Expiry recorded for the output.
- -> TxOutput
- -> [(HTLC, Script)]
- -> (Maybe HTLC, [(HTLC, Script)])
-take_htlc !dir !expiry !out !cands =
- case break matches cands of
- (pre, (htlc, _) : post) -> (Just htlc, pre ++ post)
- (_, []) -> (Nothing, cands)
- where
- matches (htlc, script) =
- htlc_direction htlc == dir
- && htlc_cltv_expiry htlc == expiry
- && msatToSat (htlc_amount_msat htlc) == txout_value out
- && script == txout_script out
+-- | The txid of a commitment transaction.
+commitment_txid :: CommitmentTx -> TxId
+commitment_txid = BT.txid . commitment_to_tx
+{-# INLINE commitment_txid #-}
diff --git a/lib/Lightning/Protocol/BOLT5/Internal.hs b/lib/Lightning/Protocol/BOLT5/Internal.hs
@@ -1,26 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-
--- |
--- Module: Lightning.Protocol.BOLT5.Internal
--- Copyright: (c) 2025 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- Internal definitions for BOLT #5.
---
--- This module re-exports all constructors from the Types
--- module, including those not exported by the public API.
--- Use only in tests or trusted internal code.
-
-module Lightning.Protocol.BOLT5.Internal (
- -- * All type constructors (for test use)
- CloseType(..)
- , UnresolvedOutput(..)
- , OutputResolution(..)
- , HTLCOutputType(..)
- , SpendingTx(..)
- , RevokedOutput(..)
- , RevokedOutputType(..)
- ) where
-
-import Lightning.Protocol.BOLT5.Types
diff --git a/lib/Lightning/Protocol/BOLT5/Spend.hs b/lib/Lightning/Protocol/BOLT5/Spend.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
-- |
@@ -10,16 +10,14 @@
-- Spending transaction construction for BOLT #5 on-chain
-- transaction handling.
--
--- All functions produce unsigned 'SpendingTx' values. The caller
--- is responsible for signing (using the sighash metadata
--- provided) and assembling final witnesses via bolt3 witness
--- constructors.
+-- All functions produce unsigned t'SpendingTx' values. The caller
+-- signs (using the sighash metadata provided) and assembles the
+-- witness with bolt3's witness functions.
module Lightning.Protocol.BOLT5.Spend (
-- * Local commitment spends
spend_to_local
- , spend_htlc_timeout
- , spend_htlc_success
+ , spend_htlc_tx
, spend_htlc_output
-- * Remote commitment spends
@@ -36,27 +34,27 @@ module Lightning.Protocol.BOLT5.Spend (
, spend_anchor_anyone
) where
-import Bitcoin.Prim.Tx (TxOut(..))
+import Bitcoin.Prim.Tx (OutPoint, Tx(..), TxIn(..), TxOut(..))
import Bitcoin.Prim.Tx.Sighash (SighashType(..))
+import qualified Data.ByteString as BS
import Data.List.NonEmpty (NonEmpty(..))
import Data.Word (Word32, Word64)
-import qualified Data.ByteString as BS
-import Lightning.Protocol.BOLT3 hiding
- (txout_value, txout_script)
+import Lightning.Protocol.BOLT1 (PaymentHash, Satoshi)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT3
import Lightning.Protocol.BOLT5.Types
-- local commitment spends --------------------------------------------
-- | Spend the to_local output of our local commitment tx.
--
--- Requires waiting for the CSV delay (to_self_delay) before
--- broadcasting. The caller signs with the local delayed privkey
--- and uses 'to_local_witness_spend' from bolt3.
---
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- The input's nSequence is the to_self_delay, so the transaction
+-- is valid only once the delay has passed. The caller signs with
+-- the local delayed privkey and uses bolt3's
+-- 'to_local_witness_spend'.
--
--- The input nSequence is set to the to_self_delay value.
+-- Returns 'Nothing' if the fee would exceed the output value, or
+-- leave an output below the destination's dust threshold.
spend_to_local
:: OutPoint
-- ^ Outpoint of the to_local output.
@@ -69,94 +67,47 @@ spend_to_local
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_to_local !op !value !revpk !delay !delayedpk
- !destScript !feerate =
- let !witnessScript =
- to_local_script revpk delay delayedpk
- !weight = to_local_penalty_input_weight
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !tx = mk_spending_tx op
- (fromIntegral (unToSelfDelay delay))
- destScript outputValue 0
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
+spend_to_local !op !value !revpk delay@(ToSelfDelay d) !delayedpk
+ !dest !feerate =
+ sweep op value (to_local_script revpk delay delayedpk)
+ to_local_penalty_input_weight (fromIntegral d) 0 dest feerate
--- | Construct an HTLC-timeout second-stage transaction.
+-- | Build the HTLC-timeout (for an offered HTLC) or HTLC-success
+-- (for a received HTLC) transaction spending an HTLC output of
+-- our local commitment, with bolt3's 'build_htlc_tx'.
--
--- Used when we offered an HTLC on our local commitment and it
--- has timed out. The bolt3 'build_htlc_timeout_tx' function
--- constructs the HTLC-timeout tx; this wraps it as a
--- 'SpendingTx' with the witness script and sighash metadata.
---
--- The sighash type is for the local signature, which is always
--- @SIGHASH_ALL@. With @option_anchors@ the remote's
--- @htlc_signature@ instead uses
--- @SIGHASH_SINGLE|SIGHASH_ANYONECANPAY@.
-spend_htlc_timeout
- :: HTLCContext
- -> CommitmentKeys
- -- ^ Full commitment keys (needed for witness script).
- -> SpendingTx
-spend_htlc_timeout !ctx !keys =
- let !htlcTx = build_htlc_timeout_tx ctx
- !htlc = hc_htlc ctx
- !features = hc_features ctx
- !witnessScript = offered_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- features
- !inputValue =
- msatToSat (htlc_amount_msat htlc)
- !tx = htlc_tx_to_tx htlcTx
- in SpendingTx tx witnessScript inputValue SIGHASH_ALL
-
--- | Construct an HTLC-success second-stage transaction.
+-- The sighash type is that of the local signature, which is
+-- always @SIGHASH_ALL@. The remote's @htlc_signature@ uses bolt3's
+-- 'remote_htlc_sighash' (@SIGHASH_SINGLE|SIGHASH_ANYONECANPAY@
+-- under 'Anchors'). The witness is bolt3's 'htlc_timeout_witness'
+-- or 'htlc_success_witness'.
--
--- Used when we received an HTLC on our local commitment and
--- have the preimage. The bolt3 'build_htlc_success_tx' function
--- constructs the HTLC-success tx; this wraps it as a
--- 'SpendingTx'.
+-- Under 'Anchors' the transaction pays no fee; it must be
+-- combined with other inputs before broadcast.
--
--- The sighash type is for the local signature, which is always
--- @SIGHASH_ALL@. With @option_anchors@ the remote's
--- @htlc_signature@ instead uses
--- @SIGHASH_SINGLE|SIGHASH_ANYONECANPAY@.
-spend_htlc_success
+-- Returns 'Nothing' if bolt3 can't build the transaction (the fee
+-- exceeds the HTLC amount).
+spend_htlc_tx
:: HTLCContext
-> CommitmentKeys
- -- ^ Full commitment keys (needed for witness script).
- -> SpendingTx
-spend_htlc_success !ctx !keys =
- let !htlcTx = build_htlc_success_tx ctx
- !htlc = hc_htlc ctx
- !features = hc_features ctx
- !witnessScript = received_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- (htlc_cltv_expiry htlc)
- features
- !inputValue =
- msatToSat (htlc_amount_msat htlc)
- !tx = htlc_tx_to_tx htlcTx
- in SpendingTx tx witnessScript inputValue SIGHASH_ALL
+ -- ^ Keys for our local commitment (for the witness script).
+ -> Maybe SpendingTx
+spend_htlc_tx !ctx !keys = do
+ htx <- build_htlc_tx ctx
+ let !h = hc_htlc ctx
+ pure SpendingTx
+ { stx_tx = htlc_to_tx htx
+ , stx_input_script = htlc_script keys (hc_format ctx) h
+ , stx_input_value = BOLT1.msat_to_sat (htlc_amount_msat h)
+ , stx_sighash_type = SIGHASH_ALL
+ }
--- | Spend a second-stage HTLC output (HTLC-timeout or
--- HTLC-success output) after the CSV delay.
+-- | Spend the output of an HTLC-timeout or HTLC-success
+-- transaction after the CSV delay.
--
--- The output of an HTLC-timeout or HTLC-success tx uses the
--- same to_local script. The caller signs with the local
--- delayed privkey and uses 'htlc_output_witness_spend'.
---
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- The output uses the to_local script, so this is
+-- 'spend_to_local'. The caller signs with the local delayed
+-- privkey and uses bolt3's 'to_local_witness_spend'.
spend_htlc_output
:: OutPoint
-- ^ Outpoint of the second-stage output.
@@ -173,14 +124,15 @@ spend_htlc_output = spend_to_local
-- remote commitment spends -------------------------------------------
--- | Spend an offered HTLC directly after timeout on the remote
--- commitment.
+-- | Spend an HTLC we offered directly, after it times out, from the
+-- remote commitment (where it is a received HTLC).
--
--- On the remote commitment, their received HTLCs (our offered)
--- have timed out and we can sweep them directly.
+-- The locktime is the HTLC's CLTV expiry. The caller signs with
+-- our HTLC privkey and uses bolt3's
+-- 'received_htlc_witness_timeout'.
--
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- Returns 'Nothing' if the fee would exceed the output value, or
+-- leave an output below the destination's dust threshold.
spend_remote_htlc_timeout
:: OutPoint
-- ^ Outpoint of the HTLC output.
@@ -190,44 +142,28 @@ spend_remote_htlc_timeout
-- ^ The HTLC being spent.
-> CommitmentKeys
-- ^ Keys for the remote commitment.
- -> ChannelFeatures
+ -> CommitmentFormat
-> Script
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_remote_htlc_timeout !op !value !htlc !keys
- !features !destScript !feerate =
- let !witnessScript = received_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- (htlc_cltv_expiry htlc)
- features
- !weight = htlcOutputTypeWeight features
- (HTLCReceivedOutput (htlc_cltv_expiry htlc))
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !locktime =
- unCltvExpiry (htlc_cltv_expiry htlc)
- !seqNo =
- if has_anchors features then 1 else 0
- !tx = mk_spending_tx op seqNo destScript
- outputValue locktime
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
+spend_remote_htlc_timeout !op !value !htlc !keys !fmt !dest !feerate =
+ let expiry@(CltvExpiry e) = htlc_cltv_expiry htlc
+ !script = received_htlc_script (ck_revocation_pubkey keys)
+ (ck_remote_htlc keys) (ck_local_htlc keys)
+ (htlc_payment_hash htlc) expiry fmt
+ in sweep op value script
+ (htlc_output_type_weight fmt (HTLCReceivedOutput expiry))
+ (remote_htlc_sequence fmt) e dest feerate
--- | Spend a received HTLC directly with preimage on the remote
--- commitment.
+-- | Spend an HTLC we received directly with the preimage, from the
+-- remote commitment (where it is an offered HTLC).
--
--- On the remote commitment, their offered HTLCs (our received)
--- can be claimed with the payment preimage.
+-- The caller signs with our HTLC privkey and uses bolt3's
+-- 'offered_htlc_witness_preimage'.
--
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- Returns 'Nothing' if the fee would exceed the output value, or
+-- leave an output below the destination's dust threshold.
spend_remote_htlc_preimage
:: OutPoint
-- ^ Outpoint of the HTLC output.
@@ -237,42 +173,29 @@ spend_remote_htlc_preimage
-- ^ The HTLC being spent.
-> CommitmentKeys
-- ^ Keys for the remote commitment.
- -> ChannelFeatures
+ -> CommitmentFormat
-> Script
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_remote_htlc_preimage !op !value !htlc !keys
- !features !destScript !feerate =
- let !witnessScript = offered_htlc_script
- (ck_revocation_pubkey keys)
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- (htlc_payment_hash htlc)
- features
- !weight = htlcOutputTypeWeight features
- (HTLCOfferedOutput (htlc_cltv_expiry htlc))
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !seqNo =
- if has_anchors features then 1 else 0
- !tx = mk_spending_tx op seqNo destScript
- outputValue 0
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
+spend_remote_htlc_preimage !op !value !htlc !keys !fmt !dest !feerate =
+ let !expiry = htlc_cltv_expiry htlc
+ !script = offered_htlc_script (ck_revocation_pubkey keys)
+ (ck_remote_htlc keys) (ck_local_htlc keys)
+ (htlc_payment_hash htlc) fmt
+ in sweep op value script
+ (htlc_output_type_weight fmt (HTLCOfferedOutput expiry))
+ (remote_htlc_sequence fmt) 0 dest feerate
-- revoked commitment spends ------------------------------------------
--- | Spend a revoked to_local output using the revocation key.
+-- | Spend a revoked to_local output with the revocation key.
--
--- The caller signs with the revocation privkey and uses
--- 'to_local_witness_revoke' from bolt3.
+-- The caller signs with the revocation privkey and uses bolt3's
+-- 'to_local_witness_revoke'.
--
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- Returns 'Nothing' if the fee would exceed the output value, or
+-- leave an output below the destination's dust threshold.
spend_revoked_to_local
:: OutPoint
-- ^ Outpoint of the to_local output.
@@ -285,30 +208,19 @@ spend_revoked_to_local
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_revoked_to_local !op !value !revpk !delay
- !delayedpk !destScript !feerate =
- let !witnessScript =
- to_local_script revpk delay delayedpk
- !weight = to_local_penalty_input_weight
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !tx = mk_spending_tx op 0xFFFFFFFF destScript
- outputValue 0
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
+spend_revoked_to_local !op !value !revpk !delay !delayedpk !dest
+ !feerate =
+ sweep op value (to_local_script revpk delay delayedpk)
+ to_local_penalty_input_weight 0xFFFFFFFF 0 dest feerate
--- | Spend a revoked HTLC output using the revocation key.
+-- | Spend a revoked HTLC output with the revocation key.
--
--- The caller signs with the revocation privkey and uses
--- 'offered_htlc_witness_revoke' or
--- 'received_htlc_witness_revoke' from bolt3, depending on
--- the output type.
+-- The caller signs with the revocation privkey and uses bolt3's
+-- 'offered_htlc_witness_revoke' or 'received_htlc_witness_revoke',
+-- according to the output type.
--
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- Returns 'Nothing' if the fee would exceed the output value, or
+-- leave an output below the destination's dust threshold.
spend_revoked_htlc
:: OutPoint
-- ^ Outpoint of the HTLC output.
@@ -318,60 +230,30 @@ spend_revoked_htlc
-- ^ Whether offered or received HTLC.
-> RevocationPubkey
-> CommitmentKeys
- -> ChannelFeatures
+ -> CommitmentFormat
-> PaymentHash
-> Script
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_revoked_htlc !op !value !htype !revpk !keys
- !features !ph !destScript !feerate =
- case htype of
- HTLCOfferedOutput _ ->
- let !witnessScript = offered_htlc_script
- revpk
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- ph
- features
- !weight = htlcOutputTypeWeight features htype
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !tx = mk_spending_tx op 0xFFFFFFFF
- destScript outputValue 0
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
- HTLCReceivedOutput expiry ->
- let !witnessScript = received_htlc_script
- revpk
- (ck_remote_htlc keys)
- (ck_local_htlc keys)
- ph
- expiry
- features
- !weight = htlcOutputTypeWeight features htype
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !tx = mk_spending_tx op 0xFFFFFFFF
- destScript outputValue 0
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
+spend_revoked_htlc !op !value !htype !revpk !keys !fmt !ph !dest
+ !feerate =
+ let !remote = ck_remote_htlc keys
+ !local = ck_local_htlc keys
+ !script = case htype of
+ HTLCOfferedOutput _ ->
+ offered_htlc_script revpk remote local ph fmt
+ HTLCReceivedOutput expiry ->
+ received_htlc_script revpk remote local ph expiry fmt
+ in sweep op value script (htlc_output_type_weight fmt htype)
+ 0xFFFFFFFF 0 dest feerate
--- | Spend a revoked second-stage HTLC output (HTLC-timeout or
--- HTLC-success output) using the revocation key.
---
--- The output of a revoked HTLC-timeout/success tx uses the
--- to_local script. The caller signs with the revocation privkey
--- and uses 'htlc_output_witness_revoke'.
+-- | Spend the output of a revoked HTLC-timeout or HTLC-success
+-- transaction with the revocation key.
--
--- Returns 'Nothing' if the fee would exceed the output value,
--- or leave an output below the destination's dust threshold.
+-- The output uses the to_local script, so this is
+-- 'spend_revoked_to_local'. The caller signs with the revocation
+-- privkey and uses bolt3's 'to_local_witness_revoke'.
spend_revoked_htlc_output
:: OutPoint
-- ^ Outpoint of the second-stage output.
@@ -384,27 +266,16 @@ spend_revoked_htlc_output
-- ^ Destination scriptPubKey.
-> FeeratePerKw
-> Maybe SpendingTx
-spend_revoked_htlc_output !op !value !revpk !delay
- !delayedpk !destScript !feerate =
- let !witnessScript =
- to_local_script revpk delay delayedpk
- !weight = to_local_penalty_input_weight
- + penalty_tx_base_weight
- !fee = spending_fee feerate weight
- in case sweep_value value fee destScript of
- Nothing -> Nothing
- Just !outputValue ->
- let !tx = mk_spending_tx op 0xFFFFFFFF destScript
- outputValue 0
- in Just (SpendingTx tx witnessScript value
- SIGHASH_ALL)
+spend_revoked_htlc_output = spend_revoked_to_local
-- anchor spends ------------------------------------------------------
--- | Spend an anchor output as the owner (immediately).
+-- | Spend an anchor output as its owner (immediately).
--
--- The caller signs with the funding privkey and uses
--- 'anchor_witness_owner' from bolt3.
+-- The transaction pays no fee and has a single input: it must be
+-- combined with other inputs before broadcast. The caller signs
+-- with the funding privkey and uses bolt3's
+-- 'anchor_witness_owner'.
spend_anchor_owner
:: OutPoint
-- ^ Outpoint of the anchor output.
@@ -414,15 +285,16 @@ spend_anchor_owner
-> Script
-- ^ Destination scriptPubKey.
-> SpendingTx
-spend_anchor_owner !op !value !fundpk !destScript =
- let !witnessScript = anchor_script fundpk
- !tx = mk_spending_tx op 0xFFFFFFFE destScript
- value 0
- in SpendingTx tx witnessScript value SIGHASH_ALL
+spend_anchor_owner !op !value !fundpk !dest =
+ SpendingTx (mk_spending_tx op 0xFFFFFFFE dest value 0)
+ (anchor_script fundpk) value SIGHASH_ALL
--- | Spend an anchor output as anyone (after 16 blocks).
+-- | Spend an anchor output as anyone (16 blocks after the
+-- commitment confirms).
--
--- Uses 'anchor_witness_anyone' from bolt3 (empty signature).
+-- As 'spend_anchor_owner', the transaction pays no fee. The
+-- witness is bolt3's 'anchor_witness_anyone', which needs no
+-- signature.
spend_anchor_anyone
:: OutPoint
-- ^ Outpoint of the anchor output.
@@ -432,98 +304,108 @@ spend_anchor_anyone
-> Script
-- ^ Destination scriptPubKey.
-> SpendingTx
-spend_anchor_anyone !op !value !fundpk !destScript =
- let !witnessScript = anchor_script fundpk
- !tx = mk_spending_tx op 16 destScript value 0
- in SpendingTx tx witnessScript value SIGHASH_ALL
+spend_anchor_anyone !op !value !fundpk !dest =
+ SpendingTx (mk_spending_tx op 16 dest value 0)
+ (anchor_script fundpk) value SIGHASH_ALL
-- internal helpers ---------------------------------------------------
+-- | A single-input, single-output sweep paying the input value, less
+-- the fee for the given input weight, to the destination.
+sweep
+ :: OutPoint
+ -> Satoshi -- ^ input value
+ -> Script -- ^ input witness script
+ -> Word64 -- ^ input weight
+ -> Word32 -- ^ input nSequence
+ -> Word32 -- ^ locktime
+ -> Script -- ^ destination scriptPubKey
+ -> FeeratePerKw
+ -> Maybe SpendingTx
+sweep !op !value !script !weight !sq !locktime !dest !feerate = do
+ let !fee = spending_fee feerate (weight + penalty_tx_base_weight)
+ out <- sweep_value value fee dest
+ pure (SpendingTx (mk_spending_tx op sq dest out locktime) script
+ value SIGHASH_ALL)
+
-- | Value of a sweep's single output: the input value less the fee.
--
--- 'Nothing' if the fee meets or exceeds the input value, or if the
--- output would be below the dust threshold of its script.
+-- 'Nothing' if the fee exceeds the input value, or if the output
+-- would be below the dust threshold of its script.
sweep_value :: Satoshi -> Satoshi -> Script -> Maybe Satoshi
-sweep_value !value !fee !destScript
- | unSatoshi fee >= unSatoshi value = Nothing
- | unSatoshi out < unSatoshi (dust_threshold destScript) = Nothing
- | otherwise = Just out
- where
- out = Satoshi (unSatoshi value - unSatoshi fee)
+sweep_value !value !fee (Script dest) = do
+ out <- BOLT1.sub_sat value fee
+ if BOLT1.un_satoshi out < dust_threshold dest
+ then Nothing
+ else Just out
--- | Dust threshold for an output paying to a script.
+-- | Dust threshold, in satoshis, for an output paying to a script.
--
--- As Bitcoin Core computes it for spendable outputs at the default
--- dust relay feerate of 3 sat/vbyte: three times the size of the
--- output plus that of an input spending it (67 vbytes for a
--- witness program, 148 otherwise). This gives 546 sats for P2PKH,
--- 540 for P2SH, 294 for P2WPKH, and 330 for P2WSH and P2TR.
-dust_threshold :: Script -> Satoshi
-dust_threshold (Script s) =
+-- As Bitcoin Core computes it for spendable outputs at the default
+-- dust relay feerate of 3 sat/vbyte: three times the size of the
+-- output plus that of an input spending it (67 vbytes for a
+-- witness program, 148 otherwise). This gives 546 sats for P2PKH,
+-- 540 for P2SH, 294 for P2WPKH, and 330 for P2WSH and P2TR.
+dust_threshold :: BS.ByteString -> Word64
+dust_threshold s =
let !len = fromIntegral (BS.length s) :: Word64
- !lenSize = if len < 0xfd then 1
- else if len <= 0xffff then 3
- else 5
- !spendSize = if is_witness_program s then 67 else 148
- in Satoshi (3 * (8 + lenSize + len + spendSize))
+ !len_size
+ | len < 0xfd = 1
+ | len <= 0xffff = 3
+ | otherwise = 5
+ !spend_size = if is_witness_program s then 67 else 148
+ in 3 * (8 + len_size + len + spend_size)
-- | Whether a script is a segwit witness program: a version opcode
-- (OP_0 or OP_1 to OP_16) followed by a single 2-40 byte push.
is_witness_program :: BS.ByteString -> Bool
is_witness_program s = case BS.unpack (BS.take 2 s) of
- [version, pushLen] ->
+ [version, push_len] ->
(version == 0x00 || (version >= 0x51 && version <= 0x60))
- && pushLen >= 2 && pushLen <= 40
- && fromIntegral pushLen + 2 == BS.length s
+ && push_len >= 2 && push_len <= 40
+ && fromIntegral push_len + 2 == BS.length s
_ -> False
--- | Build a simple single-input single-output spending tx.
+-- | The nSequence of a direct HTLC spend from the remote commitment:
+-- 1 under 'Anchors' (for the HTLC scripts' CSV), 0 otherwise.
+remote_htlc_sequence :: CommitmentFormat -> Word32
+remote_htlc_sequence fmt = case fmt of
+ StaticRemotekey -> 0
+ Anchors -> 1
+
+-- | The witness script of an HTLC output of a commitment with the
+-- given keys.
+htlc_script :: CommitmentKeys -> CommitmentFormat -> HTLC -> Script
+htlc_script !keys !fmt !h =
+ let !revpk = ck_revocation_pubkey keys
+ !remote = ck_remote_htlc keys
+ !local = ck_local_htlc keys
+ !ph = htlc_payment_hash h
+ in case htlc_direction h of
+ HTLCOffered -> offered_htlc_script revpk remote local ph fmt
+ HTLCReceived ->
+ received_htlc_script revpk remote local ph
+ (htlc_cltv_expiry h) fmt
+
+-- | Build a version 2, single-input, single-output transaction.
mk_spending_tx
- :: OutPoint -- ^ Input outpoint
- -> Word32 -- ^ Input nSequence
- -> Script -- ^ Output scriptPubKey
- -> Satoshi -- ^ Output value
- -> Word32 -- ^ Locktime
+ :: OutPoint -- ^ input outpoint
+ -> Word32 -- ^ input nSequence
+ -> Script -- ^ output scriptPubKey
+ -> Satoshi -- ^ output value
+ -> Word32 -- ^ locktime
-> Tx
-mk_spending_tx !op !seqNo !destScript !outputValue
- !locktime =
- let !txIn = TxIn
- { txin_prevout = op
- , txin_script_sig = BS.empty
- , txin_sequence = seqNo
- }
- !txOut = TxOut
- { txout_value = unSatoshi outputValue
- , txout_script_pubkey = unScript destScript
- }
- in Tx
- { tx_version = 2
- , tx_inputs = txIn :| []
- , tx_outputs = txOut :| []
- , tx_witnesses = []
- , tx_locktime = locktime
- }
-
--- | Convert a bolt3 HTLCTx to a ppad-tx Tx.
-htlc_tx_to_tx :: HTLCTx -> Tx
-htlc_tx_to_tx !htx =
- let !txIn = TxIn
- { txin_prevout = htx_input_outpoint htx
- , txin_script_sig = BS.empty
- , txin_sequence =
- unSequence (htx_input_sequence htx)
- }
- !txOut = TxOut
- { txout_value =
- unSatoshi (htx_output_value htx)
- , txout_script_pubkey =
- unScript (htx_output_script htx)
- }
- in Tx
- { tx_version = htx_version htx
- , tx_inputs = txIn :| []
- , tx_outputs = txOut :| []
- , tx_witnesses = []
- , tx_locktime =
- unLocktime (htx_locktime htx)
- }
+mk_spending_tx !op !sq (Script dest) !value !locktime = Tx
+ { tx_version = 2
+ , tx_inputs = TxIn
+ { txin_prevout = op
+ , txin_script_sig = BS.empty
+ , txin_sequence = sq
+ } :| []
+ , tx_outputs = TxOut
+ { txout_value = BOLT1.un_satoshi value
+ , txout_script_pubkey = dest
+ } :| []
+ , tx_witnesses = []
+ , tx_locktime = locktime
+ }
diff --git a/lib/Lightning/Protocol/BOLT5/Types.hs b/lib/Lightning/Protocol/BOLT5/Types.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -20,8 +20,8 @@ module Lightning.Protocol.BOLT5.Types (
-- * HTLC output type
, HTLCOutputType(..)
- , htlcOutputType
- , htlcOutputTypeWeight
+ , htlc_output_type
+ , htlc_output_type_weight
-- * Spending transactions
, SpendingTx(..)
@@ -50,19 +50,22 @@ module Lightning.Protocol.BOLT5.Types (
, spending_fee
) where
-import Bitcoin.Prim.Tx (Tx(..))
-import Bitcoin.Prim.Tx.Sighash (SighashType(..))
+import Bitcoin.Prim.Tx (OutPoint, Tx)
+import Bitcoin.Prim.Tx.Sighash (SighashType)
+import Control.DeepSeq (NFData(..))
import Data.Word (Word64)
import GHC.Generics (Generic)
-import Lightning.Protocol.BOLT3.Types
-import Lightning.Protocol.BOLT3.Tx (
- CommitmentKeys(..)
- , OutputType(..)
- )
+import Lightning.Protocol.BOLT1 (Satoshi)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT3
-- close identification -----------------------------------------------
-- | What kind of close was detected on chain.
+--
+-- @identify_close@ produces only 'LocalCommitClose' and
+-- 'RemoteCommitClose'; recognising mutual and revoked closes is
+-- left to the caller.
data CloseType
= MutualClose
-- ^ Cooperative closure agreed by both parties.
@@ -74,6 +77,8 @@ data CloseType
-- ^ A revoked (outdated) commitment transaction was broadcast.
deriving (Eq, Show, Generic)
+instance NFData CloseType
+
-- output classification ----------------------------------------------
-- | An unresolved commitment transaction output.
@@ -83,42 +88,46 @@ data UnresolvedOutput = UnresolvedOutput
, uo_type :: !OutputResolution
} deriving (Eq, Show, Generic)
+instance NFData UnresolvedOutput
+
-- | How to resolve an output, per BOLT #5 rules.
data OutputResolution
= Resolved
- -- ^ Already resolved (e.g. to_remote on local commit).
+ -- ^ Nothing to do (e.g. to_remote on our local commitment).
| SpendToLocal
!ToSelfDelay !RevocationPubkey !LocalDelayedPubkey
- -- ^ Spend to_local after CSV delay.
+ -- ^ Spend to_local after the CSV delay.
| SpendHTLCTimeout
- !HTLC !CommitmentKeys !ChannelFeatures
- -- ^ Spend via HTLC-timeout second-stage tx (local commit,
- -- local offer).
+ !HTLC !CommitmentKeys !CommitmentFormat
+ -- ^ Spend via an HTLC-timeout transaction (our commitment, an
+ -- HTLC we offered).
| SpendHTLCSuccess
- !HTLC !CommitmentKeys !ChannelFeatures
- -- ^ Spend via HTLC-success second-stage tx (local commit,
- -- remote offer).
+ !HTLC !CommitmentKeys !CommitmentFormat
+ -- ^ Spend via an HTLC-success transaction (our commitment, an
+ -- HTLC we received).
| SpendHTLCTimeoutDirect !HTLC
- -- ^ Spend HTLC directly after timeout (remote commit,
- -- local offer).
+ -- ^ Spend the HTLC directly after it times out (the remote
+ -- commitment, an HTLC we offered).
| SpendHTLCPreimageDirect !HTLC
- -- ^ Spend HTLC directly with preimage (remote commit,
- -- remote offer).
+ -- ^ Spend the HTLC directly with the preimage (the remote
+ -- commitment, an HTLC we received).
| Revoke !RevocationPubkey
- -- ^ Spend revoked to_local with revocation key.
+ -- ^ Spend a revoked to_local output with the revocation key.
| RevokeHTLC !RevocationPubkey !HTLCOutputType
- -- ^ Spend revoked HTLC output with revocation key.
+ -- ^ Spend a revoked HTLC output with the revocation key.
| AnchorSpend !FundingPubkey
- -- ^ Spend anchor output.
+ -- ^ Spend our anchor output.
deriving (Eq, Show, Generic)
+instance NFData OutputResolution
+
-- HTLC output type -------------------------------------------------
--- | Type of HTLC output, restricted to only HTLC variants.
+-- | The kind of an HTLC output, from the commitment owner's point of
+-- view.
--
--- Unlike bolt3's 'OutputType' which includes all six output
--- types, this ADT makes it impossible to confuse HTLC outputs
--- with to_local, to_remote, or anchor outputs.
+-- Unlike bolt3's 'OutputType', this can't describe a to_local,
+-- to_remote or anchor output.
data HTLCOutputType
= HTLCOfferedOutput {-# UNPACK #-} !CltvExpiry
-- ^ Offered HTLC output with CLTV expiry.
@@ -126,63 +135,74 @@ data HTLCOutputType
-- ^ Received HTLC output with CLTV expiry.
deriving (Eq, Show, Generic)
--- | Extract an 'HTLCOutputType' from a bolt3 'OutputType'.
+instance NFData HTLCOutputType
+
+-- | The 'HTLCOutputType' of a bolt3 'OutputType', or 'Nothing' if
+-- it isn't an HTLC output.
--
--- Returns 'Nothing' for non-HTLC output types.
+-- >>> htlc_output_type OutputToLocal
+-- Nothing
+htlc_output_type :: OutputType -> Maybe HTLCOutputType
+htlc_output_type t = case t of
+ OutputHTLC h -> Just $ case htlc_direction h of
+ HTLCOffered -> HTLCOfferedOutput (htlc_cltv_expiry h)
+ HTLCReceived -> HTLCReceivedOutput (htlc_cltv_expiry h)
+ OutputToLocal -> Nothing
+ OutputToRemote -> Nothing
+ OutputLocalAnchor -> Nothing
+ OutputRemoteAnchor -> Nothing
+{-# INLINE htlc_output_type #-}
+
+-- | Penalty input weight for an HTLC output.
--
--- >>> htlcOutputType (OutputOfferedHTLC (CltvExpiry 500))
--- Just (HTLCOfferedOutput (CltvExpiry ...))
--- >>> htlcOutputType OutputToLocal
--- Nothing
-htlcOutputType :: OutputType -> Maybe HTLCOutputType
-htlcOutputType (OutputOfferedHTLC e) =
- Just (HTLCOfferedOutput e)
-htlcOutputType (OutputReceivedHTLC e) =
- Just (HTLCReceivedOutput e)
-htlcOutputType _ = Nothing
-{-# INLINE htlcOutputType #-}
-
--- | Penalty input weight for an HTLC output type.
-htlcOutputTypeWeight :: ChannelFeatures -> HTLCOutputType -> Word64
-htlcOutputTypeWeight !features (HTLCOfferedOutput _)
- | has_anchors features = offered_htlc_penalty_input_weight_anchors
- | otherwise = offered_htlc_penalty_input_weight
-htlcOutputTypeWeight !features (HTLCReceivedOutput _)
- | has_anchors features = accepted_htlc_penalty_input_weight_anchors
- | otherwise = accepted_htlc_penalty_input_weight
-{-# INLINE htlcOutputTypeWeight #-}
+-- >>> htlc_output_type_weight Anchors (HTLCOfferedOutput (CltvExpiry 500))
+-- 410
+htlc_output_type_weight :: CommitmentFormat -> HTLCOutputType -> Word64
+htlc_output_type_weight !fmt !t = case (fmt, t) of
+ (StaticRemotekey, HTLCOfferedOutput _) ->
+ offered_htlc_penalty_input_weight
+ (StaticRemotekey, HTLCReceivedOutput _) ->
+ accepted_htlc_penalty_input_weight
+ (Anchors, HTLCOfferedOutput _) ->
+ offered_htlc_penalty_input_weight_anchors
+ (Anchors, HTLCReceivedOutput _) ->
+ accepted_htlc_penalty_input_weight_anchors
+{-# INLINE htlc_output_type_weight #-}
-- spending transactions ----------------------------------------------
--- | Unsigned spending transaction, ready for caller to sign.
+-- | An unsigned spending transaction, with what the caller needs to
+-- sign its (single) input.
--
--- The caller uses bolt3 witness constructors to assemble the
--- final witness after signing.
+-- The caller signs the input's BIP143 sighash (ppad-tx's
+-- @sighash_segwit@ over 'stx_tx', input 0, 'stx_input_script',
+-- 'stx_input_value' and 'stx_sighash_type') and assembles the
+-- witness with bolt3's witness functions.
data SpendingTx = SpendingTx
{ stx_tx :: !Tx
-- ^ The unsigned transaction.
, stx_input_script :: !Script
- -- ^ Witness script for the input being spent.
+ -- ^ Witness script of the output being spent.
, stx_input_value :: {-# UNPACK #-} !Satoshi
- -- ^ Value of the input being spent (for sighash).
+ -- ^ Value of the output being spent.
, stx_sighash_type :: !SighashType
- -- ^ Sighash type for the local signature.
+ -- ^ Sighash type of the local signature.
} deriving (Eq, Show, Generic)
+instance NFData SpendingTx where
+ rnf (SpendingTx tx s v h) = rnf tx `seq` rnf s `seq` rnf v `seq` h `seq` ()
+
-- revoked outputs ----------------------------------------------------
-- | A revoked output that can be swept with a revocation key.
---
--- This type restricts penalty transaction inputs to only
--- valid revocation targets: to_local outputs and HTLC outputs.
--- Other output types (to_remote, anchors) cannot appear in
--- penalty transactions.
data RevokedOutput = RevokedOutput
{ ro_outpoint :: !OutPoint
, ro_value :: {-# UNPACK #-} !Satoshi
, ro_type :: !RevokedOutputType
} deriving (Eq, Show, Generic)
+instance NFData RevokedOutput
+
-- | What kind of revoked output is being swept.
data RevokedOutputType
= RevokedToLocal
@@ -191,93 +211,104 @@ data RevokedOutputType
-- ^ Revoked HTLC output.
deriving (Eq, Show, Generic)
+instance NFData RevokedOutputType
+
-- | Penalty input weight for a revoked output.
-revoked_output_weight :: ChannelFeatures -> RevokedOutput -> Word64
-revoked_output_weight !features !ro = case ro_type ro of
+revoked_output_weight :: CommitmentFormat -> RevokedOutput -> Word64
+revoked_output_weight !fmt !ro = case ro_type ro of
RevokedToLocal ->
to_local_penalty_input_weight
RevokedHTLC !htype ->
- htlcOutputTypeWeight features htype
+ htlc_output_type_weight fmt htype
{-# INLINE revoked_output_weight #-}
-- weight constants (BOLT #5 Appendix A) ------------------------------
-- | Expected weight of the to_local penalty transaction witness
--- (160 bytes).
+-- (160 weight units).
to_local_penalty_witness_weight :: Word64
to_local_penalty_witness_weight = 160
-- | Expected weight of the offered_htlc penalty transaction
--- witness (243 bytes), for a 133-byte witness script (no
--- option_anchors).
+-- witness (243 weight units), for a 133-byte witness script
+-- (no option_anchors).
offered_htlc_penalty_witness_weight :: Word64
offered_htlc_penalty_witness_weight = 243
-- | Expected weight of the accepted_htlc penalty transaction
--- witness (249 bytes), for a 139-byte witness script (no
--- option_anchors).
+-- witness (249 weight units), for a 139-byte witness script
+-- (no option_anchors).
accepted_htlc_penalty_witness_weight :: Word64
accepted_htlc_penalty_witness_weight = 249
-- | Expected weight of the offered_htlc penalty transaction
--- witness with option_anchors (246 bytes), whose witness script
--- is 136 bytes.
+-- witness with option_anchors (246 weight units), whose witness
+-- script is 136 bytes.
offered_htlc_penalty_witness_weight_anchors :: Word64
offered_htlc_penalty_witness_weight_anchors = 246
-- | Expected weight of the accepted_htlc penalty transaction
--- witness with option_anchors (252 bytes), whose witness script
--- is 142 bytes.
+-- witness with option_anchors (252 weight units), whose witness
+-- script is 142 bytes.
accepted_htlc_penalty_witness_weight_anchors :: Word64
accepted_htlc_penalty_witness_weight_anchors = 252
--- | Weight of a to_local penalty input (164 + 160 = 324 bytes).
+-- | Weight of a to_local penalty input (164 + 160 = 324).
to_local_penalty_input_weight :: Word64
to_local_penalty_input_weight = 324
--- | Weight of an offered_htlc penalty input
--- (164 + 243 = 407 bytes).
+-- | Weight of an offered_htlc penalty input (164 + 243 = 407).
offered_htlc_penalty_input_weight :: Word64
offered_htlc_penalty_input_weight = 407
--- | Weight of an accepted_htlc penalty input
--- (164 + 249 = 413 bytes).
+-- | Weight of an accepted_htlc penalty input (164 + 249 = 413).
accepted_htlc_penalty_input_weight :: Word64
accepted_htlc_penalty_input_weight = 413
-- | Weight of an offered_htlc penalty input with option_anchors
--- (164 + 246 = 410 bytes).
+-- (164 + 246 = 410).
offered_htlc_penalty_input_weight_anchors :: Word64
offered_htlc_penalty_input_weight_anchors = 410
-- | Weight of an accepted_htlc penalty input with option_anchors
--- (164 + 252 = 416 bytes).
+-- (164 + 252 = 416).
accepted_htlc_penalty_input_weight_anchors :: Word64
accepted_htlc_penalty_input_weight_anchors = 416
--- | Weight of a to_remote P2WPKH input
--- (108 + 164 = 272 bytes).
+-- | Weight of a to_remote P2WPKH input (108 + 164 = 272).
to_remote_input_weight :: Word64
to_remote_input_weight = 272
--- | Base weight of a penalty transaction (4*53 + 2 = 214 bytes).
+-- | Base weight of a penalty transaction (4 * 53 + 2 = 214).
--
--- Non-witness: version(4) + input_count(1) + output_count(1) +
--- value(8) + script_len(1) + p2wsh_script(34) + locktime(4) = 53
--- Witness header: 2 bytes.
+-- Non-witness: version (4) + input count (1) + output count (1) +
+-- value (8) + script length (1) + P2WSH script (34) + locktime (4)
+-- = 53 bytes. Witness header: 2 bytes.
+--
+-- The spending transactions here use it as their base weight
+-- whatever their destination script.
penalty_tx_base_weight :: Word64
penalty_tx_base_weight = 214
--- | Maximum standard transaction weight (400,000 bytes).
+-- | Maximum standard transaction weight (400,000).
max_standard_weight :: Word64
max_standard_weight = 400000
-- fee calculation ----------------------------------------------------
--- | Calculate the fee for a spending transaction given its weight.
+-- | The fee for a transaction of the given weight:
+--
+-- @fee = feerate_per_kw * weight / 1000@
+--
+-- rounded down, and saturating at 21 million BTC.
--
--- @fee = feerate_per_kw * weight / 1000@
+-- >>> spending_fee (FeeratePerKw 253) 324
+-- Satoshi 81
spending_fee :: FeeratePerKw -> Word64 -> Satoshi
spending_fee (FeeratePerKw !rate) !weight =
- Satoshi ((fromIntegral rate * weight) `div` 1000)
+ let !f = toInteger rate * toInteger weight `quot` 1000
+ !m = BOLT1.un_satoshi BOLT1.max_satoshi
+ in case BOLT1.satoshi (fromInteger (min f (toInteger m))) of
+ Just s -> s
+ Nothing -> BOLT1.max_satoshi
{-# INLINE spending_fee #-}
diff --git a/ppad-bolt5.cabal b/ppad-bolt5.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ppad-bolt5
-version: 0.0.1
+version: 0.1.0
synopsis: On-chain transaction handling per BOLT #5
license: MIT
license-file: LICENSE
@@ -8,7 +8,7 @@ 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:
On-chain transaction handling, per
@@ -25,16 +25,18 @@ library
-Wall
exposed-modules:
Lightning.Protocol.BOLT5
+ other-modules:
Lightning.Protocol.BOLT5.Detect
- Lightning.Protocol.BOLT5.Internal
Lightning.Protocol.BOLT5.Spend
Lightning.Protocol.BOLT5.Types
build-depends:
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
- , ppad-bolt3 >= 0.0.1 && < 0.1
+ , deepseq >= 1.4 && < 1.6
+ , ppad-bolt1 >= 0.1 && < 0.2
+ , ppad-bolt3 >= 0.1 && < 0.2
, ppad-sha256 >= 0.3.2 && < 0.4
- , ppad-tx >= 0.1 && < 0.2
+ , ppad-tx >= 0.2 && < 0.3
test-suite bolt5-tests
type: exitcode-stdio-1.0
@@ -43,11 +45,12 @@ test-suite bolt5-tests
main-is: Main.hs
ghc-options:
- -rtsopts -Wall -O2
+ -rtsopts -Wall
build-depends:
base
, bytestring
+ , ppad-bolt1
, ppad-bolt3
, ppad-bolt5
, ppad-sha256
@@ -62,17 +65,20 @@ benchmark bolt5-bench
default-language: Haskell2010
hs-source-dirs: bench
main-is: Main.hs
+ other-modules: Fixtures
ghc-options:
- -rtsopts -O2 -Wall -fno-warn-orphans
+ -rtsopts -O2 -Wall
build-depends:
base
, bytestring
, criterion
, deepseq
+ , ppad-bolt1
, ppad-bolt3
, ppad-bolt5
+ , ppad-sha256
, ppad-tx
benchmark bolt5-weigh
@@ -80,15 +86,18 @@ benchmark bolt5-weigh
default-language: Haskell2010
hs-source-dirs: bench
main-is: Weight.hs
+ other-modules: Fixtures
ghc-options:
- -rtsopts -O2 -Wall -fno-warn-orphans
+ -rtsopts -O2 -Wall
build-depends:
base
, bytestring
, deepseq
+ , ppad-bolt1
, ppad-bolt3
, ppad-bolt5
+ , ppad-sha256
, ppad-tx
, weigh
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,17 +1,18 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Bitcoin.Prim.Tx (TxOut(..), from_base16)
+import Bitcoin.Prim.Tx (OutPoint(..), Tx(..), TxId(..), TxIn(..),
+ TxOut(..), Witness(..))
+import qualified Bitcoin.Prim.Tx as BT
import Bitcoin.Prim.Tx.Sighash (SighashType(..), encode_sighash)
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS
import Data.List.NonEmpty (NonEmpty(..))
import Data.Word (Word8, Word32, Word64)
-import Lightning.Protocol.BOLT3 hiding
- (txout_value, txout_script)
-import Lightning.Protocol.BOLT3.Types (Pubkey(..), PaymentHash(..))
+import Lightning.Protocol.BOLT1 (MilliSatoshi, PaymentHash, Satoshi)
+import qualified Lightning.Protocol.BOLT1 as BOLT1
+import Lightning.Protocol.BOLT3
import qualified Lightning.Protocol.BOLT5 as B5
import Test.Tasty
import Test.Tasty.HUnit
@@ -30,40 +31,154 @@ main = defaultMain $ testGroup "ppad-bolt5" [
, property_tests
]
--- test fixtures ------------------------------------------------------
+-- helpers ------------------------------------------------------------
--- Dummy 32-byte hash
-dummyHash32 :: BS.ByteString
-dummyHash32 = BS.replicate 32 0xAA
+-- | Unwrap a Just, failing the enclosing test on Nothing.
+need :: String -> Maybe a -> IO a
+need msg = maybe (assertFailure msg) pure
-dummyTxId :: TxId
-dummyTxId = TxId (BS.replicate 32 0x00)
+sat :: Word64 -> IO Satoshi
+sat = need "invalid satoshi amount" . BOLT1.satoshi
-dummyOutPoint :: OutPoint
-dummyOutPoint = OutPoint dummyTxId 0
+msat :: Word64 -> IO MilliSatoshi
+msat = need "invalid millisatoshi amount" . BOLT1.milli_satoshi
+
+-- | Decode a hex string.
+unhex :: BS.ByteString -> Maybe BS.ByteString
+unhex bs
+ | odd (BS.length bs) = Nothing
+ | otherwise = BS.pack <$> go (BS.unpack bs)
+ where
+ go (a:b:rest) = (:) <$> byte a b <*> go rest
+ go _ = Just []
+ byte a b = (\hi lo -> hi * 16 + lo) <$> nibble a <*> nibble b
+ nibble c
+ | c >= 0x30 && c <= 0x39 = Just (c - 0x30)
+ | c >= 0x61 && c <= 0x66 = Just (c - 0x57)
+ | otherwise = Nothing
--- Dummy 33-byte pubkey. Each role gets its own key, so a key used
--- in the wrong role changes the script.
-mkPubkey :: Word8 -> Pubkey
-mkPubkey b = Pubkey (BS.pack (0x02 : replicate 32 b))
+-- | A point from hex.
+pt :: BS.ByteString -> IO BOLT1.Point
+pt h = need ("invalid point " <> show h) (unhex h >>= BOLT1.point)
-dummyRevocationPubkey :: RevocationPubkey
-dummyRevocationPubkey = RevocationPubkey (mkPubkey 0x01)
+-- | Total head for NonEmpty.
+head' :: NonEmpty a -> a
+head' (x :| _) = x
-dummyLocalDelayedPubkey :: LocalDelayedPubkey
-dummyLocalDelayedPubkey = LocalDelayedPubkey (mkPubkey 0x02)
+-- | Value of a spending transaction's single output.
+out_value :: B5.SpendingTx -> Word64
+out_value = txout_value . head' . tx_outputs . B5.stx_tx
+
+-- | nSequence of a spending transaction's single input.
+in_sequence :: B5.SpendingTx -> Word32
+in_sequence = txin_sequence . head' . tx_inputs . B5.stx_tx
+
+-- fixtures -----------------------------------------------------------
+
+-- | Fixtures shared by the unit and property tests. Each key role
+-- gets its own point, so a key used in the wrong role changes the
+-- script.
+data Fx = Fx
+ { fx_revpk :: !RevocationPubkey
+ , fx_delayed :: !LocalDelayedPubkey
+ , fx_local_htlc :: !LocalHtlcPubkey
+ , fx_remote_htlc :: !RemoteHtlcPubkey
+ , fx_funding :: !FundingPubkey
+ , fx_keys :: !CommitmentKeys
+ , fx_hash :: !PaymentHash
+ , fx_offered :: !HTLC
+ -- ^ offered, 1000 sat, expiry 500000
+ , fx_received :: !HTLC
+ -- ^ as 'fx_offered', but received
+ , fx_local_commit :: !CommitmentTx
+ -- ^ to_local and to_remote outputs
+ , fx_htlc_commit :: !CommitmentTx
+ -- ^ as 'fx_local_commit', plus both HTLCs
+ , fx_remote_commit :: !CommitmentTx
+ -- ^ distinct from 'fx_local_commit'
+ }
-dummyLocalHtlcPubkey :: LocalHtlcPubkey
-dummyLocalHtlcPubkey = LocalHtlcPubkey (mkPubkey 0x03)
+fixtures :: Maybe Fx
+fixtures = do
+ let point b = BOLT1.point (BS.pack (0x02 : replicate 32 b))
+ revpk <- RevocationPubkey <$> point 0x01
+ delayed <- LocalDelayedPubkey <$> point 0x02
+ local_htlc <- LocalHtlcPubkey <$> point 0x03
+ remote_htlc <- RemoteHtlcPubkey <$> point 0x04
+ remote_payment <- RemotePubkey <$> point 0x06
+ funding <- FundingPubkey <$> point 0x07
+ remote_funding <- FundingPubkey <$> point 0x08
+ ph <- BOLT1.payment_hash (BS.replicate 32 0xAA)
+ amt <- BOLT1.milli_satoshi 1000000
+ v1000 <- BOLT1.satoshi 1000
+ v20k <- BOLT1.satoshi 20000
+ v30k <- BOLT1.satoshi 30000
+ v40k <- BOLT1.satoshi 40000
+ v50k <- BOLT1.satoshi 50000
+ let keys = CommitmentKeys
+ { ck_revocation_pubkey = revpk
+ , ck_local_delayed = delayed
+ , ck_local_htlc = local_htlc
+ , ck_remote_htlc = remote_htlc
+ , ck_remote_payment = remote_payment
+ , ck_local_funding = funding
+ , ck_remote_funding = remote_funding
+ }
+ offered = HTLC
+ { htlc_direction = HTLCOffered
+ , htlc_amount_msat = amt
+ , htlc_payment_hash = ph
+ , htlc_cltv_expiry = CltvExpiry 500000
+ }
+ received = offered { htlc_direction = HTLCReceived }
+ to_local = to_p2wsh (to_local_script revpk dummyDelay delayed)
+ htlc_out h = CommitmentOutput v1000
+ (to_p2wsh (htlc_witness_script keys StaticRemotekey h))
+ (OutputHTLC h)
+ commit lt outs = CommitmentTx
+ { ctx_version = 2
+ , ctx_locktime = Locktime lt
+ , ctx_input_outpoint = dummyOutPoint
+ , ctx_input_sequence = Sequence 0
+ , ctx_outputs = outs
+ , ctx_funding_script = dummyDestScript
+ }
+ local_outs =
+ CommitmentOutput v50k to_local OutputToLocal
+ :| [CommitmentOutput v30k dummyDestScript OutputToRemote]
+ pure Fx
+ { fx_revpk = revpk
+ , fx_delayed = delayed
+ , fx_local_htlc = local_htlc
+ , fx_remote_htlc = remote_htlc
+ , fx_funding = funding
+ , fx_keys = keys
+ , fx_hash = ph
+ , fx_offered = offered
+ , fx_received = received
+ , fx_local_commit = commit 0 local_outs
+ , fx_htlc_commit = commit 0 $ local_outs
+ <> (htlc_out offered :| [htlc_out received])
+ , fx_remote_commit = commit 1 $
+ CommitmentOutput v40k to_local OutputToLocal
+ :| [CommitmentOutput v20k dummyDestScript OutputToRemote]
+ }
-dummyRemoteHtlcPubkey :: RemoteHtlcPubkey
-dummyRemoteHtlcPubkey = RemoteHtlcPubkey (mkPubkey 0x04)
+-- | Run a test with the fixtures.
+with_fx :: (Fx -> Assertion) -> Assertion
+with_fx k = need "invalid fixtures" fixtures >>= k
-dummyFundingPubkey :: FundingPubkey
-dummyFundingPubkey = FundingPubkey (mkPubkey 0x07)
+-- | A property over the fixtures.
+prop_fx :: Testable p => (Fx -> p) -> Property
+prop_fx k = case fixtures of
+ Nothing -> counterexample "invalid fixtures" False
+ Just fx -> property (k fx)
-dummyPaymentHash :: PaymentHash
-dummyPaymentHash = PaymentHash dummyHash32
+dummyTxId :: TxId
+dummyTxId = TxId (BS.replicate 32 0x00)
+
+dummyOutPoint :: OutPoint
+dummyOutPoint = OutPoint dummyTxId 0
dummyDelay :: ToSelfDelay
dummyDelay = ToSelfDelay 144
@@ -71,246 +186,141 @@ dummyDelay = ToSelfDelay 144
dummyFeerate :: FeeratePerKw
dummyFeerate = FeeratePerKw 253
-dummyFeatures :: ChannelFeatures
-dummyFeatures = ChannelFeatures False
-
-dummyFeaturesAnchors :: ChannelFeatures
-dummyFeaturesAnchors = ChannelFeatures True
-
+-- | A P2WPKH scriptPubKey.
dummyDestScript :: Script
-dummyDestScript = Script $ BS.pack
- [0x00, 0x14] <> BS.replicate 20 0xCC
-
-dummyKeys :: CommitmentKeys
-dummyKeys = CommitmentKeys
- { ck_revocation_pubkey = dummyRevocationPubkey
- , ck_local_delayed = dummyLocalDelayedPubkey
- , ck_local_htlc = dummyLocalHtlcPubkey
- , ck_remote_htlc = dummyRemoteHtlcPubkey
- , ck_local_payment = LocalPubkey (mkPubkey 0x05)
- , ck_remote_payment = RemotePubkey (mkPubkey 0x06)
- , ck_local_funding = dummyFundingPubkey
- , ck_remote_funding = FundingPubkey (mkPubkey 0x08)
- }
-
-dummyHTLC :: HTLC
-dummyHTLC = HTLC
- { htlc_direction = HTLCOffered
- , htlc_amount_msat = MilliSatoshi 1000000
- , htlc_payment_hash = dummyPaymentHash
- , htlc_cltv_expiry = CltvExpiry 500000
- }
-
-dummyReceivedHTLC :: HTLC
-dummyReceivedHTLC = dummyHTLC
- { htlc_direction = HTLCReceived }
-
-dummyHTLCContext :: HTLCContext
-dummyHTLCContext = HTLCContext
- { hc_commitment_txid = dummyTxId
- , hc_output_index = 0
- , hc_htlc = dummyHTLC
- , hc_to_self_delay = dummyDelay
- , hc_feerate = dummyFeerate
- , hc_features = dummyFeatures
- , hc_revocation_pubkey = dummyRevocationPubkey
- , hc_local_delayed = dummyLocalDelayedPubkey
- }
-
--- Script that matches what findHTLC expects for offered
-offeredScript :: Script
-offeredScript = to_p2wsh $ offered_htlc_script
- dummyRevocationPubkey
- dummyRemoteHtlcPubkey
- dummyLocalHtlcPubkey
- dummyPaymentHash
- dummyFeatures
-
--- Script that matches what findHTLC expects for received
-receivedScript :: Script
-receivedScript = to_p2wsh $ received_htlc_script
- dummyRevocationPubkey
- dummyRemoteHtlcPubkey
- dummyLocalHtlcPubkey
- dummyPaymentHash
- (CltvExpiry 500000)
- dummyFeatures
-
-toLocalScript :: Script
-toLocalScript = to_p2wsh $ to_local_script
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
-
--- CommitmentTx with to_local + to_remote outputs
-dummyLocalCommitTx :: CommitmentTx
-dummyLocalCommitTx = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 0
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs =
- [ TxOutput (Satoshi 50000) toLocalScript
- OutputToLocal
- , TxOutput (Satoshi 30000) dummyDestScript
- OutputToRemote
- ]
- , ctx_funding_script = dummyDestScript
- }
-
--- CommitmentTx with HTLC outputs
-dummyLocalCommitWithHTLCs :: CommitmentTx
-dummyLocalCommitWithHTLCs = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 0
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs =
- [ TxOutput (Satoshi 50000) toLocalScript
- OutputToLocal
- , TxOutput (Satoshi 30000) dummyDestScript
- OutputToRemote
- , TxOutput (Satoshi 1000) offeredScript
- (OutputOfferedHTLC (CltvExpiry 500000))
- , TxOutput (Satoshi 1000) receivedScript
- (OutputReceivedHTLC (CltvExpiry 500000))
- ]
- , ctx_funding_script = dummyDestScript
- }
-
--- A distinct CommitmentTx (different locktime)
-dummyRemoteCommitTx :: CommitmentTx
-dummyRemoteCommitTx = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 1
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs =
- [ TxOutput (Satoshi 40000) toLocalScript
- OutputToLocal
- , TxOutput (Satoshi 20000) dummyDestScript
- OutputToRemote
- ]
- , ctx_funding_script = dummyDestScript
+dummyDestScript = Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0xCC
+
+-- | The witness script of an HTLC output of a commitment with the
+-- given keys.
+htlc_witness_script :: CommitmentKeys -> CommitmentFormat -> HTLC -> Script
+htlc_witness_script keys fmt h = 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
+
+-- | An HTLC context for one of the fixture HTLCs.
+htlc_context :: Fx -> HTLC -> CommitmentFormat -> HTLCContext
+htlc_context fx h fmt = HTLCContext
+ { hc_commitment_txid = dummyTxId
+ , hc_output_index = 0
+ , hc_htlc = h
+ , hc_to_self_delay = dummyDelay
+ , hc_feerate = dummyFeerate
+ , hc_format = fmt
+ , hc_revocation_pubkey = fx_revpk fx
+ , hc_local_delayed = fx_delayed fx
}
-- BOLT #3 Appendix C/F vectors -------------------------------------
-- | Payment hash of an Appendix C HTLC whose preimage is 32 copies
-- of the given byte.
-vecPaymentHash :: Word8 -> PaymentHash
-vecPaymentHash b = PaymentHash (SHA256.hash (BS.replicate 32 b))
-
--- | Decode a hex string.
-unhex :: BS.ByteString -> Maybe BS.ByteString
-unhex bs
- | odd (BS.length bs) = Nothing
- | otherwise = BS.pack <$> go (BS.unpack bs)
- where
- go (a:b:rest) = (:) <$> byte a b <*> go rest
- go _ = Just []
- byte a b = (\hi lo -> hi * 16 + lo) <$> nibble a <*> nibble b
- nibble c
- | c >= 0x30 && c <= 0x39 = Just (c - 0x30)
- | c >= 0x61 && c <= 0x66 = Just (c - 0x57)
- | otherwise = Nothing
+vecPaymentHash :: Word8 -> IO PaymentHash
+vecPaymentHash b =
+ need "payment hash" (BOLT1.payment_hash (SHA256.hash (BS.replicate 32 b)))
-- | An Appendix C HTLC, given its direction, amount (msat), expiry
-- and preimage byte.
-vecHtlc :: HTLCDirection -> Word64 -> Word32 -> Word8 -> HTLC
-vecHtlc dir msat expiry b = HTLC
- { htlc_direction = dir
- , htlc_amount_msat = MilliSatoshi msat
- , htlc_payment_hash = vecPaymentHash b
- , htlc_cltv_expiry = CltvExpiry expiry
- }
+vecHtlc :: HTLCDirection -> Word64 -> Word32 -> Word8 -> IO HTLC
+vecHtlc dir amt expiry b = do
+ a <- msat amt
+ ph <- vecPaymentHash b
+ pure HTLC
+ { htlc_direction = dir
+ , htlc_amount_msat = a
+ , htlc_payment_hash = ph
+ , htlc_cltv_expiry = CltvExpiry expiry
+ }
-vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4 :: HTLC
+vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4 :: IO HTLC
vecHtlc0 = vecHtlc HTLCReceived 1000000 500 0x00
vecHtlc1 = vecHtlc HTLCReceived 2000000 501 0x01
vecHtlc2 = vecHtlc HTLCOffered 2000000 502 0x02
vecHtlc3 = vecHtlc HTLCOffered 3000000 503 0x03
vecHtlc4 = vecHtlc HTLCReceived 4000000 504 0x04
-vecHtlc5, vecHtlc6 :: HTLC
+vecHtlc5, vecHtlc6 :: IO HTLC
vecHtlc5 = vecHtlc HTLCOffered 5000000 506 0x05
vecHtlc6 = vecHtlc HTLCOffered 5000001 505 0x05
-- | Appendix C keys for the local commitment (Appendix F uses the
-- same keys).
-vecKeys :: Maybe CommitmentKeys
+vecKeys :: IO CommitmentKeys
vecKeys = do
- rev <- key
+ rev <- pt
"0212a140cd0c6539d07cd08dfe09984dec3251ea808b892efeac3ede9402bf2b19"
- delayed <- key
+ delayed <- pt
"03fd5960528dc152014952efdb702a88f71e3c1653b2314431701ec77e57fde83c"
- localHtlc <- key
+ localHtlc <- pt
"030d417a46946384f88d5f3337267c5e579765875dc4daca813e21734b140639e7"
- remoteHtlc <- key
+ remoteHtlc <- pt
"0394854aa6eab5b2a8122cc726e9dded053a2184d88256816826d6231c068d4a5b"
- localPayment <- key
- "034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa"
- remotePayment <- key
+ remotePayment <- pt
"032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"
- localFunding <- key
+ localFunding <- pt
"023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"
- remoteFunding <- key
+ remoteFunding <- pt
"030e9f7b623d2ccc7c9bd44d66d5ce21ce504c0acf6385a132cec6d3c39fa711c1"
pure CommitmentKeys
{ ck_revocation_pubkey = RevocationPubkey rev
- , ck_local_delayed = LocalDelayedPubkey delayed
- , ck_local_htlc = LocalHtlcPubkey localHtlc
- , ck_remote_htlc = RemoteHtlcPubkey remoteHtlc
- , ck_local_payment = LocalPubkey localPayment
- , ck_remote_payment = RemotePubkey remotePayment
- , ck_local_funding = FundingPubkey localFunding
- , ck_remote_funding = FundingPubkey remoteFunding
+ , ck_local_delayed = LocalDelayedPubkey delayed
+ , ck_local_htlc = LocalHtlcPubkey localHtlc
+ , ck_remote_htlc = RemoteHtlcPubkey remoteHtlc
+ , ck_remote_payment = RemotePubkey remotePayment
+ , ck_local_funding = FundingPubkey localFunding
+ , ck_remote_funding = FundingPubkey remoteFunding
}
- where
- key h = unhex h >>= pubkey
-- | Rebuild an Appendix C/F local commitment with bolt3, given the
--- feerate, channel features, to_local balance and HTLCs.
+-- feerate, commitment format, to_local balance (msat) and HTLCs.
vecCommitment
- :: FeeratePerKw -> ChannelFeatures -> MilliSatoshi -> [HTLC]
- -> Maybe CommitmentTx
-vecCommitment feerate features toLocal htlcs = do
+ :: FeeratePerKw -> CommitmentFormat -> Word64 -> [HTLC]
+ -> IO CommitmentTx
+vecCommitment feerate fmt toLocal htlcs = do
keys <- vecKeys
- fundingTxid <- mkTxId =<< unhex
+ fundingTxid <- need "funding txid" $ BT.mkTxId =<< unhex
"bef67e4e2fb9ddeeb3461973cd4c62abb35050b1add772995b820b584a488489"
- cn <- commitment_number 42
- localBp <- point =<< unhex
+ cn <- need "commitment number" (commitment_number 42)
+ localBp <- pt
"034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa"
- remoteBp <- point =<< unhex
+ remoteBp <- pt
"032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"
- pure $ build_commitment_tx CommitmentContext
- { cc_funding_outpoint = OutPoint fundingTxid 0
+ dust <- sat 546
+ toLocalMsat <- msat toLocal
+ toRemoteMsat <- msat 3000000000
+ need "build_commitment_tx" $ build_commitment_tx CommitmentContext
+ { cc_funding_outpoint = OutPoint fundingTxid 0
, cc_commitment_number = cn
- , cc_local_payment_bp = PaymentBasepoint localBp
+ , cc_local_payment_bp = PaymentBasepoint localBp
, cc_remote_payment_bp = PaymentBasepoint remoteBp
- , cc_to_self_delay = ToSelfDelay 144
- , cc_dust_limit = DustLimit (Satoshi 546)
- , cc_feerate = feerate
- , cc_features = features
- , cc_is_funder = True
- , cc_to_local_msat = toLocal
- , cc_to_remote_msat = MilliSatoshi 3000000000
- , cc_htlcs = htlcs
- , cc_keys = keys
+ , cc_to_self_delay = ToSelfDelay 144
+ , cc_dust_limit = DustLimit dust
+ , cc_feerate = feerate
+ , cc_format = fmt
+ , cc_is_funder = True
+ , cc_to_local_msat = toLocalMsat
+ , cc_to_remote_msat = toRemoteMsat
+ , cc_htlcs = htlcs
+ , cc_keys = keys
}
-- | The Appendix C commitment with two offered HTLCs sharing a
-- payment hash and amount.
-vecCommitSameHash :: Maybe CommitmentTx
-vecCommitSameHash = vecCommitment (FeeratePerKw 253)
- (ChannelFeatures False) (MilliSatoshi 6987999999)
- [vecHtlc1, vecHtlc5, vecHtlc6]
+vecCommitSameHash :: IO CommitmentTx
+vecCommitSameHash = do
+ h1 <- vecHtlc1
+ h5 <- vecHtlc5
+ h6 <- vecHtlc6
+ vecCommitment (FeeratePerKw 253) StaticRemotekey 6987999999 [h1, h5, h6]
-- | The Appendix F (anchors) "commitment tx with seven outputs
-- untrimmed".
-vecCommitAnchors :: Maybe CommitmentTx
-vecCommitAnchors = vecCommitment (FeeratePerKw 644)
- (ChannelFeatures True) (MilliSatoshi 6988000000)
- [vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4]
+vecCommitAnchors :: IO CommitmentTx
+vecCommitAnchors = do
+ hs <- sequence [vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4]
+ vecCommitment (FeeratePerKw 644) Anchors 6988000000 hs
-- | Appendix C: commitment tx with 3 htlc outputs, 2 offered
-- having the same amount and preimage (signed).
@@ -420,9 +430,10 @@ vecFHtlcSuccess1 =
\875dc4daca813e21734b140639e752ae677502f501b175ac6851b27568000000\
\00"
+
-- | Parse a hex-encoded transaction, failing the test otherwise.
parseTx :: BS.ByteString -> IO Tx
-parseTx = assertJust "invalid transaction hex" . from_base16
+parseTx = need "invalid transaction hex" . BT.from_base16
-- | Witness stack of a single-input transaction.
singleWitness :: Tx -> IO [BS.ByteString]
@@ -432,32 +443,42 @@ singleWitness tx = case tx_witnesses tx of
-- | Remote signature and offered HTLC witness script, taken from the
-- Appendix C HTLC-timeout tx for htlc #5.
-offeredClaimParts :: IO (BS.ByteString, BS.ByteString)
+offeredClaimParts :: IO (BS.ByteString, Script)
offeredClaimParts = do
items <- singleWitness =<< parseTx vecCHtlcTimeout5
case items of
- [_, sig, _, _, script] -> pure (sig, script)
+ [_, sig, _, _, script] -> pure (sig, Script script)
_ -> assertFailure "unexpected HTLC-timeout witness"
+-- | Signatures and received HTLC witness script, taken from the
+-- Appendix C HTLC-success tx for htlc #1.
+successParts :: IO (BS.ByteString, BS.ByteString, Script)
+successParts = do
+ items <- singleWitness =<< parseTx vecCHtlcSuccess1
+ case items of
+ [_, remoteSig, localSig, _, script] ->
+ pure (remoteSig, localSig, Script script)
+ _ -> assertFailure "unexpected HTLC-success witness"
+
-- | Build the HTLC tx for an HTLC output of an Appendix C/F
-- commitment (to_self_delay 144).
vecHtlcTx :: FeeratePerKw -> B5.UnresolvedOutput -> IO B5.SpendingTx
vecHtlcTx feerate uo = case B5.uo_type uo of
- B5.SpendHTLCTimeout htlc keys features ->
- pure (B5.spend_htlc_timeout (ctx htlc keys features) keys)
- B5.SpendHTLCSuccess htlc keys features ->
- pure (B5.spend_htlc_success (ctx htlc keys features) keys)
+ B5.SpendHTLCTimeout htlc keys fmt -> build htlc keys fmt
+ B5.SpendHTLCSuccess htlc keys fmt -> build htlc keys fmt
other -> assertFailure ("expected an HTLC output, got " <> show other)
where
- ctx htlc keys features = HTLCContext
- { hc_commitment_txid = op_txid (B5.uo_outpoint uo)
- , hc_output_index = op_vout (B5.uo_outpoint uo)
- , hc_htlc = htlc
- , hc_to_self_delay = ToSelfDelay 144
- , hc_feerate = feerate
- , hc_features = features
+ build htlc keys fmt = need "spend_htlc_tx" $
+ B5.spend_htlc_tx (ctx htlc keys fmt) keys
+ ctx htlc keys fmt = HTLCContext
+ { hc_commitment_txid = op_txid (B5.uo_outpoint uo)
+ , hc_output_index = op_vout (B5.uo_outpoint uo)
+ , hc_htlc = htlc
+ , hc_to_self_delay = ToSelfDelay 144
+ , hc_feerate = feerate
+ , hc_format = fmt
, hc_revocation_pubkey = ck_revocation_pubkey keys
- , hc_local_delayed = ck_local_delayed keys
+ , hc_local_delayed = ck_local_delayed keys
}
-- | Check an HTLC tx against a signed BOLT #3 vector: the unsigned
@@ -473,14 +494,14 @@ assertHtlcTx stx vec = do
-- | Check the sighash flags of the signatures in a signed BOLT #3
-- HTLC-tx vector: the local one must be the type the 'SpendingTx'
--- gives, the remote one the given type.
+-- gives, the remote one bolt3's 'remote_htlc_sighash'.
assertSighashFlags
- :: B5.SpendingTx -> SighashType -> BS.ByteString -> Assertion
-assertSighashFlags stx remoteType vec = do
+ :: B5.SpendingTx -> CommitmentFormat -> BS.ByteString -> Assertion
+assertSighashFlags stx fmt vec = do
items <- singleWitness =<< parseTx vec
case items of
[_, remoteSig, localSig, _, _] -> do
- flag remoteSig @?= Just (encode_sighash remoteType)
+ flag remoteSig @?= Just (encode_sighash (remote_htlc_sighash fmt))
flag localSig
@?= Just (encode_sighash (B5.stx_sighash_type stx))
_ -> assertFailure "unexpected HTLC-tx witness"
@@ -497,14 +518,16 @@ types_tests = testGroup "Types" [
B5.RemoteCommitClose @?= B5.RemoteCommitClose
B5.RevokedCommitClose @?= B5.RevokedCommitClose
- , testCase "spending_fee calculation" $ do
- let fee = B5.spending_fee (FeeratePerKw 1000) 500
- fee @?= Satoshi 500
+ , testCase "spending_fee calculation" $
+ BOLT1.un_satoshi (B5.spending_fee (FeeratePerKw 1000) 500) @?= 500
- , testCase "spending_fee at low feerate" $ do
- let fee = B5.spending_fee (FeeratePerKw 253) 324
+ , testCase "spending_fee at low feerate" $
-- 253 * 324 / 1000 = 81.972 -> 81
- fee @?= Satoshi 81
+ BOLT1.un_satoshi (B5.spending_fee (FeeratePerKw 253) 324) @?= 81
+
+ , testCase "spending_fee saturates at 21 million BTC" $
+ B5.spending_fee (FeeratePerKw maxBound) maxBound
+ @?= BOLT1.max_satoshi
, testCase "weight constants" $ do
B5.to_local_penalty_witness_weight @?= 160
@@ -523,481 +546,359 @@ detect_tests :: TestTree
detect_tests = testGroup "Detect" [
testCase "extract_preimage_htlc_success - Appendix C" $ do
items <- singleWitness =<< parseTx vecCHtlcSuccess1
- fmap unPaymentPreimage
- (B5.extract_preimage_htlc_success
- (vecPaymentHash 0x01) (Witness items))
+ ph <- vecPaymentHash 0x01
+ fmap BOLT1.un_payment_preimage
+ (B5.extract_preimage_htlc_success ph (Witness items))
@?= Just (BS.replicate 32 0x01)
, testCase "extract_preimage_htlc_success - Appendix F" $ do
items <- singleWitness =<< parseTx vecFHtlcSuccess1
- fmap unPaymentPreimage
- (B5.extract_preimage_htlc_success
- (vecPaymentHash 0x01) (Witness items))
+ ph <- vecPaymentHash 0x01
+ fmap BOLT1.un_payment_preimage
+ (B5.extract_preimage_htlc_success ph (Witness items))
@?= Just (BS.replicate 32 0x01)
+ , testCase "extract_preimage_htlc_success - bolt3 witness" $ do
+ (remoteSig, localSig, script) <- successParts
+ ph <- vecPaymentHash 0x01
+ preimage <- need "preimage"
+ (BOLT1.payment_preimage (BS.replicate 32 0x01))
+ B5.extract_preimage_htlc_success ph
+ (htlc_success_witness remoteSig localSig preimage script)
+ @?= Just preimage
+
, testCase "extract_preimage_htlc_success - wrong hash" $ do
items <- singleWitness =<< parseTx vecCHtlcSuccess1
- B5.extract_preimage_htlc_success
- (vecPaymentHash 0x05) (Witness items)
- @?= Nothing
+ ph <- vecPaymentHash 0x05
+ B5.extract_preimage_htlc_success ph (Witness items) @?= Nothing
, testCase "extract_preimage_htlc_success - timeout witness" $ do
items <- singleWitness =<< parseTx vecCHtlcTimeout5
- B5.extract_preimage_htlc_success
- (vecPaymentHash 0x05) (Witness items)
+ ph <- vecPaymentHash 0x05
+ B5.extract_preimage_htlc_success ph (Witness items) @?= Nothing
+ (remoteSig, localSig, script) <- successParts
+ B5.extract_preimage_htlc_success ph
+ (htlc_timeout_witness remoteSig localSig script)
@?= Nothing
, testCase "extract_preimage_htlc_success - no script" $ do
items <- singleWitness =<< parseTx vecCHtlcSuccess1
- B5.extract_preimage_htlc_success
- (vecPaymentHash 0x01) (Witness (take 4 items))
+ ph <- vecPaymentHash 0x01
+ B5.extract_preimage_htlc_success ph (Witness (take 4 items))
@?= Nothing
, testCase "extract_preimage_offered - remote claim" $ do
-- <remotehtlcsig> <payment_preimage> <witness_script>; the
-- signature is not checked.
(sig, script) <- offeredClaimParts
- let preimage = BS.replicate 32 0x05
- fmap unPaymentPreimage
- (B5.extract_preimage_offered (vecPaymentHash 0x05)
- (Witness [sig, preimage, script]))
+ ph <- vecPaymentHash 0x05
+ preimage <- need "preimage"
+ (BOLT1.payment_preimage (BS.replicate 32 0x05))
+ B5.extract_preimage_offered ph
+ (offered_htlc_witness_preimage sig preimage script)
@?= Just preimage
, testCase "extract_preimage_offered - wrong hash" $ do
(sig, script) <- offeredClaimParts
- B5.extract_preimage_offered (vecPaymentHash 0x01)
- (Witness [sig, BS.replicate 32 0x05, script])
+ ph <- vecPaymentHash 0x01
+ preimage <- need "preimage"
+ (BOLT1.payment_preimage (BS.replicate 32 0x05))
+ B5.extract_preimage_offered ph
+ (offered_htlc_witness_preimage sig preimage script)
@?= Nothing
- , testCase "extract_preimage_offered - revocation spend" $ do
- -- <revocation_sig> <revocationpubkey> <witness_script>
- (sig, script) <- offeredClaimParts
- B5.extract_preimage_offered (vecPaymentHash 0x05)
- (Witness [sig, unPubkey (mkPubkey 0x01), script])
- @?= Nothing
+ , testCase "extract_preimage_offered - revocation spend" $ with_fx $
+ \fx -> do
+ -- <revocation_sig> <revocationpubkey> <witness_script>
+ (sig, script) <- offeredClaimParts
+ ph <- vecPaymentHash 0x05
+ B5.extract_preimage_offered ph
+ (offered_htlc_witness_revoke sig (fx_revpk fx) script)
+ @?= Nothing
, testCase "extract_preimage_offered - no script" $ do
(sig, _) <- offeredClaimParts
- B5.extract_preimage_offered (vecPaymentHash 0x05)
+ ph <- vecPaymentHash 0x05
+ B5.extract_preimage_offered ph
(Witness [sig, BS.replicate 32 0x05])
@?= Nothing
- , testCase "htlc_timed_out - at expiry" $ do
- let htlc = dummyHTLC
- { htlc_cltv_expiry = CltvExpiry 500000 }
- B5.htlc_timed_out 500000 htlc @?= True
+ , testCase "htlc_timed_out - at expiry" $ with_fx $ \fx ->
+ B5.htlc_timed_out 500000 (fx_offered fx) @?= True
- , testCase "htlc_timed_out - past expiry" $ do
- let htlc = dummyHTLC
- { htlc_cltv_expiry = CltvExpiry 500000 }
- B5.htlc_timed_out 500001 htlc @?= True
+ , testCase "htlc_timed_out - past expiry" $ with_fx $ \fx ->
+ B5.htlc_timed_out 500001 (fx_offered fx) @?= True
- , testCase "htlc_timed_out - before expiry" $ do
- let htlc = dummyHTLC
- { htlc_cltv_expiry = CltvExpiry 500000 }
- B5.htlc_timed_out 499999 htlc @?= False
+ , testCase "htlc_timed_out - before expiry" $ with_fx $ \fx ->
+ B5.htlc_timed_out 499999 (fx_offered fx) @?= False
]
-- classify tests -----------------------------------------------------
classify_tests :: TestTree
classify_tests = testGroup "Classify" [
- testCase "identify_close - signed local commitment" $ do
- commit <- assertJust "commitment" vecCommitSameHash
- signed <- assertJust "hex" (unhex vecCCommitSameHash)
- B5.identify_close commit dummyRemoteCommitTx signed
+ testCase "identify_close - signed local commitment" $ with_fx $
+ \fx -> do
+ commit <- vecCommitSameHash
+ signed <- need "hex" (unhex vecCCommitSameHash)
+ B5.identify_close commit (fx_remote_commit fx) signed
+ @?= Just B5.LocalCommitClose
+
+ , testCase "identify_close - signed remote commitment" $ with_fx $
+ \fx -> do
+ commit <- vecCommitSameHash
+ signed <- need "hex" (unhex vecCCommitSameHash)
+ B5.identify_close (fx_local_commit fx) commit signed
+ @?= Just B5.RemoteCommitClose
+
+ , testCase "identify_close - unsigned commitment" $ with_fx $ \fx -> do
+ commit <- vecCommitSameHash
+ B5.identify_close commit (fx_remote_commit fx)
+ (encode_commitment_tx commit)
@?= Just B5.LocalCommitClose
- , testCase "identify_close - signed remote commitment" $ do
- commit <- assertJust "commitment" vecCommitSameHash
- signed <- assertJust "hex" (unhex vecCCommitSameHash)
- B5.identify_close dummyLocalCommitTx commit signed
- @?= Just B5.RemoteCommitClose
-
- , testCase "identify_close - unsigned commitment" $ do
- commit <- assertJust "commitment" vecCommitSameHash
- unsigned <- assertJust "encode" (encode_tx_for_signing commit)
- B5.identify_close commit dummyRemoteCommitTx unsigned
- @?= Just B5.LocalCommitClose
-
- , testCase "identify_close - no match" $ do
- signed <- assertJust "hex" (unhex vecCCommitSameHash)
- B5.identify_close
- dummyLocalCommitTx dummyRemoteCommitTx signed
+ , testCase "identify_close - no match" $ with_fx $ \fx -> do
+ signed <- need "hex" (unhex vecCCommitSameHash)
+ B5.identify_close (fx_local_commit fx) (fx_remote_commit fx) signed
@?= Nothing
- , testCase "identify_close - unparseable" $ do
- B5.identify_close
- dummyLocalCommitTx
- dummyRemoteCommitTx
+ , testCase "identify_close - unparseable" $ with_fx $ \fx ->
+ B5.identify_close (fx_local_commit fx) (fx_remote_commit fx)
"unknown bytes"
- @?= Nothing
+ @?= Nothing
- , testCase "classify_local - to_local and to_remote" $ do
- let outs = B5.classify_local_commit_outputs
- dummyLocalCommitTx dummyKeys
- dummyDelay dummyFeatures []
- length outs @?= 2
- case outs of
- [o1, o2] -> do
- case B5.uo_type o1 of
- B5.SpendToLocal d rk dk -> do
- d @?= dummyDelay
- rk @?= dummyRevocationPubkey
- dk @?= dummyLocalDelayedPubkey
- other -> assertFailure $
- "expected SpendToLocal, got " <> show other
- B5.uo_type o2 @?= B5.Resolved
- _ -> assertFailure "expected 2 outputs"
-
- , testCase "classify_local - HTLC outputs" $ do
- let outs = B5.classify_local_commit_outputs
- dummyLocalCommitWithHTLCs dummyKeys
- dummyDelay dummyFeatures
- [dummyHTLC, dummyReceivedHTLC]
- length outs @?= 4
- case outs of
- [_, _, o3, o4] -> do
- case B5.uo_type o3 of
- B5.SpendHTLCTimeout _ _ _ -> pure ()
- other -> assertFailure $
- "expected SpendHTLCTimeout, got "
- <> show other
- case B5.uo_type o4 of
- B5.SpendHTLCSuccess _ _ _ -> pure ()
- other -> assertFailure $
- "expected SpendHTLCSuccess, got "
- <> show other
- _ -> assertFailure "expected 4 outputs"
-
- , testCase "classify_remote - HTLC outputs" $ do
- let commitTx = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 0
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs =
- [ TxOutput (Satoshi 50000) toLocalScript
- OutputToLocal
- , TxOutput (Satoshi 1000) offeredScript
- (OutputOfferedHTLC
- (CltvExpiry 500000))
- , TxOutput (Satoshi 1000) receivedScript
- (OutputReceivedHTLC
- (CltvExpiry 500000))
- ]
- , ctx_funding_script = dummyDestScript
+ , testCase "classify_local - to_local and to_remote" $ with_fx $ \fx ->
+ map B5.uo_type
+ (B5.classify_local_commit_outputs (fx_local_commit fx)
+ (fx_keys fx) dummyDelay StaticRemotekey)
+ @?= [ B5.SpendToLocal dummyDelay (fx_revpk fx) (fx_delayed fx)
+ , B5.Resolved
+ ]
+
+ , testCase "classify_local - outpoints and values" $ with_fx $ \fx -> do
+ let commit = fx_htlc_commit fx
+ txid = BT.txid (commitment_to_tx commit)
+ outs = B5.classify_local_commit_outputs commit (fx_keys fx)
+ dummyDelay StaticRemotekey
+ map B5.uo_outpoint outs @?= map (OutPoint txid) [0 .. 3]
+ map (BOLT1.un_satoshi . B5.uo_value) outs
+ @?= [50000, 30000, 1000, 1000]
+
+ , testCase "classify_local - HTLC outputs" $ with_fx $ \fx ->
+ map B5.uo_type
+ (drop 2 (B5.classify_local_commit_outputs (fx_htlc_commit fx)
+ (fx_keys fx) dummyDelay StaticRemotekey))
+ @?= [ B5.SpendHTLCTimeout (fx_offered fx) (fx_keys fx)
+ StaticRemotekey
+ , B5.SpendHTLCSuccess (fx_received fx) (fx_keys fx)
+ StaticRemotekey
+ ]
+
+ , testCase "classify_remote - HTLC outputs" $ with_fx $ \fx ->
+ map B5.uo_type
+ (B5.classify_remote_commit_outputs (fx_htlc_commit fx)
+ (fx_keys fx))
+ @?= [ B5.Resolved
+ , B5.Resolved
+ , B5.SpendHTLCPreimageDirect (fx_offered fx)
+ , B5.SpendHTLCTimeoutDirect (fx_received fx)
+ ]
+
+ , testCase "classify_revoked - to_local and HTLCs" $ with_fx $ \fx ->
+ map B5.uo_type
+ (B5.classify_revoked_commit_outputs (fx_htlc_commit fx)
+ (fx_revpk fx))
+ @?= [ B5.Revoke (fx_revpk fx)
+ , B5.Resolved
+ , B5.RevokeHTLC (fx_revpk fx)
+ (B5.HTLCOfferedOutput (CltvExpiry 500000))
+ , B5.RevokeHTLC (fx_revpk fx)
+ (B5.HTLCReceivedOutput (CltvExpiry 500000))
+ ]
+
+ , testCase "classify - anchor outputs" $ with_fx $ \fx -> do
+ v330 <- sat 330
+ let keys = fx_keys fx
+ anchor pk = to_p2wsh (anchor_script pk)
+ commit = (fx_local_commit fx)
+ { ctx_outputs =
+ CommitmentOutput v330 (anchor (ck_local_funding keys))
+ OutputLocalAnchor
+ :| [CommitmentOutput v330
+ (anchor (ck_remote_funding keys))
+ OutputRemoteAnchor]
}
- outs = B5.classify_remote_commit_outputs
- commitTx dummyKeys dummyFeatures
- [dummyHTLC, dummyReceivedHTLC]
- length outs @?= 3
- case outs of
- [o1, o2, o3] -> do
- B5.uo_type o1 @?= B5.Resolved
- case B5.uo_type o2 of
- B5.SpendHTLCPreimageDirect _ -> pure ()
- other -> assertFailure $
- "expected SpendHTLCPreimageDirect, got "
- <> show other
- case B5.uo_type o3 of
- B5.SpendHTLCTimeoutDirect _ -> pure ()
- other -> assertFailure $
- "expected SpendHTLCTimeoutDirect, got "
- <> show other
- _ -> assertFailure "expected 3 outputs"
-
- , testCase "classify_revoked - to_local revoked" $ do
- let outs = B5.classify_revoked_commit_outputs
- dummyLocalCommitWithHTLCs dummyKeys
- dummyRevocationPubkey dummyFeatures
- [dummyHTLC, dummyReceivedHTLC]
- length outs @?= 4
- case outs of
- [o1, o2, o3, o4] -> do
- B5.uo_type o1
- @?= B5.Revoke dummyRevocationPubkey
- B5.uo_type o2 @?= B5.Resolved
- case B5.uo_type o3 of
- B5.RevokeHTLC _ (B5.HTLCOfferedOutput _) ->
- pure ()
- other -> assertFailure $
- "expected RevokeHTLC offered, got "
- <> show other
- case B5.uo_type o4 of
- B5.RevokeHTLC _ (B5.HTLCReceivedOutput _) ->
- pure ()
- other -> assertFailure $
- "expected RevokeHTLC received, got "
- <> show other
- _ -> assertFailure "expected 4 outputs"
-
- , testCase "classify_local - anchor outputs" $ do
- let anchorScript = to_p2wsh $
- anchor_script dummyFundingPubkey
- remoteFundPk = ck_remote_funding dummyKeys
- remoteAnchorScript = to_p2wsh $
- anchor_script remoteFundPk
- commitTx = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 0
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs =
- [ TxOutput (Satoshi 330) anchorScript
- OutputLocalAnchor
- , TxOutput (Satoshi 330) remoteAnchorScript
- OutputRemoteAnchor
- ]
- , ctx_funding_script = dummyDestScript
- }
- outs = B5.classify_local_commit_outputs
- commitTx dummyKeys dummyDelay
- dummyFeaturesAnchors []
- length outs @?= 2
- case outs of
- [o1, o2] -> do
- case B5.uo_type o1 of
- B5.AnchorSpend _ -> pure ()
- other -> assertFailure $
- "expected AnchorSpend, got "
- <> show other
- B5.uo_type o2 @?= B5.Resolved
- _ -> assertFailure "expected 2 outputs"
-
- , testCase "classify_remote - non-HTLC outputs" $ do
- let outs = B5.classify_remote_commit_outputs
- dummyRemoteCommitTx dummyKeys
- dummyFeatures []
- length outs @?= 2
- case outs of
- [o1, o2] -> do
- B5.uo_type o1 @?= B5.Resolved
- B5.uo_type o2 @?= B5.Resolved
- _ -> assertFailure "expected 2 outputs"
-
- , testCase "classify_local - unmatched HTLC" $ do
- let outs = B5.classify_local_commit_outputs
- dummyLocalCommitWithHTLCs dummyKeys
- dummyDelay dummyFeatures []
- -- With no HTLCs passed, HTLC outputs -> Resolved
- length outs @?= 4
- case outs of
- [_, _, o3, o4] -> do
- B5.uo_type o3 @?= B5.Resolved
- B5.uo_type o4 @?= B5.Resolved
- _ -> assertFailure "expected 4 outputs"
-
- , testCase "classify_local - empty commit" $ do
- let emptyCommit = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 0
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs = []
- , ctx_funding_script = dummyDestScript
- }
- B5.classify_local_commit_outputs
- emptyCommit dummyKeys dummyDelay
- dummyFeatures []
- @?= []
+ map B5.uo_type
+ (B5.classify_local_commit_outputs commit keys dummyDelay Anchors)
+ @?= [B5.AnchorSpend (ck_local_funding keys), B5.Resolved]
+ map B5.uo_type (B5.classify_remote_commit_outputs commit keys)
+ @?= [B5.Resolved, B5.AnchorSpend (ck_remote_funding keys)]
+ map B5.uo_type
+ (B5.classify_revoked_commit_outputs commit (fx_revpk fx))
+ @?= [B5.Resolved, B5.Resolved]
+
+ , testCase "classify_remote - non-HTLC outputs" $ with_fx $ \fx ->
+ map B5.uo_type
+ (B5.classify_remote_commit_outputs (fx_remote_commit fx)
+ (fx_keys fx))
+ @?= [B5.Resolved, B5.Resolved]
, testCase "classify_local - HTLCs sharing a payment hash" $ do
-- Appendix C: htlcs #5 and #6 share a payment hash and amount
-- (5000 sat) and differ only in CLTV expiry (506 and 505).
- commit <- assertJust "commitment" vecCommitSameHash
- keys <- assertJust "keys" vecKeys
- let features = ChannelFeatures False
- outs = B5.classify_local_commit_outputs commit keys
- (ToSelfDelay 144) features
- [vecHtlc1, vecHtlc5, vecHtlc6]
+ commit <- vecCommitSameHash
+ keys <- vecKeys
+ h1 <- vecHtlc1
+ h5 <- vecHtlc5
+ h6 <- vecHtlc6
+ let outs = B5.classify_local_commit_outputs commit keys
+ (ToSelfDelay 144) StaticRemotekey
map B5.uo_type (take 3 outs) @?=
- [ B5.SpendHTLCSuccess vecHtlc1 keys features
- , B5.SpendHTLCTimeout vecHtlc6 keys features
- , B5.SpendHTLCTimeout vecHtlc5 keys features
+ [ B5.SpendHTLCSuccess h1 keys StaticRemotekey
+ , B5.SpendHTLCTimeout h6 keys StaticRemotekey
+ , B5.SpendHTLCTimeout h5 keys StaticRemotekey
]
, testCase "HTLC txs - Appendix C, shared payment hash" $ do
- commit <- assertJust "commitment" vecCommitSameHash
- keys <- assertJust "keys" vecKeys
+ commit <- vecCommitSameHash
+ keys <- vecKeys
let outs = B5.classify_local_commit_outputs commit keys
- (ToSelfDelay 144) (ChannelFeatures False)
- [vecHtlc1, vecHtlc5, vecHtlc6]
+ (ToSelfDelay 144) StaticRemotekey
case outs of
o0 : o1 : o2 : _ -> do
stx0 <- vecHtlcTx (FeeratePerKw 253) o0
assertHtlcTx stx0 vecCHtlcSuccess1
stx1 <- vecHtlcTx (FeeratePerKw 253) o1
assertHtlcTx stx1 vecCHtlcTimeout6
- assertSighashFlags stx1 SIGHASH_ALL vecCHtlcTimeout6
+ assertSighashFlags stx1 StaticRemotekey vecCHtlcTimeout6
stx2 <- vecHtlcTx (FeeratePerKw 253) o2
assertHtlcTx stx2 vecCHtlcTimeout5
_ -> assertFailure "expected at least 3 outputs"
, testCase "classify_remote - HTLCs sharing a payment hash" $ do
- commit <- assertJust "commitment" vecCommitSameHash
- keys <- assertJust "keys" vecKeys
+ commit <- vecCommitSameHash
+ keys <- vecKeys
+ h1 <- vecHtlc1
+ h5 <- vecHtlc5
+ h6 <- vecHtlc6
let outs = B5.classify_remote_commit_outputs commit keys
- (ChannelFeatures False)
- [vecHtlc1, vecHtlc5, vecHtlc6]
map B5.uo_type (take 3 outs) @?=
- [ B5.SpendHTLCTimeoutDirect vecHtlc1
- , B5.SpendHTLCPreimageDirect vecHtlc6
- , B5.SpendHTLCPreimageDirect vecHtlc5
+ [ B5.SpendHTLCTimeoutDirect h1
+ , B5.SpendHTLCPreimageDirect h6
+ , B5.SpendHTLCPreimageDirect h5
]
, testCase "classify_local - HTLCs differing only in amount" $ do
- let hA = vecHtlc HTLCOffered 5000000 600 0x07
- hB = vecHtlc HTLCOffered 9000000 600 0x07
- features = ChannelFeatures False
- commit <- assertJust "commitment" $ vecCommitment
- (FeeratePerKw 253) features (MilliSatoshi 6000000000)
- [hA, hB]
- keys <- assertJust "keys" vecKeys
+ hA <- vecHtlc HTLCOffered 5000000 600 0x07
+ hB <- vecHtlc HTLCOffered 9000000 600 0x07
+ commit <- vecCommitment (FeeratePerKw 253) StaticRemotekey
+ 6000000000 [hB, hA]
+ keys <- vecKeys
let outs = B5.classify_local_commit_outputs commit keys
- (ToSelfDelay 144) features [hB, hA]
- [ (B5.uo_value o, h)
+ (ToSelfDelay 144) StaticRemotekey
+ [ (BOLT1.un_satoshi (B5.uo_value o), h)
| o <- outs
, B5.SpendHTLCTimeout h _ _ <- [B5.uo_type o] ]
- @?= [(Satoshi 5000, hA), (Satoshi 9000, hB)]
-
- , testCase "classify_local - each HTLC matches one output" $ do
- let h = vecHtlc HTLCOffered 5000000 600 0x07
- features = ChannelFeatures False
- commit <- assertJust "commitment" $ vecCommitment
- (FeeratePerKw 253) features (MilliSatoshi 6000000000)
- [h, h]
- keys <- assertJust "keys" vecKeys
- let timeouts hs = length
+ @?= [(5000, hA), (9000, hB)]
+
+ , testCase "classify_local - one resolution per HTLC output" $ do
+ h <- vecHtlc HTLCOffered 5000000 600 0x07
+ keys <- vecKeys
+ let timeouts commit = length
[ ()
| o <- B5.classify_local_commit_outputs commit keys
- (ToSelfDelay 144) features hs
+ (ToSelfDelay 144) StaticRemotekey
, B5.SpendHTLCTimeout {} <- [B5.uo_type o] ]
- timeouts [h] @?= 1
- timeouts [h, h] @?= 2
+ one <- vecCommitment (FeeratePerKw 253) StaticRemotekey
+ 6000000000 [h]
+ two <- vecCommitment (FeeratePerKw 253) StaticRemotekey
+ 6000000000 [h, h]
+ timeouts one @?= 1
+ timeouts two @?= 2
]
-- spend tests --------------------------------------------------------
spend_tests :: TestTree
spend_tests = testGroup "Spend" [
- testCase "spend_to_local produces valid tx" $ do
- stx <- assertJust "spend_to_local" $
- B5.spend_to_local
- dummyOutPoint
- (Satoshi 100000)
- dummyRevocationPubkey
- dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript
- dummyFeerate
+ testCase "spend_to_local produces valid tx" $ with_fx $ \fx -> do
+ value <- sat 100000
+ stx <- need "spend_to_local" $
+ B5.spend_to_local dummyOutPoint value (fx_revpk fx) dummyDelay
+ (fx_delayed fx) dummyDestScript dummyFeerate
let tx = B5.stx_tx stx
- -- Version should be 2
tx_version tx @?= 2
- -- Single input
length (tx_inputs tx) @?= 1
- -- Single output
length (tx_outputs tx) @?= 1
- -- Output value should be less than input
- let outVal = txout_value
- (head' (tx_outputs tx))
- assertBool "output < input"
- (outVal < 100000)
- -- Sighash should be ALL
+ assertBool "output < input" (out_value stx < 100000)
B5.stx_sighash_type stx @?= SIGHASH_ALL
- -- Input value should match
- B5.stx_input_value stx @?= Satoshi 100000
- -- nSequence should encode delay
- let inp = head' (tx_inputs tx)
- txin_sequence inp @?= fromIntegral
- (unToSelfDelay dummyDelay)
-
- , testCase "spend_to_local fee deduction" $ do
- let value = Satoshi 100000
- stx <- assertJust "spend_to_local" $
- B5.spend_to_local
- dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
- outVal = txout_value
- (head' (tx_outputs tx))
- expectedFee = B5.spending_fee dummyFeerate
- (B5.to_local_penalty_input_weight
- + B5.penalty_tx_base_weight)
- Satoshi outVal @?=
- Satoshi (unSatoshi value
- - unSatoshi expectedFee)
-
- , testCase "spend_revoked_to_local nSequence" $ do
- stx <- assertJust "spend_revoked_to_local" $
- B5.spend_revoked_to_local
- dummyOutPoint (Satoshi 100000)
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
- inp = head' (tx_inputs tx)
- txin_sequence inp @?= 0xFFFFFFFF
-
- , testCase "spend_anchor_owner tx structure" $ do
- let stx = B5.spend_anchor_owner
- dummyOutPoint (Satoshi 330)
- dummyFundingPubkey dummyDestScript
+ B5.stx_input_value stx @?= value
+ B5.stx_input_script stx
+ @?= to_local_script (fx_revpk fx) dummyDelay (fx_delayed fx)
+ -- nSequence encodes the delay
+ in_sequence stx @?= 144
+
+ , testCase "spend_to_local fee deduction" $ with_fx $ \fx -> do
+ value <- sat 100000
+ stx <- need "spend_to_local" $
+ B5.spend_to_local dummyOutPoint value (fx_revpk fx) dummyDelay
+ (fx_delayed fx) dummyDestScript dummyFeerate
+ let fee = B5.spending_fee dummyFeerate
+ (B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight)
+ out_value stx @?= 100000 - BOLT1.un_satoshi fee
+
+ , testCase "spend_revoked_to_local nSequence" $ with_fx $ \fx -> do
+ value <- sat 100000
+ stx <- need "spend_revoked_to_local" $
+ B5.spend_revoked_to_local dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate
+ in_sequence stx @?= 0xFFFFFFFF
+ B5.stx_input_script stx
+ @?= to_local_script (fx_revpk fx) dummyDelay (fx_delayed fx)
+
+ , testCase "spend_anchor_owner tx structure" $ with_fx $ \fx -> do
+ value <- sat 330
+ let stx = B5.spend_anchor_owner dummyOutPoint value
+ (fx_funding fx) dummyDestScript
tx = B5.stx_tx stx
tx_version tx @?= 2
tx_locktime tx @?= 0
B5.stx_sighash_type stx @?= SIGHASH_ALL
+ B5.stx_input_script stx @?= anchor_script (fx_funding fx)
+
+ , testCase "spend_anchor_anyone nSequence" $ with_fx $ \fx -> do
+ value <- sat 330
+ let stx = B5.spend_anchor_anyone dummyOutPoint value
+ (fx_funding fx) dummyDestScript
+ in_sequence stx @?= 16
+
+ , testCase "spend_htlc_output is spend_to_local" $ with_fx $ \fx -> do
+ value <- sat 50000
+ let spend f = f dummyOutPoint value (fx_revpk fx) dummyDelay
+ (fx_delayed fx) dummyDestScript dummyFeerate
+ stx1 <- need "spend_to_local" (spend B5.spend_to_local)
+ stx2 <- need "spend_htlc_output" (spend B5.spend_htlc_output)
+ stx1 @?= stx2
+
+ , testCase "spend_to_local fee underflow" $ with_fx $ \fx -> do
+ value <- sat 1
+ B5.spend_to_local dummyOutPoint value (fx_revpk fx) dummyDelay
+ (fx_delayed fx) dummyDestScript dummyFeerate
+ @?= Nothing
- , testCase "spend_anchor_anyone nSequence" $ do
- let stx = B5.spend_anchor_anyone
- dummyOutPoint (Satoshi 330)
- dummyFundingPubkey dummyDestScript
- tx = B5.stx_tx stx
- inp = head' (tx_inputs tx)
- txin_sequence inp @?= 16
-
- , testCase "spend_htlc_output is spend_to_local" $ do
- stx1 <- assertJust "spend_to_local" $
- B5.spend_to_local
- dummyOutPoint (Satoshi 50000)
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript dummyFeerate
- stx2 <- assertJust "spend_htlc_output" $
- B5.spend_htlc_output
- dummyOutPoint (Satoshi 50000)
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript dummyFeerate
- B5.stx_tx stx1 @?= B5.stx_tx stx2
- B5.stx_input_script stx1 @?=
- B5.stx_input_script stx2
-
- , testCase "spend_to_local fee underflow" $ do
- B5.spend_to_local
- dummyOutPoint (Satoshi 1)
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript dummyFeerate
- @?= Nothing
-
- , testCase "spend_to_local dust threshold by script" $ do
- let fee = unSatoshi $ B5.spending_fee dummyFeerate
- (B5.to_local_penalty_input_weight
- + B5.penalty_tx_base_weight)
- sweep dest v = B5.spend_to_local
- dummyOutPoint (Satoshi v)
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey dest dummyFeerate
- outValue = fmap
- (txout_value . head' . tx_outputs . B5.stx_tx)
+ , testCase "spend_to_local dust threshold by script" $ with_fx $ \fx -> do
+ let fee = BOLT1.un_satoshi $ B5.spending_fee dummyFeerate
+ (B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight)
+ sweep dest v = do
+ value <- sat v
+ pure $ B5.spend_to_local dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dest dummyFeerate
check (name, dest, dust) = do
+ at <- sweep dest (fee + dust)
assertEqual (name <> " at threshold") (Just dust)
- (outValue (sweep dest (fee + dust)))
- assertEqual (name <> " below threshold") Nothing
- (sweep dest (fee + dust - 1))
+ (fmap out_value at)
+ below <- sweep dest (fee + dust - 1)
+ assertEqual (name <> " below threshold") Nothing below
mapM_ check
[ ("p2pkh", Script $ BS.pack ([0x76, 0xa9, 0x14]
<> replicate 20 0xCC <> [0x88, 0xac]), 546)
@@ -1009,60 +910,69 @@ spend_tests = testGroup "Spend" [
, ("p2tr", Script $ BS.pack ([0x51, 0x20]
<> replicate 32 0xCC), 330)
]
-
]
-- htlc spend tests ---------------------------------------------------
htlc_spend_tests :: TestTree
htlc_spend_tests = testGroup "HTLC Spend" [
- testCase "spend_htlc_timeout produces valid tx" $ do
- let stx = B5.spend_htlc_timeout
- dummyHTLCContext dummyKeys
- tx = B5.stx_tx stx
+ testCase "spend_htlc_tx - HTLC-timeout" $ with_fx $ \fx -> do
+ stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx
+ (htlc_context fx (fx_offered fx) StaticRemotekey) (fx_keys fx)
+ let tx = B5.stx_tx stx
tx_version tx @?= 2
length (tx_inputs tx) @?= 1
length (tx_outputs tx) @?= 1
+ tx_locktime tx @?= 500000
+ in_sequence stx @?= 0
B5.stx_sighash_type stx @?= SIGHASH_ALL
B5.stx_input_value stx
- @?= msatToSat (MilliSatoshi 1000000)
+ @?= BOLT1.msat_to_sat (htlc_amount_msat (fx_offered fx))
+ B5.stx_input_script stx @?=
+ htlc_witness_script (fx_keys fx) StaticRemotekey (fx_offered fx)
- , testCase "spend_htlc_success produces valid tx" $ do
- let ctx = dummyHTLCContext
- { hc_htlc = dummyReceivedHTLC }
- stx = B5.spend_htlc_success ctx dummyKeys
- tx = B5.stx_tx stx
+ , testCase "spend_htlc_tx - HTLC-success" $ with_fx $ \fx -> do
+ stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx
+ (htlc_context fx (fx_received fx) StaticRemotekey) (fx_keys fx)
+ let tx = B5.stx_tx stx
tx_version tx @?= 2
length (tx_inputs tx) @?= 1
+ tx_locktime tx @?= 0
B5.stx_sighash_type stx @?= SIGHASH_ALL
-
- , testCase "spend_htlc_timeout anchors sighash" $ do
- let ctx = dummyHTLCContext
- { hc_features = dummyFeaturesAnchors }
- stx = B5.spend_htlc_timeout ctx dummyKeys
- B5.stx_sighash_type stx @?= SIGHASH_ALL
-
- , testCase "spend_htlc_success anchors sighash" $ do
- let ctx = dummyHTLCContext
- { hc_htlc = dummyReceivedHTLC
- , hc_features = dummyFeaturesAnchors
- }
- stx = B5.spend_htlc_success ctx dummyKeys
- B5.stx_sighash_type stx @?= SIGHASH_ALL
+ B5.stx_input_script stx @?=
+ htlc_witness_script (fx_keys fx) StaticRemotekey (fx_received fx)
+
+ , testCase "spend_htlc_tx - HTLC-timeout anchors sighash" $ with_fx $
+ \fx -> do
+ stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx
+ (htlc_context fx (fx_offered fx) Anchors) (fx_keys fx)
+ B5.stx_sighash_type stx @?= SIGHASH_ALL
+ in_sequence stx @?= 1
+
+ , testCase "spend_htlc_tx - HTLC-success anchors sighash" $ with_fx $
+ \fx -> do
+ stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx
+ (htlc_context fx (fx_received fx) Anchors) (fx_keys fx)
+ B5.stx_sighash_type stx @?= SIGHASH_ALL
+
+ , testCase "spend_htlc_tx - fee exceeds amount" $ with_fx $ \fx -> do
+ -- 5000 * 663 / 1000 = 3315 sat, more than the 1000 sat HTLC
+ let ctx = (htlc_context fx (fx_offered fx) StaticRemotekey)
+ { hc_feerate = FeeratePerKw 5000 }
+ B5.spend_htlc_tx ctx (fx_keys fx) @?= Nothing
, testCase "HTLC txs - Appendix F (anchors)" $ do
-- The local signature uses SIGHASH_ALL and the remote one
-- SIGHASH_SINGLE|SIGHASH_ANYONECANPAY.
- commit <- assertJust "commitment" vecCommitAnchors
- keys <- assertJust "keys" vecKeys
+ commit <- vecCommitAnchors
+ keys <- vecKeys
let outs = B5.classify_local_commit_outputs commit keys
- (ToSelfDelay 144) (ChannelFeatures True)
- [vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4]
+ (ToSelfDelay 144) Anchors
check uo vec = do
stx <- vecHtlcTx (FeeratePerKw 644) uo
assertHtlcTx stx vec
B5.stx_sighash_type stx @?= SIGHASH_ALL
- assertSighashFlags stx SIGHASH_SINGLE_ANYONECANPAY vec
+ assertSighashFlags stx Anchors vec
case drop 3 outs of
o3 : o4 : _ -> do
check o3 vecFHtlcTimeout2
@@ -1074,139 +984,121 @@ htlc_spend_tests = testGroup "HTLC Spend" [
remote_spend_tests :: TestTree
remote_spend_tests = testGroup "Remote Spend" [
- testCase "spend_remote_htlc_timeout structure" $ do
- stx <- assertJust "spend_remote_htlc_timeout" $
- B5.spend_remote_htlc_timeout
- dummyOutPoint (Satoshi 50000)
- dummyHTLC dummyKeys dummyFeatures
- dummyDestScript dummyFeerate
+ testCase "spend_remote_htlc_timeout structure" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_remote_htlc_timeout" $
+ B5.spend_remote_htlc_timeout dummyOutPoint value (fx_offered fx)
+ (fx_keys fx) StaticRemotekey dummyDestScript dummyFeerate
let tx = B5.stx_tx stx
tx_version tx @?= 2
length (tx_inputs tx) @?= 1
B5.stx_sighash_type stx @?= SIGHASH_ALL
- B5.stx_input_value stx @?= Satoshi 50000
- -- locktime should be HTLC CLTV expiry
+ B5.stx_input_value stx @?= value
+ B5.stx_input_script stx @?=
+ htlc_witness_script (fx_keys fx) StaticRemotekey (fx_received fx)
+ -- locktime is the HTLC's CLTV expiry
tx_locktime tx @?= 500000
- , testCase "spend_remote_htlc_timeout fee deduction" $ do
- let value = Satoshi 50000
- stx <- assertJust "spend_remote_htlc_timeout" $
- B5.spend_remote_htlc_timeout
- dummyOutPoint value dummyHTLC
- dummyKeys dummyFeatures
+ , testCase "spend_remote_htlc_timeout fee deduction" $ with_fx $
+ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_remote_htlc_timeout" $
+ B5.spend_remote_htlc_timeout dummyOutPoint value
+ (fx_offered fx) (fx_keys fx) StaticRemotekey
+ dummyDestScript dummyFeerate
+ let fee = B5.spending_fee dummyFeerate
+ (B5.accepted_htlc_penalty_input_weight
+ + B5.penalty_tx_base_weight)
+ out_value stx @?= 50000 - BOLT1.un_satoshi fee
+
+ , testCase "spend_remote_htlc_preimage structure" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_remote_htlc_preimage" $
+ B5.spend_remote_htlc_preimage dummyOutPoint value
+ (fx_received fx) (fx_keys fx) StaticRemotekey
dummyDestScript dummyFeerate
let tx = B5.stx_tx stx
- outVal = txout_value (head' (tx_outputs tx))
- assertBool "output < input" (outVal < 50000)
-
- , testCase "spend_remote_htlc_preimage structure" $ do
- stx <- assertJust "spend_remote_htlc_preimage" $
- B5.spend_remote_htlc_preimage
- dummyOutPoint (Satoshi 50000)
- dummyReceivedHTLC dummyKeys
- dummyFeatures dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
tx_version tx @?= 2
B5.stx_sighash_type stx @?= SIGHASH_ALL
- -- locktime should be 0 for preimage claims
+ B5.stx_input_script stx @?=
+ htlc_witness_script (fx_keys fx) StaticRemotekey (fx_offered fx)
+ -- locktime is 0 for preimage claims
tx_locktime tx @?= 0
- , testCase "spend_remote_htlc_timeout anchors seq" $
- do
- stx <- assertJust "spend_remote_htlc_timeout" $
- B5.spend_remote_htlc_timeout
- dummyOutPoint (Satoshi 50000)
- dummyHTLC dummyKeys dummyFeaturesAnchors
+ , testCase "spend_remote_htlc_timeout anchors seq" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_remote_htlc_timeout" $
+ B5.spend_remote_htlc_timeout dummyOutPoint value (fx_offered fx)
+ (fx_keys fx) Anchors dummyDestScript dummyFeerate
+ in_sequence stx @?= 1
+
+ , testCase "spend_remote_htlc_timeout no-anchor seq" $ with_fx $
+ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_remote_htlc_timeout" $
+ B5.spend_remote_htlc_timeout dummyOutPoint value
+ (fx_offered fx) (fx_keys fx) StaticRemotekey
+ dummyDestScript dummyFeerate
+ in_sequence stx @?= 0
+
+ , testCase "spend_remote_htlc_preimage nSequence" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_remote_htlc_preimage" $
+ B5.spend_remote_htlc_preimage dummyOutPoint value
+ (fx_received fx) (fx_keys fx) StaticRemotekey
dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
- inp = head' (tx_inputs tx)
- txin_sequence inp @?= 1
-
- , testCase "spend_remote_htlc_timeout no-anchor seq" $
- do
- stx <- assertJust "spend_remote_htlc_timeout" $
- B5.spend_remote_htlc_timeout
- dummyOutPoint (Satoshi 50000)
- dummyHTLC dummyKeys dummyFeatures
- dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
- inp = head' (tx_inputs tx)
- txin_sequence inp @?= 0
-
- , testCase "spend_remote_htlc_preimage nSequence" $ do
- stx <- assertJust "spend_remote_htlc_preimage" $
- B5.spend_remote_htlc_preimage
- dummyOutPoint (Satoshi 50000)
- dummyReceivedHTLC dummyKeys
- dummyFeatures dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
- inp = head' (tx_inputs tx)
- txin_sequence inp @?= 0
+ in_sequence stx @?= 0
]
-- revoked htlc spend tests ------------------------------------------
revoked_htlc_spend_tests :: TestTree
revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [
- testCase "spend_revoked_htlc - offered" $ do
- case B5.spend_revoked_htlc
- dummyOutPoint (Satoshi 50000)
- (B5.HTLCOfferedOutput (CltvExpiry 500000))
- dummyRevocationPubkey dummyKeys
- dummyFeatures dummyPaymentHash
- dummyDestScript dummyFeerate of
- Nothing -> assertFailure "expected Just"
- Just stx -> do
- let tx = B5.stx_tx stx
- tx_version tx @?= 2
- B5.stx_sighash_type stx @?= SIGHASH_ALL
- let inp = head' (tx_inputs tx)
- txin_sequence inp @?= 0xFFFFFFFF
-
- , testCase "spend_revoked_htlc - received" $ do
- case B5.spend_revoked_htlc
- dummyOutPoint (Satoshi 50000)
- (B5.HTLCReceivedOutput
- (CltvExpiry 500000))
- dummyRevocationPubkey dummyKeys
- dummyFeatures dummyPaymentHash
- dummyDestScript dummyFeerate of
- Nothing -> assertFailure "expected Just"
- Just stx -> do
- B5.stx_sighash_type stx @?= SIGHASH_ALL
- let tx = B5.stx_tx stx
- outVal = txout_value
- (head' (tx_outputs tx))
- assertBool "output < input"
- (outVal < 50000)
-
- , testCase "htlcOutputType - valid HTLC types" $ do
- B5.htlcOutputType
- (OutputOfferedHTLC (CltvExpiry 500))
- @?= Just (B5.HTLCOfferedOutput (CltvExpiry 500))
- B5.htlcOutputType
- (OutputReceivedHTLC (CltvExpiry 600))
- @?= Just (B5.HTLCReceivedOutput
- (CltvExpiry 600))
-
- , testCase "htlcOutputType - non-HTLC types" $ do
- B5.htlcOutputType OutputToLocal @?= Nothing
- B5.htlcOutputType OutputToRemote @?= Nothing
- B5.htlcOutputType OutputLocalAnchor @?= Nothing
- B5.htlcOutputType OutputRemoteAnchor @?= Nothing
-
- , testCase "spend_revoked_htlc_output structure" $ do
- stx <- assertJust "spend_revoked_htlc_output" $
- B5.spend_revoked_htlc_output
- dummyOutPoint (Satoshi 50000)
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript dummyFeerate
- let tx = B5.stx_tx stx
- tx_version tx @?= 2
+ testCase "spend_revoked_htlc - offered" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_revoked_htlc" $
+ B5.spend_revoked_htlc dummyOutPoint value
+ (B5.HTLCOfferedOutput (CltvExpiry 500000)) (fx_revpk fx)
+ (fx_keys fx) StaticRemotekey (fx_hash fx) dummyDestScript
+ dummyFeerate
+ tx_version (B5.stx_tx stx) @?= 2
B5.stx_sighash_type stx @?= SIGHASH_ALL
- let inp = head' (tx_inputs tx)
- txin_sequence inp @?= 0xFFFFFFFF
+ in_sequence stx @?= 0xFFFFFFFF
+ B5.stx_input_script stx @?=
+ htlc_witness_script (fx_keys fx) StaticRemotekey (fx_offered fx)
+
+ , testCase "spend_revoked_htlc - received" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_revoked_htlc" $
+ B5.spend_revoked_htlc dummyOutPoint value
+ (B5.HTLCReceivedOutput (CltvExpiry 500000)) (fx_revpk fx)
+ (fx_keys fx) StaticRemotekey (fx_hash fx) dummyDestScript
+ dummyFeerate
+ B5.stx_sighash_type stx @?= SIGHASH_ALL
+ assertBool "output < input" (out_value stx < 50000)
+ B5.stx_input_script stx @?=
+ htlc_witness_script (fx_keys fx) StaticRemotekey (fx_received fx)
+
+ , testCase "htlc_output_type - HTLC outputs" $ with_fx $ \fx -> do
+ B5.htlc_output_type (OutputHTLC (fx_offered fx))
+ @?= Just (B5.HTLCOfferedOutput (CltvExpiry 500000))
+ B5.htlc_output_type (OutputHTLC (fx_received fx))
+ @?= Just (B5.HTLCReceivedOutput (CltvExpiry 500000))
+
+ , testCase "htlc_output_type - non-HTLC outputs" $ do
+ B5.htlc_output_type OutputToLocal @?= Nothing
+ B5.htlc_output_type OutputToRemote @?= Nothing
+ B5.htlc_output_type OutputLocalAnchor @?= Nothing
+ B5.htlc_output_type OutputRemoteAnchor @?= Nothing
+
+ , testCase "spend_revoked_htlc_output structure" $ with_fx $ \fx -> do
+ value <- sat 50000
+ stx <- need "spend_revoked_htlc_output" $
+ B5.spend_revoked_htlc_output dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate
+ tx_version (B5.stx_tx stx) @?= 2
+ B5.stx_sighash_type stx @?= SIGHASH_ALL
+ in_sequence stx @?= 0xFFFFFFFF
]
-- weight tests -------------------------------------------------------
@@ -1229,281 +1121,157 @@ weight_tests = testGroup "Weight" [
B5.accepted_htlc_penalty_input_weight_anchors @?=
(164 + B5.accepted_htlc_penalty_witness_weight_anchors)
- , testCase "penalty witness weights match HTLC scripts" $ do
- -- 1 (item count) + 1 + 73 (signature) + 1 + 33
- -- (revocationpubkey) + 1 + script, for a 3-byte CLTV expiry
- let witnessWeight script =
- fromIntegral (110 + BS.length (unScript script))
- offered = offered_htlc_script
- dummyRevocationPubkey dummyRemoteHtlcPubkey
- dummyLocalHtlcPubkey dummyPaymentHash
- received = received_htlc_script
- dummyRevocationPubkey dummyRemoteHtlcPubkey
- dummyLocalHtlcPubkey dummyPaymentHash
- (CltvExpiry 500000)
- witnessWeight (offered dummyFeatures)
- @?= B5.offered_htlc_penalty_witness_weight
- witnessWeight (received dummyFeatures)
- @?= B5.accepted_htlc_penalty_witness_weight
- witnessWeight (offered dummyFeaturesAnchors)
- @?= B5.offered_htlc_penalty_witness_weight_anchors
- witnessWeight (received dummyFeaturesAnchors)
- @?= B5.accepted_htlc_penalty_witness_weight_anchors
-
- , testCase "spend_revoked_htlc weight by channel type" $ do
- let value = 50000
- outValue features htype = fmap
- (txout_value . head' . tx_outputs . B5.stx_tx)
- (B5.spend_revoked_htlc dummyOutPoint (Satoshi value)
- htype dummyRevocationPubkey dummyKeys features
- dummyPaymentHash dummyDestScript dummyFeerate)
- expected inputWeight = Just $ value - unSatoshi
- (B5.spending_fee dummyFeerate
- (inputWeight + B5.penalty_tx_base_weight))
- offered = B5.HTLCOfferedOutput (CltvExpiry 500000)
- received = B5.HTLCReceivedOutput (CltvExpiry 500000)
- outValue dummyFeatures offered
- @?= expected B5.offered_htlc_penalty_input_weight
- outValue dummyFeatures received
- @?= expected B5.accepted_htlc_penalty_input_weight
- outValue dummyFeaturesAnchors offered
- @?= expected B5.offered_htlc_penalty_input_weight_anchors
- outValue dummyFeaturesAnchors received
- @?= expected B5.accepted_htlc_penalty_input_weight_anchors
-
- , testCase "max HTLCs in single penalty tx" $ do
- -- Per spec: (400000 - 324 - 272 - 212 - 2) / 413
- -- = 399190 / 413 = 966
- let maxHtlcs = (B5.max_standard_weight
- - B5.to_local_penalty_input_weight
- - B5.to_remote_input_weight
- - B5.penalty_tx_base_weight
- - 2) `div`
- B5.accepted_htlc_penalty_input_weight
- assertBool "can sweep 483 bidirectional HTLCs"
- (maxHtlcs >= 966)
+ , testCase "penalty witness weights match HTLC scripts" $ with_fx $
+ \fx -> do
+ -- 1 (item count) + 1 + 73 (signature) + 1 + 33
+ -- (revocationpubkey) + 1 + script, for a 3-byte CLTV expiry
+ let witnessWeight fmt h =
+ let Script s = htlc_witness_script (fx_keys fx) fmt h
+ in fromIntegral (110 + BS.length s)
+ witnessWeight StaticRemotekey (fx_offered fx)
+ @?= B5.offered_htlc_penalty_witness_weight
+ witnessWeight StaticRemotekey (fx_received fx)
+ @?= B5.accepted_htlc_penalty_witness_weight
+ witnessWeight Anchors (fx_offered fx)
+ @?= B5.offered_htlc_penalty_witness_weight_anchors
+ witnessWeight Anchors (fx_received fx)
+ @?= B5.accepted_htlc_penalty_witness_weight_anchors
+
+ , testCase "spend_revoked_htlc weight by commitment format" $ with_fx $
+ \fx -> do
+ value <- sat 50000
+ let outValue fmt htype = fmap out_value
+ (B5.spend_revoked_htlc dummyOutPoint value htype
+ (fx_revpk fx) (fx_keys fx) fmt (fx_hash fx)
+ dummyDestScript dummyFeerate)
+ expected inputWeight = Just $ 50000 - BOLT1.un_satoshi
+ (B5.spending_fee dummyFeerate
+ (inputWeight + B5.penalty_tx_base_weight))
+ offered = B5.HTLCOfferedOutput (CltvExpiry 500000)
+ received = B5.HTLCReceivedOutput (CltvExpiry 500000)
+ outValue StaticRemotekey offered
+ @?= expected B5.offered_htlc_penalty_input_weight
+ outValue StaticRemotekey received
+ @?= expected B5.accepted_htlc_penalty_input_weight
+ outValue Anchors offered
+ @?= expected B5.offered_htlc_penalty_input_weight_anchors
+ outValue Anchors received
+ @?= expected B5.accepted_htlc_penalty_input_weight_anchors
+
+ , testCase "max HTLCs in single penalty tx" $
+ -- Per spec: (400000 - 324 - 272 - (4 * 53) - 2) / 413 = 966,
+ -- where penalty_tx_base_weight = 4 * 53 + 2.
+ (B5.max_standard_weight
+ - B5.to_local_penalty_input_weight
+ - B5.to_remote_input_weight
+ - B5.penalty_tx_base_weight)
+ `div` B5.accepted_htlc_penalty_input_weight
+ @?= 966
]
-- property tests -----------------------------------------------------
property_tests :: TestTree
property_tests = testGroup "Properties" [
- testProperty "spending_fee always non-negative" $
- \(NonNegative rate) (NonNegative weight) ->
- let fee = B5.spending_fee
- (FeeratePerKw (fromIntegral (rate :: Int)))
- (fromIntegral (weight :: Int))
- in unSatoshi fee >= 0
-
- , testProperty "spend_to_local fee deduction correct" $
- \(Positive val) ->
- let value = Satoshi
- (fromIntegral (val :: Int) + 100000)
- expectedFee = B5.spending_fee
- (FeeratePerKw 253)
- (B5.to_local_penalty_input_weight
- + B5.penalty_tx_base_weight)
- in case B5.spend_to_local
- dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript (FeeratePerKw 253) of
- Nothing -> False
- Just stx ->
- let tx = B5.stx_tx stx
- outVal = txout_value
- (head' (tx_outputs tx))
- in Satoshi outVal ==
- Satoshi (unSatoshi value
- - unSatoshi expectedFee)
-
- , testProperty "sweeps never create dust outputs" $
- forAll (choose (0, 3000 :: Int)) $ \v ->
- let value = Satoshi (fromIntegral v)
- sweeps =
- [ B5.spend_to_local dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey dummyDestScript
- dummyFeerate
+ testProperty "output + fee = input (spend_to_local)" $ prop_fx $
+ \fx -> forAll (choose (100000, 2100000000000000)) $ \v ->
+ let fee = B5.spending_fee dummyFeerate
+ (B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight)
+ spent = do
+ value <- BOLT1.satoshi v
+ B5.spend_to_local dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate
+ in fmap (\stx -> out_value stx + BOLT1.un_satoshi fee) spent
+ === Just v
+
+ , testProperty "sweeps never create dust outputs" $ prop_fx $ \fx ->
+ forAll (choose (0, 3000)) $ \v ->
+ let sweeps value =
+ [ B5.spend_to_local dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate
, B5.spend_remote_htlc_timeout dummyOutPoint value
- dummyHTLC dummyKeys dummyFeatures
+ (fx_offered fx) (fx_keys fx) StaticRemotekey
dummyDestScript dummyFeerate
, B5.spend_remote_htlc_preimage dummyOutPoint value
- dummyReceivedHTLC dummyKeys dummyFeatures
+ (fx_received fx) (fx_keys fx) StaticRemotekey
dummyDestScript dummyFeerate
, B5.spend_revoked_to_local dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey dummyDestScript
- dummyFeerate
+ (fx_revpk fx) dummyDelay (fx_delayed fx)
+ dummyDestScript dummyFeerate
, B5.spend_revoked_htlc dummyOutPoint value
(B5.HTLCOfferedOutput (CltvExpiry 500000))
- dummyRevocationPubkey dummyKeys dummyFeatures
- dummyPaymentHash dummyDestScript dummyFeerate
+ (fx_revpk fx) (fx_keys fx) StaticRemotekey
+ (fx_hash fx) dummyDestScript dummyFeerate
, B5.spend_revoked_htlc dummyOutPoint value
(B5.HTLCReceivedOutput (CltvExpiry 500000))
- dummyRevocationPubkey dummyKeys dummyFeatures
- dummyPaymentHash dummyDestScript dummyFeerate
+ (fx_revpk fx) (fx_keys fx) StaticRemotekey
+ (fx_hash fx) dummyDestScript dummyFeerate
, B5.spend_revoked_htlc_output dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey dummyDestScript
- dummyFeerate
+ (fx_revpk fx) dummyDelay (fx_delayed fx)
+ dummyDestScript dummyFeerate
]
- notDust = maybe True $ \stx ->
- txout_value (head' (tx_outputs (B5.stx_tx stx)))
- >= 294
- in all notDust sweeps
-
- , testProperty "htlc_timed_out monotonic" $
- \(NonNegative h1) (NonNegative h2) ->
- let height1 = fromIntegral (h1 :: Int)
- height2 = fromIntegral (h2 :: Int)
- htlc = dummyHTLC
- { htlc_cltv_expiry = CltvExpiry 1000 }
- in if height1 <= height2
- then not (B5.htlc_timed_out height1 htlc)
- || B5.htlc_timed_out height2 htlc
- else True
-
- , testProperty "output + fee = input (spend_to_local)" $
- \(Positive val) ->
- let value = Satoshi
- (fromIntegral (val :: Int) + 100000)
- fee = B5.spending_fee (FeeratePerKw 253)
- (B5.to_local_penalty_input_weight
- + B5.penalty_tx_base_weight)
- in case B5.spend_to_local
- dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript (FeeratePerKw 253) of
- Nothing -> False
- Just stx ->
- let tx = B5.stx_tx stx
- outVal = txout_value
- (head' (tx_outputs tx))
- in outVal + unSatoshi fee ==
- unSatoshi value
+ notDust = maybe True (\stx -> out_value stx >= 294)
+ in case BOLT1.satoshi v of
+ Nothing -> counterexample "invalid amount" False
+ Just value -> property (all notDust (sweeps value))
+
+ , testProperty "htlc_timed_out monotonic" $ prop_fx $
+ \fx (NonNegative h1) (NonNegative h2) ->
+ let htlc = (fx_offered fx) { htlc_cltv_expiry = CltvExpiry 1000 }
+ lo = min h1 h2
+ hi = max h1 h2
+ in not (B5.htlc_timed_out lo htlc) || B5.htlc_timed_out hi htlc
, testProperty "fee monotonic in feerate" $
- \(Positive r1) (Positive r2) ->
- let rate1 = fromIntegral (r1 :: Int)
- rate2 = fromIntegral (r2 :: Int)
- w = B5.to_local_penalty_input_weight
- + B5.penalty_tx_base_weight
- fee1 = B5.spending_fee
- (FeeratePerKw rate1) w
- fee2 = B5.spending_fee
- (FeeratePerKw rate2) w
- in if rate1 <= rate2
- then unSatoshi fee1 <= unSatoshi fee2
- else unSatoshi fee1 >= unSatoshi fee2
-
- , testProperty "classify preserves output count" $
- \(NonNegative n') ->
- let n = min (n' :: Int) 10
- outputs =
- [ TxOutput (Satoshi 50000) toLocalScript
- OutputToLocal
- | _ <- [1..n] ]
- commitTx = CommitmentTx
- { ctx_version = 2
- , ctx_locktime = Locktime 0
- , ctx_input_outpoint = dummyOutPoint
- , ctx_input_sequence = Sequence 0
- , ctx_outputs = outputs
- , ctx_funding_script = dummyDestScript
- }
- outs = B5.classify_local_commit_outputs
- commitTx dummyKeys dummyDelay
- dummyFeatures []
- in length outs == n
-
- , testProperty "spend_to_local always version 2" $
- \(Positive val) ->
- let value = Satoshi
- (fromIntegral (val :: Int) + 100000)
- in case B5.spend_to_local
- dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript (FeeratePerKw 253) of
- Nothing -> False
- Just stx ->
- tx_version (B5.stx_tx stx) == 2
-
- , testProperty "revoked nSequence is 0xFFFFFFFF" $
- \(Positive val) ->
- let value = Satoshi
- (fromIntegral (val :: Int) + 100000)
- in case B5.spend_revoked_to_local
- dummyOutPoint value
- dummyRevocationPubkey dummyDelay
- dummyLocalDelayedPubkey
- dummyDestScript (FeeratePerKw 253) of
- Nothing -> False
- Just stx ->
- let inp = head'
- (tx_inputs (B5.stx_tx stx))
- in txin_sequence inp == 0xFFFFFFFF
-
- , testProperty "htlcOutputType preserves expiry" $
- \expiry ->
+ \r1 r2 ->
+ let w = B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight
+ fee r = B5.spending_fee (FeeratePerKw r) w
+ in fee (min r1 r2) <= fee (max r1 r2)
+
+ , testProperty "spend_to_local always version 2" $ prop_fx $
+ \fx -> forAll (choose (100000, 2100000000000000)) $ \v ->
+ let spent = do
+ value <- BOLT1.satoshi v
+ B5.spend_to_local dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate
+ in fmap (tx_version . B5.stx_tx) spent === Just 2
+
+ , testProperty "revoked nSequence is 0xFFFFFFFF" $ prop_fx $
+ \fx -> forAll (choose (100000, 2100000000000000)) $ \v ->
+ let spent = do
+ value <- BOLT1.satoshi v
+ B5.spend_revoked_to_local dummyOutPoint value (fx_revpk fx)
+ dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate
+ in fmap in_sequence spent === Just 0xFFFFFFFF
+
+ , testProperty "htlc_output_type preserves direction and expiry" $
+ prop_fx $ \fx expiry ->
let ce = CltvExpiry expiry
- in B5.htlcOutputType (OutputOfferedHTLC ce)
- == Just (B5.HTLCOfferedOutput ce)
- &&
- B5.htlcOutputType (OutputReceivedHTLC ce)
- == Just (B5.HTLCReceivedOutput ce)
-
- , testProperty "htlcOutputType rejects non-HTLC" $
- property $
- B5.htlcOutputType OutputToLocal == Nothing
- && B5.htlcOutputType OutputToRemote == Nothing
- && B5.htlcOutputType OutputLocalAnchor == Nothing
- && B5.htlcOutputType OutputRemoteAnchor
- == Nothing
+ at h = OutputHTLC h { htlc_cltv_expiry = ce }
+ in B5.htlc_output_type (at (fx_offered fx))
+ == Just (B5.HTLCOfferedOutput ce)
+ && B5.htlc_output_type (at (fx_received fx))
+ == Just (B5.HTLCReceivedOutput ce)
, testProperty "revoked_output_weight by type" $
\expiry ->
let ce = CltvExpiry expiry
- roLocal = B5.RevokedOutput
- dummyOutPoint (Satoshi 1000)
- B5.RevokedToLocal
- roOffered = B5.RevokedOutput
- dummyOutPoint (Satoshi 1000)
- (B5.RevokedHTLC
- (B5.HTLCOfferedOutput ce))
- roReceived = B5.RevokedOutput
- dummyOutPoint (Satoshi 1000)
- (B5.RevokedHTLC
- (B5.HTLCReceivedOutput ce))
- weight = B5.revoked_output_weight
- in weight dummyFeatures roLocal
- == B5.to_local_penalty_input_weight
- &&
- weight dummyFeatures roOffered
- == B5.offered_htlc_penalty_input_weight
- &&
- weight dummyFeatures roReceived
- == B5.accepted_htlc_penalty_input_weight
- &&
- weight dummyFeaturesAnchors roLocal
- == B5.to_local_penalty_input_weight
- &&
- weight dummyFeaturesAnchors roOffered
- == B5.offered_htlc_penalty_input_weight_anchors
- &&
- weight dummyFeaturesAnchors roReceived
- == B5.accepted_htlc_penalty_input_weight_anchors
-
+ ro t = case BOLT1.satoshi 1000 of
+ Nothing -> Nothing
+ Just v -> Just (B5.RevokedOutput dummyOutPoint v t)
+ weight fmt t = fmap (B5.revoked_output_weight fmt) (ro t)
+ offered = B5.RevokedHTLC (B5.HTLCOfferedOutput ce)
+ received = B5.RevokedHTLC (B5.HTLCReceivedOutput ce)
+ in weight StaticRemotekey B5.RevokedToLocal
+ == Just B5.to_local_penalty_input_weight
+ && weight StaticRemotekey offered
+ == Just B5.offered_htlc_penalty_input_weight
+ && weight StaticRemotekey received
+ == Just B5.accepted_htlc_penalty_input_weight
+ && weight Anchors B5.RevokedToLocal
+ == Just B5.to_local_penalty_input_weight
+ && weight Anchors offered
+ == Just B5.offered_htlc_penalty_input_weight_anchors
+ && weight Anchors received
+ == Just B5.accepted_htlc_penalty_input_weight_anchors
]
-
--- helpers ------------------------------------------------------------
-
--- | Total head for NonEmpty.
-head' :: NonEmpty a -> a
-head' (x :| _) = x
-
--- | Assert a Maybe is Just, failing with a message otherwise.
-assertJust :: String -> Maybe a -> IO a
-assertJust msg = maybe (assertFailure msg) pure
