ppad-tx 0.1.0 → 0.2.0

raw patch · 8 files changed

+1735/−376 lines, 8 filesdep ~deepseqdep ~ppad-base16PVP ok

version bump matches the API change (PVP)

Dependency ranges changed: deepseq, ppad-base16

API changes (from Hackage documentation)

Files

• CHANGELOG +27/−1
• bench/Main.hs +103/−19
• bench/Weight.hs +102/−19
• lib/Bitcoin/Prim/Tx.hs +84/−173
• lib/Bitcoin/Prim/Tx/Internal.hs +168/−0
• lib/Bitcoin/Prim/Tx/Sighash.hs +346/−75
• ppad-tx.cabal +11/−10
• test/Main.hs +894/−79

@@ -1,4 +1,30 @@ # Changelog -- 0.1.0 (UNRELEASED)+- 0.2.0 (2026-10-10)+  * Breaking: TxId is abstract. Construct one with mk_txid (replacing+    mkTxId), unwrap it with un_txid; null_txid is the all-zero txid+    coinbase inputs reference.+  * Breaking: each TxIn carries its own witness (txin_witness), and+    Tx's tx_witnesses field is gone, so a transaction can no longer+    hold a different number of witnesses than inputs.+  * Breaking: the serialisation builders (put_compact, put_outpoint,+    to_strict, etc.) are no longer exported.+  * Widens sighash_legacy and sighash_segwit to take a raw 32-bit+    hashType, matching consensus (the full value is committed to the+    preimage; only the low byte determines behaviour). The SighashType+    ADT remains, as the canonical-byte enum, via encode_sighash. This+    is a breaking change.+  * Strips OP_CODESEPARATOR from the script code in legacy sighashes.+  * Adds BIP341 taproot sighashes (sighash_taproot_keypath,+    sighash_taproot_scriptpath).+  * Adds NFData instances for all transaction types, an NFData+    instance for SighashType, and Ord instances for TxId and OutPoint.+  * Fixes from_bytes, which threw an exception on compactSize lengths+    of 2^63 or more, and now rejects counts exceeding the remaining+    input.+  * Rejects segwit-flagged transactions carrying no witness data, and+    serialises transactions whose witnesses are all empty in the legacy+    format, as Bitcoin Core does.++- 0.1.0 (2026-04-18)   * Initial release.

@@ -3,29 +3,22 @@  module Main where -import Control.DeepSeq import Criterion.Main import qualified Data.ByteString as BS import Data.List.NonEmpty (NonEmpty(..))+import Data.Word (Word64)  import Bitcoin.Prim.Tx import Bitcoin.Prim.Tx.Sighash --- NFData instances --------------------------------------------------------------instance NFData TxId-instance NFData OutPoint-instance NFData TxIn-instance NFData TxOut-instance NFData Witness-instance NFData Tx-instance NFData SighashType+-- NFData instances ----------------------------------------------------------- --- sample data -----------------------------------------------------------------+-- sample data ----------------------------------------------------------------  -- | Sample outpoint (references a dummy txid). sampleOutPoint :: OutPoint-sampleOutPoint = OutPoint (TxId (BS.replicate 32 0xab)) 0+sampleOutPoint =+  OutPoint (maybe null_txid id (mk_txid (BS.replicate 32 0xab))) 0  -- | Sample input with typical P2PKH signature (~107 bytes). sampleInput :: TxIn@@ -33,14 +26,16 @@   { txin_prevout    = sampleOutPoint   , txin_script_sig = BS.replicate 107 0x00  -- typical P2PKH sig   , txin_sequence   = 0xffffffff+  , txin_witness    = Witness []   } --- | Sample input for segwit (empty scriptSig).+-- | Sample input for segwit (empty scriptSig, P2WPKH-style witness). sampleSegwitInput :: TxIn sampleSegwitInput = TxIn   { txin_prevout    = sampleOutPoint   , txin_script_sig = BS.empty   , txin_sequence   = 0xffffffff+  , txin_witness    = sampleWitness   }  -- | Sample output with typical P2PKH script (25 bytes).@@ -64,7 +59,6 @@   { tx_version   = 1   , tx_inputs    = sampleInput :| replicate (numInputs - 1) sampleInput   , tx_outputs   = sampleOutput :| replicate (numOutputs - 1) sampleOutput-  , tx_witnesses = []   , tx_locktime  = 0   } @@ -73,13 +67,13 @@ mkSegwitTx :: Int -> Int -> Tx mkSegwitTx !numInputs !numOutputs = Tx   { tx_version   = 2-  , tx_inputs    = sampleSegwitInput :| replicate (numInputs - 1) sampleSegwitInput+  , tx_inputs    =+      sampleSegwitInput :| replicate (numInputs - 1) sampleSegwitInput   , tx_outputs   = sampleOutput :| replicate (numOutputs - 1) sampleOutput-  , tx_witnesses = replicate numInputs sampleWitness   , tx_locktime  = 0   } --- sample transactions ---------------------------------------------------------+-- sample transactions --------------------------------------------------------  smallLegacyTx, mediumLegacyTx, largeLegacyTx :: Tx smallLegacyTx  = mkLegacyTx 1 1@@ -91,7 +85,7 @@ mediumSegwitTx = mkSegwitTx 5 5 largeSegwitTx  = mkSegwitTx 20 20 --- serialised bytes ------------------------------------------------------------+-- serialised bytes -----------------------------------------------------------  smallLegacyBytes, mediumLegacyBytes, largeLegacyBytes :: BS.ByteString smallLegacyBytes  = to_bytes smallLegacyTx@@ -103,8 +97,38 @@ mediumSegwitBytes = to_bytes mediumSegwitTx largeSegwitBytes  = to_bytes largeSegwitTx --- benchmarks ------------------------------------------------------------------+-- sighash inputs ------------------------------------------------------------- +-- | Typical P2PKH scriptPubKey (25 bytes).+sampleScriptPubKey :: BS.ByteString+sampleScriptPubKey = BS.replicate 25 0x00++-- | Typical P2WPKH scriptCode (26 bytes).+sampleScriptCode :: BS.ByteString+sampleScriptCode = BS.replicate 26 0x00++-- | Sample input value (1 BTC in satoshis).+sampleValue :: Word64+sampleValue = 100000000++-- | Typical P2TR scriptPubKey (34 bytes): OP_1 || 0x20 || 32-byte+--   x-only pubkey.+sampleTaprootSpk :: BS.ByteString+sampleTaprootSpk = BS.cons 0x51 (BS.cons 0x20 (BS.replicate 32 0x00))++-- | Amounts/scriptPubKeys lists sized to a tx's input count.+taprootAmts :: Int -> [Word64]+taprootAmts n = replicate n sampleValue++taprootSpks :: Int -> [BS.ByteString]+taprootSpks n = replicate n sampleTaprootSpk++-- | 32-byte placeholder tap leaf hash for script-path benches.+sampleTapLeaf :: BS.ByteString+sampleTapLeaf = BS.replicate 32 0x00++-- benchmarks -----------------------------------------------------------------+ main :: IO () main = defaultMain     [ bgroup "serialisation"@@ -141,4 +165,64 @@         , bench "large-legacy"  $ nf txid largeLegacyTx         , bench "large-segwit"  $ nf txid largeSegwitTx         ]+    , bgroup "sighash"+        [ bgroup "sighash_legacy"+            [ bench "small  / SIGHASH_ALL"    $+                nf (sighashLegacy smallLegacyTx  SIGHASH_ALL)    0+            , bench "medium / SIGHASH_ALL"    $+                nf (sighashLegacy mediumLegacyTx SIGHASH_ALL)    0+            , bench "large  / SIGHASH_ALL"    $+                nf (sighashLegacy largeLegacyTx  SIGHASH_ALL)    0+            , bench "medium / SIGHASH_NONE"   $+                nf (sighashLegacy mediumLegacyTx SIGHASH_NONE)   0+            , bench "medium / SIGHASH_SINGLE" $+                nf (sighashLegacy mediumLegacyTx SIGHASH_SINGLE) 0+            , bench "medium / SIGHASH_ALL|ACP" $+                nf (sighashLegacy mediumLegacyTx+                      SIGHASH_ALL_ANYONECANPAY)                  0+            ]+        , bgroup "sighash_segwit"+            [ bench "small  / SIGHASH_ALL"    $+                nf (sighashSegwit smallSegwitTx  SIGHASH_ALL)    0+            , bench "medium / SIGHASH_ALL"    $+                nf (sighashSegwit mediumSegwitTx SIGHASH_ALL)    0+            , bench "large  / SIGHASH_ALL"    $+                nf (sighashSegwit largeSegwitTx  SIGHASH_ALL)    0+            , bench "medium / SIGHASH_NONE"   $+                nf (sighashSegwit mediumSegwitTx SIGHASH_NONE)   0+            , bench "medium / SIGHASH_SINGLE" $+                nf (sighashSegwit mediumSegwitTx SIGHASH_SINGLE) 0+            , bench "medium / SIGHASH_ALL|ACP" $+                nf (sighashSegwit mediumSegwitTx+                      SIGHASH_ALL_ANYONECANPAY)                  0+            ]+        , bgroup "sighash_taproot_keypath"+            [ bench "small  / DEFAULT" $ nf (taprootKp smallSegwitTx  0x00) 0+            , bench "medium / DEFAULT" $ nf (taprootKp mediumSegwitTx 0x00) 0+            , bench "large  / DEFAULT" $ nf (taprootKp largeSegwitTx  0x00) 0+            , bench "medium / ALL"     $ nf (taprootKp mediumSegwitTx 0x01) 0+            , bench "medium / NONE"    $ nf (taprootKp mediumSegwitTx 0x02) 0+            , bench "medium / SINGLE"  $ nf (taprootKp mediumSegwitTx 0x03) 0+            , bench "medium / ALL|ACP" $ nf (taprootKp mediumSegwitTx 0x81) 0+            ]+        , bgroup "sighash_taproot_scriptpath"+            [ bench "small  / DEFAULT" $ nf (taprootSp smallSegwitTx  0x00) 0+            , bench "medium / DEFAULT" $ nf (taprootSp mediumSegwitTx 0x00) 0+            , bench "large  / DEFAULT" $ nf (taprootSp largeSegwitTx  0x00) 0+            ]+        ]     ]+  where+    sighashLegacy tx st i =+      sighash_legacy tx i sampleScriptPubKey (encode_sighash st)+    sighashSegwit tx st i =+      sighash_segwit tx i sampleScriptCode sampleValue (encode_sighash st)+    taprootKp tx ht i =+      let n = length (tx_inputs tx)+      in  sighash_taproot_keypath tx i+            (taprootAmts n) (taprootSpks n) Nothing ht+    taprootSp tx ht i =+      let n = length (tx_inputs tx)+      in  sighash_taproot_scriptpath tx i+            (taprootAmts n) (taprootSpks n) Nothing+            sampleTapLeaf 0xffffffff ht

@@ -3,29 +3,22 @@  module Main where -import Control.DeepSeq import qualified Data.ByteString as BS import Data.List.NonEmpty (NonEmpty(..))+import Data.Word (Word64) import qualified Weigh as W  import Bitcoin.Prim.Tx import Bitcoin.Prim.Tx.Sighash --- NFData instances --------------------------------------------------------------instance NFData TxId-instance NFData OutPoint-instance NFData TxIn-instance NFData TxOut-instance NFData Witness-instance NFData Tx-instance NFData SighashType+-- NFData instances ----------------------------------------------------------- --- sample data -----------------------------------------------------------------+-- sample data ----------------------------------------------------------------  -- | Sample outpoint (references a dummy txid). sampleOutPoint :: OutPoint-sampleOutPoint = OutPoint (TxId (BS.replicate 32 0xab)) 0+sampleOutPoint =+  OutPoint (maybe null_txid id (mk_txid (BS.replicate 32 0xab))) 0  -- | Sample input with typical P2PKH signature (~107 bytes). sampleInput :: TxIn@@ -33,14 +26,16 @@   { txin_prevout    = sampleOutPoint   , txin_script_sig = BS.replicate 107 0x00  -- typical P2PKH sig   , txin_sequence   = 0xffffffff+  , txin_witness    = Witness []   } --- | Sample input for segwit (empty scriptSig).+-- | Sample input for segwit (empty scriptSig, P2WPKH-style witness). sampleSegwitInput :: TxIn sampleSegwitInput = TxIn   { txin_prevout    = sampleOutPoint   , txin_script_sig = BS.empty   , txin_sequence   = 0xffffffff+  , txin_witness    = sampleWitness   }  -- | Sample output with typical P2PKH script (25 bytes).@@ -64,7 +59,6 @@   { tx_version   = 1   , tx_inputs    = sampleInput :| replicate (numInputs - 1) sampleInput   , tx_outputs   = sampleOutput :| replicate (numOutputs - 1) sampleOutput-  , tx_witnesses = []   , tx_locktime  = 0   } @@ -73,13 +67,13 @@ mkSegwitTx :: Int -> Int -> Tx mkSegwitTx !numInputs !numOutputs = Tx   { tx_version   = 2-  , tx_inputs    = sampleSegwitInput :| replicate (numInputs - 1) sampleSegwitInput+  , tx_inputs    =+      sampleSegwitInput :| replicate (numInputs - 1) sampleSegwitInput   , tx_outputs   = sampleOutput :| replicate (numOutputs - 1) sampleOutput-  , tx_witnesses = replicate numInputs sampleWitness   , tx_locktime  = 0   } --- sample transactions ---------------------------------------------------------+-- sample transactions --------------------------------------------------------  smallLegacyTx, mediumLegacyTx, largeLegacyTx :: Tx smallLegacyTx  = mkLegacyTx 1 1@@ -91,7 +85,7 @@ mediumSegwitTx = mkSegwitTx 5 5 largeSegwitTx  = mkSegwitTx 20 20 --- serialised bytes ------------------------------------------------------------+-- serialised bytes -----------------------------------------------------------  smallLegacyBytes, mediumLegacyBytes, largeLegacyBytes :: BS.ByteString smallLegacyBytes  = to_bytes smallLegacyTx@@ -103,8 +97,31 @@ mediumSegwitBytes = to_bytes mediumSegwitTx largeSegwitBytes  = to_bytes largeSegwitTx --- allocation benchmarks -------------------------------------------------------+-- sighash inputs ------------------------------------------------------------- +sampleScriptPubKey :: BS.ByteString+sampleScriptPubKey = BS.replicate 25 0x00++sampleScriptCode :: BS.ByteString+sampleScriptCode = BS.replicate 26 0x00++sampleValue :: Word64+sampleValue = 100000000++sampleTaprootSpk :: BS.ByteString+sampleTaprootSpk = BS.cons 0x51 (BS.cons 0x20 (BS.replicate 32 0x00))++taprootAmts :: Int -> [Word64]+taprootAmts n = replicate n sampleValue++taprootSpks :: Int -> [BS.ByteString]+taprootSpks n = replicate n sampleTaprootSpk++sampleTapLeaf :: BS.ByteString+sampleTapLeaf = BS.replicate 32 0x00++-- allocation benchmarks ------------------------------------------------------+ main :: IO () main = W.mainWith $ do     -- to_bytes@@ -138,3 +155,69 @@     W.func "txid/medium-segwit" txid mediumSegwitTx     W.func "txid/large-legacy"  txid largeLegacyTx     W.func "txid/large-segwit"  txid largeSegwitTx++    -- sighash_legacy+    W.func "sighash_legacy/small  / SIGHASH_ALL"+      (sighashLegacy smallLegacyTx  SIGHASH_ALL)    0+    W.func "sighash_legacy/medium / SIGHASH_ALL"+      (sighashLegacy mediumLegacyTx SIGHASH_ALL)    0+    W.func "sighash_legacy/large  / SIGHASH_ALL"+      (sighashLegacy largeLegacyTx  SIGHASH_ALL)    0+    W.func "sighash_legacy/medium / SIGHASH_NONE"+      (sighashLegacy mediumLegacyTx SIGHASH_NONE)   0+    W.func "sighash_legacy/medium / SIGHASH_SINGLE"+      (sighashLegacy mediumLegacyTx SIGHASH_SINGLE) 0+    W.func "sighash_legacy/medium / SIGHASH_ALL|ACP"+      (sighashLegacy mediumLegacyTx SIGHASH_ALL_ANYONECANPAY) 0++    -- sighash_segwit+    W.func "sighash_segwit/small  / SIGHASH_ALL"+      (sighashSegwit smallSegwitTx  SIGHASH_ALL)    0+    W.func "sighash_segwit/medium / SIGHASH_ALL"+      (sighashSegwit mediumSegwitTx SIGHASH_ALL)    0+    W.func "sighash_segwit/large  / SIGHASH_ALL"+      (sighashSegwit largeSegwitTx  SIGHASH_ALL)    0+    W.func "sighash_segwit/medium / SIGHASH_NONE"+      (sighashSegwit mediumSegwitTx SIGHASH_NONE)   0+    W.func "sighash_segwit/medium / SIGHASH_SINGLE"+      (sighashSegwit mediumSegwitTx SIGHASH_SINGLE) 0+    W.func "sighash_segwit/medium / SIGHASH_ALL|ACP"+      (sighashSegwit mediumSegwitTx SIGHASH_ALL_ANYONECANPAY) 0++    -- sighash_taproot_keypath+    W.func "sighash_taproot_keypath/small  / DEFAULT"+      (taprootKp smallSegwitTx  0x00) 0+    W.func "sighash_taproot_keypath/medium / DEFAULT"+      (taprootKp mediumSegwitTx 0x00) 0+    W.func "sighash_taproot_keypath/large  / DEFAULT"+      (taprootKp largeSegwitTx  0x00) 0+    W.func "sighash_taproot_keypath/medium / ALL"+      (taprootKp mediumSegwitTx 0x01) 0+    W.func "sighash_taproot_keypath/medium / NONE"+      (taprootKp mediumSegwitTx 0x02) 0+    W.func "sighash_taproot_keypath/medium / SINGLE"+      (taprootKp mediumSegwitTx 0x03) 0+    W.func "sighash_taproot_keypath/medium / ALL|ACP"+      (taprootKp mediumSegwitTx 0x81) 0++    -- sighash_taproot_scriptpath+    W.func "sighash_taproot_scriptpath/small  / DEFAULT"+      (taprootSp smallSegwitTx  0x00) 0+    W.func "sighash_taproot_scriptpath/medium / DEFAULT"+      (taprootSp mediumSegwitTx 0x00) 0+    W.func "sighash_taproot_scriptpath/large  / DEFAULT"+      (taprootSp largeSegwitTx  0x00) 0+  where+    sighashLegacy tx st i =+      sighash_legacy tx i sampleScriptPubKey (encode_sighash st)+    sighashSegwit tx st i =+      sighash_segwit tx i sampleScriptCode sampleValue (encode_sighash st)+    taprootKp tx ht i =+      let n = length (tx_inputs tx)+      in  sighash_taproot_keypath tx i+            (taprootAmts n) (taprootSpks n) Nothing ht+    taprootSp tx ht i =+      let n = length (tx_inputs tx)+      in  sighash_taproot_scriptpath tx i+            (taprootAmts n) (taprootSpks n) Nothing+            sampleTapLeaf 0xffffffff ht

@@ -1,6 +1,5 @@ {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -20,8 +19,10 @@   , TxOut(..)   , OutPoint(..)   , Witness(..)-  , TxId(..)-  , mkTxId+  , TxId+  , mk_txid+  , un_txid+  , null_txid      -- * Serialisation   , to_bytes@@ -32,84 +33,47 @@      -- * TxId   , txid--    -- * Internal (for Sighash)-  , put_word32_le-  , put_word64_le-  , put_compact-  , put_outpoint-  , put_txout-  , to_strict   ) where +import Bitcoin.Prim.Tx.Internal import qualified Crypto.Hash.SHA256 as SHA256 import Data.Bits ((.|.), shiftL) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Builder as BSB-import qualified Data.ByteString.Lazy as BL import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import Data.Word (Word32, Word64)-import GHC.Generics (Generic) --- | Transaction ID (32 bytes, little-endian double-SHA256).-newtype TxId = TxId BS.ByteString-  deriving (Eq, Show, Generic)---- | Construct a TxId from a 32-byte ByteString.+-- | Construct a 'TxId' from 32 bytes in internal byte order (the+--   reverse of the usual hex display). -- --   Returns 'Nothing' if the input is not exactly 32 bytes. -----   @---   mkTxId (BS.replicate 32 0x00) == Just (TxId ...)---   mkTxId (BS.replicate 31 0x00) == Nothing---   @-mkTxId :: BS.ByteString -> Maybe TxId-mkTxId bs+--   >>> fmap (BS.length . un_txid) (mk_txid (BS.replicate 32 0x00))+--   Just 32+--   >>> mk_txid (BS.replicate 31 0x00)+--   Nothing+mk_txid :: BS.ByteString -> Maybe TxId+mk_txid bs   | BS.length bs == 32 = Just (TxId bs)   | otherwise          = Nothing --- | Transaction outpoint (txid + output index).-data OutPoint = OutPoint-  { op_txid  :: {-# UNPACK #-} !TxId-  , op_vout  :: {-# UNPACK #-} !Word32-  } deriving (Eq, Show, Generic)---- | Transaction input.-data TxIn = TxIn-  { txin_prevout    :: {-# UNPACK #-} !OutPoint-  , txin_script_sig :: !BS.ByteString-  , txin_sequence   :: {-# UNPACK #-} !Word32-  } deriving (Eq, Show, Generic)---- | Transaction output.-data TxOut = TxOut-  { txout_value         :: {-# UNPACK #-} !Word64  -- ^ satoshis-  , txout_script_pubkey :: !BS.ByteString-  } deriving (Eq, Show, Generic)---- | Witness stack for a single input.-newtype Witness = Witness [BS.ByteString]-  deriving (Eq, Show, Generic)+-- | The 32 bytes of a 'TxId', in internal byte order.+un_txid :: TxId -> BS.ByteString+un_txid (TxId bs) = bs+{-# INLINE un_txid #-} --- | Complete transaction.------   Bitcoin requires at least one input and one output, enforced here---   via 'NonEmpty' lists.-data Tx = Tx-  { tx_version   :: {-# UNPACK #-} !Word32-  , tx_inputs    :: !(NonEmpty TxIn)-  , tx_outputs   :: !(NonEmpty TxOut)-  , tx_witnesses :: ![Witness]  -- ^ empty list for legacy tx-  , tx_locktime  :: {-# UNPACK #-} !Word32-  } deriving (Eq, Show, Generic)+-- | The all-zero 'TxId', referenced by coinbase inputs' outpoints.+null_txid :: TxId+null_txid = TxId (BS.replicate 32 0x00) --- serialisation ---------------------------------------------------------------+-- serialisation --------------------------------------------------------------  -- | Serialise a transaction to bytes. -----   Uses segwit format if witnesses are present, legacy otherwise.+--   Uses the segwit format if any input has a non-empty witness, and+--   the legacy format otherwise (as Bitcoin Core does). -- --   @ --   -- round-trip@@ -117,8 +81,8 @@ --   @ to_bytes :: Tx -> BS.ByteString to_bytes tx@Tx {..}-    | null tx_witnesses = to_bytes_legacy tx-    | otherwise         = to_strict $+    | not (any (has_witness . txin_witness) tx_inputs) = to_bytes_legacy tx+    | otherwise = to_strict $            put_word32_le tx_version         <> BSB.word8 0x00  -- marker         <> BSB.word8 0x01  -- flag@@ -126,19 +90,24 @@         <> foldMap put_txin tx_inputs         <> put_compact (fromIntegral (NE.length tx_outputs))         <> foldMap put_txout tx_outputs-        <> foldMap put_witness tx_witnesses+        <> foldMap (put_witness . txin_witness) tx_inputs         <> put_word32_le tx_locktime +-- whether a witness stack is non-empty+has_witness :: Witness -> Bool+has_witness (Witness items) = not (null items)+{-# INLINE has_witness #-}+ -- | Serialise a transaction to legacy format (no witness data). -- --   Used for txid computation. Excludes witness data even if present. -- --   @---   -- for legacy tx (no witnesses), same as to_bytes---   to_bytes_legacy legacyTx == to_bytes legacyTx+--   -- for a legacy tx (no witnesses), the same as to_bytes+--   to_bytes_legacy legacy_tx == to_bytes legacy_tx -----   -- for segwit tx, strips witnesses---   BS.length (to_bytes_legacy segwitTx) < BS.length (to_bytes segwitTx)+--   -- for a segwit tx, strips the witnesses+--   BS.length (to_bytes_legacy segwit_tx) < BS.length (to_bytes segwit_tx) --   @ to_bytes_legacy :: Tx -> BS.ByteString to_bytes_legacy Tx {..} = to_strict $@@ -168,75 +137,7 @@   bs <- B16.decode b16   from_bytes bs --- internal: builders -------------------------------------------------------------- | Convert a Builder to a strict ByteString.-to_strict :: BSB.Builder -> BS.ByteString-to_strict = BL.toStrict . BSB.toLazyByteString-{-# INLINE to_strict #-}---- | Encode a Word32 as little-endian bytes.-put_word32_le :: Word32 -> BSB.Builder-put_word32_le = BSB.word32LE-{-# INLINE put_word32_le #-}---- | Encode a Word64 as little-endian bytes.-put_word64_le :: Word64 -> BSB.Builder-put_word64_le = BSB.word64LE-{-# INLINE put_word64_le #-}---- | Encode a Word64 as Bitcoin compactSize (varint).------   Encoding:---   - 0x00-0xfc: 1 byte (value itself)---   - 0xfd-0xffff: 0xfd ++ 2 bytes LE---   - 0x10000-0xffffffff: 0xfe ++ 4 bytes LE---   - larger: 0xff ++ 8 bytes LE-put_compact :: Word64 -> BSB.Builder-put_compact !n-    | n <= 0xfc       = BSB.word8 (fromIntegral n)-    | n <= 0xffff     = BSB.word8 0xfd <> BSB.word16LE (fromIntegral n)-    | n <= 0xffffffff = BSB.word8 0xfe <> BSB.word32LE (fromIntegral n)-    | otherwise       = BSB.word8 0xff <> BSB.word64LE n-{-# INLINE put_compact #-}---- | Encode an OutPoint (txid + vout).-put_outpoint :: OutPoint -> BSB.Builder-put_outpoint OutPoint {..} =-    let !(TxId !txid_bs) = op_txid-    in  BSB.byteString txid_bs <> put_word32_le op_vout-{-# INLINE put_outpoint #-}---- | Encode a TxIn.-put_txin :: TxIn -> BSB.Builder-put_txin TxIn {..} =-       put_outpoint txin_prevout-    <> put_compact (fromIntegral (BS.length txin_script_sig))-    <> BSB.byteString txin_script_sig-    <> put_word32_le txin_sequence-{-# INLINE put_txin #-}---- | Encode a TxOut.-put_txout :: TxOut -> BSB.Builder-put_txout TxOut {..} =-       put_word64_le txout_value-    <> put_compact (fromIntegral (BS.length txout_script_pubkey))-    <> BSB.byteString txout_script_pubkey-{-# INLINE put_txout #-}---- | Encode a Witness stack.-put_witness :: Witness -> BSB.Builder-put_witness (Witness items) =-       put_compact (fromIntegral (length items))-    <> foldMap put_witness_item items-  where-    put_witness_item :: BS.ByteString -> BSB.Builder-    put_witness_item !item =-           put_compact (fromIntegral (BS.length item))-        <> BSB.byteString item-{-# INLINE put_witness #-}---- decoding --------------------------------------------------------------------+-- decoding -------------------------------------------------------------------  -- | Parse a transaction from bytes. --@@ -268,12 +169,12 @@   -- input count   (input_count, off1) <- get_compact bs off0   -- inputs (must have at least one)-  (inputs_list, off2) <- get_many get_txin bs off1 (fromIntegral input_count)+  (inputs_list, off2) <- get_many get_txin bs off1 input_count   inputs <- NE.nonEmpty inputs_list   -- output count   (output_count, off3) <- get_compact bs off2   -- outputs (must have at least one)-  (outputs_list, off4) <- get_many get_txout bs off3 (fromIntegral output_count)+  (outputs_list, off4) <- get_many get_txout bs off3 output_count   outputs <- NE.nonEmpty outputs_list   -- locktime (4 bytes)   guard (BS.length bs >= off4 + 4)@@ -281,7 +182,7 @@       !off5 = off4 + 4   -- should have consumed all bytes   guard (off5 == BS.length bs)-  pure $! Tx version inputs outputs [] locktime+  pure $! Tx version inputs outputs locktime  -- Parse segwit transaction (with witness data) parse_segwit :: BS.ByteString -> Word32 -> Int -> Maybe Tx@@ -289,25 +190,37 @@   -- input count   (input_count, off1) <- get_compact bs off0   -- inputs (must have at least one)-  (inputs_list, off2) <- get_many get_txin bs off1 (fromIntegral input_count)+  (inputs_list, off2) <- get_many get_txin bs off1 input_count   inputs <- NE.nonEmpty inputs_list   -- output count   (output_count, off3) <- get_compact bs off2   -- outputs (must have at least one)-  (outputs_list, off4) <- get_many get_txout bs off3 (fromIntegral output_count)+  (outputs_list, off4) <- get_many get_txout bs off3 output_count   outputs <- NE.nonEmpty outputs_list   -- witnesses (one per input)-  (witnesses, off5) <- get_many get_witness bs off4 (fromIntegral input_count)+  (witnesses, off5) <- get_many get_witness bs off4 input_count+  -- a marker and flag with no witness data is invalid (Bitcoin Core:+  -- "superfluous witness record")+  guard (any has_witness witnesses)   -- locktime (4 bytes)   guard (BS.length bs >= off5 + 4)   let !locktime = get_word32_le bs off5       !off6 = off5 + 4   -- should have consumed all bytes   guard (off6 == BS.length bs)-  pure $! Tx version inputs outputs witnesses locktime+  pure $! Tx version (attach_witnesses inputs witnesses) outputs locktime --- internal helpers ------------------------------------------------------------+-- Pair each input with its witness (get_many returns exactly one per+-- input).+attach_witnesses :: NonEmpty TxIn -> [Witness] -> NonEmpty TxIn+attach_witnesses (i :| is) ws = case ws of+  (w : rest) -> set i w :| zipWith set is rest+  []         -> i :| is+  where+    set x w = x { txin_witness = w } +-- internal helpers -----------------------------------------------------------+ -- | Guard for Maybe monad. guard :: Bool -> Maybe () guard True  = Just ()@@ -410,17 +323,13 @@ get_txin !bs !off0 = do   -- outpoint: 36 bytes   (outpoint, off1) <- get_outpoint bs off0-  -- scriptSig length + bytes-  (script_len, off2) <- get_compact bs off1-  let !slen = fromIntegral script_len-  guard (BS.length bs >= off2 + slen)-  let !script_sig = BS.take slen (BS.drop off2 bs)-      !off3 = off2 + slen+  -- scriptSig+  (script_sig, off3) <- get_bytes bs off1   -- sequence: 4 bytes   guard (BS.length bs >= off3 + 4)   let !seqn = get_word32_le bs off3       !off4 = off3 + 4-  pure (TxIn outpoint script_sig seqn, off4)+  pure (TxIn outpoint script_sig seqn (Witness []), off4)  -- | Decode a transaction output. --   Returns (TxOut, new_offset).@@ -430,13 +339,9 @@   guard (BS.length bs >= off0 + 8)   let !value = get_word64_le bs off0       !off1 = off0 + 8-  -- scriptPubKey length + bytes-  (script_len, off2) <- get_compact bs off1-  let !slen = fromIntegral script_len-  guard (BS.length bs >= off2 + slen)-  let !script_pk = BS.take slen (BS.drop off2 bs)-      !off3 = off2 + slen-  pure (TxOut value script_pk, off3)+  -- scriptPubKey+  (script_pk, off2) <- get_bytes bs off1+  pure (TxOut value script_pk, off2)  -- | Decode a witness stack for one input. --   Returns (Witness, new_offset).@@ -445,23 +350,28 @@   -- stack item count   (item_count, off1) <- get_compact bs off0   -- each item: length + bytes-  (items, off2) <- get_many get_witness_item bs off1 (fromIntegral item_count)+  (items, off2) <- get_many get_bytes bs off1 item_count   pure (Witness items, off2) --- | Decode a single witness stack item (length-prefixed bytes).-get_witness_item :: BS.ByteString -> Int -> Maybe (BS.ByteString, Int)-get_witness_item !bs !off0 = do-  (item_len, off1) <- get_compact bs off0-  let !ilen = fromIntegral item_len-  guard (BS.length bs >= off1 + ilen)-  let !item = BS.take ilen (BS.drop off1 bs)-  pure (item, off1 + ilen)+-- | Decode compactSize-length-prefixed bytes.+--   Returns (bytes, new_offset).+get_bytes :: BS.ByteString -> Int -> Maybe (BS.ByteString, Int)+get_bytes !bs !off0 = do+  (len, off1) <- get_compact bs off0+  -- compare in Word64, so that huge lengths can't wrap negative+  guard (len <= fromIntegral (BS.length bs - off1))+  let !n = fromIntegral len+  pure (BS.take n (BS.drop off1 bs), off1 + n) --- | Decode multiple items using a decoder function.+-- | Decode a counted sequence of items using a decoder function. --   Returns (list of items, new_offset). get_many :: (BS.ByteString -> Int -> Maybe (a, Int))-         -> BS.ByteString -> Int -> Int -> Maybe ([a], Int)-get_many getter !bs = go []+         -> BS.ByteString -> Int -> Word64 -> Maybe ([a], Int)+get_many getter !bs !off0 !count+  -- every item occupies at least one byte, so a larger count is+  -- malformed (and might not fit in an Int)+  | count > fromIntegral (BS.length bs - off0) = Nothing+  | otherwise = go [] off0 (fromIntegral count :: Int)   where     go !acc !off !n       | n <= 0    = Just (reverse acc, off)@@ -470,17 +380,18 @@           go (item : acc) off' (n - 1) {-# INLINE get_many #-} --- txid ------------------------------------------------------------------------+-- txid -----------------------------------------------------------------------  -- | Compute the transaction ID (double SHA256 of legacy serialisation). -- --   The txid is computed from the legacy serialisation, so segwit---   transactions have the same txid regardless of witness data.+--   transactions have the same txid regardless of witness data. It is+--   in internal byte order; reverse it for the usual hex display. -- --   @ --   -- Satoshi->Hal tx (block 170)---   txid satoshiHalTx ==---     TxId "f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16"+--   B16.encode (BS.reverse (un_txid (txid satoshi_hal_tx)))+--     == "f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16" --   @ txid :: Tx -> TxId txid tx = TxId (SHA256.hash (SHA256.hash (to_bytes_legacy tx)))

@@ -0,0 +1,168 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module: Bitcoin.Prim.Tx.Internal+-- Copyright: (c) 2025 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Transaction types and serialisation builders, shared by the public+-- modules.++module Bitcoin.Prim.Tx.Internal (+    -- * Transaction types+    TxId(..)+  , OutPoint(..)+  , TxIn(..)+  , TxOut(..)+  , Witness(..)+  , Tx(..)++    -- * Builders+  , to_strict+  , put_word32_le+  , put_word64_le+  , put_compact+  , put_bytes+  , put_outpoint+  , put_txin+  , put_txout+  , put_witness+  ) where++import Control.DeepSeq (NFData(..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BL+import Data.List.NonEmpty (NonEmpty(..))+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)++-- types ----------------------------------------------------------------------++-- | Transaction ID: 32 bytes, the double-SHA256 of the transaction's+--   legacy serialisation, in internal byte order (the reverse of the+--   usual hex display).+newtype TxId = TxId BS.ByteString+  deriving (Eq, Ord, Show, Generic)++instance NFData TxId++-- | Transaction outpoint (txid + output index).+data OutPoint = OutPoint+  { op_txid  :: {-# UNPACK #-} !TxId+  , op_vout  :: {-# UNPACK #-} !Word32+  } deriving (Eq, Ord, Show, Generic)++instance NFData OutPoint++-- | Witness stack for a single input (empty for a non-witness input).+newtype Witness = Witness [BS.ByteString]+  deriving (Eq, Show, Generic)++instance NFData Witness++-- | Transaction input.+data TxIn = TxIn+  { txin_prevout    :: {-# UNPACK #-} !OutPoint+  , txin_script_sig :: !BS.ByteString+  , txin_sequence   :: {-# UNPACK #-} !Word32+  , txin_witness    :: !Witness+  } deriving (Eq, Show, Generic)++instance NFData TxIn++-- | Transaction output.+data TxOut = TxOut+  { txout_value         :: {-# UNPACK #-} !Word64  -- ^ satoshis+  , txout_script_pubkey :: !BS.ByteString+  } deriving (Eq, Show, Generic)++instance NFData TxOut++-- | Complete transaction.+--+--   Bitcoin requires at least one input and one output, enforced here+--   via 'NonEmpty' lists. Each input carries its own witness, so a+--   transaction is serialised in the segwit format exactly when some+--   input's witness is non-empty.+data Tx = Tx+  { tx_version   :: {-# UNPACK #-} !Word32+  , tx_inputs    :: !(NonEmpty TxIn)+  , tx_outputs   :: !(NonEmpty TxOut)+  , tx_locktime  :: {-# UNPACK #-} !Word32+  } deriving (Eq, Show, Generic)++instance NFData Tx++-- builders -------------------------------------------------------------------++-- | Convert a Builder to a strict ByteString.+to_strict :: BSB.Builder -> BS.ByteString+to_strict = BL.toStrict . BSB.toLazyByteString+{-# INLINE to_strict #-}++-- | Encode a Word32 as little-endian bytes.+put_word32_le :: Word32 -> BSB.Builder+put_word32_le = BSB.word32LE+{-# INLINE put_word32_le #-}++-- | Encode a Word64 as little-endian bytes.+put_word64_le :: Word64 -> BSB.Builder+put_word64_le = BSB.word64LE+{-# INLINE put_word64_le #-}++-- | Encode a Word64 as Bitcoin compactSize (varint).+--+--   Encoding:+--   - 0x00-0xfc: 1 byte (value itself)+--   - 0xfd-0xffff: 0xfd ++ 2 bytes LE+--   - 0x10000-0xffffffff: 0xfe ++ 4 bytes LE+--   - larger: 0xff ++ 8 bytes LE+put_compact :: Word64 -> BSB.Builder+put_compact !n+    | n <= 0xfc       = BSB.word8 (fromIntegral n)+    | n <= 0xffff     = BSB.word8 0xfd <> BSB.word16LE (fromIntegral n)+    | n <= 0xffffffff = BSB.word8 0xfe <> BSB.word32LE (fromIntegral n)+    | otherwise       = BSB.word8 0xff <> BSB.word64LE n+{-# INLINE put_compact #-}++-- | Encode compactSize-length-prefixed bytes (Bitcoin @ser_string@).+put_bytes :: BS.ByteString -> BSB.Builder+put_bytes !bs =+     put_compact (fromIntegral (BS.length bs))+  <> BSB.byteString bs+{-# INLINE put_bytes #-}++-- | Encode an OutPoint (txid + vout).+put_outpoint :: OutPoint -> BSB.Builder+put_outpoint OutPoint {..} =+    let !(TxId !txid_bs) = op_txid+    in  BSB.byteString txid_bs <> put_word32_le op_vout+{-# INLINE put_outpoint #-}++-- | Encode a TxIn (without its witness, which is serialised+--   separately).+put_txin :: TxIn -> BSB.Builder+put_txin TxIn {..} =+       put_outpoint txin_prevout+    <> put_bytes txin_script_sig+    <> put_word32_le txin_sequence+{-# INLINE put_txin #-}++-- | Encode a TxOut.+put_txout :: TxOut -> BSB.Builder+put_txout TxOut {..} =+       put_word64_le txout_value+    <> put_bytes txout_script_pubkey+{-# INLINE put_txout #-}++-- | Encode a Witness stack.+put_witness :: Witness -> BSB.Builder+put_witness (Witness items) =+       put_compact (fromIntegral (length items))+    <> foldMap put_bytes items+{-# INLINE put_witness #-}

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  -- |@@ -9,38 +10,59 @@ -- License: MIT -- Maintainer: Jared Tobin <jared@ppad.tech> ----- Sighash computation for legacy and BIP143 segwit transactions.+-- Sighash computation for legacy, BIP143 segwit, and BIP341 taproot+-- transactions.  module Bitcoin.Prim.Tx.Sighash (     -- * Sighash Types     SighashType(..)+  , encode_sighash      -- * Legacy Sighash   , sighash_legacy      -- * BIP143 Segwit Sighash   , sighash_segwit++    -- * BIP341 Taproot Sighash+  , sighash_taproot_keypath+  , sighash_taproot_scriptpath++    -- * Script code+  , strip_codeseparators   ) where -import Bitcoin.Prim.Tx+import Bitcoin.Prim.Tx.Internal     ( Tx(..)     , TxIn(..)     , TxOut(..)     , put_word32_le     , put_word64_le     , put_compact+    , put_bytes     , put_outpoint+    , put_txin     , put_txout     , to_strict     )+import Control.DeepSeq (NFData)+import Control.Monad (guard) import qualified Crypto.Hash.SHA256 as SHA256+import Data.Bits ((.&.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB import qualified Data.List.NonEmpty as NE-import Data.Word (Word8, Word64)+import Data.Word (Word8, Word32, Word64) import GHC.Generics (Generic) --- | Sighash type flags.+-- | Canonical sighash type flags.+--+--   The Bitcoin consensus rules commit the full 32-bit @hashType@ to+--   the signature preimage and only use its low byte for behavioral+--   dispatch (low 5 bits select base type; bit 0x80 selects+--   ANYONECANPAY). 'SighashType' enumerates the six canonical+--   single-byte hashTypes; pass arbitrary 32-bit values directly when+--   reproducing non-canonical hashes. data SighashType   = SIGHASH_ALL   | SIGHASH_NONE@@ -50,35 +72,42 @@   | SIGHASH_SINGLE_ANYONECANPAY   deriving (Eq, Show, Generic) --- | Encode sighash type to byte value.-sighash_byte :: SighashType -> Word8-sighash_byte !st = case st of-  SIGHASH_ALL                -> 0x01-  SIGHASH_NONE               -> 0x02-  SIGHASH_SINGLE             -> 0x03+instance NFData SighashType++-- | Encode a canonical 'SighashType' to its 32-bit hashType value.+--+--   @+--   encode_sighash SIGHASH_ALL                 == 0x01+--   encode_sighash SIGHASH_SINGLE_ANYONECANPAY == 0x83+--   @+encode_sighash :: SighashType -> Word32+encode_sighash !st = case st of+  SIGHASH_ALL                 -> 0x01+  SIGHASH_NONE                -> 0x02+  SIGHASH_SINGLE              -> 0x03   SIGHASH_ALL_ANYONECANPAY    -> 0x81   SIGHASH_NONE_ANYONECANPAY   -> 0x82   SIGHASH_SINGLE_ANYONECANPAY -> 0x83-{-# INLINE sighash_byte #-}+{-# INLINE encode_sighash #-} --- | Check if ANYONECANPAY flag is set.-is_anyonecanpay :: SighashType -> Bool-is_anyonecanpay !st = case st of-  SIGHASH_ALL_ANYONECANPAY    -> True-  SIGHASH_NONE_ANYONECANPAY   -> True-  SIGHASH_SINGLE_ANYONECANPAY -> True-  _                           -> False-{-# INLINE is_anyonecanpay #-}+-- | Internal base sighash classification derived from a 32-bit hashType.+data BaseType = BaseAll | BaseNone | BaseSingle+  deriving Eq --- | Get base sighash type (without ANYONECANPAY).-base_type :: SighashType -> SighashType-base_type !st = case st of-  SIGHASH_ALL_ANYONECANPAY    -> SIGHASH_ALL-  SIGHASH_NONE_ANYONECANPAY   -> SIGHASH_NONE-  SIGHASH_SINGLE_ANYONECANPAY -> SIGHASH_SINGLE-  other                       -> other+-- | Behavioral base type: @hashType & 0x1f@. 2 → NONE, 3 → SINGLE,+--   anything else → ALL.+base_type :: Word32 -> BaseType+base_type !ht = case ht .&. 0x1f of+  2 -> BaseNone+  3 -> BaseSingle+  _ -> BaseAll {-# INLINE base_type #-} +-- | Check ANYONECANPAY flag: @hashType & 0x80@.+is_anyonecanpay :: Word32 -> Bool+is_anyonecanpay !ht = (ht .&. 0x80) /= 0+{-# INLINE is_anyonecanpay #-}+ -- | 32 zero bytes. zero32 :: BS.ByteString zero32 = BS.replicate 32 0x00@@ -94,36 +123,95 @@ hash256 = SHA256.hash . SHA256.hash {-# INLINE hash256 #-} +-- | Strip @OP_CODESEPARATOR@ (0xab) opcodes from a script, skipping+--   push-data sections so that data bytes equal to 0xab are preserved.+--+--   This is consensus-required preprocessing for the legacy sighash+--   scriptCode (see Bitcoin Core's @CTransactionSignatureSerializer@).+--   BIP143 segwit sighash does /not/ perform this stripping; for+--   segwit, the caller is responsible for trimming the scriptCode to+--   the portion after the last executed @OP_CODESEPARATOR@.+--+--   On a malformed script (truncated push data), the malformed tail is+--   copied verbatim without further codeseparator processing.+strip_codeseparators :: BS.ByteString -> BS.ByteString+strip_codeseparators !script+  | not (0xab `BS.elem` script) = script  -- fast path: nothing to strip+  | otherwise = BS.pack (go (BS.unpack script))+  where+    go :: [Word8] -> [Word8]+    go [] = []+    go (b : rest)+      | b == 0xab              = go rest+      | b >= 0x01 && b <= 0x4b = push (fromIntegral b) [b] rest+      | b == 0x4c              = case rest of+          (n : rest') -> push (fromIntegral n) [b, n] rest'+          []          -> [b]+      | b == 0x4d              = case rest of+          (n0 : n1 : rest') ->+            let !len = fromIntegral n0+                     + fromIntegral n1 * 0x100+            in  push len [b, n0, n1] rest'+          _ -> b : rest+      | b == 0x4e              = case rest of+          (n0 : n1 : n2 : n3 : rest') ->+            let !len = fromIntegral n0+                     + fromIntegral n1 * 0x100+                     + fromIntegral n2 * 0x10000+                     + fromIntegral n3 * 0x1000000+            in  push len [b, n0, n1, n2, n3] rest'+          _ -> b : rest+      | otherwise              = b : go rest++    -- | Copy a push header and N data bytes verbatim. On truncation,+    --   @splitAt@ yields @(available, [])@ so @go []@ closes the+    --   recursion naturally; the malformed tail is preserved.+    push :: Int -> [Word8] -> [Word8] -> [Word8]+    push !len !header !rest =+      let (chunk, rest') = splitAt len rest+      in  header ++ chunk ++ go rest'+{-# INLINABLE strip_codeseparators #-}+ -- legacy sighash -------------------------------------------------------------  -- | Compute legacy sighash for P2PKH/P2SH inputs. -----   Modifies a copy of the transaction based on sighash flags, appends---   the sighash type as 4-byte little-endian, and double SHA256s.+--   Modifies a copy of the transaction based on hashType flags, appends+--   the 4-byte little-endian hashType, and double SHA256s. The+--   @hashType@ is committed to the preimage verbatim; only its low byte+--   determines behavior (see 'base_type', 'is_anyonecanpay'). -- --   @ --   -- sign input 0 with SIGHASH_ALL---   let hash = sighash_legacy tx 0 scriptPubKey SIGHASH_ALL---   -- use hash with ECDSA signing+--   let hash = sighash_legacy tx 0 scriptPubKey (encode_sighash SIGHASH_ALL)+--   -- non-canonical hashType (consensus-valid, committed raw)+--   let hash = sighash_legacy tx 0 scriptPubKey 0x6f29291f --   @ -----   For SIGHASH_SINGLE with input index >= output count, returns the---   special \"sighash single bug\" value (0x01 followed by 31 zero bytes).+--   For base SIGHASH_SINGLE with input index >= output count, returns+--   the special \"sighash single bug\" value (0x01 followed by 31 zero+--   bytes).+--+--   The input index is /not/ validated against the input count; an+--   out-of-range @idx@ produces a deterministic but+--   consensus-undefined hash. Matches Bitcoin Core, which @assert@s on+--   the same precondition. Contrast 'sighash_segwit', which validates+--   and returns 'Nothing'. sighash_legacy   :: Tx   -> Int              -- ^ input index   -> BS.ByteString    -- ^ scriptPubKey being spent-  -> SighashType+  -> Word32           -- ^ hashType   -> BS.ByteString    -- ^ 32-byte hash-sighash_legacy !tx !idx !script_pubkey !sighash_type+sighash_legacy !tx !idx !script_pubkey !ht   -- SIGHASH_SINGLE edge case: index >= number of outputs-  | base == SIGHASH_SINGLE && idx >= NE.length (tx_outputs tx) =+  | base == BaseSingle && idx >= NE.length (tx_outputs tx) =       sighash_single_bug   | otherwise =-      let !serialized = serialize_legacy_sighash tx idx script_pubkey sighash_type+      let !serialized = serialize_legacy_sighash tx idx script_pubkey ht       in  hash256 serialized   where-    !base = base_type sighash_type+    !base = base_type ht  -- | Serialize transaction for legacy sighash computation. --   Handles all sighash flags directly without constructing intermediate Tx.@@ -131,11 +219,12 @@   :: Tx   -> Int   -> BS.ByteString-  -> SighashType+  -> Word32   -> BS.ByteString-serialize_legacy_sighash Tx{..} !idx !script_pubkey !sighash_type =-  let !base = base_type sighash_type-      !anyonecanpay = is_anyonecanpay sighash_type+serialize_legacy_sighash Tx{..} !idx !script_pubkey !ht =+  let !script' = strip_codeseparators script_pubkey+      !base = base_type ht+      !anyonecanpay = is_anyonecanpay ht       !inputs_list = NE.toList tx_inputs       !outputs_list = NE.toList tx_outputs @@ -143,7 +232,7 @@       clear_scripts :: Int -> [TxIn] -> [TxIn]       clear_scripts !_ [] = []       clear_scripts !i (inp : rest)-        | i == idx  = inp { txin_script_sig = script_pubkey } : clear_rest+        | i == idx  = inp { txin_script_sig = script' } : clear_rest         | otherwise = inp { txin_script_sig = BS.empty } : clear_rest         where           !clear_rest = clear_scripts (i + 1) rest@@ -160,9 +249,9 @@       !inputs_cleared = clear_scripts 0 inputs_list        !inputs_processed = case base of-        SIGHASH_NONE   -> zero_other_sequences 0 inputs_cleared-        SIGHASH_SINGLE -> zero_other_sequences 0 inputs_cleared-        _              -> inputs_cleared+        BaseNone   -> zero_other_sequences 0 inputs_cleared+        BaseSingle -> zero_other_sequences 0 inputs_cleared+        _          -> inputs_cleared        -- ANYONECANPAY: keep only signing input       !final_inputs@@ -173,18 +262,18 @@        -- Process outputs based on sighash type       !final_outputs = case base of-        SIGHASH_NONE   -> []-        SIGHASH_SINGLE -> build_single_outputs outputs_list idx-        _              -> outputs_list+        BaseNone   -> []+        BaseSingle -> build_single_outputs outputs_list idx+        _          -> outputs_list    in  to_strict $          put_word32_le tx_version       <> put_compact (fromIntegral (length final_inputs))-      <> foldMap put_txin_legacy final_inputs+      <> foldMap put_txin final_inputs       <> put_compact (fromIntegral (length final_outputs))       <> foldMap put_txout final_outputs       <> put_word32_le tx_locktime-      <> put_word32_le (fromIntegral (sighash_byte sighash_type))+      <> put_word32_le ht  -- | Build outputs for SIGHASH_SINGLE: keep only output at idx, --   replace earlier outputs with empty/zero outputs.@@ -211,29 +300,22 @@   | otherwise = safe_index xs (n - 1) {-# INLINE safe_index #-} --- | Encode TxIn for legacy sighash (same as normal encoding).-put_txin_legacy :: TxIn -> BSB.Builder-put_txin_legacy TxIn{..} =-       put_outpoint txin_prevout-    <> put_compact (fromIntegral (BS.length txin_script_sig))-    <> BSB.byteString txin_script_sig-    <> put_word32_le txin_sequence-{-# INLINE put_txin_legacy #-}---- BIP143 segwit sighash -------------------------------------------------------+-- BIP143 segwit sighash ------------------------------------------------------  -- | Compute BIP143 segwit sighash. -- --   Required for signing segwit inputs (P2WPKH, P2WSH). Unlike legacy --   sighash, this commits to the value being spent, preventing fee---   manipulation attacks.+--   manipulation attacks. The @hashType@ is committed to the preimage+--   verbatim; only its low byte determines behavior. -- --   Returns 'Nothing' if the input index is out of range. -- --   @ --   -- sign P2WPKH input 0 --   let scriptCode = ...  -- P2WPKH scriptCode---   let hash = sighash_segwit tx 0 scriptCode inputValue SIGHASH_ALL+--   let hash = sighash_segwit tx 0 scriptCode inputValue+--                  (encode_sighash SIGHASH_ALL) --   -- use hash with ECDSA signing (after checking Just) --   @ sighash_segwit@@ -241,10 +323,10 @@   -> Int              -- ^ input index   -> BS.ByteString    -- ^ scriptCode   -> Word64           -- ^ value being spent (satoshis)-  -> SighashType+  -> Word32           -- ^ hashType   -> Maybe BS.ByteString    -- ^ 32-byte hash, or Nothing if index invalid-sighash_segwit !tx !idx !script_code !value !sighash_type = do-  preimage <- build_bip143_preimage tx idx script_code value sighash_type+sighash_segwit !tx !idx !script_code !value !ht = do+  preimage <- build_bip143_preimage tx idx script_code value ht   pure $! hash256 preimage  -- | Build BIP143 preimage for signing.@@ -254,16 +336,16 @@   -> Int   -> BS.ByteString   -> Word64-  -> SighashType+  -> Word32   -> Maybe BS.ByteString-build_bip143_preimage Tx{..} !idx !script_code !value !sighash_type = do+build_bip143_preimage Tx{..} !idx !script_code !value !ht = do   -- Get the input being signed; fail if index out of range   let !inputs_list = NE.toList tx_inputs       !outputs_list = NE.toList tx_outputs   signing_input <- safe_index inputs_list idx -  let !base = base_type sighash_type-      !anyonecanpay = is_anyonecanpay sighash_type+  let !base = base_type ht+      !anyonecanpay = is_anyonecanpay ht        -- hashPrevouts: double SHA256 of all outpoints, or zero if ANYONECANPAY       !hash_prevouts@@ -274,16 +356,16 @@       -- hashSequence: double SHA256 of all sequences, or zero if       -- ANYONECANPAY or NONE or SINGLE       !hash_sequence-        | anyonecanpay = zero32-        | base == SIGHASH_SINGLE = zero32-        | base == SIGHASH_NONE   = zero32+        | anyonecanpay        = zero32+        | base == BaseSingle  = zero32+        | base == BaseNone    = zero32         | otherwise = hash256 $ to_strict $             foldMap (put_word32_le . txin_sequence) tx_inputs        -- hashOutputs: depends on sighash type       !hash_outputs = case base of-        SIGHASH_NONE -> zero32-        SIGHASH_SINGLE ->+        BaseNone   -> zero32+        BaseSingle ->           case safe_index outputs_list idx of             Nothing  -> zero32  -- index out of range             Just out -> hash256 $ to_strict $ put_txout out@@ -303,4 +385,193 @@     <> put_word32_le sequence_n     <> BSB.byteString hash_outputs     <> put_word32_le tx_locktime-    <> put_word32_le (fromIntegral (sighash_byte sighash_type))+    <> put_word32_le ht++-- BIP341 taproot sighash ----------------------------------------------------++-- | Precomputed BIP340 tagged-hash key for @\"TapSighash\"@.+tap_sighash_tag :: BS.ByteString+tap_sighash_tag = SHA256.hash "TapSighash"+{-# NOINLINE tap_sighash_tag #-}++-- | BIP340 tagged hash with the @\"TapSighash\"@ tag:+--   @SHA256(tag_hash || tag_hash || msg)@.+tap_sighash :: BS.ByteString -> BS.ByteString+tap_sighash !msg =+  SHA256.hash (tap_sighash_tag <> tap_sighash_tag <> msg)+{-# INLINE tap_sighash #-}++-- | Single SHA256 of a Builder's output.+sha :: BSB.Builder -> BS.ByteString+sha = SHA256.hash . to_strict+{-# INLINE sha #-}++-- | Valid taproot hash types per BIP341: 0x00 (DEFAULT), 0x01..0x03,+--   0x81..0x83. Non-canonical values are signalled as invalid in+--   contrast with legacy\/segwit, which commit arbitrary 32-bit values.+is_valid_taproot_ht :: Word8 -> Bool+is_valid_taproot_ht !ht =+     ht == 0x00 || ht == 0x01 || ht == 0x02 || ht == 0x03+  || ht == 0x81 || ht == 0x82 || ht == 0x83+{-# INLINE is_valid_taproot_ht #-}++-- | Compute BIP341 taproot sighash for a /key-path/ spend.+--+--   The caller must supply, in input order, the amount and+--   scriptPubKey of every previous output being spent (the entire+--   set is committed to the preimage when not using+--   @SIGHASH_ANYONECANPAY@).+--+--   The annex, if present, must include the mandatory 0x50 prefix+--   byte (as it appears in the witness).+--+--   Returns 'Nothing' if any of the following holds:+--+--     * @hash_type@ is not a canonical taproot value+--     * the input index is out of range+--     * @amounts@ or @scriptPubKeys@ does not match the input count+--     * an annex is supplied without the 0x50 prefix or is empty+--     * @hash_type@ is @SIGHASH_SINGLE@ (or its ACP variant) and the+--       input index has no corresponding output (such a signature+--       would be consensus-invalid per BIP341)+--+--   @+--   sighash_taproot_keypath tx 0 amounts scriptPubKeys Nothing 0x00+--   @+sighash_taproot_keypath+  :: Tx+  -> Int                  -- ^ input index+  -> [Word64]             -- ^ amounts for all inputs (in order)+  -> [BS.ByteString]      -- ^ scriptPubKeys for all inputs (in order)+  -> Maybe BS.ByteString  -- ^ optional annex (including 0x50 prefix)+  -> Word8                -- ^ hash type+  -> Maybe BS.ByteString  -- ^ 32-byte hash, or Nothing on invalid input+sighash_taproot_keypath !tx !idx !amts !spks !annex !ht =+  taproot_sighash tx idx amts spks annex Nothing ht++-- | Compute BIP341 taproot sighash for a /script-path/ (tapscript)+--   spend.+--+--   In addition to the key-path inputs, takes:+--+--     * the 32-byte tap leaf hash (BIP342: tagged hash of @leaf_ver ||+--       ser_string(script)@), computed by the caller+--     * the codeseparator position (0xffffffff if none was executed)+--+--   Returns 'Nothing' under the same conditions as+--   'sighash_taproot_keypath', plus when @tap_leaf_hash@ is not+--   exactly 32 bytes.+sighash_taproot_scriptpath+  :: Tx+  -> Int                  -- ^ input index+  -> [Word64]             -- ^ amounts for all inputs (in order)+  -> [BS.ByteString]      -- ^ scriptPubKeys for all inputs (in order)+  -> Maybe BS.ByteString  -- ^ optional annex (including 0x50 prefix)+  -> BS.ByteString        -- ^ tap leaf hash (32 bytes)+  -> Word32               -- ^ codeseparator position+  -> Word8                -- ^ hash type+  -> Maybe BS.ByteString+sighash_taproot_scriptpath !tx !idx !amts !spks !annex !leaf !csep !ht =+  taproot_sighash tx idx amts spks annex (Just (leaf, csep)) ht++-- | Internal worker shared by 'sighash_taproot_keypath' and+--   'sighash_taproot_scriptpath'. @Nothing@ for the extension argument+--   selects the key-path; @Just (leaf_hash, codesep_pos)@ selects the+--   script-path.+taproot_sighash+  :: Tx+  -> Int+  -> [Word64]+  -> [BS.ByteString]+  -> Maybe BS.ByteString+  -> Maybe (BS.ByteString, Word32)+  -> Word8+  -> Maybe BS.ByteString+taproot_sighash Tx{..} !idx !amts !spks !annex !sp_ext !ht = do+  guard (is_valid_taproot_ht ht)+  case annex of+    Just a  -> guard (not (BS.null a) && BS.index a 0 == 0x50)+    Nothing -> pure ()+  case sp_ext of+    Just (lh, _) -> guard (BS.length lh == 32)+    Nothing      -> pure ()++  let !inputs_list  = NE.toList tx_inputs+      !outputs_list = NE.toList tx_outputs+      !n_inputs     = length inputs_list+      !n_outputs    = length outputs_list++  guard (idx >= 0 && idx < n_inputs)+  guard (length amts == n_inputs)+  guard (length spks == n_inputs)+  -- BIP341: SIGHASH_SINGLE without a corresponding output is invalid;+  -- reject rather than return a digest no consensus-valid signature+  -- could match.+  guard (ht .&. 0x03 /= 0x03 || idx < n_outputs)++  signing_input  <- safe_index inputs_list idx+  signing_amount <- safe_index amts         idx+  signing_spk    <- safe_index spks         idx++  let -- BIP341 maps DEFAULT (0x00) to ALL for output handling.+      out_type | ht == 0x00 = 0x01 :: Word8+               | otherwise  = ht .&. 0x03+      acp           = (ht .&. 0x80) /= 0+      annex_present = case annex  of Just _ -> True; Nothing -> False+      ext_flag      = case sp_ext of Just _ -> 1;    Nothing -> 0 :: Word8+      spend_type    = ext_flag * 2 + (if annex_present then 1 else 0)++      -- Lazily bound: ACP omits these four; NONE/SINGLE omit sha_outputs.+      sha_prevouts =+        sha (foldMap (put_outpoint . txin_prevout) inputs_list)+      sha_amounts       = sha (foldMap put_word64_le amts)+      sha_scriptpubkeys = sha (foldMap put_bytes spks)+      sha_sequences     =+        sha (foldMap (put_word32_le . txin_sequence) inputs_list)+      sha_outputs_all   = sha (foldMap put_txout outputs_list)++      sha_annex_bs = case annex of+        Just a  -> sha (put_bytes a)+        Nothing -> BS.empty++      -- safe_index always succeeds for SINGLE post-guard above; the+      -- fallback is defensive and unreachable in practice.+      sha_single_output_bs = case safe_index outputs_list idx of+        Just o  -> sha (put_txout o)+        Nothing -> BS.empty++      msg = to_strict $+           BSB.word8 0x00              -- epoch+        <> BSB.word8 ht                -- hash_type+        <> put_word32_le tx_version+        <> put_word32_le tx_locktime+        <> (if acp+              then mempty+              else BSB.byteString sha_prevouts+                <> BSB.byteString sha_amounts+                <> BSB.byteString sha_scriptpubkeys+                <> BSB.byteString sha_sequences)+        <> (if out_type == 0x01+              then BSB.byteString sha_outputs_all+              else mempty)+        <> BSB.word8 spend_type+        <> (if acp+              then put_outpoint   (txin_prevout signing_input)+                <> put_word64_le  signing_amount+                <> put_bytes      signing_spk+                <> put_word32_le  (txin_sequence signing_input)+              else put_word32_le (fromIntegral idx))+        <> (if annex_present+              then BSB.byteString sha_annex_bs+              else mempty)+        <> (if out_type == 0x03+              then BSB.byteString sha_single_output_bs+              else mempty)+        <> (case sp_ext of+              Just (leaf, csep) ->+                   BSB.byteString leaf+                <> BSB.word8 0x00       -- key_version+                <> put_word32_le csep+              Nothing -> mempty)++  pure $! tap_sighash msg

@@ -1,19 +1,19 @@ cabal-version:      3.0 name:               ppad-tx-version:            0.1.0-synopsis:           Minimal Bitcoin transaction primitives.+version:            0.2.0+synopsis:           Minimal Bitcoin transaction primitives license:            MIT license-file:       LICENSE author:             Jared Tobin maintainer:         jared@ppad.tech category:           Cryptography build-type:         Simple-tested-with:        GHC == 9.10.3+tested-with:        GHC == { 9.10.3 } extra-doc-files:    CHANGELOG description:-  Minimal Bitcoin transaction primitives for ppad libraries, including-  raw transaction types, serialisation, txid computation, and sighash-  calculation.+  Minimal Bitcoin transaction primitives: raw transaction types,+  serialisation, txid computation, and legacy, BIP143 segwit and BIP341+  taproot sighash calculation.  flag llvm   description: Use GHC's LLVM backend.@@ -34,10 +34,13 @@   exposed-modules:       Bitcoin.Prim.Tx       Bitcoin.Prim.Tx.Sighash+  other-modules:+      Bitcoin.Prim.Tx.Internal   build-depends:       base >= 4.9 && < 5     , bytestring >= 0.9 && < 0.13-    , ppad-base16 >= 0.2.1 && < 0.3+    , deepseq >= 1.4 && < 1.6+    , ppad-base16 >= 0.3 && < 0.4     , ppad-sha256 >= 0.3 && < 0.4  test-suite tx-tests@@ -47,7 +50,7 @@   main-is:             Main.hs    ghc-options:-    -rtsopts -Wall+    -rtsopts -Wall -fno-warn-orphans    build-depends:       base@@ -72,7 +75,6 @@       base     , bytestring     , criterion-    , deepseq     , ppad-tx  benchmark tx-weigh@@ -87,6 +89,5 @@   build-depends:       base     , bytestring-    , deepseq     , ppad-tx     , weigh

@@ -6,16 +6,15 @@ import Bitcoin.Prim.Tx.Sighash import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16+import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE-import Data.Word (Word64)+import Data.Word (Word8, Word32, Word64) import Test.Tasty import qualified Test.Tasty.HUnit as H import Test.Tasty.QuickCheck as QC hiding (Witness)-import Test.QuickCheck-  ( Gen, Arbitrary(..), elements, oneof, chooseInt, forAll, (==>) ) --- main ------------------------------------------------------------------------+-- main -----------------------------------------------------------------------  main :: IO () main = defaultMain $@@ -30,9 +29,15 @@               parse_satoshi_hal             , parse_first_segwit             ]+        , testGroup "compactSize" [+              test_compact_non_minimal_fd+            , test_compact_non_minimal_fe+            , test_compact_non_minimal_ff+            ]         ]     , testGroup "txid" [           txid_satoshi_hal+        , txid_first_segwit         ]     , testGroup "edge cases" [           edge_empty_scriptsig@@ -41,24 +46,78 @@         , edge_multi_witness         ]     , testGroup "validation" [-          test_mkTxId_valid-        , test_mkTxId_short-        , test_mkTxId_long-        , test_mkTxId_empty+          test_mk_txid_valid+        , test_mk_txid_short+        , test_mk_txid_long+        , test_mk_txid_empty         , test_from_bytes_truncated         , test_from_bytes_trailing         , test_from_bytes_garbage         , test_from_base16_invalid_hex         , test_sighash_segwit_oob+        , test_from_bytes_huge_length+        , test_from_bytes_huge_count+        , test_from_bytes_superfluous_witness+        , test_to_bytes_empty_witnesses+        , test_fixtures_parse         ]     , testGroup "sighash" [           testGroup "legacy" [               sighash_legacy_minimal+            , testGroup "codeseparators" [+                  codesep_no_op+                , codesep_strip_simple+                , codesep_inside_push+                , codesep_inside_pushdata1+                , codesep_inside_pushdata2+                , codesep_inside_pushdata4+                , codesep_malformed_tail+                ]+            , testGroup "Bitcoin Core sighash.json" [+                  bc_sighash_1+                , bc_sighash_2+                , bc_sighash_4+                , bc_sighash_9+                , bc_sighash_14+                , bc_sighash_20+                ]             ]         , testGroup "BIP143 segwit" [               bip143_native_p2wpkh             , bip143_p2sh_p2wpkh+            , testGroup "P2SH-P2WSH multi-sighash" [+                  bip143_p2sh_p2wsh_all+                , bip143_p2sh_p2wsh_none+                , bip143_p2sh_p2wsh_single+                , bip143_p2sh_p2wsh_all_acp+                , bip143_p2sh_p2wsh_none_acp+                , bip143_p2sh_p2wsh_single_acp+                ]             ]+        , testGroup "BIP341 taproot" [+              testGroup "key-path (wallet-test-vectors.json)" [+                  bip341_kp_in0_single+                , bip341_kp_in1_single_acp+                , bip341_kp_in3_all+                , bip341_kp_in4_default+                , bip341_kp_in6_none+                , bip341_kp_in7_none_acp+                , bip341_kp_in8_all_acp+                ]+            , testGroup "script-path (rust-bitcoin)" [+                  rb_script_path_all+                ]+            , testGroup "validation" [+                  taproot_invalid_ht+                , taproot_invalid_idx+                , taproot_amounts_mismatch+                , taproot_spks_mismatch+                , taproot_bad_annex_prefix+                , taproot_empty_annex+                , taproot_short_leaf_hash+                , taproot_single_oob+                ]+            ]         ]     , testGroup "properties" [           testGroup "round-trip" [@@ -77,17 +136,30 @@               prop_sighash_legacy_32_bytes             , prop_sighash_segwit_32_bytes             , prop_sighash_single_bug+            , prop_sighash_segwit_oob+            , prop_sighash_legacy_acp_invariant+            , prop_sighash_legacy_none_invariant+            , prop_sighash_legacy_none_acp_invariant+            , prop_strip_codesep_idempotent+            , prop_strip_codesep_no_0xab_unchanged+            , prop_taproot_keypath_neq_scriptpath+            , prop_taproot_csep_changes_hash+            , prop_taproot_annex_commits+            , prop_taproot_acp_ignores_other_inputs+            , prop_taproot_none_ignores_outputs             ]         ]     ] --- helpers ---------------------------------------------------------------------+-- helpers -------------------------------------------------------------------- --- | Decode hex, failing the test on invalid input.+-- | Decode a hex literal. Total: an invalid literal decodes to empty+--   bytes, which no vector expects, and the "fixtures parse" test+--   checks the transaction fixtures explicitly. hex :: BS.ByteString -> BS.ByteString hex h = case B16.decode h of   Just bs -> bs-  Nothing -> error "test error: invalid hex literal"+  Nothing -> BS.empty  -- | Assert round-trip: from_bytes (to_bytes tx) == Just tx assertRoundtrip :: Tx -> H.Assertion@@ -104,7 +176,7 @@     Nothing -> H.assertFailure "from_base16 returned Nothing"     Just _  -> pure () --- round-trip tests ------------------------------------------------------------+-- round-trip tests -----------------------------------------------------------  -- Simple legacy tx: 1 input, 1 output, no witnesses roundtrip_legacy_simple :: TestTree@@ -115,16 +187,16 @@       { tx_version   = 1       , tx_inputs    = txin :| []       , tx_outputs   = txout :| []-      , tx_witnesses = []       , tx_locktime  = 0       }     txin = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0xab)+          { op_txid = tid 0xab           , op_vout = 0           }       , txin_script_sig = hex "483045022100abcd"       , txin_sequence   = 0xffffffff+      , txin_witness    = Witness []       }     txout = TxOut       { txout_value = 50000@@ -140,24 +212,25 @@       { tx_version   = 2       , tx_inputs    = txin :| []       , tx_outputs   = txout :| []-      , tx_witnesses = [witness]       , tx_locktime  = 500000       }     txin = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x12)+          { op_txid = tid 0x12           , op_vout = 1           }       , txin_script_sig = BS.empty  -- segwit: empty scriptSig       , txin_sequence   = 0xfffffffe+      , txin_witness    = wit       }     txout = TxOut       { txout_value = 100000000       , txout_script_pubkey = hex "0014abcdef1234567890"       }-    witness = Witness+    wit = Witness       [ hex "304402201234"-      , hex "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"+      , hex ("0279be667ef9dcbbac55a06295ce870b"+          <> "07029bfcdb2dce28d959f2815b16f81798")       ]  -- Multiple inputs and outputs@@ -169,32 +242,34 @@       { tx_version   = 1       , tx_inputs    = txin1 :| [txin2, txin3]       , tx_outputs   = txout1 :| [txout2]-      , tx_witnesses = []       , tx_locktime  = 123456       }     txin1 = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x11)+          { op_txid = tid 0x11           , op_vout = 0           }       , txin_script_sig = hex "4730440220"       , txin_sequence   = 0xffffffff+      , txin_witness    = Witness []       }     txin2 = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x22)+          { op_txid = tid 0x22           , op_vout = 2           }       , txin_script_sig = hex "483045022100"       , txin_sequence   = 0xffffffff+      , txin_witness    = Witness []       }     txin3 = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x33)+          { op_txid = tid 0x33           , op_vout = 5           }       , txin_script_sig = hex "00"       , txin_sequence   = 0xfffffffe+      , txin_witness    = Witness []       }     txout1 = TxOut       { txout_value = 10000000@@ -205,7 +280,7 @@       , txout_script_pubkey = hex "a914"       } --- known vector tests ----------------------------------------------------------+-- known vector tests ---------------------------------------------------------  -- First Bitcoin transaction ever (block 170, Satoshi to Hal Finney) -- TxId: f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16@@ -221,7 +296,8 @@   \2e160bfa9b8b64f9d4c03f999b8643f656b412a3ac00000000"  satoshiHalTxId :: BS.ByteString-satoshiHalTxId = "f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16"+satoshiHalTxId =+  "f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16"  parse_satoshi_hal :: TestTree parse_satoshi_hal = H.testCase "parse Satoshi->Hal tx (block 170)" $@@ -232,7 +308,7 @@   case from_base16 satoshiHalRaw of     Nothing -> H.assertFailure "failed to parse tx"     Just tx -> do-      let TxId computed = txid tx+      let computed = un_txid (txid tx)           -- txid is displayed big-endian, but stored little-endian           expected = BS.reverse (hex satoshiHalTxId)       H.assertEqual "txid mismatch" expected computed@@ -251,7 +327,7 @@ parse_first_segwit = H.testCase "parse first segwit tx (block 481824)" $   assertParses firstSegwitRaw --- edge case tests -------------------------------------------------------------+-- edge case tests ------------------------------------------------------------  -- Empty scriptSig (common in segwit) edge_empty_scriptsig :: TestTree@@ -262,22 +338,22 @@       { tx_version   = 2       , tx_inputs    = txin :| []       , tx_outputs   = txout :| []-      , tx_witnesses = [witness]       , tx_locktime  = 0       }     txin = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0xff)+          { op_txid = tid 0xff           , op_vout = 0           }       , txin_script_sig = BS.empty       , txin_sequence   = 0xffffffff+      , txin_witness    = wit       }     txout = TxOut       { txout_value = 1000       , txout_script_pubkey = hex "0014abcdef"       }-    witness = Witness [hex "3044", hex "02"]+    wit = Witness [hex "3044", hex "02"]  -- Maximum sequence number (0xffffffff) edge_max_sequence :: TestTree@@ -288,16 +364,16 @@       { tx_version   = 1       , tx_inputs    = txin :| []       , tx_outputs   = txout :| []-      , tx_witnesses = []       , tx_locktime  = 0       }     txin = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x00)+          { op_txid = tid 0x00           , op_vout = 0xffffffff  -- max vout too           }       , txin_script_sig = hex "00"       , txin_sequence   = 0xffffffff+      , txin_witness    = Witness []       }     txout = TxOut       { txout_value = 0@@ -313,16 +389,16 @@       { tx_version   = 1       , tx_inputs    = txin :| []       , tx_outputs   = txout :| []-      , tx_witnesses = []       , tx_locktime  = 0       }     txin = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0xaa)+          { op_txid = tid 0xaa           , op_vout = 0           }       , txin_script_sig = hex "51"  -- OP_1       , txin_sequence   = 0+      , txin_witness    = Witness []       }     txout = TxOut       { txout_value = 100@@ -338,24 +414,25 @@       { tx_version   = 2       , tx_inputs    = txin1 :| [txin2]       , tx_outputs   = txout :| []-      , tx_witnesses = [witness1, witness2]       , tx_locktime  = 0       }     txin1 = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x01)+          { op_txid = tid 0x01           , op_vout = 0           }       , txin_script_sig = BS.empty       , txin_sequence   = 0xffffffff+      , txin_witness    = witness1       }     txin2 = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x02)+          { op_txid = tid 0x02           , op_vout = 1           }       , txin_script_sig = BS.empty       , txin_sequence   = 0xffffffff+      , txin_witness    = witness2       }     txout = TxOut       { txout_value = 50000@@ -377,30 +454,30 @@  -- validation tests ----------------------------------------------------------- --- mkTxId: valid 32-byte input accepted-test_mkTxId_valid :: TestTree-test_mkTxId_valid = H.testCase "mkTxId accepts 32 bytes" $-  case mkTxId (BS.replicate 32 0x00) of-    Nothing -> H.assertFailure "mkTxId returned Nothing"+-- mk_txid: valid 32-byte input accepted+test_mk_txid_valid :: TestTree+test_mk_txid_valid = H.testCase "mk_txid accepts 32 bytes" $+  case mk_txid (BS.replicate 32 0x00) of+    Nothing -> H.assertFailure "mk_txid returned Nothing"     Just _  -> pure () --- mkTxId: 31 bytes rejected-test_mkTxId_short :: TestTree-test_mkTxId_short = H.testCase "mkTxId rejects 31 bytes" $+-- mk_txid: 31 bytes rejected+test_mk_txid_short :: TestTree+test_mk_txid_short = H.testCase "mk_txid rejects 31 bytes" $   H.assertEqual "should be Nothing"-    Nothing (mkTxId (BS.replicate 31 0x00))+    Nothing (mk_txid (BS.replicate 31 0x00)) --- mkTxId: 33 bytes rejected-test_mkTxId_long :: TestTree-test_mkTxId_long = H.testCase "mkTxId rejects 33 bytes" $+-- mk_txid: 33 bytes rejected+test_mk_txid_long :: TestTree+test_mk_txid_long = H.testCase "mk_txid rejects 33 bytes" $   H.assertEqual "should be Nothing"-    Nothing (mkTxId (BS.replicate 33 0x00))+    Nothing (mk_txid (BS.replicate 33 0x00)) --- mkTxId: empty input rejected-test_mkTxId_empty :: TestTree-test_mkTxId_empty = H.testCase "mkTxId rejects empty" $+-- mk_txid: empty input rejected+test_mk_txid_empty :: TestTree+test_mk_txid_empty = H.testCase "mk_txid rejects empty" $   H.assertEqual "should be Nothing"-    Nothing (mkTxId BS.empty)+    Nothing (mk_txid BS.empty)  -- from_bytes: truncated input rejected test_from_bytes_truncated :: TestTree@@ -427,6 +504,62 @@     H.assertEqual "should be Nothing"       Nothing (from_bytes (BS.pack [0xde, 0xad])) +-- from_bytes: a compactSize length >= 2^63 is rejected (it used to wrap+-- to a negative Int and crash with a negative index)+test_from_bytes_huge_length :: TestTree+test_from_bytes_huge_length =+  H.testCase "from_bytes rejects huge lengths without crashing" $ do+    let prefix = hex "0100000001" <> BS.replicate 36 0x00+        script_len = hex "ff0000000000000080"+    H.assertEqual "scriptSig" Nothing+      (from_bytes (prefix <> script_len <> hex "ffffffff"))+    H.assertEqual "maximal" Nothing+      (from_bytes (prefix <> hex "ffffffffffffffffff" <> hex "ffffffff"))++-- from_bytes: a count exceeding the remaining input is rejected (a huge+-- witness item count used to wrap negative and parse as zero items)+test_from_bytes_huge_count :: TestTree+test_from_bytes_huge_count =+  H.testCase "from_bytes rejects counts exceeding the input" $ do+    let tx = mconcat+          [ hex "0100000000010100", BS.replicate 35 0x00, hex "00ffffffff"+          , hex "01", BS.replicate 8 0x00, hex "00"+          , hex "ff0000000000000080"  -- witness item count 2^63+          , hex "00000000"+          ]+    H.assertEqual "witness item count" Nothing (from_bytes tx)+    H.assertEqual "input count" Nothing+      (from_bytes (hex "01000000ffffffffffffffffff00000000"))++-- from_bytes: a segwit marker and flag with only empty witnesses is+-- invalid (Bitcoin Core: "superfluous witness record")+test_from_bytes_superfluous_witness :: TestTree+test_from_bytes_superfluous_witness =+  H.testCase "from_bytes rejects a segwit tx with no witness data" $ do+    let tx = mconcat+          [ hex "0100000000010100", BS.replicate 35 0x00, hex "00ffffffff"+          , hex "01", BS.replicate 8 0x00, hex "00"+          , hex "00"                  -- empty witness stack+          , hex "00000000"+          ]+    H.assertEqual "should be Nothing" Nothing (from_bytes tx)++-- to_bytes: all-empty witnesses serialise in the legacy format+test_to_bytes_empty_witnesses :: TestTree+test_to_bytes_empty_witnesses =+  H.testCase "to_bytes uses the legacy format for empty witnesses" $ do+    let tx = strip_witnesses legacyTx1+    H.assertEqual "legacy" (to_bytes_legacy tx) (to_bytes tx)++-- every transaction fixture literal parses+test_fixtures_parse :: TestTree+test_fixtures_parse =+  H.testCase "fixtures parse" $ do+    H.assertBool "BIP143 P2SH-P2WSH" (is_just (from_base16 p2shP2wshTxHex))+    H.assertBool "BIP341" (is_just (from_base16 bip341TxHex))+  where+    is_just = maybe False (const True)+ -- from_base16: invalid hex rejected test_from_base16_invalid_hex :: TestTree test_from_base16_invalid_hex =@@ -452,7 +585,7 @@       Just tx ->         H.assertEqual "should be Nothing"           Nothing-          (sighash_segwit tx 99 "script" 0 SIGHASH_ALL)+          (sighash_segwit tx 99 "script" 0 (encode_sighash SIGHASH_ALL))  -- | A minimal legacy tx used by validation tests. legacyTx1 :: Tx@@ -460,17 +593,17 @@   { tx_version   = 1   , tx_inputs    = txin :| []   , tx_outputs   = txout :| []-  , tx_witnesses = []   , tx_locktime  = 0   }   where     txin = TxIn       { txin_prevout = OutPoint-          { op_txid = TxId (BS.replicate 32 0x00)+          { op_txid = tid 0x00           , op_vout = 0           }       , txin_script_sig = hex "00"       , txin_sequence   = 0xffffffff+      , txin_witness    = Witness []       }     txout = TxOut       { txout_value = 0@@ -488,16 +621,16 @@           { tx_version   = 1           , tx_inputs    = txin :| []           , tx_outputs   = txout :| []-          , tx_witnesses = []           , tx_locktime  = 0           }         txin = TxIn           { txin_prevout = OutPoint-              { op_txid = TxId (BS.replicate 32 0x00)+              { op_txid = tid 0x00               , op_vout = 0               }           , txin_script_sig = hex "00"           , txin_sequence   = 0xffffffff+          , txin_witness    = Witness []           }         txout = TxOut           { txout_value = 0@@ -507,7 +640,8 @@         expected = hex           "049b7618cbda49a0190c5eea6f97320b\           \930aa32b64be6e71ed20041067685c45"-        result = sighash_legacy tx 0 script_pubkey SIGHASH_ALL+        result = sighash_legacy tx 0 script_pubkey+                   (encode_sighash SIGHASH_ALL)     H.assertEqual "sighash mismatch" expected result  -- BIP143 sighash vectors -----------------------------------------------------@@ -534,7 +668,8 @@           value = 600000000 :: Word64           expected = hex             "c37af31116d1b27caf68aae9e3ac82f1477929014d5b917657d0eb49478cb670"-      case sighash_segwit tx inputIdx scriptCode value SIGHASH_ALL of+      case sighash_segwit tx inputIdx scriptCode value+             (encode_sighash SIGHASH_ALL) of         Nothing -> H.assertFailure "sighash_segwit returned Nothing"         Just result -> H.assertEqual "sighash mismatch" expected result @@ -557,14 +692,15 @@           value = 1000000000 :: Word64           expected = hex             "64f3b0f4dd2bb3aa1ce8566d220cc74dda9df97d8490cc81d89d735c92e59fb6"-      case sighash_segwit tx inputIdx scriptCode value SIGHASH_ALL of+      case sighash_segwit tx inputIdx scriptCode value+             (encode_sighash SIGHASH_ALL) of         Nothing -> H.assertFailure "sighash_segwit returned Nothing"         Just result -> H.assertEqual "sighash mismatch" expected result  -- Arbitrary instances --------------------------------------------------------  instance Arbitrary TxId where-  arbitrary = TxId . BS.pack <$> vectorOf 32 arbitrary+  arbitrary = maybe null_txid id . mk_txid . BS.pack <$> vectorOf 32 arbitrary  instance Arbitrary OutPoint where   arbitrary = OutPoint <$> arbitrary <*> arbitrary@@ -574,6 +710,7 @@     <$> arbitrary     <*> arbitraryScript     <*> arbitrary+    <*> pure (Witness [])  instance Arbitrary TxOut where   arbitrary = TxOut@@ -617,7 +754,7 @@   ins <- arbitraryNonEmpty   outs <- arbitraryNonEmpty   lt <- arbitrary-  pure $ Tx ver ins outs [] lt+  pure $ Tx ver ins outs lt  -- | Generate a valid segwit transaction (with witnesses). genSegwitTx :: Gen Tx@@ -625,11 +762,16 @@   ver <- arbitrary   ins <- arbitraryNonEmpty   outs <- arbitraryNonEmpty-  -- One witness per input+  -- One witness per input, at least one of them non-empty (a segwit+  -- serialisation requires witness data)   let numInputs = NE.length ins-  wits <- vectorOf numInputs arbitrary+  w0 <- Witness <$> listOf1 arbitraryScript+  ws <- vectorOf (numInputs - 1) arbitrary   lt <- arbitrary-  pure $ Tx ver ins outs wits lt+  let set i w = i { txin_witness = w }+      ins' = case ins of+        i :| is -> set i w0 :| zipWith set is ws+  pure $ Tx ver ins' outs lt  -- | Generate any valid transaction. instance Arbitrary Tx where@@ -659,20 +801,19 @@ prop_segwit_longer =   QC.testProperty "segwit tx: to_bytes longer than to_bytes_legacy" $     forAll genSegwitTx $ \tx ->-      not (null (tx_witnesses tx)) ==>-        BS.length (to_bytes tx) > BS.length (to_bytes_legacy tx)+      BS.length (to_bytes tx) > BS.length (to_bytes_legacy tx)  -- TxId is always 32 bytes prop_txid_32_bytes :: TestTree prop_txid_32_bytes = QC.testProperty "txid is always 32 bytes" $-  \tx -> let TxId bs = txid tx in BS.length bs === 32+  \tx -> BS.length (un_txid (txid tx)) === 32  -- TxId ignores witnesses (same txid with or without witnesses) prop_txid_ignores_witnesses :: TestTree prop_txid_ignores_witnesses =   QC.testProperty "txid ignores witnesses" $     forAll genSegwitTx $ \tx ->-      let txNoWit = tx { tx_witnesses = [] }+      let txNoWit = strip_witnesses tx       in  txid tx === txid txNoWit  -- sighash_legacy always returns 32 bytes@@ -682,19 +823,21 @@     forAll genLegacyTx $ \tx ->       forAll arbitraryScript $ \spk ->         forAll arbitrary $ \st ->-          BS.length (sighash_legacy tx 0 spk st) === 32+          BS.length (sighash_legacy tx 0 spk (encode_sighash st)) === 32 --- sighash_segwit returns Just 32 bytes for valid index+-- sighash_segwit returns Just 32 bytes for any valid index prop_sighash_segwit_32_bytes :: TestTree prop_sighash_segwit_32_bytes =   QC.testProperty "sighash_segwit is 32 bytes for valid index" $     forAll genSegwitTx $ \tx ->-      forAll arbitraryScript $ \sc ->-        forAll (arbitrary :: Gen Word64) $ \val ->-          forAll arbitrary $ \st ->-            case sighash_segwit tx 0 sc val st of-              Nothing -> False  -- should succeed for index 0-              Just bs -> BS.length bs == 32+      let nIns = NE.length (tx_inputs tx)+      in  forAll (chooseInt (0, nIns - 1)) $ \idx ->+            forAll arbitraryScript $ \sc ->+              forAll (arbitrary :: Gen Word64) $ \val ->+                forAll arbitrary $ \st ->+                  case sighash_segwit tx idx sc val (encode_sighash st) of+                    Nothing -> False  -- should succeed for valid index+                    Just bs -> BS.length bs == 32  -- SIGHASH_SINGLE bug: returns 0x01 ++ 0x00*31 when index >= outputs prop_sighash_single_bug :: TestTree@@ -704,4 +847,676 @@       let numOutputs = NE.length (tx_outputs tx)           bugValue = BS.cons 0x01 (BS.replicate 31 0x00)       in  forAll arbitraryScript $ \spk ->-            sighash_legacy tx numOutputs spk SIGHASH_SINGLE === bugValue+            sighash_legacy tx numOutputs spk+              (encode_sighash SIGHASH_SINGLE) === bugValue++-- sighash_segwit: out-of-range index always returns Nothing+prop_sighash_segwit_oob :: TestTree+prop_sighash_segwit_oob =+  QC.testProperty "sighash_segwit returns Nothing for oob index" $+    forAll genSegwitTx $ \tx ->+      let nIns = NE.length (tx_inputs tx)+      in  forAll (chooseInt (nIns, nIns + 10)) $ \idx ->+            forAll arbitraryScript $ \sc ->+              forAll (arbitrary :: Gen Word64) $ \val ->+                forAll arbitrary $ \st ->+                  sighash_segwit tx idx sc val (encode_sighash st)+                    === Nothing++-- ANYONECANPAY commits to only the signing input. Appending extra+-- inputs to the tx (without displacing index 0) must not change the+-- hash.+prop_sighash_legacy_acp_invariant :: TestTree+prop_sighash_legacy_acp_invariant =+  QC.testProperty "SIGHASH_ALL|ANYONECANPAY ignores appended inputs" $+    forAll genLegacyTx $ \tx ->+      forAll (QC.listOf1 (arbitrary :: Gen TxIn)) $ \extras ->+        forAll arbitraryScript $ \spk ->+          let tx' = tx { tx_inputs = appendInputs (tx_inputs tx) extras }+              ht  = encode_sighash SIGHASH_ALL_ANYONECANPAY+              h1  = sighash_legacy tx  0 spk ht+              h2  = sighash_legacy tx' 0 spk ht+          in  h1 === h2++-- SIGHASH_NONE strips outputs from the preimage. Appending extra+-- outputs must not change the hash.+prop_sighash_legacy_none_invariant :: TestTree+prop_sighash_legacy_none_invariant =+  QC.testProperty "SIGHASH_NONE ignores appended outputs" $+    forAll genLegacyTx $ \tx ->+      forAll (QC.listOf1 (arbitrary :: Gen TxOut)) $ \extras ->+        forAll arbitraryScript $ \spk ->+          let tx' = tx { tx_outputs = appendOutputs (tx_outputs tx) extras }+              ht  = encode_sighash SIGHASH_NONE+              h1  = sighash_legacy tx  0 spk ht+              h2  = sighash_legacy tx' 0 spk ht+          in  h1 === h2++-- SIGHASH_NONE|ANYONECANPAY ignores both other inputs and all outputs.+prop_sighash_legacy_none_acp_invariant :: TestTree+prop_sighash_legacy_none_acp_invariant =+  QC.testProperty+    "SIGHASH_NONE|ANYONECANPAY ignores appended inputs and outputs" $+    forAll genLegacyTx $ \tx ->+      forAll (QC.listOf1 (arbitrary :: Gen TxIn)) $ \extraIns ->+        forAll (QC.listOf1 (arbitrary :: Gen TxOut)) $ \extraOuts ->+          forAll arbitraryScript $ \spk ->+            let tx' = tx+                  { tx_inputs  = appendInputs  (tx_inputs tx)  extraIns+                  , tx_outputs = appendOutputs (tx_outputs tx) extraOuts+                  }+                ht = encode_sighash SIGHASH_NONE_ANYONECANPAY+                h1 = sighash_legacy tx  0 spk ht+                h2 = sighash_legacy tx' 0 spk ht+            in  h1 === h2++-- | Append items to a NonEmpty list.+appendInputs :: NonEmpty TxIn -> [TxIn] -> NonEmpty TxIn+appendInputs (x :| xs) extras = x :| (xs ++ extras)++appendOutputs :: NonEmpty TxOut -> [TxOut] -> NonEmpty TxOut+appendOutputs (x :| xs) extras = x :| (xs ++ extras)++-- compactSize non-minimal rejection -----------------------------------------++-- Build a legacy tx whose input scriptSig length is encoded with a+-- non-minimal compactSize tag. We construct the bytes directly.+--+-- Layout (legacy):+--   version(4) | n_inputs(compact) | outpoint(36) | scriptSig_len(compact)+--   | scriptSig | sequence(4) | n_outputs(compact) | outputs... | locktime(4)+--+-- We use a 0-byte scriptSig but encode its length with a non-minimal tag.+nonMinimalLegacyTx :: BS.ByteString -> BS.ByteString+nonMinimalLegacyTx badLen = BS.concat+  [ BS.pack [0x01, 0x00, 0x00, 0x00]      -- version 1+  , BS.pack [0x01]                        -- 1 input+  , BS.replicate 32 0x00                  -- outpoint txid+  , BS.pack [0x00, 0x00, 0x00, 0x00]      -- outpoint vout+  , badLen                                -- non-minimal compactSize+  , BS.pack [0xff, 0xff, 0xff, 0xff]      -- sequence+  , BS.pack [0x01]                        -- 1 output+  , BS.replicate 8 0x00                   -- value+  , BS.pack [0x00]                        -- empty scriptPubKey+  , BS.pack [0x00, 0x00, 0x00, 0x00]      -- locktime+  ]++test_compact_non_minimal_fd :: TestTree+test_compact_non_minimal_fd =+  H.testCase "rejects 0xfd encoding of value < 0xfd" $+    H.assertEqual "should be Nothing"+      Nothing+      (from_bytes (nonMinimalLegacyTx (BS.pack [0xfd, 0x00, 0x00])))++test_compact_non_minimal_fe :: TestTree+test_compact_non_minimal_fe =+  H.testCase "rejects 0xfe encoding of value <= 0xffff" $+    H.assertEqual "should be Nothing"+      Nothing+      (from_bytes+         (nonMinimalLegacyTx (BS.pack [0xfe, 0x00, 0x00, 0x00, 0x00])))++test_compact_non_minimal_ff :: TestTree+test_compact_non_minimal_ff =+  H.testCase "rejects 0xff encoding of value <= 0xffffffff" $+    H.assertEqual "should be Nothing"+      Nothing+      (from_bytes (nonMinimalLegacyTx+         (BS.pack [0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])))++-- segwit txid known vector --------------------------------------------------++-- Regression vector: txid of firstSegwitRaw, displayed big-endian.+firstSegwitTxId :: BS.ByteString+firstSegwitTxId =+  "c586389e5e4b3acb9d6c8be1c19ae8ab2795397633176f5a6442a261bbdefc3a"++txid_first_segwit :: TestTree+txid_first_segwit = H.testCase "txid of first-segwit fixture" $+  case from_base16 firstSegwitRaw of+    Nothing -> H.assertFailure "failed to parse tx"+    Just tx -> do+      let computed = un_txid (txid tx)+          expected = BS.reverse (hex firstSegwitTxId)+      H.assertEqual "txid mismatch" expected computed++-- BIP143 P2SH-P2WSH multi-sighash vectors -----------------------------------++-- Shared fixture: unsigned tx, scriptCode, input index, value.+-- Source: https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki+p2shP2wshTx :: Tx+p2shP2wshTx = maybe placeholder_tx id (from_base16 p2shP2wshTxHex)++p2shP2wshTxHex :: BS.ByteString+p2shP2wshTxHex = mconcat+  [ "010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c"+  , "1ca29787b96e0100000000ffffffff0200e9a435000000001976a914389ffc"+  , "e9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a914"+  , "7480a33f950689af511e6e84c138dbbd3c3ee41588ac00000000"+  ]++-- | A minimal transaction standing in for a fixture that fails to parse+--   (which the "fixtures parse" test reports).+placeholder_tx :: Tx+placeholder_tx = Tx 1+  (TxIn (OutPoint null_txid 0) BS.empty 0 (Witness []) :| [])+  (TxOut 0 BS.empty :| []) 0++-- | A fixture txid: 32 copies of a byte.+tid :: Word8 -> TxId+tid w = maybe null_txid id (mk_txid (BS.replicate 32 w))++-- | Clear every input's witness.+strip_witnesses :: Tx -> Tx+strip_witnesses tx =+  tx { tx_inputs = fmap (\i -> i { txin_witness = Witness [] })+                        (tx_inputs tx) }++p2shP2wshScriptCode :: BS.ByteString+p2shP2wshScriptCode = hex $ mconcat+  [ "56210307b8ae49ac90a048e9b53357a2354b3334e9c8bee813ecb98e99a7e07e8c"+  , "3ba32103b28f0c28bfab54554ae8c658ac5c3e0ce6e79ad336331f78c428dd43ee"+  , "a8449b21034b8113d703413d57761b8b9781957b8c0ac1dfe69f492580ca4195f5"+  , "0376ba4a21033400f6afecb833092a9a21cfdf1ed1376e58c5d1f47de746831239"+  , "87e967a8f42103a6d48b1131e94ba04d9737d61acdaa1322008af9602b3b14862c"+  , "07a1789aac162102d8b661b0b3302ee2f162b09e07a55ad5dfbe673a9f01d9f0c1"+  , "9617681024306b56ae"+  ]++p2shP2wshValue :: Word64+p2shP2wshValue = 987654321  -- 9.87654321 BTC++assertP2shP2wshSighash :: SighashType -> BS.ByteString -> H.Assertion+assertP2shP2wshSighash st expectedHex =+  case sighash_segwit p2shP2wshTx 0 p2shP2wshScriptCode p2shP2wshValue+         (encode_sighash st) of+    Nothing  -> H.assertFailure "sighash_segwit returned Nothing"+    Just res -> H.assertEqual "sighash mismatch" (hex expectedHex) res++bip143_p2sh_p2wsh_all :: TestTree+bip143_p2sh_p2wsh_all = H.testCase "SIGHASH_ALL" $+  assertP2shP2wshSighash SIGHASH_ALL+    "185c0be5263dce5b4bb50a047973c1b6272bfbd0103a89444597dc40b248ee7c"++bip143_p2sh_p2wsh_none :: TestTree+bip143_p2sh_p2wsh_none = H.testCase "SIGHASH_NONE" $+  assertP2shP2wshSighash SIGHASH_NONE+    "e9733bc60ea13c95c6527066bb975a2ff29a925e80aa14c213f686cbae5d2f36"++bip143_p2sh_p2wsh_single :: TestTree+bip143_p2sh_p2wsh_single = H.testCase "SIGHASH_SINGLE" $+  assertP2shP2wshSighash SIGHASH_SINGLE+    "1e1f1c303dc025bd664acb72e583e933fae4cff9148bf78c157d1e8f78530aea"++bip143_p2sh_p2wsh_all_acp :: TestTree+bip143_p2sh_p2wsh_all_acp = H.testCase "SIGHASH_ALL|ANYONECANPAY" $+  assertP2shP2wshSighash SIGHASH_ALL_ANYONECANPAY+    "2a67f03e63a6a422125878b40b82da593be8d4efaafe88ee528af6e5a9955c6e"++bip143_p2sh_p2wsh_none_acp :: TestTree+bip143_p2sh_p2wsh_none_acp = H.testCase "SIGHASH_NONE|ANYONECANPAY" $+  assertP2shP2wshSighash SIGHASH_NONE_ANYONECANPAY+    "781ba15f3779d5542ce8ecb5c18716733a5ee42a6f51488ec96154934e2c890a"++bip143_p2sh_p2wsh_single_acp :: TestTree+bip143_p2sh_p2wsh_single_acp = H.testCase "SIGHASH_SINGLE|ANYONECANPAY" $+  assertP2shP2wshSighash SIGHASH_SINGLE_ANYONECANPAY+    "511e8e52ed574121fc1b654970395502128263f62662e076dc6baf05c2e6a99b"++-- Bitcoin Core sighash.json legacy vectors ----------------------------------++-- These exercise the raw 32-bit hashType code path. Bitcoin Core's+-- sighash.json uses non-canonical hashType values that commit the full+-- 32 bits to the preimage; the SighashType ADT can't construct them.+--+-- Source: github.com/bitcoin/bitcoin src/test/data/sighash.json (first+-- 20 entries). Expected hashes are stored big-endian (via+-- uint256::GetHex) so we reverse before comparing.+--+-- Bitcoin Core's hashType field is int32_t (signed); we cast to Word32.+bcHashType :: Int32 -> Word32+bcHashType = fromIntegral++-- | Run a Bitcoin-Core sighash.json legacy vector.+bcSighashCase+  :: TestName+  -> BS.ByteString  -- ^ raw tx hex+  -> BS.ByteString  -- ^ scriptCode hex+  -> Int            -- ^ input index+  -> Int32          -- ^ signed hashType+  -> BS.ByteString  -- ^ expected hash hex (big-endian display)+  -> TestTree+bcSighashCase name rawHex scriptHex idx ht expectedHex =+  H.testCase name $+    case from_base16 rawHex of+      Nothing -> H.assertFailure "failed to parse tx"+      Just tx ->+        let result   = sighash_legacy tx idx (hex scriptHex) (bcHashType ht)+            expected = BS.reverse (hex expectedHex)+        in  H.assertEqual "sighash mismatch" expected result++bc_sighash_1 :: TestTree+bc_sighash_1 = bcSighashCase+  "entry 1: idx=2, hashType=0x6f29291f (ALL)"+  (mconcat+    [ "907c2bc503ade11cc3b04eb2918b6f547b0630ab569273824748c87ea14b0696"+    , "526c66ba740200000004ab65ababfd1f9bdd4ef073c7afc4ae00da8a66f429c9"+    , "17a0081ad1e1dabce28d373eab81d8628de802000000096aab5253ab52000052"+    , "ad042b5f25efb33beec9f3364e8a9139e8439d9d7e26529c3c30b6c3fd89f868"+    , "4cfd68ea0200000009ab53526500636a52ab599ac2fe02a526ed040000000008"+    , "535300516352515164370e010000000003006300ab2ec229"+    ])+  ""+  2+  1864164639+  "31af167a6cf3f9d5f6875caa4d31704ceb0eba078d132b78dab52c3b8997317e"++-- NOTE: raw hex is on a single line to avoid manual-splitting errors.+bc_sighash_2 :: TestTree+bc_sighash_2 = bcSighashCase+  "entry 2: idx=0, hashType=0xad118f9c (ALL|ACP)"+  "a0aa3126041621a6dea5b800141aa696daf28408959dfb2df96095db9fa425ad3f427f2f6103000000015360290e9c6063fa26912c2e7fb6a0ad80f1c5fea1771d42f12976092e7a85a4229fdb6e890000000001abc109f6e47688ac0e4682988785744602b8c87228fcef0695085edf19088af1a9db126e93000000000665516aac536affffffff8fe53e0806e12dfd05d67ac68f4768fdbe23fc48ace22a5aa8ba04c96d58e2750300000009ac51abac63ab5153650524aa680455ce7b000000000000499e50030000000008636a00ac526563ac5051ee030000000003abacabd2b6fe000000000003516563910fb6b5"+  "65"+  0+  (-1391424484)+  "48d6a1bd2cd9eec54eb866fc71209418a950402b5d7e52363bfb75c98e141175"++bc_sighash_4 :: TestTree+bc_sighash_4 = bcSighashCase+  "entry 4: idx=1, hashType=0x46fb4ce9 (ALL|ACP)"+  (mconcat+    [ "73107cbd025c22ebc8c3e0a47b2a760739216a528de8d4dab5d45cbeb3051ceb"+    , "ae73b01ca10200000007ab6353656a636affffffffe26816dffc670841e6a6c8"+    , "c61c586da401df1261a330a6c6b3dd9f9a0789bc9e000000000800ac6552ac6a"+    , "ac51ffffffff0174a8f0010000000004ac52515100000000"+    ])+  "5163ac63635151ac"+  1+  1190874345+  "06e328de263a87b09beabe222a21627a6ea5c7f560030da31610c4611f4a46bc"++bc_sighash_9 :: TestTree+bc_sighash_9 = bcSighashCase+  "entry 9: idx=0, hashType=0x8b07e3c3 (SINGLE|ACP)"+  (mconcat+    [ "d3b7421e011f4de0f1cea9ba7458bf3486bee722519efab711a963fa8c100970"+    , "cf7488b7bb0200000003525352dcd61b300148be5d05000000000000000000"+    ])+  "535251536aac536a"+  0+  (-1960128125)+  "29aa6d2d752d3310eba20442770ad345b7f6a35f96161ede5f07b33e92053e2a"++bc_sighash_14 :: TestTree+bc_sighash_14 = bcSighashCase+  "entry 14: idx=1, hashType=0x9604e295 (ALL|ACP, strips 2x 0xab)"+  "f40a750702af06efff3ea68e5d56e42bc41cdb8b6065c98f1221fe04a325a898cb61f3d7ee030000000363acacffffffffb5788174aef79788716f96af779d7959147a0c2e0e5bfb6c2dba2df5b4b97894030000000965510065535163ac6affffffff0445e6fd0200000000096aac536365526a526aa6546b000000000008acab656a6552535141a0fd010000000000c897ea030000000008526500ab526a6a631b39dba3"+  "00abab5163ac"+  1+  (-1778064747)+  "d76d0fc0abfa72d646df888bce08db957e627f72962647016eeae5a8412354cf"++bc_sighash_20 :: TestTree+bc_sighash_20 = bcSighashCase+  "entry 20: idx=0, hashType=0xcab2f825 (ALL)"+  (mconcat+    [ "c2b0b99001acfecf7da736de0ffaef8134a9676811602a6299ba5a2563a23bb0"+    , "9e8cbedf9300000000026300ffffffff042997c50300000000045252536a2724"+    , "37030000000007655353ab6363ac663752030000000002ab6a6d5c9000000000"+    , "00066a6a5265abab00000000"+    ])+  "52ac525163515251"+  0+  (-894181723)+  "8b300032a1915a4ac05cea2f7d44c26f2a08d109a71602636f15866563eaafdc"++-- strip_codeseparators tests -------------------------------------------------++-- A script containing 0x00, OP_1, OP_IF, OP_CHECKSIG and no 0xab. Strip+-- should be a no-op.+codesep_no_op :: TestTree+codesep_no_op = H.testCase "no 0xab: unchanged" $+  H.assertEqual "" (BS.pack [0x00, 0x51, 0x63, 0xac])+    (strip_codeseparators (BS.pack [0x00, 0x51, 0x63, 0xac]))++-- Two OP_CODESEPARATOR bytes in opcode position get stripped.+codesep_strip_simple :: TestTree+codesep_strip_simple = H.testCase "0xab at opcode position stripped" $+  H.assertEqual "" (BS.pack [0x00, 0x51, 0x63, 0xac])+    (strip_codeseparators (BS.pack [0x00, 0xab, 0xab, 0x51, 0x63, 0xac]))++-- A direct push (opcode 0x02) of two 0xab bytes: data preserved.+codesep_inside_push :: TestTree+codesep_inside_push = H.testCase "0xab inside push data preserved" $+  let s = BS.pack [0x02, 0xab, 0xab, 0x51]  -- push 2 bytes, then OP_1+  in  H.assertEqual "" s (strip_codeseparators s)++-- OP_PUSHDATA1 with 3 bytes of 0xab, followed by a lone 0xab opcode and+-- OP_1. The data must be preserved; the trailing 0xab opcode stripped.+codesep_inside_pushdata1 :: TestTree+codesep_inside_pushdata1 =+  H.testCase "OP_PUSHDATA1 data preserved, trailing 0xab stripped" $+    let input    = BS.pack [0x4c, 0x03, 0xab, 0xab, 0xab, 0xab, 0x51]+        expected = BS.pack [0x4c, 0x03, 0xab, 0xab, 0xab, 0x51]+    in  H.assertEqual "" expected (strip_codeseparators input)++-- OP_PUSHDATA2 with 2 bytes of 0xab data (LE length = 0x0002), then a+-- lone 0xab opcode and OP_1. Exercises the n0 + n1 * 0x100 arithmetic.+codesep_inside_pushdata2 :: TestTree+codesep_inside_pushdata2 =+  H.testCase "OP_PUSHDATA2 data preserved, trailing 0xab stripped" $+    let input    = BS.pack [0x4d, 0x02, 0x00, 0xab, 0xab, 0xab, 0x51]+        expected = BS.pack [0x4d, 0x02, 0x00, 0xab, 0xab, 0x51]+    in  H.assertEqual "" expected (strip_codeseparators input)++-- OP_PUSHDATA4 with 1 byte of 0xab data (LE length = 0x00000001), then+-- a lone 0xab opcode. Exercises the 4-byte LE length decode.+codesep_inside_pushdata4 :: TestTree+codesep_inside_pushdata4 =+  H.testCase "OP_PUSHDATA4 data preserved, trailing 0xab stripped" $+    let input    = BS.pack [0x4e, 0x01, 0x00, 0x00, 0x00, 0xab, 0xab, 0x51]+        expected = BS.pack [0x4e, 0x01, 0x00, 0x00, 0x00, 0xab, 0x51]+    in  H.assertEqual "" expected (strip_codeseparators input)++-- Malformed tail: OP_PUSHDATA2 with a truncated length header (only+-- one byte available). Per docstring, copied verbatim.+codesep_malformed_tail :: TestTree+codesep_malformed_tail =+  H.testCase "malformed tail copied verbatim" $+    let input = BS.pack [0x4d, 0x00]+    in  H.assertEqual "" input (strip_codeseparators input)++-- | Arbitrary ByteString generator (QuickCheck has no built-in instance).+genByteString :: Gen BS.ByteString+genByteString = BS.pack <$> arbitrary++prop_strip_codesep_idempotent :: TestTree+prop_strip_codesep_idempotent =+  QC.testProperty "strip_codeseparators is idempotent" $+    forAll genByteString $ \s ->+      strip_codeseparators (strip_codeseparators s)+        === strip_codeseparators s++prop_strip_codesep_no_0xab_unchanged :: TestTree+prop_strip_codesep_no_0xab_unchanged =+  QC.testProperty "strip_codeseparators is no-op without 0xab bytes" $+    forAll (resize 500 $ BS.pack . filter (/= 0xab) <$> arbitrary) $ \s ->+      strip_codeseparators s === s++-- BIP341 taproot test vectors -----------------------------------------------++-- Shared fixture: 9-input / 2-output transaction from BIP341+-- wallet-test-vectors.json (keyPathSpending[0]).+bip341Tx :: Tx+bip341Tx = maybe placeholder_tx id (from_base16 bip341TxHex)++bip341TxHex :: BS.ByteString+bip341TxHex =+    "020000000001097de20cbff686da83a54981d2b9bab3586f4ca7e48f57f5b55963115f3b334e9c010000000000000000d7b7cab57b1393ace2d064f4d4a2cb8af6def61273e127517d44759b6dafdd990000000000fffffffff8e1f583384333689228c5d28eac13366be082dc57441760d957275419a41842000000006b4830450221008f3b8f8f0537c420654d2283673a761b7ee2ea3c130753103e08ce79201cf32a022079e7ab904a1980ef1c5890b648c8783f4d10103dd62f740d13daa79e298d50c201210279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798fffffffff0689180aa63b30cb162a73c6d2a38b7eeda2a83ece74310fda0843ad604853b0100000000feffffffaa5202bdf6d8ccd2ee0f0202afbbb7461d9264a25e5bfd3c5a52ee1239e0ba6c0000000000feffffff956149bdc66faa968eb2be2d2faa29718acbfe3941215893a2a3446d32acd050000000000000000000e664b9773b88c09c32cb70a2a3e4da0ced63b7ba3b22f848531bbb1d5d5f4c94010000000000000000e9aa6b8e6c9de67619e6a3924ae25696bb7b694bb677a632a74ef7eadfd4eabf0000000000ffffffffa778eb6a263dc090464cd125c466b5a99667720b1c110468831d058aa1b82af10100000000ffffffff0200ca9a3b000000001976a91406afd46bcdfd22ef94ac122aa11f241244a37ecc88ac807840cb0000000020ac9a87f5594be208f8532db38cff670c450ed2fea8fcdefcc9a663f78bab962b0141ed7c1647cb97379e76892be0cacff57ec4a7102aa24296ca39af7541246d8ff14d38958d4cc1e2e478e4d4a764bbfd835b16d4e314b72937b29833060b87276c030141052aedffc554b41f52b521071793a6b88d6dbca9dba94cf34c83696de0c1ec35ca9c5ed4ab28059bd606a4f3a657eec0bb96661d42921b5f50a95ad33675b54f83000141ff45f742a876139946a149ab4d9185574b98dc919d2eb6754f8abaa59d18b025637a3aa043b91817739554f4ed2026cf8022dbd83e351ce1fabc272841d2510a010140b4010dd48a617db09926f729e79c33ae0b4e94b79f04a1ae93ede6315eb3669de185a17d2b0ac9ee09fd4c64b678a0b61a0a86fa888a273c8511be83bfd6810f0247304402202b795e4de72646d76eab3f0ab27dfa30b810e856ff3a46c9a702df53bb0d8cc302203ccc4d822edab5f35caddb10af1be93583526ccfbade4b4ead350781e2f8adcd012102f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f90141a3785919a2ce3c4ce26f298c3d51619bc474ae24014bcdd31328cd8cfbab2eff3395fa0a16fe5f486d12f22a9cedded5ae74feb4bbe5351346508c5405bcfee0020141ea0c6ba90763c2d3a296ad82ba45881abb4f426b3f87af162dd24d5109edc1cdd11915095ba47c3a9963dc1e6c432939872bc49212fe34c632cd3ab9fed429c4820141bbc9584a11074e83bc8c6759ec55401f0ae7b03ef290c3139814f545b58a9f8127258000874f44bc46db7646322107d4d86aec8e73b8719a61fff761d75b5dd9810065cd1d"++-- Amounts and scriptPubKeys for the 9 prevouts, in order.+bip341Amounts :: [Word64]+bip341Amounts =+  [ 420000000, 462000000, 294000000, 504000000, 630000000+  , 378000000, 672000000, 546000000, 588000000+  ]++bip341Spks :: [BS.ByteString]+bip341Spks = map hex+  [ "512053a1f6e454df1aa2776a2814a721372d6258050de330b3c6d10ee8f4e0dda343"+  , "5120147c9c57132f6e7ecddba9800bb0c4449251c92a1e60371ee77557b6620f3ea3"+  , "76a914751e76e8199196d454941c45d1b3a323f1433bd688ac"+  , "5120e4d810fd50586274face62b8a807eb9719cef49c04177cc6b76a9a4251d5450e"+  , "512091b64d5324723a985170e4dc5a0f84c041804f2cd12660fa5dec09fc21783605"+  , "00147dd65592d0ab2fe0d0257d571abf032cd9db93dc"+  , "512075169f4001aa68f15bbed28b218df1d0a62cbbcf1188c6665110c293c907b831"+  , "5120712447206d7a5238acc7ff53fbe94a3b64539ad291c7cdbc490b7577e4b17df5"+  , "512077e30a5522dd9f894c3f8b8bd4c4b2cf82ca7da8a3ea6a239655c39c050ab220"+  ]++-- | Run a BIP341 key-path vector against bip341Tx.+bip341Case :: TestName -> Int -> Word8 -> BS.ByteString -> TestTree+bip341Case name idx ht expectedHex =+  H.testCase name $+    case sighash_taproot_keypath bip341Tx idx+           bip341Amounts bip341Spks Nothing ht of+      Nothing  -> H.assertFailure "sighash_taproot_keypath returned Nothing"+      Just res -> H.assertEqual "sighash mismatch" (hex expectedHex) res++bip341_kp_in0_single :: TestTree+bip341_kp_in0_single = bip341Case+  "idx=0, hashType=0x03 (SINGLE)" 0 0x03+  "2514a6272f85cfa0f45eb907fcb0d121b808ed37c6ea160a5a9046ed5526d555"++bip341_kp_in1_single_acp :: TestTree+bip341_kp_in1_single_acp = bip341Case+  "idx=1, hashType=0x83 (SINGLE|ACP)" 1 0x83+  "325a644af47e8a5a2591cda0ab0723978537318f10e6a63d4eed783b96a71a4d"++bip341_kp_in3_all :: TestTree+bip341_kp_in3_all = bip341Case+  "idx=3, hashType=0x01 (ALL)" 3 0x01+  "bf013ea93474aa67815b1b6cc441d23b64fa310911d991e713cd34c7f5d46669"++bip341_kp_in4_default :: TestTree+bip341_kp_in4_default = bip341Case+  "idx=4, hashType=0x00 (DEFAULT)" 4 0x00+  "4f900a0bae3f1446fd48490c2958b5a023228f01661cda3496a11da502a7f7ef"++bip341_kp_in6_none :: TestTree+bip341_kp_in6_none = bip341Case+  "idx=6, hashType=0x02 (NONE)" 6 0x02+  "15f25c298eb5cdc7eb1d638dd2d45c97c4c59dcaec6679cfc16ad84f30876b85"++bip341_kp_in7_none_acp :: TestTree+bip341_kp_in7_none_acp = bip341Case+  "idx=7, hashType=0x82 (NONE|ACP)" 7 0x82+  "cd292de50313804dabe4685e83f923d2969577191a3e1d2882220dca88cbeb10"++bip341_kp_in8_all_acp :: TestTree+bip341_kp_in8_all_acp = bip341Case+  "idx=8, hashType=0x81 (ALL|ACP)" 8 0x81+  "cccb739eca6c13a8a89e6e5cd317ffe55669bbda23f2fd37b0f18755e008edd2"++-- taproot validation tests --------------------------------------------------++-- A tiny well-formed taproot context for negative tests.+tinyTaprootTx :: Tx+tinyTaprootTx = Tx+  { tx_version   = 2+  , tx_inputs    = txin :| []+  , tx_outputs   = txout :| []+  , tx_locktime  = 0+  }+  where+    txin = TxIn+      { txin_prevout    = OutPoint (tid 0xab) 0+      , txin_script_sig = BS.empty+      , txin_sequence   = 0xffffffff+      , txin_witness    = Witness []+      }+    txout = TxOut+      { txout_value         = 1000+      , txout_script_pubkey = hex "5120" <> BS.replicate 32 0x00+      }++tinyAmts :: [Word64]+tinyAmts = [100000]++tinySpks :: [BS.ByteString]+tinySpks = [hex "5120" <> BS.replicate 32 0x00]++taproot_invalid_ht :: TestTree+taproot_invalid_ht =+  H.testCase "rejects non-canonical hashType (0x04)" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_keypath tinyTaprootTx 0 tinyAmts tinySpks Nothing 0x04++taproot_invalid_idx :: TestTree+taproot_invalid_idx =+  H.testCase "rejects out-of-range input index" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_keypath tinyTaprootTx 7 tinyAmts tinySpks Nothing 0x00++taproot_amounts_mismatch :: TestTree+taproot_amounts_mismatch =+  H.testCase "rejects amounts length mismatch" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_keypath tinyTaprootTx 0 [] tinySpks Nothing 0x00++taproot_spks_mismatch :: TestTree+taproot_spks_mismatch =+  H.testCase "rejects scriptPubKeys length mismatch" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_keypath tinyTaprootTx 0 tinyAmts [] Nothing 0x00++taproot_bad_annex_prefix :: TestTree+taproot_bad_annex_prefix =+  H.testCase "rejects annex without 0x50 prefix" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_keypath tinyTaprootTx 0 tinyAmts tinySpks+        (Just (BS.pack [0xff, 0xaa])) 0x00++taproot_empty_annex :: TestTree+taproot_empty_annex =+  H.testCase "rejects empty annex" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_keypath tinyTaprootTx 0 tinyAmts tinySpks+        (Just BS.empty) 0x00++taproot_short_leaf_hash :: TestTree+taproot_short_leaf_hash =+  H.testCase "scriptpath rejects non-32-byte tap leaf hash" $+    H.assertEqual "should be Nothing" Nothing $+      sighash_taproot_scriptpath tinyTaprootTx 0 tinyAmts tinySpks Nothing+        (BS.replicate 31 0x00) 0xffffffff 0x00++-- BIP341: SIGHASH_SINGLE without a corresponding output is rejected.+-- tinyTaprootTx has 1 output; idx=0 is in range, so use a 2-input tx+-- and index the second input with SINGLE (no output 1).+taproot_single_oob :: TestTree+taproot_single_oob =+  H.testCase "rejects SIGHASH_SINGLE with idx >= n_outputs" $+    let txin2 = TxIn+          { txin_prevout    = OutPoint (tid 0xcd) 0+          , txin_script_sig = BS.empty+          , txin_sequence   = 0xffffffff+          , txin_witness    = Witness []+          }+        tx2 = tinyTaprootTx+          { tx_inputs = (NE.head (tx_inputs tinyTaprootTx)) :| [txin2] }+        amts = [100000, 200000]+        spks = tinySpks ++ tinySpks+    in  H.assertEqual "should be Nothing" Nothing $+          sighash_taproot_keypath tx2 1 amts spks Nothing 0x03++-- rust-bitcoin script-path vector -------------------------------------------++-- Source: rust-bitcoin bitcoin/src/crypto/sighash.rs,+-- sighashes_with_script_path_raw_hash test. P2TR input, ALL hashType,+-- precomputed tap leaf hash, default codesep position.+-- NOTE: raw hex on a single line to avoid manual-splitting errors.+rb_script_path_all :: TestTree+rb_script_path_all = H.testCase+  "script-path, hashType=0x01 (ALL), default codesep" $ do+    let rawTx = "020000000189fc651483f9296b906455dd939813bf086b1bbe7c77635e157c8e14ae29062195010000004445b5c7044561320000000000160014331414dbdada7fb578f700f38fb69995fc9b5ab958020000000000001976a914268db0a8104cc6d8afd91233cc8b3d1ace8ac3ef88ac580200000000000017a914ec00dcb368d6a693e11986d265f659d2f59e8be2875802000000000000160014c715799a49a0bae3956df9c17cb4440a673ac0df6f010000"+        amount = 3468315 :: Word64  -- 0x000000000034ec1b LE+        spk = hex+          "512028055142ea437db73382e991861446040b61dd2185c4891d7daf6893d79f7182"+        leaf = hex+          "15a2530514e399f8b5cf0b3d3112cf5b289eaa3e308ba2071b58392fdc6da68a"+        expected = hex+          "d66de5274a60400c7b08c86ba6b7f198f40660079edf53aca89d2a9501317f2e"+    case from_base16 rawTx of+      Nothing -> H.assertFailure "failed to parse tx"+      Just tx ->+        case sighash_taproot_scriptpath tx 0 [amount] [spk] Nothing+               leaf 0xffffffff 0x01 of+          Nothing  ->+             H.assertFailure "sighash_taproot_scriptpath returned Nothing"+          Just res -> H.assertEqual "sighash mismatch" expected res++-- taproot properties --------------------------------------------------------++-- | 32-byte tap leaf hash generator.+genTapLeaf :: Gen BS.ByteString+genTapLeaf = BS.pack <$> vectorOf 32 arbitrary++-- key-path and script-path differ in spend_type (0 vs 2) and in the+-- 37-byte tail appended for script-path. Hashes must differ for any+-- choice of leaf hash and codeseparator position.+prop_taproot_keypath_neq_scriptpath :: TestTree+prop_taproot_keypath_neq_scriptpath =+  QC.testProperty "taproot key-path /= script-path for any leaf, csep" $+    forAll genTapLeaf $ \leaf ->+      forAll (arbitrary :: Gen Word32) $ \csep ->+        let kp = sighash_taproot_keypath bip341Tx 0+                   bip341Amounts bip341Spks Nothing 0x00+            sp = sighash_taproot_scriptpath bip341Tx 0+                   bip341Amounts bip341Spks Nothing leaf csep 0x00+        in  kp =/= sp++-- Different codeseparator positions commit to different preimages.+prop_taproot_csep_changes_hash :: TestTree+prop_taproot_csep_changes_hash =+  QC.testProperty "taproot script-path: distinct csep => distinct hash" $+    forAll genTapLeaf $ \leaf ->+      forAll (arbitrary :: Gen (Word32, Word32)) $ \(c1, c2) ->+        c1 /= c2 ==>+          let mk c = sighash_taproot_scriptpath bip341Tx 0+                       bip341Amounts bip341Spks Nothing leaf c 0x01+          in  mk c1 =/= mk c2++-- | Annex generator: arbitrary payload prefixed with the mandatory+--   0x50 byte.+genAnnex :: Gen BS.ByteString+genAnnex = do+  payload <- resize 64 arbitrary+  pure (BS.cons 0x50 (BS.pack payload))++-- Distinct well-formed annexes produce distinct sighashes, confirming+-- the annex bytes are committed to the preimage.+prop_taproot_annex_commits :: TestTree+prop_taproot_annex_commits =+  QC.testProperty "taproot distinct annexes yield distinct hashes" $+    forAll genAnnex $ \a1 ->+      forAll genAnnex $ \a2 ->+        a1 /= a2 ==>+          let mk a = sighash_taproot_keypath bip341Tx 0+                       bip341Amounts bip341Spks (Just a) 0x01+          in  mk a1 =/= mk a2++-- ANYONECANPAY omits sha_prevouts, sha_amounts, sha_scriptpubkeys, and+-- sha_sequences from the preimage. Permuting the OTHER (non-signing)+-- entries in amounts and scriptPubKeys must not change the hash.+prop_taproot_acp_ignores_other_inputs :: TestTree+prop_taproot_acp_ignores_other_inputs =+  QC.testProperty "taproot ACP ignores other inputs' amounts/spks" $+    let idx = 0+        ht  = 0x81 :: Word8  -- ALL|ACP+        h1  = sighash_taproot_keypath bip341Tx idx+                bip341Amounts bip341Spks Nothing ht+        -- Mutate the *other* amounts and scriptPubKeys arbitrarily.+        mutAmts = take 1 bip341Amounts ++ map (* 7) (drop 1 bip341Amounts)+        mutSpks = take 1 bip341Spks+               ++ map (BS.cons 0xff) (drop 1 bip341Spks)+        h2  = sighash_taproot_keypath bip341Tx idx+                mutAmts mutSpks Nothing ht+    in  h1 === h2++-- For NONE (no SINGLE bit), sha_outputs is omitted. Appending extra+-- outputs to the tx must not change the hash.+prop_taproot_none_ignores_outputs :: TestTree+prop_taproot_none_ignores_outputs =+  QC.testProperty "taproot NONE ignores appended outputs" $+    forAll (QC.listOf1 (arbitrary :: Gen TxOut)) $ \extras ->+      let idx = 6+          ht  = 0x02 :: Word8  -- NONE+          tx' = bip341Tx+            { tx_outputs = appendOutputs (tx_outputs bip341Tx) extras }+          h1 = sighash_taproot_keypath bip341Tx idx+                 bip341Amounts bip341Spks Nothing ht+          h2 = sighash_taproot_keypath tx' idx+                 bip341Amounts bip341Spks Nothing ht+      in  h1 === h2+