ppad-tx-0.2.0: lib/Bitcoin/Prim/Tx/Sighash.hs
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Module: Bitcoin.Prim.Tx.Sighash
-- Copyright: (c) 2025 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- 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.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, Word32, Word64)
import GHC.Generics (Generic)
-- | 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
| SIGHASH_SINGLE
| SIGHASH_ALL_ANYONECANPAY
| SIGHASH_NONE_ANYONECANPAY
| SIGHASH_SINGLE_ANYONECANPAY
deriving (Eq, Show, Generic)
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 encode_sighash #-}
-- | Internal base sighash classification derived from a 32-bit hashType.
data BaseType = BaseAll | BaseNone | BaseSingle
deriving Eq
-- | 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
{-# 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 #-}
-- | 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 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 (encode_sighash SIGHASH_ALL)
-- -- non-canonical hashType (consensus-valid, committed raw)
-- let hash = sighash_legacy tx 0 scriptPubKey 0x6f29291f
-- @
--
-- 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
-> Word32 -- ^ hashType
-> BS.ByteString -- ^ 32-byte hash
sighash_legacy !tx !idx !script_pubkey !ht
-- SIGHASH_SINGLE edge case: index >= number of outputs
| base == BaseSingle && idx >= NE.length (tx_outputs tx) =
sighash_single_bug
| otherwise =
let !serialized = serialize_legacy_sighash tx idx script_pubkey ht
in hash256 serialized
where
!base = base_type ht
-- | Serialize transaction for legacy sighash computation.
-- Handles all sighash flags directly without constructing intermediate Tx.
serialize_legacy_sighash
:: Tx
-> Int
-> BS.ByteString
-> Word32
-> BS.ByteString
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
-- 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' } : 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
BaseNone -> zero_other_sequences 0 inputs_cleared
BaseSingle -> 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
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 final_inputs
<> put_compact (fromIntegral (length final_outputs))
<> foldMap put_txout final_outputs
<> put_word32_le tx_locktime
<> put_word32_le ht
-- | 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 #-}
-- 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. 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
-- (encode_sighash SIGHASH_ALL)
-- -- use hash with ECDSA signing (after checking Just)
-- @
sighash_segwit
:: Tx
-> Int -- ^ input index
-> BS.ByteString -- ^ scriptCode
-> Word64 -- ^ value being spent (satoshis)
-> Word32 -- ^ hashType
-> Maybe BS.ByteString -- ^ 32-byte hash, or Nothing if index invalid
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.
-- Returns Nothing if the input index is out of range.
build_bip143_preimage
:: Tx
-> Int
-> BS.ByteString
-> Word64
-> Word32
-> Maybe BS.ByteString
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 ht
!anyonecanpay = is_anyonecanpay ht
-- 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 == 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
BaseNone -> zero32
BaseSingle ->
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 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