diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -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 diff --git a/lib/Bitcoin/Prim/Tx.hs b/lib/Bitcoin/Prim/Tx.hs --- a/lib/Bitcoin/Prim/Tx.hs +++ b/lib/Bitcoin/Prim/Tx.hs @@ -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))) diff --git a/lib/Bitcoin/Prim/Tx/Internal.hs b/lib/Bitcoin/Prim/Tx/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Prim/Tx/Internal.hs @@ -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 +-- +-- 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 #-} diff --git a/lib/Bitcoin/Prim/Tx/Sighash.hs b/lib/Bitcoin/Prim/Tx/Sighash.hs --- a/lib/Bitcoin/Prim/Tx/Sighash.hs +++ b/lib/Bitcoin/Prim/Tx/Sighash.hs @@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | @@ -9,38 +10,59 @@ -- License: MIT -- Maintainer: Jared Tobin -- --- 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 diff --git a/ppad-tx.cabal b/ppad-tx.cabal --- a/ppad-tx.cabal +++ b/ppad-tx.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 +