diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +# Changelog + +- 0.1.0 (UNRELEASED) + * Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Control.DeepSeq +import Criterion.Main +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty(..)) + +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 + +-- sample data ----------------------------------------------------------------- + +-- | Sample outpoint (references a dummy txid). +sampleOutPoint :: OutPoint +sampleOutPoint = OutPoint (TxId (BS.replicate 32 0xab)) 0 + +-- | Sample input with typical P2PKH signature (~107 bytes). +sampleInput :: TxIn +sampleInput = TxIn + { txin_prevout = sampleOutPoint + , txin_script_sig = BS.replicate 107 0x00 -- typical P2PKH sig + , txin_sequence = 0xffffffff + } + +-- | Sample input for segwit (empty scriptSig). +sampleSegwitInput :: TxIn +sampleSegwitInput = TxIn + { txin_prevout = sampleOutPoint + , txin_script_sig = BS.empty + , txin_sequence = 0xffffffff + } + +-- | Sample output with typical P2PKH script (25 bytes). +sampleOutput :: TxOut +sampleOutput = TxOut + { txout_value = 50000000 + , txout_script_pubkey = BS.replicate 25 0x00 -- typical P2PKH script + } + +-- | Sample witness stack (signature + pubkey for P2WPKH). +sampleWitness :: Witness +sampleWitness = Witness + [ BS.replicate 72 0x00 -- DER signature + , BS.replicate 33 0x00 -- compressed pubkey + ] + +-- | Create a legacy transaction with n inputs and m outputs. +-- Requires n >= 1 and m >= 1. +mkLegacyTx :: Int -> Int -> Tx +mkLegacyTx !numInputs !numOutputs = Tx + { tx_version = 1 + , tx_inputs = sampleInput :| replicate (numInputs - 1) sampleInput + , tx_outputs = sampleOutput :| replicate (numOutputs - 1) sampleOutput + , tx_witnesses = [] + , tx_locktime = 0 + } + +-- | Create a segwit transaction with n inputs and m outputs. +-- Requires n >= 1 and m >= 1. +mkSegwitTx :: Int -> Int -> Tx +mkSegwitTx !numInputs !numOutputs = Tx + { tx_version = 2 + , tx_inputs = sampleSegwitInput :| replicate (numInputs - 1) sampleSegwitInput + , tx_outputs = sampleOutput :| replicate (numOutputs - 1) sampleOutput + , tx_witnesses = replicate numInputs sampleWitness + , tx_locktime = 0 + } + +-- sample transactions --------------------------------------------------------- + +smallLegacyTx, mediumLegacyTx, largeLegacyTx :: Tx +smallLegacyTx = mkLegacyTx 1 1 +mediumLegacyTx = mkLegacyTx 5 5 +largeLegacyTx = mkLegacyTx 20 20 + +smallSegwitTx, mediumSegwitTx, largeSegwitTx :: Tx +smallSegwitTx = mkSegwitTx 1 1 +mediumSegwitTx = mkSegwitTx 5 5 +largeSegwitTx = mkSegwitTx 20 20 + +-- serialised bytes ------------------------------------------------------------ + +smallLegacyBytes, mediumLegacyBytes, largeLegacyBytes :: BS.ByteString +smallLegacyBytes = to_bytes smallLegacyTx +mediumLegacyBytes = to_bytes mediumLegacyTx +largeLegacyBytes = to_bytes largeLegacyTx + +smallSegwitBytes, mediumSegwitBytes, largeSegwitBytes :: BS.ByteString +smallSegwitBytes = to_bytes smallSegwitTx +mediumSegwitBytes = to_bytes mediumSegwitTx +largeSegwitBytes = to_bytes largeSegwitTx + +-- benchmarks ------------------------------------------------------------------ + +main :: IO () +main = defaultMain + [ bgroup "serialisation" + [ bgroup "to_bytes" + [ bench "small-legacy" $ nf to_bytes smallLegacyTx + , bench "small-segwit" $ nf to_bytes smallSegwitTx + , bench "medium-legacy" $ nf to_bytes mediumLegacyTx + , bench "medium-segwit" $ nf to_bytes mediumSegwitTx + , bench "large-legacy" $ nf to_bytes largeLegacyTx + , bench "large-segwit" $ nf to_bytes largeSegwitTx + ] + , bgroup "from_bytes" + [ bench "small-legacy" $ nf from_bytes smallLegacyBytes + , bench "small-segwit" $ nf from_bytes smallSegwitBytes + , bench "medium-legacy" $ nf from_bytes mediumLegacyBytes + , bench "medium-segwit" $ nf from_bytes mediumSegwitBytes + , bench "large-legacy" $ nf from_bytes largeLegacyBytes + , bench "large-segwit" $ nf from_bytes largeSegwitBytes + ] + , bgroup "to_bytes_legacy" + [ bench "small-legacy" $ nf to_bytes_legacy smallLegacyTx + , bench "small-segwit" $ nf to_bytes_legacy smallSegwitTx + , bench "medium-legacy" $ nf to_bytes_legacy mediumLegacyTx + , bench "medium-segwit" $ nf to_bytes_legacy mediumSegwitTx + , bench "large-legacy" $ nf to_bytes_legacy largeLegacyTx + , bench "large-segwit" $ nf to_bytes_legacy largeSegwitTx + ] + ] + , bgroup "txid" + [ bench "small-legacy" $ nf txid smallLegacyTx + , bench "small-segwit" $ nf txid smallSegwitTx + , bench "medium-legacy" $ nf txid mediumLegacyTx + , bench "medium-segwit" $ nf txid mediumSegwitTx + , bench "large-legacy" $ nf txid largeLegacyTx + , bench "large-segwit" $ nf txid largeSegwitTx + ] + ] diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -0,0 +1,140 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Control.DeepSeq +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty(..)) +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 + +-- sample data ----------------------------------------------------------------- + +-- | Sample outpoint (references a dummy txid). +sampleOutPoint :: OutPoint +sampleOutPoint = OutPoint (TxId (BS.replicate 32 0xab)) 0 + +-- | Sample input with typical P2PKH signature (~107 bytes). +sampleInput :: TxIn +sampleInput = TxIn + { txin_prevout = sampleOutPoint + , txin_script_sig = BS.replicate 107 0x00 -- typical P2PKH sig + , txin_sequence = 0xffffffff + } + +-- | Sample input for segwit (empty scriptSig). +sampleSegwitInput :: TxIn +sampleSegwitInput = TxIn + { txin_prevout = sampleOutPoint + , txin_script_sig = BS.empty + , txin_sequence = 0xffffffff + } + +-- | Sample output with typical P2PKH script (25 bytes). +sampleOutput :: TxOut +sampleOutput = TxOut + { txout_value = 50000000 + , txout_script_pubkey = BS.replicate 25 0x00 -- typical P2PKH script + } + +-- | Sample witness stack (signature + pubkey for P2WPKH). +sampleWitness :: Witness +sampleWitness = Witness + [ BS.replicate 72 0x00 -- DER signature + , BS.replicate 33 0x00 -- compressed pubkey + ] + +-- | Create a legacy transaction with n inputs and m outputs. +-- Requires n >= 1 and m >= 1. +mkLegacyTx :: Int -> Int -> Tx +mkLegacyTx !numInputs !numOutputs = Tx + { tx_version = 1 + , tx_inputs = sampleInput :| replicate (numInputs - 1) sampleInput + , tx_outputs = sampleOutput :| replicate (numOutputs - 1) sampleOutput + , tx_witnesses = [] + , tx_locktime = 0 + } + +-- | Create a segwit transaction with n inputs and m outputs. +-- Requires n >= 1 and m >= 1. +mkSegwitTx :: Int -> Int -> Tx +mkSegwitTx !numInputs !numOutputs = Tx + { tx_version = 2 + , tx_inputs = sampleSegwitInput :| replicate (numInputs - 1) sampleSegwitInput + , tx_outputs = sampleOutput :| replicate (numOutputs - 1) sampleOutput + , tx_witnesses = replicate numInputs sampleWitness + , tx_locktime = 0 + } + +-- sample transactions --------------------------------------------------------- + +smallLegacyTx, mediumLegacyTx, largeLegacyTx :: Tx +smallLegacyTx = mkLegacyTx 1 1 +mediumLegacyTx = mkLegacyTx 5 5 +largeLegacyTx = mkLegacyTx 20 20 + +smallSegwitTx, mediumSegwitTx, largeSegwitTx :: Tx +smallSegwitTx = mkSegwitTx 1 1 +mediumSegwitTx = mkSegwitTx 5 5 +largeSegwitTx = mkSegwitTx 20 20 + +-- serialised bytes ------------------------------------------------------------ + +smallLegacyBytes, mediumLegacyBytes, largeLegacyBytes :: BS.ByteString +smallLegacyBytes = to_bytes smallLegacyTx +mediumLegacyBytes = to_bytes mediumLegacyTx +largeLegacyBytes = to_bytes largeLegacyTx + +smallSegwitBytes, mediumSegwitBytes, largeSegwitBytes :: BS.ByteString +smallSegwitBytes = to_bytes smallSegwitTx +mediumSegwitBytes = to_bytes mediumSegwitTx +largeSegwitBytes = to_bytes largeSegwitTx + +-- allocation benchmarks ------------------------------------------------------- + +main :: IO () +main = W.mainWith $ do + -- to_bytes + W.func "to_bytes/small-legacy" to_bytes smallLegacyTx + W.func "to_bytes/small-segwit" to_bytes smallSegwitTx + W.func "to_bytes/medium-legacy" to_bytes mediumLegacyTx + W.func "to_bytes/medium-segwit" to_bytes mediumSegwitTx + W.func "to_bytes/large-legacy" to_bytes largeLegacyTx + W.func "to_bytes/large-segwit" to_bytes largeSegwitTx + + -- from_bytes + W.func "from_bytes/small-legacy" from_bytes smallLegacyBytes + W.func "from_bytes/small-segwit" from_bytes smallSegwitBytes + W.func "from_bytes/medium-legacy" from_bytes mediumLegacyBytes + W.func "from_bytes/medium-segwit" from_bytes mediumSegwitBytes + W.func "from_bytes/large-legacy" from_bytes largeLegacyBytes + W.func "from_bytes/large-segwit" from_bytes largeSegwitBytes + + -- to_bytes_legacy + W.func "to_bytes_legacy/small-legacy" to_bytes_legacy smallLegacyTx + W.func "to_bytes_legacy/small-segwit" to_bytes_legacy smallSegwitTx + W.func "to_bytes_legacy/medium-legacy" to_bytes_legacy mediumLegacyTx + W.func "to_bytes_legacy/medium-segwit" to_bytes_legacy mediumSegwitTx + W.func "to_bytes_legacy/large-legacy" to_bytes_legacy largeLegacyTx + W.func "to_bytes_legacy/large-segwit" to_bytes_legacy largeSegwitTx + + -- txid + W.func "txid/small-legacy" txid smallLegacyTx + W.func "txid/small-segwit" txid smallSegwitTx + W.func "txid/medium-legacy" txid mediumLegacyTx + W.func "txid/medium-segwit" txid mediumSegwitTx + W.func "txid/large-legacy" txid largeLegacyTx + W.func "txid/large-segwit" txid largeSegwitTx diff --git a/lib/Bitcoin/Prim/Tx.hs b/lib/Bitcoin/Prim/Tx.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Prim/Tx.hs @@ -0,0 +1,486 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: Bitcoin.Prim.Tx +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Minimal Bitcoin transaction primitives, including raw transaction +-- types, serialisation to/from bytes, and txid computation. + +module Bitcoin.Prim.Tx ( + -- * Transaction Types + Tx(..) + , TxIn(..) + , TxOut(..) + , OutPoint(..) + , Witness(..) + , TxId(..) + , mkTxId + + -- * Serialisation + , to_bytes + , from_bytes + , to_bytes_legacy + , to_base16 + , from_base16 + + -- * TxId + , txid + + -- * Internal (for Sighash) + , put_word32_le + , put_word64_le + , put_compact + , put_outpoint + , put_txout + , to_strict + ) where + +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. +-- +-- 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 + | 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) + +-- | 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) + +-- serialisation --------------------------------------------------------------- + +-- | Serialise a transaction to bytes. +-- +-- Uses segwit format if witnesses are present, legacy otherwise. +-- +-- @ +-- -- round-trip +-- from_bytes (to_bytes tx) == Just tx +-- @ +to_bytes :: Tx -> BS.ByteString +to_bytes tx@Tx {..} + | null tx_witnesses = to_bytes_legacy tx + | otherwise = to_strict $ + put_word32_le tx_version + <> BSB.word8 0x00 -- marker + <> BSB.word8 0x01 -- flag + <> put_compact (fromIntegral (NE.length tx_inputs)) + <> foldMap put_txin tx_inputs + <> put_compact (fromIntegral (NE.length tx_outputs)) + <> foldMap put_txout tx_outputs + <> foldMap put_witness tx_witnesses + <> put_word32_le tx_locktime + +-- | 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 segwit tx, strips witnesses +-- BS.length (to_bytes_legacy segwitTx) < BS.length (to_bytes segwitTx) +-- @ +to_bytes_legacy :: Tx -> BS.ByteString +to_bytes_legacy Tx {..} = to_strict $ + put_word32_le tx_version + <> put_compact (fromIntegral (NE.length tx_inputs)) + <> foldMap put_txin tx_inputs + <> put_compact (fromIntegral (NE.length tx_outputs)) + <> foldMap put_txout tx_outputs + <> put_word32_le tx_locktime + +-- | Serialise a transaction to base16 (hex). +-- +-- @ +-- to_base16 tx = B16.encode (to_bytes tx) +-- @ +to_base16 :: Tx -> BS.ByteString +to_base16 tx = B16.encode (to_bytes tx) + +-- | Parse a transaction from base16 (hex). +-- +-- @ +-- -- round-trip +-- from_base16 (to_base16 tx) == Just tx +-- @ +from_base16 :: BS.ByteString -> Maybe Tx +from_base16 b16 = do + 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 -------------------------------------------------------------------- + +-- | Parse a transaction from bytes. +-- +-- Automatically detects segwit vs legacy format by checking for +-- marker byte 0x00 followed by flag 0x01 after the version field. +-- +-- Returns 'Nothing' on invalid or truncated input. +-- +-- @ +-- -- round-trip +-- from_bytes (to_bytes tx) == Just tx +-- @ +from_bytes :: BS.ByteString -> Maybe Tx +from_bytes !bs = do + -- need at least 4 bytes for version + guard (BS.length bs >= 4) + let !version = get_word32_le bs 0 + !off0 = 4 + -- check for segwit marker (0x00) and flag (0x01) + if BS.length bs > off0 + 1 + && BS.index bs off0 == 0x00 + && BS.index bs (off0 + 1) == 0x01 + then parse_segwit bs version (off0 + 2) + else parse_legacy bs version off0 + +-- Parse legacy transaction (no witness data) +parse_legacy :: BS.ByteString -> Word32 -> Int -> Maybe Tx +parse_legacy !bs !version !off0 = do + -- 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 <- 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 <- NE.nonEmpty outputs_list + -- locktime (4 bytes) + guard (BS.length bs >= off4 + 4) + let !locktime = get_word32_le bs off4 + !off5 = off4 + 4 + -- should have consumed all bytes + guard (off5 == BS.length bs) + pure $! Tx version inputs outputs [] locktime + +-- Parse segwit transaction (with witness data) +parse_segwit :: BS.ByteString -> Word32 -> Int -> Maybe Tx +parse_segwit !bs !version !off0 = do + -- 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 <- 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 <- NE.nonEmpty outputs_list + -- witnesses (one per input) + (witnesses, off5) <- get_many get_witness bs off4 (fromIntegral input_count) + -- 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 + +-- internal helpers ------------------------------------------------------------ + +-- | Guard for Maybe monad. +guard :: Bool -> Maybe () +guard True = Just () +guard False = Nothing +{-# INLINE guard #-} + +-- | Decode a 32-bit little-endian word at the given offset. +-- Does not bounds-check; caller must ensure sufficient bytes. +get_word32_le :: BS.ByteString -> Int -> Word32 +get_word32_le !bs !off = + let !b0 = fromIntegral (BS.index bs off) :: Word32 + !b1 = fromIntegral (BS.index bs (off + 1)) :: Word32 + !b2 = fromIntegral (BS.index bs (off + 2)) :: Word32 + !b3 = fromIntegral (BS.index bs (off + 3)) :: Word32 + in b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) +{-# INLINE get_word32_le #-} + +-- | Decode a 64-bit little-endian word at the given offset. +-- Does not bounds-check; caller must ensure sufficient bytes. +get_word64_le :: BS.ByteString -> Int -> Word64 +get_word64_le !bs !off = + let !b0 = fromIntegral (BS.index bs off) :: Word64 + !b1 = fromIntegral (BS.index bs (off + 1)) :: Word64 + !b2 = fromIntegral (BS.index bs (off + 2)) :: Word64 + !b3 = fromIntegral (BS.index bs (off + 3)) :: Word64 + !b4 = fromIntegral (BS.index bs (off + 4)) :: Word64 + !b5 = fromIntegral (BS.index bs (off + 5)) :: Word64 + !b6 = fromIntegral (BS.index bs (off + 6)) :: Word64 + !b7 = fromIntegral (BS.index bs (off + 7)) :: Word64 + in b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) + .|. (b4 `shiftL` 32) .|. (b5 `shiftL` 40) + .|. (b6 `shiftL` 48) .|. (b7 `shiftL` 56) +{-# INLINE get_word64_le #-} + +-- | Decode a 16-bit little-endian word at the given offset. +-- Does not bounds-check; caller must ensure sufficient bytes. +get_word16_le :: BS.ByteString -> Int -> Word64 +get_word16_le !bs !off = + let !b0 = fromIntegral (BS.index bs off) :: Word64 + !b1 = fromIntegral (BS.index bs (off + 1)) :: Word64 + in b0 .|. (b1 `shiftL` 8) +{-# INLINE get_word16_le #-} + +-- | Decode compactSize (Bitcoin's variable-length integer). +-- Returns (value, new_offset). +-- Enforces minimal encoding: rejects non-minimal representations. +get_compact :: BS.ByteString -> Int -> Maybe (Word64, Int) +get_compact !bs !off + | off >= BS.length bs = Nothing + | otherwise = case BS.index bs off of + tag | tag <= 0xfc -> + -- Single byte: value is the tag itself + Just (fromIntegral tag, off + 1) + + 0xfd -> + -- 2-byte value follows + if BS.length bs < off + 3 + then Nothing + else + let !val = get_word16_le bs (off + 1) + in if val < 0xfd + then Nothing -- non-minimal encoding + else Just (val, off + 3) + + 0xfe -> + -- 4-byte value follows + if BS.length bs < off + 5 + then Nothing + else + let !val = fromIntegral (get_word32_le bs (off + 1)) :: Word64 + in if val <= 0xffff + then Nothing -- non-minimal encoding + else Just (val, off + 5) + + _ -> -- 0xff + -- 8-byte value follows + if BS.length bs < off + 9 + then Nothing + else + let !val = get_word64_le bs (off + 1) + in if val <= 0xffffffff + then Nothing -- non-minimal encoding + else Just (val, off + 9) +{-# INLINE get_compact #-} + +-- | Decode an outpoint (txid + vout). +-- Returns (OutPoint, new_offset). +get_outpoint :: BS.ByteString -> Int -> Maybe (OutPoint, Int) +get_outpoint !bs !off + | BS.length bs < off + 36 = Nothing + | otherwise = + let !txid_bytes = BS.take 32 (BS.drop off bs) + !vout = get_word32_le bs (off + 32) + in Just (OutPoint (TxId txid_bytes) vout, off + 36) +{-# INLINE get_outpoint #-} + +-- | Decode a transaction input. +-- Returns (TxIn, new_offset). +get_txin :: BS.ByteString -> Int -> Maybe (TxIn, Int) +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 + -- 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) + +-- | Decode a transaction output. +-- Returns (TxOut, new_offset). +get_txout :: BS.ByteString -> Int -> Maybe (TxOut, Int) +get_txout !bs !off0 = do + -- value: 8 bytes + 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) + +-- | Decode a witness stack for one input. +-- Returns (Witness, new_offset). +get_witness :: BS.ByteString -> Int -> Maybe (Witness, Int) +get_witness !bs !off0 = do + -- 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) + 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 multiple 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 [] + where + go !acc !off !n + | n <= 0 = Just (reverse acc, off) + | otherwise = do + (item, off') <- getter bs off + go (item : acc) off' (n - 1) +{-# INLINE get_many #-} + +-- 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. +-- +-- @ +-- -- Satoshi->Hal tx (block 170) +-- txid satoshiHalTx == +-- TxId "f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16" +-- @ +txid :: Tx -> TxId +txid tx = TxId (SHA256.hash (SHA256.hash (to_bytes_legacy tx))) diff --git a/lib/Bitcoin/Prim/Tx/Sighash.hs b/lib/Bitcoin/Prim/Tx/Sighash.hs new file mode 100644 --- /dev/null +++ b/lib/Bitcoin/Prim/Tx/Sighash.hs @@ -0,0 +1,306 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: Bitcoin.Prim.Tx.Sighash +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Sighash computation for legacy and BIP143 segwit transactions. + +module Bitcoin.Prim.Tx.Sighash ( + -- * Sighash Types + SighashType(..) + + -- * Legacy Sighash + , sighash_legacy + + -- * BIP143 Segwit Sighash + , sighash_segwit + ) where + +import Bitcoin.Prim.Tx + ( Tx(..) + , TxIn(..) + , TxOut(..) + , put_word32_le + , put_word64_le + , put_compact + , put_outpoint + , put_txout + , to_strict + ) +import qualified Crypto.Hash.SHA256 as SHA256 +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 GHC.Generics (Generic) + +-- | Sighash type flags. +data SighashType + = SIGHASH_ALL + | SIGHASH_NONE + | SIGHASH_SINGLE + | SIGHASH_ALL_ANYONECANPAY + | SIGHASH_NONE_ANYONECANPAY + | 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 + SIGHASH_ALL_ANYONECANPAY -> 0x81 + SIGHASH_NONE_ANYONECANPAY -> 0x82 + SIGHASH_SINGLE_ANYONECANPAY -> 0x83 +{-# INLINE sighash_byte #-} + +-- | 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 #-} + +-- | 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 +{-# INLINE base_type #-} + +-- | 32 zero bytes. +zero32 :: BS.ByteString +zero32 = BS.replicate 32 0x00 +{-# NOINLINE zero32 #-} + +-- | Hash of 0x01 followed by 31 zero bytes (SIGHASH_SINGLE edge case). +sighash_single_bug :: BS.ByteString +sighash_single_bug = BS.cons 0x01 (BS.replicate 31 0x00) +{-# NOINLINE sighash_single_bug #-} + +-- | Double SHA256. +hash256 :: BS.ByteString -> BS.ByteString +hash256 = SHA256.hash . SHA256.hash +{-# INLINE hash256 #-} + +-- 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. +-- +-- @ +-- -- sign input 0 with SIGHASH_ALL +-- let hash = sighash_legacy tx 0 scriptPubKey SIGHASH_ALL +-- -- use hash with ECDSA signing +-- @ +-- +-- For SIGHASH_SINGLE with input index >= output count, returns the +-- special \"sighash single bug\" value (0x01 followed by 31 zero bytes). +sighash_legacy + :: Tx + -> Int -- ^ input index + -> BS.ByteString -- ^ scriptPubKey being spent + -> SighashType + -> BS.ByteString -- ^ 32-byte hash +sighash_legacy !tx !idx !script_pubkey !sighash_type + -- SIGHASH_SINGLE edge case: index >= number of outputs + | base == SIGHASH_SINGLE && idx >= NE.length (tx_outputs tx) = + sighash_single_bug + | otherwise = + let !serialized = serialize_legacy_sighash tx idx script_pubkey sighash_type + in hash256 serialized + where + !base = base_type sighash_type + +-- | Serialize transaction for legacy sighash computation. +-- Handles all sighash flags directly without constructing intermediate Tx. +serialize_legacy_sighash + :: Tx + -> Int + -> BS.ByteString + -> SighashType + -> BS.ByteString +serialize_legacy_sighash Tx{..} !idx !script_pubkey !sighash_type = + let !base = base_type sighash_type + !anyonecanpay = is_anyonecanpay sighash_type + !inputs_list = NE.toList tx_inputs + !outputs_list = NE.toList tx_outputs + + -- Clear all scriptSigs, set signing input's script to scriptPubKey + clear_scripts :: Int -> [TxIn] -> [TxIn] + clear_scripts !_ [] = [] + clear_scripts !i (inp : rest) + | i == idx = inp { txin_script_sig = script_pubkey } : clear_rest + | otherwise = inp { txin_script_sig = BS.empty } : clear_rest + where + !clear_rest = clear_scripts (i + 1) rest + + -- For NONE/SINGLE: zero out sequence numbers for other inputs + zero_other_sequences :: Int -> [TxIn] -> [TxIn] + zero_other_sequences !_ [] = [] + zero_other_sequences !i (inp : rest) + | i == idx = inp : zero_other_sequences (i + 1) rest + | otherwise = + inp { txin_sequence = 0 } : zero_other_sequences (i + 1) rest + + -- Process inputs based on sighash type + !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 + + -- ANYONECANPAY: keep only signing input + !final_inputs + | anyonecanpay = case safe_index inputs_processed idx of + Just inp -> [inp] + Nothing -> [] -- shouldn't happen if idx is valid + | otherwise = inputs_processed + + -- Process outputs based on sighash type + !final_outputs = case base of + SIGHASH_NONE -> [] + SIGHASH_SINGLE -> 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 + <> put_compact (fromIntegral (length final_outputs)) + <> foldMap put_txout final_outputs + <> put_word32_le tx_locktime + <> put_word32_le (fromIntegral (sighash_byte sighash_type)) + +-- | Build outputs for SIGHASH_SINGLE: keep only output at idx, +-- replace earlier outputs with empty/zero outputs. +build_single_outputs :: [TxOut] -> Int -> [TxOut] +build_single_outputs !outs !target_idx = go 0 outs + where + go :: Int -> [TxOut] -> [TxOut] + go !_ [] = [] + go !i (o : rest) + | i == target_idx = [o] -- keep this one and stop + | i < target_idx = empty_output : go (i + 1) rest + | otherwise = [] -- shouldn't reach here + + -- Empty output: -1 (0xffffffffffffffff) value, empty script + empty_output :: TxOut + empty_output = TxOut 0xffffffffffffffff BS.empty + +-- | Safe list indexing. +safe_index :: [a] -> Int -> Maybe a +safe_index [] _ = Nothing +safe_index (x : xs) !n + | n < 0 = Nothing + | n == 0 = Just x + | 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 ------------------------------------------------------- + +-- | 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. +-- +-- 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 +-- -- use hash with ECDSA signing (after checking Just) +-- @ +sighash_segwit + :: Tx + -> Int -- ^ input index + -> BS.ByteString -- ^ scriptCode + -> Word64 -- ^ value being spent (satoshis) + -> SighashType + -> 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 + pure $! hash256 preimage + +-- | Build BIP143 preimage for signing. +-- Returns Nothing if the input index is out of range. +build_bip143_preimage + :: Tx + -> Int + -> BS.ByteString + -> Word64 + -> SighashType + -> Maybe BS.ByteString +build_bip143_preimage Tx{..} !idx !script_code !value !sighash_type = 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 + + -- hashPrevouts: double SHA256 of all outpoints, or zero if ANYONECANPAY + !hash_prevouts + | anyonecanpay = zero32 + | otherwise = hash256 $ to_strict $ + foldMap (put_outpoint . txin_prevout) tx_inputs + + -- 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 + | 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 -> + case safe_index outputs_list idx of + Nothing -> zero32 -- index out of range + Just out -> hash256 $ to_strict $ put_txout out + _ -> hash256 $ to_strict $ foldMap put_txout tx_outputs + + !outpoint = txin_prevout signing_input + !sequence_n = txin_sequence signing_input + + pure $! to_strict $ + put_word32_le tx_version + <> BSB.byteString hash_prevouts + <> BSB.byteString hash_sequence + <> put_outpoint outpoint + <> put_compact (fromIntegral (BS.length script_code)) + <> BSB.byteString script_code + <> put_word64_le value + <> put_word32_le sequence_n + <> BSB.byteString hash_outputs + <> put_word32_le tx_locktime + <> put_word32_le (fromIntegral (sighash_byte sighash_type)) diff --git a/ppad-tx.cabal b/ppad-tx.cabal new file mode 100644 --- /dev/null +++ b/ppad-tx.cabal @@ -0,0 +1,92 @@ +cabal-version: 3.0 +name: ppad-tx +version: 0.1.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 +extra-doc-files: CHANGELOG +description: + Minimal Bitcoin transaction primitives for ppad libraries, including + raw transaction types, serialisation, txid computation, and sighash + calculation. + +flag llvm + description: Use GHC's LLVM backend. + default: False + manual: True + +source-repository head + type: git + location: git.ppad.tech/tx.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + if flag(llvm) + ghc-options: -fllvm -O2 + exposed-modules: + Bitcoin.Prim.Tx + Bitcoin.Prim.Tx.Sighash + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.9 && < 0.13 + , ppad-base16 >= 0.2.1 && < 0.3 + , ppad-sha256 >= 0.3 && < 0.4 + +test-suite tx-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: + -rtsopts -Wall + + build-depends: + base + , bytestring + , ppad-base16 + , ppad-tx + , QuickCheck + , tasty + , tasty-hunit + , tasty-quickcheck + +benchmark tx-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , bytestring + , criterion + , deepseq + , ppad-tx + +benchmark tx-weigh + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Weight.hs + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , bytestring + , deepseq + , ppad-tx + , weigh diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Bitcoin.Prim.Tx +import Bitcoin.Prim.Tx.Sighash +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Word (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 :: IO () +main = defaultMain $ + testGroup "ppad-tx" [ + testGroup "serialisation" [ + testGroup "round-trip" [ + roundtrip_legacy_simple + , roundtrip_segwit + , roundtrip_multi_io + ] + , testGroup "known vectors" [ + parse_satoshi_hal + , parse_first_segwit + ] + ] + , testGroup "txid" [ + txid_satoshi_hal + ] + , testGroup "edge cases" [ + edge_empty_scriptsig + , edge_max_sequence + , edge_zero_locktime + , edge_multi_witness + ] + , testGroup "validation" [ + test_mkTxId_valid + , test_mkTxId_short + , test_mkTxId_long + , test_mkTxId_empty + , test_from_bytes_truncated + , test_from_bytes_trailing + , test_from_bytes_garbage + , test_from_base16_invalid_hex + , test_sighash_segwit_oob + ] + , testGroup "sighash" [ + testGroup "legacy" [ + sighash_legacy_minimal + ] + , testGroup "BIP143 segwit" [ + bip143_native_p2wpkh + , bip143_p2sh_p2wpkh + ] + ] + , testGroup "properties" [ + testGroup "round-trip" [ + prop_roundtrip_bytes + , prop_roundtrip_base16 + ] + , testGroup "serialisation" [ + prop_legacy_no_witnesses + , prop_segwit_longer + ] + , testGroup "txid" [ + prop_txid_32_bytes + , prop_txid_ignores_witnesses + ] + , testGroup "sighash" [ + prop_sighash_legacy_32_bytes + , prop_sighash_segwit_32_bytes + , prop_sighash_single_bug + ] + ] + ] + +-- helpers --------------------------------------------------------------------- + +-- | Decode hex, failing the test on invalid input. +hex :: BS.ByteString -> BS.ByteString +hex h = case B16.decode h of + Just bs -> bs + Nothing -> error "test error: invalid hex literal" + +-- | Assert round-trip: from_bytes (to_bytes tx) == Just tx +assertRoundtrip :: Tx -> H.Assertion +assertRoundtrip tx = + let bs = to_bytes tx + in case from_bytes bs of + Nothing -> H.assertFailure "from_bytes returned Nothing" + Just tx' -> H.assertEqual "round-trip mismatch" tx tx' + +-- | Assert parsing from hex succeeds. +assertParses :: BS.ByteString -> H.Assertion +assertParses rawHex = + case from_base16 rawHex of + Nothing -> H.assertFailure "from_base16 returned Nothing" + Just _ -> pure () + +-- round-trip tests ------------------------------------------------------------ + +-- Simple legacy tx: 1 input, 1 output, no witnesses +roundtrip_legacy_simple :: TestTree +roundtrip_legacy_simple = H.testCase "simple legacy tx" $ + assertRoundtrip legacyTx + where + legacyTx = Tx + { 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_vout = 0 + } + , txin_script_sig = hex "483045022100abcd" + , txin_sequence = 0xffffffff + } + txout = TxOut + { txout_value = 50000 + , txout_script_pubkey = hex "76a91489abcdef" + } + +-- Segwit tx with witnesses +roundtrip_segwit :: TestTree +roundtrip_segwit = H.testCase "segwit tx with witnesses" $ + assertRoundtrip segwitTx + where + segwitTx = Tx + { 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_vout = 1 + } + , txin_script_sig = BS.empty -- segwit: empty scriptSig + , txin_sequence = 0xfffffffe + } + txout = TxOut + { txout_value = 100000000 + , txout_script_pubkey = hex "0014abcdef1234567890" + } + witness = Witness + [ hex "304402201234" + , hex "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" + ] + +-- Multiple inputs and outputs +roundtrip_multi_io :: TestTree +roundtrip_multi_io = H.testCase "multiple inputs/outputs" $ + assertRoundtrip multiTx + where + multiTx = Tx + { 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_vout = 0 + } + , txin_script_sig = hex "4730440220" + , txin_sequence = 0xffffffff + } + txin2 = TxIn + { txin_prevout = OutPoint + { op_txid = TxId (BS.replicate 32 0x22) + , op_vout = 2 + } + , txin_script_sig = hex "483045022100" + , txin_sequence = 0xffffffff + } + txin3 = TxIn + { txin_prevout = OutPoint + { op_txid = TxId (BS.replicate 32 0x33) + , op_vout = 5 + } + , txin_script_sig = hex "00" + , txin_sequence = 0xfffffffe + } + txout1 = TxOut + { txout_value = 10000000 + , txout_script_pubkey = hex "76a914" + } + txout2 = TxOut + { txout_value = 5000000 + , txout_script_pubkey = hex "a914" + } + +-- known vector tests ---------------------------------------------------------- + +-- First Bitcoin transaction ever (block 170, Satoshi to Hal Finney) +-- TxId: f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16 +satoshiHalRaw :: BS.ByteString +satoshiHalRaw = + "0100000001c997a5e56e104102fa209c6a852dd90660a20b2d9c352423edce25857fcd37\ + \04000000004847304402204e45e16932b8af514961a1d3a1a25fdf3f4f7732e9d624c6c6\ + \1548ab5fb8cd410220181522ec8eca07de4860a4acdd12909d831cc56cbbac46220822\ + \21a8768d1d0901ffffffff0200ca9a3b00000000434104ae1a62fe09c5f51b13905f07f0\ + \6b99a2f7159b2225f374cd378d71302fa28414e7aab37397f554a7df5f142c21c1b7303\ + \b8a0626f1baded5c72a704f7e6cd84cac00286bee0000000043410411db93e1dcdb8a01\ + \6b49840f8c53bc1eb68a382e97b1482ecad7b148a6909a5cb2e0eaddfb84ccf9744464f8\ + \2e160bfa9b8b64f9d4c03f999b8643f656b412a3ac00000000" + +satoshiHalTxId :: BS.ByteString +satoshiHalTxId = "f4184fc596403b9d638783cf57adfe4c75c605f6356fbc91338530e9831e9e16" + +parse_satoshi_hal :: TestTree +parse_satoshi_hal = H.testCase "parse Satoshi->Hal tx (block 170)" $ + assertParses satoshiHalRaw + +txid_satoshi_hal :: TestTree +txid_satoshi_hal = H.testCase "txid of Satoshi->Hal tx" $ do + case from_base16 satoshiHalRaw of + Nothing -> H.assertFailure "failed to parse tx" + Just tx -> do + let TxId computed = txid tx + -- txid is displayed big-endian, but stored little-endian + expected = BS.reverse (hex satoshiHalTxId) + H.assertEqual "txid mismatch" expected computed + +-- First segwit tx on mainnet (block 481824) +firstSegwitRaw :: BS.ByteString +firstSegwitRaw = + "0200000000010140d43a99926d43eb0e619bf0b3d83b4a31f60c176beecfb9d35bf45e54\ + \d0f7420100000017160014a4b4ca48de0b3fffc15404a1acdc8dbaae226955ffffffff01\ + \00e1f5050000000017a9144a1154d50b03292b3024370901711946cb7cccc38702483045\ + \0221008604ef8f6d8afa892dee0f31259b6ce02dd70c545cfcfed8148179971f48d59202\ + \20770b9e1e5cf7f8c5d28c48abe49a3a25f1cf9e8a5b0d8f1c8f2f1c2dde88aa370121\ + \03d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210500000000" + +parse_first_segwit :: TestTree +parse_first_segwit = H.testCase "parse first segwit tx (block 481824)" $ + assertParses firstSegwitRaw + +-- edge case tests ------------------------------------------------------------- + +-- Empty scriptSig (common in segwit) +edge_empty_scriptsig :: TestTree +edge_empty_scriptsig = H.testCase "empty scriptSig" $ + assertRoundtrip tx + where + tx = Tx + { 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_vout = 0 + } + , txin_script_sig = BS.empty + , txin_sequence = 0xffffffff + } + txout = TxOut + { txout_value = 1000 + , txout_script_pubkey = hex "0014abcdef" + } + witness = Witness [hex "3044", hex "02"] + +-- Maximum sequence number (0xffffffff) +edge_max_sequence :: TestTree +edge_max_sequence = H.testCase "maximum sequence (0xffffffff)" $ + assertRoundtrip tx + where + tx = Tx + { 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_vout = 0xffffffff -- max vout too + } + , txin_script_sig = hex "00" + , txin_sequence = 0xffffffff + } + txout = TxOut + { txout_value = 0 + , txout_script_pubkey = hex "6a" -- OP_RETURN + } + +-- Zero locktime +edge_zero_locktime :: TestTree +edge_zero_locktime = H.testCase "zero locktime" $ + assertRoundtrip tx + where + tx = Tx + { 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_vout = 0 + } + , txin_script_sig = hex "51" -- OP_1 + , txin_sequence = 0 + } + txout = TxOut + { txout_value = 100 + , txout_script_pubkey = hex "51" + } + +-- Multiple witness items per input +edge_multi_witness :: TestTree +edge_multi_witness = H.testCase "multiple witness items" $ + assertRoundtrip tx + where + tx = Tx + { 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_vout = 0 + } + , txin_script_sig = BS.empty + , txin_sequence = 0xffffffff + } + txin2 = TxIn + { txin_prevout = OutPoint + { op_txid = TxId (BS.replicate 32 0x02) + , op_vout = 1 + } + , txin_script_sig = BS.empty + , txin_sequence = 0xffffffff + } + txout = TxOut + { txout_value = 50000 + , txout_script_pubkey = hex "0014" + } + -- 5 witness items for input 1 + witness1 = Witness + [ BS.empty -- empty item (common in multisig) + , hex "304402201234" + , hex "3045022100abcd" + , hex "522102" + , hex "ae" + ] + -- 2 witness items for input 2 + witness2 = Witness + [ hex "3044" + , hex "03" + ] + +-- 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" + Just _ -> pure () + +-- mkTxId: 31 bytes rejected +test_mkTxId_short :: TestTree +test_mkTxId_short = H.testCase "mkTxId rejects 31 bytes" $ + H.assertEqual "should be Nothing" + Nothing (mkTxId (BS.replicate 31 0x00)) + +-- mkTxId: 33 bytes rejected +test_mkTxId_long :: TestTree +test_mkTxId_long = H.testCase "mkTxId rejects 33 bytes" $ + H.assertEqual "should be Nothing" + Nothing (mkTxId (BS.replicate 33 0x00)) + +-- mkTxId: empty input rejected +test_mkTxId_empty :: TestTree +test_mkTxId_empty = H.testCase "mkTxId rejects empty" $ + H.assertEqual "should be Nothing" + Nothing (mkTxId BS.empty) + +-- from_bytes: truncated input rejected +test_from_bytes_truncated :: TestTree +test_from_bytes_truncated = + H.testCase "from_bytes rejects truncated input" $ do + let full = to_bytes legacyTx1 + truncated = BS.take (BS.length full - 1) full + H.assertEqual "should be Nothing" + Nothing (from_bytes truncated) + +-- from_bytes: trailing bytes rejected +test_from_bytes_trailing :: TestTree +test_from_bytes_trailing = + H.testCase "from_bytes rejects trailing bytes" $ do + let full = to_bytes legacyTx1 + padded = full <> BS.singleton 0x00 + H.assertEqual "should be Nothing" + Nothing (from_bytes padded) + +-- from_bytes: garbage rejected +test_from_bytes_garbage :: TestTree +test_from_bytes_garbage = + H.testCase "from_bytes rejects garbage" $ + H.assertEqual "should be Nothing" + Nothing (from_bytes (BS.pack [0xde, 0xad])) + +-- from_base16: invalid hex rejected +test_from_base16_invalid_hex :: TestTree +test_from_base16_invalid_hex = + H.testCase "from_base16 rejects invalid hex" $ + H.assertEqual "should be Nothing" + Nothing (from_base16 "not valid hex!!!") + +-- sighash_segwit: out-of-range index returns Nothing +test_sighash_segwit_oob :: TestTree +test_sighash_segwit_oob = + H.testCase "sighash_segwit rejects out-of-range index" $ do + let rawTx = hex $ mconcat + [ "0100000002fff7f7881a8099afa6940d42d1e7f6362bec" + , "38171ea3edf433541db4e4ad969f0000000000eeffffff" + , "ef51e1b804cc89d182d279655c3aa89e815b1b309fe287" + , "d9b2b55d57b90ec68a0100000000ffffffff02202cb206" + , "000000001976a9148280b37df378db99f66f85c95a783a" + , "76ac7a6d5988ac9093510d000000001976a9143bde42db" + , "ee7e4dbe6a21b2d50ce2f0167faa815988ac11000000" + ] + case from_bytes rawTx of + Nothing -> H.assertFailure "failed to parse tx" + Just tx -> + H.assertEqual "should be Nothing" + Nothing + (sighash_segwit tx 99 "script" 0 SIGHASH_ALL) + +-- | A minimal legacy tx used by validation tests. +legacyTx1 :: Tx +legacyTx1 = Tx + { 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_vout = 0 + } + , txin_script_sig = hex "00" + , txin_sequence = 0xffffffff + } + txout = TxOut + { txout_value = 0 + , txout_script_pubkey = hex "6a" + } + +-- legacy sighash vectors ---------------------------------------------------- + +-- Minimal tx: 1-in/1-out, signing input 0, SIGHASH_ALL, +-- scriptPubKey = OP_1 (0x51) +sighash_legacy_minimal :: TestTree +sighash_legacy_minimal = + H.testCase "minimal tx SIGHASH_ALL" $ do + let tx = Tx + { 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_vout = 0 + } + , txin_script_sig = hex "00" + , txin_sequence = 0xffffffff + } + txout = TxOut + { txout_value = 0 + , txout_script_pubkey = hex "6a" + } + script_pubkey = hex "51" + expected = hex + "049b7618cbda49a0190c5eea6f97320b\ + \930aa32b64be6e71ed20041067685c45" + result = sighash_legacy tx 0 script_pubkey SIGHASH_ALL + H.assertEqual "sighash mismatch" expected result + +-- BIP143 sighash vectors ----------------------------------------------------- + +-- Native P2WPKH (BIP143 example) +-- https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki +bip143_native_p2wpkh :: TestTree +bip143_native_p2wpkh = H.testCase "native P2WPKH" $ do + let rawTx = hex $ mconcat + [ "0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf43354" + , "1db4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e" + , "815b1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600" + , "0000001976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093" + , "510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988" + , "ac11000000" + ] + case from_bytes rawTx of + Nothing -> H.assertFailure "failed to parse BIP143 tx" + Just tx -> do + let inputIdx = 1 + -- scriptCode for P2WPKH (without length prefix) + scriptCode = hex + "76a9141d0f172a0ecb48aee1be1f2687d2963ae33f71a188ac" + value = 600000000 :: Word64 + expected = hex + "c37af31116d1b27caf68aae9e3ac82f1477929014d5b917657d0eb49478cb670" + case sighash_segwit tx inputIdx scriptCode value SIGHASH_ALL of + Nothing -> H.assertFailure "sighash_segwit returned Nothing" + Just result -> H.assertEqual "sighash mismatch" expected result + +-- P2SH-P2WPKH (BIP143 example) +bip143_p2sh_p2wpkh :: TestTree +bip143_p2sh_p2wpkh = H.testCase "P2SH-P2WPKH" $ do + let rawTx = hex $ mconcat + [ "0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac" + , "4d3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b6" + , "84d7f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914" + , "fd270b1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000" + ] + case from_bytes rawTx of + Nothing -> H.assertFailure "failed to parse BIP143 tx" + Just tx -> do + let inputIdx = 0 + -- scriptCode without length prefix + scriptCode = hex + "76a91479091972186c449eb1ded22b78e40d009bdf008988ac" + value = 1000000000 :: Word64 + expected = hex + "64f3b0f4dd2bb3aa1ce8566d220cc74dda9df97d8490cc81d89d735c92e59fb6" + case sighash_segwit tx inputIdx scriptCode value 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 + +instance Arbitrary OutPoint where + arbitrary = OutPoint <$> arbitrary <*> arbitrary + +instance Arbitrary TxIn where + arbitrary = TxIn + <$> arbitrary + <*> arbitraryScript + <*> arbitrary + +instance Arbitrary TxOut where + arbitrary = TxOut + <$> arbitrary + <*> arbitraryScript + +instance Arbitrary Witness where + arbitrary = Witness <$> listOf arbitraryScript + +instance Arbitrary SighashType where + arbitrary = elements + [ SIGHASH_ALL + , SIGHASH_NONE + , SIGHASH_SINGLE + , SIGHASH_ALL_ANYONECANPAY + , SIGHASH_NONE_ANYONECANPAY + , SIGHASH_SINGLE_ANYONECANPAY + ] + +-- | Generate arbitrary script-like bytestrings (0-200 bytes). +arbitraryScript :: Gen BS.ByteString +arbitraryScript = do + len <- chooseInt (0, 200) + BS.pack <$> vectorOf len arbitrary + +-- | Generate a NonEmpty list of 1-5 items. +arbitraryNonEmpty :: Arbitrary a => Gen (NonEmpty a) +arbitraryNonEmpty = do + x <- arbitrary + xs <- listOf1to4 + pure (x :| xs) + where + listOf1to4 = do + n <- chooseInt (0, 4) + vectorOf n arbitrary + +-- | Generate a valid legacy transaction (no witnesses). +genLegacyTx :: Gen Tx +genLegacyTx = do + ver <- arbitrary + ins <- arbitraryNonEmpty + outs <- arbitraryNonEmpty + lt <- arbitrary + pure $ Tx ver ins outs [] lt + +-- | Generate a valid segwit transaction (with witnesses). +genSegwitTx :: Gen Tx +genSegwitTx = do + ver <- arbitrary + ins <- arbitraryNonEmpty + outs <- arbitraryNonEmpty + -- One witness per input + let numInputs = NE.length ins + wits <- vectorOf numInputs arbitrary + lt <- arbitrary + pure $ Tx ver ins outs wits lt + +-- | Generate any valid transaction. +instance Arbitrary Tx where + arbitrary = oneof [genLegacyTx, genSegwitTx] + +-- property tests ------------------------------------------------------------- + +-- Round-trip: from_bytes (to_bytes tx) == Just tx +prop_roundtrip_bytes :: TestTree +prop_roundtrip_bytes = QC.testProperty "from_bytes . to_bytes == Just" $ + \tx -> from_bytes (to_bytes tx) === Just (tx :: Tx) + +-- Round-trip: from_base16 (to_base16 tx) == Just tx +prop_roundtrip_base16 :: TestTree +prop_roundtrip_base16 = QC.testProperty "from_base16 . to_base16 == Just" $ + \tx -> from_base16 (to_base16 tx) === Just (tx :: Tx) + +-- Legacy tx (no witnesses): to_bytes == to_bytes_legacy +prop_legacy_no_witnesses :: TestTree +prop_legacy_no_witnesses = + QC.testProperty "legacy tx: to_bytes == to_bytes_legacy" $ + forAll genLegacyTx $ \tx -> + to_bytes tx === to_bytes_legacy tx + +-- Segwit tx: to_bytes is longer than to_bytes_legacy (when witnesses present) +prop_segwit_longer :: TestTree +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) + +-- 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 + +-- 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 = [] } + in txid tx === txid txNoWit + +-- sighash_legacy always returns 32 bytes +prop_sighash_legacy_32_bytes :: TestTree +prop_sighash_legacy_32_bytes = + QC.testProperty "sighash_legacy is always 32 bytes" $ + forAll genLegacyTx $ \tx -> + forAll arbitraryScript $ \spk -> + forAll arbitrary $ \st -> + BS.length (sighash_legacy tx 0 spk st) === 32 + +-- sighash_segwit returns Just 32 bytes for 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 + +-- SIGHASH_SINGLE bug: returns 0x01 ++ 0x00*31 when index >= outputs +prop_sighash_single_bug :: TestTree +prop_sighash_single_bug = + QC.testProperty "SIGHASH_SINGLE bug when index >= outputs" $ + forAll genLegacyTx $ \tx -> + 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