ScriptSpec.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Haskoin.ScriptSpec (spec) where

import Control.Monad
import Data.Aeson as A
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Default (def)
import Data.Either
import Data.List
import Data.Maybe
import Data.String
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Word
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.HUnit as HUnit
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Text.Read

identityTests :: Ctx -> IdentityTests
identityTests ctx =
  def
    { readTests =
        [ ReadBox arbitrarySigHash,
          ReadBox arbitrarySigHashFlag,
          ReadBox arbitraryScript,
          ReadBox arbitraryPushDataType,
          ReadBox arbitraryScriptOp,
          ReadBox ((`arbitraryScriptOutput` ctx) =<< arbitraryNetwork),
          ReadBox ((`arbitraryScriptInput` ctx) =<< arbitraryNetwork)
        ],
      jsonTests =
        [ JsonBox arbitraryScript,
          JsonBox arbitraryOutPoint,
          JsonBox arbitrarySigHash
        ],
      marshalJsonTests =
        [ MarshalJsonBox $ do
            n <- arbitraryNetwork
            (_, _, ts) <- arbitraryTxSignature n ctx
            return ((n, ctx), ts),
          MarshalJsonBox $ do
            n <- arbitraryNetwork
            o <- arbitraryScriptOutput n ctx
            return (ctx, o),
          MarshalJsonBox $ do
            n <- arbitraryNetwork
            (i, _) <- arbitrarySigInput n ctx
            return (ctx, i)
        ],
      serialTests =
        [ SerialBox arbitraryScriptOp,
          SerialBox arbitraryScript
        ],
      marshalTests =
        [ MarshalBox $ do
            n <- arbitraryNetwork
            (_, _, ts) <- arbitraryTxSignature n ctx
            return ((n, ctx), ts),
          MarshalBox $ do
            n <- arbitraryNetwork
            o <- arbitraryScriptOutput n ctx
            return (ctx, o),
          MarshalBox $ do
            n <- arbitraryNetwork
            i <- arbitraryScriptInput n ctx
            return ((n, ctx), i)
        ]
    }

spec :: Spec
spec = prepareContext $ \ctx -> do
  testIdentity $ identityTests ctx
  describe "btc scripts" $ props btc ctx
  describe "bch scripts" $ props bch ctx
  describe "multi signatures" $
    zipWithM_ (curry (mapMulSigVector ctx)) mulSigVectors [0 ..]
  describe "signature decoding" $
    zipWithM_ (curry (sigDecodeMap btc ctx)) scriptSigSignatures [0 ..]
  describe "SigHashFlag fromEnum/toEnum" $
    prop "fromEnum/toEnum" $
      forAll arbitrarySigHashFlag $
        \f -> toEnum (fromEnum f) `shouldBe` f
  describe "Script vectors" $
    it "Can encode script vectors" encodeScriptVector

props :: Network -> Ctx -> Spec
props net ctx = do
  standardSpec net ctx
  strictSigSpec net ctx
  scriptSpec net ctx
  txSigHashForkIdSpec net
  forkIdScriptSpec net ctx
  sigHashSpec net ctx
  txSigHashSpec net

standardSpec :: Network -> Ctx -> Spec
standardSpec net ctx = do
  prop "has intToScriptOp . scriptOpToInt identity" $
    forAll arbitraryIntScriptOp $ \i ->
      intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
  prop "has decodeOutput . encodeOutput identity" $
    forAll (arbitraryScriptOutput net ctx) $ \so ->
      decodeOutput ctx (encodeOutput ctx so) `shouldBe` Right so
  prop "has decodeInput . encodeOutput identity" $
    forAll (arbitraryScriptInput net ctx) $ \si ->
      (decodeInput net ctx . encodeInput net ctx) si `shouldBe` Right si
  prop "can sort multisig scripts" $
    forAll (arbitraryMSOutput ctx) $ \out ->
      let keyList = map (marshal ctx) (sortMulSig ctx out).keys
          isSorted xs = xs == sort xs
       in keyList `shouldSatisfy` isSorted
  it "can decode inputs with empty signatures" $ do
    decodeInput net ctx (Script [OP_0])
      `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
    decodeInput net ctx (Script [opPushData ""])
      `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
    let Just sk = secKey (B.replicate 32 1)
        pk = derivePublicKey ctx (wrapSecKey True sk)
    decodeInput net ctx (Script [OP_0, opPushData $ marshal ctx pk])
      `shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
    decodeInput net ctx (Script [OP_0, OP_0])
      `shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
    decodeInput net ctx (Script [OP_0, OP_0, OP_0, OP_0])
      `shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))

scriptSpec :: Network -> Ctx -> Spec
scriptSpec net ctx =
  when (net.name == "btc") $
    it "can verify standard scripts from script_tests.json file" $ do
      xs <- readTestFile "script_tests.json" :: IO [A.Value]
      let vectorsA =
            mapMaybe (A.decode . A.encode) xs ::
              [(String, String, String, String, String)]
          vectorsB =
            mapMaybe (A.decode . A.encode) xs ::
              [([Word64], String, String, String, String, String)]
          vectors =
            map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA
              <> vectorsB
      length vectors `shouldBe` 86
      forM_ vectors $ \([val], siStr, soStr, flags, res, desc) ->
        -- We can disable specific tests by adding a DISABLED flag in the data
        unless ("DISABLED" `isInfixOf` flags) $ do
          let _strict =
                any
                  (`isInfixOf` flags)
                  ["DERSIG", "STRICTENC", "NULLDUMMY"]
              scriptSig = parseScript siStr
              scriptPubKey = parseScript soStr
              out = unmarshal ctx scriptPubKey
              tx = spendTx scriptPubKey 0 scriptSig
              sat = val * 100000000
              ver o = verifyStdInput net ctx tx 0 o sat
              valid = either (const False) ver out
          assertBool desc $ if res == "OK" then valid else not valid

forkIdScriptSpec :: Network -> Ctx -> Spec
forkIdScriptSpec net ctx =
  when (isJust net.sigHashForkId) $
    it "can verify scripts from forkid_script_tests.json file" $ do
      xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value]
      let vectors =
            mapMaybe (A.decode . A.encode) xs ::
              [ ( [Word64],
                  String,
                  String,
                  String,
                  String,
                  String
                )
              ]
      length vectors `shouldBe` 3
      forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do
        let val = valBTC * 100000000
            scriptSig = parseScript siStr
            scriptPubKey = parseScript soStr
            out = unmarshal ctx scriptPubKey
            tx = spendTx scriptPubKey val scriptSig
            ver o = verifyStdInput net ctx tx 0 o val
            valid = either (const False) ver out
        case res of
          "OK" -> valid `shouldBe` True
          _ -> valid `shouldBe` False

creditTx :: ByteString -> Word64 -> Tx
creditTx scriptPubKey val =
  Tx 1 [txI] [txO] [] 0
  where
    txO = TxOut {value = val, script = scriptPubKey}
    txI =
      TxIn
        { outpoint = nullOutPoint,
          script = runPutS $ serialize $ Script [OP_0, OP_0],
          sequence = maxBound
        }

spendTx :: ByteString -> Word64 -> ByteString -> Tx
spendTx scriptPubKey val scriptSig =
  Tx 1 [txI] [txO] [] 0
  where
    txO = TxOut {value = val, script = B.empty}
    txI =
      TxIn
        { outpoint = OutPoint (txHash $ creditTx scriptPubKey val) 0,
          script = scriptSig,
          sequence = maxBound
        }

parseScript :: String -> ByteString
parseScript str =
  B.concat $ fromMaybe err $ mapM f $ words str
  where
    f = decodeHex . cs . dropHex . replaceToken
    dropHex ('0' : 'x' : xs) = xs
    dropHex xs = xs
    err = error $ "Could not decode script: " <> str

replaceToken :: String -> String
replaceToken str = case readMaybe $ "OP_" <> str of
  Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp))
  _ -> str

strictSigSpec :: Network -> Ctx -> Spec
strictSigSpec net ctx =
  when (net.name == "btc") $ do
    it "can decode strict signatures" $ do
      xs <- readTestFile "sig_strict.json"
      let vectors = mapMaybe decodeHex xs
      length vectors `shouldBe` 3
      forM_ vectors $ \sig ->
        let eitherSig :: Either String TxSignature
            eitherSig = decodeTxSig net ctx sig
         in eitherSig `shouldSatisfy` isRight
    it "can detect non-strict signatures" $ do
      xs <- readTestFile "sig_nonstrict.json"
      let vectors = mapMaybe decodeHex xs
      length vectors `shouldBe` 17
      forM_ vectors $ \sig ->
        let eitherSig = decodeTxSig net ctx sig
         in eitherSig `shouldSatisfy` isLeft

txSigHashSpec :: Network -> Spec
txSigHashSpec net =
  when (net.name == "btc") $
    it "can produce valid sighashes from sighash.json test vectors" $ do
      xs <- readTestFile "sighash.json" :: IO [A.Value]
      let vectors =
            mapMaybe (A.decode . A.encode) xs ::
              [ ( String,
                  String,
                  Int,
                  Integer,
                  String
                )
              ]
      length vectors `shouldBe` 500
      forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do
        let tx = fromString txStr
            s =
              fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
                eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
            sh = fromIntegral shI
            res =
              eitherToMaybe . runGetS deserialize . B.reverse
                =<< decodeHex (cs resStr)
        Just (txSigHash net tx s 0 i sh) `shouldBe` res

txSigHashForkIdSpec :: Network -> Spec
txSigHashForkIdSpec net =
  when (net.name == "btc") $
    it "can produce valid sighashes from forkid_sighash.json test vectors" $ do
      xs <- readTestFile "forkid_sighash.json" :: IO [A.Value]
      let vectors =
            mapMaybe (A.decode . A.encode) xs ::
              [ ( String,
                  String,
                  Int,
                  Word64,
                  Integer,
                  String
                )
              ]
      length vectors `shouldBe` 13
      forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do
        let tx = fromString txStr
            s =
              fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
                eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
            sh = fromIntegral shI
            res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr)
        Just (txSigHashForkId net tx s val i sh) `shouldBe` res

sigHashSpec :: Network -> Ctx -> Spec
sigHashSpec net ctx = do
  it "can correctly show" $ do
    show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32)
    show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32)
    show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32)
    show (0xabac3344 :: SigHash)
      `shouldBe` "SigHash "
        <> show (0xabac3344 :: Word32)
  it "can add a forkid" $ do
    0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
    0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
    0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
    0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
    0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
    0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
    0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
  it "can extract a forkid" $ do
    sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
    sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
    sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
    sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
  it "can build some vectors" $ do
    sigHashAll `shouldBe` 0x01
    sigHashNone `shouldBe` 0x02
    sigHashSingle `shouldBe` 0x03
    setForkIdFlag sigHashAll `shouldBe` 0x41
    setAnyoneCanPay sigHashAll `shouldBe` 0x81
    setAnyoneCanPay (setForkIdFlag sigHashAll) `shouldBe` 0xc1
  it "can test flags" $ do
    hasForkIdFlag sigHashAll `shouldBe` False
    hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
    anyoneCanPay sigHashAll `shouldBe` False
    anyoneCanPay (setAnyoneCanPay sigHashAll) `shouldBe` True
    isSigHashAll sigHashNone `shouldBe` False
    isSigHashAll sigHashAll `shouldBe` True
    isSigHashNone sigHashSingle `shouldBe` False
    isSigHashNone sigHashNone `shouldBe` True
    isSigHashSingle sigHashAll `shouldBe` False
    isSigHashSingle sigHashSingle `shouldBe` True
    isSigHashUnknown sigHashAll `shouldBe` False
    isSigHashUnknown sigHashNone `shouldBe` False
    isSigHashUnknown sigHashSingle `shouldBe` False
    isSigHashUnknown 0x00 `shouldBe` True
    isSigHashUnknown 0x04 `shouldBe` True
  it "can decodeTxSig . encode a TxSignature" $
    property $
      forAll (arbitraryTxSignature net ctx) $ \(_, _, ts) ->
        let f = decodeTxSig net ctx . encodeTxSig net ctx
         in f ts `shouldBe` Right ts
  it "can produce the sighash one" $
    property $
      forAll (arbitraryTx net ctx) $
        forAll arbitraryScript . testSigHashOne net

testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property
testSigHashOne net tx s val acp =
  not (null tx.inputs) ==>
    if length tx.inputs > length tx.outputs
      then res `shouldBe` one
      else res `shouldNotBe` one
  where
    res = txSigHash net tx s val (length tx.inputs - 1) (f sigHashSingle)
    one = "0100000000000000000000000000000000000000000000000000000000000000"
    f =
      if acp
        then setAnyoneCanPay
        else id

{- Parse tests from bitcoin-qt repository -}

mapMulSigVector :: Ctx -> ((Text, Text), Int) -> Spec
mapMulSigVector ctx (v, i) =
  it name $ runMulSigVector ctx v
  where
    name = "check multisig vector " <> show i

runMulSigVector :: Ctx -> (Text, Text) -> Assertion
runMulSigVector ctx (a, ops) = assertBool "multisig vector" $ Just a == b
  where
    s = do
      s' <- decodeHex ops
      eitherToMaybe $ runGetS deserialize s'
    b = do
      o <- s
      d <- eitherToMaybe $ decodeOutput ctx o
      addrToText btc $ payToScriptAddress ctx d

sigDecodeMap :: Network -> Ctx -> (Text, Int) -> Spec
sigDecodeMap net ctx (_, i) =
  it ("check signature " ++ show i) func
  where
    func = testSigDecode net ctx $ scriptSigSignatures !! i

testSigDecode :: Network -> Ctx -> Text -> Assertion
testSigDecode net ctx str =
  let bs = fromJust $ decodeHex str
      eitherSig = decodeTxSig net ctx bs
   in assertBool
        ( unwords
            [ "Decode failed:",
              fromLeft (error "Decode did not fail") eitherSig
            ]
        )
        $ isRight eitherSig

mulSigVectors :: [(Text, Text)]
mulSigVectors =
  [ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC",
      "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\
      \129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\
      \334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\
      \e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\
      \fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\
      \4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\
      \322a1863d4621353ae"
    )
  ]

scriptSigSignatures :: [Text]
scriptSigSignatures =
  -- Signature in input of txid
  -- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053
  [ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\
    \57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\
    \41a2b1e401"
    -- Signature in input of txid
    -- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d.
    -- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only
    -- decode strict signatures.
    -- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\
    -- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\
    -- \e18fe1e7d1510db501"
  ]

encodeScriptVector :: Assertion
encodeScriptVector =
  assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s)
  where
    res =
      "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\
      \bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\
      \348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\
      \cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\
      \25c15342af52ae"
    s =
      Script
        [ OP_1,
          opPushData $
            d
              "04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\
              \8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\
              \11fcdd0d348ac4",
          opPushData $
            d
              "0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\
              \deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\
              \f58b25c15342af",
          OP_2,
          OP_CHECKMULTISIG
        ]
    d = fromJust . decodeHex