diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,46 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [Unreleased] + +## [1.6.2] - 2026-11-12 + +### Added + +- `judgeInputs` says of each input of a transaction whether its + signature verifies, is forged, or cannot be told without running a + script (`InputVerdict`). `verifyStdTx` answers no both for a forged + signature and for a script it does not read; to refuse a transaction + before sending it, the two have to be told apart. "Forged" is said only + of a coin locked to one key, spent with the items such a coin takes and + a hash type of all. +- `verifyCashSchnorr` verifies a Schnorr signature of Bitcoin Cash, which + is not the one of BIP 340 and has no function in libsecp256k1. It is + held to the test vectors of Bitcoin Cash Node. +- `splitTokenPrefix` takes the token prefix off the script of an output of + Bitcoin Cash, and `txSigHashCashToken` is the digest of a coin that holds + tokens. `judgeInputs` uses both, and reads Schnorr signatures, so it + verifies inputs on Bitcoin Cash that `verifyStdInput` does not. The + tests hold it to two transactions signed by Bitcoin Cash Node 29.2.0, + one of them spending tokens. +- `judgeInputs` verifies a multisig of Bitcoin Cash signed with Schnorr + signatures, where a field of bits in place of the empty first item says + which keys signed, as `OP_CHECKMULTISIG` of Bitcoin Cash Node reads it. +- `verifyStdInput`, `verifyStdTx` and `judgeInputs` verify the multisig + of Taproot: a script path whose leaf is `multi_a` of the output + descriptors, with `OP_CHECKSIGADD`. + +### Changed + +- `stack.yaml` builds against secp256k1-haskell 2.0.1. The README's Stack + example names that version and the current haskoin-core release. The + package and its bounds are unchanged. +- The README shows a badge with the status of CI on `master`. +- The Nix CI job deletes Stack's cached Setup programs before building. One + restored from an older nixos-unstable cache was linked against Nix store + paths missing on the runner, and the build failed with "posix_spawnp: does + not exist". + ## [1.6.1] - 2026-11-06 ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ # Haskoin Core +[![CI](https://github.com/jprupp/haskoin-core/actions/workflows/ci.yml/badge.svg)](https://github.com/jprupp/haskoin-core/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/haskoin-core.svg)](https://hackage.haskell.org/package/haskoin-core) [![License: MIT](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/jprupp/haskoin-core/blob/master/LICENSE) @@ -54,8 +55,11 @@ - **A script interpreter.** `verifyStdTx` recognises the standard templates. It is not a consensus check. - **Signet, output descriptors, Miniscript and MuSig2.** -- **Schnorr transaction signatures, `SIGHASH_UTXOS` and token outputs of Bitcoin - Cash.** An input or an output that uses them does not decode or verify. +- **Signing with Schnorr signatures, `SIGHASH_UTXOS` and token outputs of + Bitcoin Cash.** `judgeInputs` verifies a Schnorr signature, of one key + or in a multisig, and the spend of a coin that holds tokens. + Nothing here signs them, `verifyStdTx` does not read them, and an + output with tokens has no address. - **BIP-324 encrypted transport.** - **BIP-39 word lists other than English.** @@ -111,9 +115,9 @@ ```yaml resolver: nightly-2026-10-28 extra-deps: - - haskoin-core-1.6.0 + - haskoin-core-1.6.2 - base16-2.0 - - secp256k1-haskell-2.0.0 + - secp256k1-haskell-2.0.1 ``` ## Quick start diff --git a/haskoin-core.cabal b/haskoin-core.cabal --- a/haskoin-core.cabal +++ b/haskoin-core.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-core -version: 1.6.1 +version: 1.6.2 synopsis: Bitcoin & Bitcoin Cash library for Haskell description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -174,6 +174,7 @@ Haskoin.ScriptSpec Haskoin.Transaction.PsbtSpec Haskoin.Transaction.TaprootSpec + Haskoin.Transaction.VerdictSpec Haskoin.TransactionSpec Haskoin.UtilSpec Paths_haskoin_core diff --git a/src/Haskoin/Crypto/Signature.hs b/src/Haskoin/Crypto/Signature.hs --- a/src/Haskoin/Crypto/Signature.hs +++ b/src/Haskoin/Crypto/Signature.hs @@ -22,6 +22,9 @@ isCanonicalHalfOrder, decodeStrictSig, exportSig, + + -- * Schnorr signatures of Bitcoin Cash + verifyCashSchnorr, ) where @@ -31,11 +34,12 @@ import Data.Aeson.Encoding import Data.Binary (Binary (..)) import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as L import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.Serialize (Serialize (..)) import Haskoin.Crypto.Hash import Haskoin.Util.Helpers @@ -109,3 +113,56 @@ -- block chain. Use 'isCanonicalHalfOrder' for the low-S relay rule. decodeStrictSig :: Ctx -> ByteString -> Maybe Sig decodeStrictSig = importSig + +-- | Verify a Schnorr signature of Bitcoin Cash: 64 bytes, @r@ then @s@, +-- of a public key over a 32-byte digest. +-- +-- Bitcoin Cash has had these in @OP_CHECKSIG@ since May 2019, where a +-- signature of 64 bytes and the hash type byte is one, and most of its +-- wallets make them. They are not the Schnorr signatures of BIP 340, +-- which Taproot uses: the key is a full public key and not its x +-- coordinate, the challenge is a plain SHA-256 of @r@, the compressed +-- key and the digest, and @R@ is told from its negation by its y +-- coordinate being a square. libsecp256k1 has no function for them, so +-- this builds the check out of the operations it has on points: +-- +-- > e = SHA-256(r || compressed P || m) mod n +-- > R = s*G - e*P +-- > valid when R is not at infinity, x(R) = r, and y(R) is a square mod p +-- +-- This is the check of @secp256k1_schnorr_sig_verify@ in Bitcoin Cash +-- Node, and the tests hold it to the test vectors of that code. It only +-- verifies: nothing here is secret, so it is not written to run in +-- constant time. +verifyCashSchnorr :: Ctx -> PubKey -> ByteString -> Hash256 -> Bool +verifyCashSchnorr ctx pub sig h + | BS.length sig /= 64 = False + | r >= fieldP || s >= orderN = False + | otherwise = case combined of + Nothing -> False + Just point -> + let (x, y) = BS.splitAt 32 (BS.drop 1 (exportPubKey ctx False point)) + in bsToInteger x == r && isSquare (bsToInteger y) + where + (rBytes, sBytes) = BS.splitAt 32 sig + r = bsToInteger rBytes + s = bsToInteger sBytes + digest = runPutS (serialize h) + e = bsToInteger (runPutS (serialize (sha256 (rBytes <> exportPubKey ctx True pub <> digest)))) `mod` orderN + -- s*G, when s is not zero + sG = derivePubKey ctx <$> secKey (word256 s) + -- -e*P, when e is not zero + eP = tweak (word256 ((orderN - e) `mod` orderN)) >>= tweakMulPubKey ctx pub + -- their sum, which is nothing when it is the point at infinity + combined = case catMaybes [sG, eP] of + [] -> Nothing + points -> combinePubKeys ctx points + -- Euler's criterion + isSquare y = powMod y ((fieldP - 1) `div` 2) fieldP == 1 + word256 n = let b = integerToBS n in BS.replicate (32 - BS.length b) 0 <> b + fieldP = 2 ^ (256 :: Int) - 2 ^ (32 :: Int) - 977 :: Integer + orderN = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 :: Integer + powMod _ 0 _ = 1 + powMod b k m + | even k = let half = powMod b (k `div` 2) m in half * half `mod` m + | otherwise = b * powMod b (k - 1) m `mod` m diff --git a/src/Haskoin/Script/SigHash.hs b/src/Haskoin/Script/SigHash.hs --- a/src/Haskoin/Script/SigHash.hs +++ b/src/Haskoin/Script/SigHash.hs @@ -41,6 +41,8 @@ sigHashAddNetworkId, txSigHash, txSigHashForkId, + txSigHashCashToken, + splitTokenPrefix, TxSignature (..), decodeTxSig, encodeTxSig, @@ -356,12 +358,15 @@ -- digest. 'isSigHashUnknown' treats the bit as undefined, so 'decodeTxSig' -- refuses such a signature. -- --- * Coins that hold tokens. Their digest also covers the token data, and --- their output script starts with the prefix byte 0xef, which --- 'Haskoin.Script.Standard.decodeOutput' does not read. A signature made --- here for such a coin is not valid. +-- * Coins that hold tokens, in this function. Their digest also covers the +-- token data, and their output script starts with the prefix byte 0xef, +-- which 'Haskoin.Script.Standard.decodeOutput' does not read. Their +-- digest is 'txSigHashCashToken', with the prefix that 'splitTokenPrefix' +-- takes off the script. -- --- * Schnorr signatures, see 'TxSignature'. +-- * Schnorr signatures as a 'TxSignature'. They are verified by +-- 'Haskoin.Crypto.Signature.verifyCashSchnorr', and by +-- 'Haskoin.Transaction.Builder.judgeInputs' in an input. -- -- Fails when the input index is not an index of the transaction. txSigHashForkId :: @@ -378,7 +383,33 @@ SigHash -> -- | hash to be signed Either String Hash256 -txSigHashForkId net tx out v i sh +txSigHashForkId net tx = txSigHashCashToken net tx B.empty + +-- | 'txSigHashForkId' for a coin of Bitcoin Cash that holds tokens. The +-- digest of such a coin also covers its token prefix, the bytes that +-- 'splitTokenPrefix' takes off the front of its output script, which go in +-- right before the script. With an empty prefix this is 'txSigHashForkId'. +-- +-- The outputs of the transaction need nothing done: on the wire the +-- prefix of an output is part of its script field, and so it is in the +-- 'TxOut' that is hashed. +txSigHashCashToken :: + Network -> + -- | transaction to sign + Tx -> + -- | token prefix of the output being spent, or empty + ByteString -> + -- | script from output being spent, without the prefix + Script -> + -- | value of output being spent + Word64 -> + -- | index of input being signed + Int -> + -- | what to sign + SigHash -> + -- | hash to be signed + Either String Hash256 +txSigHashCashToken net tx prefix out v i sh | i < 0 || i >= length tx.inputs = Left "txSigHashForkId: input index out of range" | otherwise = Right . doubleSHA256 . runPutS $ do @@ -386,6 +417,7 @@ serialize hashPrevouts serialize hashSequence serialize (tx.inputs !! i).outpoint + putByteString prefix putScript out putWord64le v putWord32le (tx.inputs !! i).sequence @@ -416,6 +448,63 @@ putByteString encodedScript zeros :: Hash256 zeros = "0000000000000000000000000000000000000000000000000000000000000000" + +-- | Split the script field of an output of Bitcoin Cash into its token +-- prefix and the output script after it. An output without tokens has an +-- empty prefix. 'Nothing' for a prefix that is not well formed. +-- +-- Since May 2023 an output may hold tokens (CashTokens). They are written +-- at the front of its script field: the byte @0xef@, the 32 bytes of the +-- token category, a byte of flags, and after it a commitment with its +-- length and an amount, each when its flag is set. What follows is the +-- output script that locks the coin. +splitTokenPrefix :: ByteString -> Maybe (ByteString, ByteString) +splitTokenPrefix bytes + | B.null bytes || B.head bytes /= 0xef = Just (B.empty, bytes) + | B.length bytes < 34 = Nothing + | flags .&. 0x80 /= 0 = Nothing + -- tokens of some kind, a commitment only with a non-fungible one, and + -- a capability of none, mutable or minting, only with one too + | not hasNft && not hasAmount = Nothing + | not hasNft && (hasCommitment || capability /= 0) = Nothing + | capability > 2 = Nothing + | otherwise = do + afterCommitment <- + if hasCommitment + then do + (n, rest) <- compact afterFlags + if n == 0 || fromIntegral (B.length rest) < n then Nothing else Just (B.drop (fromIntegral n) rest) + else Just afterFlags + afterAmount <- + if hasAmount + then do + (n, rest) <- compact afterCommitment + if n == 0 || n > 0x7fffffffffffffff then Nothing else Just rest + else Just afterCommitment + Just (B.splitAt (B.length bytes - B.length afterAmount) bytes) + where + flags = B.index bytes 33 + afterFlags = B.drop 34 bytes + hasCommitment = flags .&. 0x40 /= 0 + hasNft = flags .&. 0x20 /= 0 + hasAmount = flags .&. 0x10 /= 0 + capability = flags .&. 0x0f + -- a number in the compact form of the protocol, in its shortest + -- encoding only + compact :: ByteString -> Maybe (Word64, ByteString) + compact b = case B.uncons b of + Nothing -> Nothing + Just (w, rest) + | w < 0xfd -> Just (fromIntegral w, rest) + | w == 0xfd -> sized 2 0xfd rest + | w == 0xfe -> sized 4 0x10000 rest + | otherwise -> sized 8 0x100000000 rest + sized k least rest + | B.length rest < k = Nothing + | n < least = Nothing + | otherwise = Just (n, B.drop k rest) + where + n = B.foldr (\w acc -> acc `shiftL` 8 .|. fromIntegral w) 0 (B.take k rest) -- | Data type representing a signature together with a 'SigHash'. The 'SigHash' -- is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in diff --git a/src/Haskoin/Transaction/Builder.hs b/src/Haskoin/Transaction/Builder.hs --- a/src/Haskoin/Transaction/Builder.hs +++ b/src/Haskoin/Transaction/Builder.hs @@ -35,6 +35,8 @@ mergeTxInput, findSigInput, verifyStdInput, + InputVerdict (..), + judgeInputs, -- * Coin Selection Coin (..), @@ -59,7 +61,10 @@ import Control.Monad (foldM, unless, when) import Control.Monad.Identity (runIdentity) import Crypto.Secp256k1 +import Data.Bits (popCount, testBit) import Data.ByteString qualified as B +import Data.Bytes.Get (runGetS) +import Data.Bytes.Serial (deserialize) import Data.Conduit (ConduitT, Void, await, runConduit, (.|)) import Data.Conduit.List (sourceList) import Data.Either (fromRight, rights) @@ -771,9 +776,14 @@ -- pay-to-public-key, pay-to-public-key-hash, multisig and pay-to-script-hash -- inputs, their SegWit forms, native or nested in pay-to-script-hash, and -- Taproot inputs spent by the key path or by a script path whose leaf is a --- single key check. An input that is not a witness program must have no --- witness, as @VerifyScript@ requires in Bitcoin Core. Other script path --- spends need script execution and are not verified: they are refused. +-- single key check or a multisig. The multisig of Taproot is @multi_a@ of +-- the output descriptors: a key and @OP_CHECKSIG@, then a key and +-- @OP_CHECKSIGADD@ for each other key, the number of signatures asked +-- for, and @OP_NUMEQUAL@; its witness has an item for every key, that of +-- the last key first, empty for a key that did not sign. An input that +-- is not a witness program must have no witness, as @VerifyScript@ +-- requires in Bitcoin Core. Other script path spends need script +-- execution and are not verified: they are refused. -- -- The answer is never 'True' for an input that no block can contain: -- @@ -941,8 +951,210 @@ leafKey <- maybe (Left "not an x-only key") Right (importXOnlyPubKey ctx keyBytes) (sig, h) <- schnorr sigBytes spd.annex (Just (leafHash spd.leafVersion spd.script, 0xffffffff)) return (verifyScriptPathData ctx outKey spd && verifySchnorr ctx leafKey sig (hashToMsg h)) - _ -> Left "script path spends other than a single key check are not verified" + -- The multisig of Taproot, @multi_a@ of the output descriptors: + -- a key and OP_CHECKSIG, then a key and OP_CHECKSIGADD for each + -- other key, the number of signatures asked for, and + -- OP_NUMEQUAL. The witness has an item for every key, that of + -- the last key first: a signature, or nothing for a key that + -- did not sign. A signature that does not verify fails the + -- script, it does not count for nothing (BIP 342). + (ops, items) + | spd.leafVersion == tapscriptLeafVersion, + Just (keys, asked) <- multiA ops, + length items == length keys -> do + let leaf = Just (leafHash spd.leafVersion spd.script, 0xffffffff) + signs keyBytes sigBytes + | B.null sigBytes = Right False + | otherwise = do + key <- maybe (Left "not an x-only key") Right (importXOnlyPubKey ctx keyBytes) + (sig, h) <- schnorr sigBytes spd.annex leaf + if verifySchnorr ctx key sig (hashToMsg h) + then Right True + else Left "a signature that does not verify" + signed <- sequence (zipWith signs keys (reverse items)) + return (verifyScriptPathData ctx outKey spd && length (filter id signed) == asked) + _ -> Left "script path spends other than key checks are not verified" Nothing -> Left "not a Taproot witness" + +-- | What can be said of the signature of an input without running its +-- script. +data InputVerdict + = -- | the input is one of the standard kinds and its signatures verify + -- ('verifyStdInput') + InputVerified + | -- | the input spends a coin locked to one key, with the signature and + -- key that such a coin takes, and they do not open it: no node takes + -- the transaction + InputForged + | -- | neither: a script that is not run here, a coin that was not + -- given, a hash type other than all, an encoding that is not read + InputUndecided + deriving (Eq, Show) + +-- | Judge each input of a transaction, given the output it spends, in +-- order, as it is in the transaction that made it: 'Nothing' for one that +-- is not known. +-- +-- 'verifyStdTx' answers 'False' both for a forged signature and for a +-- script it does not read. To refuse a transaction before sending it, +-- those have to be told apart: a wrong 'InputForged' turns away a good +-- transaction, while 'InputUndecided' only leaves the question to a +-- node. So 'InputForged' is said of little, and only where there is +-- nothing to run: +-- +-- * a coin locked to a key hash, to a key, to a witness key hash, to one +-- nested in a script hash, or to a Taproot key, spent by the key and +-- not by a script; +-- * with exactly the items such an input has, and a hash type of all; +-- * whose key is not the one the coin names, or whose signature does not +-- verify over the digest. +-- +-- On Bitcoin Cash it reads what 'verifyStdInput' does not: a Schnorr +-- signature ('verifyCashSchnorr'), of one key or in a multisig, bare or in +-- a script hash, and a coin that holds tokens, whose digest covers them +-- ('txSigHashCashToken'). Inputs of those kinds are 'InputVerified' here +-- and not by 'verifyStdInput'. A multisig is never 'InputForged': one +-- that does not verify is 'InputUndecided'. +judgeInputs :: Network -> Ctx -> Tx -> [Maybe TxOut] -> [InputVerdict] +judgeInputs net ctx tx given = zipWith judge [0 ..] decoded + where + prevs = take (length tx.inputs) (given <> repeat Nothing) + forked = net.sigHashForkId /= Nothing + split bytes + | forked = splitTokenPrefix bytes + | otherwise = Just (B.empty, bytes) + decoded = map (>>= decode) prevs + decode o = do + (prefix, script) <- split o.script + so <- eitherToMaybe (unmarshal ctx script) + return (prefix, so, o.value) + spent = + SpentCoins + { coins = [d >>= \(prefix, so, v) -> if B.null prefix then Just (so, v) else Nothing | d <- decoded], + outputs = sequence prevs + } + judge :: Int -> Maybe (B.ByteString, ScriptOutput, Word64) -> InputVerdict + judge _ Nothing = InputUndecided + judge i (Just (prefix, so, val)) + | B.null prefix && verifyInput net ctx tx spent i = InputVerified + | otherwise = case so of + PayPKHash h + | null ws, Just [sig, pub] <- pushes -> keyed (addressHash pub == h) sig pub legacy + PayPK pub + | null ws, Just [sig] <- pushes -> signed sig pub.point legacy + PayWitnessPKHash h + | net.segWit, B.null inp, [sig, pub] <- ws -> keyed (addressHash pub == h) sig pub (segwit so) + PayScriptHash h + | net.segWit, + Just [program] <- pushes, + addressHash program == h, + Right nested@(PayWitnessPKHash kh) <- unmarshal ctx program, + [sig, pub] <- ws -> + keyed (addressHash pub == kh) sig pub (segwit nested) + PayWitness 1 program + | net.segWit, B.length program == 32, B.null inp, [sig] <- ws -> taproot program sig + PayMulSig keys asked + | forked, null ws, Just (bits : sigs) <- pushes -> cashMultisig so keys asked bits sigs + PayScriptHash h + | forked, + null ws, + Just items@(_ : _ : _) <- pushes, + addressHash (last items) == h, + Right redeem@(PayMulSig keys asked) <- unmarshal ctx (last items), + bits : sigs <- init items -> + cashMultisig redeem keys asked bits sigs + _ -> InputUndecided + where + inp = (tx.inputs !! i).script + ws = if length tx.witness > i then tx.witness !! i else [] + -- the items of an input script that only pushes data + pushes = case runGetS deserialize inp of + Right (Script ops) -> mapM pushed ops + Left _ -> Nothing + -- a small number is pushed by an opcode of its own + pushed = \case + OP_PUSHDATA d _ -> Just d + op -> B.singleton . fromIntegral <$> eitherToMaybe (scriptOpToInt op) + legacy sh = do + script <- encodeOutput ctx so + if forked then txSigHashCashToken net tx prefix script val i sh else txSigHash net tx script val i sh + segwit out sh = Sign.makeSigHash net ctx tx i out val sh Nothing + -- a coin that names the hash of its key: another key does not + -- open it, whatever it signed + keyed named sig pub digest + | not named = InputForged + | otherwise = maybe InputUndecided (\k -> signed sig k digest) (importPubKey ctx pub) + -- Forged is said of the hash type "all" only. With another hash + -- type a signature that verifies is verified, and one that does + -- not is left alone. + signed sig key digest + | B.null sig || not (readable (B.last sig)) = InputUndecided + | otherwise = case digest (fromIntegral (B.last sig)) of + Left _ -> InputUndecided + Right m + -- on Bitcoin Cash a signature of 64 bytes is a Schnorr one + | forked && B.length body == 64 -> sure (verifyCashSchnorr ctx key body m) + | otherwise -> maybe InputUndecided (\s -> sure (verifyHashSig ctx m s key)) (decodeStrictSig ctx body) + where + body = B.init sig + sure ok + | ok = InputVerified + | B.last sig == (if forked then 0x41 else 0x01) = InputForged + | otherwise = InputUndecided + -- The hash types whose digest is computed here. On Bitcoin Cash: + -- all, none or single, with the fork id, alone or with "anyone + -- can pay"; not the one that covers every coin spent. + readable ht + | forked = ht `elem` [0x41, 0x42, 0x43, 0xc1, 0xc2, 0xc3] + | otherwise = ht == 0x01 + -- A multisig of Bitcoin Cash signed with Schnorr signatures. In + -- place of the empty item that a multisig takes first there is a + -- field of bits, one for each key in the order of the script, + -- the first key lowest, set for the keys that signed. It has + -- exactly the bytes that hold a bit for every key, no bit past + -- the keys, and as many bits set as signatures are asked for. + -- The signatures follow in the order of their keys, and every + -- one must be a Schnorr signature that verifies. This is + -- OP_CHECKMULTISIG of Bitcoin Cash Node, since November 2019. + cashMultisig script keys asked bits sigs + | B.null bits = InputUndecided + | B.length bits /= (length keys + 7) `div` 8 = InputUndecided + | field >= 2 ^ length keys || popCount field /= asked || length sigs /= asked = InputUndecided + | all good (zip signers sigs) = InputVerified + | otherwise = InputUndecided + where + field = B.foldr (\w acc -> acc * 256 + toInteger w) 0 bits :: Integer + signers = [k | (n, k) <- zip [0 ..] keys, testBit field n] + good (key, sig) = + B.length sig == 65 + && readable (B.last sig) + && either + (const False) + (verifyCashSchnorr ctx key.point (B.init sig)) + (encodeOutput ctx script >>= \code -> cashDigest code (fromIntegral (B.last sig))) + cashDigest code = txSigHashCashToken net tx prefix code val i + taproot program sig = fromRight InputUndecided $ do + key <- maybe (Left "not a key") Right (importXOnlyPubKey ctx program) + outs <- maybe (Left "a spent output is missing") Right spent.outputs + TaprootSignature s sh <- decodeTaprootSig sig + unless (sh == sigHashDefault || sh == sigHashAll) $ Left "another hash type" + m <- taprootSigHash tx outs i sh Nothing Nothing + return (verdict (verifySchnorr ctx key s (hashToMsg m))) + verdict ok = if ok then InputVerified else InputForged + +-- | The keys of a Taproot multisig script and the number of signatures it +-- asks for, if the script is one: see 'verifyStdInput'. +multiA :: [ScriptOp] -> Maybe ([B.ByteString], Int) +multiA (OP_PUSHDATA first OPCODE : OP_CHECKSIG : rest) = go [first] rest + where + go keys (OP_PUSHDATA key OPCODE : OP_CHECKSIGADD : more) = go (key : keys) more + go keys [number, OP_NUMEQUAL] + | Right asked <- scriptOpToInt number, + asked <= length keys, + all ((== 32) . B.length) keys = + Just (reverse keys, asked) + go _ _ = Nothing +multiA _ = Nothing -- | Whether an output script is a Taproot output: a witness program of -- version 1 that is 32 bytes long diff --git a/test/Haskoin/Crypto/SignatureSpec.hs b/test/Haskoin/Crypto/SignatureSpec.hs --- a/test/Haskoin/Crypto/SignatureSpec.hs +++ b/test/Haskoin/Crypto/SignatureSpec.hs @@ -32,6 +32,7 @@ spec :: Spec spec = prepareContext $ \ctx -> do + cashSchnorrSpec ctx describe "Signature property checks" $ do prop "verifies signature" $ forAll (arbitrarySignature ctx) $ \(m, key', sig) -> @@ -571,3 +572,113 @@ toPubKey :: Ctx -> SecKey -> PublicKey toPubKey ctx = derivePublicKey ctx . wrapSecKey True + +-- | The test vectors of the Schnorr module of Bitcoin Cash Node +-- (@src\/secp256k1\/src\/modules\/schnorr\/tests_impl.h@, version 29.0.0): +-- a name, the public key, the digest, the signature, and whether it +-- verifies. +cashSchnorrVectors :: [(String, Text, Text, Text, Bool)] +cashSchnorrVectors = + [ + ( "1", + "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798", + "0000000000000000000000000000000000000000000000000000000000000000", + "787a848e71043d280c50470e8e1532b2dd5d20ee912a45dbdd2bd1dfbf187ef6\ + \7031a98831859dc34dffeedda86831842ccd0079e1f92af177f7f22cc1dced05", + True + ), + ( "2", + "02dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "2a298dacae57395a15d0795ddbfd1dcb564da82b0f269bc70a74f8220429ba1d\ + \1e51a22ccec35599b8f266912281f8365ffc2d035a230434a1a64dc59f7013fd", + True + ), + ( "3", + "03fac2114c2fbb091527eb7c64ecb11f8021cb45e8e7809d3c0938e4b8c0e5f84b", + "5e2d58d8b3bcdf1abadec7829054f90dda9805aab56c77333024b9d0a508b75c", + "00da9b08172a9b6f0466a2defd817f2d7ab437e0d253cb5395a963866b3574be\ + \00880371d01766935b92d2ab4cd5c8a2a5837ec57fed7660773a05f0de142380", + True + ), + ( "4", + "03defdea4cdb677750a420fee807eacf21eb9898ae79b9768766e4faa04a2d4a34", + "4df3c3f68fcc83b27e9d42c90431a72499f17875c81a599b566c9889b9696703", + "00000000000000000000003b78ce563f89a0ed9414f5aa28ad0d96d6795f9c63\ + \02a8dc32e64e86a333f20ef56eac9ba30b7246d6d25e22adb8c6be1aeb08d49d", + True + ), + ( "4b", + "031b84c5567b126440995d3ed5aaba0565d71e1834604819ff9c17f5e9d5dd078f", + "0000000000000000000000000000000000000000000000000000000000000000", + "52818579aca59767e3291d91b76b637bef062083284992f2d95f564ca6cb4e35\ + \30b1da849c8e8304adc0cfe870660334b3cfc18e825ef1db34cfae3dfc5d8187", + True + ), + ( "6: R.y is not a quadratic residue", + "02dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "2a298dacae57395a15d0795ddbfd1dcb564da82b0f269bc70a74f8220429ba1d\ + \fa16aee06609280a19b67a24e1977e4697712b5fd2943914ecd5f730901b4ab7", + False + ), + ( "7: negated message hash", + "03fac2114c2fbb091527eb7c64ecb11f8021cb45e8e7809d3c0938e4b8c0e5f84b", + "5e2d58d8b3bcdf1abadec7829054f90dda9805aab56c77333024b9d0a508b75c", + "00da9b08172a9b6f0466a2defd817f2d7ab437e0d253cb5395a963866b3574be\ + \d092f9d860f1776a1f7412ad8a1eb50daccc222bc8c0e26b2056df2f273efdec", + False + ), + ( "8: negated s", + "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798", + "0000000000000000000000000000000000000000000000000000000000000000", + "787a848e71043d280c50470e8e1532b2dd5d20ee912a45dbdd2bd1dfbf187ef6\ + \8fce5677ce7a623cb20011225797ce7a8de1dc6ccd4f754a47da6c600e59543c", + False + ), + ( "9: negated P", + "03dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "2a298dacae57395a15d0795ddbfd1dcb564da82b0f269bc70a74f8220429ba1d\ + \1e51a22ccec35599b8f266912281f8365ffc2d035a230434a1a64dc59f7013fd", + False + ), + ( "10: s * G = e * P, R at infinity", + "02dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "2a298dacae57395a15d0795ddbfd1dcb564da82b0f269bc70a74f8220429ba1d\ + \8c3428869a663ed1e954705b020cbb3e7bb6ac31965b9ea4c73e227b17c5af5a", + False + ), + ( "11: r not on the curve", + "02dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "4a298dacae57395a15d0795ddbfd1dcb564da82b0f269bc70a74f8220429ba1d\ + \1e51a22ccec35599b8f266912281f8365ffc2d035a230434a1a64dc59f7013fd", + False + ), + ( "12: r = p", + "02dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc2f\ + \1e51a22ccec35599b8f266912281f8365ffc2d035a230434a1a64dc59f7013fd", + False + ), + ( "13: s = n", + "02dff1d77f2a671c5f36183726db2341be58feae1da2deced843240f7b502ba659", + "243f6a8885a308d313198a2e03707344a4093822299f31d0082efa98ec4e6c89", + "2a298dacae57395a15d0795ddbfd1dcb564da82b0f269bc70a74f8220429ba1d\ + \fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141", + False + ) + ] + +cashSchnorrSpec :: Ctx -> Spec +cashSchnorrSpec ctx = + describe "Schnorr signatures of Bitcoin Cash" $ + forM_ cashSchnorrVectors $ \(name, pk, digest, sig, valid) -> + it ("vector " <> name) $ do + let bytes = fromJust . decodeHex + pub = fromJust (importPubKey ctx (bytes pk)) + h = either error id (S.decode (bytes digest)) :: Hash256 + verifyCashSchnorr ctx pub (bytes sig) h `shouldBe` valid diff --git a/test/Haskoin/Transaction/VerdictSpec.hs b/test/Haskoin/Transaction/VerdictSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Transaction/VerdictSpec.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Transaction.VerdictSpec (spec) where + +import Crypto.Secp256k1 +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.Bytes.Get (runGetS) +import Data.Bytes.Put (runPutS) +import Data.Bytes.Serial (deserialize, serialize) +import Data.Either (rights) +import Data.Maybe (fromJust, mapMaybe) +import Data.Word (Word64, Word8) +import Haskoin.Address +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Network.Data +import Haskoin.Script +import Haskoin.Transaction +import Haskoin.Util +import Haskoin.Util.Arbitrary +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +secret :: Word8 -> SecKey +secret n = fromJust (secKey (B.replicate 31 0 <> B.singleton n)) + +-- | The compressed bytes of the public key of a secret. +pubBytes :: Ctx -> SecKey -> ByteString +pubBytes ctx = exportPubKey ctx True . derivePubKey ctx + +coin :: OutPoint +coin = OutPoint "0101010101010101010101010101010101010101010101010101010101010101" 0 + +-- | A transaction that spends the coin and pays most of 100,000. +spending :: ByteString -> [ByteString] -> Tx +spending inputScript witness = + Tx + { version = 2, + inputs = [TxIn coin inputScript maxBound], + outputs = [TxOut 90000 (B.replicate 25 0x51)], + witness = [witness | not (null witness)], + locktime = 0 + } + +-- | An input script that pushes these items. +pushing :: [ByteString] -> ByteString +pushing = runPutS . serialize . Script . map opPushData + +-- | Pay one satoshi less: what was signed is no longer what is there. +tampered :: Tx -> Tx +tampered tx = tx {outputs = [o {value = o.value - 1} | o <- tx.outputs]} + +ecdsa :: Ctx -> SecKey -> Word8 -> Either String Hash256 -> ByteString +ecdsa ctx k hashType = either error (\h -> exportSig ctx (signHash ctx k h) <> B.singleton hashType) + +-- | A Schnorr signature of Bitcoin Cash, made the plain way: this is a +-- test, and the nonce is not a secret worth keeping. +cashSchnorr :: Ctx -> SecKey -> Hash256 -> ByteString +cashSchnorr ctx k h = head (mapMaybe attempt [1 ..]) + where + n = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 :: Integer + p = 2 ^ (256 :: Int) - 2 ^ (32 :: Int) - 977 :: Integer + word256 i = let b = integerToBS i in B.replicate (32 - B.length b) 0 <> b + d = bsToInteger k.get + attempt nonce = do + r <- derivePubKey ctx <$> secKey (word256 nonce) + let (x, y) = B.splitAt 32 (B.drop 1 (exportPubKey ctx False r)) + square = powMod (bsToInteger y) ((p - 1) `div` 2) == 1 + e = bsToInteger (runPutS (serialize (sha256 (x <> pubBytes ctx k <> runPutS (serialize h))))) `mod` n + if square then Just (x <> word256 ((nonce + e * d) `mod` n)) else Nothing + powMod _ 0 = 1 :: Integer + powMod b i + | even i = let half = powMod b (i `div` 2) in half * half `mod` p + | otherwise = b * powMod b (i - 1) `mod` p + +spec :: Spec +spec = prepareContext $ \ctx -> do + let k = secret 7 + pub = pubBytes ctx k + h160 = addressHash pub + value = 100000 :: Word64 + prev so = Just (TxOut value (marshal ctx so)) + pkhScript = either error id (encodeOutput ctx (PayPKHash h160)) + three net tx prevOut = do + judgeInputs net ctx tx [prevOut] `shouldBe` [InputVerified] + judgeInputs net ctx (tampered tx) [prevOut] `shouldBe` [InputForged] + judgeInputs net ctx tx [Nothing] `shouldBe` [InputUndecided] + + describe "judgeInputs on coins of one key" $ do + it "tells a key hash input that verifies from a forged one, and from one it cannot see" $ do + let unsigned = spending "" [] + sig = ecdsa ctx k 0x01 (txSigHash btc unsigned pkhScript value 0 sigHashAll) + three btc (spending (pushing [sig, pub]) []) (prev (PayPKHash h160)) + it "says forged of another key than the one the coin names" $ do + let other = secret 8 + unsigned = spending "" [] + sig = ecdsa ctx other 0x01 (txSigHash btc unsigned pkhScript value 0 sigHashAll) + judgeInputs btc ctx (spending (pushing [sig, pubBytes ctx other]) []) [prev (PayPKHash h160)] + `shouldBe` [InputForged] + it "does the same for a witness key hash, plain and nested" $ do + let unsigned = spending "" [] + sig = ecdsa ctx k 0x01 (txSigHashForkId btc unsigned pkhScript value 0 sigHashAll) + program = marshal ctx (PayWitnessPKHash h160) + three btc (spending "" [sig, pub]) (prev (PayWitnessPKHash h160)) + three btc (spending (pushing [program]) [sig, pub]) (prev (PayScriptHash (addressHash program))) + it "does the same for a Taproot key" $ do + let outKey = B.drop 1 pub + out = TxOut value (marshal ctx (PayWitness 1 outKey)) + -- the secret of the key with an even y, whichever of the two it is + signed = head (rights [signTaprootInput ctx (spending "" []) [out] 0 sigHashDefault s | s <- [k, negated]]) + negated = fromJust (secKey . (.get) =<< tweakNegate ctx =<< tweak k.get) + three btc signed (Just out) + it "leaves a hash type other than all, and a script, to a node" $ do + let unsigned = spending "" [] + none = ecdsa ctx k 0x02 (txSigHash btc unsigned pkhScript value 0 sigHashNone) + judgeInputs btc ctx (tampered (spending (pushing [none, pub]) [])) [prev (PayPKHash h160)] + `shouldBe` [InputVerified] + judgeInputs btc ctx (spending (pushing ["anything"]) []) [prev (PayScriptHash h160)] + `shouldBe` [InputUndecided] + + describe "judgeInputs on Bitcoin Cash" $ do + let unsigned = spending "" [] + digest prefix = txSigHashCashToken bch unsigned prefix pkhScript value 0 (setForkIdFlag sigHashAll) + tokens = B.singleton 0xef <> B.replicate 32 0xaa <> B.pack [0x10, 0xfd, 0xe8, 0x03] + it "reads a Schnorr signature" $ do + let sig = cashSchnorr ctx k (either error id (digest "")) <> B.singleton 0x41 + B.length sig `shouldBe` 65 + three bch (spending (pushing [sig, pub]) []) (prev (PayPKHash h160)) + it "reads an ECDSA signature" $ + three bch (spending (pushing [ecdsa ctx k 0x41 (digest ""), pub]) []) (prev (PayPKHash h160)) + it "reads a coin that holds tokens, whose digest covers them" $ do + let withTokens = Just (TxOut value (tokens <> marshal ctx (PayPKHash h160))) + three bch (spending (pushing [ecdsa ctx k 0x41 (digest tokens), pub]) []) withTokens + three bch (spending (pushing [cashSchnorr ctx k (either error id (digest tokens)) <> "\x41", pub]) []) withTokens + -- signed as if the coin held none: not a signature of this coin + judgeInputs bch ctx (spending (pushing [ecdsa ctx k 0x41 (digest ""), pub]) []) [withTokens] + `shouldBe` [InputForged] + + describe "judgeInputs on what Bitcoin Cash Node signed" $ do + -- Two transactions of the wallet of Bitcoin Cash Node 29.2.0 on + -- regtest, both with Schnorr signatures. The first spends a coinbase + -- of 50 coins to the same key and makes 1,000 fungible tokens. The + -- second spends that output, tokens and all. + let parse h = either error id (runGetS deserialize (fromJust (decodeHex h))) :: Tx + genesis = + parse + "0200000001f28fd1cdb4293ae6bb76e580c5a3469fb926690471f3ffb798ef0a\ + \cda9886525000000006441e31c237fe3a1a45f6c32c779c78025f29bd735fa44\ + \d18c182bc1c08fbbcab25f08cbd8c1937dccd38acf37ef2bf8907e75029d622c\ + \5a9f6f5161ffe534fa2775412103bcacac8993931b1f0867991841a140425906\ + \839d26c4c906a737a4f2f29dd79effffffff01c0aff629010000003eeff28fd1\ + \cdb4293ae6bb76e580c5a3469fb926690471f3ffb798ef0acda988652510fde8\ + \0376a9145dd6bc82b5a42053b8f7802e68d296ac3578537a88ac00000000" + spend = + parse + "0200000001db5f2a09c11a2aaceb0d9bfa755006380257d48dab94a73cfd4d69\ + \c2e2d122a6000000006441f52f838cf46e41b8c630334d2b6edefdb49f67fd19\ + \45ee864321da50b1fa652b6b2db4b517110ee5598cbf5193eac763a56d59bfe2\ + \e20d8f3fb9af4b08bfe340412103bcacac8993931b1f0867991841a140425906\ + \839d26c4c906a737a4f2f29dd79effffffff01806de729010000003eeff28fd1\ + \cdb4293ae6bb76e580c5a3469fb926690471f3ffb798ef0acda988652510fde8\ + \0376a9145dd6bc82b5a42053b8f7802e68d296ac3578537a88ac00000000" + coinbase = TxOut 5000000000 (fromJust (decodeHex "76a9145dd6bc82b5a42053b8f7802e68d296ac3578537a88ac")) + it "verifies its Schnorr signature of a coin without tokens" $ do + judgeInputs bchRegTest ctx genesis [Just coinbase] `shouldBe` [InputVerified] + judgeInputs bchRegTest ctx (tampered genesis) [Just coinbase] `shouldBe` [InputForged] + it "verifies its Schnorr signature of a coin that holds tokens" $ do + let held = head genesis.outputs + fmap fst (splitTokenPrefix held.script) `shouldSatisfy` maybe False (not . B.null) + judgeInputs bchRegTest ctx spend [Just held] `shouldBe` [InputVerified] + judgeInputs bchRegTest ctx (tampered spend) [Just held] `shouldBe` [InputForged] + -- the same coin without its tokens is another coin + let bare = held {script = maybe held.script snd (splitTokenPrefix held.script)} :: TxOut + judgeInputs bchRegTest ctx spend [Just bare] `shouldBe` [InputForged] + + describe "judgeInputs on a multisig of Bitcoin Cash signed with Schnorr signatures" $ do + let secrets = map secret [11, 12, 13] + keys = map (wrapPubKey True . derivePubKey ctx) secrets + twoOfThree = PayMulSig keys 2 + redeem = marshal ctx twoOfThree + locked = prev (PayScriptHash (addressHash redeem)) + code = either error id (encodeOutput ctx twoOfThree) + digest = either error id (txSigHashForkId bch (spending "" []) code value 0 (setForkIdFlag sigHashAll)) + sign s = cashSchnorr ctx s digest <> B.singleton 0x41 + -- the field of bits is a small number, pushed by its own opcode + spendWith bits sigs = + spending (runPutS (serialize (Script ([bits] <> map opPushData (sigs <> [redeem]))))) [] + verdict tx = judgeInputs bch ctx tx [locked] + it "verifies the signatures of the keys that the bits name, in the order of the keys" $ do + verdict (spendWith OP_5 [sign (head secrets), sign (secrets !! 2)]) `shouldBe` [InputVerified] + verdict (spendWith OP_3 [sign (head secrets), sign (secrets !! 1)]) `shouldBe` [InputVerified] + verdict (spendWith OP_6 [sign (secrets !! 1), sign (secrets !! 2)]) `shouldBe` [InputVerified] + it "does not verify bits that name other keys, too many or too few, or keys past the last" $ do + let sigs = [sign (head secrets), sign (secrets !! 2)] + verdict (spendWith OP_3 sigs) `shouldBe` [InputUndecided] + verdict (spendWith OP_7 sigs) `shouldBe` [InputUndecided] + verdict (spendWith OP_1 sigs) `shouldBe` [InputUndecided] + verdict (spendWith OP_9 sigs) `shouldBe` [InputUndecided] + -- in the other order + verdict (spendWith OP_5 (reverse sigs)) `shouldBe` [InputUndecided] + it "does not verify what was not signed, nor an ECDSA signature among them" $ do + verdict (tampered (spendWith OP_5 [sign (head secrets), sign (secrets !! 2)])) `shouldBe` [InputUndecided] + let ecdsaSig = ecdsa ctx (head secrets) 0x41 (Right digest) + verdict (spendWith OP_5 [ecdsaSig, sign (secrets !! 2)]) `shouldBe` [InputUndecided] + + describe "verifyStdInput on a multisig of Taproot" $ do + let secrets = map secret [11, 12, 13] + xOnly = B.drop 1 . pubBytes ctx + leaf = + Script $ + [opPushData (xOnly (head secrets)), OP_CHECKSIG] + <> concat [[opPushData (xOnly s), OP_CHECKSIGADD] | s <- drop 1 secrets] + <> [OP_2, OP_NUMEQUAL] + internal = derivePubKey ctx (secret 14) + tree = TaprootOutput {internalKey = internal, mast = Just (MASTLeaf tapscriptLeafVersion leaf)} + out = TxOut value (marshal ctx (taprootScriptOutput ctx tree)) + unsigned = spending "" [] + leafOf = Just (leafHash tapscriptLeafVersion leaf, 0xffffffff) + digest = either error id (taprootSigHash unsigned [out] 0 sigHashDefault Nothing leafOf) + sign s = (signSchnorr ctx s (hashToMsg digest)).get + spendWith items = + let path = + ScriptPathSpend + ScriptPathData + { annex = Nothing, + stack = items, + script = leaf, + extIsOdd = odd (keyParity ctx (taprootOutputKey ctx tree)), + leafVersion = tapscriptLeafVersion, + internalKey = internal, + control = [], + opaqueScript = Nothing + } + in unsigned {witness = [either error id (encodeTaprootWitness ctx path)]} :: Tx + verdict tx = judgeInputs btc ctx tx [Just out] + it "verifies two signatures of three keys, with an item for each key, the last first" $ do + verdict (spendWith [sign (secrets !! 2), "", sign (head secrets)]) `shouldBe` [InputVerified] + verdict (spendWith ["", sign (secrets !! 1), sign (head secrets)]) `shouldBe` [InputVerified] + let lastTwo = spendWith [sign (secrets !! 2), sign (secrets !! 1), ""] + verifyStdInput btc ctx lastTwo [(taprootScriptOutput ctx tree, value, coin)] 0 `shouldBe` True + it "does not verify one signature, three, a signature of another key, or one of other outputs" $ do + verdict (spendWith ["", "", sign (head secrets)]) `shouldBe` [InputUndecided] + verdict (spendWith [sign (secrets !! 2), sign (secrets !! 1), sign (head secrets)]) `shouldBe` [InputUndecided] + -- the signature of the first key where that of the third goes + verdict (spendWith [sign (head secrets), "", sign (head secrets)]) `shouldBe` [InputUndecided] + verdict (tampered (spendWith [sign (secrets !! 2), "", sign (head secrets)])) `shouldBe` [InputUndecided] + -- an item for a key is missing + verdict (spendWith [sign (secrets !! 1), sign (head secrets)]) `shouldBe` [InputUndecided] + + describe "splitTokenPrefix" $ do + let category = B.replicate 32 0xaa + script = "\x76\xa9" + it "leaves a script without tokens alone" $ + splitTokenPrefix script `shouldBe` Just ("", script) + it "takes off fungible tokens, a non-fungible one, and one with a commitment" $ do + let fungible = "\xef" <> category <> "\x10\x05" + nft = "\xef" <> category <> "\x22" + committed = "\xef" <> category <> "\x70\x02\xbe\xef\xfd\x00\x01" + splitTokenPrefix (fungible <> script) `shouldBe` Just (fungible, script) + splitTokenPrefix (nft <> script) `shouldBe` Just (nft, script) + splitTokenPrefix (committed <> script) `shouldBe` Just (committed, script) + it "refuses a prefix that is not well formed" $ do + -- no tokens at all, a commitment without a token to carry it, an + -- amount of zero, a number not in its shortest form, and one cut short + splitTokenPrefix ("\xef" <> category <> "\x00" <> script) `shouldBe` Nothing + splitTokenPrefix ("\xef" <> category <> "\x50\x01\x00\x01" <> script) `shouldBe` Nothing + splitTokenPrefix ("\xef" <> category <> "\x10\x00" <> script) `shouldBe` Nothing + splitTokenPrefix ("\xef" <> category <> "\x10\xfd\x05\x00" <> script) `shouldBe` Nothing + splitTokenPrefix ("\xef" <> category) `shouldBe` Nothing + + describe "judgeInputs on signed transactions" $ + prop "never says forged of an input that verifies" $ + forAll (elements [btc, bch] >>= \net -> (,) net <$> arbitrarySigningData net ctx) $ \(net, (tx, sigis, keys)) -> + case signTx net ctx tx sigis (map (.key) keys) of + Left _ -> property True + Right signed -> + let prevOf i = lookup i.outpoint [(s.outpoint, TxOut s.value (marshal ctx s.script)) | s <- sigis] + verdicts = judgeInputs net ctx signed (map prevOf signed.inputs) + coins = [(s.script, s.value, s.outpoint) | s <- sigis] + in counterexample (show verdicts) $ + InputForged `notElem` verdicts + && (not (verifyStdTx net ctx signed coins) || all (== InputVerified) verdicts)