haskoin 0.0.2.1 → 0.1.0

raw patch · 86 files changed

+5598/−3417 lines, 86 filesdep +asyncdep +deepseqdep +json-rpcdep −conduitdep −conduit-extradep −scientificdep ~QuickCheckdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: async, deepseq, json-rpc

Dependencies removed: conduit, conduit-extra, scientific, text-icu, vector

Dependency ranges changed: QuickCheck, aeson, base, bytestring, either, mtl, text

API changes (from Hackage documentation)

Files

• Network/Haskoin/Crypto.hs +15/−13
• Network/Haskoin/Crypto/Base58.hs +36/−31
• Network/Haskoin/Crypto/BigWord.hs +104/−39
• Network/Haskoin/Crypto/Bloom.hs +18/−18
• Network/Haskoin/Crypto/ECDSA.hs +15/−12
• Network/Haskoin/Crypto/ExtendedKeys.hs +64/−19
• Network/Haskoin/Crypto/Hash.hs +48/−26
• Network/Haskoin/Crypto/Keys.hs +13/−32
• Network/Haskoin/Crypto/Merkle.hs +24/−17
• Network/Haskoin/Crypto/Mnemonic.hs +52/−57
• Network/Haskoin/Crypto/NormalizedKeys.hs +38/−22
• Network/Haskoin/Crypto/Point.hs +5/−0
• Network/Haskoin/Internals.hs +47/−0
• Network/Haskoin/Protocol.hs +4/−38
• Network/Haskoin/Protocol/Addr.hs +0/−39
• Network/Haskoin/Protocol/Alert.hs +0/−21
• Network/Haskoin/Protocol/Block.hs +0/−38
• Network/Haskoin/Protocol/BlockHeader.hs +0/−63
• Network/Haskoin/Protocol/BloomFilter.hs +0/−101
• Network/Haskoin/Protocol/GetBlocks.hs +0/−53
• Network/Haskoin/Protocol/GetData.hs +0/−34
• Network/Haskoin/Protocol/GetHeaders.hs +0/−46
• Network/Haskoin/Protocol/Headers.hs +0/−36
• Network/Haskoin/Protocol/Inv.hs +0/−29
• Network/Haskoin/Protocol/InvVector.hs +0/−54
• Network/Haskoin/Protocol/MerkleBlock.hs +0/−67
• Network/Haskoin/Protocol/Message.hs +108/−51
• Network/Haskoin/Protocol/MessageHeader.hs +0/−134
• Network/Haskoin/Protocol/NetworkAddress.hs +0/−45
• Network/Haskoin/Protocol/NotFound.hs +0/−30
• Network/Haskoin/Protocol/Ping.hs +0/−37
• Network/Haskoin/Protocol/Script.hs +0/−252
• Network/Haskoin/Protocol/Tx.hs +0/−194
• Network/Haskoin/Protocol/Types.hs +1089/−0
• Network/Haskoin/Protocol/VarInt.hs +0/−46
• Network/Haskoin/Protocol/VarString.hs +0/−29
• Network/Haskoin/Protocol/Version.hs +0/−85
• Network/Haskoin/Script.hs +24/−7
• Network/Haskoin/Script/Evaluator.hs +681/−0
• Network/Haskoin/Script/Parser.hs +131/−84
• Network/Haskoin/Script/SigHash.hs +38/−17
• Network/Haskoin/Script/Types.hs +543/−0
• Network/Haskoin/Stratum.hs +195/−237
• Network/Haskoin/Stratum/Conduit.hs +0/−153
• Network/Haskoin/Stratum/Message.hs +0/−218
• Network/Haskoin/Transaction.hs +4/−1
• Network/Haskoin/Transaction/Builder.hs +229/−216
• Network/Haskoin/Util.hs +13/−35
• Network/Haskoin/Util/BuildMonad.hs +0/−136
• Network/Haskoin/Util/Constants.hs +0/−55
• Network/Haskoin/Util/Constants/Testnet.hs +0/−55
• haskoin.cabal +64/−73
• prodnet/Network/Haskoin/Constants.hs +85/−0
• testnet/Network/Haskoin/Constants.hs +73/−0
• tests/Main.hs +8/−0
• tests/Network/Haskoin/Crypto/Arbitrary.hs +0/−4
• tests/Network/Haskoin/Crypto/Base58/Units.hs +44/−0
• tests/Network/Haskoin/Crypto/ECDSA/Tests.hs +2/−2
• tests/Network/Haskoin/Crypto/Hash/Tests.hs +2/−1
• tests/Network/Haskoin/Crypto/Keys/Tests.hs +5/−4
• tests/Network/Haskoin/Crypto/Merkle/Tests.hs +1/−1
• tests/Network/Haskoin/Crypto/Merkle/Units.hs +3/−4
• tests/Network/Haskoin/Crypto/Mnemonic/Tests.hs +15/−16
• tests/Network/Haskoin/Crypto/Mnemonic/Units.hs +5/−6
• tests/Network/Haskoin/Crypto/Units.hs +3/−3
• tests/Network/Haskoin/Json/Tests.hs +36/−0
• tests/Network/Haskoin/Protocol/Arbitrary.hs +17/−32
• tests/Network/Haskoin/Protocol/Tests.hs +7/−4
• tests/Network/Haskoin/Protocol/Units.hs +2/−2
• tests/Network/Haskoin/Script/Arbitrary.hs +182/−30
• tests/Network/Haskoin/Script/Tests.hs +213/−12
• tests/Network/Haskoin/Script/Units.hs +23/−2
• tests/Network/Haskoin/Stratum/Arbitrary.hs +138/−0
• tests/Network/Haskoin/Stratum/Tests.hs +37/−0
• tests/Network/Haskoin/Stratum/Units.hs +100/−41
• tests/Network/Haskoin/Transaction/Arbitrary.hs +41/−35
• tests/Network/Haskoin/Transaction/Tests.hs +50/−44
• tests/Network/Haskoin/Transaction/Units.hs +7/−5
• tests/Network/Haskoin/Util/Arbitrary.hs +0/−13
• tests/Network/Haskoin/Util/Tests.hs +0/−25
• tests/data/errors.json +6/−7
• tests/data/notifications.json +1/−7
• tests/data/requests.json +7/−12
• tests/data/responses.json +7/−10
• tests/data/script_invalid.json +366/−0
• tests/data/script_valid.json +510/−0

@@ -13,7 +13,6 @@ , isPubKeyU , derivePubKey , pubKeyAddr-, addPubKeys    -- **Private Keys , PrvKey(..)@@ -22,7 +21,6 @@ , makePrvKeyU , fromPrvKey , isPrvKeyU-, addPrvKeys , putPrvKey , getPrvKey , getPrvKeyU@@ -32,8 +30,7 @@   -- *ECDSA   -- **SecretT Monad   -- | The SecretT monad is a monadic wrapper around  HMAC DRBG (deterministic-  -- random byte generator) using SHA-256. The implementation is provided in -  -- 'Network.Haskoin.Crypto.Hash' and the specification is defined in+  -- random byte generator) using SHA-256. The specification is defined in   -- <http://csrc.nist.gov/publications/nistpubs/800-90A/SP800-90A.pdf>. The   -- SecretT monad is used to generate random private keys and random nonces   -- for ECDSA signatures.@@ -59,14 +56,22 @@ , Word128    -- *Hash functions-, Hash512-, Hash256-, Hash160+, TxHash+, BlockHash , CheckSum32+, txHash+, cbHash+, headerHash+, encodeTxHashLE+, decodeTxHashLE+, encodeBlockHashLE+, decodeBlockHashLE , hash512 , hash512BS , hash256 , hash256BS+, hashSha1+, hashSha1BS , hash160 , hash160BS , doubleHash256@@ -94,16 +99,12 @@ , decodeBase58Check    -- *Mnemonic keys (BIP-0039)-, WordList , Entropy , Mnemonic , Passphrase , Seed , toMnemonic-, fromMnemonic , mnemonicToSeed-, anyToSeed-, english    -- *Extended Keys , ChainCode@@ -205,8 +206,9 @@ , bloomCreate , bloomInsert , bloomContains-, bloomUpdateEmptyFull-, bloomIsValid+, isBloomValid+, isBloomEmpty+, isBloomFull    -- *Partial merkle trees , calcTreeHeight

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.Haskoin.Crypto.Base58 ( Address(..) , addrToBase58@@ -8,12 +10,15 @@ , decodeBase58Check ) where +import Control.DeepSeq (NFData, rnf) import Control.Monad (guard) import Control.Applicative ((<$>),(<*>)) -import Data.Char (ord)+import Data.Char (ord, chr) import Data.Word (Word8)-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, isJust, listToMaybe)+import Numeric (showIntAtBase, readInt)+import Data.String (fromString) import Data.Aeson     ( Value (String)     , FromJSON@@ -24,39 +29,39 @@     )  import qualified Data.ByteString as BS-import qualified Data.Map.Strict as M+import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T -import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.BigWord+import Network.Haskoin.Crypto.Hash+import Network.Haskoin.Constants import Network.Haskoin.Util  -b58String :: String-b58String = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"- b58Data :: BS.ByteString-b58Data = BS.pack $ map (fromIntegral . ord) b58String--b58Data' :: M.Map Word8 Int-b58Data' = M.fromList $ zip (BS.unpack b58Data) [0..57]+b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"  b58 :: Word8 -> Word8 b58 i = BS.index b58Data (fromIntegral i)  b58' :: Word8 -> Maybe Word8-b58' w = fromIntegral <$> M.lookup w b58Data'+b58' w = fromIntegral <$> BS.elemIndex w b58Data  encodeBase58I :: Integer -> BS.ByteString-encodeBase58I 0 = BS.pack [b58 0]-encodeBase58I i-    | i >= 0 = go BS.empty i-    | otherwise = error "encodeBase58 is not defined for negative Integers"-  where -    go acc 0 = acc-    go acc n = go (BS.cons (fromIntegral b) acc) q-      where -        (q,r) = n `quotRem` 58-        b     = b58 $ fromIntegral r+encodeBase58I i = +    fromString $ showIntAtBase (58 :: Integer) f (fromIntegral i) ""+  where+    f = chr . fromIntegral . b58 . fromIntegral +decodeBase58I :: BS.ByteString -> Maybe Integer+decodeBase58I s = case go of +    Just (r,[]) -> Just r+    _           -> Nothing+  where+    c = b58' . fromIntegral . ord+    p = isJust . c +    f = fromIntegral . fromJust . c+    go = listToMaybe $ readInt 58 p f (B8.unpack s)+ -- | Encode a bytestring to a base 58 representation. encodeBase58 :: BS.ByteString -> BS.ByteString encodeBase58 bs = BS.append l r@@ -74,11 +79,7 @@     (z,b)  = BS.span (== (b58 0)) bs     prefix = BS.map (fromJust . b58') z -- preserve leading 1's     r | BS.null b = Just BS.empty-      | otherwise = integerToBS <$> foldl f (Just 0) (BS.unpack b)-    f i w  = do-        n <- fromIntegral <$> b58' w-        p <- i-        return $ p*58 + n+      | otherwise = integerToBS <$> decodeBase58I b  -- | Computes a checksum for the input bytestring and encodes the input and -- the checksum to a base 58 representation.@@ -100,13 +101,17 @@ -- |Data type representing a Bitcoin address data Address      -- | Public Key Hash Address-    = PubKeyAddress { getAddrHash :: Hash160 }+    = PubKeyAddress { getAddrHash :: Word160 }     -- | Script Hash Address-    | ScriptAddress { getAddrHash :: Hash160 }-       deriving (Eq, Show)+    | ScriptAddress { getAddrHash :: Word160 }+       deriving (Eq, Show, Read) +instance NFData Address where+    rnf (PubKeyAddress h) = rnf h+    rnf (ScriptAddress h) = rnf h+ instance FromJSON Address where-    parseJSON = withText "Address not a string: " $ \a -> do+    parseJSON = withText "address" $ \a -> do         let s = T.unpack a         maybe (fail $ "Not a Bitcoin address: " ++ s) return $ base58ToAddr s 

@@ -3,9 +3,8 @@ module Network.Haskoin.Crypto.BigWord ( -- Useful type aliases-  Hash512-, Hash256-, Hash160+  TxHash+, BlockHash , Word512 , Word256 , Word160@@ -18,16 +17,14 @@ , BigWordMod(..)  -- Functions-, toFieldN-, toFieldP-, toMod512-, toMod256-, toMod160-, toMod128 , inverseP , inverseN , quadraticResidue , isIntegerValidKey+, encodeTxHashLE+, decodeTxHashLE+, encodeBlockHashLE+, decodeBlockHashLE ) where  import Data.Bits @@ -52,27 +49,38 @@     , putWord8     , putByteString     )+import Data.Aeson+    ( Value (String)+    , FromJSON+    , ToJSON+    , parseJSON+    , toJSON+    , withText+    )+import Control.DeepSeq (NFData, rnf) import Control.Monad (unless, guard) import Control.Applicative ((<$>)) import Data.Ratio (numerator, denominator)-import qualified Data.ByteString as BS (head, length)+import qualified Data.ByteString as BS (head, length, reverse)+import qualified Data.Text as T (pack, unpack)  import Network.Haskoin.Crypto.Curve  import Network.Haskoin.Crypto.NumberTheory  import Network.Haskoin.Util  +-- | Type representing a transaction hash.+type TxHash  = BigWord Mod256Tx+-- | Type representing a block hash.+type BlockHash = BigWord Mod256Block -- | Data type representing a 512 bit unsigned integer. -- It is implemented as an Integer modulo 2^512. type Word512 = BigWord Mod512-type Hash512 = Word512 -- | Data type representing a 256 bit unsigned integer. -- It is implemented as an Integer modulo 2^256. type Word256 = BigWord Mod256-type Hash256 = Word256 -- | Data type representing a 160 bit unsigned integer. -- It is implemented as an Integer modulo 2^160. type Word160 = BigWord Mod160-type Hash160 = Word160 -- | Data type representing a 128 bit unsigned integer. -- It is implemented as an Integer modulo 2^128. type Word128 = BigWord Mod128@@ -83,6 +91,8 @@  data Mod512 data Mod256 +data Mod256Tx+data Mod256Block data Mod160 data Mod128 data ModP@@ -91,23 +101,8 @@ newtype BigWord n = BigWord { getBigWordInteger :: Integer }     deriving (Eq, Ord, Read, Show) -toFieldN :: BigWord n -> FieldN-toFieldN (BigWord i) = fromInteger i--toFieldP :: BigWord n -> FieldP-toFieldP (BigWord i) = fromInteger i--toMod512 :: BigWord n -> Word512-toMod512 (BigWord i) = fromInteger i--toMod256 :: BigWord n -> Word256-toMod256 (BigWord i) = fromInteger i--toMod160 :: BigWord n -> Word160-toMod160 (BigWord i) = fromInteger i--toMod128 :: BigWord n -> Word128-toMod128 (BigWord i) = fromInteger i+instance NFData (BigWord n) where+    rnf (BigWord n) = rnf n  inverseP :: FieldP -> FieldP inverseP (BigWord i) = fromInteger $ mulInverse i curveP@@ -127,6 +122,14 @@     rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int)     rBitSize     _ = 256 +instance BigWordMod Mod256Tx where+    rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int)+    rBitSize     _ = 256++instance BigWordMod Mod256Block where+    rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int)+    rBitSize     _ = 256+ instance BigWordMod Mod160 where     rFromInteger i = BigWord $ i `mod` 2 ^ (160 :: Int)     rBitSize     _ = 160@@ -216,13 +219,13 @@  instance Binary (BigWord Mod512) where     get = do-        a <- fromIntegral <$> (get :: Get Hash256)-        b <- fromIntegral <$> (get :: Get Hash256)+        a <- fromIntegral <$> (get :: Get Word256)+        b <- fromIntegral <$> (get :: Get Word256)         return $ (a `shiftL` 256) + b      put (BigWord i) = do-        put $ (fromIntegral (i `shiftR` 256) :: Hash256)-        put $ (fromIntegral i :: Hash256)+        put $ (fromIntegral (i `shiftR` 256) :: Word256)+        put $ (fromIntegral i :: Word256)  instance Binary (BigWord Mod256) where     get = do@@ -238,6 +241,34 @@         putWord64be $ fromIntegral (i `shiftR` 64)         putWord64be $ fromIntegral i +instance Binary (BigWord Mod256Tx) where+    get = do+        a <- fromIntegral <$> getWord64be+        b <- fromIntegral <$> getWord64be+        c <- fromIntegral <$> getWord64be+        d <- fromIntegral <$> getWord64be+        return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d++    put (BigWord i) = do+        putWord64be $ fromIntegral (i `shiftR` 192)+        putWord64be $ fromIntegral (i `shiftR` 128)+        putWord64be $ fromIntegral (i `shiftR` 64)+        putWord64be $ fromIntegral i++instance Binary (BigWord Mod256Block) where+    get = do+        a <- fromIntegral <$> getWord64be+        b <- fromIntegral <$> getWord64be+        c <- fromIntegral <$> getWord64be+        d <- fromIntegral <$> getWord64be+        return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d++    put (BigWord i) = do+        putWord64be $ fromIntegral (i `shiftR` 192)+        putWord64be $ fromIntegral (i `shiftR` 128)+        putWord64be $ fromIntegral (i `shiftR` 64)+        putWord64be $ fromIntegral i+ instance Binary (BigWord Mod160) where     get = do         a <- fromIntegral <$> getWord32be@@ -268,8 +299,6 @@         unless (t == 0x02) (fail $             "Bad DER identifier byte " ++ (show t) ++ ". Expecting 0x02" )         l <- getWord8-        unless (l <= 33) (fail $-            "Bad DER length " ++ (show l) ++ ". Expecting length <= 33" )         i <- bsToInteger <$> getByteString (fromIntegral l)         unless (isIntegerValidKey i) $ fail $              "Invalid fieldN element: " ++ (show i)@@ -292,14 +321,30 @@      -- Section 2.3.6 http://www.secg.org/download/aid-780/sec1-v2.pdf     get = do-        (BigWord i) <- get :: Get Hash256+        (BigWord i) <- get :: Get Word256         unless (i < curveP) (fail $ "Get: Integer not in FieldP: " ++ (show i))         return $ fromInteger i      -- Section 2.3.7 http://www.secg.org/download/aid-780/sec1-v2.pdf-    put r = put $ toMod256 r-         +    put r = put (fromIntegral r :: Word256)+      +instance ToJSON (BigWord Mod256Tx) where+    toJSON = String . T.pack . encodeTxHashLE +instance FromJSON (BigWord Mod256Tx) where+    parseJSON = withText "TxHash not a string: " $ \a -> do+        let s = T.unpack a+        maybe (fail $ "Not a TxHash: " ++ s) return $ decodeTxHashLE s++instance ToJSON (BigWord Mod256) where+    toJSON = String . T.pack . bsToHex . encode'++instance FromJSON (BigWord Mod256) where+    parseJSON = withText "Word256 not a string: " $ \a -> do+        let s = T.unpack a+        maybe (fail $ "Not a Word256: " ++ s) return $ +            hexToBS s >>= decodeToMaybe+ -- curveP = 3 (mod 4), thus Lagrange solutions apply -- http://en.wikipedia.org/wiki/Quadratic_residue quadraticResidue :: FieldP -> [FieldP]@@ -310,4 +355,24 @@  isIntegerValidKey :: Integer -> Bool isIntegerValidKey i = i > 0 && i < curveN++-- | Encodes a 'TxHash' as little endian in HEX format. This is mostly used for+-- displaying transaction ids. Internally, these ids are handled as big endian+-- but are transformed to little endian when displaying them.+encodeTxHashLE :: TxHash -> String+encodeTxHashLE = bsToHex . BS.reverse .  encode' ++-- | Decodes a little endian 'TxHash' in HEX format. +decodeTxHashLE :: String -> Maybe TxHash+decodeTxHashLE = (decodeToMaybe . BS.reverse =<<) . hexToBS++-- | Encodes a 'BlockHash' as little endian in HEX format. This is mostly used+-- for displaying Block hash ids. Internally, these ids are handled as big+-- endian but are transformed to little endian when displaying them.+encodeBlockHashLE :: BlockHash -> String+encodeBlockHashLE = bsToHex . BS.reverse .  encode' ++-- | Decodes a little endian 'BlockHash' in HEX format. +decodeBlockHashLE :: String -> Maybe BlockHash+decodeBlockHashLE = (decodeToMaybe . BS.reverse =<<) . hexToBS 

@@ -4,8 +4,9 @@ , bloomCreate , bloomInsert , bloomContains-, bloomUpdateEmptyFull-, bloomIsValid+, isBloomValid+, isBloomEmpty+, isBloomFull ) where  import Data.Word@@ -44,7 +45,7 @@             -> BloomFlags   -- ^ Bloom filter flags             -> BloomFilter  -- ^ Bloom filter bloomCreate numElem fpRate tweak flags =-    BloomFilter (S.replicate bloomSize 0) False False numHashF tweak flags+    BloomFilter (S.replicate bloomSize 0) numHashF tweak flags   where     bloomSize = truncate $ (min a b) / 8     a         = -1 / ln2Squared * (fromIntegral numElem) * log fpRate@@ -64,8 +65,8 @@             -> BS.ByteString  -- ^ New data to insert             -> BloomFilter    -- ^ Bloom filter containing the new data bloomInsert bfilter bs -    | bloomFull bfilter = bfilter-    | otherwise = bfilter { bloomData = newData, bloomEmpty = False }+    | isBloomFull bfilter = bfilter+    | otherwise = bfilter { bloomData = newData }   where     idxs    = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter - 1]     upd s i = S.adjust (.|. bitMask !! (7 .&. i)) (i `shiftR` 3) s@@ -79,9 +80,9 @@               -> Bool               -- ^ Returns True if the data matches the filter bloomContains bfilter bs-    | bloomFull bfilter  = True-    | bloomEmpty bfilter = False-    | otherwise         = and $ map isSet idxs+    | isBloomFull bfilter  = True+    | isBloomEmpty bfilter = False+    | otherwise            = and $ map isSet idxs   where     s       = bloomData bfilter     idxs    = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter - 1]@@ -90,19 +91,18 @@ -- TODO: Write bloomRelevantUpdate -- bloomRelevantUpdate :: BloomFilter -> Tx -> Hash256 -> Maybe BloomFilter --- | Sets the bloom filter empty flag to True if the filter is empty, and--- the bloom filter full flag to True if the filter is full.-bloomUpdateEmptyFull :: BloomFilter -- ^ Bloom filter to update-                     -> BloomFilter -- ^ Filter with updated flags-bloomUpdateEmptyFull bfilter = -    bfilter { bloomEmpty = all (== 0x00) l, bloomFull = all (== 0xff) l }-  where-    l = F.toList $ bloomData bfilter+-- | Returns True if the filter is empty (all bytes set to 0x00)+isBloomEmpty :: BloomFilter -> Bool+isBloomEmpty bfilter = all (== 0x00) $ F.toList $ bloomData bfilter +-- | Returns True if the filter is full (all bytes set to 0xff)+isBloomFull :: BloomFilter -> Bool+isBloomFull bfilter = all (== 0xff) $ F.toList $ bloomData bfilter+ -- | Tests if a given bloom filter is valid.-bloomIsValid :: BloomFilter -- ^ Bloom filter to test+isBloomValid :: BloomFilter -- ^ Bloom filter to test              -> Bool        -- ^ True if the given filter is valid-bloomIsValid bfilter =+isBloomValid bfilter =     (S.length $ bloomData bfilter) <= maxBloomSize &&     (bloomHashFuncs bfilter) <= maxHashFuncs 

@@ -15,6 +15,7 @@  import System.IO +import Control.DeepSeq (NFData, rnf) import Control.Monad (liftM, guard, unless) import Control.Monad.Trans (MonadTrans, lift) import Control.Applicative (Applicative, (<*>), (<$>))@@ -37,6 +38,7 @@     )    import Network.Haskoin.Util +import Network.Haskoin.Constants import Network.Haskoin.Crypto.Hash  import Network.Haskoin.Crypto.Keys  import Network.Haskoin.Crypto.Point @@ -48,7 +50,7 @@ -- | StateT monad stack tracking the internal state of HMAC DRBG  -- pseudo random number generator using SHA-256. The 'SecretT' monad is -- run with the 'withSource' function by providing it a source of entropy.-type SecretT m a = S.StateT (SecretState m) m a+type SecretT m = S.StateT (SecretState m) m  -- | Run a 'SecretT' monad by providing it a source of entropy. You can -- use 'devURandom', 'devRandom' or provide your own entropy source function.@@ -109,12 +111,15 @@     Signature { sigR :: !FieldN                , sigS :: !FieldN                }-    deriving (Show, Eq)+    deriving (Read, Show, Eq) +instance NFData Signature where+    rnf (Signature r s) = rnf r `seq` rnf s+ -- Section 4.1.3 http://www.secg.org/download/aid-780/sec1-v2.pdf -- | Safely sign a message inside the 'SecretT' monad. The 'SecretT' monad will -- generate a new nonce for each signature.-signMsg :: Monad m => Hash256 -> PrvKey -> SecretT m Signature+signMsg :: Monad m => Word256 -> PrvKey -> SecretT m Signature signMsg _ (PrvKey  0) = error "signMsg: Invalid private key 0" signMsg _ (PrvKeyU 0) = error "signMsg: Invalid private key 0" signMsg h d = do@@ -127,7 +132,7 @@  -- | Sign a message using ECDSA deterministic signatures as defined by -- RFC 6979 <http://tools.ietf.org/html/rfc6979>-detSignMsg :: Hash256 -> PrvKey -> Signature+detSignMsg :: Word256 -> PrvKey -> Signature detSignMsg _ (PrvKey  0) = error "detSignMsg: Invalid private key 0" detSignMsg _ (PrvKeyU 0) = error "detSignMsg: Invalid private key 0" detSignMsg h d = go $ hmacDRBGNew (runPut' $ putPrvKey d) (encode' h) BS.empty@@ -146,16 +151,16 @@ -- Re-using the same nonce twice will expose the private keys -- Use signMsg within the SecretT monad or detSignMsg instead -- Section 4.1.3 http://www.secg.org/download/aid-780/sec1-v2.pdf-unsafeSignMsg :: Hash256 -> FieldN -> (FieldN, Point) -> Maybe Signature+unsafeSignMsg :: Word256 -> FieldN -> (FieldN, Point) -> Maybe Signature unsafeSignMsg _ 0 _ = Nothing unsafeSignMsg h d (k,p) = do     -- 4.1.3.1 (4.1.3.2 not required)     (x,_) <- getAffine p     -- 4.1.3.3-    let r = toFieldN x+    let r = (fromIntegral x :: FieldN)     guard (r /= 0)     -- 4.1.3.4 / 4.1.3.5-    let e = toFieldN h+    let e = (fromIntegral h :: FieldN)     -- 4.1.3.6     let s' = (e + r*d)/k         -- Canonicalize signatures: s <= order/2@@ -167,17 +172,17 @@  -- Section 4.1.4 http://www.secg.org/download/aid-780/sec1-v2.pdf -- | Verify an ECDSA signature-verifySig :: Hash256 -> Signature -> PubKey -> Bool+verifySig :: Word256 -> Signature -> PubKey -> Bool -- 4.1.4.1 (r and s can not be zero) verifySig _ (Signature 0 _) _ = False verifySig _ (Signature _ 0) _ = False verifySig h (Signature r s) q = case getAffine p of     Nothing      -> False     -- 4.1.4.7 / 4.1.4.8-    (Just (x,_)) -> (toFieldN x) == r+    (Just (x,_)) -> (fromIntegral x :: FieldN) == r   where      -- 4.1.4.2 / 4.1.4.3-    e  = toFieldN h+    e  = (fromIntegral h :: FieldN)     -- 4.1.4.4     s' = inverseN s     u1 = e*s'@@ -198,8 +203,6 @@             "Bad DER identifier byte " ++ (show t) ++ ". Expecting 0x30")         l <- getWord8         -- Length = (33 + 1 identifier byte + 1 length byte) * 2-        unless (l <= 70) (fail $-            "Bad DER length " ++ (show t) ++ ". Expecting length <= 70")         isolate (fromIntegral l) $ do             Signature <$> get <*> get 

@@ -28,38 +28,35 @@ , xPrvWIF , cycleIndex , cycleIndex'+, addPubKeys+, addPrvKeys ) where -import Control.Monad -    ( guard-    , unless-    , when-    , liftM2-    )+import Control.DeepSeq (NFData, rnf)+import Control.Monad (mzero, guard, unless, when, liftM2)++import Data.Aeson (Value(String), FromJSON, ToJSON, parseJSON, toJSON, withText) import Data.Binary (Binary, get, put) import Data.Binary.Get (Get, getWord8, getWord32be) import Data.Binary.Put (Put, runPut, putWord8, putWord32be) import Data.Word (Word8, Word32)-import Data.Bits -    ( shiftR-    , setBit-    , testBit-    , clearBit-    )+import Data.Bits (shiftR, setBit, testBit, clearBit) import Data.Maybe (mapMaybe)-import qualified Data.ByteString as BS -    ( ByteString-    , append-    )+import qualified Data.Text as T (pack, unpack)+import qualified Data.ByteString as BS (ByteString, append)  import Network.Haskoin.Util+import Network.Haskoin.Constants import Network.Haskoin.Crypto.Keys import Network.Haskoin.Crypto.Hash import Network.Haskoin.Crypto.Base58+import Network.Haskoin.Crypto.BigWord+import Network.Haskoin.Crypto.Curve+import Network.Haskoin.Crypto.Point  {- See BIP32 for details: https://en.bitcoin.it/wiki/BIP_0032 -} -type ChainCode = Hash256+type ChainCode = Word256  -- | Data type representing an extended BIP32 private key. An extended key -- is a node in a tree of key derivations. It has a depth in the tree, a @@ -72,6 +69,17 @@     , xPrvKey    :: !PrvKey    -- ^ The private key of this extended key node.     } deriving (Eq, Show, Read) +instance NFData XPrvKey where+    rnf (XPrvKey d p i c k) =+        rnf d `seq` rnf p `seq` rnf i `seq` rnf c `seq` rnf k++instance ToJSON XPrvKey where+    toJSON = String . T.pack . xPrvExport++instance FromJSON XPrvKey where+    parseJSON = withText "xprvkey" $ \t -> +        maybe mzero return $ xPrvImport (T.unpack t)+ -- | Data type representing an extended BIP32 public key. data XPubKey = XPubKey     { xPubDepth  :: !Word8     -- ^ Depth in the tree of key derivations.@@ -81,6 +89,17 @@     , xPubKey    :: !PubKey    -- ^ The public key of this extended key node.     } deriving (Eq, Show, Read) +instance NFData XPubKey where+    rnf (XPubKey d p i c k) =+        rnf d `seq` rnf p `seq` rnf i `seq` rnf c `seq` rnf k++instance ToJSON XPubKey where+    toJSON = String . T.pack . xPubExport++instance FromJSON XPubKey where+    parseJSON = withText "xpubkey" $ \t -> +        maybe mzero return $ xPubImport (T.unpack t)+ -- | Build a BIP32 compatible extended private key from a bytestring. This will -- produce a root node (depth=0 and parent=0). makeXPrvKey :: BS.ByteString -> Maybe XPrvKey@@ -141,6 +160,32 @@           msg   = BS.append (bsPadPrvKey $ xPrvKey xkey) (encode' i)           (a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg +-- Add two private keys together. One of the keys is defined by a Word256.+-- The functions fails on uncompressed private keys and return Nothing if the+-- Word256 is smaller than the order of the curve N.+addPrvKeys :: PrvKey -> Word256 -> Maybe PrvKey+addPrvKeys key i+    | isPrvKeyU key = error "Add: HDW only supports compressed formats"+    | toInteger i < curveN =+        let r = (prvKeyFieldN key) + (fromIntegral i :: FieldN) +            in makePrvKey $ toInteger r+    | otherwise = Nothing++-- Add a public key to a private key defined by its Word256 value. This will+-- transform the private key into a public key and add the respective public+-- key points together. This function fails for uncompressed keys and returns+-- Nothing if the private key value is >= than the order of the curve N.+addPubKeys :: PubKey -> Word256 -> Maybe PubKey+addPubKeys pub i+    | isPubKeyU pub = error "Add: HDW only supports compressed formats"+    | toInteger i < curveN =+        let pt1 = mulPoint (fromIntegral i :: FieldN) curveG+            pt2 = addPoint (pubKeyPoint pub) pt1+            in if isInfPoint pt2 then Nothing+                                 else Just $ PubKey pt2+    | otherwise = Nothing++ -- | Cyclic list of all private non-prime child key derivations of a parent key -- starting from an offset index. prvSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)]@@ -217,11 +262,11 @@ xPubChild k = clearBit (xPubIndex k) 31  -- | Computes the key identifier of an extended private key.-xPrvID :: XPrvKey -> Hash160+xPrvID :: XPrvKey -> Word160 xPrvID = xPubID . deriveXPubKey  -- | Computes the key identifier of an extended public key.-xPubID :: XPubKey -> Hash160+xPubID :: XPubKey -> Word160 xPubID = hash160 . hash256BS . encode' . xPubKey   -- | Computes the key fingerprint of an extended private key.

@@ -1,14 +1,13 @@ -- | Hashing functions and HMAC DRBG definition module Network.Haskoin.Crypto.Hash-( Hash512-, Hash256-, Hash160-, CheckSum32+( CheckSum32 , hash512 , hash256+, hashSha1 , hash160 , hash512BS , hash256BS+, hashSha1BS , hash160BS , doubleHash256 , doubleHash256BS@@ -27,15 +26,18 @@ , join512 , decodeCompact , encodeCompact+, txHash+, cbHash+, headerHash ) where -import Control.Applicative ((<$>)) import Control.Monad (replicateM)  import Crypto.Hash -    ( Digest +    ( Digest     , SHA512     , SHA256+    , SHA1     , RIPEMD160     , hash     )@@ -43,7 +45,7 @@  import Data.Word (Word16, Word32) import Data.Byteable (toBytes)-import Data.Binary (Binary, get, put)+import Data.Binary (Binary, get) import Data.Binary.Get (getWord32le) import Data.Bits      ( shiftL@@ -68,13 +70,9 @@  import Network.Haskoin.Util  import Network.Haskoin.Crypto.BigWord ---- | Data type representing a 32 bit checksum-newtype CheckSum32 = CheckSum32 Word32 deriving (Show, Eq, Read)+import Network.Haskoin.Protocol.Types -instance Binary CheckSum32 where-    get = CheckSum32 <$> get-    put (CheckSum32 w) = put w+type CheckSum32 = Word32  run512 :: BS.ByteString -> BS.ByteString run512 = (toBytes :: Digest SHA512 -> BS.ByteString) . hash@@ -85,8 +83,11 @@ run160 :: BS.ByteString -> BS.ByteString run160 = (toBytes :: Digest RIPEMD160 -> BS.ByteString) . hash +runSha1 :: BS.ByteString -> BS.ByteString+runSha1 = (toBytes :: Digest SHA1 -> BS.ByteString) . hash+ -- | Computes SHA-512.-hash512 :: BS.ByteString -> Hash512+hash512 :: BS.ByteString -> Word512 hash512 bs = runGet' get (run512 bs)  -- | Computes SHA-512 and returns the result as a bytestring.@@ -94,15 +95,23 @@ hash512BS bs = run512 bs  -- | Computes SHA-256.-hash256 :: BS.ByteString -> Hash256+hash256 :: BS.ByteString -> Word256 hash256 bs = runGet' get (run256 bs)  -- | Computes SHA-256 and returns the result as a bytestring. hash256BS :: BS.ByteString -> BS.ByteString hash256BS bs = run256 bs +-- | Computes SHA-160.+hashSha1 :: BS.ByteString -> Word160+hashSha1 bs = runGet' get (runSha1 bs)++-- | Computes SHA-160 and returns the result as a bytestring.+hashSha1BS :: BS.ByteString -> BS.ByteString+hashSha1BS bs = runSha1 bs+ -- | Computes RIPEMD-160.-hash160 :: BS.ByteString -> Hash160+hash160 :: BS.ByteString -> Word160 hash160 bs = runGet' get (run160 bs)  -- | Computes RIPEMD-160 and returns the result as a bytestring.@@ -110,7 +119,7 @@ hash160BS bs = run160 bs  -- | Computes two rounds of SHA-256.-doubleHash256 :: BS.ByteString -> Hash256+doubleHash256 :: BS.ByteString -> Word256 doubleHash256 bs = runGet' get (run256 $ run256 bs)  -- | Computes two rounds of SHA-256 and returns the result as a bytestring.@@ -121,12 +130,12 @@  -- | Computes a 32 bit checksum. chksum32 :: BS.ByteString -> CheckSum32-chksum32 bs = CheckSum32 $ fromIntegral $ (doubleHash256 bs) `shiftR` 224+chksum32 bs = fromIntegral $ (doubleHash256 bs) `shiftR` 224  {- HMAC -}  -- | Computes HMAC over SHA-512.-hmac512 :: BS.ByteString -> BS.ByteString -> Hash512+hmac512 :: BS.ByteString -> BS.ByteString -> Word512 hmac512 key = decode' . (hmac512BS key)  -- | Computes HMAC over SHA-512 and return the result as a bytestring.@@ -134,20 +143,21 @@ hmac512BS key msg = hmac hash512BS 128 key msg  -- | Computes HMAC over SHA-256.-hmac256 :: BS.ByteString -> BS.ByteString -> Hash256+hmac256 :: BS.ByteString -> BS.ByteString -> Word256 hmac256 key = decode' . (hmac256BS key)  -- | Computes HMAC over SHA-256 and return the result as a bytestring. hmac256BS :: BS.ByteString -> BS.ByteString -> BS.ByteString hmac256BS key msg = hmac hash256BS 64 key msg --- | Split a 'Hash512' into a pair of 'Hash256'.-split512 :: Hash512 -> (Hash256, Hash256)+-- | Split a 'Word512' into a pair of 'Word256'.+split512 :: Word512 -> (Word256, Word256) split512 i = (fromIntegral $ i `shiftR` 256, fromIntegral i) --- | Join a pair of 'Hash256' into a 'Hash512'.-join512 :: (Hash256, Hash256) -> Hash512-join512 (a,b) = ((toMod512 a) `shiftL` 256) + (toMod512 b)+-- | Join a pair of 'Word256' into a 'Word512'.+join512 :: (Word256, Word256) -> Word512+join512 (a,b) = +    ((fromIntegral a :: Word512) `shiftL` 256) + (fromIntegral b :: Word512)  -- | Decode the compact number used in the difficulty target of a block into an -- Integer. @@ -186,6 +196,18 @@             | otherwise               = (s1, c1)     c3 = fromIntegral $ c2 .|. ((toInteger s2) `shiftL` 24) +-- | Computes the hash of a transaction.+txHash :: Tx -> TxHash+txHash = fromIntegral . doubleHash256 . encode' ++-- | Computes the hash of a coinbase transaction.+cbHash :: CoinbaseTx -> TxHash+cbHash = fromIntegral . doubleHash256 . encode' ++-- | Compute the hash of a block header+headerHash :: BlockHeader -> BlockHash+headerHash = fromIntegral . doubleHash256 . encode'+ {- 10.1.2 HMAC_DRBG with HMAC-SHA256    http://csrc.nist.gov/publications/nistpubs/800-90A/SP800-90A.pdf     Constants are based on recommentations in Appendix D section 2 (D.2)@@ -259,7 +281,7 @@ {- MurmurHash3 -}      -- | MurmurHash3 (x86_32). For more details, see--- http://code.google.com/p/smhasher/source/browse/trunk/MurmurHash3.cpp+-- <http://code.google.com/p/smhasher/source/browse/trunk/MurmurHash3.cpp> -- This code is used in the bloom filters of SPV nodes. murmurHash3 :: Word32 -> BS.ByteString -> Word32 murmurHash3 nHashSeed bs = h8

@@ -4,14 +4,12 @@ , isPubKeyU , derivePubKey , pubKeyAddr-, addPubKeys , PrvKey(..) , isValidPrvKey , makePrvKey , makePrvKeyU , fromPrvKey , isPrvKeyU-, addPrvKeys , putPrvKey , getPrvKey , getPrvKeyU@@ -24,6 +22,7 @@ import Data.Binary.Get (Get, getWord8) import Data.Binary.Put (Put, putWord8) +import Control.DeepSeq (NFData, rnf) import Control.Monad (when, unless, guard) import Control.Applicative ((<$>),(<*>)) import Data.Maybe (isJust, fromJust)@@ -39,6 +38,7 @@ import Network.Haskoin.Crypto.Point  import Network.Haskoin.Crypto.Base58  import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Constants import Network.Haskoin.Util   -- | G parameter of the EC curve expressed as a Point@@ -57,6 +57,10 @@     | PubKeyU { pubKeyPoint :: !Point }     deriving (Read, Show) +instance NFData PubKey where+    rnf (PubKey p) = rnf p+    rnf (PubKeyU p) = rnf p+ instance Eq PubKey where     -- Compression does not matter for InfPoint     (PubKey  InfPoint) == (PubKeyU InfPoint) = True@@ -70,21 +74,6 @@ isValidPubKey :: PubKey -> Bool isValidPubKey = validatePoint . pubKeyPoint --- | Add a public key to a private key defined by its Hash256 value. This will--- transform the private key into a public key and add the respective public--- key points together. This is provided as a helper for BIP32 wallet--- implementations. This function fails for uncompressed keys and returns--- Nothing if the private key value is >= than the order of the curve N.-addPubKeys :: PubKey -> Hash256 -> Maybe PubKey-addPubKeys pub i-    | isPubKeyU pub = error "Add: HDW only supports compressed formats"-    | toInteger i < curveN =-        let pt1 = mulPoint (toFieldN i) curveG-            pt2 = addPoint (pubKeyPoint pub) pt1-            in if isInfPoint pt2 then Nothing-                                 else Just $ PubKey pt2-    | otherwise = Nothing- -- | Returns True if the public key is uncompressed isPubKeyU :: PubKey -> Bool isPubKeyU (PubKey  _) = False@@ -161,6 +150,10 @@     | PrvKeyU { prvKeyFieldN :: !FieldN }      deriving (Eq, Show, Read) +instance NFData PrvKey where+    rnf (PrvKey p) = rnf p+    rnf (PrvKeyU p) = rnf p+ -- | Returns True if the private key is valid. This will check if the integer -- value representing the private key is greater than 0 and smaller than the -- curve order N.@@ -187,18 +180,6 @@ fromPrvKey :: PrvKey -> Integer fromPrvKey = fromIntegral . prvKeyFieldN --- | Add two private keys together. One of the keys is defined by a Hash256.--- The functions fails on uncompressed private keys and return Nothing if the--- Hash256 is smaller than the order of the curve N. This is provided--- as a helper for implementing BIP32 wallets.-addPrvKeys :: PrvKey -> Hash256 -> Maybe PrvKey-addPrvKeys key i-    | isPrvKeyU key = error "Add: HDW only supports compressed formats"-    | toInteger i < curveN =-        let r = (prvKeyFieldN key) + (toFieldN i) -            in makePrvKey $ toInteger r-    | otherwise = Nothing- -- | Returns True of the private key is uncompressed isPrvKeyU :: PrvKey -> Bool isPrvKeyU (PrvKey  _) = False@@ -209,13 +190,13 @@ -- format for private keys is required putPrvKey :: PrvKey -> Put putPrvKey k | prvKeyFieldN k == 0 = error "Put: 0 is an invalid private key"-            | otherwise        = put $ toMod256 $ prvKeyFieldN k+            | otherwise = put $ (fromIntegral (prvKeyFieldN k) :: Word256)  -- | Deserializes a compressed private key from the Data.Binary.Get monad as a -- 32 byte big endian ByteString. getPrvKey :: Get PrvKey getPrvKey = do-        i <- get :: Get Hash256+        i <- get :: Get Word256         let res = makePrvKey $ fromIntegral i         unless (isJust res) $ fail "Get: PrivateKey is invalid"         return $ fromJust res@@ -224,7 +205,7 @@ -- a 32 byte big endian ByteString getPrvKeyU :: Get PrvKey getPrvKeyU = do-        i <- get :: Get Hash256+        i <- get :: Get Word256         let res = makePrvKeyU $ fromIntegral i         unless (isJust res) $ fail "Get: PrivateKey is invalid"         return $ fromJust res

@@ -12,8 +12,14 @@ import qualified Data.ByteString as BS   import Network.Haskoin.Crypto.Hash+import Network.Haskoin.Crypto.BigWord import Network.Haskoin.Util+import Network.Haskoin.Constants +type MerkleRoot        = Word256+type FlagBits          = [Bool]+type PartialMerkleTree = [Word256]+ -- | Computes the height of a merkle tree. calcTreeHeight :: Int -- ^ Number of transactions (leaf nodes).                -> Int -- ^ Height of the merkle tree.@@ -27,21 +33,21 @@ calcTreeWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h  -- | Computes the root of a merkle tree from a list of leaf node hashes.-buildMerkleRoot :: [Hash256] -- ^ List of transaction hashes (leaf nodes).-                -> Hash256   -- ^ Root of the merkle tree.+buildMerkleRoot :: [TxHash]   -- ^ List of transaction hashes (leaf nodes).+                -> MerkleRoot -- ^ Root of the merkle tree. buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs -hash2 :: Hash256 -> Hash256 -> Hash256+hash2 :: Word256 -> Word256 -> Word256 hash2 a b = doubleHash256 $ encode' a `BS.append` encode' b  -- | Computes the hash of a specific node in a merkle tree. calcHash :: Int       -- ^ Height of the node in the merkle tree.          -> Int       -- ^ Position of the node (0 for the leftmost node).-         -> [Hash256] -- ^ Transaction hashes of the merkle tree (leaf nodes).-         -> Hash256   -- ^ Hash of the node at the specified position.+         -> [TxHash]  -- ^ Transaction hashes of the merkle tree (leaf nodes).+         -> Word256   -- ^ Hash of the node at the specified position. calcHash height pos txs     | height < 0 || pos < 0 = error "calcHash: Invalid parameters"-    | height == 0 = txs !! pos+    | height == 0 = fromIntegral $ txs !! pos     | otherwise = hash2 left right   where     left = calcHash (height-1) (pos*2) txs@@ -51,16 +57,17 @@  -- | Build a partial merkle tree. buildPartialMerkle -    :: [(Hash256,Bool)] +    :: [(TxHash,Bool)]      -- ^ List of transactions hashes forming the leaves of the merkle tree     -- and a bool indicating if that transaction should be included in the      -- partial merkle tree.-    -> ([Bool], [Hash256]) +    -> (FlagBits, PartialMerkleTree)      -- ^ Flag bits (used to parse the partial merkle tree) and the      -- partial merkle tree. buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs -traverseAndBuild :: Int -> Int -> [(Hash256,Bool)] -> ([Bool], [Hash256])+traverseAndBuild :: Int -> Int -> [(TxHash,Bool)] +                 -> (FlagBits, PartialMerkleTree) traverseAndBuild height pos txs     | height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters"     | height == 0 || not match = ([match],[calcHash height pos t])@@ -75,8 +82,8 @@                 = traverseAndBuild (height-1) (pos*2+1) txs             | otherwise = ([],[]) -traverseAndExtract :: Int -> Int -> Int -> [Bool] -> [Hash256] -                   -> Maybe (Hash256, [Hash256], Int, Int)+traverseAndExtract :: Int -> Int -> Int -> FlagBits -> PartialMerkleTree+                   -> Maybe (MerkleRoot, [TxHash], Int, Int) traverseAndExtract height pos ntx flags hashes     | length flags == 0        = Nothing     | height == 0 || not match = leafResult@@ -89,7 +96,8 @@   where     leafResult         | null hashes = Nothing-        | otherwise = Just (h,if height == 0 && match then [h] else [],1,1)+        | otherwise = Just +            (h,if height == 0 && match then [fromIntegral h] else [],1,1)     (match:fs) = flags     (h:_)     = hashes     leftM  = traverseAndExtract (height-1) (pos*2) ntx fs hashes@@ -101,10 +109,10 @@ -- | Extracts the matching hashes from a partial merkle tree. This will return -- the list of transaction hashes that have been included (set to True) in -- a call to 'buildPartialMerkle'.-extractMatches :: [Bool]    -- ^ Flag bits (produced by buildPartialMerkle).-               -> [Hash256] -- ^ Partial merkle tree.-               -> Int       -- ^ Number of transaction at height 0 (leaf nodes).-               -> Either String (Hash256, [Hash256])+extractMatches :: FlagBits -- ^ Flag bits (produced by buildPartialMerkle).+               -> PartialMerkleTree -- ^ Partial merkle tree.+               -> Int -- ^ Number of transaction at height 0 (leaf nodes).+               -> Either String (MerkleRoot, [TxHash])                -- ^ Merkle root and the list of matching transaction hashes. extractMatches flags hashes ntx     | ntx == 0 = Left $@@ -125,6 +133,5 @@   where     resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes     (merkleRoot, matches, nBitsUsed, nHashUsed) = fromJust resM-  

@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}--- | Mnemonic keys (BIP-0039)+-- | Mnemonic keys (BIP-39). Only the English dictionary in the BIP is+-- supported. module Network.Haskoin.Crypto.Mnemonic (   -- * Data types-  WordList-, Entropy+  Entropy , Mnemonic , Passphrase , Seed@@ -14,12 +14,8 @@ , fromMnemonic    -- * Generating 512-bit seeds-, anyToSeed , mnemonicToSeed -  -- * Dictionaries-, english-   -- * Helper functions , getBits ) where@@ -30,53 +26,55 @@ import Data.Bits ((.&.), shiftL, shiftR) import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import Data.Char (isAscii) import Data.List import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)-import Data.Text.ICU.Normalize (NormalizationMode(NFKD), normalize) import Network.Haskoin.Util (bsToInteger, integerToBS) -type WordList = [Text] type Entropy = ByteString-type Mnemonic = Text-type Passphrase = Text+type Mnemonic = String+type Passphrase = String type Seed = ByteString type Checksum = ByteString --- | Provide dictionary and intial entropy as a 'ByteString' with length--- multiple of 32 bits (4 bytes). Output a mnemonic sentence as 'Text'.-toMnemonic :: WordList -> Entropy -> Either String Mnemonic-toMnemonic wl ent = do-    when (remainder /= 0)-        $ Left "toMnemonic: entropy must be multiples of 32 bits"-    when (cs_len > 16)-        $ Left "toMnemonic: maximum entropy is 512 bits"+-- | Provide intial entropy as a 'ByteString' of length multiple of 4 bytes.+-- Output a mnemonic sentence.+toMnemonic :: Entropy -> Either String Mnemonic+toMnemonic ent = do+    when (remainder /= 0) $ +        Left "toMnemonic: entropy must be multiples of 4 bytes"+    when (cs_len > 16) $ +        Left "toMnemonic: maximum entropy is 64 bytes (512 bits)"+    when (isJust $ find (not . isAscii) ms) $+        Left "fromMnemonic: non-ASCII characters not supported"     return ms   where     (cs_len, remainder) = BS.length ent `quotRem` 4     cs = calcCS cs_len ent     indices = bsToIndices $ ent `BS.append` cs-    ms = T.unwords $ map (wl !!) indices+    ms = unwords $ map (wl !!) indices  -- | Revert 'toMnemonic'. Do not use this to generate seeds. Instead use--- 'mnemonicToSeed'.-fromMnemonic :: WordList -> Mnemonic -> Either String Entropy-fromMnemonic wl ms = do-    when (word_count > 48)-        . Left $ "fromMnemonic: too many words: " ++ show word_count-    when (word_count `mod` 3 /= 0)-        . Left $ "fromMnemonic: wrong number of words: " ++ show word_count-    ms_bs <- indicesToBS =<< getIndices wl ms_words+-- 'mnemonicToSeed'. This outputs the original entropy used to generate a+-- mnemonic.+fromMnemonic :: Mnemonic -> Either String Entropy+fromMnemonic ms = do+    when (isJust $ find (not . isAscii) ms) $+        Left "fromMnemonic: non-ASCII characters not supported"+    when (word_count > 48) $ +        Left $ "fromMnemonic: too many words: " ++ show word_count+    when (word_count `mod` 3 /= 0) $ +        Left $ "fromMnemonic: wrong number of words: " ++ show word_count+    ms_bs <- indicesToBS =<< getIndices ms_words     let (ms_ent, ms_cs) = BS.splitAt (ent_len * 4) ms_bs         ms_cs_num = numCS cs_len ms_cs         ent_cs_num = numCS cs_len $ calcCS cs_len ms_ent-    when (ent_cs_num /= ms_cs_num)-        . Left $ "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num+    when (ent_cs_num /= ms_cs_num) $ +        Left $ "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num     return ms_ent   where-    ms_words = T.words $ normalize NFKD ms+    ms_words = words ms     word_count = length ms_words     (ent_len, cs_len) = (word_count * 11) `quotRem` 32     sh cs_a cs_b = show cs_a ++ " /= " ++ show cs_b@@ -91,23 +89,20 @@         0 -> id         x -> flip shiftR x --- | Turn any sequence of characters to a seed. Does not have to be a mnemonic--- sentence generated from 'toMnemonic'. Use 'mnemonicToSeed' to get a seed--- from a mnemonic sentence.+-- | Turn any sequence of characters into a 512-bit seed.  Does not have to be+-- a mnemonic sentence generated from 'toMnemonic'.  Use 'mnemonicToSeed' to+-- get a seed from a mnemonic sentence.  Warning: Does not perform NFKD+-- normalization. anyToSeed :: Passphrase -> Mnemonic -> Seed-anyToSeed pf ms = sha512PBKDF2 p s 2048 64-  where-    p = encodeUtf8 $ normalize NFKD ms-    s = encodeUtf8 $ normalize NFKD ("mnemonic" `T.append` pf)+anyToSeed pf ms = sha512PBKDF2 (B8.pack ms) (B8.pack $ "mnemonic" ++ pf) 2048 64 --- | Get a seed from a mnemonic sentence. Will calculate checksum. Requires--- same dictionary used to generate the mnemonic sentence as first argument.--- Passphrase can be used to protect the mnemonic. Use an empty string as+-- | Get a 512-bit seed from a mnemonic sentence.  Will calculate checksum.+-- Passphrase can be used to protect the mnemonic.  Use an empty string as -- passphrase if none is required.-mnemonicToSeed :: WordList -> Passphrase -> Mnemonic -> Either String Seed-mnemonicToSeed wl pf ms = do-    ent <- fromMnemonic wl ms-    mnm <- toMnemonic wl ent+mnemonicToSeed :: Passphrase -> Mnemonic -> Either String Seed+mnemonicToSeed pf ms = do+    ent <- fromMnemonic ms+    mnm <- toMnemonic ent     return $ anyToSeed pf mnm  -- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString'@@ -123,15 +118,15 @@     i = BS.init s     l = BS.last s .&. (0xff `shiftL` (8 - r))    -- zero unneeded bits --- Expects already normalized list of words-getIndices :: WordList -> [Text] -> Either String [Int]-getIndices wl ws-    | null n = return . fromJust $ sequence i-    | otherwise = Left $ "getIndices: words not found: " ++ T.unpack w+-- | Get indices of words in word list.+getIndices :: [String] -> Either String [Int]+getIndices ws+    | null n = return $ catMaybes i+    | otherwise = Left $ "getIndices: words not found: " ++ w   where     i = map (flip elemIndex wl) ws     n = elemIndices Nothing i-    w = T.unwords $ map (ws !!) n+    w = unwords $ map (ws !!) n  indicesToBS :: [Int] -> Either String ByteString indicesToBS is = do@@ -152,9 +147,9 @@     go 0 _ = []     go n i = (fromIntegral $ i `mod` 2048) : go (n - 1) (i `shiftR` 11) --- | Standard English dictionary from BIP-0039 specification.-english :: [Text]-english =+-- | Standard English dictionary from BIP-39 specification.+wl :: [String]+wl =     [ "abandon", "ability", "able", "about", "above", "absent"     , "absorb", "abstract", "absurd", "abuse", "access", "accident"     , "account", "accuse", "achieve", "acid", "acoustic", "acquire"

@@ -38,6 +38,7 @@ , intMulSigAddrs ) where +import Control.DeepSeq (NFData, rnf) import Control.Monad (liftM2, guard) import Control.Applicative ((<$>)) @@ -57,6 +58,9 @@ newtype MasterKey = MasterKey { masterKey :: XPrvKey }     deriving (Eq, Show, Read) +instance NFData MasterKey where+    rnf (MasterKey m) = rnf m+ -- | Data type representing a private account key. Account keys are generated -- from a 'MasterKey' through prime derivation. This guarantees that the -- 'MasterKey' will not be compromised if the account key is compromised. @@ -64,6 +68,9 @@ newtype AccPrvKey = AccPrvKey { getAccPrvKey :: XPrvKey }     deriving (Eq, Show, Read) +instance NFData AccPrvKey where+    rnf (AccPrvKey k) = rnf k+ -- | Data type representing a public account key. It is computed through -- derivation from an 'AccPrvKey'. It can not be derived from the 'MasterKey' -- directly (property of prime derivation). It is represented as M\/i'\/ in@@ -72,6 +79,9 @@ newtype AccPubKey = AccPubKey { getAccPubKey :: XPubKey }     deriving (Eq, Show, Read) +instance NFData AccPubKey where+    rnf (AccPubKey k) = rnf k+ -- | Data type representing a private address key. Private address keys are -- generated through a non-prime derivation from an 'AccPrvKey'. Non-prime -- derivation is used so that the public account key can generate the receiving@@ -83,6 +93,9 @@ newtype AddrPrvKey = AddrPrvKey { getAddrPrvKey :: XPrvKey }     deriving (Eq, Show, Read) +instance NFData AddrPrvKey where+    rnf (AddrPrvKey k) = rnf k+ -- | Data type representing a public address key. They are generated through -- non-prime derivation from an 'AccPubKey'. This is a useful feature for -- read-only wallets. They are represented as M\/i'\/0\/j in BIP32 notation@@ -91,6 +104,9 @@ newtype AddrPubKey = AddrPubKey { getAddrPubKey :: XPubKey }     deriving (Eq, Show, Read) +instance NFData AddrPubKey where+    rnf (AddrPubKey k) = rnf k+ -- | Create a 'MasterKey' from a seed. makeMasterKey :: BS.ByteString -> Maybe MasterKey makeMasterKey bs = MasterKey <$> makeXPrvKey bs@@ -198,35 +214,35 @@ addr :: AddrPubKey -> Address addr = xPubAddr . getAddrPubKey --- | Computes an external base58 address from an 'AccPubKey' and a +-- | Computes an external address from an 'AccPubKey' and a  -- derivation index.-extAddr :: AccPubKey -> KeyIndex -> Maybe String-extAddr a i = addrToBase58 . addr <$> extPubKey a i+extAddr :: AccPubKey -> KeyIndex -> Maybe Address+extAddr a i = addr <$> extPubKey a i --- | Computes an internal base58 addres from an 'AccPubKey' and a +-- | Computes an internal addres from an 'AccPubKey' and a  -- derivation index.-intAddr :: AccPubKey -> KeyIndex -> Maybe String-intAddr a i = addrToBase58 . addr <$> intPubKey a i+intAddr :: AccPubKey -> KeyIndex -> Maybe Address+intAddr a i = addr <$> intPubKey a i --- | Cyclic list of all external base58 addresses derived from a 'AccPubKey'+-- | Cyclic list of all external addresses derived from a 'AccPubKey' -- and starting from an offset index.-extAddrs :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]+extAddrs :: AccPubKey -> KeyIndex -> [(Address,KeyIndex)] extAddrs a i = mapMaybe f $ cycleIndex i     where f j = liftM2 (,) (extAddr a j) (return j) --- | Cyclic list of all internal base58 addresses derived from a 'AccPubKey'+-- | Cyclic list of all internal addresses derived from a 'AccPubKey' -- and starting from an offset index.-intAddrs :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]+intAddrs :: AccPubKey -> KeyIndex -> [(Address,KeyIndex)] intAddrs a i = mapMaybe f $ cycleIndex i     where f j = liftM2 (,) (intAddr a j) (return j)  -- | Same as 'extAddrs' with the list reversed.-extAddrs' :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]+extAddrs' :: AccPubKey -> KeyIndex -> [(Address,KeyIndex)] extAddrs' a i = mapMaybe f $ cycleIndex' i     where f j = liftM2 (,) (extAddr a j) (return j)  -- | Same as 'intAddrs' with the list reversed.-intAddrs' :: AccPubKey -> KeyIndex -> [(String,KeyIndex)]+intAddrs' :: AccPubKey -> KeyIndex -> [(Address,KeyIndex)] intAddrs' a i = mapMaybe f $ cycleIndex' i     where f j = liftM2 (,) (intAddr a j) (return j) @@ -260,33 +276,33 @@ intMulSigKeys a ps i = mapMaybe f $ cycleIndex i     where f j = liftM2 (,) (intMulSigKey a ps j) (return j) --- | Computes an external base58 multisig address from an 'AccPubKey', a+-- | Computes an external multisig address from an 'AccPubKey', a -- list of thirdparty multisig keys and a derivation index.-extMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe String+extMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe Address extMulSigAddr a ps r i = do     xs <- (map (xPubKey . getAddrPubKey)) <$> extMulSigKey a ps i-    return $ addrToBase58 $ scriptAddr $ sortMulSig $ PayMulSig xs r+    return $ scriptAddr $ sortMulSig $ PayMulSig xs r --- | Computes an internal base58 multisig address from an 'AccPubKey', a+-- | Computes an internal multisig address from an 'AccPubKey', a -- list of thirdparty multisig keys and a derivation index.-intMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe String+intMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe Address intMulSigAddr a ps r i = do     xs <- (map (xPubKey . getAddrPubKey)) <$> intMulSigKey a ps i-    return $ addrToBase58 $ scriptAddr $ sortMulSig $ PayMulSig xs r+    return $ scriptAddr $ sortMulSig $ PayMulSig xs r --- | Cyclic list of all external base58 multisig addresses derived from+-- | Cyclic list of all external multisig addresses derived from -- an 'AccPubKey' and a list of thirdparty multisig keys. The list starts -- at an offset index. extMulSigAddrs :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -              -> [(String,KeyIndex)]+              -> [(Address,KeyIndex)] extMulSigAddrs a ps r i = mapMaybe f $ cycleIndex i     where f j = liftM2 (,) (extMulSigAddr a ps r j) (return j) --- | Cyclic list of all internal base58 multisig addresses derived from+-- | Cyclic list of all internal multisig addresses derived from -- an 'AccPubKey' and a list of thirdparty multisig keys. The list starts -- at an offset index. intMulSigAddrs :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -              -> [(String,KeyIndex)]+              -> [(Address,KeyIndex)] intMulSigAddrs a ps r i = mapMaybe f $ cycleIndex i     where f j = liftM2 (,) (intMulSigAddr a ps r j) (return j) 

@@ -15,6 +15,7 @@  import Data.Bits (shiftR) import Control.Applicative ((<$>))+import Control.DeepSeq (NFData, rnf)  import Network.Haskoin.Crypto.Curve import Network.Haskoin.Crypto.BigWord @@ -33,6 +34,10 @@ -} data Point = Point !FieldP !FieldP !FieldP | InfPoint     deriving (Show, Read)++instance NFData Point where+    rnf (Point p1 p2 p3) = rnf p1 `seq` rnf p2 `seq` rnf p3+    rnf x = x `seq` ()  instance Eq Point where     InfPoint         == InfPoint         = True

@@ -0,0 +1,47 @@+{-|+  This module expose haskoin internals. No guarantee is made on the+  stability of the interface of these internal modules.+-}+module Network.Haskoin.Internals+( module Network.Haskoin.Crypto.NumberTheory+, module Network.Haskoin.Crypto.Curve+, module Network.Haskoin.Crypto.Hash+, module Network.Haskoin.Crypto.BigWord+, module Network.Haskoin.Crypto.Point+, module Network.Haskoin.Crypto.Base58+, module Network.Haskoin.Crypto.Keys+, module Network.Haskoin.Crypto.ExtendedKeys+, module Network.Haskoin.Crypto.NormalizedKeys+, module Network.Haskoin.Crypto.ECDSA+, module Network.Haskoin.Crypto.Mnemonic+, module Network.Haskoin.Crypto.Merkle+, module Network.Haskoin.Crypto.Bloom+, module Network.Haskoin.Protocol.Message+, module Network.Haskoin.Protocol.Types+, module Network.Haskoin.Script.Types+, module Network.Haskoin.Script.Parser+, module Network.Haskoin.Script.SigHash+, module Network.Haskoin.Script.Evaluator+, module Network.Haskoin.Transaction.Builder+) where++import Network.Haskoin.Crypto.NumberTheory+import Network.Haskoin.Crypto.Curve+import Network.Haskoin.Crypto.Hash+import Network.Haskoin.Crypto.BigWord+import Network.Haskoin.Crypto.Point+import Network.Haskoin.Crypto.Base58+import Network.Haskoin.Crypto.Keys+import Network.Haskoin.Crypto.ExtendedKeys+import Network.Haskoin.Crypto.NormalizedKeys+import Network.Haskoin.Crypto.ECDSA+import Network.Haskoin.Crypto.Mnemonic+import Network.Haskoin.Crypto.Merkle+import Network.Haskoin.Crypto.Bloom+import Network.Haskoin.Protocol.Message+import Network.Haskoin.Protocol.Types+import Network.Haskoin.Script.Types+import Network.Haskoin.Script.Parser+import Network.Haskoin.Script.SigHash+import Network.Haskoin.Script.Evaluator+import Network.Haskoin.Transaction.Builder

@@ -16,7 +16,6 @@ , GetHeaders(..) , Headers(..) , BlockHeaderCount-, blockid    -- * Requesting data , GetData(..)@@ -25,28 +24,12 @@ , InvType(..) , NotFound(..) -  -- *Scripts-  -- | More informations on scripts is available here:-  -- <http://en.bitcoin.it/wiki/Script>-, Script(..)-, ScriptOp(..)-, PushDataType(..)-, opPushData-, getScriptOps-, putScriptOps-, decodeScriptOps-, encodeScriptOps-   -- *Transactions , Tx(..)-, txid-, cbid , CoinbaseTx(..) , TxIn(..) , TxOut(..) , OutPoint(..)-, encodeTxid-, decodeTxid    -- * Merkle trees and bloom filters , MerkleBlock(..)@@ -67,6 +50,9 @@ , Ping(..) , Pong(..) , Alert(..)+, Reject(..)+, RejectCode(..)+, reject    -- *Messages , Message(..)@@ -75,25 +61,5 @@ ) where  import Network.Haskoin.Protocol.Message-import Network.Haskoin.Protocol.Addr-import Network.Haskoin.Protocol.Alert-import Network.Haskoin.Protocol.BlockHeader-import Network.Haskoin.Protocol.Block-import Network.Haskoin.Protocol.MerkleBlock-import Network.Haskoin.Protocol.GetBlocks-import Network.Haskoin.Protocol.GetData-import Network.Haskoin.Protocol.GetHeaders-import Network.Haskoin.Protocol.Headers-import Network.Haskoin.Protocol.Inv-import Network.Haskoin.Protocol.InvVector-import Network.Haskoin.Protocol.MessageHeader-import Network.Haskoin.Protocol.NetworkAddress-import Network.Haskoin.Protocol.NotFound-import Network.Haskoin.Protocol.Ping-import Network.Haskoin.Protocol.Script-import Network.Haskoin.Protocol.Tx-import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.VarString-import Network.Haskoin.Protocol.Version-import Network.Haskoin.Protocol.BloomFilter+import Network.Haskoin.Protocol.Types 

@@ -1,39 +0,0 @@-module Network.Haskoin.Protocol.Addr -( Addr(..)-, NetworkAddressTime -) where--import Control.Monad (liftM2, replicateM, forM_)-import Control.Applicative ((<$>))--import Data.Word (Word32)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord32le)-import Data.Binary.Put (putWord32le)--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.NetworkAddress---- | Network address with a timestamp-type NetworkAddressTime = (Word32, NetworkAddress)---- | Provides information on known nodes in the bitcoin network. An 'Addr'--- type is sent inside a 'Message' as a response to a 'GetAddr' message.-data Addr = -    Addr { -           -- List of addresses of other nodes on the network with timestamps.-           addrList :: ![NetworkAddressTime] -         } -    deriving (Eq, Show, Read)--instance Binary Addr where--    get = Addr <$> (repList =<< get)-      where -        repList (VarInt c) = replicateM (fromIntegral c) action-        action             = liftM2 (,) getWord32le get --    put (Addr xs) = do-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs $ \(a,b) -> (putWord32le a) >> (put b)-

@@ -1,21 +0,0 @@-module Network.Haskoin.Protocol.Alert ( Alert(..) ) where--import Control.Applicative ((<$>),(<*>))-import Data.Binary (Binary, get, put)-import Network.Haskoin.Protocol.VarString---- | Data type describing signed messages that can be sent between bitcoin--- nodes to display important notifications to end users about the health of--- the network.-data Alert = -    Alert {-          -- | Alert payload. -            alertPayload   :: !VarString-          -- | ECDSA signature of the payload-          , alertSignature :: !VarString-          } deriving (Eq, Show, Read)--instance Binary Alert where-    get = Alert <$> get <*> get-    put (Alert p s) = put p >> put s-

@@ -1,38 +0,0 @@-module Network.Haskoin.Protocol.Block (Block(..)) where--import Control.Monad (replicateM, forM_)--import Data.Binary (Binary, get, put)--import Network.Haskoin.Protocol.Tx-import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.BlockHeader---- | Data type describing a block in the bitcoin protocol. Blocks are sent in--- response to 'GetData' messages that are requesting information from a--- block hash.-data Block = -    Block {-            -- | Header information for this block.-            blockHeader     :: !BlockHeader-            -- | Coinbase transaction of this block.-          , blockCoinbaseTx :: !CoinbaseTx-            -- | List of transactions pertaining to this block.-          , blockTxns       :: ![Tx]-          } deriving (Eq, Show)--instance Binary Block where--    get = do-        header     <- get-        (VarInt c) <- get-        cb         <- get-        txs        <- replicateM (fromIntegral (c-1)) get-        return $ Block header cb txs--    put (Block h cb txs) = do-        put h-        put $ VarInt $ fromIntegral $ (length txs) + 1-        put cb-        forM_ txs put-

@@ -1,63 +0,0 @@-module Network.Haskoin.Protocol.BlockHeader -( BlockHeader(..) -, blockid-) where--import Control.Applicative ((<$>),(<*>))--import Data.Word (Word32)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord32le)-import Data.Binary.Put (putWord32le)--import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Util ---- | Data type recording information on a 'Block'. The hash of a block is--- defined as the hash of this data structure. The block mining process--- involves finding a partial hash collision by varying the nonce in the--- 'BlockHeader' and/or additional randomness in the 'CoinbaseTx' of this--- 'Block'. Variations in the 'CoinbaseTx' will result in different merkle --- roots in the 'BlockHeader'.-data BlockHeader = -    BlockHeader {-                  -- | Block version information, based on the version of the-                  -- software creating this block.-                  blockVersion   :: !Word32-                  -- | Hash of the previous block (parent) referenced by this-                  -- block.-                , prevBlock      :: !Hash256-                  -- | Root of the merkle tree of all transactions pertaining-                  -- to this block.-                , merkleRoot     :: !Hash256-                  -- | Unix timestamp recording when this block was created-                , blockTimestamp :: !Word32-                  -- | The difficulty target being used for this block-                , blockBits      :: !Word32-                  -- | A random nonce used to generate this block. Additional-                  -- randomness is included in the coinbase transaction of-                  -- this block.-                , bhNonce        :: !Word32-                } deriving (Eq, Show, Read)--instance Binary BlockHeader where--    get = BlockHeader <$> getWord32le-                      <*> get-                      <*> get-                      <*> getWord32le-                      <*> getWord32le-                      <*> getWord32le--    put (BlockHeader v p m bt bb n) = do-        putWord32le v-        put         p-        put         m-        putWord32le bt-        putWord32le bb-        putWord32le n ---- | Compute the hash of a block header-blockid :: BlockHeader -> Hash256-blockid = doubleHash256 . encode'-

@@ -1,101 +0,0 @@-module Network.Haskoin.Protocol.BloomFilter -( BloomFlags(..)-, BloomFilter(..)-, FilterLoad(..)-, FilterAdd(..)-) where--import Control.Monad (replicateM, forM_)-import Control.Applicative ((<$>),(<*>))--import Data.Word (Word8, Word32)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord8, getWord32le, getByteString)-import Data.Binary.Put (putWord8, putWord32le, putByteString)-import qualified Data.Foldable as F (toList)-import qualified Data.Sequence as S (Seq, fromList, length)-import qualified Data.ByteString as BS (ByteString, length)--import Network.Haskoin.Protocol.VarInt---- | The bloom flags are used to tell the remote peer how to auto-update--- the provided bloom filter. -data BloomFlags-    = BloomUpdateNone         -- ^ Never update-    | BloomUpdateAll          -- ^ Auto-update on all outputs-    | BloomUpdateP2PubKeyOnly -    -- ^ Only auto-update on outputs that are pay-to-pubkey or pay-to-multisig.-    -- This is the default setting.-    deriving (Eq, Show, Read)--instance Binary BloomFlags where-    get = go =<< getWord8-      where-        go 0 = return BloomUpdateNone-        go 1 = return BloomUpdateAll-        go 2 = return BloomUpdateP2PubKeyOnly-        go _ = fail "BloomFlags get: Invalid bloom flag"--    put f = putWord8 $ case f of-        BloomUpdateNone         -> 0-        BloomUpdateAll          -> 1-        BloomUpdateP2PubKeyOnly -> 2-            --- | A bloom filter is a probabilistic data structure that SPV clients send to--- other peers to filter the set of transactions received from them. Bloom--- filters are probabilistic and have a false positive rate. Some transactions--- that pass the filter may not be relevant to the receiving peer. By--- controlling the false positive rate, SPV nodes can trade off bandwidth--- versus privacy.-data BloomFilter = BloomFilter-    { bloomData      :: S.Seq Word8 -- ^ Bloom filter data-    , bloomFull      :: Bool        -    -- ^ Flag indicating if the filter is full ('bloomData' is all 0x00)-    , bloomEmpty     :: Bool-    -- ^ Flag indicating if the filter is empty ('bloomData' is all 0xff)-    , bloomHashFuncs :: Word32     -- ^ Number of hash functions for this filter-    , bloomTweak     :: Word32     -- ^ Hash function random nonce-    , bloomFlags     :: BloomFlags -- ^ Bloom filter auto-update flags-    }-    deriving (Eq, Show, Read)--instance Binary BloomFilter where--    get = BloomFilter <$> (S.fromList <$> (readDat =<< get))-                      <*> (return False) <*> (return False)-                      <*> getWord32le <*> getWord32le-                      <*> get-      where-        readDat (VarInt len) = replicateM (fromIntegral len) getWord8   --    put (BloomFilter dat _ _ hashFuncs tweak flags) = do-        put $ VarInt $ fromIntegral $ S.length dat-        forM_ (F.toList dat) putWord8-        putWord32le hashFuncs-        putWord32le tweak-        put flags---- | Set a new bloom filter on the peer connection.-newtype FilterLoad = FilterLoad { getBloomFilter :: BloomFilter }-    deriving (Eq, Show, Read)--instance Binary FilterLoad where-    get = FilterLoad <$> get-    put (FilterLoad f) = put f---- | Add the given data element to the connections current filter without--- requiring a completely new one to be set.-newtype FilterAdd = FilterAdd { getFilterData :: BS.ByteString }-    deriving (Eq, Show, Read)--instance Binary FilterAdd where-    get = do-        (VarInt len) <- get-        dat <- getByteString $ fromIntegral len-        return $ FilterAdd dat--    put (FilterAdd bs) = do-        put $ VarInt $ fromIntegral $ BS.length bs-        putByteString bs--

@@ -1,53 +0,0 @@-module Network.Haskoin.Protocol.GetBlocks -( GetBlocks(..) -, BlockLocator-) where--import Control.Monad (replicateM, forM_)-import Control.Applicative ((<$>),(<*>))--import Data.Word (Word32)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord32le)-import Data.Binary.Put (putWord32le)--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Crypto.Hash --type BlockLocator = [Hash256]---- | Data type representing a GetBlocks message request. It is used in the--- bitcoin protocol to retrieve blocks from a peer by providing it a--- 'BlockLocator' object. The 'BlockLocator' is a sparse list of block hashes--- from the caller node with the purpose of informing the receiving node--- about the state of the caller's blockchain. The receiver node will detect--- a wrong branch in the caller's main chain and send the caller appropriate --- 'Blocks'. The response to a 'GetBlocks' message is an 'Inv' message--- containing the list of block hashes pertaining to the request. -data GetBlocks = -    GetBlocks {-                -- | The protocol version-                getBlocksVersion  :: !Word32-                -- | Block locator object. It is a list of block hashes from the-                -- most recent block back to the genesis block. The list is-                -- dense at first and sparse towards the end.-              , getBlocksLocator  :: !BlockLocator-                -- | Hash of the last desired block. If set to zero, the-                -- maximum number of block hashes is returned (500).-              , getBlocksHashStop :: !Hash256-              } deriving (Eq, Show, Read)--instance Binary GetBlocks where--    get = GetBlocks <$> getWord32le-                    <*> (repList =<< get)-                    <*> get-      where -        repList (VarInt c) = replicateM (fromIntegral c) get--    put (GetBlocks v xs h) = do-        putWord32le v-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs put-        put h-

@@ -1,34 +0,0 @@-module Network.Haskoin.Protocol.GetData ( GetData(..) ) where--import Control.Monad (replicateM, forM_)-import Control.Applicative ((<$>))--import Data.Binary (Binary, get, put)--import Network.Haskoin.Protocol.InvVector-import Network.Haskoin.Protocol.VarInt---- | The 'GetData' type is used to retrieve information on a specific object--- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData'--- request is a list of 'InvVector' which represent all the hashes for which a--- node wants to request information. The response to a 'GetBlock' message--- wille be either a 'Block' or a 'Tx' message depending on the type of the--- object referenced by the hash. Usually, 'GetData' messages are sent after a--- node receives an 'Inv' message to obtain information on unknown object--- hashes. -data GetData = -    GetData {-              -- | List of object hashes -              getDataList :: ![InvVector] -            } deriving (Eq, Show, Read)--instance Binary GetData where--    get = GetData <$> (repList =<< get)-      where -        repList (VarInt c) = replicateM (fromIntegral c) get--    put (GetData xs) = do-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs put-

@@ -1,46 +0,0 @@-module Network.Haskoin.Protocol.GetHeaders ( GetHeaders(..) ) where--import Control.Monad (replicateM, forM_)-import Control.Applicative ((<$>),(<*>))--import Data.Word (Word32)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord32le)-import Data.Binary.Put (putWord32le)--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.GetBlocks -import Network.Haskoin.Crypto.Hash ---- | Similar to the 'GetBlocks' message type but for retrieving block headers--- only. The response to a 'GetHeaders' request is a 'Headers' message--- containing a list of block headers pertaining to the request. A maximum of--- 2000 block headers can be returned. 'GetHeaders' is used by thin (SPV)--- clients to exclude block contents when synchronizing the blockchain.-data GetHeaders = -    GetHeaders {-                 -- | The protocol version-                 getHeadersVersion  :: !Word32-                 -- | Block locator object. It is a list of block hashes from-                 -- the most recent block back to the Genesis block. The list-                 -- is dense at first and sparse towards the end.-               , getHeadersBL       :: !BlockLocator-                 -- | Hash of the last desired block header. When set to zero,-                 -- the maximum number of block headers is returned (2000)-               , getHeadersHashStop :: !Hash256-               } deriving (Eq, Show, Read)--instance Binary GetHeaders where--    get = GetHeaders <$> getWord32le-                     <*> (repList =<< get)-                     <*> get-      where -        repList (VarInt c) = replicateM (fromIntegral c) get--    put (GetHeaders v xs h) = do-        putWord32le v-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs put-        put h-

@@ -1,36 +0,0 @@-module Network.Haskoin.Protocol.Headers -( Headers(..)-, BlockHeaderCount-) where--import Control.Monad (liftM2, replicateM, forM_)-import Control.Applicative ((<$>))--import Data.Binary (Binary, get, put)--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.BlockHeader---- | 'BlockHeader' type with a transaction count as 'VarInt'-type BlockHeaderCount = (BlockHeader, VarInt)---- | The 'Headers' type is used to return a list of block headers in--- response to a 'GetHeaders' message.-data Headers = -    Headers { -              -- | List of block headers with respective transaction counts-              headersList :: ![BlockHeaderCount] -            } -    deriving (Eq, Show, Read)--instance Binary Headers where--    get = Headers <$> (repList =<< get)-      where -        repList (VarInt c) = replicateM (fromIntegral c) action-        action = liftM2 (,) get get--    put (Headers xs) = do-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs $ \(a,b) -> put a >> put b-

@@ -1,29 +0,0 @@-module Network.Haskoin.Protocol.Inv ( Inv(..) ) where--import Control.Monad (replicateM, forM_)-import Control.Applicative ((<$>))--import Data.Binary (Binary, get, put)--import Network.Haskoin.Protocol.InvVector-import Network.Haskoin.Protocol.VarInt---- | 'Inv' messages are used by nodes to advertise their knowledge of new--- objects by publishing a list of hashes. 'Inv' messages can be sent--- unsolicited or in response to a 'GetBlocks' message.-data Inv = -    Inv { -        -- | Inventory vectors-          invList :: ![InvVector] -        } deriving (Eq, Show, Read)--instance Binary Inv where--    get = Inv <$> (repList =<< get)-      where -        repList (VarInt c) = replicateM (fromIntegral c) get--    put (Inv xs) = do-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs put-

@@ -1,54 +0,0 @@-module Network.Haskoin.Protocol.InvVector -( InvVector(..) -, InvType(..)-) where--import Control.Applicative ((<$>),(<*>))--import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord32le)-import Data.Binary.Put (putWord32le)--import Network.Haskoin.Crypto.Hash ---- | Data type identifying the type of an inventory vector. -data InvType -    = InvError -- ^ Error. Data containing this type can be ignored.-    | InvTx    -- ^ InvVector hash is related to a transaction -    | InvBlock -- ^ InvVector hash is related to a block-    | InvMerkleBlock -- ^ InvVector has is related to a merkle block-    deriving (Eq, Show, Read)--instance Binary InvType where--    get = go =<< getWord32le-      where -        go x = case x of-            0 -> return InvError-            1 -> return InvTx-            2 -> return InvBlock-            3 -> return InvMerkleBlock-            _ -> fail "bitcoinGet InvType: Invalid Type"--    put x = putWord32le $ case x of-                InvError       -> 0-                InvTx          -> 1-                InvBlock       -> 2-                InvMerkleBlock -> 3---- | Invectory vectors represent hashes identifying objects such as a 'Block'--- or a 'Tx'. They are sent inside messages to notify other peers about --- new data or data they have requested.-data InvVector = -    InvVector {-                -- | Type of the object referenced by this inventory vector-                invType :: !InvType-                -- | Hash of the object referenced by this inventory vector-              , invHash :: !Hash256-              } deriving (Eq, Show, Read)--instance Binary InvVector where-    get = InvVector <$> get <*> get-    put (InvVector t h) = put t >> put h--

@@ -1,67 +0,0 @@-module Network.Haskoin.Protocol.MerkleBlock (MerkleBlock(..)) where--import Control.Monad (replicateM, forM_)--import Data.Word (Word8, Word32)-import Data.Bits (testBit, setBit)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord8, getWord32le)-import Data.Binary.Put (putWord8, putWord32le)--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.BlockHeader-import Network.Haskoin.Crypto.Hash --data MerkleBlock = -    MerkleBlock {-                -- | Header information for this merkle block.-                  merkleHeader :: !BlockHeader-                -- | Number of transactions in the block (including-                -- unmatched transactions).-                , merkleTotalTxns :: !Word32-                  -- | Hashes in depth-first order. They are used to rebuild a-                  -- partial merkle tree.-                , mHashes     :: [Hash256]-                  -- | Flag bits, packed per 8 in a byte. Least significant bit-                  -- first. Flag bits are used to rebuild a partial merkle-                  -- tree.-                , mFlags      :: [Bool]-                } deriving (Eq, Show, Read)--instance Binary MerkleBlock where--    get = do-        header <- get-        ntx    <- getWord32le-        (VarInt matchLen) <- get-        hashes <- replicateM (fromIntegral matchLen) get-        (VarInt flagLen)  <- get-        ws <- replicateM (fromIntegral flagLen) getWord8-        return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)--    put (MerkleBlock h ntx hashes flags) = do-        put h-        putWord32le ntx-        put $ VarInt $ fromIntegral $ length hashes-        forM_ hashes put-        let ws = encodeMerkleFlags flags-        put $ VarInt $ fromIntegral $ length ws-        forM_ ws putWord8--decodeMerkleFlags :: [Word8] -> [Bool]-decodeMerkleFlags ws = -    [ b | p <- [0..(length ws)*8-1]-    , b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)]-    ]--encodeMerkleFlags :: [Bool] -> [Word8]-encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs-    -splitIn :: Int -> [a] -> [[a]]-splitIn _ [] = []-splitIn c xs = take c xs : (splitIn c $ drop c xs)- -boolsToWord8 :: [Bool] -> Word8-boolsToWord8 [] = 0-boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0..7])-

@@ -1,38 +1,70 @@-module Network.Haskoin.Protocol.Message ( Message(..) ) where+module Network.Haskoin.Protocol.Message +( Message(..) +, MessageHeader(..) +) where +import Control.DeepSeq (NFData, rnf) import Control.Monad (unless)-import Control.Applicative ((<$>))+import Control.Applicative ((<$>),(<*>)) +import Data.Word (Word32) import Data.Binary (Binary, get, put) import Data.Binary.Get      ( lookAhead     , getByteString+    , getWord32le+    , getWord32be     )-import Data.Binary.Put (putByteString)+import Data.Binary.Put +    ( putByteString+    , putWord32le+    , putWord32be+    ) import qualified Data.ByteString as BS      ( length      , append     , empty     ) -import Network.Haskoin.Protocol.MessageHeader-import Network.Haskoin.Protocol.Version-import Network.Haskoin.Protocol.Addr-import Network.Haskoin.Protocol.Inv-import Network.Haskoin.Protocol.GetData-import Network.Haskoin.Protocol.NotFound-import Network.Haskoin.Protocol.GetBlocks-import Network.Haskoin.Protocol.GetHeaders-import Network.Haskoin.Protocol.Tx-import Network.Haskoin.Protocol.Block-import Network.Haskoin.Protocol.Headers-import Network.Haskoin.Protocol.BloomFilter-import Network.Haskoin.Protocol.Ping-import Network.Haskoin.Protocol.Alert+import Network.Haskoin.Protocol.Types  import Network.Haskoin.Util  import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Constants +-- | Data type representing the header of a 'Message'. All messages sent between+-- nodes contain a message header.+data MessageHeader = +    MessageHeader {+                  -- | Network magic bytes. It is used to differentiate +                  -- messages meant for different bitcoin networks, such as+                  -- prodnet and testnet.+                    headMagic       :: !Word32+                  -- | Message command identifying the type of message.+                  -- included in the payload.+                  , headCmd         :: !MessageCommand+                  -- | Byte length of the payload.+                  , headPayloadSize :: !Word32+                  -- | Checksum of the payload. +                  , headChecksum    :: !CheckSum32+                  } deriving (Eq, Show, Read)++instance NFData MessageHeader where+    rnf (MessageHeader m c p s) = rnf m `seq` rnf c `seq` rnf p `seq` rnf s++instance Binary MessageHeader where++    get = MessageHeader <$> getWord32be+                        <*> get+                        <*> getWord32le+                        <*> get++    put (MessageHeader m c l chk) = do+        putWord32be m+        put         c+        putWord32le l+        put         chk+ -- | The 'Message' type is used to identify all the valid messages that can be -- sent between bitcoin peers. Only values of type 'Message' will be accepted -- by other bitcoin peers as bitcoin protocol messages need to be correctly@@ -40,26 +72,47 @@ -- include the 'MessageHeader' with the correct checksum value automatically. -- No need to add the 'MessageHeader' separately. data Message -    = MVersion Version +    = MVersion !Version      | MVerAck -    | MAddr Addr -    | MInv Inv -    | MGetData GetData -    | MNotFound NotFound -    | MGetBlocks GetBlocks -    | MGetHeaders GetHeaders -    | MTx Tx -    | MBlock Block -    | MHeaders Headers +    | MAddr !Addr +    | MInv !Inv +    | MGetData !GetData +    | MNotFound !NotFound +    | MGetBlocks !GetBlocks +    | MGetHeaders !GetHeaders +    | MTx !Tx +    | MBlock !Block +    | MMerkleBlock !MerkleBlock +    | MHeaders !Headers      | MGetAddr -    | MFilterLoad FilterLoad-    | MFilterAdd FilterAdd+    | MFilterLoad !FilterLoad+    | MFilterAdd !FilterAdd     | MFilterClear-    | MPing Ping -    | MPong Pong -    | MAlert Alert-    deriving (Eq, Show)+    | MPing !Ping +    | MPong !Pong +    | MAlert !Alert+    | MReject Reject+    deriving (Eq, Show, Read) +instance NFData Message where+    rnf (MVersion v) = rnf v+    rnf (MAddr a) = rnf a+    rnf (MInv i) = rnf i+    rnf (MGetData d) = rnf d+    rnf (MNotFound n) = rnf n+    rnf (MGetBlocks b) = rnf b+    rnf (MGetHeaders h) = rnf h+    rnf (MTx t) = rnf t+    rnf (MBlock b) = rnf b+    rnf (MMerkleBlock b) = rnf b+    rnf (MHeaders h) = rnf h+    rnf (MFilterLoad f) = rnf f+    rnf (MFilterAdd f) = rnf f+    rnf (MPing p) = rnf p+    rnf (MPong p) = rnf p+    rnf (MAlert a) = rnf a+    rnf x = x `seq` ()+ instance Binary Message where      get = do@@ -80,12 +133,14 @@                 MCGetHeaders  -> MGetHeaders <$> get                 MCTx          -> MTx <$> get                 MCBlock       -> MBlock <$> get+                MCMerkleBlock -> MMerkleBlock <$> get                 MCHeaders     -> MHeaders <$> get                 MCFilterLoad  -> MFilterLoad <$> get                 MCFilterAdd   -> MFilterAdd <$> get                 MCPing        -> MPing <$> get                 MCPong        -> MPong <$> get                 MCAlert       -> MAlert <$> get+                MCReject      -> MReject <$> get                 _             -> fail $ "get: Invalid command " ++ (show cmd)             else case cmd of                 MCGetAddr     -> return MGetAddr @@ -95,24 +150,26 @@      put msg = do         let (cmd, payload) = case msg of-                (MVersion m)    -> (MCVersion, encode' m)-                (MVerAck)       -> (MCVerAck, BS.empty)-                (MAddr m)       -> (MCAddr, encode' m)-                (MInv m)        -> (MCInv, encode' m)-                (MGetData m)    -> (MCGetData, encode' m)-                (MNotFound m)   -> (MCNotFound, encode' m)-                (MGetBlocks m)  -> (MCGetBlocks, encode' m)-                (MGetHeaders m) -> (MCGetHeaders, encode' m)-                (MTx m)         -> (MCTx, encode' m)-                (MBlock m)      -> (MCBlock, encode' m)-                (MHeaders m)    -> (MCHeaders, encode' m)-                (MGetAddr)      -> (MCGetAddr, BS.empty)-                (MFilterLoad m) -> (MCFilterLoad, encode' m)-                (MFilterAdd m)  -> (MCFilterAdd, encode' m)-                (MFilterClear)  -> (MCFilterClear, BS.empty)-                (MPing m)       -> (MCPing, encode' m)-                (MPong m)       -> (MCPong, encode' m)-                (MAlert m)      -> (MCAlert, encode' m)+                MVersion m     -> (MCVersion, encode' m)+                MVerAck        -> (MCVerAck, BS.empty)+                MAddr m        -> (MCAddr, encode' m)+                MInv m         -> (MCInv, encode' m)+                MGetData m     -> (MCGetData, encode' m)+                MNotFound m    -> (MCNotFound, encode' m)+                MGetBlocks m   -> (MCGetBlocks, encode' m)+                MGetHeaders m  -> (MCGetHeaders, encode' m)+                MTx m          -> (MCTx, encode' m)+                MBlock m       -> (MCBlock, encode' m)+                MMerkleBlock m -> (MCMerkleBlock, encode' m)+                MHeaders m     -> (MCHeaders, encode' m)+                MGetAddr       -> (MCGetAddr, BS.empty)+                MFilterLoad m  -> (MCFilterLoad, encode' m)+                MFilterAdd m   -> (MCFilterAdd, encode' m)+                MFilterClear   -> (MCFilterClear, BS.empty)+                MPing m        -> (MCPing, encode' m)+                MPong m        -> (MCPong, encode' m)+                MAlert m       -> (MCAlert, encode' m)+                MReject m      -> (MCReject, encode' m)             chk = chksum32 payload             len = fromIntegral $ BS.length payload             header = MessageHeader networkMagic cmd len chk

@@ -1,134 +0,0 @@-module Network.Haskoin.Protocol.MessageHeader -    ( MessageHeader(..) -    , MessageCommand(..)-    ) where--import Control.Applicative ((<$>),(<*>))--import Data.Word (Word32)-import qualified Data.ByteString as BS -    ( ByteString-    , takeWhile-    )-import Data.Binary (Binary, get, put)-import Data.Binary.Get -    ( getWord32le-    , getWord32be-    , getByteString-    )-import Data.Binary.Put -    ( putWord32le-    , putWord32be-    , putByteString-    )--import Network.Haskoin.Util (stringToBS, bsToString)-import Network.Haskoin.Crypto.Hash (CheckSum32)---- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify--- the type of message present in the payload. This allows the message --- de-serialization code to know how to decode a particular message payload.--- Every valid 'Message' constructor has a corresponding 'MessageCommand'--- constructor.-data MessageCommand -    = MCVersion -    | MCVerAck -    | MCAddr -    | MCInv -    | MCGetData -    | MCNotFound -    | MCGetBlocks -    | MCGetHeaders -    | MCTx -    | MCBlock -    | MCHeaders -    | MCGetAddr -    | MCFilterLoad-    | MCFilterAdd-    | MCFilterClear-    | MCPing -    | MCPong -    | MCAlert-    deriving (Eq, Show, Read)--instance Binary MessageCommand where-    -    get = go =<< getByteString 12-      where -        go bs = case unpackCommand bs of-            "version"     -> return MCVersion-            "verack"      -> return MCVerAck-            "addr"        -> return MCAddr-            "inv"         -> return MCInv-            "getdata"     -> return MCGetData-            "notfound"    -> return MCNotFound-            "getblocks"   -> return MCGetBlocks-            "getheaders"  -> return MCGetHeaders-            "tx"          -> return MCTx-            "block"       -> return MCBlock-            "headers"     -> return MCHeaders-            "getaddr"     -> return MCGetAddr-            "filterload"  -> return MCFilterLoad-            "filteradd"   -> return MCFilterAdd-            "filterclear" -> return MCFilterClear-            "ping"        -> return MCPing-            "pong"        -> return MCPong-            "alert"       -> return MCAlert-            _             -> fail "get MessageCommand : Invalid command"--    put mc = putByteString $ packCommand $ case mc of-        MCVersion     -> "version"-        MCVerAck      -> "verack"-        MCAddr        -> "addr"-        MCInv         -> "inv"-        MCGetData     -> "getdata"-        MCNotFound    -> "notfound"-        MCGetBlocks   -> "getblocks"-        MCGetHeaders  -> "getheaders"-        MCTx          -> "tx"-        MCBlock       -> "block"-        MCHeaders     -> "headers"-        MCGetAddr     -> "getaddr"-        MCFilterLoad  -> "filterload"-        MCFilterAdd   -> "filteradd"-        MCFilterClear -> "filterclear"-        MCPing        -> "ping"-        MCPong        -> "pong"-        MCAlert       -> "alert"--packCommand :: String -> BS.ByteString-packCommand s = stringToBS $ take 12 $ s ++ repeat '\NUL'--unpackCommand :: BS.ByteString -> String-unpackCommand bs = bsToString $ BS.takeWhile (/= 0) bs---- | Data type representing the header of a 'Message'. All messages sent between--- nodes contain a message header.-data MessageHeader = -    MessageHeader {-                  -- | Network magic bytes. It is used to differentiate -                  -- messages meant for different bitcoin networks, such as-                  -- prodnet and testnet.-                    headMagic       :: !Word32-                  -- | Message command identifying the type of message.-                  -- included in the payload.-                  , headCmd         :: !MessageCommand-                  -- | Byte length of the payload.-                  , headPayloadSize :: !Word32-                  -- | Checksum of the payload. -                  , headChecksum    :: !CheckSum32-                  } deriving (Eq, Show, Read)--instance Binary MessageHeader where--    get = MessageHeader <$> getWord32be-                        <*> get-                        <*> getWord32le-                        <*> get--    put (MessageHeader m c l chk) = do-        putWord32be m-        put         c-        putWord32le l-        put         chk-

@@ -1,45 +0,0 @@-module Network.Haskoin.Protocol.NetworkAddress ( NetworkAddress(..) ) where--import Control.Monad (liftM2)-import Control.Applicative ((<$>),(<*>))--import Data.Word (Word16, Word64)-import Data.Binary (Binary, get, put)-import Data.Binary.Get -    ( getWord16be-    , getWord64le-    , getWord64be-    )-import Data.Binary.Put-    ( putWord16be-    , putWord64le-    , putWord64be-    )---- | Data type describing a bitcoin network address. Addresses are stored in--- IPv6. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 addresses:--- <http://en.wikipedia.org/wiki/IPv6#IPv4-mapped_IPv6_addresses>. Sometimes,--- timestamps are sent together with the 'NetworkAddress' such as in the 'Addr'--- data type.-data NetworkAddress = -    NetworkAddress {-                   -- | Bitmask of services available for this address-                     naServices :: !Word64-                   -- | IPv6 address serialized as big endian-                   , naAddress  :: !(Word64, Word64)-                   -- | Port number serialized as big endian-                   , naPort     :: !Word16-                   } deriving (Eq, Show, Read)--instance Binary NetworkAddress where--    get = NetworkAddress <$> getWord64le-                         <*> (liftM2 (,) getWord64be getWord64be)-                         <*> getWord16be--    put (NetworkAddress s (al,ar) p) = do-        putWord64le s-        putWord64be al-        putWord64be ar-        putWord16be p-

@@ -1,30 +0,0 @@-module Network.Haskoin.Protocol.NotFound ( NotFound(..) ) where--import Control.Monad (replicateM, forM_)-import Control.Applicative ((<$>))--import Data.Binary (Binary, get, put)--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.InvVector---- | A 'NotFound' message is returned as a response to a 'GetData' message--- whe one of the requested objects could not be retrieved. This could happen,--- for example, if a tranasaction was requested and was not available in the--- memory pool of the receiving node.-data NotFound = -    NotFound {-             -- | Inventory vectors related to this request-               notFoundList :: ![InvVector] -             } deriving (Eq, Show, Read)--instance Binary NotFound where--    get = NotFound <$> (repList =<< get)-      where -        repList (VarInt c) = replicateM (fromIntegral c) get--    put (NotFound xs) = do-        put $ VarInt $ fromIntegral $ length xs-        forM_ xs put-

@@ -1,37 +0,0 @@-module Network.Haskoin.Protocol.Ping-( Ping(..)-, Pong(..)-) where--import Control.Applicative ((<$>))--import Data.Word (Word64)-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getWord64le)-import Data.Binary.Put (putWord64le)---- | A Ping message is sent to bitcoin peers to check if a TCP\/IP connection--- is still valid.-newtype Ping = -    Ping { -           -- | A random nonce used to identify the recipient of the ping-           -- request once a Pong response is received.  -           pingNonce :: Word64 -         } deriving (Eq, Show, Read)---- | A Pong message is sent as a response to a ping message.-newtype Pong = -    Pong { -           -- | When responding to a Ping request, the nonce from the Ping-           -- is copied in the Pong response.-           pongNonce :: Word64 -         } deriving (Eq, Show, Read)--instance Binary Ping where-    get = Ping <$> getWord64le-    put (Ping n) = putWord64le n--instance Binary Pong where-    get = Pong <$> getWord64le-    put (Pong n) = putWord64le n-

@@ -1,252 +0,0 @@-module Network.Haskoin.Protocol.Script -( ScriptOp(..)-, Script(..)-, PushDataType(..)-, opPushData-, getScriptOps-, putScriptOps-, decodeScriptOps-, encodeScriptOps-) where--import Control.Monad (liftM2, unless, when)-import Control.Applicative ((<$>))--import Data.Word (Word8)-import Data.Binary (Binary, get, put)-import Data.Binary.Get -    ( Get-    , isEmpty-    , getWord8-    , getWord16le-    , getWord32le-    , getByteString-    )-import Data.Binary.Put -    ( Put -    , putWord8-    , putWord16le-    , putWord32le-    , putByteString-    )-import qualified Data.ByteString as BS-    ( ByteString-    , length-    )--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Crypto.Keys -import Network.Haskoin.Util ---- | Data type representing a transaction script. Scripts are defined as lists--- of script operators 'ScriptOp'. Scripts are used to:------ * Define the spending conditions in the output of a transaction------ * Provide the spending signatures in the input of a transaction-data Script = -    Script { -             -- | List of script operators defining this script-             scriptOps :: [ScriptOp] -           }-    deriving (Eq, Show, Read)--instance Binary Script where-    get = do-        (VarInt len) <- get-        isolate (fromIntegral len) $ Script <$> getScriptOps--    put (Script ops) = do-        let bs = runPut' $ putScriptOps ops-        put $ VarInt $ fromIntegral $ BS.length bs-        putByteString bs---- | Deserialize a list of 'ScriptOp' inside the 'Data.Binary.Get' monad.--- This deserialization does not take into account the length of the script.-getScriptOps :: Get [ScriptOp]-getScriptOps = do-    empty <- isEmpty-    if empty -        then return [] -        else liftM2 (:) get getScriptOps---- | Serialize a list of 'ScriptOp' inside the 'Data.Binary.Put' monad.--- This serialization does not take into account the length of the script.-putScriptOps :: [ScriptOp] -> Put-putScriptOps (x:xs) = put x >> putScriptOps xs-putScriptOps _       = return ()---- | Decode a 'Script' from a ByteString by omiting the length of the script.--- This is used to produce scripthash addresses.-decodeScriptOps :: BS.ByteString -> Either String Script-decodeScriptOps bs = fromRunGet getScriptOps bs msg (return . Script)-  where -    msg = Left "decodeScriptOps: Could not decode scriptops"---- | Encode a 'Script' into a ByteString by omiting the length of the script.--- This is used to produce scripthash addresses.-encodeScriptOps :: Script -> BS.ByteString-encodeScriptOps = runPut' . putScriptOps . scriptOps---- | Data type representing the type of an OP_PUSHDATA opcode.-data PushDataType-    = -      -- | The next opcode bytes is data to be pushed onto the stack-      OPCODE -      -- | The next byte contains the number of bytes to be pushed onto-      -- the stack-    | OPDATA1 -      -- | The next two bytes contains the number of bytes to be pushed onto-      -- the stack-    | OPDATA2-      -- | The next four bytes contains the number of bytes to be pushed onto-      -- the stack-    | OPDATA4-    deriving (Show, Read, Eq)---- | Data type representing all of the operators allowed inside a 'Script'.-data ScriptOp -      -- Pushing Data-    = OP_PUSHDATA BS.ByteString PushDataType -    | OP_0 -    | OP_1NEGATE -    | 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 --      -- Flow control-    | OP_VERIFY --      -- Stack operations-    | OP_DUP --      -- Bitwise logic-    | OP_EQUAL -    | OP_EQUALVERIFY --      -- Crypto-    | OP_HASH160 -    | OP_CHECKSIG -    | OP_CHECKMULTISIG --      -- Other-    | OP_PUBKEY PubKey -    | OP_INVALIDOPCODE Word8-        deriving (Show, Read, Eq)--instance Binary ScriptOp where--    get = go =<< (fromIntegral <$> getWord8) -      where -        go op -            | op == 0x00 = return $ OP_0-            | op <= 0x4b = do-                payload <- getByteString (fromIntegral op)-                return $ OP_PUSHDATA payload OPCODE-            | op == 0x4c = do-                len  <- getWord8-                payload <- getByteString (fromIntegral len)-                return $ OP_PUSHDATA payload OPDATA1-            | op == 0x4d = do-                len  <- getWord16le-                payload <- getByteString (fromIntegral len)-                return $ OP_PUSHDATA payload OPDATA2-            | op == 0x4e = do-                len  <- getWord32le-                payload <- getByteString (fromIntegral len)-                return $ OP_PUSHDATA payload OPDATA4-            | op == 0x4f = return $ OP_1NEGATE-            | op == 0x51 = return $ OP_1-            | op == 0x52 = return $ OP_2-            | op == 0x53 = return $ OP_3-            | op == 0x54 = return $ OP_4-            | op == 0x55 = return $ OP_5-            | op == 0x56 = return $ OP_6-            | op == 0x57 = return $ OP_7-            | op == 0x58 = return $ OP_8-            | op == 0x59 = return $ OP_9-            | op == 0x5a = return $ OP_10-            | op == 0x5b = return $ OP_11-            | op == 0x5c = return $ OP_12-            | op == 0x5d = return $ OP_13-            | op == 0x5e = return $ OP_14-            | op == 0x5f = return $ OP_15-            | op == 0x60 = return $ OP_16-            | op == 0x69 = return $ OP_VERIFY-            | op == 0x76 = return $ OP_DUP-            | op == 0x87 = return $ OP_EQUAL-            | op == 0x88 = return $ OP_EQUALVERIFY-            | op == 0xa9 = return $ OP_HASH160-            | op == 0xac = return $ OP_CHECKSIG-            | op == 0xae = return $ OP_CHECKMULTISIG-            | op == 0xfe = OP_PUBKEY <$> get-            | otherwise = return $ OP_INVALIDOPCODE op--    put op = case op of--        (OP_PUSHDATA payload optype)-> do-            let len = BS.length payload-            when (len == 0) $ fail "OP_PUSHDATA: Payload size must be > 0"-            case optype of-                OPCODE -> do-                    unless (len <= 0x4b) $ fail -                        "OP_PUSHDATA OPCODE: Payload size too big"-                    putWord8 $ fromIntegral len-                OPDATA1 -> do-                    unless (len <= 0xff) $ fail -                        "OP_PUSHDATA OPDATA1: Payload size too big"-                    putWord8 0x4c-                    putWord8 $ fromIntegral len-                OPDATA2 -> do-                    unless (len <= 0xffff) $ fail -                        "OP_PUSHDATA OPDATA2: Payload size too big"-                    putWord8 0x4d-                    putWord16le $ fromIntegral len-                OPDATA4 -> do-                    unless (len <= 0xffffffff) $ fail -                        "OP_PUSHDATA OPDATA4: Payload size too big"-                    putWord8 0x4e-                    putWord32le $ fromIntegral len-            putByteString payload--        OP_0                 -> putWord8 0x00-        OP_1NEGATE           -> putWord8 0x4f-        OP_1                 -> putWord8 0x51-        OP_2                 -> putWord8 0x52-        OP_3                 -> putWord8 0x53-        OP_4                 -> putWord8 0x54-        OP_5                 -> putWord8 0x55-        OP_6                 -> putWord8 0x56-        OP_7                 -> putWord8 0x57-        OP_8                 -> putWord8 0x58-        OP_9                 -> putWord8 0x59-        OP_10                -> putWord8 0x5a-        OP_11                -> putWord8 0x5b-        OP_12                -> putWord8 0x5c-        OP_13                -> putWord8 0x5d-        OP_14                -> putWord8 0x5e-        OP_15                -> putWord8 0x5f-        OP_16                -> putWord8 0x60-        OP_VERIFY            -> putWord8 0x69-        OP_DUP               -> putWord8 0x76-        OP_EQUAL             -> putWord8 0x87-        OP_EQUALVERIFY       -> putWord8 0x88-        OP_HASH160           -> putWord8 0xa9-        OP_CHECKSIG          -> putWord8 0xac-        OP_CHECKMULTISIG     -> putWord8 0xae-        (OP_PUBKEY pk)       -> putWord8 0xfe >> put pk-        (OP_INVALIDOPCODE _) -> putWord8 0xff---- | Optimally encode data using one of the 4 types of data pushing opcodes-opPushData :: BS.ByteString -> ScriptOp-opPushData bs-    | len <= 0          = error "opPushData: data length must be > 0"-    | len <= 0x4b       = OP_PUSHDATA bs OPCODE-    | len <= 0xff       = OP_PUSHDATA bs OPDATA1-    | len <= 0xffff     = OP_PUSHDATA bs OPDATA2-    | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4-    | otherwise         = error "opPushData: payload size too big"-  where-    len = BS.length bs-

@@ -1,194 +0,0 @@-module Network.Haskoin.Protocol.Tx -( Tx(..) -, TxIn(..)-, TxOut(..)-, OutPoint(..)-, CoinbaseTx(..)-, txid-, cbid-, encodeTxid-, decodeTxid-) where--import Control.Monad (replicateM, forM_, liftM2, unless)-import Control.Applicative ((<$>),(<*>))--import Data.Word (Word32, Word64)-import Data.Binary (Binary, get, put)-import Data.Binary.Get -    ( getWord32le-    , getWord64le-    , getByteString-    )-import Data.Binary.Put -    ( putWord32le-    , putWord64le-    , putByteString-    )-import qualified Data.ByteString as BS -    ( ByteString-    , length-    , reverse-    )--import Network.Haskoin.Protocol.VarInt-import Network.Haskoin.Protocol.Script-import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Util ---- | Data type representing a bitcoin transaction-data Tx = -    Tx { -         -- | Transaction data format version-         txVersion  :: !Word32-         -- | List of transaction inputs-       , txIn       :: ![TxIn]-         -- | List of transaction outputs-       , txOut      :: ![TxOut]-         -- | The block number of timestamp at which this transaction is locked-       , txLockTime :: !Word32-       } deriving (Eq, Show, Read)--instance Binary Tx where--    get = Tx <$> getWord32le-             <*> (replicateList =<< get)-             <*> (replicateList =<< get)-             <*> getWord32le-      where -        replicateList (VarInt c) = replicateM (fromIntegral c) get--    put (Tx v is os l) = do-        putWord32le v-        put $ VarInt $ fromIntegral $ length is-        forM_ is put-        put $ VarInt $ fromIntegral $ length os-        forM_ os put-        putWord32le l---- | Data type representing the coinbase transaction of a 'Block'. Coinbase--- transactions are special types of transactions which are created by miners--- when they find a new block. Coinbase transactions have no inputs. They have--- outputs sending the newly generated bitcoins together with all the block's--- fees to a bitcoin address (usually the miners address). Data can be embedded--- in a Coinbase transaction which can be chosen by the miner of a block. This--- data also typically contains some randomness which is used, together with--- the nonce, to find a partial hash collision on the block's hash.-data CoinbaseTx = -    CoinbaseTx { -                 -- | Transaction data format version.-                 cbVersion    :: !Word32-                 -- | Previous outpoint. This is ignored for-                 -- coinbase transactions but preserved for computing-                 -- the correct txid.-               , cbPrevOutput :: !OutPoint-                 -- | Data embedded inside the coinbase transaction.-               , cbData       :: !BS.ByteString-                 -- | Transaction sequence number. This is ignored for-                 -- coinbase transactions but preserved for computing-                 -- the correct txid.-               , cbInSequence :: !Word32-                 -- | List of transaction outputs.-               , cbOut        :: ![TxOut]-                 -- | The block number of timestamp at which this -                 -- transaction is locked.-               , cbLockTime   :: !Word32-               } deriving (Eq, Show, Read)--instance Binary CoinbaseTx where--    get = do-        v <- getWord32le-        (VarInt len) <- get-        unless (len == 1) $ fail "CoinbaseTx get: Input size is not 1"-        op <- get-        (VarInt cbLen) <- get-        cb <- getByteString (fromIntegral cbLen)-        sq <- getWord32le-        (VarInt oLen) <- get-        os <- replicateM (fromIntegral oLen) get-        lt <- getWord32le-        return $ CoinbaseTx v op cb sq os lt--    put (CoinbaseTx v op cb sq os lt) = do-        putWord32le v-        put $ VarInt 1-        put op-        put $ VarInt $ fromIntegral $ BS.length cb-        putByteString cb -        putWord32le sq-        put $ VarInt $ fromIntegral $ length os-        forM_ os put-        putWord32le lt---- | Data type representing a transaction input.-data TxIn = -    TxIn { -           -- | Reference the previous transaction output (hash + position)-           prevOutput   :: !OutPoint-           -- | Script providing the requirements of the previous transaction-           -- output to spend those coins.-         , scriptInput  :: !Script-           -- | Transaction version as defined by the sender of the-           -- transaction. The intended use is for replacing transactions with-           -- new information before the transaction is included in a block.-         , txInSequence :: !Word32-         } deriving (Eq, Show, Read)--instance Binary TxIn where-    get = TxIn <$> get <*> get <*> getWord32le-    put (TxIn o s q) = put o >> put s >> putWord32le q---- | Data type representing a transaction output.-data TxOut = -    TxOut { -            -- | Transaction output value.-            outValue     :: !Word64-            -- | Script specifying the conditions to spend this output.-          , scriptOutput :: !Script-          } deriving (Eq, Show, Read)--instance Binary TxOut where-    get = do-        val <- getWord64le-        unless (val <= 2100000000000000) $ fail $-            "Invalid TxOut value: " ++ (show val)-        TxOut val <$> get-    put (TxOut o s) = putWord64le o >> put s---- | The OutPoint is used inside a transaction input to reference the previous--- transaction output that it is spending.-data OutPoint = -    OutPoint { -               -- | The hash of the referenced transaction.-               outPointHash  :: !Hash256-               -- | The position of the specific output in the transaction.-               -- The first output position is 0.-             , outPointIndex :: !Word32-             } deriving (Read, Show, Eq)--instance Binary OutPoint where-    get = do-        (h,i) <- liftM2 (,) get getWord32le-        return $ OutPoint h i-    put (OutPoint h i) = put h >> putWord32le i---- | Computes the hash of a transaction.-txid :: Tx -> Hash256-txid = doubleHash256 . encode' ---- | Computes the hash of a coinbase transaction.-cbid :: CoinbaseTx -> Hash256-cbid = doubleHash256 . encode' ---- | Encodes a transaction hash as little endian in HEX format.--- This is mostly used for displaying transaction ids. Internally, these ids--- are handled as big endian but are transformed to little endian when--- displaying them.-encodeTxid :: Hash256 -> String-encodeTxid = bsToHex . BS.reverse .  encode' ---- | Decodes a little endian transaction hash in HEX format. -decodeTxid :: String -> Maybe Hash256-decodeTxid = (decodeToMaybe . BS.reverse =<<) . hexToBS-

@@ -0,0 +1,1089 @@+module Network.Haskoin.Protocol.Types +( Addr(..)+, NetworkAddressTime +, Alert(..)+, Block(..)+, BlockHeader(..) +, BloomFlags(..)+, BloomFilter(..)+, FilterLoad(..)+, FilterAdd(..)+, GetBlocks(..) +, BlockLocator+, GetData(..)+, GetHeaders(..)+, Headers(..)+, BlockHeaderCount+, Inv(..)+, InvVector(..) +, InvType(..)+, MerkleBlock(..)+, NetworkAddress(..)+, NotFound(..)+, Ping(..)+, Pong(..)+, Reject(..)+, RejectCode(..)+, reject+, Tx(..) +, TxIn(..)+, TxOut(..)+, OutPoint(..)+, CoinbaseTx(..)+, VarInt(..)+, VarString(..)+, Version(..)+, MessageCommand(..)+) where++import Control.DeepSeq (NFData, rnf)+import Control.Monad (liftM2, replicateM, forM_, unless)+import Control.Applicative ((<$>),(<*>))++import Data.Aeson (Value(String), FromJSON, ToJSON, parseJSON, toJSON, withText)+import Data.Bits (testBit, setBit)+import Data.Word (Word8, Word16, Word32, Word64)+import qualified Data.Text as T+import Data.Binary (Binary, get, put)+import Data.Binary.Get +    ( Get+    , getWord8+    , getWord16le+    , getWord16be+    , getWord32le+    , getWord64le+    , getWord64be+    , getByteString+    , isEmpty+    )+import Data.Binary.Put +    ( Put+    , putWord8+    , putWord16le+    , putWord16be+    , putWord32le+    , putWord64le+    , putWord64be+    , putByteString+    )+import qualified Data.Foldable as F (toList)+import qualified Data.Sequence as S (Seq, fromList, length)+import qualified Data.ByteString as BS +    ( ByteString+    , length+    , takeWhile+    )++import Network.Haskoin.Util +import Network.Haskoin.Crypto.BigWord++-- | Network address with a timestamp+type NetworkAddressTime = (Word32, NetworkAddress)++-- | Provides information on known nodes in the bitcoin network. An 'Addr'+-- type is sent inside a 'Message' as a response to a 'GetAddr' message.+data Addr = +    Addr { +           -- List of addresses of other nodes on the network with timestamps.+           addrList :: ![NetworkAddressTime] +         } +    deriving (Eq, Show, Read)++instance NFData Addr where+    rnf (Addr as) = rnf as++instance Binary Addr where++    get = Addr <$> (repList =<< get)+      where +        repList (VarInt c) = replicateM (fromIntegral c) action+        action             = liftM2 (,) getWord32le get ++    put (Addr xs) = do+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs $ \(a,b) -> (putWord32le a) >> (put b)++-- | Data type describing signed messages that can be sent between bitcoin+-- nodes to display important notifications to end users about the health of+-- the network.+data Alert = +    Alert {+          -- | Alert payload. +            alertPayload   :: !VarString+          -- | ECDSA signature of the payload+          , alertSignature :: !VarString+          } deriving (Eq, Show, Read)++instance NFData Alert where+    rnf (Alert p s) = rnf p `seq` rnf s++instance Binary Alert where+    get = Alert <$> get <*> get+    put (Alert p s) = put p >> put s++-- | Data type describing a block in the bitcoin protocol. Blocks are sent in+-- response to 'GetData' messages that are requesting information from a+-- block hash.+data Block = +    Block {+            -- | Header information for this block.+            blockHeader     :: !BlockHeader+            -- | Coinbase transaction of this block.+          , blockCoinbaseTx :: !CoinbaseTx+            -- | List of transactions pertaining to this block.+          , blockTxns       :: ![Tx]+          } deriving (Eq, Show, Read)++instance NFData Block where+    rnf (Block h c ts) = rnf h `seq` rnf c `seq` rnf ts++instance Binary Block where++    get = do+        header     <- get+        (VarInt c) <- get+        cb         <- get+        txs        <- replicateM (fromIntegral (c-1)) get+        return $ Block header cb txs++    put (Block h cb txs) = do+        put h+        put $ VarInt $ fromIntegral $ (length txs) + 1+        put cb+        forM_ txs put++-- | Data type recording information on a 'Block'. The hash of a block is+-- defined as the hash of this data structure. The block mining process+-- involves finding a partial hash collision by varying the nonce in the+-- 'BlockHeader' and/or additional randomness in the 'CoinbaseTx' of this+-- 'Block'. Variations in the 'CoinbaseTx' will result in different merkle +-- roots in the 'BlockHeader'.+data BlockHeader = +    BlockHeader {+                  -- | Block version information, based on the version of the+                  -- software creating this block.+                  blockVersion   :: !Word32+                  -- | Hash of the previous block (parent) referenced by this+                  -- block.+                , prevBlock      :: !BlockHash+                  -- | Root of the merkle tree of all transactions pertaining+                  -- to this block.+                , merkleRoot     :: !Word256+                  -- | Unix timestamp recording when this block was created+                , blockTimestamp :: !Word32+                  -- | The difficulty target being used for this block+                , blockBits      :: !Word32+                  -- | A random nonce used to generate this block. Additional+                  -- randomness is included in the coinbase transaction of+                  -- this block.+                , bhNonce        :: !Word32+                } deriving (Eq, Show, Read)++instance NFData BlockHeader where+    rnf (BlockHeader v p m t b n) =+        rnf v `seq` rnf p `seq` rnf m `seq` rnf t `seq` rnf b `seq` rnf n++instance Binary BlockHeader where++    get = BlockHeader <$> getWord32le+                      <*> get+                      <*> get+                      <*> getWord32le+                      <*> getWord32le+                      <*> getWord32le++    put (BlockHeader v p m bt bb n) = do+        putWord32le v+        put         p+        put         m+        putWord32le bt+        putWord32le bb+        putWord32le n ++-- | The bloom flags are used to tell the remote peer how to auto-update+-- the provided bloom filter. +data BloomFlags+    = BloomUpdateNone         -- ^ Never update+    | BloomUpdateAll          -- ^ Auto-update on all outputs+    | BloomUpdateP2PubKeyOnly +    -- ^ Only auto-update on outputs that are pay-to-pubkey or pay-to-multisig.+    -- This is the default setting.+    deriving (Eq, Show, Read)++instance NFData BloomFlags++instance Binary BloomFlags where+    get = go =<< getWord8+      where+        go 0 = return BloomUpdateNone+        go 1 = return BloomUpdateAll+        go 2 = return BloomUpdateP2PubKeyOnly+        go _ = fail "BloomFlags get: Invalid bloom flag"++    put f = putWord8 $ case f of+        BloomUpdateNone         -> 0+        BloomUpdateAll          -> 1+        BloomUpdateP2PubKeyOnly -> 2+            +-- | A bloom filter is a probabilistic data structure that SPV clients send to+-- other peers to filter the set of transactions received from them. Bloom+-- filters are probabilistic and have a false positive rate. Some transactions+-- that pass the filter may not be relevant to the receiving peer. By+-- controlling the false positive rate, SPV nodes can trade off bandwidth+-- versus privacy.+data BloomFilter = BloomFilter+    { bloomData      :: !(S.Seq Word8)+    -- ^ Bloom filter data+    , bloomHashFuncs :: !Word32+    -- ^ Number of hash functions for this filter+    , bloomTweak     :: !Word32+    -- ^ Hash function random nonce+    , bloomFlags     :: !BloomFlags+    -- ^ Bloom filter auto-update flags+    }+    deriving (Eq, Show, Read)++instance NFData BloomFilter where+    rnf (BloomFilter d h t g) =+        rnf d `seq` rnf h `seq` rnf t `seq` rnf g++instance Binary BloomFilter where++    get = BloomFilter <$> (S.fromList <$> (readDat =<< get))+                      <*> getWord32le <*> getWord32le+                      <*> get+      where+        readDat (VarInt len) = replicateM (fromIntegral len) getWord8   ++    put (BloomFilter dat hashFuncs tweak flags) = do+        put $ VarInt $ fromIntegral $ S.length dat+        forM_ (F.toList dat) putWord8+        putWord32le hashFuncs+        putWord32le tweak+        put flags++-- | Set a new bloom filter on the peer connection.+newtype FilterLoad = FilterLoad { getBloomFilter :: BloomFilter }+    deriving (Eq, Show, Read)++instance NFData FilterLoad where+    rnf (FilterLoad f) = rnf f++instance Binary FilterLoad where+    get = FilterLoad <$> get+    put (FilterLoad f) = put f++-- | Add the given data element to the connections current filter without+-- requiring a completely new one to be set.+newtype FilterAdd = FilterAdd { getFilterData :: BS.ByteString }+    deriving (Eq, Show, Read)++instance NFData FilterAdd where+    rnf (FilterAdd f) = rnf f++instance Binary FilterAdd where+    get = do+        (VarInt len) <- get+        dat <- getByteString $ fromIntegral len+        return $ FilterAdd dat++    put (FilterAdd bs) = do+        put $ VarInt $ fromIntegral $ BS.length bs+        putByteString bs++type BlockLocator = [BlockHash]++-- | Data type representing a GetBlocks message request. It is used in the+-- bitcoin protocol to retrieve blocks from a peer by providing it a+-- 'BlockLocator' object. The 'BlockLocator' is a sparse list of block hashes+-- from the caller node with the purpose of informing the receiving node+-- about the state of the caller's blockchain. The receiver node will detect+-- a wrong branch in the caller's main chain and send the caller appropriate +-- 'Blocks'. The response to a 'GetBlocks' message is an 'Inv' message+-- containing the list of block hashes pertaining to the request. +data GetBlocks = +    GetBlocks {+                -- | The protocol version+                getBlocksVersion  :: !Word32+                -- | Block locator object. It is a list of block hashes from the+                -- most recent block back to the genesis block. The list is+                -- dense at first and sparse towards the end.+              , getBlocksLocator  :: !BlockLocator+                -- | Hash of the last desired block. If set to zero, the+                -- maximum number of block hashes is returned (500).+              , getBlocksHashStop :: !BlockHash+              } deriving (Eq, Show, Read)++instance NFData GetBlocks where+    rnf (GetBlocks v l h) = rnf v `seq` rnf l `seq` rnf h++instance Binary GetBlocks where++    get = GetBlocks <$> getWord32le+                    <*> (repList =<< get)+                    <*> get+      where +        repList (VarInt c) = replicateM (fromIntegral c) get++    put (GetBlocks v xs h) = do+        putWord32le v+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs put+        put h++-- | The 'GetData' type is used to retrieve information on a specific object+-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData'+-- request is a list of 'InvVector' which represent all the hashes for which a+-- node wants to request information. The response to a 'GetBlock' message+-- wille be either a 'Block' or a 'Tx' message depending on the type of the+-- object referenced by the hash. Usually, 'GetData' messages are sent after a+-- node receives an 'Inv' message to obtain information on unknown object+-- hashes. +data GetData = +    GetData {+              -- | List of object hashes +              getDataList :: ![InvVector] +            } deriving (Eq, Show, Read)++instance NFData GetData where+    rnf (GetData l) = rnf l++instance Binary GetData where++    get = GetData <$> (repList =<< get)+      where +        repList (VarInt c) = replicateM (fromIntegral c) get++    put (GetData xs) = do+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs put++-- | Similar to the 'GetBlocks' message type but for retrieving block headers+-- only. The response to a 'GetHeaders' request is a 'Headers' message+-- containing a list of block headers pertaining to the request. A maximum of+-- 2000 block headers can be returned. 'GetHeaders' is used by thin (SPV)+-- clients to exclude block contents when synchronizing the blockchain.+data GetHeaders = +    GetHeaders {+                 -- | The protocol version+                 getHeadersVersion  :: !Word32+                 -- | Block locator object. It is a list of block hashes from+                 -- the most recent block back to the Genesis block. The list+                 -- is dense at first and sparse towards the end.+               , getHeadersBL       :: !BlockLocator+                 -- | Hash of the last desired block header. When set to zero,+                 -- the maximum number of block headers is returned (2000)+               , getHeadersHashStop :: !BlockHash+               } deriving (Eq, Show, Read)++instance NFData GetHeaders where+    rnf (GetHeaders v l h) = rnf v `seq` rnf l `seq` rnf h++instance Binary GetHeaders where++    get = GetHeaders <$> getWord32le+                     <*> (repList =<< get)+                     <*> get+      where +        repList (VarInt c) = replicateM (fromIntegral c) get++    put (GetHeaders v xs h) = do+        putWord32le v+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs put+        put h++-- | 'BlockHeader' type with a transaction count as 'VarInt'+type BlockHeaderCount = (BlockHeader, VarInt)++-- | The 'Headers' type is used to return a list of block headers in+-- response to a 'GetHeaders' message.+data Headers = +    Headers { +              -- | List of block headers with respective transaction counts+              headersList :: ![BlockHeaderCount] +            } +    deriving (Eq, Show, Read)++instance NFData Headers where+    rnf (Headers l) = rnf l++instance Binary Headers where++    get = Headers <$> (repList =<< get)+      where +        repList (VarInt c) = replicateM (fromIntegral c) action+        action = liftM2 (,) get get++    put (Headers xs) = do+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs $ \(a,b) -> put a >> put b++-- | 'Inv' messages are used by nodes to advertise their knowledge of new+-- objects by publishing a list of hashes. 'Inv' messages can be sent+-- unsolicited or in response to a 'GetBlocks' message.+data Inv = +    Inv { +        -- | Inventory vectors+          invList :: ![InvVector] +        } deriving (Eq, Show, Read)++instance NFData Inv where+    rnf (Inv l) = rnf l++instance Binary Inv where++    get = Inv <$> (repList =<< get)+      where +        repList (VarInt c) = replicateM (fromIntegral c) get++    put (Inv xs) = do+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs put++-- | Data type identifying the type of an inventory vector. +data InvType +    = InvError -- ^ Error. Data containing this type can be ignored.+    | InvTx    -- ^ InvVector hash is related to a transaction +    | InvBlock -- ^ InvVector hash is related to a block+    | InvMerkleBlock -- ^ InvVector has is related to a merkle block+    deriving (Eq, Show, Read)++instance NFData InvType++instance Binary InvType where++    get = go =<< getWord32le+      where +        go x = case x of+            0 -> return InvError+            1 -> return InvTx+            2 -> return InvBlock+            3 -> return InvMerkleBlock+            _ -> fail "bitcoinGet InvType: Invalid Type"++    put x = putWord32le $ case x of+                InvError       -> 0+                InvTx          -> 1+                InvBlock       -> 2+                InvMerkleBlock -> 3++-- | Invectory vectors represent hashes identifying objects such as a 'Block'+-- or a 'Tx'. They are sent inside messages to notify other peers about +-- new data or data they have requested.+data InvVector = +    InvVector {+                -- | Type of the object referenced by this inventory vector+                invType :: !InvType+                -- | Hash of the object referenced by this inventory vector+              , invHash :: !Word256+              } deriving (Eq, Show, Read)++instance NFData InvVector where+    rnf (InvVector t h) = rnf t `seq` rnf h++instance Binary InvVector where+    get = InvVector <$> get <*> get+    put (InvVector t h) = put t >> put h++data MerkleBlock = +    MerkleBlock {+                -- | Header information for this merkle block.+                  merkleHeader :: !BlockHeader+                -- | Number of transactions in the block (including+                -- unmatched transactions).+                , merkleTotalTxns :: !Word32+                  -- | Hashes in depth-first order. They are used to rebuild a+                  -- partial merkle tree.+                , mHashes :: ![Word256]+                  -- | Flag bits, packed per 8 in a byte. Least significant bit+                  -- first. Flag bits are used to rebuild a partial merkle+                  -- tree.+                , mFlags :: ![Bool]+                } deriving (Eq, Show, Read)++instance NFData MerkleBlock where+    rnf (MerkleBlock m t h f) = rnf m `seq` rnf t `seq` rnf h `seq` rnf f++instance Binary MerkleBlock where++    get = do+        header <- get+        ntx    <- getWord32le+        (VarInt matchLen) <- get+        hashes <- replicateM (fromIntegral matchLen) get+        (VarInt flagLen)  <- get+        ws <- replicateM (fromIntegral flagLen) getWord8+        return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)++    put (MerkleBlock h ntx hashes flags) = do+        put h+        putWord32le ntx+        put $ VarInt $ fromIntegral $ length hashes+        forM_ hashes put+        let ws = encodeMerkleFlags flags+        put $ VarInt $ fromIntegral $ length ws+        forM_ ws putWord8++decodeMerkleFlags :: [Word8] -> [Bool]+decodeMerkleFlags ws = +    [ b | p <- [0..(length ws)*8-1]+    , b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)]+    ]++encodeMerkleFlags :: [Bool] -> [Word8]+encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs+    +splitIn :: Int -> [a] -> [[a]]+splitIn _ [] = []+splitIn c xs = take c xs : (splitIn c $ drop c xs)+ +boolsToWord8 :: [Bool] -> Word8+boolsToWord8 [] = 0+boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0..7])++-- | Data type describing a bitcoin network address. Addresses are stored in+-- IPv6. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 addresses:+-- <http://en.wikipedia.org/wiki/IPv6#IPv4-mapped_IPv6_addresses>. Sometimes,+-- timestamps are sent together with the 'NetworkAddress' such as in the 'Addr'+-- data type.+data NetworkAddress = +    NetworkAddress {+                   -- | Bitmask of services available for this address+                     naServices :: !Word64+                   -- | IPv6 address serialized as big endian+                   , naAddress  :: !(Word64, Word64)+                   -- | Port number serialized as big endian+                   , naPort     :: !Word16+                   } deriving (Eq, Show, Read)++instance NFData NetworkAddress where+    rnf (NetworkAddress s a p) = rnf s `seq` rnf a `seq` rnf p++instance Binary NetworkAddress where++    get = NetworkAddress <$> getWord64le+                         <*> (liftM2 (,) getWord64be getWord64be)+                         <*> getWord16be++    put (NetworkAddress s (al,ar) p) = do+        putWord64le s+        putWord64be al+        putWord64be ar+        putWord16be p++-- | A 'NotFound' message is returned as a response to a 'GetData' message+-- whe one of the requested objects could not be retrieved. This could happen,+-- for example, if a tranasaction was requested and was not available in the+-- memory pool of the receiving node.+data NotFound = +    NotFound {+             -- | Inventory vectors related to this request+               notFoundList :: ![InvVector] +             } deriving (Eq, Show, Read)++instance NFData NotFound where+    rnf (NotFound l) = rnf l++instance Binary NotFound where++    get = NotFound <$> (repList =<< get)+      where +        repList (VarInt c) = replicateM (fromIntegral c) get++    put (NotFound xs) = do+        put $ VarInt $ fromIntegral $ length xs+        forM_ xs put++-- | A Ping message is sent to bitcoin peers to check if a TCP\/IP connection+-- is still valid.+newtype Ping = +    Ping { +           -- | A random nonce used to identify the recipient of the ping+           -- request once a Pong response is received.  +           pingNonce :: Word64 +         } deriving (Eq, Show, Read)++instance NFData Ping where+    rnf (Ping n) = rnf n++-- | A Pong message is sent as a response to a ping message.+newtype Pong = +    Pong { +           -- | When responding to a Ping request, the nonce from the Ping+           -- is copied in the Pong response.+           pongNonce :: Word64 +         } deriving (Eq, Show, Read)++instance NFData Pong where+    rnf (Pong n) = rnf n++instance Binary Ping where+    get = Ping <$> getWord64le+    put (Ping n) = putWord64le n++instance Binary Pong where+    get = Pong <$> getWord64le+    put (Pong n) = putWord64le n++-- | The reject message is sent when messages are rejected by a peer.+data Reject =+    Reject { +            -- | Type of message rejected+             rejectMessage :: !MessageCommand+             -- | Code related to the rejected message+           , rejectCode    :: !RejectCode+             -- | Text version of rejected reason+           , rejectReason  :: !VarString+           } deriving (Eq, Show, Read)+++data RejectCode +    = RejectMalformed+    | RejectInvalid+    | RejectObsolete+    | RejectDuplicate+    | RejectNonStandard+    | RejectDust+    | RejectInsufficientFee+    | RejectCheckpoint+    deriving (Eq, Show, Read)++instance Binary RejectCode where++    get = getWord8 >>= \code -> case code of+        0x01 -> return RejectMalformed+        0x10 -> return RejectInvalid+        0x11 -> return RejectObsolete+        0x12 -> return RejectDuplicate+        0x40 -> return RejectNonStandard+        0x41 -> return RejectDust+        0x42 -> return RejectInsufficientFee+        0x43 -> return RejectCheckpoint+        _    -> fail $ unwords+            [ "Reject get: Invalid code"+            , show code+            ]++    put code = putWord8 $ case code of+        RejectMalformed       -> 0x01+        RejectInvalid         -> 0x10+        RejectObsolete        -> 0x11+        RejectDuplicate       -> 0x12+        RejectNonStandard     -> 0x40+        RejectDust            -> 0x41+        RejectInsufficientFee -> 0x42+        RejectCheckpoint      -> 0x43++-- | Convenience function to build a Reject message+reject :: MessageCommand -> RejectCode -> String -> Reject+reject cmd code reason = Reject cmd code (VarString $ stringToBS reason)++instance Binary Reject where++    get = get >>= \(VarString bs) -> case stringToCommand $ bsToString bs of+        Just cmd -> Reject cmd <$> get <*> get+        _        -> fail $ unwords $+            [ "Reason get: Invalid message command"+            , bsToString bs+            ]++    put (Reject cmd code reason) = do+        put $ VarString $ stringToBS $ commandToString cmd+        put code+        put reason++-- | Data type representing a bitcoin transaction+data Tx = +    Tx { +         -- | Transaction data format version+         txVersion  :: !Word32+         -- | List of transaction inputs+       , txIn       :: ![TxIn]+         -- | List of transaction outputs+       , txOut      :: ![TxOut]+         -- | The block number of timestamp at which this transaction is locked+       , txLockTime :: !Word32+       } deriving (Eq, Show, Read)++instance NFData Tx where+    rnf (Tx v i o l) = rnf v `seq` rnf i `seq` rnf o `seq` rnf l++instance Binary Tx where++    get = Tx <$> getWord32le+             <*> (replicateList =<< get)+             <*> (replicateList =<< get)+             <*> getWord32le+      where +        replicateList (VarInt c) = replicateM (fromIntegral c) get++    put (Tx v is os l) = do+        putWord32le v+        put $ VarInt $ fromIntegral $ length is+        forM_ is put+        put $ VarInt $ fromIntegral $ length os+        forM_ os put+        putWord32le l++instance FromJSON Tx where+    parseJSON = withText "transaction" $ \t -> either fail return $+        maybeToEither "tx not hex" (hexToBS $ T.unpack t) >>= decodeToEither++instance ToJSON Tx where+    toJSON = String . T.pack . bsToHex . encode'++-- | Data type representing the coinbase transaction of a 'Block'. Coinbase+-- transactions are special types of transactions which are created by miners+-- when they find a new block. Coinbase transactions have no inputs. They have+-- outputs sending the newly generated bitcoins together with all the block's+-- fees to a bitcoin address (usually the miners address). Data can be embedded+-- in a Coinbase transaction which can be chosen by the miner of a block. This+-- data also typically contains some randomness which is used, together with+-- the nonce, to find a partial hash collision on the block's hash.+data CoinbaseTx = +    CoinbaseTx { +                 -- | Transaction data format version.+                 cbVersion    :: !Word32+                 -- | Previous outpoint. This is ignored for+                 -- coinbase transactions but preserved for computing+                 -- the correct txid.+               , cbPrevOutput :: !OutPoint+                 -- | Data embedded inside the coinbase transaction.+               , cbData       :: !BS.ByteString+                 -- | Transaction sequence number. This is ignored for+                 -- coinbase transactions but preserved for computing+                 -- the correct txid.+               , cbInSequence :: !Word32+                 -- | List of transaction outputs.+               , cbOut        :: ![TxOut]+                 -- | The block number of timestamp at which this +                 -- transaction is locked.+               , cbLockTime   :: !Word32+               } deriving (Eq, Show, Read)++instance NFData CoinbaseTx where+    rnf (CoinbaseTx v p d i o l) =+        rnf v `seq` rnf p `seq` rnf d `seq` rnf i `seq` rnf o `seq` rnf l++instance Binary CoinbaseTx where++    get = do+        v <- getWord32le+        (VarInt len) <- get+        unless (len == 1) $ fail "CoinbaseTx get: Input size is not 1"+        op <- get+        (VarInt cbLen) <- get+        cb <- getByteString (fromIntegral cbLen)+        sq <- getWord32le+        (VarInt oLen) <- get+        os <- replicateM (fromIntegral oLen) get+        lt <- getWord32le+        return $ CoinbaseTx v op cb sq os lt++    put (CoinbaseTx v op cb sq os lt) = do+        putWord32le v+        put $ VarInt 1+        put op+        put $ VarInt $ fromIntegral $ BS.length cb+        putByteString cb +        putWord32le sq+        put $ VarInt $ fromIntegral $ length os+        forM_ os put+        putWord32le lt++-- | Data type representing a transaction input.+data TxIn = +    TxIn { +           -- | Reference the previous transaction output (hash + position)+           prevOutput   :: !OutPoint+           -- | Script providing the requirements of the previous transaction+           -- output to spend those coins.+         , scriptInput  :: !BS.ByteString+           -- | Transaction version as defined by the sender of the+           -- transaction. The intended use is for replacing transactions with+           -- new information before the transaction is included in a block.+         , txInSequence :: !Word32+         } deriving (Eq, Show, Read)++instance NFData TxIn where+    rnf (TxIn p i s) = rnf p `seq` rnf i `seq` rnf s++instance Binary TxIn where++    get = +        TxIn <$> get <*> (readBS =<< get) <*> getWord32le+      where+        readBS (VarInt len) = getByteString $ fromIntegral len++    put (TxIn o s q) = do+        put o +        put $ VarInt $ fromIntegral $ BS.length s+        putByteString s+        putWord32le q++-- | Data type representing a transaction output.+data TxOut = +    TxOut { +            -- | Transaction output value.+            outValue     :: !Word64+            -- | Script specifying the conditions to spend this output.+          , scriptOutput :: !BS.ByteString+          } deriving (Eq, Show, Read)++instance NFData TxOut where+    rnf (TxOut v o) = rnf v `seq` rnf o++instance Binary TxOut where++    get = do+        val <- getWord64le+        unless (val <= 2100000000000000) $ fail $+            "Invalid TxOut value: " ++ (show val)+        (VarInt len) <- get+        TxOut val <$> (getByteString $ fromIntegral len)++    put (TxOut o s) = do+        putWord64le o +        put $ VarInt $ fromIntegral $ BS.length s+        putByteString s++-- | The OutPoint is used inside a transaction input to reference the previous+-- transaction output that it is spending.+data OutPoint = +    OutPoint { +               -- | The hash of the referenced transaction.+               outPointHash  :: !TxHash+               -- | The position of the specific output in the transaction.+               -- The first output position is 0.+             , outPointIndex :: !Word32+             } deriving (Read, Show, Eq)++instance NFData OutPoint where+    rnf (OutPoint h i) = rnf h `seq` rnf i++instance FromJSON OutPoint where+    parseJSON = withText "outpoint" $ \t -> either fail return $+        maybeToEither "outpoint not hex" +          (hexToBS $ T.unpack t) >>= decodeToEither++instance ToJSON OutPoint where+    toJSON = String . T.pack . bsToHex . encode'++instance Binary OutPoint where+    get = do+        (h,i) <- liftM2 (,) get getWord32le+        return $ OutPoint h i+    put (OutPoint h i) = put h >> putWord32le i++-- | Data type representing a variable length integer. The 'VarInt' type+-- usually precedes an array or a string that can vary in length. +newtype VarInt = VarInt { getVarInt :: Word64 }+    deriving (Eq, Show, Read)++instance NFData VarInt where+    rnf (VarInt w) = rnf w++instance Binary VarInt where++    get = VarInt <$> ( getWord8 >>= go )+      where +        go 0xff = getWord64le+        go 0xfe = fromIntegral <$> getWord32le+        go 0xfd = fromIntegral <$> getWord16le+        go x    = fromIntegral <$> return x++    put (VarInt x)+        | x < 0xfd = +            putWord8 $ fromIntegral x+        | x <= 0xffff = do+            putWord8 0xfd+            putWord16le $ fromIntegral x+        | x <= 0xffffffff = do+            putWord8 0xfe+            putWord32le $ fromIntegral x+        | otherwise = do+            putWord8 0xff+            putWord64le x++-- | Data type for variable length strings. Variable length strings are+-- serialized as a 'VarInt' followed by a bytestring.+newtype VarString = VarString { getVarString :: BS.ByteString }+    deriving (Eq, Show, Read)++instance NFData VarString where+    rnf (VarString s) = rnf s++instance Binary VarString where++    get = VarString <$> (readBS =<< get)+      where +        readBS (VarInt len) = getByteString (fromIntegral len)++    put (VarString bs) = do+        put $ VarInt $ fromIntegral $ BS.length bs+        putByteString bs++-- | When a bitcoin node creates an outgoing connection to another node,+-- the first message it will send is a 'Version' message. The other node+-- will similarly respond with it's own 'Version' message.+data Version = +    Version {+              -- | Protocol version being used by the node.+              version     :: !Word32+              -- | Bitmask of features to enable for this connection.+            , services    :: !Word64+              -- | UNIX timestamp+            , timestamp   :: !Word64+              -- | Network address of the node receiving this message.+            , addrRecv    :: !NetworkAddress+              -- | Network address of the node sending this message.+            , addrSend    :: !NetworkAddress+              -- | Randomly generated identifying sent with every version+              -- message. This nonce is used to detect connection to self.+            , verNonce    :: !Word64+              -- | User agent+            , userAgent   :: !VarString+              -- | The height of the last block received by the sending node.+            , startHeight :: !Word32+              -- | Wether the remote peer should announce relaying transactions+              -- or not. This feature is enabled since version >= 70001. See+              -- BIP37 for more details.+            , relay       :: !Bool+            } deriving (Eq, Show, Read)++instance NFData Version where+    rnf (Version ver ser ts ar as vn ua sh re) =+        rnf ver `seq` rnf ser `seq` rnf ts `seq` rnf ar `seq`+        rnf as `seq` rnf vn `seq` rnf ua `seq` rnf sh `seq` rnf re++instance Binary Version where++    get = Version <$> getWord32le+                  <*> getWord64le+                  <*> getWord64le+                  <*> get+                  <*> get+                  <*> getWord64le+                  <*> get+                  <*> getWord32le+                  <*> (go =<< isEmpty)+      where +        go True  = return True+        go False = getBool++    put (Version v s t ar as n ua sh r) = do+        putWord32le v+        putWord64le s+        putWord64le t+        put         ar+        put         as+        putWord64le n+        put         ua+        putWord32le sh+        putBool     r++getBool :: Get Bool+getBool = go =<< getWord8+  where +    go 0 = return False+    go _ = return True++putBool :: Bool -> Put +putBool True  = putWord8 1+putBool False = putWord8 0++-- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify+-- the type of message present in the payload. This allows the message +-- de-serialization code to know how to decode a particular message payload.+-- Every valid 'Message' constructor has a corresponding 'MessageCommand'+-- constructor.+data MessageCommand +    = MCVersion +    | MCVerAck +    | MCAddr +    | MCInv +    | MCGetData +    | MCNotFound +    | MCGetBlocks +    | MCGetHeaders +    | MCTx +    | MCBlock +    | MCMerkleBlock+    | MCHeaders +    | MCGetAddr +    | MCFilterLoad+    | MCFilterAdd+    | MCFilterClear+    | MCPing +    | MCPong +    | MCAlert+    | MCReject+    deriving (Eq, Show, Read)++instance NFData MessageCommand++instance Binary MessageCommand where+    +    get = go =<< getByteString 12+      where +        go bs = case stringToCommand $ unpackCommand bs of+            Just cmd -> return cmd+            Nothing  -> fail "get MessageCommand : Invalid command"++    put mc = putByteString $ packCommand $ commandToString mc+++stringToCommand :: String -> Maybe MessageCommand+stringToCommand str = case str of+    "version"     -> Just MCVersion+    "verack"      -> Just MCVerAck+    "addr"        -> Just MCAddr+    "inv"         -> Just MCInv+    "getdata"     -> Just MCGetData+    "notfound"    -> Just MCNotFound+    "getblocks"   -> Just MCGetBlocks+    "getheaders"  -> Just MCGetHeaders+    "tx"          -> Just MCTx+    "block"       -> Just MCBlock+    "merkleblock" -> Just MCMerkleBlock+    "headers"     -> Just MCHeaders+    "getaddr"     -> Just MCGetAddr+    "filterload"  -> Just MCFilterLoad+    "filteradd"   -> Just MCFilterAdd+    "filterclear" -> Just MCFilterClear+    "ping"        -> Just MCPing+    "pong"        -> Just MCPong+    "alert"       -> Just MCAlert+    "reject"      -> Just MCReject+    _             -> Nothing++commandToString :: MessageCommand -> String+commandToString mc = case mc of+    MCVersion     -> "version"+    MCVerAck      -> "verack"+    MCAddr        -> "addr"+    MCInv         -> "inv"+    MCGetData     -> "getdata"+    MCNotFound    -> "notfound"+    MCGetBlocks   -> "getblocks"+    MCGetHeaders  -> "getheaders"+    MCTx          -> "tx"+    MCBlock       -> "block"+    MCMerkleBlock -> "merkleblock"+    MCHeaders     -> "headers"+    MCGetAddr     -> "getaddr"+    MCFilterLoad  -> "filterload"+    MCFilterAdd   -> "filteradd"+    MCFilterClear -> "filterclear"+    MCPing        -> "ping"+    MCPong        -> "pong"+    MCAlert       -> "alert"+    MCReject      -> "reject"++packCommand :: String -> BS.ByteString+packCommand s = stringToBS $ take 12 $ s ++ repeat '\NUL'++unpackCommand :: BS.ByteString -> String+unpackCommand bs = bsToString $ BS.takeWhile (/= 0) bs+

@@ -1,46 +0,0 @@-module Network.Haskoin.Protocol.VarInt ( VarInt(..) ) where- -import Data.Word (Word64)-import Control.Applicative ((<$>))--import Data.Binary (Binary, get, put)-import Data.Binary.Get -    ( getWord8-    , getWord16le-    , getWord32le-    , getWord64le-    )-import Data.Binary.Put -    ( putWord8-    , putWord16le-    , putWord32le-    , putWord64le-    )---- | Data type representing a variable length integer. The 'VarInt' type--- usually precedes an array or a string that can vary in length. -newtype VarInt = VarInt { getVarInt :: Word64 }-    deriving (Eq, Show, Read)-    -instance Binary VarInt where--    get = VarInt <$> ( getWord8 >>= go )-      where -        go 0xff = getWord64le-        go 0xfe = fromIntegral <$> getWord32le-        go 0xfd = fromIntegral <$> getWord16le-        go x    = fromIntegral <$> return x--    put (VarInt x)-        | x < 0xfd = -            putWord8 $ fromIntegral x-        | x <= 0xffff = do-            putWord8 0xfd-            putWord16le $ fromIntegral x-        | x <= 0xffffffff = do-            putWord8 0xfe-            putWord32le $ fromIntegral x-        | otherwise = do-            putWord8 0xff-            putWord64le x-

@@ -1,29 +0,0 @@-module Network.Haskoin.Protocol.VarString ( VarString(..) ) where--import Control.Applicative ((<$>))--import qualified Data.ByteString as BS -    ( ByteString-    , length-    )-import Data.Binary (Binary, get, put)-import Data.Binary.Get (getByteString)-import Data.Binary.Put (putByteString)--import Network.Haskoin.Protocol.VarInt---- | Data type for variable length strings. Variable length strings are--- serialized as a 'VarInt' followed by a bytestring.-newtype VarString = VarString { getVarString :: BS.ByteString }-    deriving (Eq, Show, Read)--instance Binary VarString where--    get = VarString <$> (readBS =<< get)-      where -        readBS (VarInt len) = getByteString (fromIntegral len)--    put (VarString bs) = do-        put $ VarInt $ fromIntegral $ BS.length bs-        putByteString bs-

@@ -1,85 +0,0 @@-module Network.Haskoin.Protocol.Version ( Version(..) ) where--import Control.Applicative ((<$>),(<*>))--import Data.Word (Word32, Word64)-import Data.Binary (Binary, get, put, Get, Put)-import Data.Binary.Get -    ( getWord8-    , getWord32le-    , getWord64le-    , isEmpty-    )-import Data.Binary.Put -    ( putWord8-    , putWord32le-    , putWord64le-    )--import Network.Haskoin.Protocol.VarString-import Network.Haskoin.Protocol.NetworkAddress---- | When a bitcoin node creates an outgoing connection to another node,--- the first message it will send is a 'Version' message. The other node--- will similarly respond with it's own 'Version' message.-data Version = -    Version {-              -- | Protocol version being used by the node.-              version     :: !Word32-              -- | Bitmask of features to enable for this connection.-            , services    :: !Word64-              -- | UNIX timestamp-            , timestamp   :: !Word64-              -- | Network address of the node receiving this message.-            , addrRecv    :: !NetworkAddress-              -- | Network address of the node sending this message.-            , addrSend    :: !NetworkAddress-              -- | Randomly generated identifying sent with every version-              -- message. This nonce is used to detect connection to self.-            , verNonce    :: !Word64-              -- | User agent-            , userAgent   :: !VarString-              -- | The height of the last block received by the sending node.-            , startHeight :: !Word32-              -- | Wether the remote peer should announce relaying transactions-              -- or not. This feature is enabled since version >= 70001. See-              -- BIP37 for more details.-            , relay       :: !Bool-            } deriving (Eq, Show, Read)--instance Binary Version where--    get = Version <$> getWord32le-                  <*> getWord64le-                  <*> getWord64le-                  <*> get-                  <*> get-                  <*> getWord64le-                  <*> get-                  <*> getWord32le-                  <*> (go =<< isEmpty)-      where -        go True  = return True-        go False = getBool--    put (Version v s t ar as n ua sh r) = do-        putWord32le v-        putWord64le s-        putWord64le t-        put         ar-        put         as-        putWord64le n-        put         ua-        putWord32le sh-        putBool     r--getBool :: Get Bool-getBool = go =<< getWord8-  where -    go 0 = return False-    go _ = return True--putBool :: Bool -> Put -putBool True  = putWord8 1-putBool False = putWord8 0-

@@ -5,29 +5,41 @@ -} module Network.Haskoin.Script (+  -- *Scripts+  -- | More informations on scripts is available here:+  -- <http://en.bitcoin.it/wiki/Script>+  Script(..)+, ScriptOp(..)+, PushDataType(..)+, opPushData+   -- *Script Parsing   -- **Script Outputs-  ScriptOutput(..)+, ScriptOutput(..) , encodeOutput+, encodeOutputBS , decodeOutput+, decodeOutputBS , isPayPK , isPayPKHash , isPayMulSig , isPayScriptHash , scriptAddr , sortMulSig+   -- **Script Inputs , ScriptInput(..)+, SimpleInput(..)+, RedeemScript , encodeInput+, encodeInputBS , decodeInput+, decodeInputBS , isSpendPK , isSpendPKHash , isSpendMulSig-  -- **ScriptHash Inputs-, ScriptHashInput(..)-, RedeemScript-, encodeScriptHash-, decodeScriptHash+, isScriptHashInput+   -- * Helpers , scriptRecipient , scriptSender@@ -49,8 +61,13 @@ , decodeSig , decodeCanonicalSig +-- *Evaluation+, evalScript+, verifySpend+, SigCheck ) where +import Network.Haskoin.Script.Types import Network.Haskoin.Script.Parser import Network.Haskoin.Script.SigHash-+import Network.Haskoin.Script.Evaluator

@@ -0,0 +1,681 @@+{-# LANGUAGE LambdaCase #-}+{-|++Module providing Bitcoin script evaluation.  See+<https://github.com/bitcoin/bitcoin/blob/master/src/script.cpp>+EvalScript and <https://en.bitcoin.it/wiki/Script>++-}+module Network.Haskoin.Script.Evaluator+( +-- * Script evaluation+  verifySpend+, evalScript+, SigCheck+-- * Evaluation data types+, Program+, Stack+-- * Helper functions+, encodeInt+, decodeInt+, encodeBool+, decodeBool+, runStack+, checkStack+, dumpScript+, dumpStack+, execScript+) where++import Control.Monad.State+import Control.Monad.Error+import Control.Monad.Identity++import Control.Applicative ((<$>), (<*>))++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++import Data.List (intercalate)+import Data.Bits (shiftR, shiftL, testBit, setBit, clearBit)+import Data.Int (Int64)+import Data.Word (Word8, Word64)+import Data.Either ( rights )+import Data.Maybe ( mapMaybe, isJust )++import Network.Haskoin.Crypto+import Network.Haskoin.Script.Types+import Network.Haskoin.Script.SigHash( TxSignature(..), decodeSig, txSigHash )+import Network.Haskoin.Util ( bsToHex, decode', decodeToMaybe )+import Network.Haskoin.Protocol( Tx(..), TxIn(..) )++import Data.Binary (encode, decode)+++maxScriptSize :: Int+maxScriptSize = 10000++maxScriptElementSize :: Int+maxScriptElementSize = 520++maxStackSize :: Int+maxStackSize = 1000++maxOpcodes :: Int+maxOpcodes = 200++maxKeysMultisig :: Int+maxKeysMultisig = 20++data EvalError =+    EvalError String+    | ProgramError String Program+    | StackError ScriptOp+    | DisabledOp ScriptOp++instance Error EvalError where+    noMsg = EvalError "Evaluation Error"+    strMsg s = EvalError $ noMsg ++ " " ++ s++instance Show EvalError where+    show (EvalError m) = m+    show (ProgramError m prog) = m ++ " - program: " ++ show prog+    show (StackError op) = show op ++ ": Stack Error"+    show (DisabledOp op) = show op ++ ": disabled"++type StackValue = [Word8]+type AltStack = [StackValue]+type Stack = [StackValue]+type HashOps = [ScriptOp] -- the code that is verified by OP_CHECKSIG++-- | Defines the type of function required by script evaluating+-- functions to check transaction signatures.+type SigCheck = [ScriptOp] -> TxSignature -> PubKey -> Bool++-- | Data type of the evaluation state.+data Program = Program {+    stack        :: Stack,+    altStack     :: AltStack,+    hashOps      :: HashOps,+    sigCheck     :: SigCheck,+    opCount      :: Int+}++dumpOp :: ScriptOp -> String+dumpOp (OP_PUSHDATA payload optype) =+  "OP_PUSHDATA(" ++ show optype ++ ")" +++  " 0x" ++ bsToHex payload+dumpOp op = show op++dumpList :: [String] -> String+dumpList xs = "[" ++ intercalate "," xs ++ "]"++dumpScript :: [ScriptOp] -> String+dumpScript script = dumpList $ map dumpOp script++dumpStack :: Stack -> String+dumpStack s = dumpList $ map (bsToHex . BS.pack) s++instance Show Program where+    show p = " stack: " ++ dumpStack (stack p)++type ProgramState = ErrorT EvalError Identity+type IfStack = [ Bool ]++-- | Monad of actions independent of conditional statements.+type ProgramTransition = StateT Program ProgramState+-- | Monad of actions which taking if statements into account.+-- Separate state type from ProgramTransition for type safety+type ConditionalProgramTransition a = StateT IfStack ProgramTransition a++evalProgramTransition :: ProgramTransition a -> Program -> Either EvalError a+evalProgramTransition m s = runIdentity . runErrorT $ evalStateT m s++evalConditionalProgram :: ConditionalProgramTransition a -- ^ Program monad+                       -> [ Bool ]                       -- ^ Initial if state stack+                       -> Program                        -- ^ Initial computation data+                       -> Either EvalError a+evalConditionalProgram m s = evalProgramTransition ( evalStateT m s )++--------------------------------------------------------------------------------+-- Error utils++programError :: String -> ProgramTransition a+programError s = get >>= throwError . ProgramError s++disabled :: ScriptOp -> ProgramTransition ()+disabled op = throwError . DisabledOp $ op++--------------------------------------------------------------------------------+-- Type Conversions++-- | Encoding function for the stack value format of integers.  Most+-- significant bit defines sign.+encodeInt :: Int64 -> StackValue+encodeInt i = prefix $ encode' (fromIntegral $ abs i) []+    where encode' :: Word64 -> StackValue -> StackValue+          encode' 0 bytes = bytes+          encode' j bytes = fromIntegral j:encode' (j `shiftR` 8) bytes+          prefix :: StackValue -> StackValue+          prefix [] = []+          prefix xs | testBit (last xs) 7 = prefix $ xs ++ [0]+                    | i < 0 = init xs ++ [setBit (last xs) 7]+                    | otherwise = xs++-- | Inverse of `encodeInt`.+decodeInt :: StackValue -> Maybe Int64+decodeInt bytes | length bytes > 4 = Nothing+                | otherwise = Just $ sign' (decodeW bytes)+                  where decodeW [] = 0+                        decodeW [x] = fromIntegral $ clearBit x 7+                        decodeW (x:xs) = fromIntegral x + decodeW xs `shiftL` 8+                        sign' i | null bytes = 0+                                | testBit (last bytes) 7 = -i+                                | otherwise = i++-- | Conversion of StackValue to Bool (true if non-zero).+decodeBool :: StackValue -> Bool+decodeBool []     = False+decodeBool [0x00] = False+decodeBool [0x80] = False+decodeBool (0x00:vs) = decodeBool vs+decodeBool _ = True++encodeBool :: Bool -> StackValue+encodeBool True = [1]+encodeBool False = []++constValue :: ScriptOp -> Maybe StackValue+constValue op = case op of+    OP_0  -> Just $ encodeInt 0+    OP_1  -> Just $ encodeInt 1+    OP_2  -> Just $ encodeInt 2+    OP_3  -> Just $ encodeInt 3+    OP_4  -> Just $ encodeInt 4+    OP_5  -> Just $ encodeInt 5+    OP_6  -> Just $ encodeInt 6+    OP_7  -> Just $ encodeInt 7+    OP_8  -> Just $ encodeInt 8+    OP_9  -> Just $ encodeInt 9+    OP_10 -> Just $ encodeInt 10+    OP_11 -> Just $ encodeInt 11+    OP_12 -> Just $ encodeInt 12+    OP_13 -> Just $ encodeInt 13+    OP_14 -> Just $ encodeInt 14+    OP_15 -> Just $ encodeInt 15+    OP_16 -> Just $ encodeInt 16+    OP_1NEGATE -> Just $ encodeInt $ -1+    (OP_PUSHDATA string _) -> Just $ BS.unpack string+    _ -> Nothing+++-- | Check if OpCode is constant+isConstant :: ScriptOp -> Bool+isConstant = isJust . constValue++-- | Check if OpCode is disabled+isDisabled :: ScriptOp -> Bool+isDisabled op = op `elem` [ OP_CAT+                          , OP_SUBSTR+                          , OP_LEFT+                          , OP_RIGHT+                          , OP_INVERT+                          , OP_AND+                          , OP_OR+                          , OP_XOR+                          , OP_2MUL+                          , OP_2DIV+                          , OP_MUL+                          , OP_DIV+                          , OP_MOD+                          , OP_LSHIFT+                          , OP_RSHIFT+                          , OP_VER+                          , OP_VERIF+                          , OP_VERNOTIF ]++-- | Check if OpCode counts towards opcount limit++countOp :: ScriptOp -> Bool+countOp op | isConstant op     = False+           | op == OP_RESERVED = False+           | otherwise         = True++popInt :: ProgramTransition Int64+popInt = decodeInt <$> popStack >>= \case+    Nothing -> programError "popInt: data > nMaxNumSize"+    Just i -> return i++pushInt :: Int64 -> ProgramTransition ()+pushInt = pushStack . encodeInt++popBool :: ProgramTransition Bool+popBool = decodeBool <$> popStack++pushBool :: Bool -> ProgramTransition ()+pushBool = pushStack . encodeBool++opToSv :: StackValue -> BS.ByteString+opToSv = BS.pack++bsToSv :: BS.ByteString -> StackValue+bsToSv = BS.unpack++--------------------------------------------------------------------------------+-- Stack Primitives++getStack :: ProgramTransition Stack+getStack = stack <$> get++getCond :: ConditionalProgramTransition [Bool]+getCond = get++popCond :: ConditionalProgramTransition Bool+popCond = get >>= \condStack -> case condStack of+    [] -> lift $ programError "popCond: empty condStack"+    (c:cs) -> put cs >> return c++pushCond :: Bool -> ConditionalProgramTransition ()+pushCond c = get >>= \s ->+    put (c:s)++flipCond :: ConditionalProgramTransition ()+flipCond = popCond >>= pushCond . not++withStack :: ProgramTransition Stack+withStack = getStack >>= \case+    [] -> stackError+    s  -> return s++putStack :: Stack -> ProgramTransition ()+putStack st = modify $ \p -> p { stack = st }++prependStack :: Stack -> ProgramTransition ()+prependStack s = getStack >>= \s' -> putStack $ s ++ s'++checkPushData :: ScriptOp -> ProgramTransition ()+checkPushData (OP_PUSHDATA v _) | BS.length v > fromIntegral maxScriptElementSize+                                  = programError "OP_PUSHDATA > maxScriptElementSize"+                                | otherwise = return ()+checkPushData _ = return ()++checkStackSize :: ProgramTransition ()+checkStackSize = do n <- length <$> stack <$> get+                    m <- length <$> altStack <$> get+                    when ((n + m) > fromIntegral maxStackSize) $+                         programError "stack > maxStackSize"++pushStack :: StackValue -> ProgramTransition ()+pushStack v = getStack >>= \s -> putStack (v:s)++popStack :: ProgramTransition StackValue+popStack = withStack >>= \(s:ss) -> putStack ss >> return s++popStackN :: Integer -> ProgramTransition [StackValue]+popStackN n | n < 0     = programError "popStackN: negative argument"+            | n == 0    = return []+            | otherwise = (:) <$> popStack <*> popStackN (n - 1)++pickStack :: Bool -> Int -> ProgramTransition ()+pickStack remove n = do+    st <- getStack++    when (n < 0) $+        programError "pickStack: n < 0"+    when (n > length st - 1) $+        programError "pickStack: n > size"++    let v = st !! n+    when remove $ putStack $ take n st ++ drop (n+1) st+    pushStack v++getHashOps :: ProgramTransition HashOps+getHashOps = hashOps <$> get++-- | Function to track the verified OPs signed by OP_CHECK(MULTI) sig.+-- Dependent on the sequence of `OP_CODESEPARATOR`+dropHashOpsSeparatedCode :: ProgramTransition ()+dropHashOpsSeparatedCode = modify $ \p ->+   let tryDrop = dropWhile ( /= OP_CODESEPARATOR ) $ hashOps p in+   case tryDrop of+     -- If no OP_CODESEPARATOR, take the whole script.  This case is+     -- possible when there is no OP_CODESEPARATOR in scriptPubKey but+     -- one exists in scriptSig+     [] -> p+     _  -> p { hashOps = tail tryDrop }++-- | Filters out `OP_CODESEPARATOR` from the output script used by+-- OP_CHECK(MULTI)SIG+preparedHashOps :: ProgramTransition HashOps+preparedHashOps = filter ( /= OP_CODESEPARATOR ) <$> getHashOps++-- | Removes any PUSHDATA that contains the signatures.  Used in+-- CHECK(MULTI)SIG so that signatures can be contained in output+-- scripts.  See FindAndDelete() in Bitcoin Core.+findAndDelete :: [ StackValue ] -> [ ScriptOp ] -> [ ScriptOp ]+findAndDelete [] ops = ops+findAndDelete (s:ss) ops = let pushOp = opPushData . opToSv $ s in+  findAndDelete ss $ filter ( /= pushOp ) ops++checkMultiSig :: SigCheck -- ^ Signature checking function+              -> [ StackValue ] -- ^ PubKeys+              -> [ StackValue ] -- ^ Signatures+              -> [ ScriptOp ]   -- ^ CODESEPARATOR'd hashops+              -> Bool+checkMultiSig f encPubKeys encSigs hOps =+  let pubKeys = mapMaybe ( decodeToMaybe . opToSv ) encPubKeys+      sigs = rights $ map ( decodeSig . opToSv ) encSigs+      cleanHashOps = findAndDelete encSigs hOps+  in (length sigs == length encSigs) && -- check for bad signatures+     orderedSatisfy (f cleanHashOps) sigs pubKeys++-- | Tests whether a function is satisfied for every a with some b "in+-- order".  By "in order" we mean, if a pair satisfies the function,+-- any other satisfying pair must be deeper in each list.  Designed to+-- return as soon as the result is known to minimize expensive+-- function calls.  Used in checkMultiSig to verify signature/pubKey+-- pairs with a values as signatures and b values as pubkeys+orderedSatisfy :: ( a -> b -> Bool )+                    -> [ a ]+                    -> [ b ]+                    -> Bool+orderedSatisfy _ [] _ = True+orderedSatisfy _ (_:_) [] = False+orderedSatisfy f x@(a:as) y@(b:bs) | length x > length y = False+                                   | f a b     = orderedSatisfy f as bs+                                   | otherwise = orderedSatisfy f x bs++tStack1 :: (StackValue -> Stack) -> ProgramTransition ()+tStack1 f = f <$> popStack >>= prependStack++tStack2 :: (StackValue -> StackValue -> Stack) -> ProgramTransition ()+tStack2 f = f <$> popStack <*> popStack >>= prependStack++tStack3 :: (StackValue -> StackValue -> StackValue -> Stack) -> ProgramTransition ()+tStack3 f = f <$> popStack <*> popStack <*> popStack >>= prependStack++tStack4 :: (StackValue -> StackValue -> StackValue -> StackValue -> Stack)+            -> ProgramTransition ()+tStack4 f = f <$> popStack <*> popStack <*> popStack <*> popStack+              >>= prependStack++tStack6 :: (StackValue -> StackValue -> StackValue ->+            StackValue -> StackValue -> StackValue -> Stack) -> ProgramTransition ()+tStack6 f = f <$> popStack <*> popStack <*> popStack+              <*> popStack <*> popStack <*> popStack >>= prependStack++arith1 :: (Int64 -> Int64) -> ProgramTransition ()+arith1 f = do+    i <- popInt+    pushStack $ encodeInt (f i)++arith2 :: (Int64 -> Int64 -> Int64) -> ProgramTransition ()+arith2 f = do+    i <- popInt+    j <- popInt+    pushStack $ encodeInt (f i j)++stackError :: ProgramTransition a+stackError = programError "stack error"++-- AltStack Primitives++pushAltStack :: StackValue -> ProgramTransition ()+pushAltStack op = modify $ \p -> p { altStack = op:altStack p }++popAltStack :: ProgramTransition StackValue+popAltStack = get >>= \p -> case altStack p of+    a:as -> put p { altStack = as } >> return a+    []   -> programError "popAltStack: empty stack"+++incrementOpCount :: Int -> ProgramTransition ()+incrementOpCount i | i > maxOpcodes = programError "reached opcode limit"+                   | otherwise      = modify $ \p -> p { opCount = i + 1 }++-- Instruction Evaluation+eval :: ScriptOp -> ProgramTransition ()+eval OP_NOP     = return ()+eval OP_NOP1    = return ()+eval OP_NOP2    = return ()+eval OP_NOP3    = return ()+eval OP_NOP4    = return ()+eval OP_NOP5    = return ()+eval OP_NOP6    = return ()+eval OP_NOP7    = return ()+eval OP_NOP8    = return ()+eval OP_NOP9    = return ()+eval OP_NOP10   = return ()++eval OP_VERIFY = popBool >>= \case+    True  -> return ()+    False -> programError "OP_VERIFY failed"++eval OP_RETURN = programError "explicit OP_RETURN"++-- Stack++eval OP_TOALTSTACK = popStack >>= pushAltStack+eval OP_FROMALTSTACK = popAltStack >>= pushStack+eval OP_IFDUP   = tStack1 $ \a -> if decodeBool a then [a, a] else [a]+eval OP_DEPTH   = getStack >>= pushStack . encodeInt . fromIntegral . length+eval OP_DROP    = void popStack+eval OP_DUP     = tStack1 $ \a -> [a, a]+eval OP_NIP     = tStack2 $ \a _ -> [a]+eval OP_OVER    = tStack2 $ \a b -> [b, a, b]+eval OP_PICK    = popInt >>= (pickStack False . fromIntegral)+eval OP_ROLL    = popInt >>= (pickStack True . fromIntegral)+eval OP_ROT     = tStack3 $ \a b c -> [c, a, b]+eval OP_SWAP    = tStack2 $ \a b -> [b, a]+eval OP_TUCK    = tStack2 $ \a b -> [a, b, a]+eval OP_2DROP   = tStack2 $ \_ _ -> []+eval OP_2DUP    = tStack2 $ \a b -> [a, b, a, b]+eval OP_3DUP    = tStack3 $ \a b c -> [a, b, c, a, b, c]+eval OP_2OVER   = tStack4 $ \a b c d -> [c, d, a, b, c, d]+eval OP_2ROT    = tStack6 $ \a b c d e f -> [e, f, a, b, c, d]+eval OP_2SWAP   = tStack4 $ \a b c d -> [c, d, a, b]++-- Splice++eval OP_SIZE   = (fromIntegral . length <$> head <$> withStack) >>= pushInt++-- Bitwise Logic++eval OP_EQUAL   = tStack2 $ \a b -> [encodeBool (a == b)]+eval OP_EQUALVERIFY = eval OP_EQUAL >> eval OP_VERIFY++-- Arithmetic++eval OP_1ADD    = arith1 (+1)+eval OP_1SUB    = arith1 (subtract 1)+eval OP_NEGATE  = arith1 negate+eval OP_ABS     = arith1 abs+eval OP_NOT         = arith1 $ \case 0 -> 1; _ -> 0+eval OP_0NOTEQUAL   = arith1 $ \case 0 -> 0; _ -> 1+eval OP_ADD     = arith2 (+)+eval OP_SUB     = arith2 $ flip (-)+eval OP_BOOLAND     = (&&) <$> ((0 /=) <$> popInt)+                           <*> ((0 /=) <$> popInt) >>= pushBool+eval OP_BOOLOR      = (||) <$> ((0 /=) <$> popInt)+                           <*> ((0 /=) <$> popInt) >>= pushBool+eval OP_NUMEQUAL    = (==) <$> popInt <*> popInt >>= pushBool+eval OP_NUMEQUALVERIFY = eval OP_NUMEQUAL >> eval OP_VERIFY+eval OP_NUMNOTEQUAL         = (/=) <$> popInt <*> popInt >>= pushBool+eval OP_LESSTHAN            = (>)  <$> popInt <*> popInt >>= pushBool+eval OP_GREATERTHAN         = (<)  <$> popInt <*> popInt >>= pushBool+eval OP_LESSTHANOREQUAL     = (>=) <$> popInt <*> popInt >>= pushBool+eval OP_GREATERTHANOREQUAL  = (<=) <$> popInt <*> popInt >>= pushBool+eval OP_MIN     = min <$> popInt <*> popInt >>= pushInt+eval OP_MAX     = max <$> popInt <*> popInt >>= pushInt+eval OP_WITHIN  = within <$> popInt <*> popInt <*> popInt >>= pushBool+                  where within y x a = (x <= a) && (a < y)++eval OP_RIPEMD160 = tStack1 $ return . bsToSv . hash160BS . opToSv+eval OP_SHA1 = tStack1 $ return . bsToSv . hashSha1BS . opToSv++eval OP_SHA256 = tStack1 $ return . bsToSv . hash256BS . opToSv+eval OP_HASH160 = tStack1 $ return . bsToSv . hash160BS . hash256BS . opToSv+eval OP_HASH256 = tStack1 $ return . bsToSv . doubleHash256BS  . opToSv+eval OP_CODESEPARATOR = dropHashOpsSeparatedCode+eval OP_CHECKSIG = do+  pubKey <- popStack+  sig <- popStack+  checker <- sigCheck <$> get+  hOps <- preparedHashOps+  pushBool $ checkMultiSig checker [ pubKey ] [ sig ] hOps -- Reuse checkMultiSig code++eval OP_CHECKMULTISIG =+    do nPubKeys <- fromIntegral <$> popInt+       when (nPubKeys < 0 || nPubKeys > maxKeysMultisig)+            $ programError $ "nPubKeys outside range: " ++ show nPubKeys+       pubKeys <- popStackN $ toInteger nPubKeys++       nSigs <- fromIntegral <$> popInt+       when (nSigs < 0 || nSigs > nPubKeys)+            $ programError $ "nSigs outside range: " ++ show nSigs+       sigs <- popStackN $ toInteger nSigs++       void popStack -- spec bug+       checker <- sigCheck <$> get+       hOps <- preparedHashOps+       pushBool $ checkMultiSig checker pubKeys sigs hOps+       modify $ \p -> p { opCount = opCount p + length pubKeys }++eval OP_CHECKSIGVERIFY      = eval OP_CHECKSIG      >> eval OP_VERIFY+eval OP_CHECKMULTISIGVERIFY = eval OP_CHECKMULTISIG >> eval OP_VERIFY++eval op = case constValue op of+    Just sv -> pushStack sv+    Nothing -> programError $ "unexpected op " ++ show op++--------------------------------------------------------------------------------+-- | Based on the IfStack, returns whether the script is within an+-- evaluating if-branch.+getExec :: ConditionalProgramTransition Bool+getExec = and <$> getCond++-- | Converts a `ScriptOp` to a program monad.+conditionalEval :: ScriptOp -> ConditionalProgramTransition ()+conditionalEval scrpOp = do+   -- lift $ checkOpEnabled scrpOp+   lift $ checkPushData scrpOp++   e  <- getExec+   eval' e scrpOp++   when (countOp scrpOp) $ lift $ join $ incrementOpCount <$> opCount <$> get++   lift checkStackSize++   where+     eval' :: Bool -> ScriptOp -> ConditionalProgramTransition ()++     eval' True  OP_IF      = lift popStack >>= pushCond . decodeBool+     eval' True  OP_NOTIF   = lift popStack >>= pushCond . not . decodeBool+     eval' True  OP_ELSE    = flipCond+     eval' True  OP_ENDIF   = void popCond+     eval' True  op = lift $ eval op++     eval' False OP_IF    = pushCond False+     eval' False OP_NOTIF = pushCond False+     eval' False OP_ELSE  = flipCond+     eval' False OP_ENDIF = void popCond+     eval' False OP_CODESEPARATOR = lift $ eval OP_CODESEPARATOR+     eval' False OP_VER = return ()+     eval' False op | isDisabled op = lift $ disabled op+                    | otherwise = return ()++-- | Builds a Script evaluation monad.+evalAll :: [ ScriptOp ] -> ConditionalProgramTransition ()+evalAll ops = do mapM_ conditionalEval ops+                 cond <- getCond+                 unless (null cond) (lift $ programError "ifStack not empty")+++checkPushOnly :: [ ScriptOp ] -> ConditionalProgramTransition ()+checkPushOnly ops+      | not (all checkPushOp ops) = lift $ programError "only push ops allowed"+      | otherwise = return ()+      where checkPushOp op = case constValue op of+                                  Just _ -> True+                                  Nothing -> False++checkStack :: Stack -> Bool+checkStack (x:_) = decodeBool x+checkStack []  = False+++isPayToScriptHash :: [ ScriptOp ] -> Bool+isPayToScriptHash [OP_HASH160, OP_PUSHDATA bytes OPCODE, OP_EQUAL]+                    = BS.length bytes == 20+isPayToScriptHash _ = False++stackToScriptOps :: StackValue -> [ ScriptOp ]+stackToScriptOps sv = scriptOps $ decode $ BSL.pack sv++--+-- exported functions++execScript :: Script -- ^ scriptSig ( redeemScript )+           -> Script -- ^ scriptPubKey+           -> SigCheck -- ^ signature verification Function+           -> Either EvalError Program+execScript scriptSig scriptPubKey sigCheckFcn =+  let sigOps = scriptOps scriptSig+      pubKeyOps = scriptOps scriptPubKey+      emptyProgram = Program {+        stack = [],+        altStack = [],+        hashOps = pubKeyOps,+        sigCheck = sigCheckFcn,+        opCount = 0+      }+++      checkSig | isPayToScriptHash pubKeyOps = checkPushOnly sigOps+               | otherwise = return ()++      checkKey | BSL.length (encode scriptPubKey) > fromIntegral maxScriptSize+                 = lift $ programError "pubKey > maxScriptSize"+               | otherwise = return ()+++      redeemEval = checkSig >> evalAll sigOps >> lift (stack <$> get)+      pubKeyEval = checkKey >> evalAll pubKeyOps >> lift get+      p2shEval [] = lift $ programError "PayToScriptHash: no script on stack"+      p2shEval (sv:_) = evalAll (stackToScriptOps sv) >> lift get++      in do s <- evalConditionalProgram redeemEval [] emptyProgram+            p <- evalConditionalProgram pubKeyEval [] emptyProgram { stack = s }+            if ( checkStack . runStack $ p ) &&  ( isPayToScriptHash pubKeyOps ) && ( not . null $ s )+                then evalConditionalProgram (p2shEval s) [] emptyProgram { stack = drop 1 s,+                                                                           hashOps = stackToScriptOps $ head s }+                else return p++evalScript :: Script -> Script -> SigCheck -> Bool+evalScript scriptSig scriptPubKey sigCheckFcn =+              case execScript scriptSig scriptPubKey sigCheckFcn of+                  Left _ -> False+                  Right p -> checkStack . runStack $ p++runStack :: Program -> Stack+runStack = stack++-- | A wrapper around 'verifySig' which handles grabbing the hash type+verifySigWithType :: Tx -> Int -> [ ScriptOp ] -> TxSignature -> PubKey -> Bool+verifySigWithType tx i outOps txSig pubKey =+  let outScript = Script outOps+      h = txSigHash tx outScript i ( sigHashType txSig ) in+  verifySig h ( txSignature txSig ) pubKey++-- | Uses `evalScript` to check that the input script of a spending+-- transaction satisfies the output script.+verifySpend :: Tx     -- ^ The spending transaction+            -> Int    -- ^ The input index+            -> Script -- ^ The output script we are spending+            -> Bool+verifySpend tx i outscript =+  let scriptSig = decode' . scriptInput $ txIn tx !! i+      verifyFcn = verifySigWithType tx i+  in+  evalScript scriptSig outscript verifyFcn

@@ -1,17 +1,19 @@ module Network.Haskoin.Script.Parser ( ScriptOutput(..) , ScriptInput(..)+, SimpleInput(..) , RedeemScript-, ScriptHashInput(..) , scriptAddr , scriptRecipient , scriptSender , encodeInput+, encodeInputBS , decodeInput+, decodeInputBS , encodeOutput+, encodeOutputBS , decodeOutput-, encodeScriptHash-, decodeScriptHash+, decodeOutputBS , sortMulSig , intToScriptOp , scriptOpToInt@@ -22,19 +24,34 @@ , isSpendPK , isSpendPKHash , isSpendMulSig+, isScriptHashInput ) where -import Control.Monad (liftM2)-import Control.Applicative ((<$>),(<*>))+import Control.DeepSeq (NFData, rnf)+import Control.Monad (liftM2, guard)+import Control.Applicative ((<$>), (<|>))  import Data.List (sortBy)-import qualified Data.ByteString as BS (head, singleton)-+import Data.Foldable (foldrM)+import qualified Data.Text as T+import qualified Data.ByteString as BS +    ( ByteString+    , head+    , singleton+    )+import Data.Aeson+    ( Value (String)+    , FromJSON+    , ToJSON+    , parseJSON+    , toJSON+    , withText+    ) import Network.Haskoin.Util import Network.Haskoin.Crypto.Keys import Network.Haskoin.Crypto.Base58 import Network.Haskoin.Crypto.Hash-import Network.Haskoin.Protocol.Script+import Network.Haskoin.Script.Types import Network.Haskoin.Script.SigHash  -- | Data type describing standard transaction output scripts. Output scripts@@ -51,8 +68,22 @@                     }       -- | Pay to a script hash.     | PayScriptHash { getOutputAddress  :: !Address }-    deriving (Eq, Show)+    deriving (Eq, Show, Read) +instance FromJSON ScriptOutput where+    parseJSON = withText "scriptoutput" $ \t -> either fail return $+        maybeToEither "scriptoutput not hex" +          (hexToBS $ T.unpack t) >>= decodeOutputBS++instance ToJSON ScriptOutput where+    toJSON = String . T.pack . bsToHex . encodeOutputBS++instance NFData ScriptOutput where+    rnf (PayPK k) = rnf k+    rnf (PayPKHash a) = rnf a+    rnf (PayMulSig k r) = rnf k `seq` rnf r+    rnf (PayScriptHash a) = rnf a+ -- | Returns True if the script is a pay to public key output. isPayPK :: ScriptOutput -> Bool isPayPK (PayPK _) = True@@ -76,9 +107,7 @@ -- | 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 +scriptAddr = ScriptAddress . hash160 . hash256BS . encodeOutputBS  -- | Sorts the public keys of a multisignature output in ascending order by -- comparing their serialized representations. This feature allows for easier@@ -121,6 +150,10 @@         (PubKeyAddress _) ->              error "encodeOutput: PubKeyAddress is invalid in PayScriptHash" +-- | Similar to 'encodeOutput' but encodes to a ByteString+encodeOutputBS :: ScriptOutput -> BS.ByteString+encodeOutputBS = encode' . encodeOutput+ -- | 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@@ -136,6 +169,10 @@     -- Pay to MultiSig Keys     _ -> matchPayMulSig s +-- | Similar to 'decodeOutput' but decodes from a ByteString+decodeOutputBS :: BS.ByteString -> Either String ScriptOutput+decodeOutputBS = (decodeOutput =<<) . decodeToEither+ -- Match [ OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG ] matchPayMulSig :: Script -> Either String ScriptOutput matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of@@ -182,106 +219,116 @@ -- input.  scriptSender :: Script -> Either String Address scriptSender s = case decodeInput s of-    Right (SpendPKHash _ key) -> return $ pubKeyAddr key+    Right (RegularInput (SpendPKHash _ key)) -> return $ pubKeyAddr key+    Right (ScriptHashInput _ rdm)            -> return $ scriptAddr rdm     Right _ -> Left "scriptSender: bad input script type"-    _ -> case decodeScriptHash s of-        Right (ScriptHashInput _ rdm) -> return $ scriptAddr rdm-        _ -> Left "scriptSender: non-standard script type"+    _ -> 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 = +data SimpleInput       -- | Spend the coins of a PayPK output.-      SpendPK     { getInputSig       :: !TxSignature }+    = 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)+    | SpendMulSig { getInputMulSigKeys :: ![TxSignature] }+    deriving (Eq, Show, Read) +instance NFData SimpleInput where+    rnf (SpendPK i) = rnf i+    rnf (SpendPKHash i k) = rnf i `seq` rnf k+    rnf (SpendMulSig k) = rnf k + -- | Returns True if the input script is spending a public key. isSpendPK :: ScriptInput -> Bool-isSpendPK (SpendPK _) = True+isSpendPK (RegularInput (SpendPK _)) = True isSpendPK _ = False  -- | Returns True if the input script is spending a public key hash. isSpendPKHash :: ScriptInput -> Bool-isSpendPKHash (SpendPKHash _ _) = True+isSpendPKHash (RegularInput (SpendPKHash _ _)) = True isSpendPKHash _ = False  -- | Returns True if the input script is spending a multisignature output. isSpendMulSig :: ScriptInput -> Bool-isSpendMulSig (SpendMulSig _ _) = True+isSpendMulSig (RegularInput (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        -> [ opPushData $ encodeSig ts ]-    SpendPKHash ts p  -> [ opPushData $ encodeSig ts-                         , opPushData $ encode' p-                         ]-    SpendMulSig ts r -        | length ts <= 16 && r >= 1 && r <= 16 ->-            let sigs = map (opPushData . encodeSig) ts-                in OP_0 : sigs ++ replicate (r - length ts) OP_0-        | otherwise -> error "SpendMulSig: Bad multisig parameters"+isScriptHashInput :: ScriptInput -> Bool+isScriptHashInput (ScriptHashInput _ _) = True+isScriptHashInput _ = False --- | 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"+type RedeemScript = ScriptOutput -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"+data ScriptInput+    = RegularInput    { getRegularInput     :: SimpleInput }+    | ScriptHashInput { getScriptHashInput  :: SimpleInput+                      , getScriptHashRedeem :: RedeemScript+                      }+    deriving (Eq, Show, Read) -type RedeemScript = ScriptOutput+instance NFData ScriptInput where+    rnf (RegularInput i) = rnf i+    rnf (ScriptHashInput i o) = rnf i `seq` rnf o --- | 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)+-- | Computes a 'Script' from a 'SimpleInput'. The 'Script' is a list of +-- 'ScriptOp' that can be used to build a 'Tx'.+encodeSimpleInput :: SimpleInput -> Script+encodeSimpleInput s = Script $ case s of+    SpendPK ts       -> [ opPushData $ encodeSig ts ]+    SpendPKHash ts p -> [ opPushData $ encodeSig ts+                        , opPushData $ encode' p+                        ]+    SpendMulSig ts   -> OP_0 : map (opPushData . encodeSig) ts --- | 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) ++ [opPushData $ encodeScriptOps so]-  where -    si = encodeInput i-    so = encodeOutput o+decodeSimpleInput :: Script -> Either String SimpleInput+decodeSimpleInput (Script ops) = maybeToEither errMsg $+    matchPK ops <|> matchPKHash ops <|> matchMulSig ops+  where+    matchPK [OP_PUSHDATA bs _] = SpendPK <$> eitherToMaybe (decodeSig bs)+    matchPK _ = Nothing+    matchPKHash [OP_PUSHDATA sig _, OP_PUSHDATA pub _] =+        liftM2 SpendPKHash (eitherToMaybe $ decodeSig sig) (decodeToMaybe pub)+    matchPKHash _ = Nothing+    matchMulSig (x:xs) = do+        guard $ isPushOp x+        SpendMulSig <$> foldrM f [] xs+    matchMulSig _ = Nothing+    f (OP_PUSHDATA bs _) acc = +        liftM2 (:) (eitherToMaybe $ decodeSig bs) (Just acc)+    f _ _ = Nothing+    errMsg = "decodeInput: Could not decode script input" --- | 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"+encodeInput :: ScriptInput -> Script+encodeInput s = case s of+    RegularInput ri -> encodeSimpleInput ri+    ScriptHashInput i o -> Script $+        (scriptOps $ encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o]++-- | Similar to 'encodeInput' but encodes to a ByteString+encodeInputBS :: ScriptInput -> BS.ByteString+encodeInputBS = encode' . encodeInput++-- | 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@(Script ops) = maybeToEither errMsg $+    matchSimpleInput <|> matchPayScriptHash+  where+    matchSimpleInput = RegularInput <$> (eitherToMaybe $ decodeSimpleInput s)+    matchPayScriptHash = case splitAt (length (scriptOps s) - 1) ops of+        (is, [OP_PUSHDATA bs _]) -> do+            rdm <- eitherToMaybe $ decodeOutputBS bs+            inp <- eitherToMaybe $ decodeSimpleInput $ Script is+            return $ ScriptHashInput inp rdm+        _ -> Nothing+    errMsg = "decodeInput: Could not decode script input"+        +-- | Similar to 'decodeInput' but decodes from a ByteString+decodeInputBS :: BS.ByteString -> Either String ScriptInput+decodeInputBS = (decodeInput =<<) . decodeToEither  

@@ -12,12 +12,15 @@ , decodeCanonicalSig ) where -import Control.Monad (liftM2)+import Control.DeepSeq (NFData, rnf)+import Control.Monad (liftM2, mzero)  import Data.Word (Word8) import Data.Bits (testBit, clearBit, setBit) import Data.Maybe (fromMaybe) import Data.Binary (Binary, get, put, getWord8, putWord8)+import Data.Aeson (Value(String), FromJSON, ToJSON, parseJSON, toJSON, withText)+import qualified Data.Text as T import qualified Data.ByteString as BS      ( ByteString     , index@@ -26,12 +29,14 @@     , append     , pack     , splitAt+    , empty     ) +import Network.Haskoin.Crypto.BigWord import Network.Haskoin.Crypto.Hash import Network.Haskoin.Crypto.ECDSA-import Network.Haskoin.Protocol.Script-import Network.Haskoin.Protocol.Tx+import Network.Haskoin.Script.Types+import Network.Haskoin.Protocol import Network.Haskoin.Util  -- | Data type representing the different ways a transaction can be signed.@@ -49,20 +54,26 @@     -- | 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 }   +    = 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 }     +    | 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 }   +    | SigSingle  { anyoneCanPay :: !Bool }        -- | Unrecognized sighash types will decode to SigUnknown.-    | SigUnknown { anyoneCanPay :: Bool-                 , getSigCode   :: Word8 +    | SigUnknown { anyoneCanPay :: !Bool+                 , getSigCode   :: !Word8                   }-    deriving (Eq, Show)+    deriving (Eq, Show, Read) +instance NFData SigHash where+    rnf (SigAll a) = rnf a+    rnf (SigNone a) = rnf a+    rnf (SigSingle a) = rnf a+    rnf (SigUnknown a c) = rnf a `seq` rnf c+ -- | Returns True if the 'SigHash' has the value SigAll. isSigAll :: SigHash -> Bool isSigAll sh = case sh of@@ -103,6 +114,13 @@         SigSingle acp -> if acp then 0x83 else 0x03         SigUnknown _ w -> w +instance ToJSON SigHash where+    toJSON = String . T.pack . bsToHex . encode'++instance FromJSON SigHash where+    parseJSON = withText "sighash" $ \t ->+        maybe mzero return $ decodeToMaybe =<< (hexToBS $ T.unpack t)+ -- | Encodes a 'SigHash' to a 32 bit-long bytestring. encodeSigHash32 :: SigHash -> BS.ByteString encodeSigHash32 sh = encode' sh `BS.append` BS.pack [0,0,0]@@ -112,7 +130,7 @@           -> 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.+          -> Word256 -- ^ 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@@ -124,12 +142,12 @@ -- Builds transaction inputs for computing SigHashes buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] buildInputs txins out i sh-    | anyoneCanPay sh   = (txins !! i) { scriptInput = out } : []+    | anyoneCanPay sh   = (txins !! i) { scriptInput = encode' 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 }+    empty  = map (\ti -> ti{ scriptInput = BS.empty }) txins+    single = updateIndex i empty $ \ti -> ti{ scriptInput = encode' out }     noSeq (ti,j) = if i == j then ti else ti{ txInSequence = 0 }  -- Build transaction outputs for computing SigHashes@@ -140,15 +158,18 @@     | i >= length txos = Nothing     | otherwise = return $ buffer ++ [txos !! i]   where -    buffer = replicate i $ TxOut (-1) $ Script []+    buffer = replicate i $ TxOut (-1) BS.empty  -- | 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)+    { txSignature :: !Signature +    , sigHashType :: !SigHash+    } deriving (Eq, Show, Read)++instance NFData TxSignature where+    rnf (TxSignature s h) = rnf s `seq` rnf h  -- | Serialize a 'TxSignature' to a ByteString. encodeSig :: TxSignature -> BS.ByteString

@@ -0,0 +1,543 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.Haskoin.Script.Types+( ScriptOp(..)+, Script(..)+, PushDataType(..)+, isPushOp+, opPushData+) where++import Control.DeepSeq (NFData, rnf)+import Control.Monad (liftM2, unless, forM_)+import Control.Applicative ((<$>))++import Data.Word (Word8)+import Data.Binary (Binary, get, put)+import Data.Binary.Get +    ( isEmpty+    , getWord8+    , getWord16le+    , getWord32le+    , getByteString+    )+import Data.Binary.Put +    ( putWord8+    , putWord16le+    , putWord32le+    , putByteString+    )+import qualified Data.ByteString as BS+    ( ByteString+    , length+    )++-- | Data type representing a transaction script. Scripts are defined as lists+-- of script operators 'ScriptOp'. Scripts are used to:+--+-- * Define the spending conditions in the output of a transaction+--+-- * Provide the spending signatures in the input of a transaction+data Script = +    Script { +             -- | List of script operators defining this script+             scriptOps :: ![ScriptOp] +           }+    deriving (Eq, Show, Read)++instance NFData Script where+    rnf (Script o) = rnf o++instance Binary Script where+    get = +        Script <$> getScriptOps+      where+        getScriptOps = do+            empty <- isEmpty+            if empty +                then return [] +                else liftM2 (:) get getScriptOps++    put (Script ops) = forM_ ops put++-- | Data type representing the type of an OP_PUSHDATA opcode.+data PushDataType+    = +      -- | The next opcode bytes is data to be pushed onto the stack+      OPCODE +      -- | The next byte contains the number of bytes to be pushed onto+      -- the stack+    | OPDATA1 +      -- | The next two bytes contains the number of bytes to be pushed onto+      -- the stack+    | OPDATA2+      -- | The next four bytes contains the number of bytes to be pushed onto+      -- the stack+    | OPDATA4+    deriving (Show, Read, Eq)++instance NFData PushDataType++-- | Data type representing all of the operators allowed inside a 'Script'.+data ScriptOp+      -- Pushing Data+    = OP_PUSHDATA !BS.ByteString !PushDataType+    | OP_0+    | OP_1NEGATE+    | OP_RESERVED+    | 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++      -- Flow control+    | OP_NOP+    | OP_VER        -- reserved+    | OP_IF+    | OP_NOTIF+    | OP_VERIF      -- resreved+    | OP_VERNOTIF   -- reserved+    | OP_ELSE+    | OP_ENDIF+    | OP_VERIFY+    | OP_RETURN++      -- Stack operations+    | OP_TOALTSTACK+    | OP_FROMALTSTACK+    | OP_IFDUP+    | OP_DEPTH+    | OP_DROP+    | OP_DUP+    | OP_NIP+    | OP_OVER+    | OP_PICK+    | OP_ROLL+    | OP_ROT+    | OP_SWAP+    | OP_TUCK+    | OP_2DROP+    | OP_2DUP+    | OP_3DUP+    | OP_2OVER+    | OP_2ROT+    | OP_2SWAP++      -- Splice+    | OP_CAT+    | OP_SUBSTR+    | OP_LEFT+    | OP_RIGHT+    | OP_SIZE++      -- Bitwise logic+    | OP_INVERT+    | OP_AND+    | OP_OR+    | OP_XOR+    | OP_EQUAL+    | OP_EQUALVERIFY+    | OP_RESERVED1+    | OP_RESERVED2++      -- Arithmetic+    | OP_1ADD+    | OP_1SUB+    | OP_2MUL+    | OP_2DIV+    | OP_NEGATE+    | OP_ABS+    | OP_NOT+    | OP_0NOTEQUAL+    | OP_ADD+    | OP_SUB+    | OP_MUL+    | OP_DIV+    | OP_MOD+    | OP_LSHIFT+    | OP_RSHIFT+    | OP_BOOLAND+    | OP_BOOLOR+    | OP_NUMEQUAL+    | OP_NUMEQUALVERIFY+    | OP_NUMNOTEQUAL+    | OP_LESSTHAN+    | OP_GREATERTHAN+    | OP_LESSTHANOREQUAL+    | OP_GREATERTHANOREQUAL+    | OP_MIN+    | OP_MAX+    | OP_WITHIN++      -- Crypto+    | OP_RIPEMD160+    | OP_SHA1+    | OP_SHA256+    | OP_HASH160+    | OP_HASH256+    | OP_CODESEPARATOR+    | OP_CHECKSIG+    | OP_CHECKSIGVERIFY+    | OP_CHECKMULTISIG+    | OP_CHECKMULTISIGVERIFY++      -- Expansion+    | OP_NOP1 | OP_NOP2 | OP_NOP3 | OP_NOP4 | OP_NOP5+    | OP_NOP6 | OP_NOP7 | OP_NOP8 | OP_NOP9 | OP_NOP10+++      -- Other+    | OP_PUBKEYHASH+    | OP_PUBKEY+    | OP_INVALIDOPCODE !Word8++        deriving (Show, Read, Eq)+++instance NFData ScriptOp where+    rnf (OP_PUSHDATA b t) = rnf b `seq` rnf t+    rnf (OP_INVALIDOPCODE c) = rnf c+    rnf x = x `seq` ()+++instance Binary ScriptOp where++    get = go =<< (fromIntegral <$> getWord8) +      where +        go op +            | op == 0x00 = return $ OP_0+            | op <= 0x4b = do+                payload <- getByteString (fromIntegral op)+                return $ OP_PUSHDATA payload OPCODE+            | op == 0x4c = do+                len  <- getWord8+                payload <- getByteString (fromIntegral len)+                return $ OP_PUSHDATA payload OPDATA1+            | op == 0x4d = do+                len  <- getWord16le+                payload <- getByteString (fromIntegral len)+                return $ OP_PUSHDATA payload OPDATA2+            | op == 0x4e = do+                len  <- getWord32le+                payload <- getByteString (fromIntegral len)+                return $ OP_PUSHDATA payload OPDATA4++            | op == 0x4f = return $ OP_1NEGATE+            | op == 0x50 = return $ OP_RESERVED+            | op == 0x51 = return $ OP_1+            | op == 0x52 = return $ OP_2+            | op == 0x53 = return $ OP_3+            | op == 0x54 = return $ OP_4+            | op == 0x55 = return $ OP_5+            | op == 0x56 = return $ OP_6+            | op == 0x57 = return $ OP_7+            | op == 0x58 = return $ OP_8+            | op == 0x59 = return $ OP_9+            | op == 0x5a = return $ OP_10+            | op == 0x5b = return $ OP_11+            | op == 0x5c = return $ OP_12+            | op == 0x5d = return $ OP_13+            | op == 0x5e = return $ OP_14+            | op == 0x5f = return $ OP_15+            | op == 0x60 = return $ OP_16+            -- Flow control+            | op == 0x61 = return $ OP_NOP+            | op == 0x62 = return $ OP_VER        -- reserved+            | op == 0x63 = return $ OP_IF+            | op == 0x64 = return $ OP_NOTIF+            | op == 0x65 = return $ OP_VERIF      -- reserved+            | op == 0x66 = return $ OP_VERNOTIF   -- reserved+            | op == 0x67 = return $ OP_ELSE+            | op == 0x68 = return $ OP_ENDIF+            | op == 0x69 = return $ OP_VERIFY+            | op == 0x6a = return $ OP_RETURN++            -- Stack+            | op == 0x6b = return $ OP_TOALTSTACK+            | op == 0x6c = return $ OP_FROMALTSTACK+            | op == 0x6d = return $ OP_2DROP+            | op == 0x6e = return $ OP_2DUP+            | op == 0x6f = return $ OP_3DUP+            | op == 0x70 = return $ OP_2OVER+            | op == 0x71 = return $ OP_2ROT+            | op == 0x72 = return $ OP_2SWAP+            | op == 0x73 = return $ OP_IFDUP+            | op == 0x74 = return $ OP_DEPTH+            | op == 0x75 = return $ OP_DROP+            | op == 0x76 = return $ OP_DUP+            | op == 0x77 = return $ OP_NIP+            | op == 0x78 = return $ OP_OVER+            | op == 0x79 = return $ OP_PICK+            | op == 0x7a = return $ OP_ROLL+            | op == 0x7b = return $ OP_ROT+            | op == 0x7c = return $ OP_SWAP+            | op == 0x7d = return $ OP_TUCK++            -- Splice+            | op == 0x7e = return $ OP_CAT+            | op == 0x7f = return $ OP_SUBSTR+            | op == 0x80 = return $ OP_LEFT+            | op == 0x81 = return $ OP_RIGHT+            | op == 0x82 = return $ OP_SIZE++            -- Bitwise logic+            | op == 0x83 = return $ OP_INVERT+            | op == 0x84 = return $ OP_AND+            | op == 0x85 = return $ OP_OR+            | op == 0x86 = return $ OP_XOR+            | op == 0x87 = return $ OP_EQUAL+            | op == 0x88 = return $ OP_EQUALVERIFY+            | op == 0x89 = return $ OP_RESERVED1+            | op == 0x8a = return $ OP_RESERVED2++            -- Arithmetic+            | op == 0x8b = return $ OP_1ADD+            | op == 0x8c = return $ OP_1SUB+            | op == 0x8d = return $ OP_2MUL+            | op == 0x8e = return $ OP_2DIV+            | op == 0x8f = return $ OP_NEGATE+            | op == 0x90 = return $ OP_ABS+            | op == 0x91 = return $ OP_NOT+            | op == 0x92 = return $ OP_0NOTEQUAL+            | op == 0x93 = return $ OP_ADD+            | op == 0x94 = return $ OP_SUB+            | op == 0x95 = return $ OP_MUL+            | op == 0x96 = return $ OP_DIV+            | op == 0x97 = return $ OP_MOD+            | op == 0x98 = return $ OP_LSHIFT+            | op == 0x99 = return $ OP_RSHIFT+            | op == 0x9a = return $ OP_BOOLAND+            | op == 0x9b = return $ OP_BOOLOR+            | op == 0x9c = return $ OP_NUMEQUAL+            | op == 0x9d = return $ OP_NUMEQUALVERIFY+            | op == 0x9e = return $ OP_NUMNOTEQUAL+            | op == 0x9f = return $ OP_LESSTHAN+            | op == 0xa0 = return $ OP_GREATERTHAN+            | op == 0xa1 = return $ OP_LESSTHANOREQUAL+            | op == 0xa2 = return $ OP_GREATERTHANOREQUAL+            | op == 0xa3 = return $ OP_MIN+            | op == 0xa4 = return $ OP_MAX+            | op == 0xa5 = return $ OP_WITHIN++            -- Crypto+            | op == 0xa6 = return $ OP_RIPEMD160+            | op == 0xa7 = return $ OP_SHA1+            | op == 0xa8 = return $ OP_SHA256+            | op == 0xa9 = return $ OP_HASH160+            | op == 0xaa = return $ OP_HASH256+            | op == 0xab = return $ OP_CODESEPARATOR+            | op == 0xac = return $ OP_CHECKSIG+            | op == 0xad = return $ OP_CHECKSIGVERIFY+            | op == 0xae = return $ OP_CHECKMULTISIG+            | op == 0xaf = return $ OP_CHECKMULTISIGVERIFY++            -- More NOPs+            | op == 0xb0 = return $ OP_NOP1+            | op == 0xb1 = return $ OP_NOP2+            | op == 0xb2 = return $ OP_NOP3+            | op == 0xb3 = return $ OP_NOP4+            | op == 0xb4 = return $ OP_NOP5+            | op == 0xb5 = return $ OP_NOP6+            | op == 0xb6 = return $ OP_NOP7+            | op == 0xb7 = return $ OP_NOP8+            | op == 0xb8 = return $ OP_NOP9+            | op == 0xb9 = return $ OP_NOP10++            -- Constants+            | op == 0xfd = return $ OP_PUBKEYHASH+            | op == 0xfe = return $ OP_PUBKEY++            | otherwise = return $ OP_INVALIDOPCODE op++    put op = case op of++        (OP_PUSHDATA payload optype)-> do+            let len = BS.length payload+            case optype of+                OPCODE -> do+                    unless (len <= 0x4b) $ fail +                        "OP_PUSHDATA OPCODE: Payload size too big"+                    putWord8 $ fromIntegral len+                OPDATA1 -> do+                    unless (len <= 0xff) $ fail +                        "OP_PUSHDATA OPDATA1: Payload size too big"+                    putWord8 0x4c+                    putWord8 $ fromIntegral len+                OPDATA2 -> do+                    unless (len <= 0xffff) $ fail +                        "OP_PUSHDATA OPDATA2: Payload size too big"+                    putWord8 0x4d+                    putWord16le $ fromIntegral len+                OPDATA4 -> do+                    unless (len <= 0xffffffff) $ fail +                        "OP_PUSHDATA OPDATA4: Payload size too big"+                    putWord8 0x4e+                    putWord32le $ fromIntegral len+            putByteString payload++        -- Constants+        OP_0                 -> putWord8 0x00+        OP_1NEGATE           -> putWord8 0x4f+        OP_RESERVED          -> putWord8 0x50+        OP_1                 -> putWord8 0x51+        OP_2                 -> putWord8 0x52+        OP_3                 -> putWord8 0x53+        OP_4                 -> putWord8 0x54+        OP_5                 -> putWord8 0x55+        OP_6                 -> putWord8 0x56+        OP_7                 -> putWord8 0x57+        OP_8                 -> putWord8 0x58+        OP_9                 -> putWord8 0x59+        OP_10                -> putWord8 0x5a+        OP_11                -> putWord8 0x5b+        OP_12                -> putWord8 0x5c+        OP_13                -> putWord8 0x5d+        OP_14                -> putWord8 0x5e+        OP_15                -> putWord8 0x5f+        OP_16                -> putWord8 0x60++        -- Crypto Constants+        OP_PUBKEY            -> putWord8 0xfe+        OP_PUBKEYHASH        -> putWord8 0xfd++        -- Invalid Opcodes+        (OP_INVALIDOPCODE x) -> putWord8 x++        -- Flow Control+        OP_NOP               -> putWord8 0x61+        OP_VER               -> putWord8 0x62+        OP_IF                -> putWord8 0x63+        OP_NOTIF             -> putWord8 0x64+        OP_VERIF             -> putWord8 0x65+        OP_VERNOTIF          -> putWord8 0x66+        OP_ELSE              -> putWord8 0x67+        OP_ENDIF             -> putWord8 0x68+        OP_VERIFY            -> putWord8 0x69+        OP_RETURN            -> putWord8 0x6a++        -- Stack Operations+        OP_TOALTSTACK        -> putWord8 0x6b+        OP_FROMALTSTACK      -> putWord8 0x6c+        OP_2DROP             -> putWord8 0x6d+        OP_2DUP              -> putWord8 0x6e+        OP_3DUP              -> putWord8 0x6f+        OP_2OVER             -> putWord8 0x70+        OP_2ROT              -> putWord8 0x71+        OP_2SWAP             -> putWord8 0x72+        OP_IFDUP             -> putWord8 0x73+        OP_DEPTH             -> putWord8 0x74+        OP_DROP              -> putWord8 0x75+        OP_DUP               -> putWord8 0x76+        OP_NIP               -> putWord8 0x77+        OP_OVER              -> putWord8 0x78+        OP_PICK              -> putWord8 0x79+        OP_ROLL              -> putWord8 0x7a+        OP_ROT               -> putWord8 0x7b+        OP_SWAP              -> putWord8 0x7c+        OP_TUCK              -> putWord8 0x7d++        -- Splice+        OP_CAT               -> putWord8 0x7e+        OP_SUBSTR            -> putWord8 0x7f+        OP_LEFT              -> putWord8 0x80+        OP_RIGHT             -> putWord8 0x81+        OP_SIZE              -> putWord8 0x82++        -- Bitwise Logic+        OP_INVERT            -> putWord8 0x83+        OP_AND               -> putWord8 0x84+        OP_OR                -> putWord8 0x85+        OP_XOR               -> putWord8 0x86+        OP_EQUAL             -> putWord8 0x87+        OP_EQUALVERIFY       -> putWord8 0x88+        OP_RESERVED1         -> putWord8 0x89+        OP_RESERVED2         -> putWord8 0x8a++        -- Arithmetic+        OP_1ADD              -> putWord8 0x8b+        OP_1SUB              -> putWord8 0x8c+        OP_2MUL              -> putWord8 0x8d+        OP_2DIV              -> putWord8 0x8e+        OP_NEGATE            -> putWord8 0x8f+        OP_ABS               -> putWord8 0x90+        OP_NOT               -> putWord8 0x91+        OP_0NOTEQUAL         -> putWord8 0x92+        OP_ADD               -> putWord8 0x93+        OP_SUB               -> putWord8 0x94+        OP_MUL               -> putWord8 0x95+        OP_DIV               -> putWord8 0x96+        OP_MOD               -> putWord8 0x97+        OP_LSHIFT            -> putWord8 0x98+        OP_RSHIFT            -> putWord8 0x99+        OP_BOOLAND           -> putWord8 0x9a+        OP_BOOLOR            -> putWord8 0x9b+        OP_NUMEQUAL          -> putWord8 0x9c+        OP_NUMEQUALVERIFY    -> putWord8 0x9d+        OP_NUMNOTEQUAL       -> putWord8 0x9e+        OP_LESSTHAN          -> putWord8 0x9f+        OP_GREATERTHAN       -> putWord8 0xa0+        OP_LESSTHANOREQUAL   -> putWord8 0xa1+        OP_GREATERTHANOREQUAL-> putWord8 0xa2+        OP_MIN               -> putWord8 0xa3+        OP_MAX               -> putWord8 0xa4+        OP_WITHIN            -> putWord8 0xa5++        -- Crypto+        OP_RIPEMD160         -> putWord8 0xa6+        OP_SHA1              -> putWord8 0xa7+        OP_SHA256            -> putWord8 0xa8+        OP_HASH160           -> putWord8 0xa9+        OP_HASH256           -> putWord8 0xaa+        OP_CODESEPARATOR     -> putWord8 0xab+        OP_CHECKSIG          -> putWord8 0xac+        OP_CHECKSIGVERIFY    -> putWord8 0xad+        OP_CHECKMULTISIG     -> putWord8 0xae+        OP_CHECKMULTISIGVERIFY -> putWord8 0xaf++        -- More NOPs+        OP_NOP1              -> putWord8 0xb0+        OP_NOP2              -> putWord8 0xb1+        OP_NOP3              -> putWord8 0xb2+        OP_NOP4              -> putWord8 0xb3+        OP_NOP5              -> putWord8 0xb4+        OP_NOP6              -> putWord8 0xb5+        OP_NOP7              -> putWord8 0xb6+        OP_NOP8              -> putWord8 0xb7+        OP_NOP9              -> putWord8 0xb8+        OP_NOP10             -> putWord8 0xb9+++-- | Check whether opcode is only data.+isPushOp :: ScriptOp -> Bool+isPushOp op = case op of+    OP_PUSHDATA _ _ -> True+    OP_0            -> True+    OP_1NEGATE      -> True+    OP_1            -> True+    OP_2            -> True+    OP_3            -> True+    OP_4            -> True+    OP_5            -> True+    OP_6            -> True+    OP_7            -> True+    OP_8            -> True+    OP_9            -> True+    OP_10           -> True+    OP_11           -> True+    OP_12           -> True+    OP_13           -> True+    OP_14           -> True+    OP_15           -> True+    OP_16           -> True+    _               -> False       ++-- | Optimally encode data using one of the 4 types of data pushing opcodes+opPushData :: BS.ByteString -> ScriptOp+opPushData bs+    | len <= 0x4b       = OP_PUSHDATA bs OPCODE+    | len <= 0xff       = OP_PUSHDATA bs OPDATA1+    | len <= 0xffff     = OP_PUSHDATA bs OPDATA2+    | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4+    | otherwise         = error "opPushData: payload size too big"+  where+    len = BS.length bs+

@@ -1,274 +1,232 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} module Network.Haskoin.Stratum-( -- * Types-  -- ** Bitcoin-  Balance(..)-, Coin(..)-, TxHeight(..)-  -- ** Stratum data+( -- * Stratum JSON-RPC Message Types+  StratumRequest(..) , StratumNotif(..)-, StratumQuery(..)-, StratumResponse(..)-  -- ** JSON-RPC data for Stratum-, MessageStratum-, NotifStratum-, RequestStratum-, ResponseStratum-, ResultStratum-  -- ** Stratum Session for JSON-RPC Conduit-, StratumSession-  -- * Functions-, toRequest-, parseResult-, parseNotif-, newStratumReq-  -- * Generic JSON-RPC Conduit-  -- ** Types-, Session-  -- ** Functions-, initSession-, newReq-, newNotif-, reqSource-, resConduit-  -- * Generic JSON-RPC Messages-  -- ** Types-, Method-, ErrorValue-, RequestValue-, ResponseValue-, MessageValue-, ResultValue-, Id(..)-, Result-, Error(..)-  -- ** Messages-, Request(..)-, Response(..)-, Message(..)-  -- ** Errors-, errParse-, errReq-, errMeth-, errParams-, errInternal-, errStr-  -- ** Helpers-, leftStr-, numericId+, StratumResult(..)+  -- * Stratum Internal Types+, StratumTxInfo(..)+, StratumCoin(..) ) where +import Control.Applicative ((<$>), (<*>))+import Control.DeepSeq (NFData, rnf) import Control.Monad (mzero)-import Control.Monad.Trans (MonadIO)+ import Data.Aeson-    ( FromJSON-    , ToJSON-    , Value (Array, Object, String)-    , (.:), (.=)-    , object-    , parseJSON-    , toJSON-    , withText-    )-import Data.Aeson.Types (Parser)-import Data.Maybe (fromJust)-import Data.Text (Text, pack, unpack)-import qualified Data.Vector as V+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import qualified Data.Text as T import Data.Word (Word, Word64)-import Network.Haskoin.Crypto-import Network.Haskoin.Protocol hiding (Message)-import Network.Haskoin.Stratum.Message-import Network.Haskoin.Stratum.Conduit-import Network.Haskoin.Util --- | JSON-RPC request with Stratum payload.-type RequestStratum = Request StratumQuery--- | JSON-RPC notification with Stratum payload.-type NotifStratum = Request StratumNotif--- | JSON-RPC response with Stratum payload.-type ResponseStratum = Response StratumResponse Value String--- | Stratum result in JSON-RPC response.-type ResultStratum = Result StratumResponse Value String--- | Message from Stratum JSON-RPC server.-type MessageStratum = Message StratumNotif StratumResponse Value String--- | Session type for JSON-RPC conduit.-type StratumSession-    = Session RequestStratum StratumResponse Value String StratumNotif---- | Transaction height and ID pair. Used in history responses.-data TxHeight = TxHeight-    { txHeightBlock :: Word  -- ^ Block height.-    , txHeightId :: Hash256 -- ^ Transaction id.-    } deriving (Show, Eq)+import Network.JsonRpc --- | Bitcoin outpoint information.-data Coin = Coin-    { coinOutPoint :: OutPoint   -- ^ Coin data.-    , coinTxHeight :: TxHeight   -- ^ Transaction information.-    , coinValue :: Word64        -- ^ Output vale.-    } deriving (Show, Eq)+import Network.Haskoin.Crypto+import Network.Haskoin.Protocol --- | Balance information.-data Balance = Balance-    { balConfirmed :: Word64   -- ^ Confirmed balance.-    , balUnconfirmed :: Word64 -- ^ Unconfirmed balance.-    } deriving (Show, Eq)+--+-- Stratum Request+--  -- | Stratum Request data. To be placed inside JSON request.-data StratumQuery-    = QueryVersion { queryClientVer :: Text, queryProtoVer :: Text }-    | QueryHistory { queryAddr :: Address }-    | QueryBalance { queryAddr :: Address }-    | QueryUnspent { queryAddr :: Address }-    | QueryTx { queryTxid :: Hash256 }-    | QueryBroadcast { queryTx :: Tx }-    | SubAddress { queryAddr :: Address }+data StratumRequest+    = StratumReqVersion { stratumReqClientVer     :: !Text+                        , stratumReqProtoVer      :: !Text+                        }+    | StratumReqHistory { stratumReqAddr          :: !Address+                        }+    | StratumReqBalance { stratumReqAddr          :: !Address+                        }+    | StratumReqUnspent { stratumReqAddr          :: !Address+                        }+    | StratumReqTx      { stratumReqTxid          :: !TxHash+                        }+    | StratumBcastTx    { stratumReqTx            :: !Tx+                        }+    | StratumSubAddr    { stratumReqAddr          :: !Address+                        }     deriving (Eq, Show) --- | Stratum Response Result data.-data StratumResponse-    = ServerVersion { stratumServerVer :: String }-    | AddressHistory { stratumAddrHist :: [TxHeight] }-    | AddressBalance { stratumBalance :: Balance }-    | AddressUnspent { stratumCoins :: [Coin] }-    | Transaction { stratumTx :: Tx }-    | BroadcastId { stratumTxid :: Hash256 }-    | AddrStatus { stratumAddrStatus :: Hash256 }-    deriving (Eq, Show)+instance NFData StratumRequest where+    rnf (StratumReqVersion c p) = rnf c `seq` rnf p+    rnf (StratumReqHistory   a) = rnf a+    rnf (StratumReqBalance   a) = rnf a+    rnf (StratumReqUnspent   a) = rnf a+    rnf (StratumReqTx        i) = rnf i+    rnf (StratumBcastTx      t) = rnf t+    rnf (StratumSubAddr      a) = rnf a +instance ToJSON StratumRequest where+    toJSON (StratumReqVersion c p) = toJSON (c, p)+    toJSON (StratumReqHistory   a) = toJSON [a]+    toJSON (StratumReqBalance   a) = toJSON [a]+    toJSON (StratumReqUnspent   a) = toJSON [a]+    toJSON (StratumReqTx        i) = toJSON [i]+    toJSON (StratumBcastTx      t) = toJSON [t]+    toJSON (StratumSubAddr      a) = toJSON [a]++instance ToRequest StratumRequest where+    requestMethod (StratumReqVersion _ _) = "server.version"+    requestMethod (StratumReqHistory   _) = "blockchain.address.get_history"+    requestMethod (StratumReqBalance   _) = "blockchain.address.get_balance"+    requestMethod (StratumReqUnspent   _) = "blockchain.address.listunspent"+    requestMethod (StratumReqTx        _) = "blockchain.transaction.get"+    requestMethod (StratumBcastTx      _) = "blockchain.transaction.broadcast"+    requestMethod (StratumSubAddr      _) = "blockchain.address.subscribe"++instance FromRequest StratumRequest where+    paramsParser "server.version" = Just $ \x ->+        fmap (\(c, p) -> StratumReqVersion c p) $ parseJSON x++    paramsParser "blockchain.address.get_history" = Just $ \x ->+        parseJSON x >>= maybe mzero (return . StratumReqHistory) . listToMaybe++    paramsParser "blockchain.address.get_balance" = Just $ \x ->+        parseJSON x >>= maybe mzero (return . StratumReqBalance) . listToMaybe++    paramsParser "blockchain.address.listunspent" = Just $ \x ->+        parseJSON x >>= maybe mzero (return . StratumReqUnspent) . listToMaybe++    paramsParser "blockchain.address.subscribe" = Just $ \x ->+        parseJSON x >>= maybe mzero (return . StratumSubAddr) . listToMaybe++    paramsParser "blockchain.transaction.get" = Just $ \x ->+        parseJSON x >>= maybe mzero (return . StratumReqTx) . listToMaybe++    paramsParser "blockchain.transaction.broadcast" = Just $ \x ->+        parseJSON x >>= maybe mzero (return . StratumBcastTx) . listToMaybe++    paramsParser _ = Nothing++--+-- Stratum Notifications+--+ data StratumNotif-    = NotifAddress { notifAddr :: Address, notifAddrStatus :: Hash256 }+    = StratumNotifAddr  { stratumNotifAddr        :: !Address+                        , stratumNotifAddrStatus  :: !Word256+                        }     deriving (Eq, Show) -instance ToJSON StratumNotif where-    toJSON (NotifAddress a t) = toJSON (a, hashToJSON t)+instance NFData StratumNotif where+    rnf (StratumNotifAddr  a t) = rnf a `seq` rnf t -instance ToJSON StratumQuery where-    toJSON (QueryVersion c p) = toJSON (c, p)-    toJSON (QueryHistory a) = toJSON [a]-    toJSON (QueryUnspent a) = toJSON [a]-    toJSON (QueryBalance a) = toJSON [a]-    toJSON (QueryTx i) = toJSON [txidToJSON i]-    toJSON (QueryBroadcast t) = txToJSON t-    toJSON (SubAddress a) = toJSON [a]+instance ToJSON StratumNotif where+    toJSON (StratumNotifAddr  a t) = toJSON (a, t) -instance FromJSON Balance where-    parseJSON (Object o) = do-        c <- o .: "confirmed"-        u <- o .: "unconfirmed"-        return $ Balance c u-    parseJSON _ = mzero+instance ToNotif StratumNotif where+    notifMethod (StratumNotifAddr  _ _) = "blockchain.address.subscribe" -instance FromJSON TxHeight where-    parseJSON (Object v) = do-        h <- v .: "height"-        t <- v .: "tx_hash"-        i <- txidParse t-        return $ TxHeight h i-    parseJSON _ = mzero+instance FromNotif StratumNotif where+    notifParamsParser "blockchain.address.subscribe" = Just $ \x ->+        fmap (\(a, s) -> StratumNotifAddr a s) $ parseJSON x -instance ToJSON TxHeight where-    toJSON x = object-        [ "height" .= txHeightBlock x-        , "tx_hash" .= txidToJSON (txHeightId x)-        ]+    notifParamsParser _ = Nothing -instance FromJSON Coin where-    parseJSON (Object o) = do-        h <- o .: "height"-        v <- o .: "value"-        t <- o .: "tx_hash"-        p <- o .: "tx_pos"-        i <- txidParse t-        let op = OutPoint i p-            th = TxHeight h i-        return $ Coin op th v-    parseJSON _ = mzero+--+-- Stratum Responses+-- -instance ToJSON Coin where-    toJSON x = object-        [ "height" .= txHeightBlock (coinTxHeight x)-        , "value" .= coinValue x-        , "tx_hash" .= txidToJSON (txHeightId $ coinTxHeight x)-        , "tx_pos" .= outPointIndex (coinOutPoint x)-        ]+-- | Stratum Response Result data.+data StratumResult+    = StratumSrvVersion     { stratumSrvVersion     :: !String+                            }+    | StratumAddrHistory    { stratumAddrHist       :: ![StratumTxInfo]+                            }+    | StratumAddrBalance    { stratumConfirmed      :: !Word64+                            , stratumUnconfirmed    :: !Word64+                            }+    | StratumAddrUnspent    { stratumCoins          :: ![StratumCoin]+                            }+    | StratumAddrStatus     { stratumAddrStatus     :: !Word256+                            }+    | StratumTx             { stratumTx             :: !Tx+                            }+    | StratumBcastId        { stratumTxId           :: !TxHash+                            }+    deriving (Eq, Show) -method :: StratumQuery -> Text-method (QueryVersion _ _) = "server.version"-method (QueryHistory _) = "blockchain.address.get_history"-method (QueryBalance _) = "blockchain.address.get_balance"-method (QueryUnspent _) = "blockchain.address.get_unspent"-method (QueryTx _) = "blockchain.transaction.get"-method (QueryBroadcast _) = "blockchain.transaction.broadcast"-method (SubAddress _) = "blockchain.address.subscribe"+instance NFData StratumResult where+    rnf (StratumSrvVersion    s) = rnf s+    rnf (StratumAddrHistory  ts) = rnf ts+    rnf (StratumAddrBalance c u) = rnf c `seq` rnf u+    rnf (StratumAddrUnspent  cs) = rnf cs+    rnf (StratumAddrStatus    s) = rnf s+    rnf (StratumTx            t) = rnf t+    rnf (StratumBcastId       i) = rnf i --- | Create a JSON-RPC request from a Stratum request.-toRequest :: StratumQuery          -- ^ Stratum request data.-          -> Int                   -- ^ JSON-RPC request id.-          -> RequestStratum   -- ^ Returns JSON-RPC request object.-toRequest s i = Request (method s) (Just s) (Just (IntId i))+instance ToJSON StratumResult where+    toJSON (StratumSrvVersion    v) = toJSON v+    toJSON (StratumAddrHistory  ts) = toJSON ts+    toJSON (StratumAddrBalance c u) = object+        ["confirmed" .= c, "unconfirmed" .= u]+    toJSON (StratumAddrUnspent  cs) = toJSON cs+    toJSON (StratumAddrStatus    s) = toJSON s+    toJSON (StratumTx            t) = toJSON t+    toJSON (StratumBcastId       i) = toJSON i --- | Parse result from JSON-RPC response into a Stratum response.-parseResult :: StratumQuery -- ^ StratumQuery used in corresponding request.-            -> ResultValue -- ^ Result from JSON-RPC response-            -> Parser ResultStratum -- ^ Returns Aeson parser.-parseResult q (Right v) = parseHelper q v >>= return . Right-parseResult _ (Left e) = return $ Left e+instance FromResponse StratumResult where+    parseResult "server.version" =+        fmap StratumSrvVersion . parseJSON+    parseResult "blockchain.address.get_history" =+        fmap StratumAddrHistory . parseJSON+    parseResult "blockchain.address.get_balance" =+        withObject "balance" $ \o ->+            StratumAddrBalance <$> o .: "confirmed" <*> o .: "unconfirmed"+    parseResult "blockchain.address.listunspent" =+        fmap StratumAddrUnspent . parseJSON+    parseResult "blockchain.transaction.get" =+        fmap StratumTx . parseJSON+    parseResult "blockchain.transaction.broadcast" =+        fmap StratumBcastId . parseJSON+    parseResult "blockchain.address.subscribe" =+        fmap StratumAddrStatus . parseJSON+    parseResult m = const . fail $+        "Unknown method: " ++ T.unpack m -parseHelper :: StratumQuery -> Value -> Parser StratumResponse-parseHelper (QueryVersion _ _) v = parseJSON v >>= return . ServerVersion-parseHelper (QueryHistory _) v = parseJSON v >>= return . AddressHistory-parseHelper (QueryBalance _) v = parseJSON v >>= return . AddressBalance-parseHelper (QueryUnspent _) v = parseJSON v >>= return . AddressUnspent-parseHelper (QueryTx _) v = txParse v >>= return . Transaction-parseHelper (QueryBroadcast _) v = txidParse v >>= return . BroadcastId-parseHelper (SubAddress _) v = hashParse v >>= return . AddrStatus+--+-- Stratum Types+-- -parseNotifHelper :: Method-                 -> Value-                 -> Parser StratumNotif-parseNotifHelper "blockchain.address.subscribe" (Array v) = do-    a <- parseJSON (V.head v)-    s <- hashParse (V.head $ V.tail v)-    return $ NotifAddress a s-parseNotifHelper _ _ = mzero+-- | Transaction height and ID pair. Used in history responses.+data StratumTxInfo = StratumTxInfo+    { stratumTxInfoHeight   :: !Word   -- ^ Block height.+    , stratumTxInfoId       :: !TxHash -- ^ Transaction id.+    } deriving (Show, Eq) --- | Parse notification from JSON-RPC request into Stratum format.-parseNotif :: RequestValue-             -- ^ Request to parse.-             -> Parser NotifStratum-             -- ^ Parser to Stratum request format-parseNotif (Request m (Just p) i) =-    parseNotifHelper m p >>= \s -> return $ Request m (Just s) i-parseNotif _ = mzero+instance NFData StratumTxInfo where+    rnf (StratumTxInfo h i) = rnf h `seq` rnf i --- | Helper function for Network.Haskoin.JSONRPC.Conduit-newStratumReq :: MonadIO m-              => StratumSession-              -> StratumQuery-              -> m Int-newStratumReq s q = newReq s (toRequest q) p-  where-    p (Response r i) = do-        x <- parseResult q r-        return $ Response x i+instance FromJSON StratumTxInfo where+    parseJSON = withObject "txheight" $ \o ->+        StratumTxInfo <$> o .: "height" <*> o .: "tx_hash" -txidToJSON :: Hash256 -> Value-txidToJSON = String . pack . encodeTxid+instance ToJSON StratumTxInfo where+    toJSON (StratumTxInfo h i) = object ["height" .= h, "tx_hash" .= i] -txToJSON :: Tx -> Value-txToJSON = String . pack . bsToHex . encode'+-- | Bitcoin outpoint information.+data StratumCoin = StratumCoin+    { stratumCoinOutPoint  :: !OutPoint         -- ^ Coin data.+    , stratumCoinTxInfo    :: !StratumTxInfo    -- ^ Transaction information.+    , stratumCoinValue     :: !Word64           -- ^ Output vale.+    } deriving (Show, Eq) -txParse :: Value -> Parser Tx-txParse = withText "bitcoin transaction" $-    return . decode' . fromJust . hexToBS . unpack+instance NFData StratumCoin where+    rnf (StratumCoin o t v) = rnf o `seq` rnf t `seq` rnf v -txidParse :: Value -> Parser Hash256-txidParse = withText "transaction id" $-    return . fromJust . decodeTxid . unpack+instance FromJSON StratumCoin where+    parseJSON = withObject "coin" $ \o -> do+        h <- o .: "height"+        v <- o .: "value"+        p <- o .: "tx_pos"+        i <- o .: "tx_hash"+        return $ StratumCoin (OutPoint i p) (StratumTxInfo h i) v -hashToJSON :: Hash256 -> Value-hashToJSON = String . pack . bsToHex . encode'+instance ToJSON StratumCoin where+    toJSON (StratumCoin (OutPoint _ p) (StratumTxInfo h i) v) = object+        [ "height"   .= h+        , "value"    .= v+        , "tx_hash"  .= i+        , "tx_pos"   .= p ] -hashParse :: Value -> Parser Hash256-hashParse = withText "hash" $ return . decode' . fromJust . hexToBS . unpack