haskoin-core-0.21.0: src/Haskoin/Util/Arbitrary/Script.hs
{-# LANGUAGE LambdaCase #-}
{- |
Module : Haskoin.Test.Script
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
module Haskoin.Util.Arbitrary.Script where
import Crypto.Secp256k1
import qualified Data.ByteString as B
import Data.Maybe
import Data.Word
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Script
import Haskoin.Transaction.Common
import Haskoin.Util
import Haskoin.Util.Arbitrary.Address
import Haskoin.Util.Arbitrary.Crypto
import Haskoin.Util.Arbitrary.Keys
import Haskoin.Util.Arbitrary.Util
import Test.QuickCheck
-- | Arbitrary 'Script' with random script ops.
arbitraryScript :: Gen Script
arbitraryScript = Script <$> listOf arbitraryScriptOp
-- | Arbitrary 'ScriptOp' (push operations have random data).
arbitraryScriptOp :: Gen ScriptOp
arbitraryScriptOp =
oneof
-- Pushing Data
[ opPushData <$> arbitraryBS1
, return OP_0
, return OP_1NEGATE
, return OP_RESERVED
, return OP_1
, return OP_2
, return OP_3
, return OP_4
, return OP_5
, return OP_6
, return OP_7
, return OP_8
, return OP_9
, return OP_10
, return OP_11
, return OP_12
, return OP_13
, return OP_14
, return OP_15
, return OP_16
, -- Flow control
return OP_NOP
, return OP_VER
, return OP_IF
, return OP_NOTIF
, return OP_VERIF
, return OP_VERNOTIF
, return OP_ELSE
, return OP_ENDIF
, return OP_VERIFY
, return OP_RETURN
, -- Stack operations
return OP_TOALTSTACK
, return OP_FROMALTSTACK
, return OP_IFDUP
, return OP_DEPTH
, return OP_DROP
, return OP_DUP
, return OP_NIP
, return OP_OVER
, return OP_PICK
, return OP_ROLL
, return OP_ROT
, return OP_SWAP
, return OP_TUCK
, return OP_2DROP
, return OP_2DUP
, return OP_3DUP
, return OP_2OVER
, return OP_2ROT
, return OP_2SWAP
, -- Splice
return OP_CAT
, return OP_SUBSTR
, return OP_LEFT
, return OP_RIGHT
, return OP_SIZE
, -- Bitwise logic
return OP_INVERT
, return OP_AND
, return OP_OR
, return OP_XOR
, return OP_EQUAL
, return OP_EQUALVERIFY
, return OP_RESERVED1
, return OP_RESERVED2
, -- Arithmetic
return OP_1ADD
, return OP_1SUB
, return OP_2MUL
, return OP_2DIV
, return OP_NEGATE
, return OP_ABS
, return OP_NOT
, return OP_0NOTEQUAL
, return OP_ADD
, return OP_SUB
, return OP_MUL
, return OP_DIV
, return OP_MOD
, return OP_LSHIFT
, return OP_RSHIFT
, return OP_BOOLAND
, return OP_BOOLOR
, return OP_NUMEQUAL
, return OP_NUMEQUALVERIFY
, return OP_NUMNOTEQUAL
, return OP_LESSTHAN
, return OP_GREATERTHAN
, return OP_LESSTHANOREQUAL
, return OP_GREATERTHANOREQUAL
, return OP_MIN
, return OP_MAX
, return OP_WITHIN
, -- Crypto
return OP_RIPEMD160
, return OP_SHA1
, return OP_SHA256
, return OP_HASH160
, return OP_HASH256
, return OP_CODESEPARATOR
, return OP_CHECKSIG
, return OP_CHECKSIGVERIFY
, return OP_CHECKMULTISIG
, return OP_CHECKMULTISIGVERIFY
, -- Expansion
return OP_NOP1
, return OP_CHECKLOCKTIMEVERIFY
, return OP_CHECKSEQUENCEVERIFY
, return OP_NOP4
, return OP_NOP5
, return OP_NOP6
, return OP_NOP7
, return OP_NOP8
, return OP_NOP9
, return OP_NOP10
, -- Bitcoin Cash Nov 2018 hard fork
return OP_CHECKDATASIG
, return OP_CHECKDATASIGVERIFY
, -- Bitcoin Cash May 2020 hard fork
return OP_REVERSEBYTES
, -- Other
return OP_PUBKEYHASH
, return OP_PUBKEY
, return $ OP_INVALIDOPCODE 0xff
]
-- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@.
arbitraryIntScriptOp :: Gen ScriptOp
arbitraryIntScriptOp =
elements
[ OP_1
, OP_2
, OP_3
, OP_4
, OP_5
, OP_6
, OP_7
, OP_8
, OP_9
, OP_10
, OP_11
, OP_12
, OP_13
, OP_14
, OP_15
, OP_16
]
-- | Arbitrary 'PushDataType'.
arbitraryPushDataType :: Gen PushDataType
arbitraryPushDataType = elements [OPCODE, OPDATA1, OPDATA2, OPDATA4]
-- | Arbitrary 'SigHash' (including invalid/unknown sighash codes).
arbitrarySigHash :: Gen SigHash
arbitrarySigHash = fromIntegral <$> (arbitrary :: Gen Word32)
-- | Arbitrary valid 'SigHash'.
arbitraryValidSigHash :: Network -> Gen SigHash
arbitraryValidSigHash net = do
sh <- elements [sigHashAll, sigHashNone, sigHashSingle]
f1 <-
elements $
if isJust (getSigHashForkId net)
then [id, setForkIdFlag]
else [id]
f2 <- elements [id, setAnyoneCanPayFlag]
return $ f1 $ f2 sh
arbitrarySigHashFlag :: Gen SigHashFlag
arbitrarySigHashFlag =
elements
[ SIGHASH_ALL
, SIGHASH_NONE
, SIGHASH_SINGLE
, SIGHASH_FORKID
, SIGHASH_ANYONECANPAY
]
{- | Arbitrary message hash, private key and corresponding 'TxSignature'. The
signature is generated deterministically using a random message and a random
private key.
-}
arbitraryTxSignature :: Network -> Gen (TxHash, SecKey, TxSignature)
arbitraryTxSignature net = do
(m, key, sig) <- arbitrarySignature
sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad
let txsig = TxSignature sig sh
return (TxHash m, key, txsig)
where
filterBad sh =
not $
isSigHashUnknown sh
|| isNothing (getSigHashForkId net) && hasForkIdFlag sh
-- | Arbitrary transaction signature that could also be empty.
arbitraryTxSignatureEmpty :: Network -> Gen TxSignature
arbitraryTxSignatureEmpty net =
frequency
[ (1, return TxSignatureEmpty)
, (10, lst3 <$> arbitraryTxSignature net)
]
-- | Arbitrary m of n parameters.
arbitraryMSParam :: Gen (Int, Int)
arbitraryMSParam = do
m <- choose (1, 16)
n <- choose (m, 16)
return (m, n)
-- | Arbitrary 'ScriptOutput' (Can by any valid type).
arbitraryScriptOutput :: Network -> Gen ScriptOutput
arbitraryScriptOutput net =
oneof $
[ arbitraryPKOutput
, arbitraryPKHashOutput
, arbitraryMSOutput
, arbitrarySHOutput
, arbitraryDCOutput
]
++ if getSegWit net
then
[ arbitraryWPKHashOutput
, arbitraryWSHOutput
, arbitraryWitOutput
]
else []
{- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS'
(Not 'PayScriptHash', 'DataCarrier', or SegWit)
-}
arbitrarySimpleOutput :: Gen ScriptOutput
arbitrarySimpleOutput =
oneof
[ arbitraryPKOutput
, arbitraryPKHashOutput
, arbitraryMSOutput
]
-- | Arbitrary 'ScriptOutput' of type 'PayPK'
arbitraryPKOutput :: Gen ScriptOutput
arbitraryPKOutput = PayPK . snd <$> arbitraryKeyPair
-- | Arbitrary 'ScriptOutput' of type 'PayPKHash'
arbitraryPKHashOutput :: Gen ScriptOutput
arbitraryPKHashOutput = PayPKHash <$> arbitraryHash160
-- | Arbitrary 'PayWitnessPKHash' output.
arbitraryWPKHashOutput :: Gen ScriptOutput
arbitraryWPKHashOutput = PayWitnessPKHash <$> arbitraryHash160
-- | Arbitrary 'PayWitnessScriptHash' output.
arbitraryWSHOutput :: Gen ScriptOutput
arbitraryWSHOutput = PayWitnessScriptHash <$> arbitraryHash256
arbitraryWitOutput :: Gen ScriptOutput
arbitraryWitOutput = do
ver <- choose (1, 16)
len <- choose (2, 40)
ws <- vectorOf len arbitrary
let bs = B.pack ws
return $ PayWitness ver bs
-- | Arbitrary 'ScriptOutput' of type 'PayMS'.
arbitraryMSOutput :: Gen ScriptOutput
arbitraryMSOutput = do
(m, n) <- arbitraryMSParam
keys <- map snd <$> vectorOf n arbitraryKeyPair
return $ PayMulSig keys m
-- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys.
arbitraryMSOutputC :: Gen ScriptOutput
arbitraryMSOutputC = do
(m, n) <- arbitraryMSParam
keys <-
map snd
<$> vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd))
return $ PayMulSig keys m
-- | Arbitrary 'ScriptOutput' of type 'PayScriptHash'.
arbitrarySHOutput :: Gen ScriptOutput
arbitrarySHOutput = PayScriptHash . getAddrHash160 <$> arbitraryScriptAddress
-- | Arbitrary 'ScriptOutput' of type 'DataCarrier'.
arbitraryDCOutput :: Gen ScriptOutput
arbitraryDCOutput = DataCarrier <$> arbitraryBS1
-- | Arbitrary 'ScriptInput'.
arbitraryScriptInput :: Network -> Gen ScriptInput
arbitraryScriptInput net =
oneof
[ arbitraryPKInput net
, arbitraryPKHashInput net
, arbitraryMSInput net
, arbitrarySHInput net
]
{- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig'
(not 'ScriptHashInput')
-}
arbitrarySimpleInput :: Network -> Gen ScriptInput
arbitrarySimpleInput net =
oneof
[ arbitraryPKInput net
, arbitraryPKHashInput net
, arbitraryMSInput net
]
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
arbitraryPKInput :: Network -> Gen ScriptInput
arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
arbitraryPKHashInput :: Network -> Gen ScriptInput
arbitraryPKHashInput net = do
sig <- arbitraryTxSignatureEmpty net
key <- snd <$> arbitraryKeyPair
return $ RegularInput $ SpendPKHash sig key
-- | Like 'arbitraryPKHashInput' without empty signatures.
arbitraryPKHashInputFull :: Network -> Gen ScriptInput
arbitraryPKHashInputFull net = do
sig <- lst3 <$> arbitraryTxSignature net
key <- snd <$> arbitraryKeyPair
return $ RegularInput $ SpendPKHash sig key
-- | Like above but only compressed.
arbitraryPKHashInputFullC :: Network -> Gen ScriptInput
arbitraryPKHashInputFullC net = do
sig <- lst3 <$> arbitraryTxSignature net
key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)
return $ RegularInput $ SpendPKHash sig key
-- | Arbitrary 'ScriptInput' of type 'SpendMulSig'.
arbitraryMSInput :: Network -> Gen ScriptInput
arbitraryMSInput net = do
m <- fst <$> arbitraryMSParam
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
return $ RegularInput $ SpendMulSig sigs
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput'.
arbitrarySHInput :: Network -> Gen ScriptInput
arbitrarySHInput net = do
i <- arbitrarySimpleInput net
ScriptHashInput (getRegularInput i) <$> arbitrarySimpleOutput
{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
-}
arbitraryMulSigSHInput :: Network -> Gen ScriptInput
arbitraryMulSigSHInput net =
arbitraryMSOutput >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
-}
arbitraryMulSigSHInputC :: Network -> Gen ScriptInput
arbitraryMulSigSHInputC net =
arbitraryMSOutputC >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput
arbitraryMulSigSHInputFull net =
arbitraryMSOutput >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput
arbitraryMulSigSHInputFullC net =
arbitraryMSOutputC >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined