diff --git a/Network/Haskoin/Script.hs b/Network/Haskoin/Script.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script.hs @@ -0,0 +1,56 @@ +{-| + This package provides functions for parsing and evaluating bitcoin + transaction scripts. Data types are provided for building and + deconstructing all of the standard input and output script types. +-} +module Network.Haskoin.Script +( + -- *Script Parsing + -- **Script Outputs + ScriptOutput(..) +, encodeOutput +, decodeOutput +, isPayPK +, isPayPKHash +, isPayMulSig +, isPayScriptHash +, scriptAddr +, sortMulSig + -- **Script Inputs +, ScriptInput(..) +, encodeInput +, decodeInput +, isSpendPK +, isSpendPKHash +, isSpendMulSig + -- **ScriptHash Inputs +, ScriptHashInput(..) +, RedeemScript +, encodeScriptHash +, decodeScriptHash + -- * Helpers +, scriptRecipient +, scriptSender +, intToScriptOp +, scriptOpToInt + +-- *SigHash +-- | For additional information on sighashes, see: +-- +, SigHash(..) +, txSigHash +, encodeSigHash32 +, isSigAll +, isSigNone +, isSigSingle +, isSigUnknown +, TxSignature(..) +, encodeSig +, decodeSig +, decodeCanonicalSig + +) where + +import Network.Haskoin.Script.Parser +import Network.Haskoin.Script.SigHash + diff --git a/Network/Haskoin/Script/Arbitrary.hs b/Network/Haskoin/Script/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script/Arbitrary.hs @@ -0,0 +1,85 @@ +{-| + This module provides arbitrary instances for data types in + 'Network.Haskoin.Script'. +-} +module Network.Haskoin.Script.Arbitrary where + +import Test.QuickCheck + ( Gen + , Arbitrary + , arbitrary + , oneof + , choose + , vectorOf + , elements + ) +import Network.Haskoin.Crypto.Arbitrary() + +import Control.Monad (liftM2) +import Control.Applicative ((<$>),(<*>)) + +import Data.Bits (testBit, clearBit) +import Data.Word (Word8) + +import Network.Haskoin.Script +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto + +instance Arbitrary TxSignature where + arbitrary = liftM2 TxSignature arbitrary arbitrary + +instance Arbitrary SigHash where + arbitrary = do + w <- arbitrary :: Gen Word8 + let acp = testBit w 7 + return $ case clearBit w 7 of + 1 -> SigAll acp + 2 -> SigNone acp + 3 -> SigSingle acp + _ -> SigUnknown acp w + +instance Arbitrary ScriptOutput where + arbitrary = oneof + [ PayPK <$> arbitrary + , (PayPKHash . pubKeyAddr) <$> arbitrary + , genPayMulSig + , (PayScriptHash . scriptAddr) <$> arbitrary + ] + +-- | Generate an arbitrary 'ScriptOutput' of value PayMulSig. +genPayMulSig :: Gen ScriptOutput +genPayMulSig = do + n <- choose (1,16) + m <- choose (1,n) + PayMulSig <$> (vectorOf n arbitrary) <*> (return m) + +instance Arbitrary ScriptInput where + arbitrary = oneof + [ SpendPK <$> arbitrary + , SpendPKHash <$> arbitrary <*> arbitrary + , genSpendMulSig + ] + +-- | Generate an arbitrary 'ScriptInput' of value SpendMulSig. +genSpendMulSig :: Gen ScriptInput +genSpendMulSig = do + m <- choose (1,16) + s <- choose (1,m) + SpendMulSig <$> (vectorOf s arbitrary) <*> (return m) + +instance Arbitrary ScriptHashInput where + arbitrary = ScriptHashInput <$> arbitrary <*> arbitrary + +-- | Data type for generating an arbitrary 'ScriptOp' with a value in +-- [OP_1 .. OP_16] +data ScriptOpInt = ScriptOpInt ScriptOp + deriving (Eq, Show) + +instance Arbitrary ScriptOpInt where + arbitrary = ScriptOpInt <$> 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 + ] + diff --git a/Network/Haskoin/Script/Parser.hs b/Network/Haskoin/Script/Parser.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script/Parser.hs @@ -0,0 +1,285 @@ +module Network.Haskoin.Script.Parser +( ScriptOutput(..) +, ScriptInput(..) +, RedeemScript +, ScriptHashInput(..) +, scriptAddr +, scriptRecipient +, scriptSender +, encodeInput +, decodeInput +, encodeOutput +, decodeOutput +, encodeScriptHash +, decodeScriptHash +, sortMulSig +, intToScriptOp +, scriptOpToInt +, isPayPK +, isPayPKHash +, isPayMulSig +, isPayScriptHash +, isSpendPK +, isSpendPKHash +, isSpendMulSig +) where + +import Control.Monad (liftM2) +import Control.Applicative ((<$>),(<*>)) + +import Data.List (sortBy) +import qualified Data.ByteString as BS (head, singleton) + +import Network.Haskoin.Script.SigHash +import Network.Haskoin.Crypto +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +-- | Data type describing standard transaction output scripts. Output scripts +-- provide the conditions that must be fulfilled for someone to spend the +-- output coins. +data ScriptOutput = + -- | Pay to a public key. + PayPK { getOutputPubKey :: !PubKey } + -- | Pay to a public key hash. + | PayPKHash { getOutputAddress :: !Address } + -- | Pay to multiple public keys. + | PayMulSig { getOutputMulSigKeys :: ![PubKey] + , getOutputMulSigRequired :: !Int + } + -- | Pay to a script hash. + | PayScriptHash { getOutputAddress :: !Address } + deriving (Eq, Show) + +-- | Returns True if the script is a pay to public key output. +isPayPK :: ScriptOutput -> Bool +isPayPK (PayPK _) = True +isPayPK _ = False + +-- | Returns True if the script is a pay to public key hash output. +isPayPKHash :: ScriptOutput -> Bool +isPayPKHash (PayPKHash _) = True +isPayPKHash _ = False + +-- | Returns True if the script is a pay to multiple public keys output. +isPayMulSig :: ScriptOutput -> Bool +isPayMulSig (PayMulSig _ _) = True +isPayMulSig _ = False + +-- | Returns true if the script is a pay to script hash output. +isPayScriptHash :: ScriptOutput -> Bool +isPayScriptHash (PayScriptHash _) = True +isPayScriptHash _ = False + +-- | Computes a script address from a script output. This address can be used +-- in a pay to script hash output. +scriptAddr :: ScriptOutput -> Address +scriptAddr = ScriptAddress . hash160 . hash256BS . toBS + where + toBS = encodeScriptOps . encodeOutput + +-- | Sorts the public keys of a multisignature output in ascending order by +-- comparing their serialized representations. This feature allows for easier +-- multisignature account management as participants in a multisignature wallet +-- will blindly agree on an ordering of the public keys without having to +-- communicate. +sortMulSig :: ScriptOutput -> ScriptOutput +sortMulSig out = case out of + PayMulSig keys r -> PayMulSig (sortBy f keys) r + _ -> error "Can only call orderMulSig on PayMulSig scripts" + where + f a b = encode' a `compare` encode' b + +-- | Computes a 'Script' from a 'ScriptOutput'. The 'Script' is a list of +-- 'ScriptOp' can can be used to build a 'Tx'. +encodeOutput :: ScriptOutput -> Script +encodeOutput s = Script $ case s of + -- Pay to PubKey + (PayPK k) -> [OP_PUSHDATA $ encode' k, OP_CHECKSIG] + -- Pay to PubKey Hash Address + (PayPKHash a) -> case a of + (PubKeyAddress h) -> [ OP_DUP, OP_HASH160, OP_PUSHDATA $ encode' h + , OP_EQUALVERIFY, OP_CHECKSIG + ] + (ScriptAddress _) -> + error "encodeOutput: ScriptAddress is invalid in PayPKHash" + -- Pay to MultiSig Keys + (PayMulSig ps r) + | r <= length ps -> + let opM = intToScriptOp r + opN = intToScriptOp $ length ps + keys = map (OP_PUSHDATA . encode') ps + in opM : keys ++ [opN, OP_CHECKMULTISIG] + | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" + -- Pay to Script Hash Address + (PayScriptHash a) -> case a of + (ScriptAddress h) -> [ OP_HASH160 + , OP_PUSHDATA $ encode' h, OP_EQUAL + ] + (PubKeyAddress _) -> + error "encodeOutput: PubKeyAddress is invalid in PayScriptHash" + +-- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the +-- script is not recognized as any of the standard output types. +decodeOutput :: Script -> Either String ScriptOutput +decodeOutput s = case scriptOps s of + -- Pay to PubKey + [OP_PUSHDATA bs, OP_CHECKSIG] -> PayPK <$> decodeToEither bs + -- Pay to PubKey Hash + [OP_DUP, OP_HASH160, OP_PUSHDATA bs, OP_EQUALVERIFY, OP_CHECKSIG] -> + (PayPKHash . PubKeyAddress) <$> decodeToEither bs + -- Pay to Script Hash + [OP_HASH160, OP_PUSHDATA bs, OP_EQUAL] -> + (PayScriptHash . ScriptAddress) <$> decodeToEither bs + -- Pay to MultiSig Keys + _ -> matchPayMulSig s + +-- Match [ OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG ] +matchPayMulSig :: Script -> Either String ScriptOutput +matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of + (m:xs,[n,OP_CHECKMULTISIG]) -> do + (intM,intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n) + if intM <= intN && length xs == intN + then liftM2 PayMulSig (go xs) (return intM) + else Left "matchPayMulSig: Invalid M or N parameters" + _ -> Left "matchPayMulSig: script did not match output template" + where + go (OP_PUSHDATA bs:xs) = liftM2 (:) (decodeToEither bs) (go xs) + go [] = return [] + go _ = Left "matchPayMulSig: invalid multisig opcode" + +-- | Transforms integers [1 .. 16] to 'ScriptOp' [OP_1 .. OP_16] +intToScriptOp :: Int -> ScriptOp +intToScriptOp i + | i `elem` [1..16] = op + | otherwise = error $ "intToScriptOp: Invalid integer " ++ (show i) + where + op = decode' $ BS.singleton $ fromIntegral $ i + 0x50 + +-- | Decode 'ScriptOp' [OP_1 .. OP_16] to integers [1 .. 16]. This functions +-- fails for other values of 'ScriptOp' +scriptOpToInt :: ScriptOp -> Either String Int +scriptOpToInt s + | res `elem` [1..16] = return res + | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ (show s) + where + res = (fromIntegral $ BS.head $ encode' s) - 0x50 + +-- | Computes the recipient address of a script. This function fails if the +-- script could not be decoded as a pay to public key hash or pay to script +-- hash. +scriptRecipient :: Script -> Either String Address +scriptRecipient s = case decodeOutput s of + Right (PayPKHash a) -> return a + Right (PayScriptHash a) -> return a + Right _ -> Left "scriptRecipient: bad output script type" + _ -> Left "scriptRecipient: non-standard script type" + +-- | Computes the sender address of a script. This function fails if the +-- script could not be decoded as a spend public key hash or script hash +-- input. +scriptSender :: Script -> Either String Address +scriptSender s = case decodeInput s of + Right (SpendPKHash _ key) -> return $ pubKeyAddr key + Right _ -> Left "scriptSender: bad input script type" + _ -> case decodeScriptHash s of + Right (ScriptHashInput _ rdm) -> return $ scriptAddr rdm + _ -> Left "scriptSender: non-standard script type" + +-- | Data type describing standard transaction input scripts. Input scripts +-- provide the signing data required to unlock the coins of the output they are +-- trying to spend. +data ScriptInput = + -- | Spend the coins of a PayPK output. + SpendPK { getInputSig :: !TxSignature } + -- | Spend the coins of a PayPKHash output. + | SpendPKHash { getInputSig :: !TxSignature + , getInputKey :: !PubKey + } + -- | Spend the coins of a PayMulSig output. + | SpendMulSig { getInputMulSigKeys :: ![TxSignature] + , getInputMulSigRequired :: !Int + } + deriving (Eq, Show) + +-- | Returns True if the input script is spending a public key. +isSpendPK :: ScriptInput -> Bool +isSpendPK (SpendPK _) = True +isSpendPK _ = False + +-- | Returns True if the input script is spending a public key hash. +isSpendPKHash :: ScriptInput -> Bool +isSpendPKHash (SpendPKHash _ _) = True +isSpendPKHash _ = False + +-- | Returns True if the input script is spending a multisignature output. +isSpendMulSig :: ScriptInput -> Bool +isSpendMulSig (SpendMulSig _ _) = True +isSpendMulSig _ = False + +-- | Computes a 'Script' from a 'ScriptInput'. The 'Script' is a list of +-- 'ScriptOp' can can be used to build a 'Tx'. +encodeInput :: ScriptInput -> Script +encodeInput s = Script $ case s of + SpendPK ts -> [ OP_PUSHDATA $ encodeSig ts ] + SpendPKHash ts p -> [ OP_PUSHDATA $ encodeSig ts + , OP_PUSHDATA $ encode' p + ] + SpendMulSig ts r + | length ts <= 16 && r >= 1 && r <= 16 -> + let sigs = map (OP_PUSHDATA . encodeSig) ts + in OP_0 : sigs ++ replicate (r - length ts) OP_0 + | otherwise -> error "SpendMulSig: Bad multisig parameters" + +-- | Decodes a 'ScriptInput' from a 'Script'. This function fails if the +-- script can not be parsed as a standard script input. +decodeInput :: Script -> Either String ScriptInput +decodeInput s = case scriptOps s of + [OP_PUSHDATA bs] -> SpendPK <$> decodeSig bs + [OP_PUSHDATA sig, OP_PUSHDATA p] -> + liftM2 SpendPKHash (decodeSig sig) (decodeToEither p) + (OP_0 : xs) -> matchSpendMulSig $ Script xs + _ -> Left "decodeInput: Script did not match input templates" + +matchSpendMulSig :: Script -> Either String ScriptInput +matchSpendMulSig (Script ops) = + liftM2 SpendMulSig (go ops) (return $ length ops) + where + go (OP_PUSHDATA bs:xs) = liftM2 (:) (decodeSig bs) (go xs) + go (OP_0:xs) + | all (== OP_0) xs = return [] + | otherwise = Left "matchSpendMulSig: invalid opcode after OP_0" + go [] = return [] + go _ = Left "matchSpendMulSig: invalid multisig opcode" + +type RedeemScript = ScriptOutput + +-- | Data type describing an input script spending a pay to script hash +-- output. To spend a script hash output, an input script must provide +-- both a redeem script and a regular input script spending the redeem +-- script. +data ScriptHashInput = ScriptHashInput + { -- | Input script spending the redeem script + spendSHInput :: ScriptInput + -- | Redeem script + , spendSHOutput :: RedeemScript + } deriving (Eq, Show) + +-- | Compute a 'Script' from a 'ScriptHashInput'. The 'Script' is a list of +-- 'ScriptOp' can can be used to build a 'Tx'. +encodeScriptHash :: ScriptHashInput -> Script +encodeScriptHash (ScriptHashInput i o) = + Script $ (scriptOps si) ++ [OP_PUSHDATA $ encodeScriptOps so] + where + si = encodeInput i + so = encodeOutput o + +-- | Tries to decode a 'ScriptHashInput' from a 'Script'. This function fails +-- if the script can not be parsed as a script hash input. +decodeScriptHash :: Script -> Either String ScriptHashInput +decodeScriptHash (Script ops) = case splitAt (length ops - 1) ops of + (is,[OP_PUSHDATA bs]) -> + ScriptHashInput <$> (decodeInput $ Script is) + <*> (decodeOutput =<< decodeScriptOps bs) + _ -> Left "decodeScriptHash: Script did not match input template" + diff --git a/Network/Haskoin/Script/SigHash.hs b/Network/Haskoin/Script/SigHash.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script/SigHash.hs @@ -0,0 +1,197 @@ +module Network.Haskoin.Script.SigHash +( SigHash(..) +, encodeSigHash32 +, isSigAll +, isSigNone +, isSigSingle +, isSigUnknown +, txSigHash +, TxSignature(..) +, encodeSig +, decodeSig +, decodeCanonicalSig +) where + +import Control.Monad (liftM2) + +import Data.Word (Word8) +import Data.Bits (testBit, clearBit, setBit) +import Data.Maybe (fromMaybe) +import Data.Binary (Binary, get, put, getWord8, putWord8) +import qualified Data.ByteString as BS + ( ByteString + , index + , length + , last + , append + , pack + , splitAt + ) + +import Network.Haskoin.Crypto +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +-- | Data type representing the different ways a transaction can be signed. +-- When producing a signature, a hash of the transaction is used as the message +-- to be signed. The 'SigHash' parameter controls which parts of the +-- transaction are used or ignored to produce the transaction hash. The idea is +-- that if some part of a transaction is not used to produce the transaction +-- hash, then you can change that part of the transaction after producing a +-- signature without invalidating that signature. +-- +-- If the anyoneCanPay flag is True, then only the current input is signed. +-- Otherwise, all of the inputs of a transaction are signed. The default value +-- for anyoneCanPay is False. +data SigHash + -- | Sign all of the outputs of a transaction (This is the default value). + -- Changing any of the outputs of the transaction will invalidate the + -- signature. + = SigAll { anyoneCanPay :: Bool } + -- | Sign none of the outputs of a transaction. This allows anyone to + -- change any of the outputs of the transaction. + | SigNone { anyoneCanPay :: Bool } + -- | Sign only the output corresponding the the current transaction input. + -- You care about your own output in the transaction but you don't + -- care about any of the other outputs. + | SigSingle { anyoneCanPay :: Bool } + -- | Unrecognized sighash types will decode to SigUnknown. + | SigUnknown { anyoneCanPay :: Bool + , getSigCode :: Word8 + } + deriving (Eq, Show) + +-- | Returns True if the 'SigHash' has the value SigAll. +isSigAll :: SigHash -> Bool +isSigAll sh = case sh of + SigAll _ -> True + _ -> False + +-- | Returns True if the 'SigHash' has the value SigNone. +isSigNone :: SigHash -> Bool +isSigNone sh = case sh of + SigNone _ -> True + _ -> False + +-- | Returns True if the 'SigHash' has the value SigSingle. +isSigSingle :: SigHash -> Bool +isSigSingle sh = case sh of + SigSingle _ -> True + _ -> False + +-- | Returns True if the 'SigHash' has the value SigUnknown. +isSigUnknown :: SigHash -> Bool +isSigUnknown sh = case sh of + SigUnknown _ _ -> True + _ -> False + +instance Binary SigHash where + + get = getWord8 >>= \w -> + let acp = testBit w 7 + in return $ case clearBit w 7 of + 1 -> SigAll acp + 2 -> SigNone acp + 3 -> SigSingle acp + _ -> SigUnknown acp w + + put sh = putWord8 $ case sh of + SigAll acp -> if acp then 0x81 else 0x01 + SigNone acp -> if acp then 0x82 else 0x02 + SigSingle acp -> if acp then 0x83 else 0x03 + SigUnknown _ w -> w + +-- | Encodes a 'SigHash' to a 32 bit-long bytestring. +encodeSigHash32 :: SigHash -> BS.ByteString +encodeSigHash32 sh = encode' sh `BS.append` BS.pack [0,0,0] + +-- | Computes the hash that will be used for signing a transaction. +txSigHash :: Tx -- ^ Transaction to sign. + -> Script -- ^ Output script that is being spent. + -> Int -- ^ Index of the input that is being signed. + -> SigHash -- ^ What parts of the transaction should be signed. + -> Hash256 -- ^ Result hash to be signed. +txSigHash tx out i sh = do + let newIn = buildInputs (txIn tx) out i sh + -- When SigSingle and input index > outputs, then sign integer 1 + fromMaybe (setBit 0 248) $ do + newOut <- buildOutputs (txOut tx) i sh + let newTx = tx{ txIn = newIn, txOut = newOut } + return $ doubleHash256 $ encode' newTx `BS.append` encodeSigHash32 sh + +-- Builds transaction inputs for computing SigHashes +buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] +buildInputs txins out i sh + | anyoneCanPay sh = (txins !! i) { scriptInput = out } : [] + | isSigAll sh || isSigUnknown sh = single + | otherwise = map noSeq $ zip single [0..] + where + empty = map (\ti -> ti{ scriptInput = Script [] }) txins + single = updateIndex i empty $ \ti -> ti{ scriptInput = out } + noSeq (ti,j) = if i == j then ti else ti{ txInSequence = 0 } + +-- Build transaction outputs for computing SigHashes +buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] +buildOutputs txos i sh + | isSigAll sh || isSigUnknown sh = return txos + | isSigNone sh = return [] + | i >= length txos = Nothing + | otherwise = return $ buffer ++ [txos !! i] + where + buffer = replicate i $ TxOut (-1) $ Script [] + +-- | Data type representing a 'Signature' together with a 'SigHash'. The +-- 'SigHash' is serialized as one byte at the end of a regular ECDSA +-- 'Signature'. All signatures in transaction inputs are of type 'TxSignature'. +data TxSignature = TxSignature + { txSignature :: Signature + , sigHashType :: SigHash + } deriving (Eq, Show) + +-- | Serialize a 'TxSignature' to a ByteString. +encodeSig :: TxSignature -> BS.ByteString +encodeSig (TxSignature sig sh) = runPut' $ put sig >> put sh + +-- | Decode a 'TxSignature' from a ByteString. +decodeSig :: BS.ByteString -> Either String TxSignature +decodeSig bs = do + let (h,l) = BS.splitAt (BS.length bs - 1) bs + liftM2 TxSignature (decodeToEither h) (decodeToEither l) + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- | Decode a 'TxSignature' from a ByteString. This function will check if +-- the signature is canonical and fail if it is not. +decodeCanonicalSig :: BS.ByteString -> Either String TxSignature +decodeCanonicalSig bs + | len < 9 = Left "Non-canonical signature: too short" + | len > 73 = Left "Non-canonical signature: too long" + | hashtype < 1 || hashtype > 3 = + Left" Non-canonical signature: unknown hashtype byte" + | BS.index bs 0 /= 0x30 = Left "Non-canonical signature: wrong type" + | BS.index bs 1 /= len - 3 = + Left "Non-canonical signature: wrong length marker" + | 5 + rlen >= len = Left "Non-canonical signature: S length misplaced" + | rlen + slen + 7 /= len = + Left "Non-canonical signature: R+S length mismatch" + | BS.index bs 2 /= 0x02 = + Left "Non-canonical signature: R value type mismatch" + | rlen == 0 = Left "Non-canonical signature: R length is zero" + | testBit (BS.index bs 4) 7 = + Left "Non-canonical signature: R value negative" + | rlen > 1 && BS.index bs 4 == 0 && not (testBit (BS.index bs 5) 7) = + Left "Non-canonical signature: R value excessively padded" + | BS.index bs (fromIntegral rlen+4) /= 0x02 = + Left "Non-canonical signature: S value type mismatch" + | slen == 0 = Left "Non-canonical signature: S length is zero" + | testBit (BS.index bs (fromIntegral rlen+6)) 7 = + Left "Non-canonical signature: S value negative" + | slen > 1 && BS.index bs (fromIntegral rlen+6) == 0 + && not (testBit (BS.index bs (fromIntegral rlen+7)) 7) = + Left "Non-canonical signature: S value excessively padded" + | otherwise = decodeSig bs + where + len = fromIntegral $ BS.length bs + rlen = BS.index bs 3 + slen = BS.index bs (fromIntegral rlen + 5) + hashtype = clearBit (BS.last bs) 7 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +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 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. + +For more information, please refer to diff --git a/haskoin-script.cabal b/haskoin-script.cabal new file mode 100644 --- /dev/null +++ b/haskoin-script.cabal @@ -0,0 +1,57 @@ +name: haskoin-script +version: 0.0.1 +synopsis: Implementation of Bitcoin script parsing and evaluation +description: + This package provides functions for parsing and evaluating bitcoin + transaction scripts. Data types are provided for building and + deconstructing all of the standard input and output script types. +homepage: http://github.com/plaprade/haskoin-script +bug-reports: http://github.com/plaprade/haskoin-script/issues +stability: experimental +license: PublicDomain +license-file: UNLICENSE +author: Philippe Laprade +maintainer: plaprade+hackage@gmail.com +category: Bitcoin, Finance, Network +build-type: Simple +cabal-version: >= 1.9.2 + +source-repository head + type: git + location: git://github.com/plaprade/haskoin-script.git + +library + exposed-modules: Network.Haskoin.Script, + Network.Haskoin.Script.Arbitrary + other-modules: Network.Haskoin.Script.Parser, + Network.Haskoin.Script.SigHash + build-depends: base >= 4.6 && < 4.7, + binary >= 0.7 && < 0.8, + bytestring >= 0.10 && < 0.11, + mtl >= 2.1 && < 2.2, + haskoin-protocol >= 0.0 && < 0.1, + haskoin-crypto >= 0.0 && < 0.1, + haskoin-util >= 0.0 && < 0.1, + QuickCheck >= 2.6 && < 2.7 + ghc-options: -Wall -fno-warn-orphans + +test-suite test-haskoin-script + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Network.Haskoin.Script.Tests, + Units + build-depends: base >= 4.6 && < 4.7, + binary >= 0.7 && < 0.8, + bytestring >= 0.10 && < 0.11, + mtl >= 2.1 && < 2.2, + haskoin-protocol >= 0.0 && < 0.1, + haskoin-crypto >= 0.0 && < 0.1, + haskoin-util >= 0.0 && < 0.1, + QuickCheck >= 2.6 && < 2.7, + test-framework >= 0.8 && < 0.9, + test-framework-quickcheck2 >= 0.3 && < 0.4, + test-framework-hunit >= 0.3 && < 0.4, + HUnit >= 1.2 && < 1.3 + hs-source-dirs: . tests + ghc-options: -Wall -fno-warn-orphans + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Test.Framework (defaultMain) + +import qualified Network.Haskoin.Script.Tests (tests) +import qualified Units (tests) + +main :: IO () +main = defaultMain + ( Network.Haskoin.Script.Tests.tests + ++ Units.tests + ) + diff --git a/tests/Network/Haskoin/Script/Tests.hs b/tests/Network/Haskoin/Script/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Script/Tests.hs @@ -0,0 +1,116 @@ +module Network.Haskoin.Script.Tests (tests) where + +import Test.QuickCheck.Property (Property, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Applicative ((<$>)) + +import Data.Bits (setBit, testBit) +import Data.Binary (Word8) +import qualified Data.ByteString as BS + ( singleton + , length + , tail + , head + , pack + ) + +import Network.Haskoin.Protocol.Arbitrary () +import Network.Haskoin.Script.Arbitrary (ScriptOpInt(..)) + +import Network.Haskoin.Script +import Network.Haskoin.Crypto +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Script Parser" + [ testProperty "decode . encode OP_1 .. OP_16" testScriptOpInt + , testProperty "decode . encode ScriptOutput" testScriptOutput + , testProperty "decode . encode ScriptInput" testScriptInput + , testProperty "decode . encode ScriptHashInput" testScriptHashInput + , testProperty "sorting MultiSig scripts" testSortMulSig + ] + , testGroup "Script SigHash" + [ testProperty "canonical signatures" testCanonicalSig + , testProperty "decode . encode SigHash" binSigHash + , testProperty "decode SigHash from Word8" binSigHashByte + , testProperty "encodeSigHash32 is 4 bytes long" testEncodeSH32 + , testProperty "decode . encode TxSignature" binTxSig + , testProperty "decodeCanonical . encode TxSignature" binTxSigCanonical + , testProperty "Testing txSigHash with SigSingle" testSigHashOne + ] + ] + +{- Script Parser -} + +testScriptOpInt :: ScriptOpInt -> Bool +testScriptOpInt (ScriptOpInt i) = (intToScriptOp <$> scriptOpToInt i) == Right i + +testScriptOutput :: ScriptOutput -> Bool +testScriptOutput so = (decodeOutput $ encodeOutput so) == Right so + +testScriptInput :: ScriptInput -> Bool +testScriptInput si = (decodeInput $ encodeInput si) == Right si + +testScriptHashInput :: ScriptHashInput -> Bool +testScriptHashInput sh = (decodeScriptHash $ encodeScriptHash sh) == Right sh + +testSortMulSig :: ScriptOutput -> Bool +testSortMulSig out = case out of + (PayMulSig _ _) -> check $ sortMulSig out + _ -> True + where check (PayMulSig ps _) + | length ps <= 1 = True + | otherwise = snd $ foldl f (head ps,True) $ tail ps + check _ = False + f (a,t) b | t && encode' a <= encode' b = (b,True) + | otherwise = (b,False) + +{- Script SigHash -} + +testCanonicalSig :: TxSignature -> Bool +testCanonicalSig ts@(TxSignature _ sh) + | isSigUnknown sh = isLeft $ decodeCanonicalSig bs + | otherwise = isRight (decodeCanonicalSig bs) && + isCanonicalHalfOrder (txSignature ts) + where bs = encodeSig ts + +binSigHash :: SigHash -> Bool +binSigHash sh = (decode' $ encode' sh) == sh + +binSigHashByte :: Word8 -> Bool +binSigHashByte w + | w == 0x01 = res == SigAll False + | w == 0x02 = res == SigNone False + | w == 0x03 = res == SigSingle False + | w == 0x81 = res == SigAll True + | w == 0x82 = res == SigNone True + | w == 0x83 = res == SigSingle True + | testBit w 7 = res == SigUnknown True w + | otherwise = res == SigUnknown False w + where res = decode' $ BS.singleton w + +testEncodeSH32 :: SigHash -> Bool +testEncodeSH32 sh = BS.length bs == 4 && BS.head bs == w && BS.tail bs == zs + where bs = encodeSigHash32 sh + w = BS.head $ encode' sh + zs = BS.pack [0,0,0] + +binTxSig :: TxSignature -> Bool +binTxSig ts = (fromRight $ decodeSig $ encodeSig ts) == ts + +binTxSigCanonical :: TxSignature -> Bool +binTxSigCanonical ts@(TxSignature _ sh) + | isSigUnknown sh = isLeft $ decodeCanonicalSig $ encodeSig ts + | otherwise = (fromRight $ decodeCanonicalSig $ encodeSig ts) == ts + +testSigHashOne :: Tx -> Script -> Bool -> Property +testSigHashOne tx s acp = not (null $ txIn tx) ==> + if length (txIn tx) > length (txOut tx) + then res == (setBit 0 248) + else res /= (setBit 0 248) + where res = txSigHash tx s (length (txIn tx) - 1) (SigSingle acp) + diff --git a/tests/Units.hs b/tests/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Units.hs @@ -0,0 +1,90 @@ +module Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust) + +import Network.Haskoin.Script +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Canonical signatures" + (map canonicalVectorsMap $ zip canonicalVectors [0..]) + , testGroup "Non canonical sigatures" + (map notCanonicalVectorsMap $ zip notCanonicalVectors [0..]) + , testGroup "Multi Signatures" + (map mapMulSigVector $ zip mulSigVectors [0..]) + ] + +canonicalVectorsMap :: (String,Int) -> Test.Framework.Test +canonicalVectorsMap (_,i) = testCase ("Canonical Sig " ++ (show i)) func + where func = testCanonicalSig $ canonicalVectors !! i + +notCanonicalVectorsMap :: (String,Int) -> Test.Framework.Test +notCanonicalVectorsMap (_,i) = testCase ("Not canonical Sig " ++ (show i)) func + where func = testNotCanonicalSig $ notCanonicalVectors !! i + +testCanonicalSig :: String -> Assertion +testCanonicalSig str = assertBool " > Canonical Sig" $ + isRight $ decodeCanonicalSig bs + where bs = fromJust $ hexToBS str + +testNotCanonicalSig :: String -> Assertion +testNotCanonicalSig str = assertBool " > Not canonical sig" $ + isLeft $ decodeCanonicalSig bs + where bs = fromJust $ hexToBS str + +mapMulSigVector :: ((String,String),Int) -> Test.Framework.Test +mapMulSigVector (v,i) = testCase name $ runMulSigVector v + where name = "MultiSignature vector " ++ (show i) + +runMulSigVector :: (String,String) -> Assertion +runMulSigVector (a,ops) = assertBool " > MultiSig Vector" $ + a == (addrToBase58 $ scriptAddr $ fromRight $ decodeOutput s) + where s = Script $ runGet' getScriptOps $ fromJust $ hexToBS ops + +{- Canonical Signatures -} + +-- Test vectors from bitcoind +-- http://github.com/bitcoin/bitcoin/blob/master/src/test/data/sig_canonical.json + +canonicalVectors :: [String] +canonicalVectors = + [ "300602010102010101" -- Changed 0x00 to 0x01 as 0x00 is invalid + , "3008020200ff020200ff01" + , "304402203932c892e2e550f3af8ee4ce9c215a87f9bb831dcac87b2838e2c2eaa891df0c022030b61dd36543125d56b9f9f3a1f9353189e5af33cdda8d77a5209aec03978fa001" + , "30450220076045be6f9eca28ff1ec606b833d0b87e70b2a630f5e3a496b110967a40f90a0221008fffd599910eefe00bc803c688c2eca1d2ba7f6b180620eaa03488e6585db6ba01" + , "3046022100876045be6f9eca28ff1ec606b833d0b87e70b2a630f5e3a496b110967a40f90a0221008fffd599910eefe00bc803c688c2eca1d2ba7f6b180620eaa03488e6585db6ba01" + ] + +notCanonicalVectors :: [String] +notCanonicalVectors = + [ "30050201ff020001" + , "30470221005990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba6105022200002d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed11" + , "314402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304502205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "301f01205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb101" + , "304502205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed0001" + , "304401205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "3024020002202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304402208990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "30450221005990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610501202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "302402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba6105020001" + , "304402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba61050220fd5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304502205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba61050221002d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + ] + +mulSigVectors :: [(String,String)] +mulSigVectors = + [ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC" + , "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccffef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f9974ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f322a1863d4621353ae" + ) + ] +