ppad-bolt3 0.0.1 → 0.1.0

raw patch · 15 files changed

+4770/−4211 lines, 15 filesdep +QuickCheckdep +ppad-base16dep +ppad-bolt1dep −base16-bytestringdep ~deepseqdep ~ppad-secp256k1dep ~ppad-sha256PVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, ppad-base16, ppad-bolt1, ppad-fixed, ppad-tx, tasty-quickcheck

Dependencies removed: base16-bytestring

Dependency ranges changed: deepseq, ppad-secp256k1, ppad-sha256

API changes (from Hackage documentation)

Files

• CHANGELOG +69/−0
• bench/Fixtures.hs +203/−0
• bench/Main.hs +74/−481
• bench/Weight.hs +47/−473
• lib/Lightning/Protocol/BOLT3.hs +104/−215
• lib/Lightning/Protocol/BOLT3/Decode.hs +0/−389
• lib/Lightning/Protocol/BOLT3/Encode.hs +0/−298
• lib/Lightning/Protocol/BOLT3/Keys.hs +433/−333
• lib/Lightning/Protocol/BOLT3/Scripts.hs +355/−529
• lib/Lightning/Protocol/BOLT3/Tx.hs +452/−475
• lib/Lightning/Protocol/BOLT3/Types.hs +282/−314
• lib/Lightning/Protocol/BOLT3/Validate.hs +0/−359
• ppad-bolt3.cabal +33/−12
• test/Main.hs +1019/−333
• test/Vectors.hs +1699/−0

@@ -0,0 +1,69 @@+# Changelog++- 0.1.0 (2026-10-10)+  * A substantial rewrite, with breaking changes throughout:++    * Ports to ppad-bolt1 0.1.0 and ppad-tx 0.2.0. Amounts, points,+      hashes and per-commitment secrets are bolt1's types (amounts are+      bounded, with checked arithmetic); bolt3's Pubkey is merged into+      bolt1's Point, wrapped in role newtypes (RevocationPubkey, etc.).++    * The API is exported from Lightning.Protocol.BOLT3 alone, with+      snake_case names. Types with invariants (CommitmentNumber,+      SecretIndex, Seed, Seckey, SecretStore) are abstract, and every+      type has an NFData instance.++    * ChannelFeatures is replaced by CommitmentFormat (StaticRemotekey+      or Anchors).++    * CommitmentContext is owner-relative throughout: the payment+      basepoints are ordered for the obscured commitment number by+      cc_is_funder. build_commitment_tx fails rather than produce a+      transaction without outputs.++    * OutputType carries the HTLC an output pays. build_htlc_tx replaces+      build_htlc_timeout_tx and build_htlc_success_tx, choosing by HTLC+      direction, and fails if the fee exceeds the amount.++    * Closing transactions have separate builders with spec-shaped+      inputs: build_legacy_closing_tx applies the signer's dust limit to+      both outputs and can omit the signer's output; build_closing_tx+      (option_simple_close) charges the closer, takes an explicit choice+      of outputs, and gives OP_RETURN outputs amount zero.++    * to_remote_script is split into to_remote_witness_script and+      to_remote_script_pubkey. Witness functions append the witness+      script and take typed keys; funding_witness orders signatures by+      pubkey. Adds htlc_success_witness, htlc_timeout_witness and+      remote_htlc_sighash.++    * Per-commitment secrets use Seed, SecretIndex and bolt1's+      PerCommitmentSecret. SecretStore is abstract, with a redacted+      Show instance and secret_store/un_secret_store for persistence.+      Adds commitment_secret_index.++    * Adds derive_commitment_keys, derive_privkey and+      derive_revocationprivkey.++    * Renames encode_tx to encode_commitment_tx, and documents the+      encoders as producing unsigned, witness-free serializations.++    * Removes the Validate, Decode, Encode and Internal modules, the+      role-specific key derivation functions, encode_tx_for_signing,+      encode_witness, encode_funding_witness, has_anchors, sort_outputs,+      trimmed_htlcs, untrimmed_htlcs, derive_secret, the HTLC output+      script aliases, the weight constants and unused record fields.++  * Fixes insert_secret, which discarded the entries needed to derive+    older secrets and accepted invalid secret sequences.++  * Fixes closing transactions, which used each party's dust limit in+    legacy closes, and charged the funder and paid OP_RETURN outputs in+    option_simple_close.++  * Rejects key derivations yielding the point at infinity.++  * Tests cover every BOLT #3 Appendix B-F vector.++- 0.0.1 (2026-04-18)+  * Initial release.

@@ -0,0 +1,203 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Fixtures (+    Fixtures(..)+  , fixtures+  , tex+  ) where++import qualified Bitcoin.Prim.Tx as BT+import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Control.Monad (foldM)+import qualified Crypto.Curve.Secp256k1 as S+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import GHC.Generics (Generic)+import qualified Lightning.Protocol.BOLT1 as BOLT1+import Lightning.Protocol.BOLT3++-- | Shared wNAF context.+tex :: S.Context+tex = S.precompute+{-# NOINLINE tex #-}++data Fixtures = Fixtures+  { fx_secret       :: !BOLT1.PerCommitmentSecret+  , fx_seed         :: !Seed+  , fx_basepoint    :: !BOLT1.Point+  , fx_pcp          :: !PerCommitmentPoint+  , fx_rbp          :: !RevocationBasepoint+  , fx_seckey       :: !Seckey+  , fx_local_bps    :: !Basepoints+  , fx_remote_bps   :: !Basepoints+  , fx_local_fund   :: !FundingPubkey+  , fx_remote_fund  :: !FundingPubkey+  , fx_store        :: !SecretStore+  , fx_store_next   :: !(SecretIndex, BOLT1.PerCommitmentSecret)+  , fx_store_oldest :: !SecretIndex+  , fx_ctx_simple   :: !CommitmentContext+  , fx_ctx_htlcs    :: !CommitmentContext+  , fx_ctx_anchors  :: !CommitmentContext+  , fx_commit       :: !CommitmentTx+  , fx_htlc_ctx     :: !HTLCContext+  , fx_htlc_tx      :: !HTLCTx+  , fx_closing      :: !ClosingContext+  , fx_legacy       :: !LegacyClosingContext+  , fx_closing_tx   :: !ClosingTx+  } deriving Generic++instance NFData Fixtures++hex :: BS.ByteString -> Maybe BS.ByteString+hex = B16.decode++pt :: BS.ByteString -> Maybe BOLT1.Point+pt h = hex h >>= BOLT1.point++-- | Benchmark fixtures, from the BOLT #3 Appendix C parameters, fully+--   evaluated.+fixtures :: IO Fixtures+fixtures = maybe (fail "invalid fixtures") (evaluate . force) build++build :: Maybe Fixtures+build = do+  secret <- BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])+  sd <- seed (BS.replicate 32 0xff)+  basepoint <- pt+    "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"+  pcp <- PerCommitmentPoint <$> pt+    "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"+  sk <- seckey (BS.pack [0 .. 31])++  local_pay <- pt+    "034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa"+  remote_pay <- pt+    "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991"+  local_delayed <- pt+    "023c72addb4fdf09af94f0c94d7fe92a386a7e70cf8a1d85916386bb2535c7b1b1"+  remote_rev <- pt+    "02466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27"+  local_fund <- FundingPubkey <$> pt+    "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb"+  remote_fund <- FundingPubkey <$> pt+    "030e9f7b623d2ccc7c9bd44d66d5ce21ce504c0acf6385a132cec6d3c39fa711c1"+  let local_bps = Basepoints (RevocationBasepoint local_pay)+        (PaymentBasepoint local_pay) (DelayedPaymentBasepoint local_delayed)+        (HtlcBasepoint local_pay)+      remote_bps = Basepoints (RevocationBasepoint remote_rev)+        (PaymentBasepoint remote_pay) (DelayedPaymentBasepoint remote_pay)+        (HtlcBasepoint remote_pay)+  keys <- derive_commitment_keys local_bps local_fund remote_bps remote_fund+            pcp++  -- a store holding the 2^14 - 1 most recent secrets; the next index has+  -- 14 trailing zeros, so inserting it checks every lower bucket+  let n = 16383 :: Int+  idxs <- traverse secret_index (take n [0xFFFFFFFFFFFF, 0xFFFFFFFFFFFE ..])+  store <- foldM (\st i -> insert_secret (generate_from_seed sd i) i st)+             empty_secret_store idxs+  next <- secret_index (0xFFFFFFFFFFFF - fromIntegral n)+  oldest <- secret_index 0xFFFFFFFFFFFF++  txid <- hex+    "8984484a580b825b9972d7adb15050b3ab624ccd731946b3eeddb92f4e7ef6be"+  outpoint <- (\t -> BT.OutPoint t 0) <$> BT.mk_txid (BS.reverse txid)+  cn <- commitment_number 42+  dust <- DustLimit <$> BOLT1.satoshi 546+  to_local <- BOLT1.milli_satoshi 6988000000+  to_remote <- BOLT1.milli_satoshi 3000000000+  htlcs <- traverse htlc+    [ (HTLCReceived, 1000000, 500, 0x00), (HTLCReceived, 2000000, 501, 0x01)+    , (HTLCOffered, 2000000, 502, 0x02), (HTLCOffered, 3000000, 503, 0x03)+    , (HTLCReceived, 4000000, 504, 0x04) ]+  let ctx_simple = CommitmentContext+        { cc_funding_outpoint  = outpoint+        , cc_commitment_number = cn+        , cc_local_payment_bp  = PaymentBasepoint local_pay+        , cc_remote_payment_bp = PaymentBasepoint remote_pay+        , cc_to_self_delay     = ToSelfDelay 144+        , cc_dust_limit        = dust+        , cc_feerate           = FeeratePerKw 15000+        , cc_format            = StaticRemotekey+        , cc_is_funder         = True+        , cc_to_local_msat     = to_local+        , cc_to_remote_msat    = to_remote+        , cc_htlcs             = []+        , cc_keys              = keys+        }+      ctx_htlcs = ctx_simple { cc_feerate = FeeratePerKw 644+                             , cc_htlcs = htlcs }+      ctx_anchors = ctx_htlcs { cc_format = Anchors }+  commit <- build_commitment_tx ctx_htlcs+  htlc_out <- case htlcs of+    (h : _) -> Just h+    []      -> Nothing+  let htlc_ctx = HTLCContext+        { hc_commitment_txid   = BT.txid (commitment_to_tx commit)+        , hc_output_index      = 0+        , hc_htlc              = htlc_out+        , hc_to_self_delay     = ToSelfDelay 144+        , hc_feerate           = FeeratePerKw 644+        , hc_format            = StaticRemotekey+        , hc_revocation_pubkey = ck_revocation_pubkey keys+        , hc_local_delayed     = ck_local_delayed keys+        }+  htlc_tx <- build_htlc_tx htlc_ctx++  fee <- BOLT1.satoshi 1000+  let p2wpkh b = Script (BS.pack [0x00, 0x14] <> BS.replicate 20 b)+      closing = ClosingContext+        { clc_funding_outpoint = outpoint+        , clc_closer_msat      = to_local+        , clc_closee_msat      = to_remote+        , clc_closer_script    = p2wpkh 0x11+        , clc_closee_script    = p2wpkh 0x22+        , clc_fee              = fee+        , clc_locktime         = Locktime 0+        , clc_outputs          = CloserAndCloseeOutputs+        }+      legacy = LegacyClosingContext+        { lcc_funding_outpoint = outpoint+        , lcc_local_msat       = to_local+        , lcc_remote_msat      = to_remote+        , lcc_local_script     = p2wpkh 0x11+        , lcc_remote_script    = p2wpkh 0x22+        , lcc_dust_limit       = dust+        , lcc_fee              = fee+        , lcc_is_funder        = True+        , lcc_omit_local       = False+        }+  closing_tx <- build_closing_tx closing++  pure Fixtures+    { fx_secret       = secret+    , fx_seed         = sd+    , fx_basepoint    = basepoint+    , fx_pcp          = pcp+    , fx_rbp          = RevocationBasepoint basepoint+    , fx_seckey       = sk+    , fx_local_bps    = local_bps+    , fx_remote_bps   = remote_bps+    , fx_local_fund   = local_fund+    , fx_remote_fund  = remote_fund+    , fx_store        = store+    , fx_store_next   = (next, generate_from_seed sd next)+    , fx_store_oldest = oldest+    , fx_ctx_simple   = ctx_simple+    , fx_ctx_htlcs    = ctx_htlcs+    , fx_ctx_anchors  = ctx_anchors+    , fx_commit       = commit+    , fx_htlc_ctx     = htlc_ctx+    , fx_htlc_tx      = htlc_tx+    , fx_closing      = closing+    , fx_legacy       = legacy+    , fx_closing_tx   = closing_tx+    }+  where+    htlc (dir, amt, expiry, b) = do+      a <- BOLT1.milli_satoshi amt+      ph <- BOLT1.payment_hash (SHA256.hash (BS.replicate 32 b))+      pure (HTLC dir a ph (CltvExpiry expiry))

@@ -1,489 +1,82 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}- module Main where -import Control.DeepSeq (NFData(..)) import Criterion.Main-import Data.Word (Word64)-import qualified Data.ByteString as BS+import Fixtures import Lightning.Protocol.BOLT3 --- NFData instances for benchmarking---- Existing instances-instance NFData Satoshi where-  rnf (Satoshi x) = rnf x--instance NFData MilliSatoshi where-  rnf (MilliSatoshi x) = rnf x--instance NFData Pubkey where-  rnf (Pubkey x) = rnf x--instance NFData Point where-  rnf (Point x) = rnf x--instance NFData PerCommitmentPoint where-  rnf (PerCommitmentPoint x) = rnf x--instance NFData RevocationPubkey where-  rnf (RevocationPubkey x) = rnf x--instance NFData RevocationBasepoint where-  rnf (RevocationBasepoint x) = rnf x--instance NFData ChannelFeatures where-  rnf (ChannelFeatures x) = rnf x--instance NFData FeeratePerKw where-  rnf (FeeratePerKw x) = rnf x--instance NFData DustLimit where-  rnf (DustLimit x) = rnf x--instance NFData PaymentHash where-  rnf (PaymentHash x) = rnf x--instance NFData CltvExpiry where-  rnf (CltvExpiry x) = rnf x--instance NFData HTLCDirection where-  rnf HTLCOffered = ()-  rnf HTLCReceived = ()--instance NFData HTLC where-  rnf (HTLC d a h c) = rnf d `seq` rnf a `seq` rnf h `seq` rnf c---- Transaction types-instance NFData CommitmentTx where-  rnf (CommitmentTx v l i s o f) =-    rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f--instance NFData HTLCTx where-  rnf (HTLCTx v l i s ov os) =-    rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os--instance NFData ClosingTx where-  rnf (ClosingTx v l i s o f) =-    rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f---- Output types-instance NFData TxOutput where-  rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t--instance NFData OutputType where-  rnf OutputToLocal = ()-  rnf OutputToRemote = ()-  rnf OutputLocalAnchor = ()-  rnf OutputRemoteAnchor = ()-  rnf (OutputOfferedHTLC e) = rnf e-  rnf (OutputReceivedHTLC e) = rnf e---- Primitives-instance NFData Script where-  rnf (Script bs) = rnf bs--instance NFData Witness where-  rnf (Witness items) = rnf items--instance NFData Outpoint where-  rnf (Outpoint t i) = rnf t `seq` rnf i--instance NFData Sequence where-  rnf (Sequence x) = rnf x--instance NFData Locktime where-  rnf (Locktime x) = rnf x--instance NFData TxId where-  rnf (TxId bs) = rnf bs--instance NFData ToSelfDelay where-  rnf (ToSelfDelay x) = rnf x--instance NFData CommitmentNumber where-  rnf (CommitmentNumber x) = rnf x---- Parsing types-instance NFData RawTx where-  rnf (RawTx v i o w l) =-    rnf v `seq` rnf i `seq` rnf o `seq` rnf w `seq` rnf l--instance NFData RawInput where-  rnf (RawInput o scr sq) = rnf o `seq` rnf scr `seq` rnf sq--instance NFData RawOutput where-  rnf (RawOutput v s) = rnf v `seq` rnf s---- Context types-instance NFData CommitmentContext where-  rnf ctx = rnf (cc_funding_outpoint ctx) `seq`-            rnf (cc_commitment_number ctx) `seq`-            rnf (cc_htlcs ctx) `seq`-            rnf (cc_keys ctx)--instance NFData CommitmentKeys where-  rnf keys = rnf (ck_revocation_pubkey keys) `seq`-             rnf (ck_local_delayed keys) `seq`-             rnf (ck_local_htlc keys) `seq`-             rnf (ck_remote_htlc keys)--instance NFData HTLCContext where-  rnf ctx = rnf (hc_commitment_txid ctx) `seq`-            rnf (hc_htlc ctx)--instance NFData ClosingContext where-  rnf ctx = rnf (clc_funding_outpoint ctx) `seq`-            rnf (clc_local_amount ctx) `seq`-            rnf (clc_remote_amount ctx)---- Key types-instance NFData LocalDelayedPubkey where-  rnf (LocalDelayedPubkey p) = rnf p--instance NFData RemoteDelayedPubkey where-  rnf (RemoteDelayedPubkey p) = rnf p--instance NFData LocalHtlcPubkey where-  rnf (LocalHtlcPubkey p) = rnf p--instance NFData RemoteHtlcPubkey where-  rnf (RemoteHtlcPubkey p) = rnf p--instance NFData LocalPubkey where-  rnf (LocalPubkey p) = rnf p--instance NFData RemotePubkey where-  rnf (RemotePubkey p) = rnf p--instance NFData PaymentBasepoint where-  rnf (PaymentBasepoint p) = rnf p--instance NFData DelayedPaymentBasepoint where-  rnf (DelayedPaymentBasepoint p) = rnf p--instance NFData HtlcBasepoint where-  rnf (HtlcBasepoint p) = rnf p--instance NFData FundingPubkey where-  rnf (FundingPubkey p) = rnf p--instance NFData PerCommitmentSecret where-  rnf (PerCommitmentSecret bs) = rnf bs---- Secret storage (SecretStore is a newtype over list)-instance NFData SecretStore where-  rnf store = rnf (derive_old_secret 0 store)---- Validation errors-instance NFData ValidationError where-  rnf (InvalidVersion a b) = rnf a `seq` rnf b-  rnf (InvalidLocktime a) = rnf a-  rnf (InvalidSequence a) = rnf a-  rnf InvalidOutputOrdering = ()-  rnf (DustLimitViolation a b c) = rnf a `seq` rnf b `seq` rnf c-  rnf MissingAnchorOutput = ()-  rnf (InvalidAnchorValue a) = rnf a-  rnf (InvalidFee a b) = rnf a `seq` rnf b-  rnf (InvalidHTLCLocktime a b) = rnf a `seq` rnf b-  rnf (InvalidHTLCSequence a b) = rnf a `seq` rnf b-  rnf NoOutputs = ()-  rnf (TooManyOutputs a) = rnf a---- Decode errors-instance NFData DecodeError where-  rnf (InsufficientBytes a b) = rnf a `seq` rnf b-  rnf (InvalidMarker a) = rnf a-  rnf (InvalidFlag a) = rnf a-  rnf InvalidVarint = ()-  rnf EmptyInput = ()- main :: IO ()-main = defaultMain [-    bgroup "key derivation" [-      bench "derive_pubkey" $-        whnf (derive_pubkey basepoint) perCommitmentPoint-    , bench "derive_revocationpubkey" $-        whnf (derive_revocationpubkey revocationBasepoint) perCommitmentPoint-    ]-  , bgroup "secret generation" [-      bench "generate_from_seed (final node)" $-        whnf (generate_from_seed seed) 281474976710655-    , bench "generate_from_seed (first node)" $-        whnf (generate_from_seed seed) 0-    ]-  , bgroup "fee calculation" [-      bench "commitment_fee (no anchors, 0 htlcs)" $-        whnf (commitment_fee feerate noAnchors) 0-    , bench "commitment_fee (no anchors, 10 htlcs)" $-        whnf (commitment_fee feerate noAnchors) 10-    , bench "commitment_fee (anchors, 10 htlcs)" $-        whnf (commitment_fee feerate withAnchors) 10-    , bench "htlc_timeout_fee" $-        whnf (htlc_timeout_fee feerate) noAnchors-    , bench "htlc_success_fee" $-        whnf (htlc_success_fee feerate) noAnchors-    ]-  , bgroup "trimming" [-      bench "is_trimmed (offered, not trimmed)" $-        whnf (is_trimmed dust feerate noAnchors) htlcNotTrimmed-    , bench "is_trimmed (offered, trimmed)" $-        whnf (is_trimmed dust feerate noAnchors) htlcTrimmed-    , bench "htlc_trim_threshold (offered)" $-        whnf (htlc_trim_threshold dust feerate noAnchors) HTLCOffered-    ]-  , bgroup "tx building" [-      bench "build_commitment_tx (0 htlcs, no anchors)" $-        whnf build_commitment_tx (mkCommitmentContext htlcs0 noAnchors)-    , bench "build_commitment_tx (10 htlcs, no anchors)" $-        whnf build_commitment_tx (mkCommitmentContext htlcs10 noAnchors)-    , bench "build_commitment_tx (100 htlcs, no anchors)" $-        whnf build_commitment_tx (mkCommitmentContext htlcs100 noAnchors)-    , bench "build_commitment_tx (10 htlcs, anchors)" $-        whnf build_commitment_tx (mkCommitmentContext htlcs10 withAnchors)-    , bench "build_htlc_timeout_tx" $-        whnf build_htlc_timeout_tx sampleHtlcContext-    , bench "build_htlc_success_tx" $-        whnf build_htlc_success_tx sampleHtlcContext-    , bench "build_closing_tx" $-        whnf build_closing_tx sampleClosingContext-    ]-  , bgroup "script generation" [-      bench "funding_script" $-        whnf (funding_script (FundingPubkey samplePubkey1))-             (FundingPubkey samplePubkey2)-    , bench "to_local_script" $-        whnf (to_local_script (RevocationPubkey samplePubkey1)-                              (ToSelfDelay 144))-             (LocalDelayedPubkey samplePubkey2)-    , bench "to_remote_script (no anchors)" $-        whnf (to_remote_script (RemotePubkey samplePubkey1)) noAnchors-    , bench "to_remote_script (anchors)" $-        whnf (to_remote_script (RemotePubkey samplePubkey1)) withAnchors-    , bench "anchor_script" $-        whnf anchor_script (FundingPubkey samplePubkey1)-    , bench "offered_htlc_script" $-        whnf (offered_htlc_script (RevocationPubkey samplePubkey1)-                                  (RemoteHtlcPubkey samplePubkey2)-                                  (LocalHtlcPubkey samplePubkey3)-                                  (PaymentHash $ BS.replicate 32 0))-             noAnchors-    , bench "received_htlc_script" $-        whnf (received_htlc_script (RevocationPubkey samplePubkey1)-                                   (RemoteHtlcPubkey samplePubkey2)-                                   (LocalHtlcPubkey samplePubkey3)-                                   (PaymentHash $ BS.replicate 32 0)-                                   (CltvExpiry 500000))-             noAnchors-    ]-  , bgroup "serialization" [-      env (pure $ build_commitment_tx $ mkCommitmentContext htlcs0 noAnchors)-        $ \tx -> bench "encode_tx (0 htlcs)" $ whnf encode_tx tx-    , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)-        $ \tx -> bench "encode_tx (10 htlcs)" $ whnf encode_tx tx-    , env (pure $ build_commitment_tx $ mkCommitmentContext htlcs100 noAnchors)-        $ \tx -> bench "encode_tx (100 htlcs)" $ whnf encode_tx tx-    , bench "encode_htlc_tx" $-        whnf encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)-    , bench "encode_closing_tx" $-        whnf encode_closing_tx (build_closing_tx sampleClosingContext)-    ]-  , bgroup "parsing" [-      env (pure $ encode_tx $ build_commitment_tx $-             mkCommitmentContext htlcs0 noAnchors)-        $ \bs -> bench "decode_tx (0 htlcs)" $ whnf decode_tx bs-    , env (pure $ encode_tx $ build_commitment_tx $-             mkCommitmentContext htlcs10 noAnchors)-        $ \bs -> bench "decode_tx (10 htlcs)" $ whnf decode_tx bs-    , env (pure $ encode_tx $ build_commitment_tx $-             mkCommitmentContext htlcs100 noAnchors)-        $ \bs -> bench "decode_tx (100 htlcs)" $ whnf decode_tx bs-    ]-  , bgroup "validation" [-      env (pure $ build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)-        $ \tx -> bench "validate_commitment_tx (valid)" $-            whnf (validate_commitment_tx dust noAnchors) tx-    , env (pure $ build_htlc_timeout_tx sampleHtlcContext)-        $ \tx -> bench "validate_htlc_tx" $-            whnf validate_htlc_tx tx-    , env (pure $ build_closing_tx sampleClosingContext)-        $ \tx -> bench "validate_closing_tx" $-            whnf validate_closing_tx tx-    , env (pure $ ctx_outputs $ build_commitment_tx $-             mkCommitmentContext htlcs10 noAnchors)-        $ \outs -> bench "validate_output_ordering" $-            whnf validate_output_ordering outs-    ]-  , bgroup "secret storage" [-      bench "insert_secret (first)" $-        whnf (insert_secret (BS.replicate 32 0xFF) 281474976710655)-             empty_store-    , env setupFilledStore $ \store ->-        bench "derive_old_secret (recent)" $-          whnf (derive_old_secret 281474976710654) store-    , env setupFilledStore $ \store ->-        bench "derive_old_secret (old)" $-          whnf (derive_old_secret 281474976710600) store-    ]-  , bgroup "output sorting" [-      env (pure $ ctx_outputs $ build_commitment_tx $-             mkCommitmentContext htlcs10 noAnchors)-        $ \outs -> bench "sort_outputs (10)" $ nf sort_outputs outs-    , env (pure $ ctx_outputs $ build_commitment_tx $-             mkCommitmentContext htlcs100 noAnchors)-        $ \outs -> bench "sort_outputs (100)" $ nf sort_outputs outs+main = do+  fx <- fixtures+  let (next_idx, next_secret) = fx_store_next fx+      keys = ck fx+  defaultMain [+      bgroup "keys" [+        bench "derive_per_commitment_point" $+          nf derive_per_commitment_point (fx_secret fx)+      , bench "derive_per_commitment_point'" $+          nf (derive_per_commitment_point' tex) (fx_secret fx)+      , bench "derive_pubkey" $+          nf (derive_pubkey (fx_basepoint fx)) (fx_pcp fx)+      , bench "derive_revocationpubkey" $+          nf (derive_revocationpubkey (fx_rbp fx)) (fx_pcp fx)+      , bench "derive_commitment_keys" $+          nf (derive_commitment_keys (fx_local_bps fx) (fx_local_fund fx)+                (fx_remote_bps fx) (fx_remote_fund fx)) (fx_pcp fx)+      , bench "derive_commitment_keys'" $+          nf (derive_commitment_keys' tex (fx_local_bps fx) (fx_local_fund fx)+                (fx_remote_bps fx) (fx_remote_fund fx)) (fx_pcp fx)+      , bench "derive_privkey" $+          nf (derive_privkey (fx_seckey fx)) (fx_pcp fx)+      , bench "derive_revocationprivkey" $+          nf (derive_revocationprivkey (fx_seckey fx)) (fx_secret fx)+      ]+    , bgroup "secrets" [+        bench "generate_from_seed (index 2^48 - 1)" $+          nf (generate_from_seed (fx_seed fx)) (fx_store_oldest fx)+      , bench "insert_secret (14 lower buckets)" $+          nf (insert_secret next_secret next_idx) (fx_store fx)+      , bench "derive_old_secret (index 2^48 - 1)" $+          nf (derive_old_secret (fx_store_oldest fx)) (fx_store fx)+      , bench "secret_store . un_secret_store" $+          nf (secret_store . un_secret_store) (fx_store fx)+      ]+    , bgroup "scripts" [+        bench "funding_script" $+          nf (funding_script (fx_local_fund fx)) (fx_remote_fund fx)+      , bench "to_local_script" $+          nf (to_local_script (ck_revocation_pubkey keys) (ToSelfDelay 144))+             (ck_local_delayed keys)+      , bench "offered_htlc_script" $+          nf (offered_htlc_script (ck_revocation_pubkey keys)+                (ck_remote_htlc keys) (ck_local_htlc keys) (hash fx))+             Anchors+      , bench "received_htlc_script" $+          nf (received_htlc_script (ck_revocation_pubkey keys)+                (ck_remote_htlc keys) (ck_local_htlc keys) (hash fx)+                (CltvExpiry 500))+             Anchors+      ]+    , bgroup "transactions" [+        bench "build_commitment_tx (no htlcs)" $+          nf build_commitment_tx (fx_ctx_simple fx)+      , bench "build_commitment_tx (5 htlcs)" $+          nf build_commitment_tx (fx_ctx_htlcs fx)+      , bench "build_commitment_tx (5 htlcs, anchors)" $+          nf build_commitment_tx (fx_ctx_anchors fx)+      , bench "encode_commitment_tx (5 htlcs)" $+          nf encode_commitment_tx (fx_commit fx)+      , bench "build_htlc_tx" $+          nf build_htlc_tx (fx_htlc_ctx fx)+      , bench "encode_htlc_tx" $+          nf encode_htlc_tx (fx_htlc_tx fx)+      , bench "build_closing_tx" $+          nf build_closing_tx (fx_closing fx)+      , bench "build_legacy_closing_tx" $+          nf build_legacy_closing_tx (fx_legacy fx)+      , bench "encode_closing_tx" $+          nf encode_closing_tx (fx_closing_tx fx)+      ]     ]-  ]   where-    -- Key derivation test data-    basepoint = Point $ BS.pack-      [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,-       0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,-       0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]--    perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack-      [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,-       0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,-       0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]--    revocationBasepoint = RevocationBasepoint $ Point $ BS.pack-      [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,-       0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,-       0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]--    -- Secret generation test data-    seed = BS.replicate 32 0xFF--    -- Fee calculation test data-    feerate = FeeratePerKw 5000-    noAnchors = ChannelFeatures { cf_option_anchors = False }-    withAnchors = ChannelFeatures { cf_option_anchors = True }--    -- Trimming test data-    dust = DustLimit (Satoshi 546)--    htlcNotTrimmed = HTLC-      { htlc_direction = HTLCOffered-      , htlc_amount_msat = MilliSatoshi 5000000-      , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-      , htlc_cltv_expiry = CltvExpiry 500000-      }--    htlcTrimmed = HTLC-      { htlc_direction = HTLCOffered-      , htlc_amount_msat = MilliSatoshi 1000000-      , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-      , htlc_cltv_expiry = CltvExpiry 500000-      }--    -- Sample pubkeys-    samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey-    samplePubkey1 = Pubkey $ BS.pack-      [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,-       0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,-       0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]-    samplePubkey2 = Pubkey $ BS.pack-      [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,-       0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,-       0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]-    samplePubkey3 = samplePubkey1--    -- Funding outpoint-    sampleFundingOutpoint :: Outpoint-    sampleFundingOutpoint = Outpoint (TxId $ BS.replicate 32 0x01) 0--    -- HTLC lists-    mkHtlc :: HTLCDirection -> Word64 -> Word64 -> HTLC-    mkHtlc dir amtMsat expiry = HTLC-      { htlc_direction = dir-      , htlc_amount_msat = MilliSatoshi amtMsat-      , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00)-      , htlc_cltv_expiry = CltvExpiry (fromIntegral expiry)-      }--    htlcs0, htlcs10, htlcs100 :: [HTLC]-    htlcs0 = []-    htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)-                      (5000000 + i * 100000) (500000 + i)-              | i <- [0..9]]-    htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)-                       (5000000 + i * 10000) (500000 + i)-               | i <- [0..99]]--    -- CommitmentKeys fixture-    sampleCommitmentKeys :: CommitmentKeys-    sampleCommitmentKeys = CommitmentKeys-      { ck_revocation_pubkey = RevocationPubkey samplePubkey1-      , ck_local_delayed = LocalDelayedPubkey samplePubkey1-      , ck_local_htlc = LocalHtlcPubkey samplePubkey1-      , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2-      , ck_local_payment = LocalPubkey samplePubkey1-      , ck_remote_payment = RemotePubkey samplePubkey2-      , ck_local_funding = FundingPubkey samplePubkey1-      , ck_remote_funding = FundingPubkey samplePubkey2-      }--    -- CommitmentContext builder-    mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext-    mkCommitmentContext htlcs features = CommitmentContext-      { cc_funding_outpoint = sampleFundingOutpoint-      , cc_commitment_number = CommitmentNumber 42-      , cc_local_payment_bp =-          PaymentBasepoint $ Point $ unPubkey samplePubkey1-      , cc_remote_payment_bp =-          PaymentBasepoint $ Point $ unPubkey samplePubkey2-      , cc_to_self_delay = ToSelfDelay 144-      , cc_dust_limit = DustLimit (Satoshi 546)-      , cc_feerate = FeeratePerKw 5000-      , cc_features = features-      , cc_is_funder = True-      , cc_to_local_msat = MilliSatoshi 500000000-      , cc_to_remote_msat = MilliSatoshi 500000000-      , cc_htlcs = htlcs-      , cc_keys = sampleCommitmentKeys-      }--    -- HTLC context-    sampleHtlcContext :: HTLCContext-    sampleHtlcContext = HTLCContext-      { hc_commitment_txid = TxId $ BS.replicate 32 0x01-      , hc_output_index = 0-      , hc_htlc = mkHtlc HTLCOffered 5000000 500000-      , hc_to_self_delay = ToSelfDelay 144-      , hc_feerate = FeeratePerKw 5000-      , hc_features = noAnchors-      , hc_revocation_pubkey = RevocationPubkey samplePubkey1-      , hc_local_delayed = LocalDelayedPubkey samplePubkey1-      }--    -- Closing context-    sampleClosingContext :: ClosingContext-    sampleClosingContext = ClosingContext-      { clc_funding_outpoint = sampleFundingOutpoint-      , clc_local_amount = Satoshi 500000-      , clc_remote_amount = Satoshi 500000-      , clc_local_script =-          Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x01-      , clc_remote_script =-          Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0x02-      , clc_local_dust_limit = DustLimit (Satoshi 546)-      , clc_remote_dust_limit = DustLimit (Satoshi 546)-      , clc_fee = Satoshi 1000-      , clc_is_funder = True-      , clc_locktime = Locktime 0-      , clc_funding_script = funding_script (FundingPubkey samplePubkey1)-                                            (FundingPubkey samplePubkey2)-      }--    -- Setup for secret storage benchmarks-    setupFilledStore :: IO SecretStore-    setupFilledStore = do-      let secrets = [(generate_from_seed seed i, i)-                    | i <- [281474976710655, 281474976710654 .. 281474976710600]]-      pure $! foldl insertOrFail empty_store secrets-      where-        insertOrFail store (sec, idx) =-          case insert_secret sec idx store of-            Just s  -> s-            Nothing -> store+    ck = cc_keys . fx_ctx_simple+    hash = htlc_payment_hash . hc_htlc . fx_htlc_ctx

@@ -1,479 +1,53 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}- module Main where -import Control.DeepSeq (NFData(..))-import qualified Data.ByteString as BS-import Data.Word (Word32, Word64)+import Fixtures import Lightning.Protocol.BOLT3 import Weigh --- NFData instances for weigh---- Monetary types-instance NFData Satoshi where-  rnf (Satoshi x) = rnf x--instance NFData MilliSatoshi where-  rnf (MilliSatoshi x) = rnf x---- Key types-instance NFData Pubkey where-  rnf (Pubkey x) = rnf x--instance NFData Point where-  rnf (Point x) = rnf x--instance NFData PerCommitmentPoint where-  rnf (PerCommitmentPoint x) = rnf x--instance NFData RevocationPubkey where-  rnf (RevocationPubkey x) = rnf x--instance NFData RevocationBasepoint where-  rnf (RevocationBasepoint x) = rnf x--instance NFData LocalDelayedPubkey where-  rnf (LocalDelayedPubkey p) = rnf p--instance NFData RemoteDelayedPubkey where-  rnf (RemoteDelayedPubkey p) = rnf p--instance NFData LocalHtlcPubkey where-  rnf (LocalHtlcPubkey p) = rnf p--instance NFData RemoteHtlcPubkey where-  rnf (RemoteHtlcPubkey p) = rnf p--instance NFData LocalPubkey where-  rnf (LocalPubkey p) = rnf p--instance NFData RemotePubkey where-  rnf (RemotePubkey p) = rnf p--instance NFData PaymentBasepoint where-  rnf (PaymentBasepoint p) = rnf p--instance NFData DelayedPaymentBasepoint where-  rnf (DelayedPaymentBasepoint p) = rnf p--instance NFData HtlcBasepoint where-  rnf (HtlcBasepoint p) = rnf p--instance NFData FundingPubkey where-  rnf (FundingPubkey p) = rnf p--instance NFData PerCommitmentSecret where-  rnf (PerCommitmentSecret bs) = rnf bs---- Channel features-instance NFData ChannelFeatures where-  rnf (ChannelFeatures x) = rnf x--instance NFData FeeratePerKw where-  rnf (FeeratePerKw x) = rnf x--instance NFData DustLimit where-  rnf (DustLimit x) = rnf x---- Hash types-instance NFData PaymentHash where-  rnf (PaymentHash x) = rnf x--instance NFData CltvExpiry where-  rnf (CltvExpiry x) = rnf x---- HTLC types-instance NFData HTLCDirection where-  rnf HTLCOffered = ()-  rnf HTLCReceived = ()--instance NFData HTLC where-  rnf (HTLC d a h c) = rnf d `seq` rnf a `seq` rnf h `seq` rnf c---- Transaction types-instance NFData CommitmentTx where-  rnf (CommitmentTx v l i s o f) =-    rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f--instance NFData HTLCTx where-  rnf (HTLCTx v l i s ov os) =-    rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf ov `seq` rnf os--instance NFData ClosingTx where-  rnf (ClosingTx v l i s o f) =-    rnf v `seq` rnf l `seq` rnf i `seq` rnf s `seq` rnf o `seq` rnf f---- Output types-instance NFData TxOutput where-  rnf (TxOutput v s t) = rnf v `seq` rnf s `seq` rnf t--instance NFData OutputType where-  rnf OutputToLocal = ()-  rnf OutputToRemote = ()-  rnf OutputLocalAnchor = ()-  rnf OutputRemoteAnchor = ()-  rnf (OutputOfferedHTLC e) = rnf e-  rnf (OutputReceivedHTLC e) = rnf e---- Primitives-instance NFData Script where-  rnf (Script bs) = rnf bs--instance NFData Witness where-  rnf (Witness items) = rnf items--instance NFData Outpoint where-  rnf (Outpoint t i) = rnf t `seq` rnf i--instance NFData Sequence where-  rnf (Sequence x) = rnf x--instance NFData Locktime where-  rnf (Locktime x) = rnf x--instance NFData TxId where-  rnf (TxId bs) = rnf bs--instance NFData ToSelfDelay where-  rnf (ToSelfDelay x) = rnf x--instance NFData CommitmentNumber where-  rnf (CommitmentNumber x) = rnf x---- Parsing types-instance NFData RawTx where-  rnf (RawTx v i o w l) =-    rnf v `seq` rnf i `seq` rnf o `seq` rnf w `seq` rnf l--instance NFData RawInput where-  rnf (RawInput o scr sq) = rnf o `seq` rnf scr `seq` rnf sq--instance NFData RawOutput where-  rnf (RawOutput v s) = rnf v `seq` rnf s---- Context types-instance NFData CommitmentContext where-  rnf ctx = rnf (cc_funding_outpoint ctx) `seq`-            rnf (cc_commitment_number ctx) `seq`-            rnf (cc_htlcs ctx) `seq`-            rnf (cc_keys ctx)--instance NFData CommitmentKeys where-  rnf keys = rnf (ck_revocation_pubkey keys) `seq`-             rnf (ck_local_delayed keys) `seq`-             rnf (ck_local_htlc keys) `seq`-             rnf (ck_remote_htlc keys)--instance NFData HTLCContext where-  rnf ctx = rnf (hc_commitment_txid ctx) `seq`-            rnf (hc_htlc ctx)--instance NFData ClosingContext where-  rnf ctx = rnf (clc_funding_outpoint ctx) `seq`-            rnf (clc_local_amount ctx) `seq`-            rnf (clc_remote_amount ctx)---- Error types-instance NFData DecodeError where-  rnf (InsufficientBytes e a) = rnf e `seq` rnf a-  rnf (InvalidMarker w) = rnf w-  rnf (InvalidFlag w) = rnf w-  rnf InvalidVarint = ()-  rnf EmptyInput = ()--instance NFData ValidationError where-  rnf (InvalidVersion e a) = rnf e `seq` rnf a-  rnf (InvalidLocktime lt) = rnf lt-  rnf (InvalidSequence sq) = rnf sq-  rnf InvalidOutputOrdering = ()-  rnf (DustLimitViolation i v d) = rnf i `seq` rnf v `seq` rnf d-  rnf MissingAnchorOutput = ()-  rnf (InvalidAnchorValue v) = rnf v-  rnf (InvalidFee e a) = rnf e `seq` rnf a-  rnf (InvalidHTLCLocktime e a) = rnf e `seq` rnf a-  rnf (InvalidHTLCSequence e a) = rnf e `seq` rnf a-  rnf NoOutputs = ()-  rnf (TooManyOutputs n) = rnf n---- Secret store (opaque, use generic rnf on the list)-instance NFData SecretStore where-  rnf ss = ss `seq` ()- main :: IO ()-main = mainWith $ do-  setColumns [Case, Allocated, GCs, Max]--  -- Key derivation allocations-  func "derive_pubkey" (derive_pubkey basepoint) perCommitmentPoint-  func "derive_revocationpubkey"-       (derive_revocationpubkey revocationBasepoint) perCommitmentPoint--  -- Secret generation allocations-  func "generate_from_seed (final)" (generate_from_seed seed) 281474976710655-  func "generate_from_seed (first)" (generate_from_seed seed) 0--  -- Fee calculation allocations-  func "commitment_fee (0 htlcs)" (commitment_fee feerate noAnchors) 0-  func "commitment_fee (10 htlcs)" (commitment_fee feerate noAnchors) 10-  func "htlc_timeout_fee" (htlc_timeout_fee feerate) noAnchors-  func "htlc_success_fee" (htlc_success_fee feerate) noAnchors--  -- Trimming allocations-  func "is_trimmed (not trimmed)"-       (is_trimmed dust feerate noAnchors) htlcNotTrimmed-  func "is_trimmed (trimmed)"-       (is_trimmed dust feerate noAnchors) htlcTrimmed-  func "htlc_trim_threshold"-       (htlc_trim_threshold dust feerate noAnchors) HTLCOffered--  -- Transaction building allocations-  func "build_commitment_tx (0 htlcs, no anchors)"-       build_commitment_tx (mkCommitmentContext htlcs0 noAnchors)-  func "build_commitment_tx (10 htlcs, no anchors)"-       build_commitment_tx (mkCommitmentContext htlcs10 noAnchors)-  func "build_commitment_tx (100 htlcs, no anchors)"-       build_commitment_tx (mkCommitmentContext htlcs100 noAnchors)-  func "build_commitment_tx (10 htlcs, anchors)"-       build_commitment_tx (mkCommitmentContext htlcs10 withAnchors)-  func "build_htlc_timeout_tx"-       build_htlc_timeout_tx sampleHtlcContext-  func "build_htlc_success_tx"-       build_htlc_success_tx sampleHtlcContext-  func "build_closing_tx"-       build_closing_tx sampleClosingContext--  -- Script generation allocations-  func "funding_script"-       (funding_script (FundingPubkey samplePubkey1))-       (FundingPubkey samplePubkey2)-  func "to_local_script"-       (to_local_script (RevocationPubkey samplePubkey1)-                        (ToSelfDelay 144))-       (LocalDelayedPubkey samplePubkey2)-  func "to_remote_script (no anchors)"-       (to_remote_script (RemotePubkey samplePubkey1)) noAnchors-  func "to_remote_script (anchors)"-       (to_remote_script (RemotePubkey samplePubkey1)) withAnchors-  func "anchor_script"-       anchor_script (FundingPubkey samplePubkey1)-  func "offered_htlc_script"-       (offered_htlc_script (RevocationPubkey samplePubkey1)-                            (RemoteHtlcPubkey samplePubkey2)-                            (LocalHtlcPubkey samplePubkey3)-                            (PaymentHash $ BS.replicate 32 0))-       noAnchors-  func "received_htlc_script"-       (received_htlc_script (RevocationPubkey samplePubkey1)-                             (RemoteHtlcPubkey samplePubkey2)-                             (LocalHtlcPubkey samplePubkey3)-                             (PaymentHash $ BS.replicate 32 0)-                             (CltvExpiry 500000))-       noAnchors--  -- Serialization allocations-  func "encode_tx (0 htlcs)"-       encode_tx (build_commitment_tx $ mkCommitmentContext htlcs0 noAnchors)-  func "encode_tx (10 htlcs)"-       encode_tx (build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)-  func "encode_tx (100 htlcs)"-       encode_tx (build_commitment_tx $ mkCommitmentContext htlcs100 noAnchors)-  func "encode_htlc_tx"-       encode_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)-  func "encode_closing_tx"-       encode_closing_tx (build_closing_tx sampleClosingContext)--  -- Parsing allocations-  func "decode_tx (0 htlcs)"-       decode_tx (encode_tx $ build_commitment_tx $-                    mkCommitmentContext htlcs0 noAnchors)-  func "decode_tx (10 htlcs)"-       decode_tx (encode_tx $ build_commitment_tx $-                    mkCommitmentContext htlcs10 noAnchors)-  func "decode_tx (100 htlcs)"-       decode_tx (encode_tx $ build_commitment_tx $-                    mkCommitmentContext htlcs100 noAnchors)--  -- Validation allocations-  func "validate_commitment_tx (valid)"-       (validate_commitment_tx dust noAnchors)-       (build_commitment_tx $ mkCommitmentContext htlcs10 noAnchors)-  func "validate_htlc_tx"-       validate_htlc_tx (build_htlc_timeout_tx sampleHtlcContext)-  func "validate_closing_tx"-       validate_closing_tx (build_closing_tx sampleClosingContext)-  func "validate_output_ordering"-       validate_output_ordering (ctx_outputs $ build_commitment_tx $-                                   mkCommitmentContext htlcs10 noAnchors)--  -- Secret storage allocations-  func "insert_secret (first)"-       (insert_secret (BS.replicate 32 0xFF) 281474976710655)-       empty_store-  func "derive_old_secret (recent)"-       (derive_old_secret 281474976710654)-       filledStore-  func "derive_old_secret (old)"-       (derive_old_secret 281474976710600)-       filledStore--  -- Output sorting allocations-  func "sort_outputs (10)"-       sort_outputs (ctx_outputs $ build_commitment_tx $-                       mkCommitmentContext htlcs10 noAnchors)-  func "sort_outputs (100)"-       sort_outputs (ctx_outputs $ build_commitment_tx $-                       mkCommitmentContext htlcs100 noAnchors)--  where-    -- Key derivation test data-    basepoint = Point $ BS.pack-      [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,-       0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,-       0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]--    perCommitmentPoint = PerCommitmentPoint $ Point $ BS.pack-      [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,-       0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,-       0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]--    revocationBasepoint = RevocationBasepoint $ Point $ BS.pack-      [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,-       0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,-       0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]--    -- Secret generation test data-    seed = BS.replicate 32 0xFF--    -- Fee calculation test data-    feerate = FeeratePerKw 5000-    noAnchors = ChannelFeatures { cf_option_anchors = False }-    withAnchors = ChannelFeatures { cf_option_anchors = True }--    -- Trimming test data-    dust = DustLimit (Satoshi 546)--    htlcNotTrimmed = HTLC-      { htlc_direction = HTLCOffered-      , htlc_amount_msat = MilliSatoshi 5000000-      , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-      , htlc_cltv_expiry = CltvExpiry 500000-      }--    htlcTrimmed = HTLC-      { htlc_direction = HTLCOffered-      , htlc_amount_msat = MilliSatoshi 1000000-      , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-      , htlc_cltv_expiry = CltvExpiry 500000-      }--    -- Sample pubkeys-    samplePubkey1, samplePubkey2, samplePubkey3 :: Pubkey-    samplePubkey1 = Pubkey $ BS.pack-      [0x03, 0x6d, 0x6c, 0xaa, 0xc2, 0x48, 0xaf, 0x96, 0xf6, 0xaf, 0xa7,-       0xf9, 0x04, 0xf5, 0x50, 0x25, 0x3a, 0x0f, 0x3e, 0xf3, 0xf5, 0xaa,-       0x2f, 0xe6, 0x83, 0x8a, 0x95, 0xb2, 0x16, 0x69, 0x14, 0x68, 0xe2]-    samplePubkey2 = Pubkey $ BS.pack-      [0x02, 0x5f, 0x71, 0x17, 0xa7, 0x81, 0x50, 0xfe, 0x2e, 0xf9, 0x7d,-       0xb7, 0xcf, 0xc8, 0x3b, 0xd5, 0x7b, 0x2e, 0x2c, 0x0d, 0x0d, 0xd2,-       0x5e, 0xaf, 0x46, 0x7a, 0x4a, 0x1c, 0x2a, 0x45, 0xce, 0x14, 0x86]-    samplePubkey3 = samplePubkey1--    -- Funding outpoint-    sampleFundingOutpoint :: Outpoint-    sampleFundingOutpoint = Outpoint (TxId $ BS.replicate 32 0x01) 0--    -- HTLC builder-    mkHtlc :: HTLCDirection -> Word64 -> Word32 -> HTLC-    mkHtlc dir amtMsat expiry = HTLC-      { htlc_direction = dir-      , htlc_amount_msat = MilliSatoshi amtMsat-      , htlc_payment_hash = PaymentHash (BS.replicate 32 0x00)-      , htlc_cltv_expiry = CltvExpiry expiry-      }--    htlcs0, htlcs10, htlcs100 :: [HTLC]-    htlcs0 = []-    htlcs10 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)-                      (5000000 + i * 100000) (500000 + fromIntegral i)-              | i <- [0..9]]-    htlcs100 = [mkHtlc (if even i then HTLCOffered else HTLCReceived)-                       (5000000 + i * 10000) (500000 + fromIntegral i)-               | i <- [0..99]]--    -- CommitmentKeys-    sampleCommitmentKeys :: CommitmentKeys-    sampleCommitmentKeys = CommitmentKeys-      { ck_revocation_pubkey = RevocationPubkey samplePubkey1-      , ck_local_delayed = LocalDelayedPubkey samplePubkey1-      , ck_local_htlc = LocalHtlcPubkey samplePubkey1-      , ck_remote_htlc = RemoteHtlcPubkey samplePubkey2-      , ck_local_payment = LocalPubkey samplePubkey1-      , ck_remote_payment = RemotePubkey samplePubkey2-      , ck_local_funding = FundingPubkey samplePubkey1-      , ck_remote_funding = FundingPubkey samplePubkey2-      }--    -- CommitmentContext builder-    mkCommitmentContext :: [HTLC] -> ChannelFeatures -> CommitmentContext-    mkCommitmentContext htlcs features = CommitmentContext-      { cc_funding_outpoint = sampleFundingOutpoint-      , cc_commitment_number = CommitmentNumber 42-      , cc_local_payment_bp = PaymentBasepoint $-          Point $ unPubkey samplePubkey1-      , cc_remote_payment_bp = PaymentBasepoint $-          Point $ unPubkey samplePubkey2-      , cc_to_self_delay = ToSelfDelay 144-      , cc_dust_limit = DustLimit (Satoshi 546)-      , cc_feerate = FeeratePerKw 5000-      , cc_features = features-      , cc_is_funder = True-      , cc_to_local_msat = MilliSatoshi 500000000-      , cc_to_remote_msat = MilliSatoshi 500000000-      , cc_htlcs = htlcs-      , cc_keys = sampleCommitmentKeys-      }--    -- HTLC context-    sampleHtlcContext :: HTLCContext-    sampleHtlcContext = HTLCContext-      { hc_commitment_txid = TxId $ BS.replicate 32 0x01-      , hc_output_index = 0-      , hc_htlc = mkHtlc HTLCOffered 5000000 500000-      , hc_to_self_delay = ToSelfDelay 144-      , hc_feerate = FeeratePerKw 5000-      , hc_features = noAnchors-      , hc_revocation_pubkey = RevocationPubkey samplePubkey1-      , hc_local_delayed = LocalDelayedPubkey samplePubkey1-      }--    -- Closing context-    sampleClosingContext :: ClosingContext-    sampleClosingContext = ClosingContext-      { clc_funding_outpoint = sampleFundingOutpoint-      , clc_local_amount = Satoshi 500000-      , clc_remote_amount = Satoshi 500000-      , clc_local_script = Script $-          BS.pack [0x00, 0x14] <> BS.replicate 20 0x01-      , clc_remote_script = Script $-          BS.pack [0x00, 0x14] <> BS.replicate 20 0x02-      , clc_local_dust_limit = DustLimit (Satoshi 546)-      , clc_remote_dust_limit = DustLimit (Satoshi 546)-      , clc_fee = Satoshi 1000-      , clc_is_funder = True-      , clc_locktime = Locktime 0-      , clc_funding_script = funding_script (FundingPubkey samplePubkey1)-                                            (FundingPubkey samplePubkey2)-      }--    -- Secret storage for benchmarks-    filledStore :: SecretStore-    filledStore = foldl insertOne empty_store [0..99]-      where-        insertOne store i =-          let idx = 281474976710655 - i-              sec = BS.replicate 32 (fromIntegral i)-          in case insert_secret sec idx store of-               Just s -> s-               Nothing -> store+main = do+  fx <- fixtures+  let (next_idx, next_secret) = fx_store_next fx+  mainWith $ do+    wgroup "keys" $ do+      func "derive_per_commitment_point" derive_per_commitment_point+        (fx_secret fx)+      func "derive_per_commitment_point'" (derive_per_commitment_point' tex)+        (fx_secret fx)+      func "derive_pubkey" (derive_pubkey (fx_basepoint fx)) (fx_pcp fx)+      func "derive_revocationpubkey" (derive_revocationpubkey (fx_rbp fx))+        (fx_pcp fx)+      func "derive_commitment_keys"+        (derive_commitment_keys (fx_local_bps fx) (fx_local_fund fx)+           (fx_remote_bps fx) (fx_remote_fund fx))+        (fx_pcp fx)+      func "derive_commitment_keys'"+        (derive_commitment_keys' tex (fx_local_bps fx) (fx_local_fund fx)+           (fx_remote_bps fx) (fx_remote_fund fx))+        (fx_pcp fx)+      func "derive_privkey" (derive_privkey (fx_seckey fx)) (fx_pcp fx)+      func "derive_revocationprivkey"+        (derive_revocationprivkey (fx_seckey fx)) (fx_secret fx)+    wgroup "secrets" $ do+      func "generate_from_seed (index 2^48 - 1)"+        (generate_from_seed (fx_seed fx)) (fx_store_oldest fx)+      func "insert_secret (14 lower buckets)"+        (insert_secret next_secret next_idx) (fx_store fx)+      func "derive_old_secret (index 2^48 - 1)"+        (derive_old_secret (fx_store_oldest fx)) (fx_store fx)+      func "secret_store . un_secret_store"+        (secret_store . un_secret_store) (fx_store fx)+    wgroup "transactions" $ do+      func "build_commitment_tx (no htlcs)" build_commitment_tx+        (fx_ctx_simple fx)+      func "build_commitment_tx (5 htlcs)" build_commitment_tx+        (fx_ctx_htlcs fx)+      func "build_commitment_tx (5 htlcs, anchors)" build_commitment_tx+        (fx_ctx_anchors fx)+      func "encode_commitment_tx (5 htlcs)" encode_commitment_tx+        (fx_commit fx)+      func "build_htlc_tx" build_htlc_tx (fx_htlc_ctx fx)+      func "encode_htlc_tx" encode_htlc_tx (fx_htlc_tx fx)+      func "build_closing_tx" build_closing_tx (fx_closing fx)+      func "build_legacy_closing_tx" build_legacy_closing_tx (fx_legacy fx)+      func "encode_closing_tx" encode_closing_tx (fx_closing_tx fx)

@@ -6,160 +6,135 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Bitcoin transaction formats for the Lightning Network, per--- [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md).------ = Overview------ This library implements the transaction and script formats defined in--- BOLT #3, including:------ * Commitment transactions with to_local, to_remote, anchor, and HTLC---   outputs--- * HTLC-timeout and HTLC-success second-stage transactions--- * Closing transactions (legacy and option_simple_close)--- * Per-commitment key derivation and secret storage--- * Transaction serialization and parsing--- * Stateless validation------ = Quick Start------ @--- import Lightning.Protocol.BOLT3------ -- Build a commitment transaction--- let ctx = CommitmentContext { ... }---     tx = build_commitment_tx ctx------ -- Serialize for signing--- let bytes = encode_tx tx------ -- Validate the transaction--- case validate_commitment_tx dustLimit features tx of---   Right () -> putStrLn "Valid"---   Left err -> print err--- @------ = Modules+-- Bitcoin transaction and script formats for the Lightning Network, per+-- [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md)+-- (commitment, HTLC and closing transactions, their output scripts and+-- witnesses, per-commitment key derivation, and per-commitment secret+-- generation and storage). ----- * "Lightning.Protocol.BOLT3.Types" - Core types (Satoshi, Pubkey, HTLC,---   etc.)--- * "Lightning.Protocol.BOLT3.Keys" - Per-commitment key derivation and---   secret storage--- * "Lightning.Protocol.BOLT3.Scripts" - Witness script templates (funding,---   to_local, HTLC, anchor)--- * "Lightning.Protocol.BOLT3.Tx" - Transaction assembly--- * "Lightning.Protocol.BOLT3.Encode" - Transaction serialization--- * "Lightning.Protocol.BOLT3.Decode" - Transaction parsing--- * "Lightning.Protocol.BOLT3.Validate" - Stateless validation+-- Amounts, points, hashes and per-commitment secrets are the types of+-- ppad-bolt1's "Lightning.Protocol.BOLT1"; transactions convert to+-- ppad-tx's "Bitcoin.Prim.Tx" for txids, sighashes and serialization.+-- The @option_static_remotekey@ and @option_anchors@ commitment formats+-- are supported ('CommitmentFormat').  module Lightning.Protocol.BOLT3 (-    -- * Types-    -- ** Monetary amounts-    Satoshi(..)-  , MilliSatoshi(..)-  , msat_to_sat-  , sat_to_msat--    -- ** Keys and points-  , Pubkey(..)-  , pubkey-  , Seckey(..)-  , seckey-  , Point(..)-  , point--    -- ** Hashes-  , PaymentHash(..)-  , payment_hash-  , PaymentPreimage(..)-  , payment_preimage+    -- * Commitment transactions+    CommitmentContext(..)+  , CommitmentFormat(..)+  , CommitmentTx(..)+  , CommitmentOutput(..)+  , OutputType(..)+  , build_commitment_tx -    -- ** Transaction primitives-  , TxId(..)-  , txid-  , Outpoint(..)-  , Sequence(..)-  , Locktime(..)+    -- ** HTLCs+  , HTLC(..)+  , HTLCDirection(..)      -- ** Channel parameters-  , CommitmentNumber(..)+  , CommitmentNumber   , commitment_number+  , un_commitment_number+  , next_commitment_number   , ToSelfDelay(..)   , CltvExpiry(..)   , DustLimit(..)   , FeeratePerKw(..)+  , Locktime(..)+  , Sequence(..) -    -- ** HTLC types-  , HTLC(..)-  , HTLCDirection(..)+    -- ** Fees and trimming+  , commitment_fee+  , htlc_timeout_fee+  , htlc_success_fee+  , htlc_trim_threshold+  , is_trimmed+  , anchor_output_value -    -- ** Basepoints+    -- * HTLC transactions+  , HTLCContext(..)+  , HTLCTx(..)+  , build_htlc_tx++    -- * Closing transactions+  , ClosingTx(..)+  , ClosingOutput(..)+  , ClosingContext(..)+  , ClosingOutputs(..)+  , build_closing_tx+  , LegacyClosingContext(..)+  , build_legacy_closing_tx++    -- ** Dust thresholds+  , dust_p2pkh+  , dust_p2sh+  , dust_p2wpkh+  , dust_p2wsh++    -- * Serialization+  , commitment_to_tx+  , htlc_to_tx+  , closing_to_tx+  , encode_commitment_tx+  , encode_htlc_tx+  , encode_closing_tx++    -- * Keys+    -- ** Basepoints and per-commitment points   , Basepoints(..)-  , PerCommitmentPoint(..)-  , PerCommitmentSecret(..)-  , per_commitment_secret   , RevocationBasepoint(..)   , PaymentBasepoint(..)   , DelayedPaymentBasepoint(..)   , HtlcBasepoint(..)+  , PerCommitmentPoint(..)+  , derive_per_commitment_point+  , derive_per_commitment_point' -    -- ** Derived keys-  , LocalPubkey(..)-  , RemotePubkey(..)+    -- ** Public keys+  , CommitmentKeys(..)+  , derive_commitment_keys+  , derive_commitment_keys'+  , RevocationPubkey(..)   , LocalDelayedPubkey(..)-  , RemoteDelayedPubkey(..)   , LocalHtlcPubkey(..)   , RemoteHtlcPubkey(..)-  , RevocationPubkey(..)+  , RemotePubkey(..)   , FundingPubkey(..)--    -- ** Script and witness-  , Script(..)-  , Witness(..)--    -- ** Channel features-  , ChannelFeatures(..)-  , has_anchors--    -- ** Constants-  , commitment_weight_no_anchors-  , commitment_weight_anchors-  , htlc_timeout_weight_no_anchors-  , htlc_timeout_weight_anchors-  , htlc_success_weight_no_anchors-  , htlc_success_weight_anchors-  , htlc_output_weight-  , dust_p2pkh-  , dust_p2sh-  , dust_p2wpkh-  , dust_p2wsh-  , anchor_output_value--    -- * Key derivation-  , derive_per_commitment_point   , derive_pubkey-  , derive_localpubkey-  , derive_local_htlcpubkey-  , derive_remote_htlcpubkey-  , derive_local_delayedpubkey-  , derive_remote_delayedpubkey   , derive_revocationpubkey -    -- ** Secret generation+    -- ** Private keys+  , Seckey+  , seckey+  , un_seckey+  , derive_privkey+  , derive_revocationprivkey++    -- * Per-commitment secrets+  , Seed+  , seed+  , un_seed+  , SecretIndex+  , secret_index+  , un_secret_index+  , commitment_secret_index   , generate_from_seed-  , derive_secret -    -- ** Secret storage+    -- ** Storage   , SecretStore-  , empty_store+  , empty_secret_store   , insert_secret   , derive_old_secret+  , secret_store+  , un_secret_store -    -- ** Commitment number+    -- ** Commitment number obscuring   , obscured_commitment_number -    -- * Scripts+    -- * Scripts and witnesses+  , Script(..)+  , to_p2wsh+     -- ** Funding output   , funding_script   , funding_witness@@ -170,7 +145,8 @@   , to_local_witness_revoke      -- ** to_remote output-  , to_remote_script+  , to_remote_witness_script+  , to_remote_script_pubkey   , to_remote_witness      -- ** Anchor outputs@@ -178,110 +154,23 @@   , anchor_witness_owner   , anchor_witness_anyone -    -- ** Offered HTLC+    -- ** Offered HTLC outputs   , offered_htlc_script   , offered_htlc_witness_preimage   , offered_htlc_witness_revoke -    -- ** Received HTLC+    -- ** Received HTLC outputs   , received_htlc_script   , received_htlc_witness_timeout   , received_htlc_witness_revoke -    -- ** HTLC output (same as to_local)-  , htlc_output_script-  , htlc_output_witness_spend-  , htlc_output_witness_revoke--    -- ** P2WSH helpers-  , to_p2wsh-  , witness_script_hash--    -- * Transaction assembly-    -- ** Commitment transactions-  , CommitmentTx(..)-  , CommitmentContext(..)-  , CommitmentKeys(..)-  , build_commitment_tx--    -- ** HTLC transactions-  , HTLCTx(..)-  , HTLCContext(..)-  , build_htlc_timeout_tx-  , build_htlc_success_tx--    -- ** Closing transactions-  , ClosingTx(..)-  , ClosingContext(..)-  , build_closing_tx-  , build_legacy_closing_tx--    -- ** Transaction outputs-  , TxOutput(..)-  , OutputType(..)--    -- ** Fee calculation-  , commitment_fee-  , commitment_weight-  , htlc_timeout_fee-  , htlc_success_fee--    -- ** Trimming-  , htlc_trim_threshold-  , is_trimmed-  , trimmed_htlcs-  , untrimmed_htlcs--    -- ** Output ordering-  , sort_outputs--    -- * Serialization-  , encode_tx-  , encode_htlc_tx-  , encode_closing_tx-  , encode_tx_for_signing-  , encode_varint-  , encode_le32-  , encode_le64-  , encode_outpoint-  , encode_output-  , encode_witness-  , encode_funding_witness--    -- * Parsing-  , DecodeError(..)-  , RawTx(..)-  , RawInput(..)-  , RawOutput(..)-  , decode_tx-  , decode_varint-  , decode_le32-  , decode_le64-  , decode_outpoint-  , decode_output-  , decode_witness--    -- * Validation-  , ValidationError(..)-  , validate_commitment_tx-  , validate_commitment_locktime-  , validate_commitment_sequence-  , validate_htlc_tx-  , validate_htlc_timeout_tx-  , validate_htlc_success_tx-  , validate_closing_tx-  , validate_legacy_closing_tx-  , validate_output_ordering-  , validate_dust_limits-  , validate_anchor_outputs-  , validate_commitment_fee-  , validate_htlc_fee+    -- ** HTLC transaction inputs+  , htlc_success_witness+  , htlc_timeout_witness+  , remote_htlc_sighash   ) where -import Lightning.Protocol.BOLT3.Types import Lightning.Protocol.BOLT3.Keys import Lightning.Protocol.BOLT3.Scripts import Lightning.Protocol.BOLT3.Tx-import Lightning.Protocol.BOLT3.Encode-import Lightning.Protocol.BOLT3.Decode-import Lightning.Protocol.BOLT3.Validate+import Lightning.Protocol.BOLT3.Types

@@ -1,389 +0,0 @@-{-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}---- |--- Module: Lightning.Protocol.BOLT3.Decode--- Copyright: (c) 2025 Jared Tobin--- License: MIT--- Maintainer: Jared Tobin <jared@ppad.tech>------ Parsing for BOLT #3 transactions and scripts.------ Decodes SegWit Bitcoin transactions from raw bytes.--module Lightning.Protocol.BOLT3.Decode (-    -- * Error types-    DecodeError(..)--    -- * Raw transaction type-  , RawTx(..)-  , RawInput(..)-  , RawOutput(..)--    -- * Transaction parsing-  , decode_tx--    -- * Witness parsing-  , decode_witness--    -- * Primitive decoding-  , decode_varint-  , decode_le32-  , decode_le64-  , decode_outpoint-  , decode_output-  ) where--import Data.Bits ((.|.), shiftL)-import Data.Word (Word8, Word32, Word64)-import qualified Data.ByteString as BS-import GHC.Generics (Generic)-import Lightning.Protocol.BOLT3.Types---- error types --------------------------------------------------------------------- | Errors that can occur during transaction decoding.-data DecodeError-  = InsufficientBytes !Int !Int-    -- ^ Expected bytes, actual bytes available-  | InvalidMarker !Word8-    -- ^ Invalid SegWit marker byte (expected 0x00)-  | InvalidFlag !Word8-    -- ^ Invalid SegWit flag byte (expected 0x01)-  | InvalidVarint-    -- ^ Malformed varint encoding-  | EmptyInput-    -- ^ No bytes to decode-  deriving (Eq, Show, Generic)---- raw transaction types ----------------------------------------------------------- | A raw transaction input as parsed from bytes.-data RawInput = RawInput-  { ri_outpoint   :: !Outpoint-  , ri_script_sig :: !BS.ByteString-  , ri_sequence   :: !Sequence-  } deriving (Eq, Show, Generic)---- | A raw transaction output as parsed from bytes.-data RawOutput = RawOutput-  { ro_value  :: !Satoshi-  , ro_script :: !Script-  } deriving (Eq, Show, Generic)---- | A raw transaction as parsed from bytes.------ Supports both legacy and SegWit transaction formats.-data RawTx = RawTx-  { rtx_version  :: {-# UNPACK #-} !Word32-  , rtx_inputs   :: ![RawInput]-  , rtx_outputs  :: ![RawOutput]-  , rtx_witness  :: ![[BS.ByteString]]-    -- ^ Witness stack for each input (empty list for legacy tx)-  , rtx_locktime :: !Locktime-  } deriving (Eq, Show, Generic)---- primitive decoding -------------------------------------------------------------- | Decode a little-endian 32-bit integer.------ >>> decode_le32 (BS.pack [0x01, 0x00, 0x00, 0x00])--- Right (1, "")-decode_le32 :: BS.ByteString -> Either DecodeError (Word32, BS.ByteString)-decode_le32 !bs-  | BS.length bs < 4 = Left (InsufficientBytes 4 (BS.length bs))-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0)-          !b1 = fromIntegral (BS.index bs 1)-          !b2 = fromIntegral (BS.index bs 2)-          !b3 = fromIntegral (BS.index bs 3)-          !val = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16)-                     .|. (b3 `shiftL` 24)-          !rest = BS.drop 4 bs-      in Right (val, rest)-{-# INLINE decode_le32 #-}---- | Decode a little-endian 64-bit integer.------ >>> decode_le64 (BS.pack [0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])--- Right (1, "")-decode_le64 :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)-decode_le64 !bs-  | BS.length bs < 8 = Left (InsufficientBytes 8 (BS.length bs))-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0)-          !b1 = fromIntegral (BS.index bs 1)-          !b2 = fromIntegral (BS.index bs 2)-          !b3 = fromIntegral (BS.index bs 3)-          !b4 = fromIntegral (BS.index bs 4)-          !b5 = fromIntegral (BS.index bs 5)-          !b6 = fromIntegral (BS.index bs 6)-          !b7 = fromIntegral (BS.index bs 7)-          !val = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16)-                    .|. (b3 `shiftL` 24) .|. (b4 `shiftL` 32)-                    .|. (b5 `shiftL` 40) .|. (b6 `shiftL` 48)-                    .|. (b7 `shiftL` 56)-          !rest = BS.drop 8 bs-      in Right (val, rest)-{-# INLINE decode_le64 #-}---- | Decode a Bitcoin varint (CompactSize).------ Encoding:--- * 0x00-0xFC: 1 byte--- * 0xFD: 2 bytes little-endian follow--- * 0xFE: 4 bytes little-endian follow--- * 0xFF: 8 bytes little-endian follow------ >>> decode_varint (BS.pack [0x01])--- Right (1, "")--- >>> decode_varint (BS.pack [0xfd, 0x00, 0x01])--- Right (256, "")-decode_varint :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)-decode_varint !bs-  | BS.null bs = Left EmptyInput-  | otherwise =-      let !first = BS.index bs 0-          !rest = BS.drop 1 bs-      in case first of-           0xFD -> decode_varint_16 rest-           0xFE -> decode_varint_32 rest-           0xFF -> decode_le64 rest-           _    -> Right (fromIntegral first, rest)-{-# INLINE decode_varint #-}---- | Decode a 16-bit varint payload.-decode_varint_16 :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)-decode_varint_16 !bs-  | BS.length bs < 2 = Left (InsufficientBytes 2 (BS.length bs))-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0) :: Word64-          !b1 = fromIntegral (BS.index bs 1) :: Word64-          !val = b0 .|. (b1 `shiftL` 8)-          !rest = BS.drop 2 bs-      in Right (val, rest)-{-# INLINE decode_varint_16 #-}---- | Decode a 32-bit varint payload.-decode_varint_32 :: BS.ByteString -> Either DecodeError (Word64, BS.ByteString)-decode_varint_32 !bs-  | BS.length bs < 4 = Left (InsufficientBytes 4 (BS.length bs))-  | otherwise =-      let !b0 = fromIntegral (BS.index bs 0) :: Word64-          !b1 = fromIntegral (BS.index bs 1) :: Word64-          !b2 = fromIntegral (BS.index bs 2) :: Word64-          !b3 = fromIntegral (BS.index bs 3) :: Word64-          !val = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16)-                    .|. (b3 `shiftL` 24)-          !rest = BS.drop 4 bs-      in Right (val, rest)-{-# INLINE decode_varint_32 #-}---- | Decode a transaction outpoint (txid + output index).------ Format: 32 bytes txid (little-endian) + 4 bytes index (little-endian)------ >>> let txid = BS.replicate 32 0--- >>> let idx = BS.pack [0x01, 0x00, 0x00, 0x00]--- >>> decode_outpoint (txid <> idx)--- Right (Outpoint {outpoint_txid = ..., outpoint_index = 1}, "")-decode_outpoint-  :: BS.ByteString-  -> Either DecodeError (Outpoint, BS.ByteString)-decode_outpoint !bs-  | BS.length bs < 36 = Left (InsufficientBytes 36 (BS.length bs))-  | otherwise =-      let !txid = TxId (BS.take 32 bs)-          !rest1 = BS.drop 32 bs-      in case decode_le32 rest1 of-           Left err -> Left err-           Right (!idx, !rest2) ->-             let !outpoint = Outpoint txid idx-             in Right (outpoint, rest2)-{-# INLINE decode_outpoint #-}---- | Decode a transaction output (value + scriptPubKey).------ Format: 8 bytes value (little-endian) + varint script length + script-decode_output :: BS.ByteString -> Either DecodeError (RawOutput, BS.ByteString)-decode_output !bs = do-  (!value, !rest1) <- decode_le64 bs-  (!scriptLen, !rest2) <- decode_varint rest1-  let !len = fromIntegral scriptLen-  if BS.length rest2 < len-    then Left (InsufficientBytes len (BS.length rest2))-    else-      let !script = Script (BS.take len rest2)-          !rest3 = BS.drop len rest2-          !output = RawOutput (Satoshi value) script-      in Right (output, rest3)-{-# INLINE decode_output #-}---- witness parsing ----------------------------------------------------------------- | Decode a witness stack for one input.------ Format: varint num_items + (varint length + data) for each item-decode_witness-  :: BS.ByteString-  -> Either DecodeError (Witness, BS.ByteString)-decode_witness !bs = do-  (!numItems, !rest1) <- decode_varint bs-  (!items, !rest2) <- decode_witness_items (fromIntegral numItems) rest1 []-  Right (Witness items, rest2)-{-# INLINE decode_witness #-}---- | Decode witness items recursively.-decode_witness_items-  :: Int-  -> BS.ByteString-  -> [BS.ByteString]-  -> Either DecodeError ([BS.ByteString], BS.ByteString)-decode_witness_items 0 !bs !acc = Right (reverse acc, bs)-decode_witness_items !n !bs !acc = do-  (!itemLen, !rest1) <- decode_varint bs-  let !len = fromIntegral itemLen-  if BS.length rest1 < len-    then Left (InsufficientBytes len (BS.length rest1))-    else-      let !item = BS.take len rest1-          !rest2 = BS.drop len rest1-      in decode_witness_items (n - 1) rest2 (item : acc)---- | Decode witness stacks for all inputs (internal, returns list).-decode_witness_stacks-  :: Int-  -> BS.ByteString-  -> [[BS.ByteString]]-  -> Either DecodeError ([[BS.ByteString]], BS.ByteString)-decode_witness_stacks 0 !bs !acc = Right (reverse acc, bs)-decode_witness_stacks !n !bs !acc = do-  (Witness !items, !rest) <- decode_witness bs-  decode_witness_stacks (n - 1) rest (items : acc)---- transaction parsing ------------------------------------------------------------- | Decode a raw Bitcoin transaction from bytes.------ Handles both legacy and SegWit transaction formats.------ SegWit format:--- * version (4 bytes LE)--- * marker (0x00) + flag (0x01)--- * input count (varint)--- * inputs: outpoint (32+4), scriptSig length (varint), scriptSig, sequence--- * output count (varint)--- * outputs: value (8 LE), scriptPubKey length (varint), scriptPubKey--- * witness data (for each input)--- * locktime (4 bytes LE)------ >>> decode_tx rawTxBytes--- Right (RawTx {...})-decode_tx :: BS.ByteString -> Either DecodeError RawTx-decode_tx !bs = do-  -- Version (4 bytes LE)-  (!version, !rest1) <- decode_le32 bs--  -- Check for SegWit marker/flag-  let !hasWitness = BS.length rest1 >= 2 &&-                    BS.index rest1 0 == 0x00 &&-                    BS.index rest1 1 == 0x01--  if hasWitness-    then decode_tx_segwit version (BS.drop 2 rest1)-    else decode_tx_legacy version rest1-{-# INLINE decode_tx #-}---- | Decode a SegWit transaction (after marker/flag consumed).-decode_tx_segwit-  :: Word32-  -> BS.ByteString-  -> Either DecodeError RawTx-decode_tx_segwit !version !bs = do-  -- Input count and inputs-  (!inputCount, !rest1) <- decode_varint bs-  (!inputs, !rest2) <- decode_inputs (fromIntegral inputCount) rest1 []--  -- Output count and outputs-  (!outputCount, !rest3) <- decode_varint rest2-  (!outputs, !rest4) <- decode_outputs (fromIntegral outputCount) rest3 []--  -- Witness data for each input-  (!witnesses, !rest5) <- decode_witness_stacks (length inputs) rest4 []--  -- Locktime (4 bytes LE)-  (!locktime, !_rest6) <- decode_le32 rest5--  Right RawTx-    { rtx_version  = version-    , rtx_inputs   = inputs-    , rtx_outputs  = outputs-    , rtx_witness  = witnesses-    , rtx_locktime = Locktime locktime-    }---- | Decode a legacy (non-SegWit) transaction.-decode_tx_legacy-  :: Word32-  -> BS.ByteString-  -> Either DecodeError RawTx-decode_tx_legacy !version !bs = do-  -- Input count and inputs-  (!inputCount, !rest1) <- decode_varint bs-  (!inputs, !rest2) <- decode_inputs (fromIntegral inputCount) rest1 []--  -- Output count and outputs-  (!outputCount, !rest3) <- decode_varint rest2-  (!outputs, !rest4) <- decode_outputs (fromIntegral outputCount) rest3 []--  -- Locktime (4 bytes LE)-  (!locktime, !_rest5) <- decode_le32 rest4--  Right RawTx-    { rtx_version  = version-    , rtx_inputs   = inputs-    , rtx_outputs  = outputs-    , rtx_witness  = []-    , rtx_locktime = Locktime locktime-    }---- | Decode transaction inputs recursively.-decode_inputs-  :: Int-  -> BS.ByteString-  -> [RawInput]-  -> Either DecodeError ([RawInput], BS.ByteString)-decode_inputs 0 !bs !acc = Right (reverse acc, bs)-decode_inputs !n !bs !acc = do-  (!input, !rest) <- decode_input bs-  decode_inputs (n - 1) rest (input : acc)---- | Decode a single transaction input.------ Format: outpoint (36 bytes) + scriptSig length (varint) + scriptSig +---         sequence (4 bytes LE)-decode_input :: BS.ByteString -> Either DecodeError (RawInput, BS.ByteString)-decode_input !bs = do-  (!outpoint, !rest1) <- decode_outpoint bs-  (!scriptLen, !rest2) <- decode_varint rest1-  let !len = fromIntegral scriptLen-  if BS.length rest2 < len-    then Left (InsufficientBytes len (BS.length rest2))-    else do-      let !scriptSig = BS.take len rest2-          !rest3 = BS.drop len rest2-      (!seqNum, !rest4) <- decode_le32 rest3-      let !input = RawInput outpoint scriptSig (Sequence seqNum)-      Right (input, rest4)---- | Decode transaction outputs recursively.-decode_outputs-  :: Int-  -> BS.ByteString-  -> [RawOutput]-  -> Either DecodeError ([RawOutput], BS.ByteString)-decode_outputs 0 !bs !acc = Right (reverse acc, bs)-decode_outputs !n !bs !acc = do-  (!output, !rest) <- decode_output bs-  decode_outputs (n - 1) rest (output : acc)

@@ -1,298 +0,0 @@-{-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE BangPatterns #-}---- |--- Module: Lightning.Protocol.BOLT3.Encode--- Copyright: (c) 2025 Jared Tobin--- License: MIT--- Maintainer: Jared Tobin <jared@ppad.tech>------ Serialization for BOLT #3 transactions and scripts.------ Provides Bitcoin transaction serialization in both standard SegWit--- format (with witness data) and the stripped format used for signing.------ == Transaction Format (SegWit)------ * version (4 bytes LE)--- * marker (0x00) + flag (0x01)--- * input count (varint)--- * inputs: outpoint (32+4), scriptSig length (varint), scriptSig, sequence--- * output count (varint)--- * outputs: value (8 LE), scriptPubKey length (varint), scriptPubKey--- * witness data (for each input)--- * locktime (4 bytes LE)--module Lightning.Protocol.BOLT3.Encode (-    -- * Transaction serialization-    encode_tx-  , encode_htlc_tx-  , encode_closing_tx-  , encode_tx_for_signing--    -- * Witness serialization-  , encode_witness-  , encode_funding_witness--    -- * Primitive encoding-  , encode_varint-  , encode_le32-  , encode_le64-  , encode_outpoint-  , encode_output-  ) where--import Data.Word (Word32, Word64)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as BSB-import qualified Data.ByteString.Lazy as BSL-import Lightning.Protocol.BOLT3.Types-import Lightning.Protocol.BOLT3.Tx---- primitive encoding -------------------------------------------------------------- | Encode a 32-bit value in little-endian format.------ >>> encode_le32 0x12345678--- "\x78\x56\x34\x12"-encode_le32 :: Word32 -> BS.ByteString-encode_le32 = BSL.toStrict . BSB.toLazyByteString . BSB.word32LE-{-# INLINE encode_le32 #-}---- | Encode a 64-bit value in little-endian format.------ >>> encode_le64 0x123456789ABCDEF0--- "\xF0\xDE\xBC\x9A\x78\x56\x34\x12"-encode_le64 :: Word64 -> BS.ByteString-encode_le64 = BSL.toStrict . BSB.toLazyByteString . BSB.word64LE-{-# INLINE encode_le64 #-}---- | Encode a value as a Bitcoin varint (CompactSize).------ Encoding scheme:------ * 0-252: 1 byte--- * 253-65535: 0xFD followed by 2 bytes LE--- * 65536-4294967295: 0xFE followed by 4 bytes LE--- * larger: 0xFF followed by 8 bytes LE------ >>> encode_varint 100--- "\x64"--- >>> encode_varint 1000--- "\xFD\xE8\x03"-encode_varint :: Word64 -> BS.ByteString-encode_varint !n-  | n < 0xFD = BS.singleton (fromIntegral n)-  | n <= 0xFFFF = BSL.toStrict $ BSB.toLazyByteString $-      BSB.word8 0xFD <> BSB.word16LE (fromIntegral n)-  | n <= 0xFFFFFFFF = BSL.toStrict $ BSB.toLazyByteString $-      BSB.word8 0xFE <> BSB.word32LE (fromIntegral n)-  | otherwise = BSL.toStrict $ BSB.toLazyByteString $-      BSB.word8 0xFF <> BSB.word64LE n-{-# INLINE encode_varint #-}---- | Encode an outpoint (txid + output index).------ Format: 32 bytes txid (already LE in TxId) + 4 bytes output index LE------ >>> encode_outpoint (Outpoint txid 0)--- <32-byte txid><4-byte index>-encode_outpoint :: Outpoint -> BS.ByteString-encode_outpoint !op = BSL.toStrict $ BSB.toLazyByteString $-  BSB.byteString (unTxId $ outpoint_txid op) <>-  BSB.word32LE (outpoint_index op)-{-# INLINE encode_outpoint #-}---- | Encode a transaction output.------ Format: 8 bytes value LE + varint scriptPubKey length + scriptPubKey------ >>> encode_output (TxOutput (Satoshi 100000) script OutputToLocal)--- <8-byte value><varint length><scriptPubKey>-encode_output :: TxOutput -> BS.ByteString-encode_output !out = BSL.toStrict $ BSB.toLazyByteString $-  let !script = unScript (txout_script out)-      !scriptLen = fromIntegral (BS.length script) :: Word64-  in BSB.word64LE (unSatoshi $ txout_value out) <>-     varint_builder scriptLen <>-     BSB.byteString script-{-# INLINE encode_output #-}---- witness encoding ---------------------------------------------------------------- | Encode a witness stack.------ Format: varint item count + (varint length + data) for each item------ >>> encode_witness (Witness [sig, pubkey])--- <varint 2><varint sigLen><sig><varint pkLen><pubkey>-encode_witness :: Witness -> BS.ByteString-encode_witness (Witness !items) = BSL.toStrict $ BSB.toLazyByteString $-  let !count = fromIntegral (length items) :: Word64-  in varint_builder count <> mconcat (map encode_witness_item items)-{-# INLINE encode_witness #-}---- | Encode a single witness stack item.-encode_witness_item :: BS.ByteString -> BSB.Builder-encode_witness_item !bs =-  let !len = fromIntegral (BS.length bs) :: Word64-  in varint_builder len <> BSB.byteString bs-{-# INLINE encode_witness_item #-}---- | Encode a funding witness (2-of-2 multisig).------ The witness stack is: @0 <sig1> <sig2> <witnessScript>@------ Signatures must be ordered to match pubkey order in the funding script.------ >>> encode_funding_witness sig1 sig2 fundingScript--- <witness with 4 items: empty, sig1, sig2, script>-encode_funding_witness-  :: BS.ByteString  -- ^ Signature for pubkey1 (lexicographically lesser)-  -> BS.ByteString  -- ^ Signature for pubkey2 (lexicographically greater)-  -> Script         -- ^ The funding witness script-  -> BS.ByteString-encode_funding_witness !sig1 !sig2 (Script !witnessScript) =-  BSL.toStrict $ BSB.toLazyByteString $-    varint_builder 4 <>-    encode_witness_item BS.empty <>-    encode_witness_item sig1 <>-    encode_witness_item sig2 <>-    encode_witness_item witnessScript-{-# INLINE encode_funding_witness #-}---- transaction encoding ------------------------------------------------------------ | Encode a commitment transaction (SegWit format with witness).------ SegWit format:------ * version (4 bytes LE)--- * marker (0x00)--- * flag (0x01)--- * input count (varint)--- * inputs--- * output count (varint)--- * outputs--- * witness data--- * locktime (4 bytes LE)------ Note: The witness is empty (just count=0) since the commitment tx--- spending the funding output requires external signatures.-encode_tx :: CommitmentTx -> BS.ByteString-encode_tx !tx = BSL.toStrict $ BSB.toLazyByteString $-  -- Version-  BSB.word32LE (ctx_version tx) <>-  -- SegWit marker and flag-  BSB.word8 0x00 <>-  BSB.word8 0x01 <>-  -- Input count (always 1 for commitment tx)-  varint_builder 1 <>-  -- Input: outpoint + empty scriptSig + sequence-  BSB.byteString (encode_outpoint (ctx_input_outpoint tx)) <>-  varint_builder 0 <>  -- scriptSig length (empty for SegWit)-  BSB.word32LE (unSequence $ ctx_input_sequence tx) <>-  -- Output count-  varint_builder (fromIntegral $ length $ ctx_outputs tx) <>-  -- Outputs-  mconcat (map (BSB.byteString . encode_output) (ctx_outputs tx)) <>-  -- Witness (empty stack for unsigned tx)-  varint_builder 0 <>-  -- Locktime-  BSB.word32LE (unLocktime $ ctx_locktime tx)---- | Encode an HTLC transaction (SegWit format with witness).------ HTLC transactions have a single input (the commitment tx HTLC output)--- and a single output (the to_local-style delayed output).-encode_htlc_tx :: HTLCTx -> BS.ByteString-encode_htlc_tx !tx = BSL.toStrict $ BSB.toLazyByteString $-  -- Version-  BSB.word32LE (htx_version tx) <>-  -- SegWit marker and flag-  BSB.word8 0x00 <>-  BSB.word8 0x01 <>-  -- Input count (always 1)-  varint_builder 1 <>-  -- Input: outpoint + empty scriptSig + sequence-  BSB.byteString (encode_outpoint (htx_input_outpoint tx)) <>-  varint_builder 0 <>  -- scriptSig length (empty for SegWit)-  BSB.word32LE (unSequence $ htx_input_sequence tx) <>-  -- Output count (always 1)-  varint_builder 1 <>-  -- Output: value + scriptPubKey-  BSB.word64LE (unSatoshi $ htx_output_value tx) <>-  let !script = unScript (htx_output_script tx)-      !scriptLen = fromIntegral (BS.length script) :: Word64-  in varint_builder scriptLen <> BSB.byteString script <>-  -- Witness (empty stack for unsigned tx)-  varint_builder 0 <>-  -- Locktime-  BSB.word32LE (unLocktime $ htx_locktime tx)---- | Encode a closing transaction (SegWit format with witness).------ Closing transactions have a single input (the funding output) and--- one or two outputs (to_local and/or to_remote).-encode_closing_tx :: ClosingTx -> BS.ByteString-encode_closing_tx !tx = BSL.toStrict $ BSB.toLazyByteString $-  -- Version-  BSB.word32LE (cltx_version tx) <>-  -- SegWit marker and flag-  BSB.word8 0x00 <>-  BSB.word8 0x01 <>-  -- Input count (always 1)-  varint_builder 1 <>-  -- Input: outpoint + empty scriptSig + sequence-  BSB.byteString (encode_outpoint (cltx_input_outpoint tx)) <>-  varint_builder 0 <>  -- scriptSig length (empty for SegWit)-  BSB.word32LE (unSequence $ cltx_input_sequence tx) <>-  -- Output count-  varint_builder (fromIntegral $ length $ cltx_outputs tx) <>-  -- Outputs-  mconcat (map (BSB.byteString . encode_output) (cltx_outputs tx)) <>-  -- Witness (empty stack for unsigned tx)-  varint_builder 0 <>-  -- Locktime-  BSB.word32LE (unLocktime $ cltx_locktime tx)---- | Encode a commitment transaction for signing (stripped format).------ The stripped format omits the SegWit marker, flag, and witness data.--- This is the format used to compute the sighash for signing.------ Format:------ * version (4 bytes LE)--- * input count (varint)--- * inputs--- * output count (varint)--- * outputs--- * locktime (4 bytes LE)-encode_tx_for_signing :: CommitmentTx -> BS.ByteString-encode_tx_for_signing !tx = BSL.toStrict $ BSB.toLazyByteString $-  -- Version-  BSB.word32LE (ctx_version tx) <>-  -- Input count (always 1 for commitment tx)-  varint_builder 1 <>-  -- Input: outpoint + empty scriptSig + sequence-  BSB.byteString (encode_outpoint (ctx_input_outpoint tx)) <>-  varint_builder 0 <>  -- scriptSig length (empty for SegWit)-  BSB.word32LE (unSequence $ ctx_input_sequence tx) <>-  -- Output count-  varint_builder (fromIntegral $ length $ ctx_outputs tx) <>-  -- Outputs-  mconcat (map (BSB.byteString . encode_output) (ctx_outputs tx)) <>-  -- Locktime-  BSB.word32LE (unLocktime $ ctx_locktime tx)---- internal helpers ---------------------------------------------------------------- | Build a varint directly to Builder.-varint_builder :: Word64 -> BSB.Builder-varint_builder !n-  | n < 0xFD = BSB.word8 (fromIntegral n)-  | n <= 0xFFFF = BSB.word8 0xFD <> BSB.word16LE (fromIntegral n)-  | n <= 0xFFFFFFFF = BSB.word8 0xFE <> BSB.word32LE (fromIntegral n)-  | otherwise = BSB.word8 0xFF <> BSB.word64LE n-{-# INLINE varint_builder #-}

@@ -1,4 +1,4 @@-{-# OPTIONS_HADDOCK prune #-}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} @@ -8,419 +8,519 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Per-commitment key derivation per BOLT #3.------ Implements key derivation formulas:------ @--- pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G--- revocationpubkey = revocation_basepoint * SHA256(revocation_basepoint---                      || per_commitment_point)---                  + per_commitment_point * SHA256(per_commitment_point---                      || revocation_basepoint)--- @+-- Key derivation, per-commitment secrets and commitment number+-- obscuring, per BOLT #3.  module Lightning.Protocol.BOLT3.Keys (-    -- * Per-commitment point derivation+    -- * Per-commitment points     derive_per_commitment_point+  , derive_per_commitment_point' -    -- * Key derivation+    -- * Public keys   , derive_pubkey-  , derive_localpubkey-  , derive_local_htlcpubkey-  , derive_remote_htlcpubkey-  , derive_local_delayedpubkey-  , derive_remote_delayedpubkey--    -- * Revocation key derivation   , derive_revocationpubkey+  , CommitmentKeys(..)+  , derive_commitment_keys+  , derive_commitment_keys' -    -- * Per-commitment secret generation-  , generate_from_seed-  , derive_secret+    -- * Private keys+  , derive_privkey+  , derive_revocationprivkey -    -- * Per-commitment secret storage+    -- * Per-commitment secrets+  , generate_from_seed   , SecretStore-  , empty_store+  , empty_secret_store   , insert_secret   , derive_old_secret+  , secret_store+  , un_secret_store      -- * Commitment number obscuring   , obscured_commitment_number   ) where -import Data.Bits ((.&.), xor, shiftL, testBit, complementBit)+import Control.DeepSeq (NFData(..))+import qualified Crypto.Curve.Secp256k1 as S+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.Choice as C+import Data.Bits ((.&.), (.|.), complement, complementBit, shiftL, shiftR,+                  testBit, xor) import qualified Data.ByteString as BS import Data.Word (Word64) import GHC.Generics (Generic)-import qualified Crypto.Curve.Secp256k1 as S-import qualified Crypto.Hash.SHA256 as SHA256+import Lightning.Protocol.BOLT1 (Point, PerCommitmentSecret)+import qualified Lightning.Protocol.BOLT1 as BOLT1 import Lightning.Protocol.BOLT3.Types+import qualified Numeric.Montgomery.Secp256k1.Scalar as SC --- Per-commitment point derivation ----------------------------------------+-- points --------------------------------------------------------------------- --- | Derive the per-commitment point from a per-commitment secret.+-- Serialize a secp256k1 point, failing on the point at infinity.+to_point :: S.Projective -> Maybe Point+to_point p+  | p == S._CURVE_ZERO = Nothing+  | otherwise          = case BOLT1.point (S.serialize_point p) of+      Just pt -> Just pt+      Nothing -> internal_error+{-# INLINE to_point #-}++-- per-commitment points ------------------------------------------------------++-- | Derive the per-commitment point from a per-commitment secret: ----- @per_commitment_point = per_commitment_secret * G@+--   @per_commitment_point = per_commitment_secret * G@ ----- >>> let secret = PerCommitmentSecret (BS.replicate 32 0x01)--- >>> derive_per_commitment_point secret--- Just (PerCommitmentPoint ...)+--   Fails if the secret is not a valid secp256k1 secret key.+--+--   >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])+--   >>> let Just (PerCommitmentPoint p) = derive_per_commitment_point s+--   >>> B16.encode (BOLT1.un_point p)+--   "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486" derive_per_commitment_point   :: PerCommitmentSecret   -> Maybe PerCommitmentPoint-derive_per_commitment_point (PerCommitmentSecret sec) = do-  sk <- S.parse_int256 sec+derive_per_commitment_point s = do+  sk <- S.parse_int256 (BOLT1.un_per_commitment_secret s)   pk <- S.derive_pub sk-  let !bs = S.serialize_point pk-  pure $! PerCommitmentPoint (Point bs)-{-# INLINE derive_per_commitment_point #-}+  PerCommitmentPoint <$> to_point pk --- Key derivation ---------------------------------------------------------+-- | As 'derive_per_commitment_point', but uses a precomputed+--   'S.Context' to speed up the scalar multiplication.+derive_per_commitment_point'+  :: S.Context+  -> PerCommitmentSecret+  -> Maybe PerCommitmentPoint+derive_per_commitment_point' tex s = do+  sk <- S.parse_int256 (BOLT1.un_per_commitment_secret s)+  pk <- S.derive_pub' tex sk+  PerCommitmentPoint <$> to_point pk --- | Derive a pubkey from a basepoint and per-commitment point.+-- public keys ----------------------------------------------------------------++-- | Derive a per-commitment public key from a basepoint: ----- @pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G@+--   @pubkey = basepoint + SHA256(per_commitment_point || basepoint) * G@ ----- This is the general derivation formula used for localpubkey,--- local_htlcpubkey, remote_htlcpubkey, local_delayedpubkey, and--- remote_delayedpubkey.+--   This gives @local_htlcpubkey@, @remote_htlcpubkey@,+--   @local_delayedpubkey@ and the like, depending on the basepoint;+--   'derive_commitment_keys' derives all of a commitment's keys at+--   once. ----- >>> derive_pubkey basepoint per_commitment_point--- Just (Pubkey ...)-derive_pubkey-  :: Point             -- ^ basepoint-  -> PerCommitmentPoint -- ^ per_commitment_point-  -> Maybe Pubkey-derive_pubkey (Point basepointBs) (PerCommitmentPoint (Point pcpBs)) = do-  basepoint <- S.parse_point basepointBs-  -- SHA256(per_commitment_point || basepoint)-  let !h = SHA256.hash (pcpBs <> basepointBs)-  -- Treat hash as scalar and multiply by G-  tweak <- S.parse_int256 h-  tweakPoint <- S.derive_pub tweak-  -- Add basepoint + tweak*G-  let !result = S.add basepoint tweakPoint-      !bs = S.serialize_point result-  pure $! Pubkey bs-{-# INLINE derive_pubkey #-}---- | Derive localpubkey from payment_basepoint and per_commitment_point.+--   Fails if the basepoint is not on the curve. ----- >>> derive_localpubkey payment_basepoint per_commitment_point--- Just (LocalPubkey ...)-derive_localpubkey-  :: PaymentBasepoint-  -> PerCommitmentPoint-  -> Maybe LocalPubkey-derive_localpubkey (PaymentBasepoint pt) pcp =-  LocalPubkey <$> derive_pubkey pt pcp-{-# INLINE derive_localpubkey #-}+--   >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])+--   >>> let Just pcp = derive_per_commitment_point s+--   >>> let Just b = BOLT1.per_commitment_secret (BS.pack [0 .. 31])+--   >>> let Just (PerCommitmentPoint bp) = derive_per_commitment_point b+--   >>> fmap (B16.encode . BOLT1.un_point) (derive_pubkey bp pcp)+--   Just "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"+derive_pubkey :: Point -> PerCommitmentPoint -> Maybe Point+derive_pubkey = derive_pubkey_with mul_g+{-# INLINE derive_pubkey #-} --- | Derive local_htlcpubkey from htlc_basepoint and per_commitment_point.------ >>> derive_local_htlcpubkey htlc_basepoint per_commitment_point--- Just (LocalHtlcPubkey ...)-derive_local_htlcpubkey-  :: HtlcBasepoint-  -> PerCommitmentPoint-  -> Maybe LocalHtlcPubkey-derive_local_htlcpubkey (HtlcBasepoint pt) pcp =-  LocalHtlcPubkey <$> derive_pubkey pt pcp-{-# INLINE derive_local_htlcpubkey #-}+-- Multiply the generator by a 32-byte scalar.+mul_g :: BS.ByteString -> Maybe S.Projective+mul_g bs = S.derive_pub =<< S.parse_int256 bs+{-# INLINE mul_g #-} --- | Derive remote_htlcpubkey from htlc_basepoint and per_commitment_point.------ >>> derive_remote_htlcpubkey htlc_basepoint per_commitment_point--- Just (RemoteHtlcPubkey ...)-derive_remote_htlcpubkey-  :: HtlcBasepoint-  -> PerCommitmentPoint-  -> Maybe RemoteHtlcPubkey-derive_remote_htlcpubkey (HtlcBasepoint pt) pcp =-  RemoteHtlcPubkey <$> derive_pubkey pt pcp-{-# INLINE derive_remote_htlcpubkey #-}+-- As 'mul_g', using a precomputed context.+mul_g' :: S.Context -> BS.ByteString -> Maybe S.Projective+mul_g' tex bs = S.derive_pub' tex =<< S.parse_int256 bs+{-# INLINE mul_g' #-} --- | Derive local_delayedpubkey from delayed_payment_basepoint and--- per_commitment_point.------ >>> derive_local_delayedpubkey delayed_payment_basepoint per_commitment_point--- Just (LocalDelayedPubkey ...)-derive_local_delayedpubkey-  :: DelayedPaymentBasepoint+derive_pubkey_with+  :: (BS.ByteString -> Maybe S.Projective)+  -> Point   -> PerCommitmentPoint-  -> Maybe LocalDelayedPubkey-derive_local_delayedpubkey (DelayedPaymentBasepoint pt) pcp =-  LocalDelayedPubkey <$> derive_pubkey pt pcp-{-# INLINE derive_local_delayedpubkey #-}+  -> Maybe Point+derive_pubkey_with mul bp (PerCommitmentPoint pcp) = do+  let !bp_bs = BOLT1.un_point bp+  base <- S.parse_point bp_bs+  t    <- mul (SHA256.hash (BOLT1.un_point pcp <> bp_bs))+  to_point (S.add base t)+{-# INLINE derive_pubkey_with #-} --- | Derive remote_delayedpubkey from delayed_payment_basepoint and--- per_commitment_point.+-- | Derive a commitment's @revocationpubkey@ from the revocation+--   basepoint of the party that will hold the revocation key, and the+--   commitment owner's per-commitment point: ----- >>> derive_remote_delayedpubkey delayed_payment_basepoint pcp--- Just (RemoteDelayedPubkey ...)-derive_remote_delayedpubkey-  :: DelayedPaymentBasepoint-  -> PerCommitmentPoint-  -> Maybe RemoteDelayedPubkey-derive_remote_delayedpubkey (DelayedPaymentBasepoint pt) pcp =-  RemoteDelayedPubkey <$> derive_pubkey pt pcp-{-# INLINE derive_remote_delayedpubkey #-}---- Revocation key derivation -------------------------------------------------- | Derive revocationpubkey from revocation_basepoint and--- per_commitment_point.+--   @+--   revocationpubkey =+--       revocation_basepoint+--         * SHA256(revocation_basepoint || per_commitment_point)+--     + per_commitment_point+--         * SHA256(per_commitment_point || revocation_basepoint)+--   @ ----- @--- revocationpubkey = revocation_basepoint---                      * SHA256(revocation_basepoint || per_commitment_point)---                  + per_commitment_point---                      * SHA256(per_commitment_point || revocation_basepoint)--- @+--   Fails if either point is not on the curve. ----- >>> derive_revocationpubkey revocation_basepoint per_commitment_point--- Just (RevocationPubkey ...)+--   >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])+--   >>> let Just pcp = derive_per_commitment_point s+--   >>> let Just b = BOLT1.per_commitment_secret (BS.pack [0 .. 31])+--   >>> let Just (PerCommitmentPoint p) = derive_per_commitment_point b+--   >>> let Just r = derive_revocationpubkey (RevocationBasepoint p) pcp+--   >>> (\(RevocationPubkey k) -> B16.encode (BOLT1.un_point k)) r+--   "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0" derive_revocationpubkey   :: RevocationBasepoint   -> PerCommitmentPoint   -> Maybe RevocationPubkey derive_revocationpubkey-  (RevocationBasepoint (Point rbpBs))-  (PerCommitmentPoint (Point pcpBs)) = do-    rbp <- S.parse_point rbpBs-    pcp <- S.parse_point pcpBs-    -- SHA256(revocation_basepoint || per_commitment_point)-    let !h1 = SHA256.hash (rbpBs <> pcpBs)-    -- SHA256(per_commitment_point || revocation_basepoint)-    let !h2 = SHA256.hash (pcpBs <> rbpBs)-    -- Multiply points by their respective scalars-    s1 <- S.parse_int256 h1-    s2 <- S.parse_int256 h2-    p1 <- S.mul rbp s1  -- revocation_basepoint * h1-    p2 <- S.mul pcp s2  -- per_commitment_point * h2-    -- Add the two points-    let !result = S.add p1 p2-        !bs = S.serialize_point result-    pure $! RevocationPubkey (Pubkey bs)-{-# INLINE derive_revocationpubkey #-}+  (RevocationBasepoint rbp)+  (PerCommitmentPoint pcp) = do+    let !rbp_bs = BOLT1.un_point rbp+        !pcp_bs = BOLT1.un_point pcp+    r  <- S.parse_point rbp_bs+    p  <- S.parse_point pcp_bs+    s1 <- S.parse_int256 (SHA256.hash (rbp_bs <> pcp_bs))+    s2 <- S.parse_int256 (SHA256.hash (pcp_bs <> rbp_bs))+    p1 <- S.mul r s1+    p2 <- S.mul p s2+    RevocationPubkey <$> to_point (S.add p1 p2) --- Per-commitment secret generation ---------------------------------------+-- | The keys a commitment transaction's scripts use.+data CommitmentKeys = CommitmentKeys+  { ck_revocation_pubkey :: !RevocationPubkey+  , ck_local_delayed     :: !LocalDelayedPubkey+  , ck_local_htlc        :: !LocalHtlcPubkey+  , ck_remote_htlc       :: !RemoteHtlcPubkey+  , ck_remote_payment    :: !RemotePubkey+  , ck_local_funding     :: !FundingPubkey+  , ck_remote_funding    :: !FundingPubkey+  } deriving (Eq, Show, Generic) --- | Generate the I'th per-commitment secret from a seed.------ Implements the generate_from_seed algorithm from BOLT #3:+instance NFData CommitmentKeys++-- | Derive the keys for a commitment transaction from both parties'+--   basepoints and funding pubkeys, and the commitment owner's+--   per-commitment point. ----- @--- generate_from_seed(seed, I):---     P = seed---     for B in 47 down to 0:---         if B set in I:---             flip(B) in P---             P = SHA256(P)---     return P--- @+--   The owner is the "local" party: its delayed and HTLC basepoints+--   give @local_delayedpubkey@ and @local_htlcpubkey@, while the other+--   party's revocation and HTLC basepoints give @revocationpubkey@ and+--   @remote_htlcpubkey@. As every supported 'CommitmentFormat' uses+--   @option_static_remotekey@, @remotepubkey@ is the other party's+--   @payment_basepoint@. ----- >>> generate_from_seed seed 281474976710655--- <32-byte secret>-generate_from_seed-  :: BS.ByteString  -- ^ seed (32 bytes)-  -> Word64         -- ^ index I (max 2^48 - 1)-  -> BS.ByteString  -- ^ per-commitment secret (32 bytes)-generate_from_seed seed idx = go 47 seed where-  go :: Int -> BS.ByteString -> BS.ByteString-  go !b !p-    | b < 0 = p-    | testBit idx b =-        let !p' = flip_bit b p-            !p'' = SHA256.hash p'-        in  go (b - 1) p''-    | otherwise = go (b - 1) p-{-# INLINE generate_from_seed #-}+--   Fails if a basepoint it derives a key from, or the per-commitment+--   point, is not on the curve.+derive_commitment_keys+  :: Basepoints          -- ^ the owner's basepoints+  -> FundingPubkey       -- ^ the owner's funding pubkey+  -> Basepoints          -- ^ the other party's basepoints+  -> FundingPubkey       -- ^ the other party's funding pubkey+  -> PerCommitmentPoint  -- ^ the owner's per-commitment point+  -> Maybe CommitmentKeys+derive_commitment_keys = derive_commitment_keys_with mul_g --- | Derive a secret from a base secret.+-- | As 'derive_commitment_keys', but uses a precomputed 'S.Context'+--   to speed up the scalar multiplications.+derive_commitment_keys'+  :: S.Context+  -> Basepoints+  -> FundingPubkey+  -> Basepoints+  -> FundingPubkey+  -> PerCommitmentPoint+  -> Maybe CommitmentKeys+derive_commitment_keys' tex = derive_commitment_keys_with (mul_g' tex)++derive_commitment_keys_with+  :: (BS.ByteString -> Maybe S.Projective)+  -> Basepoints+  -> FundingPubkey+  -> Basepoints+  -> FundingPubkey+  -> PerCommitmentPoint+  -> Maybe CommitmentKeys+derive_commitment_keys_with mul local local_fund remote remote_fund pcp = do+  let DelayedPaymentBasepoint local_delayed_bp = bp_delayed_payment local+      HtlcBasepoint local_htlc_bp = bp_htlc local+      HtlcBasepoint remote_htlc_bp = bp_htlc remote+      PaymentBasepoint remote_payment_bp = bp_payment remote+  revocation   <- derive_revocationpubkey (bp_revocation remote) pcp+  delayed      <- derive_pubkey_with mul local_delayed_bp pcp+  local_htlc   <- derive_pubkey_with mul local_htlc_bp pcp+  remote_htlc  <- derive_pubkey_with mul remote_htlc_bp pcp+  pure CommitmentKeys+    { ck_revocation_pubkey = revocation+    , ck_local_delayed     = LocalDelayedPubkey delayed+    , ck_local_htlc        = LocalHtlcPubkey local_htlc+    , ck_remote_htlc       = RemoteHtlcPubkey remote_htlc+    , ck_remote_payment    = RemotePubkey remote_payment_bp+    , ck_local_funding     = local_fund+    , ck_remote_funding    = remote_fund+    }++-- private keys ---------------------------------------------------------------++-- | Derive the private key for a per-commitment public key from its+--   basepoint secret: ----- This is a generalization of generate_from_seed used for efficient--- secret storage. Given a base secret whose index has bits..47 the same--- as target index I, derive the I'th secret.+--   @privkey = basepoint_secret + SHA256(per_commitment_point || basepoint)@ ----- @--- derive_secret(base, bits, I):---     P = base---     for B in bits - 1 down to 0:---         if B set in I:---             flip(B) in P---             P = SHA256(P)---     return P--- @-derive_secret-  :: BS.ByteString  -- ^ base secret-  -> Int            -- ^ bits (number of trailing bits to process)-  -> Word64         -- ^ target index I-  -> BS.ByteString  -- ^ derived secret-derive_secret base bits idx = go (bits - 1) base where-  go :: Int -> BS.ByteString -> BS.ByteString-  go !b !p-    | b < 0 = p-    | testBit idx b =-        let !p' = flip_bit b p-            !p'' = SHA256.hash p'-        in  go (b - 1) p''-    | otherwise = go (b - 1) p-{-# INLINE derive_secret #-}+--   where @basepoint = basepoint_secret * G@. The result is the secret+--   key for @'derive_pubkey' basepoint per_commitment_point@.+--+--   The arithmetic on the secret is constant-time. Fails (with+--   negligible probability) if the result is zero.+--+--   >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])+--   >>> let Just pcp = derive_per_commitment_point s+--   >>> let Just k = seckey (BS.pack [0 .. 31])+--   >>> fmap (B16.encode . un_seckey) (derive_privkey k pcp)+--   Just "cbced912d3b21bf196a766651e436aff192362621ce317704ea2f75d87e7be0f"+derive_privkey :: Seckey -> PerCommitmentPoint -> Maybe Seckey+derive_privkey (Seckey sk_bs) (PerCommitmentPoint pcp) = do+  sk <- S.parse_int256 sk_bs+  bp <- to_point =<< S.derive_pub sk+  let !h = SHA256.hash (BOLT1.un_point pcp <> BOLT1.un_point bp)+  to_seckey (SC.to sk + SC.to (S.unsafe_roll32 h)) --- | Flip bit B in a 32-byte bytestring.+-- | Derive a commitment's @revocationprivkey@ from the revocation+--   basepoint secret and the commitment's (revealed) per-commitment+--   secret: ----- "flip(B)" alternates the (B mod 8) bit of the (B div 8) byte.+--   @+--   revocationprivkey =+--       revocation_basepoint_secret+--         * SHA256(revocation_basepoint || per_commitment_point)+--     + per_commitment_secret+--         * SHA256(per_commitment_point || revocation_basepoint)+--   @+--+--   The result is the secret key for the 'derive_revocationpubkey'+--   of the corresponding points.+--+--   The arithmetic on the secrets is constant-time. Fails if the+--   per-commitment secret is not a valid secret key, or (with+--   negligible probability) if the result is zero.+--+--   >>> let Just s = BOLT1.per_commitment_secret (BS.pack [31, 30 .. 0])+--   >>> let Just k = seckey (BS.pack [0 .. 31])+--   >>> fmap (B16.encode . un_seckey) (derive_revocationprivkey k s)+--   Just "d09ffff62ddb2297ab000cc85bcb4283fdeb6aa052affbc9dddcf33b61078110"+derive_revocationprivkey+  :: Seckey               -- ^ revocation basepoint secret+  -> PerCommitmentSecret  -- ^ per-commitment secret+  -> Maybe Seckey+derive_revocationprivkey (Seckey rbs_bs) pcs = do+  let !pcs_bs = BOLT1.un_per_commitment_secret pcs+  rbs <- S.parse_int256 rbs_bs+  ps  <- S.parse_int256 pcs_bs+  rbp <- to_point =<< S.derive_pub rbs+  pcp <- to_point =<< S.derive_pub ps+  let !rbp_bs = BOLT1.un_point rbp+      !pcp_bs = BOLT1.un_point pcp+      !h1 = SC.to (S.unsafe_roll32 (SHA256.hash (rbp_bs <> pcp_bs)))+      !h2 = SC.to (S.unsafe_roll32 (SHA256.hash (pcp_bs <> rbp_bs)))+  to_seckey (SC.to rbs * h1 + SC.to ps * h2)++-- The secret key for a nonzero scalar. Reduction, arithmetic and the+-- zero check are constant-time (ppad-fixed).+to_seckey :: SC.Montgomery -> Maybe Seckey+to_seckey r+  | C.decide (SC.eq r 0) = Nothing+  | otherwise            = Just (Seckey (S.unroll32 (SC.retr r)))++-- per-commitment secrets -----------------------------------------------------++-- Wrap a 32-byte value as a per-commitment secret.+to_secret :: BS.ByteString -> PerCommitmentSecret+to_secret bs = case BOLT1.per_commitment_secret bs of+  Just s  -> s+  Nothing -> internal_error+{-# INLINE to_secret #-}++-- Flip bit b (< 256) of a 32-byte value: the (b mod 8) bit of the+-- (b div 8) byte. flip_bit :: Int -> BS.ByteString -> BS.ByteString flip_bit b bs =-  let !byteIdx = b `div` 8-      !bitIdx = b `mod` 8-      !len = BS.length bs-  in  if byteIdx >= len-      then bs-      else-        let !prefix = BS.take byteIdx bs-            !byte = BS.index bs byteIdx-            !byte' = complementBit byte bitIdx-            !suffix = BS.drop (byteIdx + 1) bs-        in  prefix <> BS.singleton byte' <> suffix+  let !(pre, post) = BS.splitAt (b `shiftR` 3) bs+  in  case BS.uncons post of+        Just (h, t) -> pre <> BS.cons (complementBit h (b .&. 7)) t+        Nothing     -> bs {-# INLINE flip_bit #-} --- Per-commitment secret storage ------------------------------------------+-- The spec's derive_secret: the secret for index i, from a base+-- secret whose index agrees with i in bits 47 down to 'bits'.+derive_secret :: BS.ByteString -> Int -> Word64 -> BS.ByteString+derive_secret base bits i = go (bits - 1) base where+  go !b !p+    | b < 0       = p+    | testBit i b = go (b - 1) (SHA256.hash (flip_bit b p))+    | otherwise   = go (b - 1) p --- | Entry in the secret store: (bucket, index, secret).-data SecretEntry = SecretEntry-  { se_bucket :: {-# UNPACK #-} !Int-  , se_index  :: {-# UNPACK #-} !Word64-  , se_secret :: !BS.ByteString-  } deriving (Eq, Show, Generic)+-- | Generate the per-commitment secret with a given index from a seed,+--   per BOLT #3's @generate_from_seed@.+--+--   >>> let Just s = seed (BS.replicate 32 0xff)+--   >>> let Just i = secret_index 281474976710655+--   >>> B16.encode (BOLT1.un_per_commitment_secret (generate_from_seed s i))+--   "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"+generate_from_seed :: Seed -> SecretIndex -> PerCommitmentSecret+generate_from_seed (Seed s) (SecretIndex i) = to_secret (derive_secret s 48 i) --- | Compact storage for per-commitment secrets.+-- | Compact storage for the per-commitment secrets received from a+--   peer, per BOLT #3's "Efficient Per-commitment Secret Storage". ----- Stores up to 49 (value, index) pairs, allowing efficient derivation--- of any previously-received secret. This is possible because for a--- given secret on a 2^X boundary, all secrets up to the next 2^X--- boundary can be derived from it.-newtype SecretStore = SecretStore { unSecretStore :: [SecretEntry] }-  deriving (Eq, Show, Generic)+--   Holds at most 49 secrets, from which every secret received so far+--   can be derived. This is secret material: its 'Show' instance is+--   redacted, and it has no 'Eq' instance.+newtype SecretStore = SecretStore [Entry] --- | Empty secret store.-empty_store :: SecretStore-empty_store = SecretStore []-{-# INLINE empty_store #-}+-- A stored secret: its bucket (the number of trailing zeros of its+-- index), index, and value. Kept in ascending bucket order.+data Entry = Entry+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Word64+  !BS.ByteString --- | Determine which bucket to store a secret in based on its index.------ Counts trailing zeros in the index. Returns 0-47 for normal indices,--- or 48 if index is 0 (the seed).-where_to_put_secret :: Word64 -> Int-where_to_put_secret idx = go 0 where+instance Show SecretStore where+  showsPrec d _ = showParen (d > 10) $+    showString "SecretStore <redacted>"++instance NFData SecretStore where+  rnf (SecretStore es) = rnf_entries es where+    rnf_entries [] = ()+    rnf_entries (Entry _ _ s : rest) = rnf s `seq` rnf_entries rest++-- | The empty 'SecretStore'.+empty_secret_store :: SecretStore+empty_secret_store = SecretStore []++-- The bucket for an index: its number of trailing zeros (48 for 0).+bucket_of :: Word64 -> Int+bucket_of i = go 0 where   go !b-    | b > 47 = 48  -- index 0, this is the seed-    | testBit idx b = b-    | otherwise = go (b + 1)-{-# INLINE where_to_put_secret #-}+    | b > 47      = 48+    | testBit i b = b+    | otherwise   = go (b + 1) --- | Insert a secret into the store, validating against existing secrets.+-- Whether a secret at index j in bucket b can derive index i.+can_derive :: Int -> Word64 -> Word64 -> Bool+can_derive b j i = i .&. complement ((1 `shiftL` b) - 1) == j+{-# INLINE can_derive #-}++-- | Add a newly received per-commitment secret to the store, per+--   BOLT #3's @insert_secret@. ----- Returns Nothing if the secret doesn't derive correctly from known--- secrets (indicating the secrets weren't generated from the same seed).+--   Fails if a stored secret cannot be derived from the new one, i.e.+--   if the secrets were not generated from the same seed (or were not+--   received in order). ----- >>> insert_secret secret 281474976710655 empty_store--- Just (SecretStore ...)+--   >>> let Just s = seed (BS.replicate 32 0xff)+--   >>> let Just i = secret_index 281474976710655+--   >>> let secret = generate_from_seed s i+--   >>> let Just st = insert_secret secret i empty_secret_store+--   >>> fmap (== secret) (derive_old_secret i st)+--   Just True insert_secret-  :: BS.ByteString  -- ^ secret (32 bytes)-  -> Word64         -- ^ index-  -> SecretStore    -- ^ current store+  :: PerCommitmentSecret+  -> SecretIndex+  -> SecretStore   -> Maybe SecretStore-insert_secret secret idx (SecretStore known) = do-  let !bucket = where_to_put_secret idx-  -- Validate: for each bucket < this bucket, check we can derive-  validated <- validateBuckets bucket known-  if validated-    then-      -- Remove entries at bucket >= this bucket, then insert-      let !known' = filter (\e -> se_bucket e < bucket) known-          !entry = SecretEntry bucket idx secret-      in  pure $! SecretStore (known' ++ [entry])-    else Nothing+insert_secret pcs (SecretIndex i) (SecretStore known)+  | all derives known = Just $! SecretStore (put known)+  | otherwise         = Nothing   where-    validateBuckets :: Int -> [SecretEntry] -> Maybe Bool-    validateBuckets b entries = go entries where-      go [] = Just True-      go (SecretEntry entryBucket knownIdx knownSecret : rest)-        | entryBucket >= b = go rest  -- skip entries at higher buckets-        | otherwise =-            -- Check if we can derive the known secret from the new one-            let !derived = derive_secret secret b knownIdx-            in  if derived == knownSecret-                then go rest-                else Nothing-{-# INLINE insert_secret #-}+    !s = BOLT1.un_per_commitment_secret pcs+    !b = bucket_of i+    !e = Entry b i s --- | Derive a previously-received secret from the store.------ Iterates over known secrets to find one whose index is a prefix of--- the target index, then derives the target secret from it.------ >>> derive_old_secret 281474976710654 store--- Just <32-byte secret>+    -- every secret in a lower bucket must derive from the new one+    derives (Entry kb ki ks)+      | kb < b    = to_secret (derive_secret s b ki) == to_secret ks+      | otherwise = True++    -- replace this bucket's entry, keeping ascending bucket order+    put [] = [e]+    put (k@(Entry kb _ _) : ks) = case compare kb b of+      LT -> k : put ks+      EQ -> e : ks+      GT -> e : k : ks++-- | Derive a previously received per-commitment secret from the+--   store. Fails if the index has not been received. derive_old_secret-  :: Word64       -- ^ target index-  -> SecretStore  -- ^ store-  -> Maybe BS.ByteString-derive_old_secret targetIdx (SecretStore known) = go known where-  go :: [SecretEntry] -> Maybe BS.ByteString+  :: SecretIndex+  -> SecretStore+  -> Maybe PerCommitmentSecret+derive_old_secret (SecretIndex i) (SecretStore known) = go known where   go [] = Nothing-  go (SecretEntry bucket knownIdx knownSecret : rest) =-    -- Mask off the non-zero prefix of the index using the entry's bucket-    let !mask = complement ((1 `shiftL` bucket) - 1)-    in  if (targetIdx .&. mask) == knownIdx-        then Just $! derive_secret knownSecret bucket targetIdx-        else go rest+  go (Entry b j s : rest)+    | can_derive b j i = Just $! to_secret (derive_secret s b i)+    | otherwise        = go rest -  complement :: Word64 -> Word64-  complement x = x `xor` 0xFFFFFFFFFFFFFFFF-{-# INLINE derive_old_secret #-}+-- | Rebuild a 'SecretStore' from its entries, e.g. as produced by+--   'un_secret_store'.+--+--   Fails if two entries share a bucket (i.e. their indices have the+--   same number of trailing zeros), or if an entry contradicts another+--   from which it can be derived.+secret_store+  :: [(SecretIndex, PerCommitmentSecret)]+  -> Maybe SecretStore+secret_store = go [] where+  go acc [] = Just (SecretStore acc)+  go acc ((SecretIndex i, pcs) : rest) = do+    let !e = Entry (bucket_of i) i (BOLT1.un_per_commitment_secret pcs)+    acc' <- place e acc+    go acc' rest --- Commitment number obscuring --------------------------------------------+  -- insert in ascending bucket order, checking consistency with the+  -- entries already placed+  place e@(Entry b i s) es+    | all (consistent e) es = put es+    | otherwise             = Nothing+    where+      put [] = Just [e]+      put (k@(Entry kb _ _) : ks) = case compare kb b of+        LT -> (k :) <$> put ks+        EQ -> Nothing+        GT -> Just (e : k : ks)+      consistent _ (Entry kb ki ks)+        | kb > b && can_derive kb ki i =+            to_secret (derive_secret ks kb i) == to_secret s+        | kb < b && can_derive b i ki =+            to_secret (derive_secret s b ki) == to_secret ks+        | otherwise = True --- | Calculate the obscured commitment number.+-- | The entries of a 'SecretStore', for persistence; see+--   'secret_store'.+un_secret_store :: SecretStore -> [(SecretIndex, PerCommitmentSecret)]+un_secret_store (SecretStore es) =+  [ (SecretIndex i, to_secret s) | Entry _ i s <- es ]++-- commitment number obscuring ------------------------------------------------++-- | Obscure a commitment number, by XOR with the lower 48 bits of ----- The 48-bit commitment number is obscured by XOR with the lower 48 bits--- of SHA256(payment_basepoint from open_channel---         || payment_basepoint from accept_channel).+--   @SHA256(payment_basepoint from open_channel+--           || payment_basepoint from accept_channel)@ ----- >>> obscured_commitment_number local_payment_bp remote_payment_bp cn--- <obscured value>+--   As XOR is an involution, applying this to an obscured number+--   recovers the commitment number. ('build_commitment_tx' obscures+--   the commitment number itself.)+--+--   >>> let pay h = fmap PaymentBasepoint (BOLT1.point =<< B16.decode h)+--   >>> let o1 = "034f355bdcb7cc0af728ef3cceb9615d9068"+--   >>> let Just o = pay (o1 <> "4bb5b2ca5f859ab0f0b704075871aa")+--   >>> let a1 = "032c0b7cf95324a07d05398b240174dc0c2b"+--   >>> let Just a = pay (a1 <> "e444d96b159aa6c7f7b1e668680991")+--   >>> fmap (obscured_commitment_number o a) (commitment_number 42)+--   Just 48035859142974 obscured_commitment_number   :: PaymentBasepoint   -- ^ opener's payment_basepoint   -> PaymentBasepoint   -- ^ accepter's payment_basepoint-  -> CommitmentNumber   -- ^ commitment number (48-bit)-  -> Word64             -- ^ obscured commitment number+  -> CommitmentNumber+  -> Word64 obscured_commitment_number-  (PaymentBasepoint (Point openerBs))-  (PaymentBasepoint (Point accepterBs))-  (CommitmentNumber cn) =-    let !h = SHA256.hash (openerBs <> accepterBs)-        -- Extract lower 48 bits (6 bytes) from the hash-        !lower48 = extractLower48 h-        -- Mask commitment number to 48 bits-        !cn48 = cn .&. 0xFFFFFFFFFFFF-    in  cn48 `xor` lower48-{-# INLINE obscured_commitment_number #-}---- | Extract lower 48 bits from a 32-byte hash.------ Takes bytes 26-31 (last 6 bytes) and interprets as big-endian Word64.-extractLower48 :: BS.ByteString -> Word64-extractLower48 h =-  let !b0 = fromIntegral (BS.index h 26) `shiftL` 40-      !b1 = fromIntegral (BS.index h 27) `shiftL` 32-      !b2 = fromIntegral (BS.index h 28) `shiftL` 24-      !b3 = fromIntegral (BS.index h 29) `shiftL` 16-      !b4 = fromIntegral (BS.index h 30) `shiftL` 8-      !b5 = fromIntegral (BS.index h 31)-  in  b0 + b1 + b2 + b3 + b4 + b5-{-# INLINE extractLower48 #-}+  (PaymentBasepoint opener)+  (PaymentBasepoint accepter)+  cn =+    let !h = SHA256.hash (BOLT1.un_point opener <> BOLT1.un_point accepter)+        !mask = BS.foldl' (\acc x -> (acc `shiftL` 8) .|. fromIntegral x) 0+                  (BS.drop 26 h)+    in  un_commitment_number cn `xor` mask

@@ -1,6 +1,5 @@-{-# OPTIONS_HADDOCK prune #-}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}  -- | -- Module: Lightning.Protocol.BOLT3.Scripts@@ -8,17 +7,7 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Script templates for BOLT #3 transaction outputs.------ Includes witness scripts for:------ * Funding output (2-of-2 multisig)--- * to_local output (revocable with CSV delay)--- * to_remote output (P2WPKH or anchored)--- * Anchor outputs--- * Offered HTLC outputs--- * Received HTLC outputs--- * HTLC-timeout/success output (revocable with delay)+-- Scripts and witnesses for BOLT #3 transaction outputs.  module Lightning.Protocol.BOLT3.Scripts (     -- * Funding output@@ -31,7 +20,8 @@   , to_local_witness_revoke      -- * to_remote output-  , to_remote_script+  , to_remote_witness_script+  , to_remote_script_pubkey   , to_remote_witness      -- * Anchor outputs@@ -39,639 +29,475 @@   , anchor_witness_owner   , anchor_witness_anyone -    -- * Offered HTLC output+    -- * Offered HTLC outputs   , offered_htlc_script   , offered_htlc_witness_preimage   , offered_htlc_witness_revoke -    -- * Received HTLC output+    -- * Received HTLC outputs   , received_htlc_script   , received_htlc_witness_timeout   , received_htlc_witness_revoke -    -- * HTLC-timeout/success output (same as to_local)-  , htlc_output_script-  , htlc_output_witness_spend-  , htlc_output_witness_revoke+    -- * HTLC transaction inputs+  , htlc_success_witness+  , htlc_timeout_witness+  , remote_htlc_sighash -    -- * P2WSH helpers+    -- * P2WSH   , to_p2wsh-  , witness_script_hash   ) where +import Bitcoin.Prim.Tx (Witness(..))+import Bitcoin.Prim.Tx.Sighash (SighashType(..))+import qualified Crypto.Hash.RIPEMD160 as RIPEMD160+import qualified Crypto.Hash.SHA256 as SHA256 import Data.Bits ((.&.), shiftR)-import Data.Word (Word8, Word16, Word32) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as BSL-import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.Hash.RIPEMD160 as RIPEMD160+import Data.Word (Word8, Word16, Word32)+import Lightning.Protocol.BOLT1 (Point, PaymentPreimage)+import qualified Lightning.Protocol.BOLT1 as BOLT1 import Lightning.Protocol.BOLT3.Types --- opcodes ------------------------------------------------------------------------- | OP_0 / OP_FALSE (0x00)-op_0 :: Word8-op_0 = 0x00---- | OP_PUSHDATA for 1-75 bytes just uses the length as opcode--- For data <=75 bytes, opcode is just the length+-- opcodes -------------------------------------------------------------------- --- | OP_IF (0x63)-op_if :: Word8-op_if = 0x63+op_0, op_1, op_2, op_16 :: Word8+op_0  = 0x00+op_1  = 0x51+op_2  = 0x52+op_16 = 0x60 --- | OP_NOTIF (0x64)-op_notif :: Word8+op_if, op_notif, op_else, op_endif, op_drop, op_dup, op_ifdup :: Word8+op_if    = 0x63 op_notif = 0x64---- | OP_ELSE (0x67)-op_else :: Word8-op_else = 0x67---- | OP_ENDIF (0x68)-op_endif :: Word8+op_else  = 0x67 op_endif = 0x68---- | OP_DROP (0x75)-op_drop :: Word8-op_drop = 0x75---- | OP_DUP (0x76)-op_dup :: Word8-op_dup = 0x76---- | OP_SWAP (0x7c)-op_swap :: Word8-op_swap = 0x7c---- | OP_SIZE (0x82)-op_size :: Word8-op_size = 0x82---- | OP_EQUAL (0x87)-op_equal :: Word8-op_equal = 0x87---- | OP_EQUALVERIFY (0x88)-op_equalverify :: Word8-op_equalverify = 0x88---- | OP_IFDUP (0x73)-op_ifdup :: Word8 op_ifdup = 0x73---- | OP_HASH160 (0xa9)-op_hash160 :: Word8-op_hash160 = 0xa9+op_drop  = 0x75+op_dup   = 0x76 --- | OP_CHECKSIG (0xac)-op_checksig :: Word8-op_checksig = 0xac+op_swap, op_size, op_equal, op_equalverify, op_hash160 :: Word8+op_swap        = 0x7c+op_size        = 0x82+op_equal       = 0x87+op_equalverify = 0x88+op_hash160     = 0xa9 --- | OP_CHECKSIGVERIFY (0xad)-op_checksigverify :: Word8+op_checksig, op_checksigverify, op_checkmultisig :: Word8+op_checksig       = 0xac op_checksigverify = 0xad---- | OP_CHECKMULTISIG (0xae)-op_checkmultisig :: Word8-op_checkmultisig = 0xae+op_checkmultisig  = 0xae --- | OP_CHECKLOCKTIMEVERIFY (0xb1)-op_checklocktimeverify :: Word8+op_checklocktimeverify, op_checksequenceverify :: Word8 op_checklocktimeverify = 0xb1---- | OP_CHECKSEQUENCEVERIFY (0xb2)-op_checksequenceverify :: Word8 op_checksequenceverify = 0xb2 --- | OP_1 (0x51)-op_1 :: Word8-op_1 = 0x51+-- helpers -------------------------------------------------------------------- --- | OP_2 (0x52)-op_2 :: Word8-op_2 = 0x52+op :: Word8 -> BSB.Builder+op = BSB.word8+{-# INLINE op #-} --- | OP_16 (0x60)-op_16 :: Word8-op_16 = 0x60+-- Push data of at most 75 bytes (all pushes here are keys, hashes or+-- short numbers).+push :: BS.ByteString -> BSB.Builder+push bs = BSB.word8 (fromIntegral (BS.length bs)) <> BSB.byteString bs+{-# INLINE push #-} --- helpers ---------------------------------------------------------------------+push_point :: Point -> BSB.Builder+push_point = push . BOLT1.un_point+{-# INLINE push_point #-} --- | Push a bytestring onto the stack (handles length encoding).------ For data <= 75 bytes, the length itself is the opcode.-push_data :: BS.ByteString -> BSB.Builder-push_data !bs-  | len <= 75 = BSB.word8 (fromIntegral len) <> BSB.byteString bs-  | len <= 255 = BSB.word8 0x4c <> BSB.word8 (fromIntegral len)-                 <> BSB.byteString bs-  | len <= 65535 = BSB.word8 0x4d <> BSB.word16LE (fromIntegral len)-                   <> BSB.byteString bs-  | otherwise = BSB.word8 0x4e <> BSB.word32LE (fromIntegral len)-                <> BSB.byteString bs+-- Push a non-negative number, minimally encoded.+push_num :: Word32 -> BSB.Builder+push_num n+  | n == 0    = op op_0+  | n <= 16   = op (0x50 + fromIntegral n)+  | otherwise = push (BS.pack (signed (le n)))   where-    !len = BS.length bs-{-# INLINE push_data #-}+    -- little-endian magnitude+    le :: Word32 -> [Word8]+    le !x+      | x == 0    = []+      | otherwise = fromIntegral (x .&. 0xff) : le (x `shiftR` 8) --- | Encode a Word16 as minimal script number (for CSV delays).-push_csv_delay :: Word16 -> BSB.Builder-push_csv_delay !n-  | n == 0 = BSB.word8 op_0-  | n <= 16 = BSB.word8 (0x50 + fromIntegral n)-  | n <= 0x7f = push_data (BS.singleton (fromIntegral n))-  | n <= 0x7fff = push_data (BS.pack [lo, hi])-  | otherwise = push_data (BS.pack [lo, hi, 0x00])  -- need sign byte-  where-    !lo = fromIntegral (n .&. 0xff)-    !hi = fromIntegral ((n `shiftR` 8) .&. 0xff)-{-# INLINE push_csv_delay #-}+    -- append a sign byte if the top bit is set+    signed bs = case reverse bs of+      (h : _) | h .&. 0x80 /= 0 -> bs <> [0x00]+      _ -> bs --- | Encode a Word32 as minimal script number (for CLTV).-push_cltv :: Word32 -> BSB.Builder-push_cltv !n-  | n == 0 = BSB.word8 op_0-  | n <= 16 = BSB.word8 (0x50 + fromIntegral n)-  | otherwise = push_data (encode_scriptnum n)-  where-    encode_scriptnum :: Word32 -> BS.ByteString-    encode_scriptnum 0 = BS.empty-    encode_scriptnum !v =-      let -- Build bytes little-endian (LSB first)-          go :: Word32 -> [Word8]-          go 0 = []-          go !x = fromIntegral (x .&. 0xff) : go (x `shiftR` 8)-          !bytes = go v-          -- If MSB has high bit set, need 0x00 suffix for positive numbers-          !result = case reverse bytes of-            [] -> bytes-            (msb:_) | msb .&. 0x80 /= 0 -> bytes ++ [0x00]-            _ -> bytes-      in BS.pack result-{-# INLINE push_cltv #-}+push_delay :: Word16 -> BSB.Builder+push_delay = push_num . fromIntegral+{-# INLINE push_delay #-} --- | Build script from builder.-build_script :: BSB.Builder -> Script-build_script = Script . BSL.toStrict . BSB.toLazyByteString-{-# INLINE build_script #-}+script :: BSB.Builder -> Script+script = Script . BSL.toStrict . BSB.toLazyByteString+{-# INLINE script #-} --- | HASH160 = RIPEMD160(SHA256(x)) hash160 :: BS.ByteString -> BS.ByteString hash160 = RIPEMD160.hash . SHA256.hash {-# INLINE hash160 #-} --- P2WSH helpers ---------------------------------------------------------------+-- Append a witness script to a witness stack.+with_script :: [BS.ByteString] -> Script -> Witness+with_script items (Script s) = Witness (items <> [s])+{-# INLINE with_script #-} --- | Compute SHA256 hash of a witness script.------ >>> witness_script_hash (Script "some_script")--- <32-byte SHA256 hash>-witness_script_hash :: Script -> BS.ByteString-witness_script_hash (Script !s) = SHA256.hash s-{-# INLINE witness_script_hash #-}+-- P2WSH ---------------------------------------------------------------------- --- | Convert a witness script to P2WSH scriptPubKey.------ P2WSH format: OP_0 <32-byte-hash>------ >>> to_p2wsh some_witness_script--- Script "\x00\x20<32-byte-hash>"+-- | The P2WSH scriptPubKey for a witness script:+--   @0 \<SHA256(script)\>@. to_p2wsh :: Script -> Script-to_p2wsh !script =-  let !h = witness_script_hash script-  in build_script (BSB.word8 op_0 <> push_data h)-{-# INLINE to_p2wsh #-}+to_p2wsh (Script s) = script (op op_0 <> push (SHA256.hash s)) --- funding output --------------------------------------------------------------+-- funding output ------------------------------------------------------------- --- | Funding output witness script (2-of-2 multisig).------ Script: @2 <pubkey1> <pubkey2> 2 OP_CHECKMULTISIG@+-- | The funding output's witness script: ----- Where pubkey1 is lexicographically lesser.+--   @2 \<pubkey1\> \<pubkey2\> 2 OP_CHECKMULTISIG@ ----- >>> funding_script pk1 pk2--- Script "R!<pk_lesser>!<pk_greater>R\xae"+--   where @pubkey1@ is the lexicographically lesser of the two funding+--   pubkeys. The argument order doesn't matter. funding_script :: FundingPubkey -> FundingPubkey -> Script-funding_script (FundingPubkey (Pubkey !pk1)) (FundingPubkey (Pubkey !pk2)) =-  let (!lesser, !greater) = if pk1 <= pk2 then (pk1, pk2) else (pk2, pk1)-  in build_script $-       BSB.word8 op_2-       <> push_data lesser-       <> push_data greater-       <> BSB.word8 op_2-       <> BSB.word8 op_checkmultisig+funding_script (FundingPubkey a) (FundingPubkey b) =+  let (lo, hi) = if a <= b then (a, b) else (b, a)+  in  script $+           op op_2 <> push_point lo <> push_point hi+        <> op op_2 <> op op_checkmultisig --- | Witness for spending funding output.------ Witness: @0 <sig1> <sig2>@+-- | The witness spending the funding output, given each party's+--   funding pubkey and signature (DER-encoded, with sighash byte): ----- Signatures ordered to match pubkey order in script.+--   @0 \<signature_for_pubkey1\> \<signature_for_pubkey2\> \<script\>@ ----- >>> funding_witness sig1 sig2--- Witness ["", sig1, sig2]-funding_witness :: BS.ByteString -> BS.ByteString -> Witness-funding_witness !sig1 !sig2 = Witness [BS.empty, sig1, sig2]+--   The signatures are ordered to match the pubkeys in+--   'funding_script', so the argument order doesn't matter.+funding_witness+  :: FundingPubkey -> BS.ByteString+  -> FundingPubkey -> BS.ByteString+  -> Witness+funding_witness pa@(FundingPubkey a) sa pb@(FundingPubkey b) sb =+  let (s1, s2) = if a <= b then (sa, sb) else (sb, sa)+  in  with_script [BS.empty, s1, s2] (funding_script pa pb) --- to_local output -------------------------------------------------------------+-- to_local output ------------------------------------------------------------ --- | to_local witness script (revocable with CSV delay).------ Script:+-- | The @to_local@ output's witness script: ----- @--- OP_IF---     <revocationpubkey>--- OP_ELSE---     <to_self_delay>---     OP_CHECKSEQUENCEVERIFY---     OP_DROP---     <local_delayedpubkey>--- OP_ENDIF--- OP_CHECKSIG--- @+--   @+--   OP_IF+--       \<revocationpubkey\>+--   OP_ELSE+--       \<to_self_delay\> OP_CHECKSEQUENCEVERIFY OP_DROP+--       \<local_delayedpubkey\>+--   OP_ENDIF+--   OP_CHECKSIG+--   @ ----- >>> to_local_script revpk delay localpk--- Script "c!<revpk>g<delay>\xb2u!<localpk>h\xac"+--   HTLC-success and HTLC-timeout transaction outputs use the same+--   script. to_local_script   :: RevocationPubkey   -> ToSelfDelay   -> LocalDelayedPubkey   -> Script to_local_script-  (RevocationPubkey (Pubkey !revpk))-  (ToSelfDelay !delay)-  (LocalDelayedPubkey (Pubkey !localpk)) =-    build_script $-      BSB.word8 op_if-      <> push_data revpk-      <> BSB.word8 op_else-      <> push_csv_delay delay-      <> BSB.word8 op_checksequenceverify-      <> BSB.word8 op_drop-      <> push_data localpk-      <> BSB.word8 op_endif-      <> BSB.word8 op_checksig+  (RevocationPubkey rev)+  (ToSelfDelay delay)+  (LocalDelayedPubkey delayed) = script $+       op op_if+    <> push_point rev+    <> op op_else+    <> push_delay delay+    <> op op_checksequenceverify+    <> op op_drop+    <> push_point delayed+    <> op op_endif+    <> op op_checksig --- | Witness for delayed spend of to_local output.------ Input nSequence must be set to to_self_delay.+-- | The witness for the owner's delayed spend of a @to_local@ (or+--   HTLC transaction) output, given its witness script: ----- Witness: @<local_delayedsig> <>@+--   @\<local_delayedsig\> \<\> \<script\>@ ----- >>> to_local_witness_spend sig--- Witness [sig, ""]-to_local_witness_spend :: BS.ByteString -> Witness-to_local_witness_spend !sig = Witness [sig, BS.empty]+--   The spending input's @nSequence@ must be @to_self_delay@.+to_local_witness_spend :: BS.ByteString -> Script -> Witness+to_local_witness_spend sig = with_script [sig, BS.empty] --- | Witness for revocation spend of to_local output.------ Witness: @<revocation_sig> 1@+-- | The witness for the revocation spend of a @to_local@ (or HTLC+--   transaction) output, given its witness script: ----- >>> to_local_witness_revoke sig--- Witness [sig, "\x01"]-to_local_witness_revoke :: BS.ByteString -> Witness-to_local_witness_revoke !sig = Witness [sig, BS.singleton 0x01]+--   @\<revocation_sig\> 1 \<script\>@+to_local_witness_revoke :: BS.ByteString -> Script -> Witness+to_local_witness_revoke sig = with_script [sig, BS.singleton 0x01] --- to_remote output ------------------------------------------------------------+-- to_remote output ----------------------------------------------------------- --- | to_remote witness script.------ With option_anchors:------ @--- <remotepubkey> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY--- @+-- | The @to_remote@ output's witness script under 'Anchors': ----- Without option_anchors: P2WPKH (just the pubkey hash).+--   @\<remotepubkey\> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY@ ----- >>> to_remote_script pk (ChannelFeatures True)--- Script "!<pk>\xadQ\xb2"-to_remote_script :: RemotePubkey -> ChannelFeatures -> Script-to_remote_script (RemotePubkey (Pubkey !pk)) !features-  | has_anchors features =-      -- Anchors: script with 1-block CSV-      build_script $-        push_data pk-        <> BSB.word8 op_checksigverify-        <> BSB.word8 op_1-        <> BSB.word8 op_checksequenceverify-  | otherwise =-      -- No anchors: P2WPKH (OP_0 <20-byte-hash>)-      let !h = hash160 pk-      in build_script (BSB.word8 op_0 <> push_data h)+--   (Under 'StaticRemotekey' the output is P2WPKH, with no witness+--   script; see 'to_remote_script_pubkey'.)+to_remote_witness_script :: RemotePubkey -> Script+to_remote_witness_script (RemotePubkey pk) = script $+     push_point pk+  <> op op_checksigverify+  <> op op_1+  <> op op_checksequenceverify --- | Witness for spending to_remote output.------ With option_anchors (P2WSH), input nSequence must be 1.--- Witness: @<remote_sig>@ (witness script appended by caller)------ Without option_anchors (P2WPKH):--- Witness: @<remote_sig> <remotepubkey>@------ >>> to_remote_witness sig pk (ChannelFeatures False)--- Witness [sig, pk]-to_remote_witness :: BS.ByteString -> RemotePubkey -> ChannelFeatures -> Witness-to_remote_witness !sig (RemotePubkey (Pubkey !pk)) !features-  | has_anchors features = Witness [sig]-  | otherwise = Witness [sig, pk]+-- | The @to_remote@ output's scriptPubKey: P2WPKH to @remotepubkey@+--   under 'StaticRemotekey', and P2WSH of 'to_remote_witness_script'+--   under 'Anchors'.+to_remote_script_pubkey :: RemotePubkey -> CommitmentFormat -> Script+to_remote_script_pubkey pk@(RemotePubkey p) fmt = case fmt of+  StaticRemotekey -> script (op op_0 <> push (hash160 (BOLT1.un_point p)))+  Anchors         -> to_p2wsh (to_remote_witness_script pk) --- anchor outputs --------------------------------------------------------------+-- | The witness spending a @to_remote@ output: @\<remote_sig\>+--   \<remotepubkey\>@ (P2WPKH) under 'StaticRemotekey', and+--   @\<remote_sig\> \<script\>@ under 'Anchors', where the spending+--   input's @nSequence@ must be 1.+to_remote_witness+  :: BS.ByteString -> RemotePubkey -> CommitmentFormat -> Witness+to_remote_witness sig pk@(RemotePubkey p) fmt = case fmt of+  StaticRemotekey -> Witness [sig, BOLT1.un_point p]+  Anchors         -> with_script [sig] (to_remote_witness_script pk) --- | Anchor output witness script.------ Script:------ @--- <funding_pubkey> OP_CHECKSIG OP_IFDUP--- OP_NOTIF---     OP_16 OP_CHECKSEQUENCEVERIFY--- OP_ENDIF--- @+-- anchor outputs -------------------------------------------------------------++-- | An anchor output's witness script, for the funding pubkey of the+--   party it belongs to: ----- >>> anchor_script fundpk--- Script "!<fundpk>\xac\x73d`\xb2h"+--   @+--   \<funding_pubkey\> OP_CHECKSIG OP_IFDUP+--   OP_NOTIF+--       OP_16 OP_CHECKSEQUENCEVERIFY+--   OP_ENDIF+--   @ anchor_script :: FundingPubkey -> Script-anchor_script (FundingPubkey (Pubkey !pk)) =-  build_script $-    push_data pk-    <> BSB.word8 op_checksig-    <> BSB.word8 op_ifdup-    <> BSB.word8 op_notif-    <> BSB.word8 op_16-    <> BSB.word8 op_checksequenceverify-    <> BSB.word8 op_endif+anchor_script (FundingPubkey pk) = script $+     push_point pk+  <> op op_checksig+  <> op op_ifdup+  <> op op_notif+  <> op op_16+  <> op op_checksequenceverify+  <> op op_endif --- | Witness for owner to spend anchor output.------ Witness: @<sig>@------ >>> anchor_witness_owner sig--- Witness [sig]-anchor_witness_owner :: BS.ByteString -> Witness-anchor_witness_owner !sig = Witness [sig]+-- | The witness for an anchor's owner to spend it:+--   @\<sig\> \<script\>@.+anchor_witness_owner :: BS.ByteString -> FundingPubkey -> Witness+anchor_witness_owner sig pk = with_script [sig] (anchor_script pk) --- | Witness for anyone to sweep anchor output after 16 blocks.------ Witness: @<>@------ >>> anchor_witness_anyone--- Witness [""]-anchor_witness_anyone :: Witness-anchor_witness_anyone = Witness [BS.empty]+-- | The witness for anyone to sweep an anchor, 16 blocks after the+--   commitment transaction confirms: @\<\> \<script\>@.+anchor_witness_anyone :: FundingPubkey -> Witness+anchor_witness_anyone pk = with_script [BS.empty] (anchor_script pk) --- offered HTLC output ---------------------------------------------------------+-- offered HTLC outputs ------------------------------------------------------- --- | Offered HTLC witness script.------ Without option_anchors:+-- csv suffix for anchors HTLC scripts+htlc_csv :: CommitmentFormat -> BSB.Builder+htlc_csv fmt = case fmt of+  StaticRemotekey -> mempty+  Anchors         -> op op_1 <> op op_checksequenceverify <> op op_drop+{-# INLINE htlc_csv #-}++-- | An offered HTLC output's witness script: ----- @--- OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL--- OP_IF---     OP_CHECKSIG--- OP_ELSE---     <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL---     OP_NOTIF---         OP_DROP 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG---     OP_ELSE---         OP_HASH160 <RIPEMD160(payment_hash)> OP_EQUALVERIFY---         OP_CHECKSIG---     OP_ENDIF--- OP_ENDIF--- @+--   @+--   OP_DUP OP_HASH160 \<RIPEMD160(SHA256(revocationpubkey))\> OP_EQUAL+--   OP_IF+--       OP_CHECKSIG+--   OP_ELSE+--       \<remote_htlcpubkey\> OP_SWAP OP_SIZE 32 OP_EQUAL+--       OP_NOTIF+--           OP_DROP 2 OP_SWAP \<local_htlcpubkey\> 2 OP_CHECKMULTISIG+--       OP_ELSE+--           OP_HASH160 \<RIPEMD160(payment_hash)\> OP_EQUALVERIFY+--           OP_CHECKSIG+--       OP_ENDIF+--   OP_ENDIF+--   @ ----- With option_anchors, adds @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ before--- final OP_ENDIF.+--   Under 'Anchors', @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ precedes the+--   final @OP_ENDIF@. offered_htlc_script   :: RevocationPubkey   -> RemoteHtlcPubkey   -> LocalHtlcPubkey-  -> PaymentHash-  -> ChannelFeatures+  -> BOLT1.PaymentHash+  -> CommitmentFormat   -> Script offered_htlc_script-  (RevocationPubkey (Pubkey !revpk))-  (RemoteHtlcPubkey (Pubkey !remotepk))-  (LocalHtlcPubkey (Pubkey !localpk))-  (PaymentHash !ph)-  !features =-    let !revpk_hash = hash160 revpk-        !payment_hash160 = RIPEMD160.hash ph-        !csv_suffix = if has_anchors features-          then BSB.word8 op_1-               <> BSB.word8 op_checksequenceverify-               <> BSB.word8 op_drop-          else mempty-    in build_script $-         -- OP_DUP OP_HASH160 <revpk_hash> OP_EQUAL-         BSB.word8 op_dup-         <> BSB.word8 op_hash160-         <> push_data revpk_hash-         <> BSB.word8 op_equal-         -- OP_IF OP_CHECKSIG-         <> BSB.word8 op_if-         <> BSB.word8 op_checksig-         -- OP_ELSE-         <> BSB.word8 op_else-         -- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL-         <> push_data remotepk-         <> BSB.word8 op_swap-         <> BSB.word8 op_size-         <> push_data (BS.singleton 32)-         <> BSB.word8 op_equal-         -- OP_NOTIF-         <> BSB.word8 op_notif-         -- OP_DROP 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG-         <> BSB.word8 op_drop-         <> BSB.word8 op_2-         <> BSB.word8 op_swap-         <> push_data localpk-         <> BSB.word8 op_2-         <> BSB.word8 op_checkmultisig-         -- OP_ELSE-         <> BSB.word8 op_else-         -- OP_HASH160 <payment_hash160> OP_EQUALVERIFY OP_CHECKSIG-         <> BSB.word8 op_hash160-         <> push_data payment_hash160-         <> BSB.word8 op_equalverify-         <> BSB.word8 op_checksig-         -- OP_ENDIF-         <> BSB.word8 op_endif-         -- CSV suffix for anchors-         <> csv_suffix-         -- OP_ENDIF-         <> BSB.word8 op_endif+  (RevocationPubkey rev)+  (RemoteHtlcPubkey remote)+  (LocalHtlcPubkey local)+  ph+  fmt = script $+       op op_dup <> op op_hash160+    <> push (hash160 (BOLT1.un_point rev))+    <> op op_equal+    <> op op_if+    <>   op op_checksig+    <> op op_else+    <>   push_point remote <> op op_swap <> op op_size+    <>   push (BS.singleton 32) <> op op_equal+    <>   op op_notif+    <>     op op_drop <> op op_2 <> op op_swap+    <>     push_point local <> op op_2 <> op op_checkmultisig+    <>   op op_else+    <>     op op_hash160+    <>     push (RIPEMD160.hash (BOLT1.un_payment_hash ph))+    <>     op op_equalverify <> op op_checksig+    <>   op op_endif+    <>   htlc_csv fmt+    <> op op_endif --- | Witness for remote node to claim offered HTLC with preimage.------ With option_anchors, input nSequence must be 1.+-- | The witness for the remote party to claim an offered HTLC output+--   with the payment preimage, given its witness script: ----- Witness: @<remotehtlcsig> <payment_preimage>@+--   @\<remotehtlcsig\> \<payment_preimage\> \<script\>@ ----- >>> offered_htlc_witness_preimage sig preimage--- Witness [sig, preimage]+--   Under 'Anchors' the spending input's @nSequence@ must be 1. offered_htlc_witness_preimage-  :: BS.ByteString -> PaymentPreimage -> Witness-offered_htlc_witness_preimage !sig (PaymentPreimage !preimage) =-  Witness [sig, preimage]+  :: BS.ByteString -> PaymentPreimage -> Script -> Witness+offered_htlc_witness_preimage sig pre =+  with_script [sig, BOLT1.un_payment_preimage pre] --- | Witness for revocation spend of offered HTLC.------ Witness: @<revocation_sig> <revocationpubkey>@+-- | The witness for the revocation spend of an offered HTLC output,+--   given its witness script: ----- >>> offered_htlc_witness_revoke sig revpk--- Witness [sig, revpk]-offered_htlc_witness_revoke :: BS.ByteString -> Pubkey -> Witness-offered_htlc_witness_revoke !sig (Pubkey !revpk) = Witness [sig, revpk]+--   @\<revocation_sig\> \<revocationpubkey\> \<script\>@+offered_htlc_witness_revoke+  :: BS.ByteString -> RevocationPubkey -> Script -> Witness+offered_htlc_witness_revoke sig (RevocationPubkey rev) =+  with_script [sig, BOLT1.un_point rev] --- received HTLC output --------------------------------------------------------+-- received HTLC outputs ------------------------------------------------------ --- | Received HTLC witness script.------ Without option_anchors:+-- | A received HTLC output's witness script: ----- @--- OP_DUP OP_HASH160 <RIPEMD160(SHA256(revocationpubkey))> OP_EQUAL--- OP_IF---     OP_CHECKSIG--- OP_ELSE---     <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL---     OP_IF---         OP_HASH160 <RIPEMD160(payment_hash)> OP_EQUALVERIFY---         2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG---     OP_ELSE---         OP_DROP <cltv_expiry> OP_CHECKLOCKTIMEVERIFY OP_DROP---         OP_CHECKSIG---     OP_ENDIF--- OP_ENDIF--- @+--   @+--   OP_DUP OP_HASH160 \<RIPEMD160(SHA256(revocationpubkey))\> OP_EQUAL+--   OP_IF+--       OP_CHECKSIG+--   OP_ELSE+--       \<remote_htlcpubkey\> OP_SWAP OP_SIZE 32 OP_EQUAL+--       OP_IF+--           OP_HASH160 \<RIPEMD160(payment_hash)\> OP_EQUALVERIFY+--           2 OP_SWAP \<local_htlcpubkey\> 2 OP_CHECKMULTISIG+--       OP_ELSE+--           OP_DROP \<cltv_expiry\> OP_CHECKLOCKTIMEVERIFY OP_DROP+--           OP_CHECKSIG+--       OP_ENDIF+--   OP_ENDIF+--   @ ----- With option_anchors, adds @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ before--- final OP_ENDIF.+--   Under 'Anchors', @1 OP_CHECKSEQUENCEVERIFY OP_DROP@ precedes the+--   final @OP_ENDIF@. received_htlc_script   :: RevocationPubkey   -> RemoteHtlcPubkey   -> LocalHtlcPubkey-  -> PaymentHash+  -> BOLT1.PaymentHash   -> CltvExpiry-  -> ChannelFeatures+  -> CommitmentFormat   -> Script received_htlc_script-  (RevocationPubkey (Pubkey !revpk))-  (RemoteHtlcPubkey (Pubkey !remotepk))-  (LocalHtlcPubkey (Pubkey !localpk))-  (PaymentHash !ph)-  (CltvExpiry !expiry)-  !features =-    let !revpk_hash = hash160 revpk-        !payment_hash160 = RIPEMD160.hash ph-        !csv_suffix = if has_anchors features-          then BSB.word8 op_1-               <> BSB.word8 op_checksequenceverify-               <> BSB.word8 op_drop-          else mempty-    in build_script $-         -- OP_DUP OP_HASH160 <revpk_hash> OP_EQUAL-         BSB.word8 op_dup-         <> BSB.word8 op_hash160-         <> push_data revpk_hash-         <> BSB.word8 op_equal-         -- OP_IF OP_CHECKSIG-         <> BSB.word8 op_if-         <> BSB.word8 op_checksig-         -- OP_ELSE-         <> BSB.word8 op_else-         -- <remote_htlcpubkey> OP_SWAP OP_SIZE 32 OP_EQUAL-         <> push_data remotepk-         <> BSB.word8 op_swap-         <> BSB.word8 op_size-         <> push_data (BS.singleton 32)-         <> BSB.word8 op_equal-         -- OP_IF-         <> BSB.word8 op_if-         -- OP_HASH160 <payment_hash160> OP_EQUALVERIFY-         <> BSB.word8 op_hash160-         <> push_data payment_hash160-         <> BSB.word8 op_equalverify-         -- 2 OP_SWAP <local_htlcpubkey> 2 OP_CHECKMULTISIG-         <> BSB.word8 op_2-         <> BSB.word8 op_swap-         <> push_data localpk-         <> BSB.word8 op_2-         <> BSB.word8 op_checkmultisig-         -- OP_ELSE-         <> BSB.word8 op_else-         -- OP_DROP <cltv_expiry> OP_CHECKLOCKTIMEVERIFY OP_DROP OP_CHECKSIG-         <> BSB.word8 op_drop-         <> push_cltv expiry-         <> BSB.word8 op_checklocktimeverify-         <> BSB.word8 op_drop-         <> BSB.word8 op_checksig-         -- OP_ENDIF-         <> BSB.word8 op_endif-         -- CSV suffix for anchors-         <> csv_suffix-         -- OP_ENDIF-         <> BSB.word8 op_endif+  (RevocationPubkey rev)+  (RemoteHtlcPubkey remote)+  (LocalHtlcPubkey local)+  ph+  (CltvExpiry expiry)+  fmt = script $+       op op_dup <> op op_hash160+    <> push (hash160 (BOLT1.un_point rev))+    <> op op_equal+    <> op op_if+    <>   op op_checksig+    <> op op_else+    <>   push_point remote <> op op_swap <> op op_size+    <>   push (BS.singleton 32) <> op op_equal+    <>   op op_if+    <>     op op_hash160+    <>     push (RIPEMD160.hash (BOLT1.un_payment_hash ph))+    <>     op op_equalverify+    <>     op op_2 <> op op_swap <> push_point local+    <>     op op_2 <> op op_checkmultisig+    <>   op op_else+    <>     op op_drop <> push_num expiry+    <>     op op_checklocktimeverify <> op op_drop+    <>     op op_checksig+    <>   op op_endif+    <>   htlc_csv fmt+    <> op op_endif --- | Witness for remote node to timeout received HTLC.------ With option_anchors, input nSequence must be 1.+-- | The witness for the remote party to time out a received HTLC+--   output, given its witness script: ----- Witness: @<remotehtlcsig> <>@+--   @\<remotehtlcsig\> \<\> \<script\>@ ----- >>> received_htlc_witness_timeout sig--- Witness [sig, ""]-received_htlc_witness_timeout :: BS.ByteString -> Witness-received_htlc_witness_timeout !sig = Witness [sig, BS.empty]+--   Under 'Anchors' the spending input's @nSequence@ must be 1.+received_htlc_witness_timeout :: BS.ByteString -> Script -> Witness+received_htlc_witness_timeout sig = with_script [sig, BS.empty] --- | Witness for revocation spend of received HTLC.------ Witness: @<revocation_sig> <revocationpubkey>@+-- | The witness for the revocation spend of a received HTLC output,+--   given its witness script: ----- >>> received_htlc_witness_revoke sig revpk--- Witness [sig, revpk]-received_htlc_witness_revoke :: BS.ByteString -> Pubkey -> Witness-received_htlc_witness_revoke !sig (Pubkey !revpk) = Witness [sig, revpk]+--   @\<revocation_sig\> \<revocationpubkey\> \<script\>@+received_htlc_witness_revoke+  :: BS.ByteString -> RevocationPubkey -> Script -> Witness+received_htlc_witness_revoke sig (RevocationPubkey rev) =+  with_script [sig, BOLT1.un_point rev] --- HTLC-timeout/success output -------------------------------------------------+-- HTLC transaction inputs ---------------------------------------------------- --- | HTLC output witness script (same structure as to_local).------ Used for HTLC-timeout and HTLC-success transaction outputs.+-- | The witness for an HTLC-success transaction's input, given both+--   HTLC signatures, the payment preimage and the received HTLC+--   output's witness script: ----- Script:+--   @0 \<remotehtlcsig\> \<localhtlcsig\> \<payment_preimage\> \<script\>@ ----- @--- OP_IF---     <revocationpubkey>--- OP_ELSE---     <to_self_delay>---     OP_CHECKSEQUENCEVERIFY---     OP_DROP---     <local_delayedpubkey>--- OP_ENDIF--- OP_CHECKSIG--- @-htlc_output_script-  :: RevocationPubkey-  -> ToSelfDelay-  -> LocalDelayedPubkey-  -> Script-htlc_output_script = to_local_script+--   See 'remote_htlc_sighash' for the signatures' sighash types.+htlc_success_witness+  :: BS.ByteString    -- ^ remotehtlcsig+  -> BS.ByteString    -- ^ localhtlcsig+  -> PaymentPreimage+  -> Script           -- ^ the received HTLC output's witness script+  -> Witness+htlc_success_witness remote local pre =+  with_script [BS.empty, remote, local, BOLT1.un_payment_preimage pre] --- | Witness for delayed spend of HTLC output.+-- | The witness for an HTLC-timeout transaction's input, given both+--   HTLC signatures and the offered HTLC output's witness script: ----- Input nSequence must be set to to_self_delay.+--   @0 \<remotehtlcsig\> \<localhtlcsig\> \<\> \<script\>@ ----- Witness: @<local_delayedsig> 0@-htlc_output_witness_spend :: BS.ByteString -> Witness-htlc_output_witness_spend = to_local_witness_spend+--   See 'remote_htlc_sighash' for the signatures' sighash types.+htlc_timeout_witness+  :: BS.ByteString    -- ^ remotehtlcsig+  -> BS.ByteString    -- ^ localhtlcsig+  -> Script           -- ^ the offered HTLC output's witness script+  -> Witness+htlc_timeout_witness remote local =+  with_script [BS.empty, remote, local, BS.empty] --- | Witness for revocation spend of HTLC output.+-- | The sighash type of @remotehtlcsig@: the signature on an+--   HTLC-success or HTLC-timeout transaction that the commitment's+--   non-owner sends in @commitment_signed@. ----- Witness: @<revocationsig> 1@-htlc_output_witness_revoke :: BS.ByteString -> Witness-htlc_output_witness_revoke = to_local_witness_revoke+--   Under 'Anchors' it is @SIGHASH_SINGLE|SIGHASH_ANYONECANPAY@, so+--   that the owner can add inputs and outputs to pay the (otherwise+--   zero) fee; under 'StaticRemotekey' it is @SIGHASH_ALL@. The+--   owner's own signature, @localhtlcsig@, always uses @SIGHASH_ALL@.+--+--   >>> remote_htlc_sighash Anchors+--   SIGHASH_SINGLE_ANYONECANPAY+remote_htlc_sighash :: CommitmentFormat -> SighashType+remote_htlc_sighash fmt = case fmt of+  StaticRemotekey -> SIGHASH_ALL+  Anchors         -> SIGHASH_SINGLE_ANYONECANPAY

@@ -1,4 +1,4 @@-{-# OPTIONS_HADDOCK prune #-}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} @@ -8,584 +8,561 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Transaction assembly for BOLT #3.------ Constructs:------ * Commitment transactions--- * HTLC-timeout transactions--- * HTLC-success transactions--- * Closing transactions+-- Commitment, HTLC and closing transactions, per BOLT #3.  module Lightning.Protocol.BOLT3.Tx (-    -- * Commitment transaction-    CommitmentTx(..)-  , CommitmentContext(..)-  , CommitmentKeys(..)+    -- * Commitment transactions+    CommitmentContext(..)+  , CommitmentTx(..)+  , CommitmentOutput(..)+  , OutputType(..)   , build_commitment_tx      -- * HTLC transactions-  , HTLCTx(..)   , HTLCContext(..)-  , build_htlc_timeout_tx-  , build_htlc_success_tx+  , HTLCTx(..)+  , build_htlc_tx -    -- * Closing transaction+    -- * Closing transactions   , ClosingTx(..)+  , ClosingOutput(..)   , ClosingContext(..)+  , ClosingOutputs(..)   , build_closing_tx+  , LegacyClosingContext(..)   , build_legacy_closing_tx -    -- * Transaction outputs-  , TxOutput(..)-  , OutputType(..)--    -- * Fee calculation+    -- * Fees   , commitment_fee   , htlc_timeout_fee   , htlc_success_fee-  , commitment_weight      -- * Trimming-  , is_trimmed-  , trimmed_htlcs-  , untrimmed_htlcs   , htlc_trim_threshold+  , is_trimmed -    -- * Output ordering-  , sort_outputs+    -- * Serialization+  , commitment_to_tx+  , htlc_to_tx+  , closing_to_tx+  , encode_commitment_tx+  , encode_htlc_tx+  , encode_closing_tx   ) where -import Data.Bits ((.&.), (.|.), shiftL, shiftR)+import Bitcoin.Prim.Tx (OutPoint(..), TxId)+import qualified Bitcoin.Prim.Tx as BT+import Control.DeepSeq (NFData)+import Data.Bits ((.&.), (.|.), shiftR)+import qualified Data.ByteString as BS import Data.List (sortBy)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe) import Data.Word (Word32, Word64) import GHC.Generics (Generic)+import Lightning.Protocol.BOLT1 (Satoshi, MilliSatoshi)+import qualified Lightning.Protocol.BOLT1 as BOLT1 import Lightning.Protocol.BOLT3.Keys import Lightning.Protocol.BOLT3.Scripts import Lightning.Protocol.BOLT3.Types --- transaction outputs ---------------------------------------------------------+-- commitment transactions ---------------------------------------------------- --- | Type of output in a commitment transaction.+-- | What a commitment transaction output pays. data OutputType   = OutputToLocal   | OutputToRemote   | OutputLocalAnchor   | OutputRemoteAnchor-  | OutputOfferedHTLC  {-# UNPACK #-} !CltvExpiry-  | OutputReceivedHTLC {-# UNPACK #-} !CltvExpiry+  | OutputHTLC !HTLC+    -- ^ an offered or received HTLC (per its 'htlc_direction')   deriving (Eq, Show, Generic) --- | A transaction output with value, script, and type information.-data TxOutput = TxOutput-  { txout_value     :: {-# UNPACK #-} !Satoshi-  , txout_script    :: !Script-  , txout_type      :: !OutputType-  } deriving (Eq, Show, Generic)---- commitment transaction ------------------------------------------------------+instance NFData OutputType --- | Derived keys needed for commitment transaction outputs.-data CommitmentKeys = CommitmentKeys-  { ck_revocation_pubkey   :: !RevocationPubkey-  , ck_local_delayed       :: !LocalDelayedPubkey-  , ck_local_htlc          :: !LocalHtlcPubkey-  , ck_remote_htlc         :: !RemoteHtlcPubkey-  , ck_local_payment       :: !LocalPubkey-  , ck_remote_payment      :: !RemotePubkey-  , ck_local_funding       :: !FundingPubkey-  , ck_remote_funding      :: !FundingPubkey+-- | A commitment transaction output.+data CommitmentOutput = CommitmentOutput+  { co_value  :: {-# UNPACK #-} !Satoshi+  , co_script :: !Script     -- ^ scriptPubKey+  , co_type   :: !OutputType   } deriving (Eq, Show, Generic) --- | Context for building a commitment transaction.+instance NFData CommitmentOutput++-- | The parameters of a commitment transaction, from the point of view+--   of its owner (the "local" party, whose outputs are delayed). data CommitmentContext = CommitmentContext-  { cc_funding_outpoint    :: !Outpoint-  , cc_commitment_number   :: !CommitmentNumber-  , cc_local_payment_bp    :: !PaymentBasepoint-  , cc_remote_payment_bp   :: !PaymentBasepoint-  , cc_to_self_delay       :: !ToSelfDelay-  , cc_dust_limit          :: !DustLimit-  , cc_feerate             :: !FeeratePerKw-  , cc_features            :: !ChannelFeatures-  , cc_is_funder           :: !Bool-  , cc_to_local_msat       :: !MilliSatoshi-  , cc_to_remote_msat      :: !MilliSatoshi-  , cc_htlcs               :: ![HTLC]-  , cc_keys                :: !CommitmentKeys+  { cc_funding_outpoint  :: {-# UNPACK #-} !OutPoint+  , cc_commitment_number :: {-# UNPACK #-} !CommitmentNumber+  , cc_local_payment_bp  :: !PaymentBasepoint+    -- ^ the owner's @payment_basepoint@+  , cc_remote_payment_bp :: !PaymentBasepoint+    -- ^ the other party's @payment_basepoint@+  , cc_to_self_delay     :: {-# UNPACK #-} !ToSelfDelay+    -- ^ the delay on the owner's outputs (set by the other party)+  , cc_dust_limit        :: {-# UNPACK #-} !DustLimit+    -- ^ the owner's @dust_limit_satoshis@+  , cc_feerate           :: {-# UNPACK #-} !FeeratePerKw+  , cc_format            :: !CommitmentFormat+  , cc_is_funder         :: !Bool+    -- ^ whether the owner opened the channel, and so pays the fee+  , cc_to_local_msat     :: {-# UNPACK #-} !MilliSatoshi+  , cc_to_remote_msat    :: {-# UNPACK #-} !MilliSatoshi+  , cc_htlcs             :: ![HTLC]+  , cc_keys              :: !CommitmentKeys   } deriving (Eq, Show, Generic) --- | A commitment transaction.+instance NFData CommitmentContext++-- | An unsigned commitment transaction. data CommitmentTx = CommitmentTx-  { ctx_version            :: {-# UNPACK #-} !Word32-  , ctx_locktime           :: !Locktime-  , ctx_input_outpoint     :: !Outpoint-  , ctx_input_sequence     :: !Sequence-  , ctx_outputs            :: ![TxOutput]-  , ctx_funding_script     :: !Script+  { ctx_version        :: {-# UNPACK #-} !Word32+  , ctx_locktime       :: {-# UNPACK #-} !Locktime+  , ctx_input_outpoint :: {-# UNPACK #-} !OutPoint+  , ctx_input_sequence :: {-# UNPACK #-} !Sequence+  , ctx_outputs        :: !(NonEmpty CommitmentOutput)+    -- ^ in BIP69+CLTV order+  , ctx_funding_script :: !Script+    -- ^ the funding output's witness script, which signatures commit+    --   to   } deriving (Eq, Show, Generic) --- | Build a commitment transaction.+instance NFData CommitmentTx++-- | Build a commitment transaction, per BOLT #3's "Commitment+--   Transaction Construction": ----- Follows the algorithm from BOLT #3:+--   * the locktime and input sequence encode the obscured commitment+--     number (the payment basepoints are ordered by 'cc_is_funder');+--   * HTLCs whose amount, less the HTLC transaction fee, is below the+--     dust limit are trimmed;+--   * the base fee (and under 'Anchors', both anchors) are taken from+--     the funder's output, which is left at zero if it can't cover+--     them;+--   * @to_local@ and @to_remote@ outputs below the dust limit are+--     omitted, and under 'Anchors' each party's anchor is added if its+--     output, or any HTLC output, exists;+--   * outputs are sorted by value, scriptPubKey and CLTV expiry. ----- 1. Initialize input and locktime with obscured commitment number--- 2. Calculate which HTLCs are trimmed--- 3. Calculate base fee and subtract from funder--- 4. Add untrimmed HTLC outputs--- 5. Add to_local output if above dust--- 6. Add to_remote output if above dust--- 7. Add anchor outputs if option_anchors--- 8. Sort outputs per BIP69+CLTV-build_commitment_tx :: CommitmentContext -> CommitmentTx-build_commitment_tx ctx =-  let !obscured = obscured_commitment_number-        (cc_local_payment_bp ctx)-        (cc_remote_payment_bp ctx)-        (cc_commitment_number ctx)+--   Fails if the transaction would have no outputs.+build_commitment_tx :: CommitmentContext -> Maybe CommitmentTx+build_commitment_tx ctx = do+    outputs <- NE.nonEmpty . sort_outputs $+      to_local <> to_remote <> local_anchor <> remote_anchor <> htlcs+    pure CommitmentTx+      { ctx_version        = 2+      , ctx_locktime       =+          Locktime (0x20000000 .|. (fromIntegral obscured .&. 0xFFFFFF))+      , ctx_input_outpoint = cc_funding_outpoint ctx+      , ctx_input_sequence =+          Sequence+            (0x80000000 .|. (fromIntegral (obscured `shiftR` 24) .&. 0xFFFFFF))+      , ctx_outputs        = outputs+      , ctx_funding_script =+          funding_script (ck_local_funding keys) (ck_remote_funding keys)+      }+  where+    !keys = cc_keys ctx+    !fmt  = cc_format ctx+    !rate = cc_feerate ctx+    !dust = cc_dust_limit ctx+    DustLimit dust_sat = dust -      -- Locktime: upper 8 bits are 0x20, lower 24 bits are lower 24 of obscured-      !locktime = Locktime $-        (0x20 `shiftL` 24) .|. (fromIntegral obscured .&. 0x00FFFFFF)+    (!opener, !accepter)+      | cc_is_funder ctx = (cc_local_payment_bp ctx, cc_remote_payment_bp ctx)+      | otherwise        = (cc_remote_payment_bp ctx, cc_local_payment_bp ctx)+    !obscured =+      obscured_commitment_number opener accepter (cc_commitment_number ctx) -      -- Sequence: upper 8 bits are 0x80, lower 24 bits are upper 24 of obscured-      !inputSeq = Sequence $-        (0x80 `shiftL` 24) .|.-        (fromIntegral (obscured `shiftR` 24) .&. 0x00FFFFFF)+    untrimmed = filter (not . is_trimmed dust rate fmt) (cc_htlcs ctx) -      -- Funding script for witness-      !fundingScript = funding_script-        (ck_local_funding $ cc_keys ctx)-        (ck_remote_funding $ cc_keys ctx)+    !fee = commitment_fee rate fmt (fromIntegral (length untrimmed))+    !deduction = case fmt of+      StaticRemotekey -> fee+      Anchors         ->+        fromMaybe BOLT1.max_satoshi (BOLT1.add_sat fee (sat 660))+    deduct s = fromMaybe (sat 0) (BOLT1.sub_sat s deduction) -      -- Calculate untrimmed HTLCs-      !untrimmedHtlcs = untrimmed_htlcs-        (cc_dust_limit ctx)-        (cc_feerate ctx)-        (cc_features ctx)-        (cc_htlcs ctx)+    !local_sat  = BOLT1.msat_to_sat (cc_to_local_msat ctx)+    !remote_sat = BOLT1.msat_to_sat (cc_to_remote_msat ctx)+    (!to_local_sat, !to_remote_sat)+      | cc_is_funder ctx = (deduct local_sat, remote_sat)+      | otherwise        = (local_sat, deduct remote_sat) -      -- Calculate base fee-      !baseFee = commitment_fee-        (cc_feerate ctx)-        (cc_features ctx)-        (fromIntegral $ length untrimmedHtlcs)+    to_local =+      [ CommitmentOutput to_local_sat+          (to_p2wsh (to_local_script (ck_revocation_pubkey keys)+                       (cc_to_self_delay ctx) (ck_local_delayed keys)))+          OutputToLocal+      | to_local_sat >= dust_sat ] -      -- Anchor cost if applicable-      !anchorCost = if has_anchors (cc_features ctx)-        then 2 * anchor_output_value-        else Satoshi 0+    to_remote =+      [ CommitmentOutput to_remote_sat+          (to_remote_script_pubkey (ck_remote_payment keys) fmt)+          OutputToRemote+      | to_remote_sat >= dust_sat ] -      -- Subtract fees and anchors from funder-      !totalDeduction = baseFee + anchorCost-      !(toLocalSat, toRemoteSat) = if cc_is_funder ctx-        then-          let !local = msat_to_sat (cc_to_local_msat ctx)-              !deducted = if unSatoshi local >= unSatoshi totalDeduction-                          then Satoshi (unSatoshi local - unSatoshi totalDeduction)-                          else Satoshi 0-          in (deducted, msat_to_sat (cc_to_remote_msat ctx))-        else-          let !remote = msat_to_sat (cc_to_remote_msat ctx)-              !deducted = if unSatoshi remote >= unSatoshi totalDeduction-                          then Satoshi (unSatoshi remote - unSatoshi totalDeduction)-                          else Satoshi 0-          in (msat_to_sat (cc_to_local_msat ctx), deducted)+    has_htlcs = not (null untrimmed)+    anchor pk ty = CommitmentOutput anchor_output_value+      (to_p2wsh (anchor_script pk)) ty -      !dustLimit = unDustLimit (cc_dust_limit ctx)+    local_anchor = case fmt of+      Anchors | not (null to_local) || has_htlcs ->+        [anchor (ck_local_funding keys) OutputLocalAnchor]+      _ -> [] -      -- Build HTLC outputs-      !htlcOutputs = map (htlcOutput ctx) untrimmedHtlcs+    remote_anchor = case fmt of+      Anchors | not (null to_remote) || has_htlcs ->+        [anchor (ck_remote_funding keys) OutputRemoteAnchor]+      _ -> [] -      -- Build to_local output if above dust-      !toLocalOutput =-        if unSatoshi toLocalSat >= unSatoshi dustLimit-        then-          let !script = to_p2wsh $ to_local_script-                (ck_revocation_pubkey $ cc_keys ctx)-                (cc_to_self_delay ctx)-                (ck_local_delayed $ cc_keys ctx)-          in [TxOutput toLocalSat script OutputToLocal]-        else []+    htlcs = fmap htlc_output untrimmed -      -- Build to_remote output if above dust-      !toRemoteOutput =-        if unSatoshi toRemoteSat >= unSatoshi dustLimit-        then-          let !script = if has_anchors (cc_features ctx)-                then to_p2wsh $ to_remote_script-                       (ck_remote_payment $ cc_keys ctx)-                       (cc_features ctx)-                else to_remote_script-                       (ck_remote_payment $ cc_keys ctx)-                       (cc_features ctx)-          in [TxOutput toRemoteSat script OutputToRemote]-        else []+    htlc_output h =+      let !script = case htlc_direction h of+            HTLCOffered  -> offered_htlc_script+              (ck_revocation_pubkey keys) (ck_remote_htlc keys)+              (ck_local_htlc keys) (htlc_payment_hash h) fmt+            HTLCReceived -> received_htlc_script+              (ck_revocation_pubkey keys) (ck_remote_htlc keys)+              (ck_local_htlc keys) (htlc_payment_hash h)+              (htlc_cltv_expiry h) fmt+      in  CommitmentOutput (BOLT1.msat_to_sat (htlc_amount_msat h))+            (to_p2wsh script) (OutputHTLC h) -      -- Build anchor outputs if option_anchors-      !hasUntrimmedHtlcs = not (null untrimmedHtlcs)-      !toLocalExists = not (null toLocalOutput)-      !toRemoteExists = not (null toRemoteOutput)+-- BIP69+CLTV order: value, then scriptPubKey, then (for HTLCs) CLTV+-- expiry.+sort_outputs :: [CommitmentOutput] -> [CommitmentOutput]+sort_outputs = sortBy cmp where+  cmp a b = compare (co_value a) (co_value b)+         <> compare (co_script a) (co_script b)+         <> compare (cltv (co_type a)) (cltv (co_type b))+  cltv t = case t of+    OutputHTLC h -> Just (htlc_cltv_expiry h)+    _            -> Nothing -      !localAnchorOutput =-        if has_anchors (cc_features ctx) &&-           (toLocalExists || hasUntrimmedHtlcs)-        then-          let !script = to_p2wsh $ anchor_script-                (ck_local_funding $ cc_keys ctx)-          in [TxOutput anchor_output_value script OutputLocalAnchor]-        else []+-- HTLC transactions ---------------------------------------------------------- -      !remoteAnchorOutput =-        if has_anchors (cc_features ctx) &&-           (toRemoteExists || hasUntrimmedHtlcs)-        then-          let !script = to_p2wsh $ anchor_script-                (ck_remote_funding $ cc_keys ctx)-          in [TxOutput anchor_output_value script OutputRemoteAnchor]-        else []+-- | The parameters of an HTLC-success or HTLC-timeout transaction,+--   spending an HTLC output of the owner's commitment transaction.+data HTLCContext = HTLCContext+  { hc_commitment_txid   :: !TxId+  , hc_output_index      :: {-# UNPACK #-} !Word32+  , hc_htlc              :: !HTLC+  , hc_to_self_delay     :: {-# UNPACK #-} !ToSelfDelay+  , hc_feerate           :: {-# UNPACK #-} !FeeratePerKw+  , hc_format            :: !CommitmentFormat+  , hc_revocation_pubkey :: !RevocationPubkey+  , hc_local_delayed     :: !LocalDelayedPubkey+  } deriving (Eq, Show, Generic) -      -- Combine and sort all outputs-      !allOutputs = toLocalOutput ++ toRemoteOutput ++-                    localAnchorOutput ++ remoteAnchorOutput ++-                    htlcOutputs-      !sortedOutputs = sort_outputs allOutputs+instance NFData HTLCContext -  in CommitmentTx-       { ctx_version = 2-       , ctx_locktime = locktime-       , ctx_input_outpoint = cc_funding_outpoint ctx-       , ctx_input_sequence = inputSeq-       , ctx_outputs = sortedOutputs-       , ctx_funding_script = fundingScript-       }-{-# INLINE build_commitment_tx #-}+-- | An unsigned HTLC-success or HTLC-timeout transaction.+data HTLCTx = HTLCTx+  { htx_version        :: {-# UNPACK #-} !Word32+  , htx_locktime       :: {-# UNPACK #-} !Locktime+  , htx_input_outpoint :: {-# UNPACK #-} !OutPoint+  , htx_input_sequence :: {-# UNPACK #-} !Sequence+  , htx_output_value   :: {-# UNPACK #-} !Satoshi+  , htx_output_script  :: !Script+  } deriving (Eq, Show, Generic) --- | Build an HTLC output for commitment transaction.-htlcOutput :: CommitmentContext -> HTLC -> TxOutput-htlcOutput ctx htlc =-  let !amountSat = msat_to_sat (htlc_amount_msat htlc)-      !keys = cc_keys ctx-      !features = cc_features ctx-      !expiry = htlc_cltv_expiry htlc-  in case htlc_direction htlc of-       HTLCOffered ->-         let !script = to_p2wsh $ offered_htlc_script-               (ck_revocation_pubkey keys)-               (ck_remote_htlc keys)-               (ck_local_htlc keys)-               (htlc_payment_hash htlc)-               features-         in TxOutput amountSat script (OutputOfferedHTLC expiry)-       HTLCReceived ->-         let !script = to_p2wsh $ received_htlc_script-               (ck_revocation_pubkey keys)-               (ck_remote_htlc keys)-               (ck_local_htlc keys)-               (htlc_payment_hash htlc)-               expiry-               features-         in TxOutput amountSat script (OutputReceivedHTLC expiry)-{-# INLINE htlcOutput #-}+instance NFData HTLCTx --- HTLC transactions -----------------------------------------------------------+-- | Build the second-stage transaction for an HTLC output of the+--   owner's commitment transaction: HTLC-timeout (locktime+--   @cltv_expiry@) for an offered HTLC, and HTLC-success (locktime 0)+--   for a received one.+--+--   The output pays the HTLC amount, less the HTLC transaction fee+--   (zero under 'Anchors'), to the 'to_local_script' of the owner's+--   keys. Fails if the fee exceeds the amount (such an HTLC is always+--   trimmed).+build_htlc_tx :: HTLCContext -> Maybe HTLCTx+build_htlc_tx ctx = do+    value <- BOLT1.sub_sat (BOLT1.msat_to_sat (htlc_amount_msat h)) fee+    pure HTLCTx+      { htx_version        = 2+      , htx_locktime       = locktime+      , htx_input_outpoint =+          OutPoint (hc_commitment_txid ctx) (hc_output_index ctx)+      , htx_input_sequence = case fmt of+          StaticRemotekey -> Sequence 0+          Anchors         -> Sequence 1+      , htx_output_value   = value+      , htx_output_script  = to_p2wsh $ to_local_script+          (hc_revocation_pubkey ctx) (hc_to_self_delay ctx)+          (hc_local_delayed ctx)+      }+  where+    !h = hc_htlc ctx+    !fmt = hc_format ctx+    (!fee, !locktime) = case htlc_direction h of+      HTLCOffered  ->+        let CltvExpiry e = htlc_cltv_expiry h+        in  (htlc_timeout_fee (hc_feerate ctx) fmt, Locktime e)+      HTLCReceived ->+        (htlc_success_fee (hc_feerate ctx) fmt, Locktime 0) --- | Context for building HTLC transactions.-data HTLCContext = HTLCContext-  { hc_commitment_txid     :: !TxId-  , hc_output_index        :: {-# UNPACK #-} !Word32-  , hc_htlc                :: !HTLC-  , hc_to_self_delay       :: !ToSelfDelay-  , hc_feerate             :: !FeeratePerKw-  , hc_features            :: !ChannelFeatures-  , hc_revocation_pubkey   :: !RevocationPubkey-  , hc_local_delayed       :: !LocalDelayedPubkey-  } deriving (Eq, Show, Generic)+-- closing transactions ------------------------------------------------------- --- | An HTLC transaction (timeout or success).-data HTLCTx = HTLCTx-  { htx_version            :: {-# UNPACK #-} !Word32-  , htx_locktime           :: !Locktime-  , htx_input_outpoint     :: !Outpoint-  , htx_input_sequence     :: !Sequence-  , htx_output_value       :: !Satoshi-  , htx_output_script      :: !Script+-- | A closing transaction output.+data ClosingOutput = ClosingOutput+  { clo_value  :: {-# UNPACK #-} !Satoshi+  , clo_script :: !Script     -- ^ scriptPubKey   } deriving (Eq, Show, Generic) --- | Internal helper for HTLC transaction construction.------ Both HTLC-timeout and HTLC-success transactions share the same--- structure, differing only in locktime and fee calculation.-build_htlc_tx_common-  :: HTLCContext-  -> Locktime           -- ^ Transaction locktime-  -> Satoshi            -- ^ Fee to subtract from output-  -> HTLCTx-build_htlc_tx_common ctx locktime fee =-  let !amountSat = msat_to_sat (htlc_amount_msat $ hc_htlc ctx)-      !outputValue = if unSatoshi amountSat >= unSatoshi fee-                     then Satoshi (unSatoshi amountSat - unSatoshi fee)-                     else Satoshi 0-      !inputSeq = if has_anchors (hc_features ctx)-                   then Sequence 1-                   else Sequence 0-      !outpoint = Outpoint (hc_commitment_txid ctx) (hc_output_index ctx)-      !outputScript = to_p2wsh $ htlc_output_script-        (hc_revocation_pubkey ctx)-        (hc_to_self_delay ctx)-        (hc_local_delayed ctx)-  in HTLCTx-       { htx_version = 2-       , htx_locktime = locktime-       , htx_input_outpoint = outpoint-       , htx_input_sequence = inputSeq-       , htx_output_value = outputValue-       , htx_output_script = outputScript-       }-{-# INLINE build_htlc_tx_common #-}+instance NFData ClosingOutput --- | Build an HTLC-timeout transaction.------ * locktime: cltv_expiry--- * sequence: 0 (or 1 with option_anchors)--- * output: to_local style script with revocation and delayed paths-build_htlc_timeout_tx :: HTLCContext -> HTLCTx-build_htlc_timeout_tx ctx =-  let !fee = htlc_timeout_fee (hc_feerate ctx) (hc_features ctx)-      !locktime = Locktime (unCltvExpiry $ htlc_cltv_expiry $ hc_htlc ctx)-  in build_htlc_tx_common ctx locktime fee-{-# INLINE build_htlc_timeout_tx #-}+-- | An unsigned closing transaction.+data ClosingTx = ClosingTx+  { cltx_version        :: {-# UNPACK #-} !Word32+  , cltx_locktime       :: {-# UNPACK #-} !Locktime+  , cltx_input_outpoint :: {-# UNPACK #-} !OutPoint+  , cltx_input_sequence :: {-# UNPACK #-} !Sequence+  , cltx_outputs        :: !(NonEmpty ClosingOutput)+    -- ^ in BIP69 order+  } deriving (Eq, Show, Generic) --- | Build an HTLC-success transaction.------ * locktime: 0--- * sequence: 0 (or 1 with option_anchors)--- * output: to_local style script with revocation and delayed paths-build_htlc_success_tx :: HTLCContext -> HTLCTx-build_htlc_success_tx ctx =-  let !fee = htlc_success_fee (hc_feerate ctx) (hc_features ctx)-  in build_htlc_tx_common ctx (Locktime 0) fee-{-# INLINE build_htlc_success_tx #-}+instance NFData ClosingTx --- closing transaction ---------------------------------------------------------+-- | Which outputs an @option_simple_close@ closing transaction has,+--   matching the signature fields of @closing_complete@.+data ClosingOutputs+  = CloserOutputOnly+  | CloseeOutputOnly+  | CloserAndCloseeOutputs+  deriving (Eq, Show, Generic) --- | Context for building closing transactions.+instance NFData ClosingOutputs++-- | The parameters of an @option_simple_close@ closing transaction,+--   as given by a @closing_complete@ message. data ClosingContext = ClosingContext-  { clc_funding_outpoint   :: !Outpoint-  , clc_local_amount       :: !Satoshi-  , clc_remote_amount      :: !Satoshi-  , clc_local_script       :: !Script-  , clc_remote_script      :: !Script-  , clc_local_dust_limit   :: !DustLimit-  , clc_remote_dust_limit  :: !DustLimit-  , clc_fee                :: !Satoshi-  , clc_is_funder          :: !Bool-  , clc_locktime           :: !Locktime-  , clc_funding_script     :: !Script+  { clc_funding_outpoint :: {-# UNPACK #-} !OutPoint+  , clc_closer_msat      :: {-# UNPACK #-} !MilliSatoshi+    -- ^ the closer's final balance+  , clc_closee_msat      :: {-# UNPACK #-} !MilliSatoshi+    -- ^ the closee's final balance+  , clc_closer_script    :: !Script+  , clc_closee_script    :: !Script+  , clc_fee              :: {-# UNPACK #-} !Satoshi+  , clc_locktime         :: {-# UNPACK #-} !Locktime+  , clc_outputs          :: !ClosingOutputs   } deriving (Eq, Show, Generic) --- | A closing transaction.-data ClosingTx = ClosingTx-  { cltx_version           :: {-# UNPACK #-} !Word32-  , cltx_locktime          :: !Locktime-  , cltx_input_outpoint    :: !Outpoint-  , cltx_input_sequence    :: !Sequence-  , cltx_outputs           :: ![TxOutput]-  , cltx_funding_script    :: !Script-  } deriving (Eq, Show, Generic)+instance NFData ClosingContext --- | Build a closing transaction (option_simple_close).+-- | Build an @option_simple_close@ closing transaction (BOLT #3's+--   "Closing Transaction"), for @closing_complete@ and @closing_sig@. ----- * locktime: from closing_complete message--- * sequence: 0xFFFFFFFD--- * outputs: sorted per BIP69-build_closing_tx :: ClosingContext -> ClosingTx-build_closing_tx ctx =-  let -- Subtract fee from closer-      !(localAmt, remoteAmt) = if clc_is_funder ctx-        then-          let !deducted = if unSatoshi (clc_local_amount ctx) >=-                             unSatoshi (clc_fee ctx)-                          then Satoshi (unSatoshi (clc_local_amount ctx) --                                        unSatoshi (clc_fee ctx))-                          else Satoshi 0-          in (deducted, clc_remote_amount ctx)-        else-          let !deducted = if unSatoshi (clc_remote_amount ctx) >=-                             unSatoshi (clc_fee ctx)-                          then Satoshi (unSatoshi (clc_remote_amount ctx) --                                        unSatoshi (clc_fee ctx))-                          else Satoshi 0-          in (clc_local_amount ctx, deducted)+--   The closer pays the fee: its output is its balance, rounded down+--   to whole satoshis, less the fee. An output whose scriptPubKey+--   starts with @OP_RETURN@ has amount 0. Only the chosen outputs are+--   included, and none is trimmed. Fails if the fee exceeds the+--   closer's balance.+build_closing_tx :: ClosingContext -> Maybe ClosingTx+build_closing_tx ctx = do+    closer_sat <-+      BOLT1.sub_sat (BOLT1.msat_to_sat (clc_closer_msat ctx)) (clc_fee ctx)+    let !closer = output closer_sat (clc_closer_script ctx)+        !closee = output (BOLT1.msat_to_sat (clc_closee_msat ctx))+                    (clc_closee_script ctx)+    pure ClosingTx+      { cltx_version        = 2+      , cltx_locktime       = clc_locktime ctx+      , cltx_input_outpoint = clc_funding_outpoint ctx+      , cltx_input_sequence = Sequence 0xFFFFFFFD+      , cltx_outputs        = case clc_outputs ctx of+          CloserOutputOnly       -> closer :| []+          CloseeOutputOnly       -> closee :| []+          CloserAndCloseeOutputs -> sort_closing (closer :| [closee])+      }+  where+    output amt spk@(Script s) = case BS.uncons s of+      Just (0x6a, _) -> ClosingOutput (sat 0) spk+      _              -> ClosingOutput amt spk -      -- Build outputs, omitting dust-      !localOutput =-        if unSatoshi localAmt >= unSatoshi (unDustLimit $ clc_local_dust_limit ctx)-        then [TxOutput localAmt (clc_local_script ctx) OutputToLocal]-        else []+-- | The parameters of a legacy closing transaction (for+--   @closing_signed@), from the point of view of the node producing+--   the signature (the "local" party).+data LegacyClosingContext = LegacyClosingContext+  { lcc_funding_outpoint :: {-# UNPACK #-} !OutPoint+  , lcc_local_msat       :: {-# UNPACK #-} !MilliSatoshi+  , lcc_remote_msat      :: {-# UNPACK #-} !MilliSatoshi+  , lcc_local_script     :: !Script+  , lcc_remote_script    :: !Script+  , lcc_dust_limit       :: {-# UNPACK #-} !DustLimit+    -- ^ the signer's @dust_limit_satoshis@+  , lcc_fee              :: {-# UNPACK #-} !Satoshi+  , lcc_is_funder        :: !Bool+    -- ^ whether the signer funded the channel, and so pays the fee+  , lcc_omit_local       :: !Bool+    -- ^ whether the signer eliminates its own output+  } deriving (Eq, Show, Generic) -      !remoteOutput =-        if unSatoshi remoteAmt >= unSatoshi (unDustLimit $ clc_remote_dust_limit ctx)-        then [TxOutput remoteAmt (clc_remote_script ctx) OutputToRemote]-        else []+instance NFData LegacyClosingContext -      !allOutputs = localOutput ++ remoteOutput-      !sortedOutputs = sort_outputs allOutputs+-- | Build a legacy closing transaction (BOLT #3's "Legacy Closing+--   Transaction"), for @closing_signed@.+--+--   Balances are rounded down to whole satoshis and the fee is taken+--   from the funder's output. Outputs below the signer's dust limit+--   are removed, as is the signer's own output if 'lcc_omit_local' is+--   set. Fails if the fee exceeds the funder's balance, or if no+--   output remains.+build_legacy_closing_tx :: LegacyClosingContext -> Maybe ClosingTx+build_legacy_closing_tx ctx = do+    let !local_sat  = BOLT1.msat_to_sat (lcc_local_msat ctx)+        !remote_sat = BOLT1.msat_to_sat (lcc_remote_msat ctx)+        DustLimit dust = lcc_dust_limit ctx+    (l, r) <-+      if   lcc_is_funder ctx+      then fmap (\x -> (x, remote_sat)) (BOLT1.sub_sat local_sat fee)+      else fmap (\x -> (local_sat, x)) (BOLT1.sub_sat remote_sat fee)+    outputs <- NE.nonEmpty $+         [ ClosingOutput l (lcc_local_script ctx)+         | not (lcc_omit_local ctx), l >= dust ]+      <> [ ClosingOutput r (lcc_remote_script ctx) | r >= dust ]+    pure ClosingTx+      { cltx_version        = 2+      , cltx_locktime       = Locktime 0+      , cltx_input_outpoint = lcc_funding_outpoint ctx+      , cltx_input_sequence = Sequence 0xFFFFFFFF+      , cltx_outputs        = sort_closing outputs+      }+  where+    !fee = lcc_fee ctx -  in ClosingTx-       { cltx_version = 2-       , cltx_locktime = clc_locktime ctx-       , cltx_input_outpoint = clc_funding_outpoint ctx-       , cltx_input_sequence = Sequence 0xFFFFFFFD-       , cltx_outputs = sortedOutputs-       , cltx_funding_script = clc_funding_script ctx-       }-{-# INLINE build_closing_tx #-}+-- BIP69 order: value, then scriptPubKey.+sort_closing :: NonEmpty ClosingOutput -> NonEmpty ClosingOutput+sort_closing = NE.sortBy $ \a b ->+  compare (clo_value a) (clo_value b) <> compare (clo_script a) (clo_script b) --- | Build a legacy closing transaction (closing_signed).------ * locktime: 0--- * sequence: 0xFFFFFFFF--- * outputs: sorted per BIP69-build_legacy_closing_tx :: ClosingContext -> ClosingTx-build_legacy_closing_tx ctx =-  let !result = build_closing_tx ctx-        { clc_locktime = Locktime 0 }-  in result { cltx_input_sequence = Sequence 0xFFFFFFFF }-{-# INLINE build_legacy_closing_tx #-}+-- fees ----------------------------------------------------------------------- --- fee calculation -------------------------------------------------------------+-- feerate * weight / 1000, saturating at 21 million BTC.+weight_fee :: FeeratePerKw -> Integer -> Satoshi+weight_fee (FeeratePerKw rate) weight =+  let !f = toInteger rate * weight `quot` 1000+  in  if   f > toInteger (BOLT1.un_satoshi BOLT1.max_satoshi)+      then BOLT1.max_satoshi+      else sat (fromInteger f) --- | Calculate the base commitment transaction fee.+-- | The base fee of a commitment transaction with a given number of+--   untrimmed HTLC outputs: ----- @fee = feerate_per_kw * weight / 1000@+--   @feerate_per_kw * (724 + 172 * num_htlcs) / 1000@ ----- where @weight = base_weight + 172 * num_htlcs@-commitment_fee :: FeeratePerKw -> ChannelFeatures -> Word64 -> Satoshi-commitment_fee feerate features numHtlcs =-  let !weight = commitment_weight features numHtlcs-      !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000-  in Satoshi fee-{-# INLINE commitment_fee #-}---- | Calculate commitment transaction weight.+--   with a base weight of 1124 rather than 724 under 'Anchors'. ----- @weight = base + 172 * num_htlcs@-commitment_weight :: ChannelFeatures -> Word64 -> Word64-commitment_weight features numHtlcs =-  let !base = if has_anchors features-              then commitment_weight_anchors-              else commitment_weight_no_anchors-  in base + htlc_output_weight * numHtlcs-{-# INLINE commitment_weight #-}+--   >>> commitment_fee (FeeratePerKw 5000) StaticRemotekey 2+--   Satoshi 5340+commitment_fee :: FeeratePerKw -> CommitmentFormat -> Word64 -> Satoshi+commitment_fee rate fmt n = weight_fee rate (base + 172 * toInteger n) where+  base = case fmt of+    StaticRemotekey -> 724+    Anchors         -> 1124 --- | Calculate HTLC-timeout transaction fee.+-- | The fee of an HTLC-timeout transaction: @feerate_per_kw * 663 /+--   1000@, or zero under 'Anchors'. ----- With option_anchors, fee is 0 (CPFP).--- Otherwise, @fee = feerate_per_kw * 663 / 1000@-htlc_timeout_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi-htlc_timeout_fee feerate features-  | has_anchors features = Satoshi 0-  | otherwise =-      let !weight = htlc_timeout_weight_no_anchors-          !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000-      in Satoshi fee-{-# INLINE htlc_timeout_fee #-}+--   >>> htlc_timeout_fee (FeeratePerKw 5000) StaticRemotekey+--   Satoshi 3315+htlc_timeout_fee :: FeeratePerKw -> CommitmentFormat -> Satoshi+htlc_timeout_fee rate fmt = case fmt of+  StaticRemotekey -> weight_fee rate 663+  Anchors         -> sat 0 --- | Calculate HTLC-success transaction fee.+-- | The fee of an HTLC-success transaction: @feerate_per_kw * 703 /+--   1000@, or zero under 'Anchors'. ----- With option_anchors, fee is 0 (CPFP).--- Otherwise, @fee = feerate_per_kw * 703 / 1000@-htlc_success_fee :: FeeratePerKw -> ChannelFeatures -> Satoshi-htlc_success_fee feerate features-  | has_anchors features = Satoshi 0-  | otherwise =-      let !weight = htlc_success_weight_no_anchors-          !fee = (fromIntegral (unFeeratePerKw feerate) * weight) `div` 1000-      in Satoshi fee-{-# INLINE htlc_success_fee #-}+--   >>> htlc_success_fee (FeeratePerKw 5000) StaticRemotekey+--   Satoshi 3515+htlc_success_fee :: FeeratePerKw -> CommitmentFormat -> Satoshi+htlc_success_fee rate fmt = case fmt of+  StaticRemotekey -> weight_fee rate 703+  Anchors         -> sat 0 --- trimming --------------------------------------------------------------------+-- trimming ------------------------------------------------------------------- --- | Calculate the trim threshold for an HTLC.+-- | The amount below which an HTLC in a given direction is trimmed:+--   the dust limit plus the fee of its HTLC transaction. ----- An HTLC is trimmed if:--- @amount < dust_limit + htlc_tx_fee@+--   >>> let Just d = fmap DustLimit (BOLT1.satoshi 546)+--   >>> htlc_trim_threshold d (FeeratePerKw 5000) StaticRemotekey HTLCOffered+--   Satoshi 3861 htlc_trim_threshold   :: DustLimit   -> FeeratePerKw-  -> ChannelFeatures+  -> CommitmentFormat   -> HTLCDirection   -> Satoshi-htlc_trim_threshold dust feerate features direction =-  let !dustVal = unDustLimit dust-      !htlcFee = case direction of-        HTLCOffered  -> htlc_timeout_fee feerate features-        HTLCReceived -> htlc_success_fee feerate features-  in Satoshi (unSatoshi dustVal + unSatoshi htlcFee)-{-# INLINE htlc_trim_threshold #-}+htlc_trim_threshold (DustLimit dust) rate fmt dir =+  let !fee = case dir of+        HTLCOffered  -> htlc_timeout_fee rate fmt+        HTLCReceived -> htlc_success_fee rate fmt+  in  fromMaybe BOLT1.max_satoshi (BOLT1.add_sat dust fee) --- | Check if an HTLC should be trimmed.------ An HTLC is trimmed if its amount minus the HTLC tx fee is below--- the dust limit.-is_trimmed :: DustLimit -> FeeratePerKw -> ChannelFeatures -> HTLC -> Bool-is_trimmed dust feerate features htlc =-  let !threshold = htlc_trim_threshold dust feerate features-                     (htlc_direction htlc)-      !amountSat = msat_to_sat (htlc_amount_msat htlc)-  in unSatoshi amountSat < unSatoshi threshold-{-# INLINE is_trimmed #-}+-- | Whether an HTLC is trimmed from a commitment transaction: whether+--   its amount, rounded down to whole satoshis, is below+--   'htlc_trim_threshold'.+is_trimmed :: DustLimit -> FeeratePerKw -> CommitmentFormat -> HTLC -> Bool+is_trimmed dust rate fmt h =+  BOLT1.msat_to_sat (htlc_amount_msat h)+    < htlc_trim_threshold dust rate fmt (htlc_direction h) --- | Filter HTLCs that are trimmed.-trimmed_htlcs-  :: DustLimit-  -> FeeratePerKw-  -> ChannelFeatures-  -> [HTLC]-  -> [HTLC]-trimmed_htlcs dust feerate features =-  filter (is_trimmed dust feerate features)-{-# INLINE trimmed_htlcs #-}+-- serialization -------------------------------------------------------------- --- | Filter HTLCs that are not trimmed.-untrimmed_htlcs-  :: DustLimit-  -> FeeratePerKw-  -> ChannelFeatures-  -> [HTLC]-  -> [HTLC]-untrimmed_htlcs dust feerate features =-  filter (not . is_trimmed dust feerate features)-{-# INLINE untrimmed_htlcs #-}+unsigned_tx+  :: Word32 -> Locktime -> OutPoint -> Sequence -> NonEmpty BT.TxOut+  -> BT.Tx+unsigned_tx version (Locktime lt) prevout (Sequence sq) outs = BT.Tx+  { BT.tx_version   = version+  , BT.tx_inputs    = BT.TxIn prevout BS.empty sq (BT.Witness []) :| []+  , BT.tx_outputs   = outs+  , BT.tx_locktime  = lt+  } --- output ordering -------------------------------------------------------------+txout :: Satoshi -> Script -> BT.TxOut+txout v (Script s) = BT.TxOut (BOLT1.un_satoshi v) s+{-# INLINE txout #-} --- | Sort outputs per BOLT #3 ordering.------ Outputs are sorted by:--- 1. Value (smallest first)--- 2. ScriptPubKey (lexicographic)--- 3. CLTV expiry (for HTLCs)-sort_outputs :: [TxOutput] -> [TxOutput]-sort_outputs = sortBy compareOutputs-{-# INLINE sort_outputs #-}+-- | The unsigned commitment transaction as a ppad-tx 'BT.Tx' (with no+--   witnesses), e.g. for computing its txid or sighashes.+commitment_to_tx :: CommitmentTx -> BT.Tx+commitment_to_tx c = unsigned_tx (ctx_version c) (ctx_locktime c)+  (ctx_input_outpoint c) (ctx_input_sequence c)+  (fmap (\o -> txout (co_value o) (co_script o)) (ctx_outputs c)) --- | Compare two outputs for ordering.-compareOutputs :: TxOutput -> TxOutput -> Ordering-compareOutputs o1 o2 =-  case compare (txout_value o1) (txout_value o2) of-    EQ -> case compare (unScript $ txout_script o1)-                       (unScript $ txout_script o2) of-            EQ -> compareCltvExpiry (txout_type o1) (txout_type o2)-            other -> other-    other -> other-{-# INLINE compareOutputs #-}+-- | The unsigned HTLC transaction as a ppad-tx 'BT.Tx'.+htlc_to_tx :: HTLCTx -> BT.Tx+htlc_to_tx h = unsigned_tx (htx_version h) (htx_locktime h)+  (htx_input_outpoint h) (htx_input_sequence h)+  (txout (htx_output_value h) (htx_output_script h) :| []) --- | Compare CLTV expiry for HTLC outputs.-compareCltvExpiry :: OutputType -> OutputType -> Ordering-compareCltvExpiry (OutputOfferedHTLC e1)  (OutputOfferedHTLC e2)  = compare e1 e2-compareCltvExpiry (OutputReceivedHTLC e1) (OutputReceivedHTLC e2) = compare e1 e2-compareCltvExpiry (OutputOfferedHTLC e1)  (OutputReceivedHTLC e2) = compare e1 e2-compareCltvExpiry (OutputReceivedHTLC e1) (OutputOfferedHTLC e2)  = compare e1 e2-compareCltvExpiry _ _ = EQ-{-# INLINE compareCltvExpiry #-}+-- | The unsigned closing transaction as a ppad-tx 'BT.Tx'.+closing_to_tx :: ClosingTx -> BT.Tx+closing_to_tx c = unsigned_tx (cltx_version c) (cltx_locktime c)+  (cltx_input_outpoint c) (cltx_input_sequence c)+  (fmap (\o -> txout (clo_value o) (clo_script o)) (cltx_outputs c))++-- | Serialize an unsigned commitment transaction, without witness+--   data. This is the form whose double-SHA256 is the txid; it is not+--   what segwit signatures commit to (see ppad-tx's+--   @Bitcoin.Prim.Tx.Sighash@). To broadcast, attach the witness to+--   'commitment_to_tx' and serialize with ppad-tx.+encode_commitment_tx :: CommitmentTx -> BS.ByteString+encode_commitment_tx = BT.to_bytes_legacy . commitment_to_tx++-- | Serialize an unsigned HTLC transaction, without witness data (cf.+--   'encode_commitment_tx').+encode_htlc_tx :: HTLCTx -> BS.ByteString+encode_htlc_tx = BT.to_bytes_legacy . htlc_to_tx++-- | Serialize an unsigned closing transaction, without witness data+--   (cf. 'encode_commitment_tx').+encode_closing_tx :: ClosingTx -> BS.ByteString+encode_closing_tx = BT.to_bytes_legacy . closing_to_tx

@@ -1,7 +1,6 @@-{-# OPTIONS_HADDOCK prune #-}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | -- Module: Lightning.Protocol.BOLT3.Types@@ -9,435 +8,404 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Core types for BOLT #3 transaction and script formats.+-- Types for BOLT #3 transaction and script formats.  module Lightning.Protocol.BOLT3.Types (-    -- * Monetary amounts-    Satoshi(..)-  , MilliSatoshi(..)-  , msat_to_sat-  , sat_to_msat--    -- * Keys and points-  , Pubkey(..)-  , pubkey+    -- * Points and keys+    PerCommitmentPoint(..)+  , RevocationBasepoint(..)+  , PaymentBasepoint(..)+  , DelayedPaymentBasepoint(..)+  , HtlcBasepoint(..)+  , Basepoints(..)+  , RevocationPubkey(..)+  , LocalDelayedPubkey(..)+  , LocalHtlcPubkey(..)+  , RemoteHtlcPubkey(..)+  , RemotePubkey(..)+  , FundingPubkey(..)   , Seckey(..)   , seckey-  , Point(..)-  , point--    -- * Hashes-  , PaymentHash(..)-  , payment_hash-  , PaymentPreimage(..)-  , payment_preimage+  , un_seckey -    -- * Transaction primitives-  , TxId(..)-  , txid-  , Outpoint(..)-  , Sequence(..)-  , Locktime(..)+    -- * Per-commitment secrets+  , Seed(..)+  , seed+  , un_seed+  , SecretIndex(..)+  , secret_index+  , un_secret_index+  , commitment_secret_index      -- * Channel parameters   , CommitmentNumber(..)   , commitment_number+  , un_commitment_number+  , next_commitment_number   , ToSelfDelay(..)   , CltvExpiry(..)   , DustLimit(..)   , FeeratePerKw(..)+  , Locktime(..)+  , Sequence(..)+  , CommitmentFormat(..) -    -- * HTLC types+    -- * HTLCs   , HTLC(..)   , HTLCDirection(..) -    -- * Basepoints-  , Basepoints(..)-  , PerCommitmentPoint(..)-  , PerCommitmentSecret(..)-  , per_commitment_secret-  , RevocationBasepoint(..)-  , PaymentBasepoint(..)-  , DelayedPaymentBasepoint(..)-  , HtlcBasepoint(..)--    -- * Derived keys-  , LocalPubkey(..)-  , RemotePubkey(..)-  , LocalDelayedPubkey(..)-  , RemoteDelayedPubkey(..)-  , LocalHtlcPubkey(..)-  , RemoteHtlcPubkey(..)-  , RevocationPubkey(..)-  , FundingPubkey(..)--    -- * Script and witness+    -- * Scripts   , Script(..)-  , Witness(..) -    -- * Channel options-  , ChannelFeatures(..)-  , has_anchors--    -- * Transaction weights (constants)-  , commitment_weight_no_anchors-  , commitment_weight_anchors-  , htlc_timeout_weight_no_anchors-  , htlc_timeout_weight_anchors-  , htlc_success_weight_no_anchors-  , htlc_success_weight_anchors-  , htlc_output_weight--    -- * Dust thresholds (constants)+    -- * Dust thresholds   , dust_p2pkh   , dust_p2sh   , dust_p2wpkh   , dust_p2wsh   , anchor_output_value++    -- * Internal+  , sat+  , internal_error   ) where -import Data.Word (Word16, Word32, Word64)+import Control.DeepSeq (NFData(..))+import qualified Crypto.Curve.Secp256k1 as S import qualified Data.ByteString as BS+import Data.Word (Word16, Word32, Word64) import GHC.Generics (Generic)+import Lightning.Protocol.BOLT1 (Point, Satoshi, MilliSatoshi, PaymentHash)+import qualified Lightning.Protocol.BOLT1 as BOLT1 --- monetary amounts ------------------------------------------------------------+-- internal ------------------------------------------------------------------ --- | Amount in satoshis.-newtype Satoshi = Satoshi { unSatoshi :: Word64 }-  deriving (Eq, Ord, Show, Generic, Num)+-- Abort on a state that the surrounding code rules out.+internal_error :: a+internal_error = error "ppad-bolt3: internal error, please report a bug!"+{-# NOINLINE internal_error #-} --- | Amount in millisatoshis.-newtype MilliSatoshi = MilliSatoshi { unMilliSatoshi :: Word64 }-  deriving (Eq, Ord, Show, Generic, Num)+-- A 'Satoshi' amount known to be at most 21 million BTC (a constant,+-- or a value bounded by construction).+sat :: Word64 -> Satoshi+sat w = case BOLT1.satoshi w of+  Just s  -> s+  Nothing -> internal_error+{-# INLINE sat #-} --- | Convert millisatoshis to satoshis (rounds down).-msat_to_sat :: MilliSatoshi -> Satoshi-msat_to_sat (MilliSatoshi m) = Satoshi (m `div` 1000)-{-# INLINE msat_to_sat #-}+-- points and keys ------------------------------------------------------------ --- | Convert satoshis to millisatoshis.-sat_to_msat :: Satoshi -> MilliSatoshi-sat_to_msat (Satoshi s) = MilliSatoshi (s * 1000)-{-# INLINE sat_to_msat #-}+-- | A per-commitment point, from which a commitment's keys are+--   derived.+newtype PerCommitmentPoint = PerCommitmentPoint Point+  deriving (Eq, Ord, Show, Generic) --- keys and points -------------------------------------------------------------+instance NFData PerCommitmentPoint --- | Compressed public key (33 bytes).-newtype Pubkey = Pubkey { unPubkey :: BS.ByteString }+-- | A @revocation_basepoint@.+newtype RevocationBasepoint = RevocationBasepoint Point   deriving (Eq, Ord, Show, Generic) --- | Parse a 33-byte compressed public key.------ Returns Nothing if the input is not exactly 33 bytes.------ >>> pubkey (BS.replicate 33 0x02)--- Just (Pubkey ...)--- >>> pubkey (BS.replicate 32 0x02)--- Nothing-pubkey :: BS.ByteString -> Maybe Pubkey-pubkey bs-  | BS.length bs == 33 = Just (Pubkey bs)-  | otherwise = Nothing-{-# INLINE pubkey #-}+instance NFData RevocationBasepoint --- | Secret key (32 bytes).-newtype Seckey = Seckey { unSeckey :: BS.ByteString }-  deriving (Eq, Generic)+-- | A @payment_basepoint@.+newtype PaymentBasepoint = PaymentBasepoint Point+  deriving (Eq, Ord, Show, Generic) --- Don't show secret keys-instance Show Seckey where-  show _ = "Seckey <redacted>"+instance NFData PaymentBasepoint --- | Parse a 32-byte secret key.------ Returns Nothing if the input is not exactly 32 bytes.-seckey :: BS.ByteString -> Maybe Seckey-seckey bs-  | BS.length bs == 32 = Just (Seckey bs)-  | otherwise = Nothing-{-# INLINE seckey #-}+-- | A @delayed_payment_basepoint@.+newtype DelayedPaymentBasepoint = DelayedPaymentBasepoint Point+  deriving (Eq, Ord, Show, Generic) --- | Elliptic curve point (33-byte compressed form).-newtype Point = Point { unPoint :: BS.ByteString }+instance NFData DelayedPaymentBasepoint++-- | An @htlc_basepoint@.+newtype HtlcBasepoint = HtlcBasepoint Point   deriving (Eq, Ord, Show, Generic) --- | Parse a 33-byte elliptic curve point.------ Returns Nothing if the input is not exactly 33 bytes.-point :: BS.ByteString -> Maybe Point-point bs-  | BS.length bs == 33 = Just (Point bs)-  | otherwise = Nothing-{-# INLINE point #-}+instance NFData HtlcBasepoint --- hashes ----------------------------------------------------------------------+-- | The four basepoints a party announces in @open_channel@ or+--   @accept_channel@.+data Basepoints = Basepoints+  { bp_revocation      :: !RevocationBasepoint+  , bp_payment         :: !PaymentBasepoint+  , bp_delayed_payment :: !DelayedPaymentBasepoint+  , bp_htlc            :: !HtlcBasepoint+  } deriving (Eq, Show, Generic) --- | Payment hash (32 bytes, SHA256 of preimage).-newtype PaymentHash = PaymentHash { unPaymentHash :: BS.ByteString }+instance NFData Basepoints++-- | A commitment's @revocationpubkey@.+newtype RevocationPubkey = RevocationPubkey Point   deriving (Eq, Ord, Show, Generic) --- | Parse a 32-byte payment hash.------ Returns Nothing if the input is not exactly 32 bytes.-payment_hash :: BS.ByteString -> Maybe PaymentHash-payment_hash bs-  | BS.length bs == 32 = Just (PaymentHash bs)-  | otherwise = Nothing-{-# INLINE payment_hash #-}+instance NFData RevocationPubkey --- | Payment preimage (32 bytes).-newtype PaymentPreimage = PaymentPreimage { unPaymentPreimage :: BS.ByteString }-  deriving (Eq, Generic)+-- | A commitment's @local_delayedpubkey@: the owner's key for its+--   delayed outputs.+newtype LocalDelayedPubkey = LocalDelayedPubkey Point+  deriving (Eq, Ord, Show, Generic) -instance Show PaymentPreimage where-  show _ = "PaymentPreimage <redacted>"+instance NFData LocalDelayedPubkey --- | Parse a 32-byte payment preimage.------ Returns Nothing if the input is not exactly 32 bytes.-payment_preimage :: BS.ByteString -> Maybe PaymentPreimage-payment_preimage bs-  | BS.length bs == 32 = Just (PaymentPreimage bs)-  | otherwise = Nothing-{-# INLINE payment_preimage #-}+-- | A commitment's @local_htlcpubkey@: the owner's HTLC key.+newtype LocalHtlcPubkey = LocalHtlcPubkey Point+  deriving (Eq, Ord, Show, Generic) --- transaction primitives ------------------------------------------------------+instance NFData LocalHtlcPubkey --- | Transaction ID (32 bytes, little-endian hash).-newtype TxId = TxId { unTxId :: BS.ByteString }+-- | A commitment's @remote_htlcpubkey@: the other party's HTLC key.+newtype RemoteHtlcPubkey = RemoteHtlcPubkey Point   deriving (Eq, Ord, Show, Generic) --- | Parse a 32-byte transaction ID.------ Returns Nothing if the input is not exactly 32 bytes.-txid :: BS.ByteString -> Maybe TxId-txid bs-  | BS.length bs == 32 = Just (TxId bs)-  | otherwise = Nothing-{-# INLINE txid #-}---- | Transaction outpoint (txid + output index).-data Outpoint = Outpoint-  { outpoint_txid  :: {-# UNPACK #-} !TxId-  , outpoint_index :: {-# UNPACK #-} !Word32-  } deriving (Eq, Ord, Show, Generic)+instance NFData RemoteHtlcPubkey --- | Transaction input sequence number.-newtype Sequence = Sequence { unSequence :: Word32 }-  deriving (Eq, Ord, Show, Generic, Num)+-- | A commitment's @remotepubkey@: the other party's+--   @payment_basepoint@, which its @to_remote@ output pays.+newtype RemotePubkey = RemotePubkey Point+  deriving (Eq, Ord, Show, Generic) --- | Transaction locktime.-newtype Locktime = Locktime { unLocktime :: Word32 }-  deriving (Eq, Ord, Show, Generic, Num)+instance NFData RemotePubkey --- channel parameters ----------------------------------------------------------+-- | A @funding_pubkey@.+newtype FundingPubkey = FundingPubkey Point+  deriving (Eq, Ord, Show, Generic) --- | 48-bit commitment number.-newtype CommitmentNumber = CommitmentNumber { unCommitmentNumber :: Word64 }-  deriving (Eq, Ord, Show, Generic, Num)+instance NFData FundingPubkey --- | Parse a 48-bit commitment number.+-- | A secp256k1 secret key: 32 bytes encoding an integer in+--   [1, n), for n the group order. ----- Returns Nothing if the value exceeds 2^48 - 1.-commitment_number :: Word64 -> Maybe CommitmentNumber-commitment_number n-  | n <= 281474976710655 = Just (CommitmentNumber n)-  | otherwise = Nothing-{-# INLINE commitment_number #-}+--   This is secret material: its 'Show' instance is redacted, and it+--   has no 'Eq' instance.+newtype Seckey = Seckey BS.ByteString --- | CSV delay for to_local outputs.-newtype ToSelfDelay = ToSelfDelay { unToSelfDelay :: Word16 }-  deriving (Eq, Ord, Show, Generic, Num)+instance Show Seckey where+  showsPrec d _ = showParen (d > 10) $ showString "Seckey <redacted>" --- | CLTV expiry for HTLCs.-newtype CltvExpiry = CltvExpiry { unCltvExpiry :: Word32 }-  deriving (Eq, Ord, Show, Generic, Num)+instance NFData Seckey where+  rnf (Seckey bs) = rnf bs --- | Dust limit threshold.-newtype DustLimit = DustLimit { unDustLimit :: Satoshi }-  deriving (Eq, Ord, Show, Generic)+-- | Construct a 'Seckey' from 32 big-endian bytes. Fails unless the+--   bytes encode an integer in [1, n).+--+--   >>> fmap (BS.length . un_seckey) (seckey (BS.replicate 32 0x01))+--   Just 32+--   >>> seckey (BS.replicate 32 0x00)+--   Nothing+--   >>> seckey (BS.replicate 32 0xff)+--   Nothing+seckey :: BS.ByteString -> Maybe Seckey+seckey bs = do+  w <- S.parse_int256 bs+  if   S.ge w+  then Just (Seckey bs)+  else Nothing --- | Fee rate in satoshis per 1000 weight units.-newtype FeeratePerKw = FeeratePerKw { unFeeratePerKw :: Word32 }-  deriving (Eq, Ord, Show, Generic, Num)+-- | The bytes of a 'Seckey'.+un_seckey :: Seckey -> BS.ByteString+un_seckey (Seckey bs) = bs+{-# INLINE un_seckey #-} --- HTLC types ------------------------------------------------------------------+-- per-commitment secrets ----------------------------------------------------- --- | Direction of an HTLC from the commitment tx owner's perspective.-data HTLCDirection-  = HTLCOffered   -- ^ We offered this HTLC (outgoing)-  | HTLCReceived  -- ^ We received this HTLC (incoming)-  deriving (Eq, Ord, Show, Generic)+-- | The 32-byte seed from which a party generates its per-commitment+--   secrets.+--+--   This is secret material: its 'Show' instance is redacted, and it+--   has no 'Eq' instance.+newtype Seed = Seed BS.ByteString --- | HTLC output details.+instance Show Seed where+  showsPrec d _ = showParen (d > 10) $ showString "Seed <redacted>"++instance NFData Seed where+  rnf (Seed bs) = rnf bs++-- | Construct a 'Seed' from exactly 32 bytes. ----- NOTE: No Ord instance is provided. BOLT #3 requires output ordering by--- amount then scriptPubKey, but scriptPubKey depends on derived keys which--- are not available here. Use 'sort_outputs' in Tx module for proper BIP69--- output ordering.-data HTLC = HTLC-  { htlc_direction    :: !HTLCDirection-  , htlc_amount_msat  :: {-# UNPACK #-} !MilliSatoshi-  , htlc_payment_hash :: {-# UNPACK #-} !PaymentHash-  , htlc_cltv_expiry  :: {-# UNPACK #-} !CltvExpiry-  } deriving (Eq, Show, Generic)+--   >>> fmap (BS.length . un_seed) (seed (BS.replicate 32 0xff))+--   Just 32+--   >>> seed (BS.replicate 31 0xff)+--   Nothing+seed :: BS.ByteString -> Maybe Seed+seed bs+  | BS.length bs == 32 = Just (Seed bs)+  | otherwise          = Nothing+{-# INLINE seed #-} --- basepoints ------------------------------------------------------------------+-- | The bytes of a 'Seed'.+un_seed :: Seed -> BS.ByteString+un_seed (Seed bs) = bs+{-# INLINE un_seed #-} --- | Per-commitment point (used to derive keys).-newtype PerCommitmentPoint = PerCommitmentPoint { unPerCommitmentPoint :: Point }+-- | The 48-bit index /I/ of a per-commitment secret. Secrets are+--   used from index 2^48 - 1 downwards.+newtype SecretIndex = SecretIndex Word64   deriving (Eq, Ord, Show, Generic) --- | Per-commitment secret (32 bytes).-newtype PerCommitmentSecret = PerCommitmentSecret-  { unPerCommitmentSecret :: BS.ByteString }-  deriving (Eq, Generic)--instance Show PerCommitmentSecret where-  show _ = "PerCommitmentSecret <redacted>"+instance NFData SecretIndex --- | Parse a 32-byte per-commitment secret.+-- | Construct a 'SecretIndex'. Fails at or above 2^48. ----- Returns Nothing if the input is not exactly 32 bytes.-per_commitment_secret :: BS.ByteString -> Maybe PerCommitmentSecret-per_commitment_secret bs-  | BS.length bs == 32 = Just (PerCommitmentSecret bs)-  | otherwise = Nothing-{-# INLINE per_commitment_secret #-}+--   >>> secret_index 281474976710655+--   Just (SecretIndex 281474976710655)+--   >>> secret_index 281474976710656+--   Nothing+secret_index :: Word64 -> Maybe SecretIndex+secret_index w+  | w <= 0xFFFFFFFFFFFF = Just (SecretIndex w)+  | otherwise           = Nothing+{-# INLINE secret_index #-} --- | Revocation basepoint.-newtype RevocationBasepoint = RevocationBasepoint-  { unRevocationBasepoint :: Point }-  deriving (Eq, Ord, Show, Generic)+-- | The value of a 'SecretIndex'.+un_secret_index :: SecretIndex -> Word64+un_secret_index (SecretIndex w) = w+{-# INLINE un_secret_index #-} --- | Payment basepoint.-newtype PaymentBasepoint = PaymentBasepoint-  { unPaymentBasepoint :: Point }-  deriving (Eq, Ord, Show, Generic)+-- | The index of the per-commitment secret for a commitment number:+--   2^48 - 1 - n.+--+--   >>> fmap commitment_secret_index (commitment_number 0)+--   Just (SecretIndex 281474976710655)+commitment_secret_index :: CommitmentNumber -> SecretIndex+commitment_secret_index (CommitmentNumber n) = SecretIndex (0xFFFFFFFFFFFF - n)+{-# INLINE commitment_secret_index #-} --- | Delayed payment basepoint.-newtype DelayedPaymentBasepoint = DelayedPaymentBasepoint-  { unDelayedPaymentBasepoint :: Point }-  deriving (Eq, Ord, Show, Generic)+-- channel parameters --------------------------------------------------------- --- | HTLC basepoint.-newtype HtlcBasepoint = HtlcBasepoint { unHtlcBasepoint :: Point }+-- | A 48-bit commitment number.+newtype CommitmentNumber = CommitmentNumber Word64   deriving (Eq, Ord, Show, Generic) --- | Collection of all basepoints for one party.-data Basepoints = Basepoints-  { bp_revocation      :: !RevocationBasepoint-  , bp_payment         :: !PaymentBasepoint-  , bp_delayed_payment :: !DelayedPaymentBasepoint-  , bp_htlc            :: !HtlcBasepoint-  } deriving (Eq, Show, Generic)+instance NFData CommitmentNumber --- derived keys ----------------------------------------------------------------+-- | Construct a 'CommitmentNumber'. Fails at or above 2^48.+--+--   >>> commitment_number 42+--   Just (CommitmentNumber 42)+--   >>> commitment_number 281474976710656+--   Nothing+commitment_number :: Word64 -> Maybe CommitmentNumber+commitment_number n+  | n <= 0xFFFFFFFFFFFF = Just (CommitmentNumber n)+  | otherwise           = Nothing+{-# INLINE commitment_number #-} --- | Local pubkey (derived from payment_basepoint + per_commitment_point).-newtype LocalPubkey = LocalPubkey { unLocalPubkey :: Pubkey }-  deriving (Eq, Ord, Show, Generic)+-- | The value of a 'CommitmentNumber'.+un_commitment_number :: CommitmentNumber -> Word64+un_commitment_number (CommitmentNumber n) = n+{-# INLINE un_commitment_number #-} --- | Remote pubkey (simply the remote's payment_basepoint).-newtype RemotePubkey = RemotePubkey { unRemotePubkey :: Pubkey }-  deriving (Eq, Ord, Show, Generic)+-- | The next commitment number. Fails past 2^48 - 1.+--+--   >>> commitment_number 0 >>= next_commitment_number+--   Just (CommitmentNumber 1)+--   >>> commitment_number 281474976710655 >>= next_commitment_number+--   Nothing+next_commitment_number :: CommitmentNumber -> Maybe CommitmentNumber+next_commitment_number (CommitmentNumber n)+  | n < 0xFFFFFFFFFFFF = Just (CommitmentNumber (n + 1))+  | otherwise          = Nothing+{-# INLINE next_commitment_number #-} --- | Local delayed pubkey.-newtype LocalDelayedPubkey = LocalDelayedPubkey-  { unLocalDelayedPubkey :: Pubkey }+-- | The CSV delay (@to_self_delay@) on a commitment owner's outputs.+newtype ToSelfDelay = ToSelfDelay Word16   deriving (Eq, Ord, Show, Generic) --- | Remote delayed pubkey.-newtype RemoteDelayedPubkey = RemoteDelayedPubkey-  { unRemoteDelayedPubkey :: Pubkey }-  deriving (Eq, Ord, Show, Generic)+instance NFData ToSelfDelay --- | Local HTLC pubkey.-newtype LocalHtlcPubkey = LocalHtlcPubkey { unLocalHtlcPubkey :: Pubkey }+-- | An HTLC's absolute CLTV expiry.+newtype CltvExpiry = CltvExpiry Word32   deriving (Eq, Ord, Show, Generic) --- | Remote HTLC pubkey.-newtype RemoteHtlcPubkey = RemoteHtlcPubkey { unRemoteHtlcPubkey :: Pubkey }-  deriving (Eq, Ord, Show, Generic)+instance NFData CltvExpiry --- | Revocation pubkey (derived from revocation_basepoint + per_commitment).-newtype RevocationPubkey = RevocationPubkey { unRevocationPubkey :: Pubkey }+-- | A @dust_limit_satoshis@ threshold.+newtype DustLimit = DustLimit Satoshi   deriving (Eq, Ord, Show, Generic) --- | Funding pubkey (used in 2-of-2 multisig).-newtype FundingPubkey = FundingPubkey { unFundingPubkey :: Pubkey }+instance NFData DustLimit++-- | A fee rate, in satoshis per 1000 weight units.+newtype FeeratePerKw = FeeratePerKw Word32   deriving (Eq, Ord, Show, Generic) --- script and witness ----------------------------------------------------------+instance NFData FeeratePerKw --- | Bitcoin script (serialized).-newtype Script = Script { unScript :: BS.ByteString }+-- | A transaction locktime.+newtype Locktime = Locktime Word32   deriving (Eq, Ord, Show, Generic) --- | Transaction witness stack.-newtype Witness = Witness { unWitness :: [BS.ByteString] }+instance NFData Locktime++-- | A transaction input's sequence number.+newtype Sequence = Sequence Word32   deriving (Eq, Ord, Show, Generic) --- channel options -------------------------------------------------------------+instance NFData Sequence --- | Channel feature flags relevant to BOLT #3.-data ChannelFeatures = ChannelFeatures-  { cf_option_anchors :: !Bool-  } deriving (Eq, Show, Generic)+-- | The commitment format a channel uses, as fixed by its+--   @channel_type@.+data CommitmentFormat+  = StaticRemotekey+    -- ^ @option_static_remotekey@ without anchors: @to_remote@ is+    --   P2WPKH and HTLC transactions pay their own fees.+  | Anchors+    -- ^ @option_anchors@: two anchor outputs, a CSV-locked+    --   @to_remote@, and zero-fee HTLC transactions.+  deriving (Eq, Ord, Show, Generic) --- | Check if option_anchors is enabled.-has_anchors :: ChannelFeatures -> Bool-has_anchors = cf_option_anchors-{-# INLINE has_anchors #-}+instance NFData CommitmentFormat --- transaction weights (constants from spec) -----------------------------------+-- HTLCs ---------------------------------------------------------------------- --- | Base commitment tx weight without option_anchors.-commitment_weight_no_anchors :: Word64-commitment_weight_no_anchors = 724+-- | The direction of an HTLC, from the commitment owner's point of+--   view.+data HTLCDirection+  = HTLCOffered   -- ^ offered by the owner+  | HTLCReceived  -- ^ received by the owner+  deriving (Eq, Ord, Show, Generic) --- | Base commitment tx weight with option_anchors.-commitment_weight_anchors :: Word64-commitment_weight_anchors = 1124+instance NFData HTLCDirection --- | HTLC-timeout tx weight without option_anchors.-htlc_timeout_weight_no_anchors :: Word64-htlc_timeout_weight_no_anchors = 663+-- | An HTLC committed to a commitment transaction.+data HTLC = HTLC+  { htlc_direction    :: !HTLCDirection+  , htlc_amount_msat  :: {-# UNPACK #-} !MilliSatoshi+  , htlc_payment_hash :: !PaymentHash+  , htlc_cltv_expiry  :: {-# UNPACK #-} !CltvExpiry+  } deriving (Eq, Show, Generic) --- | HTLC-timeout tx weight with option_anchors.-htlc_timeout_weight_anchors :: Word64-htlc_timeout_weight_anchors = 666+instance NFData HTLC --- | HTLC-success tx weight without option_anchors.-htlc_success_weight_no_anchors :: Word64-htlc_success_weight_no_anchors = 703+-- scripts -------------------------------------------------------------------- --- | HTLC-success tx weight with option_anchors.-htlc_success_weight_anchors :: Word64-htlc_success_weight_anchors = 706+-- | A serialized Bitcoin script.+newtype Script = Script BS.ByteString+  deriving (Eq, Ord, Show, Generic) --- | Weight added per HTLC output in commitment tx.-htlc_output_weight :: Word64-htlc_output_weight = 172+instance NFData Script --- dust thresholds (constants from Bitcoin Core) -------------------------------+-- dust thresholds ------------------------------------------------------------ --- | P2PKH dust threshold (546 satoshis).+-- | Bitcoin Core's P2PKH dust threshold (546 satoshis). dust_p2pkh :: Satoshi-dust_p2pkh = Satoshi 546+dust_p2pkh = sat 546 --- | P2SH dust threshold (540 satoshis).+-- | Bitcoin Core's P2SH dust threshold (540 satoshis). dust_p2sh :: Satoshi-dust_p2sh = Satoshi 540+dust_p2sh = sat 540 --- | P2WPKH dust threshold (294 satoshis).+-- | Bitcoin Core's P2WPKH dust threshold (294 satoshis). dust_p2wpkh :: Satoshi-dust_p2wpkh = Satoshi 294+dust_p2wpkh = sat 294 --- | P2WSH dust threshold (330 satoshis).+-- | Bitcoin Core's P2WSH dust threshold (330 satoshis). dust_p2wsh :: Satoshi-dust_p2wsh = Satoshi 330+dust_p2wsh = sat 330 --- | Fixed anchor output value (330 satoshis).+-- | The value of each anchor output (330 satoshis). anchor_output_value :: Satoshi-anchor_output_value = Satoshi 330+anchor_output_value = sat 330

@@ -1,359 +0,0 @@-{-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}---- |--- Module: Lightning.Protocol.BOLT3.Validate--- Copyright: (c) 2025 Jared Tobin--- License: MIT--- Maintainer: Jared Tobin <jared@ppad.tech>------ Stateless validation for BOLT #3 transactions.------ Provides validation for:------ * Commitment transaction structure and outputs--- * HTLC transaction structure--- * Closing transaction structure--- * Output ordering per BIP69+CLTV--- * Dust limit compliance--module Lightning.Protocol.BOLT3.Validate (-    -- * Validation errors-    ValidationError(..)--    -- * Commitment transaction validation-  , validate_commitment_tx-  , validate_commitment_locktime-  , validate_commitment_sequence--    -- * HTLC transaction validation-  , validate_htlc_tx-  , validate_htlc_timeout_tx-  , validate_htlc_success_tx--    -- * Closing transaction validation-  , validate_closing_tx-  , validate_legacy_closing_tx--    -- * Output validation-  , validate_output_ordering-  , validate_dust_limits-  , validate_anchor_outputs--    -- * Fee validation-  , validate_commitment_fee-  , validate_htlc_fee-  ) where--import Data.Bits ((.&.), shiftR)-import Data.Word (Word32, Word64)-import GHC.Generics (Generic)-import Lightning.Protocol.BOLT3.Types-import Lightning.Protocol.BOLT3.Tx---- validation errors --------------------------------------------------------------- | Errors that can occur during validation.-data ValidationError-  = InvalidVersion {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32-    -- ^ Expected version, actual version-  | InvalidLocktime {-# UNPACK #-} !Word32-    -- ^ Invalid locktime format-  | InvalidSequence {-# UNPACK #-} !Word32-    -- ^ Invalid sequence format-  | InvalidOutputOrdering-    -- ^ Outputs not in BIP69+CLTV order-  | DustLimitViolation {-# UNPACK #-} !Int !Satoshi !Satoshi-    -- ^ Output index, actual value, dust limit-  | MissingAnchorOutput-    -- ^ Expected anchor output not present-  | InvalidAnchorValue {-# UNPACK #-} !Satoshi-    -- ^ Anchor value not 330 satoshis-  | InvalidFee {-# UNPACK #-} !Satoshi {-# UNPACK #-} !Satoshi-    -- ^ Expected fee, actual fee-  | InvalidHTLCLocktime {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32-    -- ^ Expected locktime, actual locktime-  | InvalidHTLCSequence {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32-    -- ^ Expected sequence, actual sequence-  | NoOutputs-    -- ^ Transaction has no outputs-  | TooManyOutputs {-# UNPACK #-} !Int-    -- ^ More outputs than expected-  deriving (Eq, Show, Generic)---- commitment transaction validation ----------------------------------------------- | Validate a commitment transaction.------ Checks:------ * Version is 2--- * Locktime format (upper 8 bits = 0x20)--- * Sequence format (upper 8 bits = 0x80)--- * Output ordering per BIP69+CLTV--- * Dust limit compliance--- * Anchor outputs if option_anchors-validate_commitment_tx-  :: DustLimit-  -> ChannelFeatures-  -> CommitmentTx-  -> Either ValidationError ()-validate_commitment_tx dust features tx = do-  -- Version must be 2-  validateVersion 2 (ctx_version tx)-  -- Locktime format-  validate_commitment_locktime (ctx_locktime tx)-  -- Sequence format-  validate_commitment_sequence (ctx_input_sequence tx)-  -- Output ordering-  validate_output_ordering (ctx_outputs tx)-  -- Dust limits-  validate_dust_limits dust (ctx_outputs tx)-  -- Anchors if applicable-  if has_anchors features-    then validate_anchor_outputs (ctx_outputs tx)-    else pure ()-{-# INLINE validate_commitment_tx #-}---- | Validate commitment transaction locktime format.------ Upper 8 bits must be 0x20.-validate_commitment_locktime :: Locktime -> Either ValidationError ()-validate_commitment_locktime (Locktime lt) =-  let !upper = (lt `shiftR` 24) .&. 0xFF-  in if upper == 0x20-     then Right ()-     else Left (InvalidLocktime lt)-{-# INLINE validate_commitment_locktime #-}---- | Validate commitment transaction sequence format.------ Upper 8 bits must be 0x80.-validate_commitment_sequence :: Sequence -> Either ValidationError ()-validate_commitment_sequence (Sequence sq) =-  let !upper = (sq `shiftR` 24) .&. 0xFF-  in if upper == 0x80-     then Right ()-     else Left (InvalidSequence sq)-{-# INLINE validate_commitment_sequence #-}---- HTLC transaction validation ----------------------------------------------------- | Validate an HTLC transaction (timeout or success).------ Checks:------ * Version is 2--- * Single output-validate_htlc_tx :: HTLCTx -> Either ValidationError ()-validate_htlc_tx tx = do-  validateVersion 2 (htx_version tx)-  pure ()-{-# INLINE validate_htlc_tx #-}---- | Validate an HTLC-timeout transaction.------ Checks:------ * Base HTLC validation--- * Locktime equals HTLC cltv_expiry--- * Sequence is 0 (or 1 with option_anchors)-validate_htlc_timeout_tx-  :: ChannelFeatures-  -> CltvExpiry-  -> HTLCTx-  -> Either ValidationError ()-validate_htlc_timeout_tx features expiry tx = do-  validate_htlc_tx tx-  -- Locktime must be cltv_expiry-  let !expectedLt = unCltvExpiry expiry-      !actualLt = unLocktime (htx_locktime tx)-  if expectedLt == actualLt-    then pure ()-    else Left (InvalidHTLCLocktime expectedLt actualLt)-  -- Sequence-  let !expectedSeq = if has_anchors features then 1 else 0-      !actualSeq = unSequence (htx_input_sequence tx)-  if expectedSeq == actualSeq-    then pure ()-    else Left (InvalidHTLCSequence expectedSeq actualSeq)-{-# INLINE validate_htlc_timeout_tx #-}---- | Validate an HTLC-success transaction.------ Checks:------ * Base HTLC validation--- * Locktime is 0--- * Sequence is 0 (or 1 with option_anchors)-validate_htlc_success_tx-  :: ChannelFeatures-  -> HTLCTx-  -> Either ValidationError ()-validate_htlc_success_tx features tx = do-  validate_htlc_tx tx-  -- Locktime must be 0-  let !actualLt = unLocktime (htx_locktime tx)-  if actualLt == 0-    then pure ()-    else Left (InvalidHTLCLocktime 0 actualLt)-  -- Sequence-  let !expectedSeq = if has_anchors features then 1 else 0-      !actualSeq = unSequence (htx_input_sequence tx)-  if expectedSeq == actualSeq-    then pure ()-    else Left (InvalidHTLCSequence expectedSeq actualSeq)-{-# INLINE validate_htlc_success_tx #-}---- closing transaction validation -------------------------------------------------- | Validate a closing transaction (option_simple_close).------ Checks:------ * Version is 2--- * Sequence is 0xFFFFFFFD--- * At least one output--- * Output ordering per BIP69-validate_closing_tx :: ClosingTx -> Either ValidationError ()-validate_closing_tx tx = do-  validateVersion 2 (cltx_version tx)-  let !actualSeq = unSequence (cltx_input_sequence tx)-  if actualSeq == 0xFFFFFFFD-    then pure ()-    else Left (InvalidSequence actualSeq)-  validateOutputCount (cltx_outputs tx)-  validate_output_ordering (cltx_outputs tx)-{-# INLINE validate_closing_tx #-}---- | Validate a legacy closing transaction (closing_signed).------ Checks:------ * Version is 2--- * Locktime is 0--- * Sequence is 0xFFFFFFFF--- * At least one output--- * Output ordering per BIP69-validate_legacy_closing_tx :: ClosingTx -> Either ValidationError ()-validate_legacy_closing_tx tx = do-  validateVersion 2 (cltx_version tx)-  let !actualLt = unLocktime (cltx_locktime tx)-  if actualLt == 0-    then pure ()-    else Left (InvalidLocktime actualLt)-  let !actualSeq = unSequence (cltx_input_sequence tx)-  if actualSeq == 0xFFFFFFFF-    then pure ()-    else Left (InvalidSequence actualSeq)-  validateOutputCount (cltx_outputs tx)-  validate_output_ordering (cltx_outputs tx)-{-# INLINE validate_legacy_closing_tx #-}---- output validation --------------------------------------------------------------- | Validate output ordering per BIP69+CLTV.------ Outputs must be sorted by:--- 1. Value (smallest first)--- 2. ScriptPubKey (lexicographic)--- 3. CLTV expiry (for HTLC outputs)-validate_output_ordering :: [TxOutput] -> Either ValidationError ()-validate_output_ordering outputs =-  let !sorted = sort_outputs outputs-  in if outputs == sorted-     then Right ()-     else Left InvalidOutputOrdering-{-# INLINE validate_output_ordering #-}---- | Validate that no output violates dust limits.-validate_dust_limits-  :: DustLimit-  -> [TxOutput]-  -> Either ValidationError ()-validate_dust_limits dust = go 0 where-  !limit = unDustLimit dust-  go !_ [] = Right ()-  go !idx (out:rest) =-    let !val = txout_value out-    in case txout_type out of-         -- Anchors have fixed value, don't check against dust limit-         OutputLocalAnchor -> go (idx + 1) rest-         OutputRemoteAnchor -> go (idx + 1) rest-         -- All other outputs must be above dust-         _ -> if unSatoshi val >= unSatoshi limit-              then go (idx + 1) rest-              else Left (DustLimitViolation idx val limit)-{-# INLINE validate_dust_limits #-}---- | Validate anchor outputs are present and correctly valued.-validate_anchor_outputs :: [TxOutput] -> Either ValidationError ()-validate_anchor_outputs outputs =-  let !anchors = filter isAnchor outputs-  in if null anchors-     then Left MissingAnchorOutput-     else validateAnchorValues anchors-  where-    isAnchor out = case txout_type out of-      OutputLocalAnchor  -> True-      OutputRemoteAnchor -> True-      _ -> False--    validateAnchorValues [] = Right ()-    validateAnchorValues (a:as) =-      let !val = txout_value a-      in if val == anchor_output_value-         then validateAnchorValues as-         else Left (InvalidAnchorValue val)-{-# INLINE validate_anchor_outputs #-}---- fee validation ------------------------------------------------------------------ | Validate commitment transaction fee.------ Checks that the fee matches the expected calculation.-validate_commitment_fee-  :: FeeratePerKw-  -> ChannelFeatures-  -> Word64           -- ^ Number of untrimmed HTLCs-  -> Satoshi          -- ^ Actual fee-  -> Either ValidationError ()-validate_commitment_fee feerate features numHtlcs actualFee =-  let !expectedFee = commitment_fee feerate features numHtlcs-  in if actualFee == expectedFee-     then Right ()-     else Left (InvalidFee expectedFee actualFee)-{-# INLINE validate_commitment_fee #-}---- | Validate HTLC transaction fee.-validate_htlc_fee-  :: FeeratePerKw-  -> ChannelFeatures-  -> HTLCDirection-  -> Satoshi          -- ^ Actual fee-  -> Either ValidationError ()-validate_htlc_fee feerate features direction actualFee =-  let !expectedFee = case direction of-        HTLCOffered  -> htlc_timeout_fee feerate features-        HTLCReceived -> htlc_success_fee feerate features-  in if actualFee == expectedFee-     then Right ()-     else Left (InvalidFee expectedFee actualFee)-{-# INLINE validate_htlc_fee #-}---- helpers ------------------------------------------------------------------------- | Validate transaction version.-validateVersion :: Word32 -> Word32 -> Either ValidationError ()-validateVersion expected actual =-  if expected == actual-  then Right ()-  else Left (InvalidVersion expected actual)-{-# INLINE validateVersion #-}---- | Validate that transaction has at least one output.-validateOutputCount :: [TxOutput] -> Either ValidationError ()-validateOutputCount [] = Left NoOutputs-validateOutputCount _  = Right ()-{-# INLINE validateOutputCount #-}

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               ppad-bolt3-version:            0.0.1+version:            0.1.0 synopsis:           Bitcoin transaction formats per BOLT #3 license:            MIT license-file:       LICENSE@@ -8,10 +8,10 @@ maintainer:         jared@ppad.tech category:           Cryptography build-type:         Simple-tested-with:        GHC == 9.10.3+tested-with:        GHC == { 9.10.3 } extra-doc-files:    CHANGELOG description:-  Bitcoin transaction formats for the Lightning Network, per+  Bitcoin transaction and script formats for the Lightning Network, per   [BOLT #3](https://github.com/lightning/bolts/blob/master/03-transactions.md).  source-repository head@@ -25,66 +25,87 @@       -Wall   exposed-modules:       Lightning.Protocol.BOLT3-      Lightning.Protocol.BOLT3.Decode-      Lightning.Protocol.BOLT3.Encode+  other-modules:       Lightning.Protocol.BOLT3.Keys       Lightning.Protocol.BOLT3.Scripts       Lightning.Protocol.BOLT3.Tx       Lightning.Protocol.BOLT3.Types-      Lightning.Protocol.BOLT3.Validate   build-depends:       base >= 4.9 && < 5     , bytestring >= 0.9 && < 0.13+    , deepseq >= 1.4 && < 1.6+    , ppad-bolt1 >= 0.1 && < 0.2+    , ppad-fixed >= 0.2 && < 0.3     , ppad-ripemd160 >= 0.1.4 && < 0.2-    , ppad-secp256k1 >= 0.5.4 && < 0.6+    , ppad-secp256k1 >= 0.5.8 && < 0.6     , ppad-sha256 >= 0.3.2 && < 0.4+    , ppad-tx >= 0.2 && < 0.3  test-suite bolt3-tests   type:                exitcode-stdio-1.0   default-language:    Haskell2010   hs-source-dirs:      test   main-is:             Main.hs+  other-modules:+      Vectors    ghc-options:-    -rtsopts -Wall -O2+    -rtsopts -Wall    build-depends:       base-    , base16-bytestring     , bytestring+    , ppad-base16+    , ppad-bolt1     , ppad-bolt3+    , ppad-secp256k1+    , ppad-sha256+    , ppad-tx+    , QuickCheck     , tasty     , tasty-hunit+    , tasty-quickcheck  benchmark bolt3-bench   type:                exitcode-stdio-1.0   default-language:    Haskell2010   hs-source-dirs:      bench   main-is:             Main.hs+  other-modules:       Fixtures    ghc-options:-    -rtsopts -O2 -Wall -fno-warn-orphans+    -rtsopts -O2 -Wall    build-depends:       base     , bytestring     , criterion     , deepseq+    , ppad-base16+    , ppad-bolt1     , ppad-bolt3+    , ppad-secp256k1+    , ppad-sha256+    , ppad-tx  benchmark bolt3-weigh   type:                exitcode-stdio-1.0   default-language:    Haskell2010   hs-source-dirs:      bench   main-is:             Weight.hs+  other-modules:       Fixtures    ghc-options:-    -rtsopts -O2 -Wall -fno-warn-orphans+    -rtsopts -O2 -Wall    build-depends:       base     , bytestring     , deepseq+    , ppad-base16+    , ppad-bolt1     , ppad-bolt3+    , ppad-secp256k1+    , ppad-sha256+    , ppad-tx     , weigh-

@@ -2,336 +2,1022 @@  module Main where -import qualified Data.ByteString as BS-import qualified Data.ByteString.Base16 as B16-import Data.Maybe (isJust, isNothing)-import Test.Tasty-import Test.Tasty.HUnit-import Lightning.Protocol.BOLT3--main :: IO ()-main = defaultMain $ testGroup "ppad-bolt3" [-    testGroup "Key derivation" [-      keyDerivationTests-    ]-  , testGroup "Secret generation" [-      secretGenerationTests-    ]-  , testGroup "Secret storage" [-      secretStorageTests-    ]-  , testGroup "Fee calculation" [-      feeCalculationTests-    ]-  , testGroup "Trimming" [-      trimmingTests-    ]-  , testGroup "Smart constructors" [-      smartConstructorTests-    ]-  ]---- hex decoding helper-hex :: BS.ByteString -> BS.ByteString-hex h = case B16.decode h of-  Right bs -> bs-  Left _ -> error "invalid hex"---- Key derivation test vectors from Appendix E -----------------------------------keyDerivationTests :: TestTree-keyDerivationTests = testGroup "BOLT #3 Appendix E" [-    testCase "derive_pubkey" $ do-      let basepoint = Point $ hex-            "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"-          perCommitmentPoint = PerCommitmentPoint $ Point $ hex-            "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"-          expected = hex-            "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"-      case derive_pubkey basepoint perCommitmentPoint of-        Nothing -> assertFailure "derive_pubkey returned Nothing"-        Just (Pubkey pk) -> pk @?= expected--  , testCase "derive_revocationpubkey" $ do-      let revocationBasepoint = RevocationBasepoint $ Point $ hex-            "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"-          perCommitmentPoint = PerCommitmentPoint $ Point $ hex-            "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"-          expected = hex-            "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0"-      case derive_revocationpubkey revocationBasepoint perCommitmentPoint of-        Nothing -> assertFailure "derive_revocationpubkey returned Nothing"-        Just (RevocationPubkey (Pubkey pk)) -> pk @?= expected-  ]---- Secret generation test vectors from Appendix D --------------------------------secretGenerationTests :: TestTree-secretGenerationTests = testGroup "BOLT #3 Appendix D - Generation" [-    testCase "generate_from_seed 0 final node" $ do-      let seed = hex-            "0000000000000000000000000000000000000000000000000000000000000000"-          i = 281474976710655-          expected = hex-            "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148"-      generate_from_seed seed i @?= expected--  , testCase "generate_from_seed FF final node" $ do-      let seed = hex-            "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"-          i = 281474976710655-          expected = hex-            "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"-      generate_from_seed seed i @?= expected--  , testCase "generate_from_seed FF alternate bits 1" $ do-      let seed = hex-            "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"-          i = 0xaaaaaaaaaaa-          expected = hex-            "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528"-      generate_from_seed seed i @?= expected--  , testCase "generate_from_seed FF alternate bits 2" $ do-      let seed = hex-            "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"-          i = 0x555555555555-          expected = hex-            "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31"-      generate_from_seed seed i @?= expected--  , testCase "generate_from_seed 01 last nontrivial node" $ do-      let seed = hex-            "0101010101010101010101010101010101010101010101010101010101010101"-          i = 1-          expected = hex-            "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c"-      generate_from_seed seed i @?= expected-  ]---- Secret storage test vectors from Appendix D -----------------------------------secretStorageTests :: TestTree-secretStorageTests = testGroup "BOLT #3 Appendix D - Storage" [-    testCase "insert_secret correct sequence" $ do-      let secrets = [-              (281474976710655, hex-                "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc")-            , (281474976710654, hex-                "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964")-            , (281474976710653, hex-                "2273e227a5b7449b6e70f1fb4652864038b1cbf9cd7c043a7d6456b7fc275ad8")-            , (281474976710652, hex-                "27cddaa5624534cb6cb9d7da077cf2b22ab21e9b506fd4998a51d54502e99116")-            , (281474976710651, hex-                "c65716add7aa98ba7acb236352d665cab17345fe45b55fb879ff80e6bd0c41dd")-            , (281474976710650, hex-                "969660042a28f32d9be17344e09374b379962d03db1574df5a8a5a47e19ce3f2")-            , (281474976710649, hex-                "a5a64476122ca0925fb344bdc1854c1c0a59fc614298e50a33e331980a220f32")-            , (281474976710648, hex-                "05cde6323d949933f7f7b78776bcc1ea6d9b31447732e3802e1f7ac44b650e17")-            ]-      let insertAll store [] = Just store-          insertAll store ((idx, secret):rest) =-            case insert_secret secret idx store of-              Nothing -> Nothing-              Just store' -> insertAll store' rest-      case insertAll empty_store secrets of-        Nothing -> assertFailure "insert_secret failed on correct sequence"-        Just _ -> return ()--  , testCase "insert_secret #1 incorrect" $ do-      -- First secret is from wrong seed, second should fail-      let store0 = empty_store-      case insert_secret (hex-             "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148")-             281474976710655 store0 of-        Nothing -> assertFailure "First insert should succeed"-        Just store1 ->-          case insert_secret (hex-                 "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964")-                 281474976710654 store1 of-            Nothing -> return ()  -- Expected to fail-            Just _ -> assertFailure "Second insert should fail"-  ]---- Fee calculation tests ---------------------------------------------------------feeCalculationTests :: TestTree-feeCalculationTests = testGroup "Fee calculation" [-    testCase "commitment_fee no anchors, 0 htlcs" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          fee = commitment_fee feerate features 0-      fee @?= Satoshi 3620  -- 5000 * 724 / 1000 = 3620--  , testCase "commitment_fee no anchors, 2 htlcs" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          fee = commitment_fee feerate features 2-      -- weight = 724 + 172*2 = 1068-      -- fee = 5000 * 1068 / 1000 = 5340-      fee @?= Satoshi 5340--  , testCase "commitment_fee with anchors, 0 htlcs" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = True }-          fee = commitment_fee feerate features 0-      -- 5000 * 1124 / 1000 = 5620-      fee @?= Satoshi 5620--  , testCase "htlc_timeout_fee no anchors" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          fee = htlc_timeout_fee feerate features-      -- 5000 * 663 / 1000 = 3315-      fee @?= Satoshi 3315--  , testCase "htlc_success_fee no anchors" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          fee = htlc_success_fee feerate features-      -- 5000 * 703 / 1000 = 3515-      fee @?= Satoshi 3515--  , testCase "htlc_timeout_fee with anchors is 0" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = True }-          fee = htlc_timeout_fee feerate features-      fee @?= Satoshi 0--  , testCase "htlc_success_fee with anchors is 0" $ do-      let feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = True }-          fee = htlc_success_fee feerate features-      fee @?= Satoshi 0-  ]---- Trimming tests ----------------------------------------------------------------trimmingTests :: TestTree-trimmingTests = testGroup "HTLC trimming" [-    testCase "offered HTLC above threshold not trimmed" $ do-      let dust = DustLimit (Satoshi 546)-          feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          htlc = HTLC-            { htlc_direction = HTLCOffered-            , htlc_amount_msat = MilliSatoshi 5000000  -- 5000 sats-            , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-            , htlc_cltv_expiry = CltvExpiry 500000-            }-      -- threshold = 546 + 3315 = 3861-      -- 5000 > 3861, so not trimmed-      is_trimmed dust feerate features htlc @?= False--  , testCase "offered HTLC below threshold is trimmed" $ do-      let dust = DustLimit (Satoshi 546)-          feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          htlc = HTLC-            { htlc_direction = HTLCOffered-            , htlc_amount_msat = MilliSatoshi 1000000  -- 1000 sats-            , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-            , htlc_cltv_expiry = CltvExpiry 500000-            }-      -- threshold = 546 + 3315 = 3861-      -- 1000 < 3861, so trimmed-      is_trimmed dust feerate features htlc @?= True--  , testCase "received HTLC above threshold not trimmed" $ do-      let dust = DustLimit (Satoshi 546)-          feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          htlc = HTLC-            { htlc_direction = HTLCReceived-            , htlc_amount_msat = MilliSatoshi 7000000  -- 7000 sats-            , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-            , htlc_cltv_expiry = CltvExpiry 500000-            }-      -- threshold = 546 + 3515 = 4061-      -- 7000 > 4061, so not trimmed-      is_trimmed dust feerate features htlc @?= False--  , testCase "received HTLC below threshold is trimmed" $ do-      let dust = DustLimit (Satoshi 546)-          feerate = FeeratePerKw 5000-          features = ChannelFeatures { cf_option_anchors = False }-          htlc = HTLC-            { htlc_direction = HTLCReceived-            , htlc_amount_msat = MilliSatoshi 800000  -- 800 sats-            , htlc_payment_hash = PaymentHash (BS.replicate 32 0)-            , htlc_cltv_expiry = CltvExpiry 500000-            }-      -- threshold = 546 + 3515 = 4061-      -- 800 < 4061, so trimmed-      is_trimmed dust feerate features htlc @?= True-  ]---- Smart constructor tests -------------------------------------------------------smartConstructorTests :: TestTree-smartConstructorTests = testGroup "validation" [-    -- 33-byte types-    testCase "pubkey accepts 33 bytes" $ do-      let bs = BS.replicate 33 0x02-      isJust (pubkey bs) @?= True-  , testCase "pubkey rejects 32 bytes" $ do-      let bs = BS.replicate 32 0x02-      isNothing (pubkey bs) @?= True-  , testCase "pubkey rejects 34 bytes" $ do-      let bs = BS.replicate 34 0x02-      isNothing (pubkey bs) @?= True-  , testCase "point accepts 33 bytes" $ do-      let bs = BS.replicate 33 0x03-      isJust (point bs) @?= True-  , testCase "point rejects 32 bytes" $ do-      let bs = BS.replicate 32 0x03-      isNothing (point bs) @?= True--    -- 32-byte types-  , testCase "seckey accepts 32 bytes" $ do-      let bs = BS.replicate 32 0x01-      isJust (seckey bs) @?= True-  , testCase "seckey rejects 31 bytes" $ do-      let bs = BS.replicate 31 0x01-      isNothing (seckey bs) @?= True-  , testCase "seckey rejects 33 bytes" $ do-      let bs = BS.replicate 33 0x01-      isNothing (seckey bs) @?= True-  , testCase "txid accepts 32 bytes" $ do-      let bs = BS.replicate 32 0x00-      isJust (txid bs) @?= True-  , testCase "txid rejects 31 bytes" $ do-      let bs = BS.replicate 31 0x00-      isNothing (txid bs) @?= True-  , testCase "payment_hash accepts 32 bytes" $ do-      let bs = BS.replicate 32 0xab-      isJust (payment_hash bs) @?= True-  , testCase "payment_hash rejects 33 bytes" $ do-      let bs = BS.replicate 33 0xab-      isNothing (payment_hash bs) @?= True-  , testCase "payment_preimage accepts 32 bytes" $ do-      let bs = BS.replicate 32 0xcd-      isJust (payment_preimage bs) @?= True-  , testCase "payment_preimage rejects 31 bytes" $ do-      let bs = BS.replicate 31 0xcd-      isNothing (payment_preimage bs) @?= True-  , testCase "per_commitment_secret accepts 32 bytes" $ do-      let bs = BS.replicate 32 0xef-      isJust (per_commitment_secret bs) @?= True-  , testCase "per_commitment_secret rejects 33 bytes" $ do-      let bs = BS.replicate 33 0xef-      isNothing (per_commitment_secret bs) @?= True--    -- 48-bit commitment number-  , testCase "commitment_number accepts 0" $ do-      isJust (commitment_number 0) @?= True-  , testCase "commitment_number accepts 2^48-1" $ do-      isJust (commitment_number 281474976710655) @?= True-  , testCase "commitment_number rejects 2^48" $ do-      isNothing (commitment_number 281474976710656) @?= True-  , testCase "commitment_number rejects maxBound Word64" $ do-      isNothing (commitment_number maxBound) @?= True-  ]+import qualified Bitcoin.Prim.Tx as BT+import qualified Bitcoin.Prim.Tx.Sighash as Sighash+import Control.Monad (foldM, forM_)+import qualified Crypto.Curve.Secp256k1 as S+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Bits (xor)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust, isNothing)+import Data.Word (Word8, Word64)+import qualified Lightning.Protocol.BOLT1 as BOLT1+import Lightning.Protocol.BOLT3+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Vectors++-- Shared wNAF context.+tex :: S.Context+tex = S.precompute+{-# NOINLINE tex #-}++main :: IO ()+main = defaultMain $ testGroup "ppad-bolt3" [+    keyTests+  , secretGenerationTests+  , secretStorageTests+  , fundingTests+  , testGroup "Commitment and HTLC transactions (Appendix C)" $+      fmap (commitVectorTests StaticRemotekey) appendix_c+  , testGroup "Commitment and HTLC transactions (Appendix F)" $+      fmap (commitVectorTests Anchors) appendix_f+  , commitmentTests+  , htlcTxTests+  , closingTests+  , scriptTests+  , feeTests+  , constructorTests+  , propertyTests+  ]++-- helpers --------------------------------------------------------------------++-- | Decode a hex literal, failing the enclosing test on bad input.+hex :: BS.ByteString -> IO BS.ByteString+hex h = case B16.decode h of+  Just bs -> pure bs+  Nothing -> assertFailure ("invalid hex literal: " ++ show h)++-- | Unwrap a Just, failing the enclosing test on Nothing.+need :: String -> Maybe a -> IO a+need msg = maybe (assertFailure msg) pure++pt :: BS.ByteString -> IO BOLT1.Point+pt h = hex h >>= need ("invalid point " ++ show h) . BOLT1.point++sat :: Word64 -> IO BOLT1.Satoshi+sat = need "invalid satoshi amount" . BOLT1.satoshi++msat :: Word64 -> IO BOLT1.MilliSatoshi+msat = need "invalid millisatoshi amount" . BOLT1.milli_satoshi++sk :: BS.ByteString -> IO Seckey+sk h = hex h >>= need ("invalid secret key " ++ show h) . seckey++pcsecret :: BS.ByteString -> IO BOLT1.PerCommitmentSecret+pcsecret h = hex h >>= need "invalid secret" . BOLT1.per_commitment_secret++idx :: Word64 -> IO SecretIndex+idx = need "invalid secret index" . secret_index++unpoint :: BOLT1.Point -> BS.ByteString+unpoint = BOLT1.un_point++unsecret :: BOLT1.PerCommitmentSecret -> BS.ByteString+unsecret = BOLT1.un_per_commitment_secret++-- | The compressed public key of a secret key.+pubkey_of :: Seckey -> Maybe BS.ByteString+pubkey_of k = do+  w <- S.parse_int256 (un_seckey k)+  S.serialize_point <$> S.derive_pub w++-- Appendix E, and the internal values of Appendix C --------------------------++e_base_secret, e_per_commitment_secret, e_base_point,+  e_per_commitment_point :: BS.ByteString+e_base_secret =+  "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f"+e_per_commitment_secret =+  "1f1e1d1c1b1a191817161514131211100f0e0d0c0b0a09080706050403020100"+e_base_point =+  "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2"+e_per_commitment_point =+  "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"++-- | Appendix C's (commented) derivation inputs.+c_local_delayed_payment_basepoint_secret, c_local_delayed_payment_basepoint,+  c_remote_revocation_basepoint, c_local_per_commitment_point,+  c_local_delayed_privkey :: BS.ByteString+c_local_delayed_payment_basepoint_secret =+  "3333333333333333333333333333333333333333333333333333333333333333"+c_local_delayed_payment_basepoint =+  "023c72addb4fdf09af94f0c94d7fe92a386a7e70cf8a1d85916386bb2535c7b1b1"+c_remote_revocation_basepoint =+  "02466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27"+c_local_per_commitment_point =+  "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486"+c_local_delayed_privkey =+  "adf3464ce9c2f230fd2582fda4c6965e4993ca5524e8c9580e3df0cf226981ad"++keyTests :: TestTree+keyTests = testGroup "Key derivation (Appendix E)" [+    testCase "per_commitment_point from per_commitment_secret" $ do+      s <- pcsecret e_per_commitment_secret+      expected <- hex e_per_commitment_point+      PerCommitmentPoint p <- need "derive_per_commitment_point"+        (derive_per_commitment_point s)+      unpoint p @?= expected+      PerCommitmentPoint p' <- need "derive_per_commitment_point'"+        (derive_per_commitment_point' tex s)+      unpoint p' @?= expected++  , testCase "localpubkey from basepoint and per_commitment_point" $ do+      bp <- pt e_base_point+      pcp <- PerCommitmentPoint <$> pt e_per_commitment_point+      expected <- hex+        "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5"+      fmap unpoint (derive_pubkey bp pcp) @?= Just expected++  , testCase "localprivkey from basepoint secret" $ do+      bs <- sk e_base_secret+      pcp <- PerCommitmentPoint <$> pt e_per_commitment_point+      expected <- hex+        "cbced912d3b21bf196a766651e436aff192362621ce317704ea2f75d87e7be0f"+      fmap un_seckey (derive_privkey bs pcp) @?= Just expected++  , testCase "revocationpubkey from basepoint and per_commitment_point" $ do+      rbp <- RevocationBasepoint <$> pt e_base_point+      pcp <- PerCommitmentPoint <$> pt e_per_commitment_point+      expected <- hex+        "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0"+      fmap (\(RevocationPubkey p) -> unpoint p)+        (derive_revocationpubkey rbp pcp) @?= Just expected++  , testCase "revocationprivkey from secrets" $ do+      rbs <- sk e_base_secret+      pcs <- pcsecret e_per_commitment_secret+      expected <- hex+        "d09ffff62ddb2297ab000cc85bcb4283fdeb6aa052affbc9dddcf33b61078110"+      fmap un_seckey (derive_revocationprivkey rbs pcs) @?= Just expected++  , testCase "Appendix C local_delayed_privkey" $ do+      bs <- sk c_local_delayed_payment_basepoint_secret+      pcp <- PerCommitmentPoint <$> pt c_local_per_commitment_point+      expected <- hex c_local_delayed_privkey+      fmap un_seckey (derive_privkey bs pcp) @?= Just expected+      -- whose public key is Appendix C's local_delayedpubkey+      expected_pub <- hex c_local_delayedpubkey+      (pubkey_of =<< derive_privkey bs pcp) @?= Just expected_pub++  , testCase "Appendix C commitment keys from basepoints" $ do+      keys <- vectorKeys+      pcp <- PerCommitmentPoint <$> pt c_local_per_commitment_point+      local_bp <- pt c_local_payment_basepoint+      remote_bp <- pt c_remote_payment_basepoint+      local_delayed_bp <- pt c_local_delayed_payment_basepoint+      remote_rev_bp <- pt c_remote_revocation_basepoint+      let local = Basepoints+            { bp_revocation      = RevocationBasepoint local_bp+            , bp_payment         = PaymentBasepoint local_bp+            , bp_delayed_payment =+                DelayedPaymentBasepoint local_delayed_bp+            , bp_htlc            = HtlcBasepoint local_bp+            }+          remote = Basepoints+            { bp_revocation      = RevocationBasepoint remote_rev_bp+            , bp_payment         = PaymentBasepoint remote_bp+            , bp_delayed_payment = DelayedPaymentBasepoint remote_bp+            , bp_htlc            = HtlcBasepoint remote_bp+            }+          derived = derive_commitment_keys local (ck_local_funding keys)+            remote (ck_remote_funding keys) pcp+      derived @?= Just keys+      derive_commitment_keys' tex local (ck_local_funding keys)+        remote (ck_remote_funding keys) pcp @?= Just keys++  , testCase "rejects a basepoint off the curve" $ do+      bad <- pt+        "020000000000000000000000000000000000000000000000000000000000000000"+      pcp <- PerCommitmentPoint <$> pt e_per_commitment_point+      isNothing (derive_pubkey bad pcp) @?= True+      isNothing (derive_revocationpubkey (RevocationBasepoint bad) pcp)+        @?= True++  , testCase "rejects a per_commitment_point off the curve" $ do+      rbp <- RevocationBasepoint <$> pt e_base_point+      bad <- PerCommitmentPoint <$> pt+        "020000000000000000000000000000000000000000000000000000000000000000"+      isNothing (derive_revocationpubkey rbp bad) @?= True++  , testCase "rejects an invalid per_commitment_secret" $ do+      zero <- pcsecret+        "0000000000000000000000000000000000000000000000000000000000000000"+      big <- pcsecret+        "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+      rbs <- sk e_base_secret+      isNothing (derive_per_commitment_point zero) @?= True+      isNothing (derive_per_commitment_point big) @?= True+      isNothing (derive_per_commitment_point' tex big) @?= True+      isNothing (derive_revocationprivkey rbs zero) @?= True+      isNothing (derive_revocationprivkey rbs big) @?= True+  ]++-- Appendix D: generation -----------------------------------------------------++secretGenerationTests :: TestTree+secretGenerationTests = testGroup "Secret generation (Appendix D)" [+    gen "generate_from_seed 0 final node"+      "0000000000000000000000000000000000000000000000000000000000000000"+      281474976710655+      "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148"+  , gen "generate_from_seed FF final node"+      "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+      281474976710655+      "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc"+  , gen "generate_from_seed FF alternate bits 1"+      "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+      0xaaaaaaaaaaa+      "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528"+  , gen "generate_from_seed FF alternate bits 2"+      "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+      0x555555555555+      "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31"+  , gen "generate_from_seed 01 last nontrivial node"+      "0101010101010101010101010101010101010101010101010101010101010101"+      1+      "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c"+  , testCase "commitment_secret_index" $ do+      cn <- need "commitment_number" (commitment_number 42)+      un_secret_index (commitment_secret_index cn) @?= 0xFFFFFFFFFFFF - 42+  ]+  where+    gen name s i expected = testCase name $ do+      sd <- hex s >>= need "seed" . seed+      ix <- idx i+      e <- hex expected+      unsecret (generate_from_seed sd ix) @?= e++-- Appendix D: storage --------------------------------------------------------++secretStorageTests :: TestTree+secretStorageTests = testGroup "Secret storage (Appendix D)" $+     fmap storageVectorTest appendix_d_storage+  ++ [+    testCase "derive_old_secret after each correct insert" $ do+      known <- correctSequence+      let step (store, seen) (i, s) = do+            store' <- need ("rejected correct secret at I=" ++ show i)+                        (insert_secret s i store)+            let seen' = (i, s) : seen+            forM_ seen' $ \(j, t) ->+              assertEqual+                ("after I=" ++ show i ++ ", derive_old_secret " ++ show j)+                (Just (unsecret t))+                (fmap unsecret (derive_old_secret j store'))+            pure (store', seen')+      (store, _) <- foldM step (empty_secret_store, []) known+      -- the next index has not been received+      next <- idx 281474976710647+      isNothing (derive_old_secret next store) @?= True++  , testCase "un_secret_store/secret_store round trip" $ do+      known <- correctSequence+      store <- need "insert" (foldM (\st (i, s) -> insert_secret s i st)+                                    empty_secret_store known)+      store' <- need "secret_store" (secret_store (un_secret_store store))+      forM_ known $ \(i, s) ->+        fmap unsecret (derive_old_secret i store') @?= Just (unsecret s)+      -- entry order doesn't matter+      store'' <- need "secret_store (reversed)"+        (secret_store (reverse (un_secret_store store)))+      forM_ known $ \(i, s) ->+        fmap unsecret (derive_old_secret i store'') @?= Just (unsecret s)++  , testCase "secret_store rejects a repeated bucket" $ do+      known <- correctSequence+      case known of+        ((i0, s0) : _ : (i2, s2) : _) ->+          -- indices 2^48-1 and 2^48-3 both have no trailing zeros+          isNothing (secret_store [(i0, s0), (i2, s2)]) @?= True+        _ -> assertFailure "short sequence"++  , testCase "secret_store rejects contradictory entries" $ do+      known <- correctSequence+      bad <- pcsecret+        "0000000000000000000000000000000000000000000000000000000000000000"+      case known of+        ((i0, _) : (i1, s1) : _) ->+          -- index 2^48-1 is derivable from index 2^48-2+          isNothing (secret_store [(i0, bad), (i1, s1)]) @?= True+        _ -> assertFailure "short sequence"++  , testCase "Show is redacted" $ do+      known <- correctSequence+      store <- need "insert" (foldM (\st (i, s) -> insert_secret s i st)+                                    empty_secret_store known)+      show store @?= "SecretStore <redacted>"+      sd <- need "seed" (seed (BS.replicate 32 0xff))+      show sd @?= "Seed <redacted>"+      k <- sk e_base_secret+      show k @?= "Seckey <redacted>"+  ]++-- | The spec's correct storage sequence, as (index, secret) pairs.+correctSequence :: IO [(SecretIndex, BOLT1.PerCommitmentSecret)]+correctSequence = do+  steps <- case filter isCorrect appendix_d_storage of+    (v : _) -> pure (sv_steps v)+    [] -> assertFailure "missing correct sequence vector"+  traverse (\st -> (,) <$> idx (ss_index st) <*> pcsecret (ss_secret st))+    steps+  where+    isCorrect v = sv_name v == "insert_secret correct sequence"++-- | Run a storage vector, asserting that each insert_secret call is+--   accepted or rejected exactly as the spec says.+storageVectorTest :: StorageVector -> TestTree+storageVectorTest (StorageVector name steps) =+    testCase name (go empty_secret_store steps)+  where+    go _ [] = pure ()+    go store (StorageStep i ok s : rest) = do+      sec <- pcsecret s+      ix <- idx i+      case (insert_secret sec ix store, ok) of+        (Just store', True) -> go store' rest+        (Nothing, False) -> go store rest+        (Just _, False) ->+          assertFailure ("accepted incorrect secret at I=" ++ show i)+        (Nothing, True) ->+          assertFailure ("rejected correct secret at I=" ++ show i)++-- Appendix B -----------------------------------------------------------------++fundingTests :: TestTree+fundingTests = testGroup "Funding transaction (Appendix B)" [+    testCase "funding witness script" $ do+      (lpk, rpk) <- fundingPubkeys+      wscript <- hex b_funding_wscript+      funding_script lpk rpk @?= Script wscript+      funding_script rpk lpk @?= Script wscript++  , testCase "funding output" $ do+      (lpk, rpk) <- fundingPubkeys+      tx <- hex b_funding_tx >>= decodeTx+      txid <- hex b_funding_txid+      BT.un_txid (BT.txid tx) @?= BS.reverse txid+      case drop (fromIntegral b_funding_output) (NE.toList (BT.tx_outputs tx))+        of+          (BT.TxOut value spk : _) -> do+            value @?= b_funding_satoshis+            Script spk @?= to_p2wsh (funding_script lpk rpk)+          [] -> assertFailure "missing funding output"+  ]+  where+    fundingPubkeys = do+      lpk <- FundingPubkey <$> pt b_local_funding_pubkey+      rpk <- FundingPubkey <$> pt b_remote_funding_pubkey+      pure (lpk, rpk)++-- Appendices C and F ---------------------------------------------------------++-- | Decode a serialized transaction, failing the test on bad input.+decodeTx :: BS.ByteString -> IO BT.Tx+decodeTx = need "undecodable transaction" . BT.from_bytes++-- | The single input's witness stack of a spec transaction.+witnessOf :: BT.Tx -> IO [BS.ByteString]+witnessOf tx = case NE.toList (BT.tx_inputs tx) of+  [i] | BT.Witness items <- BT.txin_witness i -> pure items+  _ -> assertFailure "expected one input"++-- | A test HTLC from the Appendix C parameters.+testHtlc :: Int -> IO HTLC+testHtlc i = case drop i c_htlcs of+  (TestHtlc offered amt expiry pre : _) -> do+    preimage <- hex pre+    amount <- msat amt+    ph <- need "payment hash" (BOLT1.payment_hash (SHA256.hash preimage))+    pure HTLC+      { htlc_direction    = if offered then HTLCOffered else HTLCReceived+      , htlc_amount_msat  = amount+      , htlc_payment_hash = ph+      , htlc_cltv_expiry  = CltvExpiry expiry+      }+  [] -> assertFailure ("no test HTLC #" ++ show i)++testPreimage :: Int -> IO BOLT1.PaymentPreimage+testPreimage i = case drop i c_htlcs of+  (TestHtlc _ _ _ pre : _) ->+    hex pre >>= need "preimage" . BOLT1.payment_preimage+  [] -> assertFailure ("no test HTLC #" ++ show i)++-- | Commitment keys from the Appendix C parameters, which Appendix F+--   shares. The vectors use the payment basepoints as HTLC+--   basepoints; to_remote pays the remote payment basepoint.+vectorKeys :: IO CommitmentKeys+vectorKeys = do+  revocation <- pt c_local_revocation_pubkey+  delayed <- pt c_local_delayedpubkey+  local_htlc <- pt c_local_htlcpubkey+  remote_htlc <- pt c_remote_htlcpubkey+  remote_payment <- pt c_remote_payment_basepoint+  local_funding <- pt c_local_funding_pubkey+  remote_funding <- pt c_remote_funding_pubkey+  pure CommitmentKeys+    { ck_revocation_pubkey = RevocationPubkey revocation+    , ck_local_delayed     = LocalDelayedPubkey delayed+    , ck_local_htlc        = LocalHtlcPubkey local_htlc+    , ck_remote_htlc       = RemoteHtlcPubkey remote_htlc+    , ck_remote_payment    = RemotePubkey remote_payment+    , ck_local_funding     = FundingPubkey local_funding+    , ck_remote_funding    = FundingPubkey remote_funding+    }++vectorOutpoint :: IO BT.OutPoint+vectorOutpoint = do+  txid <- hex c_funding_txid+  t <- need "invalid txid" (BT.mk_txid (BS.reverse txid))+  pure (BT.OutPoint t c_funding_output_index)++-- | The commitment context for a vector: local's commitment, with local+--   as the opener.+vectorContext :: CommitmentFormat -> CommitVector -> IO CommitmentContext+vectorContext fmt v = do+  keys <- vectorKeys+  outpoint <- vectorOutpoint+  local_bp <- PaymentBasepoint <$> pt c_local_payment_basepoint+  remote_bp <- PaymentBasepoint <$> pt c_remote_payment_basepoint+  cn <- need "commitment number" (commitment_number c_commitment_number)+  htlcs <- traverse testHtlc (cv_htlcs v)+  dust <- DustLimit <$> sat (cv_dust_limit_sat v)+  to_local <- msat (cv_to_local_msat v)+  to_remote <- msat (cv_to_remote_msat v)+  pure CommitmentContext+    { cc_funding_outpoint  = outpoint+    , cc_commitment_number = cn+    , cc_local_payment_bp  = local_bp+    , cc_remote_payment_bp = remote_bp+    , cc_to_self_delay     = ToSelfDelay c_local_delay+    , cc_dust_limit        = dust+    , cc_feerate           = FeeratePerKw (cv_feerate_per_kw v)+    , cc_format            = fmt+    , cc_is_funder         = True+    , cc_to_local_msat     = to_local+    , cc_to_remote_msat    = to_remote+    , cc_htlcs             = htlcs+    , cc_keys              = keys+    }++-- | Assert that the commitment tx and each HTLC tx of a vector match+--   the spec's, with witnesses stripped, and that the spec's witnesses+--   are those the witness functions build.+commitVectorTests :: CommitmentFormat -> CommitVector -> TestTree+commitVectorTests fmt v = testGroup (cv_name v) $+    testCase "commitment tx" (do+      ctx <- vectorContext fmt v+      spec <- hex (cv_commit_tx v) >>= decodeTx+      commit <- need "no commitment tx" (build_commitment_tx ctx)+      encode_commitment_tx commit @?= BT.to_bytes_legacy spec+      -- the funding witness, with its signatures in either order+      w <- witnessOf spec+      case w of+        [_, s1, s2, _] -> do+          let keys = cc_keys ctx+              lpk = ck_local_funding keys+              rpk = ck_remote_funding keys+          funding_witness lpk s1 rpk s2 @?= BT.Witness w+          funding_witness rpk s2 lpk s1 @?= BT.Witness w+        _ -> assertFailure "unexpected funding witness")+  : fmap htlcTxTest (cv_htlc_txs v)+  where+    htlcTxTest (HtlcTxVector kind i out raw) =+      testCase (kindName kind ++ " for htlc #" ++ show i+                 ++ " (output " ++ show out ++ ")") $ do+        ctx <- vectorContext fmt v+        commit <- need "no commitment tx" (build_commitment_tx ctx)+        expected_htlc <- testHtlc i+        -- the output names its HTLC+        htlc <- case drop (fromIntegral out) (NE.toList (ctx_outputs commit))+          of+            (CommitmentOutput _ _ (OutputHTLC h) : _) -> pure h+            _ -> assertFailure "not an HTLC output"+        htlc @?= expected_htlc+        let keys = cc_keys ctx+            hctx = HTLCContext+              { hc_commitment_txid   = BT.txid (commitment_to_tx commit)+              , hc_output_index      = out+              , hc_htlc              = htlc+              , hc_to_self_delay     = cc_to_self_delay ctx+              , hc_feerate           = cc_feerate ctx+              , hc_format            = fmt+              , hc_revocation_pubkey = ck_revocation_pubkey keys+              , hc_local_delayed     = ck_local_delayed keys+              }+        spec <- hex raw >>= decodeTx+        htx <- need "no htlc tx" (build_htlc_tx hctx)+        encode_htlc_tx htx @?= BT.to_bytes_legacy spec+        -- the input witness+        w <- witnessOf spec+        let rev = ck_revocation_pubkey keys+            rh = ck_remote_htlc keys+            lh = ck_local_htlc keys+            ph = htlc_payment_hash htlc+        case (kind, w) of+          (HtlcSuccess, [_, rsig, lsig, _, _]) -> do+            pre <- testPreimage i+            let ws = received_htlc_script rev rh lh ph+                       (htlc_cltv_expiry htlc) fmt+            htlc_success_witness rsig lsig pre ws @?= BT.Witness w+            sighashes rsig lsig+          (HtlcTimeout, [_, rsig, lsig, _, _]) -> do+            let ws = offered_htlc_script rev rh lh ph fmt+            htlc_timeout_witness rsig lsig ws @?= BT.Witness w+            sighashes rsig lsig+          _ -> assertFailure "unexpected htlc witness"++    -- the remote signature uses remote_htlc_sighash, the local one+    -- SIGHASH_ALL+    sighashes rsig lsig = do+      let flag = fromIntegral . Sighash.encode_sighash+      fmap snd (BS.unsnoc rsig) @?= Just (flag (remote_htlc_sighash fmt))+      fmap snd (BS.unsnoc lsig) @?= Just (flag Sighash.SIGHASH_ALL)++    kindName HtlcSuccess = "htlc-success tx"+    kindName HtlcTimeout = "htlc-timeout tx"++-- commitment transactions ----------------------------------------------------++simpleVector :: IO CommitVector+simpleVector = case appendix_c of+  (v : _) -> pure v+  [] -> assertFailure "missing Appendix C vectors"++commitmentTests :: TestTree+commitmentTests = testGroup "Commitment transactions" [+    testCase "obscured_commitment_number (Appendix C)" $ do+      o <- PaymentBasepoint <$> pt c_local_payment_basepoint+      a <- PaymentBasepoint <$> pt c_remote_payment_basepoint+      cn <- need "commitment_number" (commitment_number 42)+      obscured_commitment_number o a cn @?= 0x2bb038521914 `xor` 42++  , testCase "obscured commitment number from the accepter's side" $ do+      v <- simpleVector+      opener_ctx <- vectorContext StaticRemotekey v+      spec <- hex (cv_commit_tx v) >>= decodeTx+      -- the accepter's (remote's) commitment, with the owner-relative+      -- payment basepoints swapped and the owner not the funder+      let accepter_ctx = opener_ctx+            { cc_local_payment_bp  = cc_remote_payment_bp opener_ctx+            , cc_remote_payment_bp = cc_local_payment_bp opener_ctx+            , cc_is_funder         = False+            }+      commit <- need "no commitment tx" (build_commitment_tx accepter_ctx)+      let Locktime lt = ctx_locktime commit+          Sequence sq = ctx_input_sequence commit+      lt @?= BT.tx_locktime spec+      [sq] @?= fmap BT.txin_sequence (NE.toList (BT.tx_inputs spec))+      -- the obscured number is 0x2bb038521914 ^ 42+      let obscured = 0x2bb038521914 `xor` 42 :: Word64+      lt @?= 0x20000000 + fromIntegral (obscured `mod` 0x1000000)+      sq @?= 0x80000000 + fromIntegral (obscured `div` 0x1000000)++  , testCase "fee taken from the remote output when it funds" $ do+      v <- simpleVector+      ctx <- vectorContext StaticRemotekey v+      commit <- need "no commitment tx" (build_commitment_tx ctx+                  { cc_is_funder = False })+      -- the 10860 sat base fee comes from to_remote's 3000000 sat+      let values = [ (co_type o, BOLT1.un_satoshi (co_value o))+                   | o <- NE.toList (ctx_outputs commit) ]+      values @?= [(OutputToRemote, 2989140), (OutputToLocal, 7000000)]++  , testCase "no outputs" $ do+      v <- simpleVector+      ctx <- vectorContext Anchors v+      zero <- msat 0+      isNothing (build_commitment_tx ctx+        { cc_to_local_msat = zero, cc_to_remote_msat = zero })+        @?= True++  , testCase "anchors: only the anchor of a materialized output" $ do+      v <- simpleVector+      ctx <- vectorContext Anchors v+      zero <- msat 0+      commit <- need "no commitment tx" (build_commitment_tx ctx+                  { cc_to_remote_msat = zero })+      fmap co_type (NE.toList (ctx_outputs commit))+        @?= [OutputLocalAnchor, OutputToLocal]+  ]++-- HTLC transactions ----------------------------------------------------------++htlcTxTests :: TestTree+htlcTxTests = testGroup "HTLC transactions" [+    testCase "fee exceeding the amount" $ do+      keys <- vectorKeys+      outpoint <- vectorOutpoint+      h <- testHtlc 2   -- offered, 2000 sat+      let ctx = HTLCContext+            { hc_commitment_txid   = BT.op_txid outpoint+            , hc_output_index      = 0+            , hc_htlc              = h+            , hc_to_self_delay     = ToSelfDelay 144+            , hc_feerate           = FeeratePerKw 5000  -- fee 3315+            , hc_format            = StaticRemotekey+            , hc_revocation_pubkey = ck_revocation_pubkey keys+            , hc_local_delayed     = ck_local_delayed keys+            }+      isNothing (build_htlc_tx ctx) @?= True+      -- zero-fee under anchors+      htx <- need "anchors htlc tx" (build_htlc_tx ctx { hc_format = Anchors })+      BOLT1.un_satoshi (htx_output_value htx) @?= 2000+      htx_input_sequence htx @?= Sequence 1+      htx_locktime htx @?= Locktime 502+  ]++-- closing transactions -------------------------------------------------------++p2wpkh :: Word8 -> Script+p2wpkh b = Script (BS.pack [0x00, 0x14] <> BS.replicate 20 b)++closingValues :: ClosingTx -> [(Word64, Script)]+closingValues c =+  [ (BOLT1.un_satoshi (clo_value o), clo_script o)+  | o <- NE.toList (cltx_outputs c) ]++closingTests :: TestTree+closingTests = testGroup "Closing transactions" [+    testGroup "legacy" [+      testCase "fee from the funder, outputs in BIP69 order" $ do+        ctx <- legacy 6000500 4000999 546 1000 True False+        c <- need "no closing tx" (build_legacy_closing_tx ctx)+        closingValues c @?= [(4000, remote_spk), (5000, local_spk)]+        cltx_locktime c @?= Locktime 0+        cltx_input_sequence c @?= Sequence 0xFFFFFFFF+        cltx_version c @?= 2++    , testCase "fee from the remote output when it funds" $ do+        ctx <- legacy 6000000 4000000 546 1000 False False+        c <- need "no closing tx" (build_legacy_closing_tx ctx)+        closingValues c @?= [(3000, remote_spk), (6000, local_spk)]++    , testCase "the signer's dust limit applies to both outputs" $ do+        ctx <- legacy 100000000 600000 1000 500 True False+        c <- need "no closing tx" (build_legacy_closing_tx ctx)+        closingValues c @?= [(99500, local_spk)]++    , testCase "the signer may omit its own output" $ do+        ctx <- legacy 6000000 4000000 546 1000 True True+        c <- need "no closing tx" (build_legacy_closing_tx ctx)+        closingValues c @?= [(4000, remote_spk)]++    , testCase "fee exceeding the funder's balance" $ do+        ctx <- legacy 999999 4000000 546 1000 True False+        isNothing (build_legacy_closing_tx ctx) @?= True++    , testCase "no outputs" $ do+        ctx <- legacy 500000 500000 546 0 True False+        isNothing (build_legacy_closing_tx ctx) @?= True+    ]++  , testGroup "option_simple_close" [+      testCase "closer pays the fee, outputs in BIP69 order" $ do+        ctx <- simple 10000999 5000000 500 CloserAndCloseeOutputs+        c <- need "no closing tx" (build_closing_tx ctx)+        closingValues c @?= [(5000, remote_spk), (9500, local_spk)]+        cltx_locktime c @?= Locktime 800000+        cltx_input_sequence c @?= Sequence 0xFFFFFFFD+        cltx_version c @?= 2++    , testCase "closer output only" $ do+        ctx <- simple 10000000 5000000 500 CloserOutputOnly+        c <- need "no closing tx" (build_closing_tx ctx)+        closingValues c @?= [(9500, local_spk)]++    , testCase "closee output only" $ do+        ctx <- simple 10000000 5000000 500 CloseeOutputOnly+        c <- need "no closing tx" (build_closing_tx ctx)+        closingValues c @?= [(5000, remote_spk)]++    , testCase "OP_RETURN outputs have amount zero and are kept" $ do+        ctx <- simple 10000000 5000000 500 CloserAndCloseeOutputs+        let op_return = Script (BS.pack [0x6a, 0x01, 0x00])+        c <- need "no closing tx" (build_closing_tx ctx+               { clc_closer_script = op_return })+        closingValues c @?= [(0, op_return), (5000, remote_spk)]+        c' <- need "no closing tx" (build_closing_tx ctx+                { clc_closee_script = op_return })+        closingValues c' @?= [(0, op_return), (9500, local_spk)]++    , testCase "dust outputs are not trimmed" $ do+        ctx <- simple 10000000 100000 500 CloserAndCloseeOutputs+        c <- need "no closing tx" (build_closing_tx ctx)+        closingValues c @?= [(100, remote_spk), (9500, local_spk)]++    , testCase "fee exceeding the closer's balance" $ do+        ctx <- simple 499999 5000000 500 CloseeOutputOnly+        isNothing (build_closing_tx ctx) @?= True+    ]+  ]+  where+    local_spk = p2wpkh 0x11+    remote_spk = p2wpkh 0x22++    legacy l r dust fee funder omit = do+      outpoint <- vectorOutpoint+      lm <- msat l+      rm <- msat r+      d <- DustLimit <$> sat dust+      f <- sat fee+      pure LegacyClosingContext+        { lcc_funding_outpoint = outpoint+        , lcc_local_msat       = lm+        , lcc_remote_msat      = rm+        , lcc_local_script     = local_spk+        , lcc_remote_script    = remote_spk+        , lcc_dust_limit       = d+        , lcc_fee              = f+        , lcc_is_funder        = funder+        , lcc_omit_local       = omit+        }++    simple closer closee fee outs = do+      outpoint <- vectorOutpoint+      cm <- msat closer+      em <- msat closee+      f <- sat fee+      pure ClosingContext+        { clc_funding_outpoint = outpoint+        , clc_closer_msat      = cm+        , clc_closee_msat      = em+        , clc_closer_script    = local_spk+        , clc_closee_script    = remote_spk+        , clc_fee              = f+        , clc_locktime         = Locktime 800000+        , clc_outputs          = outs+        }++-- scripts --------------------------------------------------------------------++scriptTests :: TestTree+scriptTests = testGroup "Scripts and witnesses" [+    testCase "to_remote scriptPubKeys" $ do+      pk <- RemotePubkey <$> pt c_remote_payment_basepoint+      let Script ws = to_remote_witness_script pk+      -- <remotepubkey> OP_CHECKSIGVERIFY 1 OP_CHECKSEQUENCEVERIFY+      BS.length ws @?= 37+      BS.drop 34 ws @?= BS.pack [0xad, 0x51, 0xb2]+      to_remote_script_pubkey pk Anchors @?= to_p2wsh (Script ws)+      -- P2WPKH, as in Appendix C's to_remote output+      v <- simpleVector+      spec <- hex (cv_commit_tx v) >>= decodeTx+      let p2wpkhs = [ spk | BT.TxOut _ spk <- NE.toList (BT.tx_outputs spec)+                          , BS.length spk == 22 ]+      [to_remote_script_pubkey pk StaticRemotekey] @?= fmap Script p2wpkhs++  , testCase "to_remote witnesses" $ do+      pk@(RemotePubkey p) <- RemotePubkey <$> pt c_remote_payment_basepoint+      to_remote_witness "sig" pk StaticRemotekey+        @?= BT.Witness ["sig", unpoint p]+      let Script ws = to_remote_witness_script pk+      to_remote_witness "sig" pk Anchors @?= BT.Witness ["sig", ws]++  , testCase "to_local witnesses" $ do+      keys <- vectorKeys+      let s@(Script ws) = to_local_script (ck_revocation_pubkey keys)+            (ToSelfDelay 144) (ck_local_delayed keys)+      to_local_witness_spend "sig" s @?= BT.Witness ["sig", "", ws]+      to_local_witness_revoke "sig" s @?= BT.Witness ["sig", "\x01", ws]++  , testCase "anchor witnesses" $ do+      keys <- vectorKeys+      let fpk = ck_local_funding keys+          Script ws = anchor_script fpk+      anchor_witness_owner "sig" fpk @?= BT.Witness ["sig", ws]+      anchor_witness_anyone fpk @?= BT.Witness ["", ws]++  , testCase "HTLC output witnesses" $ do+      keys <- vectorKeys+      h <- testHtlc 2+      pre <- testPreimage 2+      let rev@(RevocationPubkey rp) = ck_revocation_pubkey keys+          off@(Script ows) = offered_htlc_script rev (ck_remote_htlc keys)+            (ck_local_htlc keys) (htlc_payment_hash h) Anchors+          rcv@(Script rws) = received_htlc_script rev (ck_remote_htlc keys)+            (ck_local_htlc keys) (htlc_payment_hash h) (htlc_cltv_expiry h)+            Anchors+      offered_htlc_witness_preimage "sig" pre off+        @?= BT.Witness ["sig", BOLT1.un_payment_preimage pre, ows]+      offered_htlc_witness_revoke "sig" rev off+        @?= BT.Witness ["sig", unpoint rp, ows]+      received_htlc_witness_timeout "sig" rcv+        @?= BT.Witness ["sig", "", rws]+      received_htlc_witness_revoke "sig" rev rcv+        @?= BT.Witness ["sig", unpoint rp, rws]++  , testCase "remote_htlc_sighash" $ do+      remote_htlc_sighash StaticRemotekey @?= Sighash.SIGHASH_ALL+      remote_htlc_sighash Anchors @?= Sighash.SIGHASH_SINGLE_ANYONECANPAY++  , testCase "CSV delays and CLTV expiries are minimally encoded" $ do+      keys <- vectorKeys+      h <- testHtlc 0+      let rev = ck_revocation_pubkey keys+          delayed = ck_local_delayed keys+          delay d = let Script s = to_local_script rev (ToSelfDelay d) delayed+                    in  BS.take 4 (BS.drop 36 s)+          expiry e =+            let Script s = received_htlc_script rev (ck_remote_htlc keys)+                  (ck_local_htlc keys) (htlc_payment_hash h) (CltvExpiry e)+                  StaticRemotekey+            in  BS.take 5 (BS.drop 130 s)+      delay 16 @?= BS.pack [0x60, 0xb2, 0x75, 0x21]+      delay 17 @?= BS.pack [0x01, 0x11, 0xb2, 0x75]+      delay 0x80 @?= BS.pack [0x02, 0x80, 0x00, 0xb2]+      delay 0x8000 @?= BS.pack [0x03, 0x00, 0x80, 0x00]+      expiry 500 @?= BS.pack [0x02, 0xf4, 0x01, 0xb1, 0x75]+      expiry 0x800000 @?= BS.pack [0x04, 0x00, 0x00, 0x80, 0x00]+  ]++-- fees and trimming ----------------------------------------------------------++feeTests :: TestTree+feeTests = testGroup "Fees and trimming (BOLT #3 fee example)" [+    testCase "HTLC transaction fees" $ do+      fmap BOLT1.un_satoshi+        [ htlc_timeout_fee rate StaticRemotekey+        , htlc_success_fee rate StaticRemotekey+        , htlc_timeout_fee rate Anchors+        , htlc_success_fee rate Anchors ]+        @?= [3315, 3515, 0, 0]++  , testCase "trim thresholds" $ do+      d <- DustLimit <$> sat 546+      fmap (BOLT1.un_satoshi . htlc_trim_threshold d rate StaticRemotekey)+        [HTLCOffered, HTLCReceived] @?= [3861, 4061]++  , testCase "trimmed HTLCs and base fee" $ do+      d <- DustLimit <$> sat 546+      hs <- sequence+        [ example HTLCOffered 5000000, example HTLCOffered 1000000+        , example HTLCReceived 7000000, example HTLCReceived 800000 ]+      fmap (is_trimmed d rate StaticRemotekey) hs+        @?= [False, True, False, True]+      BOLT1.un_satoshi (commitment_fee rate StaticRemotekey 2) @?= 5340+      BOLT1.un_satoshi (commitment_fee rate Anchors 0) @?= 5620++  , testCase "commitment fee saturates" $+      commitment_fee (FeeratePerKw maxBound) StaticRemotekey maxBound+        @?= BOLT1.max_satoshi+  ]+  where+    rate = FeeratePerKw 5000+    example dir amt = do+      a <- msat amt+      ph <- need "payment hash" (BOLT1.payment_hash (BS.replicate 32 0))+      pure (HTLC dir a ph (CltvExpiry 500))++-- smart constructors ---------------------------------------------------------++constructorTests :: TestTree+constructorTests = testGroup "Smart constructors" [+    testCase "commitment_number" $ do+      isJust (commitment_number 0) @?= True+      isJust (commitment_number 0xFFFFFFFFFFFF) @?= True+      isNothing (commitment_number 0x1000000000000) @?= True+  , testCase "next_commitment_number" $ do+      cn <- need "commitment_number" (commitment_number 0xFFFFFFFFFFFE)+      fmap un_commitment_number (next_commitment_number cn)+        @?= Just 0xFFFFFFFFFFFF+      top <- need "commitment_number" (commitment_number 0xFFFFFFFFFFFF)+      isNothing (next_commitment_number top) @?= True+  , testCase "secret_index" $ do+      isJust (secret_index 0xFFFFFFFFFFFF) @?= True+      isNothing (secret_index 0x1000000000000) @?= True+  , testCase "seed" $ do+      isJust (seed (BS.replicate 32 0)) @?= True+      isNothing (seed (BS.replicate 31 0)) @?= True+      isNothing (seed (BS.replicate 33 0)) @?= True+  , testCase "seckey" $ do+      isJust (seckey (BS.replicate 32 0x01)) @?= True+      isNothing (seckey (BS.replicate 31 0x01)) @?= True+      isNothing (seckey (BS.replicate 32 0x00)) @?= True+      -- the group order n is out of range, n - 1 in range+      n <- hex+        "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141"+      n1 <- hex+        "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140"+      isNothing (seckey n) @?= True+      isJust (seckey n1) @?= True+  ]++-- properties -----------------------------------------------------------------++propertyTests :: TestTree+propertyTests = testGroup "Properties" [+    testProperty "derive_privkey matches derive_pubkey" propPrivkey+  , testProperty "derive_revocationprivkey matches derive_revocationpubkey"+      propRevocationPrivkey+  , testProperty "derive_per_commitment_point' = derive_per_commitment_point"+      propPcpWnaf+  , testProperty "derive_commitment_keys' = derive_commitment_keys"+      propCommitmentKeysWnaf+  , testProperty "every inserted secret is derivable, before and after \+                 \a round trip through un_secret_store" propSecretStore+  , testProperty "commitment_number accepts exactly 48-bit values"+      propCommitmentNumber+  , testProperty "commitment_secret_index counts down from 2^48 - 1"+      propSecretIndex+  ]++genBytes :: Int -> Gen BS.ByteString+genBytes n = BS.pack <$> vectorOf n arbitrary++-- | A random valid secret key.+genSeckey :: Gen Seckey+genSeckey = do+  bs <- genBytes 32+  maybe genSeckey pure (seckey bs)++-- | A random point (as the public key of a random secret key).+genPoint :: Gen BOLT1.Point+genPoint = do+  k <- genSeckey+  case pubkey_of k >>= BOLT1.point of+    Just p  -> pure p+    Nothing -> genPoint++genSecret :: Gen BOLT1.PerCommitmentSecret+genSecret = do+  k <- genSeckey+  maybe genSecret pure (BOLT1.per_commitment_secret (un_seckey k))++genBasepoints :: Gen Basepoints+genBasepoints = Basepoints+  <$> fmap RevocationBasepoint genPoint+  <*> fmap PaymentBasepoint genPoint+  <*> fmap DelayedPaymentBasepoint genPoint+  <*> fmap HtlcBasepoint genPoint++propPrivkey :: Property+propPrivkey = forAll genSeckey $ \k -> forAll genPoint $ \p ->+  let pcp = PerCommitmentPoint p+      bp = pubkey_of k >>= BOLT1.point+  in  (pubkey_of =<< derive_privkey k pcp)+        === fmap unpoint (bp >>= \b -> derive_pubkey b pcp)++propRevocationPrivkey :: Property+propRevocationPrivkey = forAll genSeckey $ \k -> forAll genSecret $ \s ->+  let rbp = fmap RevocationBasepoint (pubkey_of k >>= BOLT1.point)+      pcp = derive_per_commitment_point s+      expected = do+        r <- rbp+        c <- pcp+        RevocationPubkey p <- derive_revocationpubkey r c+        pure (unpoint p)+  in  (pubkey_of =<< derive_revocationprivkey k s) === expected++propPcpWnaf :: Property+propPcpWnaf = forAll genSecret $ \s ->+  derive_per_commitment_point' tex s === derive_per_commitment_point s++propCommitmentKeysWnaf :: Property+propCommitmentKeysWnaf =+  forAll genBasepoints $ \l -> forAll genBasepoints $ \r ->+  forAll genPoint $ \lf -> forAll genPoint $ \rf -> forAll genPoint $ \p ->+    let args f = f l (FundingPubkey lf) r (FundingPubkey rf)+                   (PerCommitmentPoint p)+    in  args (derive_commitment_keys' tex) === args derive_commitment_keys++-- | After inserting a prefix of a correct sequence (descending from+--   2^48-1, all from one seed), every inserted index is derivable, and+--   stays so after a round trip through the store's entries.+propSecretStore :: Property+propSecretStore =+  forAll (genBytes 32) $ \sd ->+  forAll (choose (1, 600)) $ \n ->+    case seed sd of+      Nothing -> counterexample "seed" False+      Just s ->+        let idxs = [ i | Just i <- fmap secret_index+                       (take n [0xFFFFFFFFFFFF, 0xFFFFFFFFFFFE ..]) ]+            secret = generate_from_seed s+            insert st i = st >>= insert_secret (secret i) i+            derivable st = conjoin+              [ fmap unsecret (derive_old_secret i st)+                  === Just (unsecret (secret i))+              | i <- idxs ]+        in  case foldl insert (Just empty_secret_store) idxs of+              Nothing -> counterexample "insert_secret rejected" False+              Just store -> case secret_store (un_secret_store store) of+                Nothing -> counterexample "secret_store rejected" False+                Just store' -> derivable store .&&. derivable store'++propCommitmentNumber :: Property+propCommitmentNumber = forAll (choose (0, maxBound)) $ \n ->+  case commitment_number n of+    Just cn -> n <= 0xFFFFFFFFFFFF && un_commitment_number cn == n+    Nothing -> n > 0xFFFFFFFFFFFF++propSecretIndex :: Property+propSecretIndex = forAll (choose (0, 0xFFFFFFFFFFFF)) $ \n ->+  case commitment_number n of+    Nothing -> counterexample "commitment_number" False+    Just cn ->+      un_secret_index (commitment_secret_index cn) === 0xFFFFFFFFFFFF - n