packages feed

haskoin-script (empty) → 0.0.1

raw patch · 10 files changed

+925/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, binary, bytestring, haskoin-crypto, haskoin-protocol, haskoin-util, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ Network/Haskoin/Script.hs view
@@ -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:+-- <http://en.bitcoin.it/wiki/OP_CHECKSIG>+, SigHash(..)+, txSigHash+, encodeSigHash32+, isSigAll+, isSigNone+, isSigSingle+, isSigUnknown+, TxSignature(..)+, encodeSig+, decodeSig+, decodeCanonicalSig++) where++import Network.Haskoin.Script.Parser+import Network.Haskoin.Script.SigHash+
+ Network/Haskoin/Script/Arbitrary.hs view
@@ -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+                    ]+
+ Network/Haskoin/Script/Parser.hs view
@@ -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"+
+ Network/Haskoin/Script/SigHash.hs view
@@ -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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UNLICENSE view
@@ -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 <http://unlicense.org/>
+ haskoin-script.cabal view
@@ -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+
+ tests/Main.hs view
@@ -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 +    )+
+ tests/Network/Haskoin/Script/Tests.hs view
@@ -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)+
+ tests/Units.hs view
@@ -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"+      ) +    ]+