diff --git a/Network/Haskoin/Crypto.hs b/Network/Haskoin/Crypto.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto.hs @@ -0,0 +1,231 @@ +{-| + This package provides the elliptic curve cryptography required for creating + and validating bitcoin transactions. It also provides SHA-256 and RIPEMD-160 + hashing functions; as well as mnemonic keys from BIP-0039. +-} +module Network.Haskoin.Crypto +( + -- *Elliptic Curve Keys + + -- **Public Keys + PubKey(..) +, isValidPubKey +, isPubKeyU +, derivePubKey +, pubKeyAddr +, addPubKeys + + -- **Private Keys +, PrvKey(..) +, isValidPrvKey +, makePrvKey +, makePrvKeyU +, fromPrvKey +, isPrvKeyU +, addPrvKeys +, putPrvKey +, getPrvKey +, getPrvKeyU +, fromWIF +, toWIF + + -- *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 + -- . The + -- SecretT monad is used to generate random private keys and random nonces + -- for ECDSA signatures. +, SecretT +, withSource +, devURandom +, devRandom +, genPrvKey + + -- **Signatures + -- | Elliptic curve cryptography standards are defined in + -- +, Signature +, signMsg +, detSignMsg +, verifySig +, isCanonicalHalfOrder + + -- * Big words +, Word512 +, Word256 +, Word160 +, Word128 + + -- *Hash functions +, Hash512 +, Hash256 +, Hash160 +, CheckSum32 +, hash512 +, hash512BS +, hash256 +, hash256BS +, hash160 +, hash160BS +, doubleHash256 +, doubleHash256BS +, chksum32 +, hmac512 +, hmac512BS +, hmac256 +, hmac256BS +, split512 +, join512 +, murmurHash3 + + -- *Number representations +, decodeCompact +, encodeCompact + + -- *Base58 and Addresses +, Address(..) +, base58ToAddr +, addrToBase58 +, encodeBase58 +, decodeBase58 +, encodeBase58Check +, decodeBase58Check + + -- *Mnemonic keys (BIP-0039) +, WordList +, Entropy +, Mnemonic +, Passphrase +, Seed +, toMnemonic +, fromMnemonic +, mnemonicToSeed +, anyToSeed +, english + + -- *Extended Keys +, ChainCode + + -- **Extended Private Keys +, XPrvKey(..) +, makeXPrvKey +, xPrvIsPrime +, xPrvChild +, xPrvID +, xPrvFP +, xPrvExport +, xPrvImport +, xPrvWIF + + -- **Extended Public Keys +, XPubKey(..) +, deriveXPubKey +, xPubIsPrime +, xPubChild +, xPubID +, xPubFP +, xPubAddr +, xPubExport +, xPubImport + + -- **Child key derivations +, prvSubKey +, pubSubKey +, primeSubKey +, prvSubKeys +, pubSubKeys +, primeSubKeys + + -- ***Multisig derivations +, mulSigSubKey +, mulSigSubKeys + + -- *Derivation tree interoperability + + -- | To improve BIP32 wallet interoperability, a standard derivation tree + -- is used. All accounts are generated through prime derivations from the + -- master key. This ensures that the master key is not compromised if + -- an account is compromised. Every account will generate receiving + -- addresses from the non-prime subtree index 0 and internal change + -- addresses from the non-prime subtree index 1. MasterKey, AccountKey + -- and AddressKey types are defined to conform to the wallet interoperability + -- format. + +, KeyIndex + + -- **Master keys +, MasterKey(..) +, makeMasterKey +, loadMasterKey + + -- **Account keys +, AccPrvKey(..) +, AccPubKey(..) +, loadPrvAcc +, loadPubAcc +, accPrvKey +, accPubKey +, accPrvKeys +, accPubKeys + + -- **Address keys +, AddrPrvKey(..) +, AddrPubKey(..) +, addr +, extPrvKey +, extPubKey +, intPrvKey +, intPubKey +, extPrvKeys +, extPubKeys +, intPrvKeys +, intPubKeys +, extAddr +, intAddr +, extAddrs +, intAddrs +, extAddrs' +, intAddrs' + + -- ***Multisig address keys +, extMulSigKey +, intMulSigKey +, extMulSigKeys +, intMulSigKeys +, extMulSigAddr +, intMulSigAddr +, extMulSigAddrs +, intMulSigAddrs + + -- *Bloom filters +, BloomFilter +, BloomFlags(..) +, bloomCreate +, bloomInsert +, bloomContains +, bloomUpdateEmptyFull +, bloomIsValid + + -- *Partial merkle trees +, calcTreeHeight +, calcTreeWidth +, buildMerkleRoot +, calcHash +, buildPartialMerkle +, extractMatches + +) where + +import Network.Haskoin.Crypto.ECDSA +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.Base58 +import Network.Haskoin.Crypto.Mnemonic +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.ExtendedKeys +import Network.Haskoin.Crypto.NormalizedKeys +import Network.Haskoin.Crypto.Merkle +import Network.Haskoin.Crypto.Bloom + diff --git a/Network/Haskoin/Crypto/Base58.hs b/Network/Haskoin/Crypto/Base58.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Base58.hs @@ -0,0 +1,131 @@ +module Network.Haskoin.Crypto.Base58 +( Address(..) +, addrToBase58 +, base58ToAddr +, encodeBase58 +, decodeBase58 +, encodeBase58Check +, decodeBase58Check +) where + +import Control.Monad (guard) +import Control.Applicative ((<$>),(<*>)) + +import Data.Char (ord) +import Data.Word (Word8) +import Data.Maybe (fromJust) +import Data.Aeson + ( Value (String) + , FromJSON + , ToJSON + , parseJSON + , toJSON + , withText + ) + +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as M +import qualified Data.Text as T + +import Network.Haskoin.Crypto.Hash +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] + +b58 :: Word8 -> Word8 +b58 i = BS.index b58Data (fromIntegral i) + +b58' :: Word8 -> Maybe Word8 +b58' w = fromIntegral <$> M.lookup 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 + +-- | Encode a bytestring to a base 58 representation. +encodeBase58 :: BS.ByteString -> BS.ByteString +encodeBase58 bs = BS.append l r + where + (z,b) = BS.span (== 0) bs + l = BS.map b58 z -- preserve leading 0's + r | BS.null b = BS.empty + | otherwise = encodeBase58I $ bsToInteger b + +-- | Decode a base 58 encoded bytestring. This can fail if the input bytestring +-- contains invalid base 58 characters such as 0,O,l,I +decodeBase58 :: BS.ByteString -> Maybe BS.ByteString +decodeBase58 bs = r >>= return . (BS.append prefix) + where + (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 + +-- | Computes a checksum for the input bytestring and encodes the input and +-- the checksum to a base 58 representation. +encodeBase58Check :: BS.ByteString -> BS.ByteString +encodeBase58Check bs = encodeBase58 $ BS.append bs chk + where + chk = encode' $ chksum32 bs + +-- | Decode a base 58 encoded bytestring that contains a checksum. This +-- function returns Nothing if the input bytestring contains invalid base 58 +-- characters or if the checksum fails. +decodeBase58Check :: BS.ByteString -> Maybe BS.ByteString +decodeBase58Check bs = do + rs <- decodeBase58 bs + let (res,chk) = BS.splitAt ((BS.length rs) - 4) rs + guard $ chk == (encode' $ chksum32 res) + return res + +-- |Data type representing a Bitcoin address +data Address + -- | Public Key Hash Address + = PubKeyAddress { getAddrHash :: Hash160 } + -- | Script Hash Address + | ScriptAddress { getAddrHash :: Hash160 } + deriving (Eq, Show) + +instance FromJSON Address where + parseJSON = withText "Address not a string: " $ \a -> do + let s = T.unpack a + maybe (fail $ "Not a Bitcoin address: " ++ s) return $ base58ToAddr s + +instance ToJSON Address where + toJSON = String . T.pack . addrToBase58 + +-- | Transforms an Address into a base58 encoded String +addrToBase58 :: Address -> String +addrToBase58 addr = bsToString $ encodeBase58Check $ case addr of + PubKeyAddress i -> BS.cons addrPrefix $ encode' i + ScriptAddress i -> BS.cons scriptPrefix $ encode' i + +-- | Decodes an Address from a base58 encoded String. This function can fail +-- if the String is not properly encoded as base58 or the checksum fails. +base58ToAddr :: String -> Maybe Address +base58ToAddr str = do + val <- decodeBase58Check $ stringToBS str + let f | BS.head val == addrPrefix = Just PubKeyAddress + | BS.head val == scriptPrefix = Just ScriptAddress + | otherwise = Nothing + f <*> decodeToMaybe (BS.tail val) + diff --git a/Network/Haskoin/Crypto/BigWord.hs b/Network/Haskoin/Crypto/BigWord.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/BigWord.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +module Network.Haskoin.Crypto.BigWord +( +-- Useful type aliases + Hash512 +, Hash256 +, Hash160 +, Word512 +, Word256 +, Word160 +, Word128 +, FieldP +, FieldN + +-- Data types +, BigWord(..) +, BigWordMod(..) + +-- Functions +, toFieldN +, toFieldP +, toMod512 +, toMod256 +, toMod160 +, toMod128 +, inverseP +, inverseN +, quadraticResidue +, isIntegerValidKey +) where + +import Data.Bits + ( Bits + , (.&.), (.|.), xor + , complement + , shift, shiftL, shiftR + , bit, testBit, bitSize + , popCount, isSigned + ) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( getWord64be + , getWord32be + , getWord8 + , getByteString + , Get + ) +import Data.Binary.Put + ( putWord64be + , putWord32be + , putWord8 + , putByteString + ) +import Control.Monad (unless, guard) +import Control.Applicative ((<$>)) +import Data.Ratio (numerator, denominator) +import qualified Data.ByteString as BS (head, length) + +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Crypto.NumberTheory +import Network.Haskoin.Util + +-- | 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 +-- | Data type representing an Integer modulo coordinate field order P. +type FieldP = BigWord ModP +-- | Data type representing an Integer modulo curve order N. +type FieldN = BigWord ModN + +data Mod512 +data Mod256 +data Mod160 +data Mod128 +data ModP +data ModN + +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 + +inverseP :: FieldP -> FieldP +inverseP (BigWord i) = fromInteger $ mulInverse i curveP + +inverseN :: FieldN -> FieldN +inverseN (BigWord i) = fromInteger $ mulInverse i curveN + +class BigWordMod a where + rFromInteger :: Integer -> BigWord a + rBitSize :: BigWord a -> Int + +instance BigWordMod Mod512 where + rFromInteger i = BigWord $ i `mod` 2 ^ (512 :: Int) + rBitSize _ = 512 + +instance BigWordMod Mod256 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 + +instance BigWordMod Mod128 where + rFromInteger i = BigWord $ i `mod` 2 ^ (128 :: Int) + rBitSize _ = 128 + +instance BigWordMod ModP where + rFromInteger i = BigWord $ i `mod` curveP + rBitSize _ = 256 + +instance BigWordMod ModN where + rFromInteger i = BigWord $ i `mod` curveN + rBitSize _ = 256 + +instance BigWordMod n => Num (BigWord n) where + fromInteger = rFromInteger + (BigWord i1) + (BigWord i2) = fromInteger $ i1 + i2 + (BigWord i1) * (BigWord i2) = fromInteger $ i1 * i2 + negate (BigWord i) = fromInteger $ negate i + abs r = r + signum (BigWord i) = fromInteger $ signum i + +instance BigWordMod n => Bits (BigWord n) where + (BigWord i1) .&. (BigWord i2) = fromInteger $ i1 .&. i2 + (BigWord i1) .|. (BigWord i2) = fromInteger $ i1 .|. i2 + (BigWord i1) `xor` (BigWord i2) = fromInteger $ i1 `xor` i2 + complement (BigWord i) = fromInteger $ complement i + shift (BigWord i) j = fromInteger $ shift i j + bitSize = rBitSize + testBit (BigWord i) = testBit i + bit n = fromInteger $ bit n + popCount (BigWord i) = popCount i + isSigned _ = False + +instance BigWordMod n => Bounded (BigWord n) where + minBound = fromInteger 0 + maxBound = fromInteger (-1) + +instance BigWordMod n => Real (BigWord n) where + toRational (BigWord i) = toRational i + +instance BigWordMod n => Enum (BigWord n) where + succ r@(BigWord i) + | r == maxBound = error "BigWord: tried to take succ of maxBound" + | otherwise = fromInteger $ succ i + pred r@(BigWord i) + | r == minBound = error "BigWord: tried to take pred of minBound" + | otherwise = fromInteger $ pred i + toEnum i + | toInteger i >= toInteger (minFrom r) && + toInteger i <= toInteger (maxFrom r) = r + | otherwise = error "BigWord: toEnum is outside of bounds" + where + r = fromInteger $ toEnum i + minFrom :: BigWordMod a => BigWord a -> BigWord a + minFrom _ = minBound + maxFrom :: BigWordMod a => BigWord a -> BigWord a + maxFrom _ = maxBound + fromEnum (BigWord i) = fromEnum i + +instance BigWordMod n => Integral (BigWord n) where + (BigWord i1) `quot` (BigWord i2) = fromInteger $ i1 `quot` i2 + (BigWord i1) `rem` (BigWord i2) = fromInteger $ i1 `rem` i2 + (BigWord i1) `div` (BigWord i2) = fromInteger $ i1 `div` i2 + (BigWord i1) `mod` (BigWord i2) = fromInteger $ i1 `mod` i2 + (BigWord i1) `quotRem` (BigWord i2) = (fromInteger a, fromInteger b) + where + (a,b) = i1 `quotRem` i2 + (BigWord i1) `divMod` (BigWord i2) = (fromInteger a, fromInteger b) + where + (a,b) = i1 `divMod` i2 + toInteger (BigWord i) = i + +{- Fractional is only defined for prime orders -} + +instance Fractional (BigWord ModP) where + recip = inverseP + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + +instance Fractional (BigWord ModN) where + recip = inverseN + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + +{- Binary instances for serialization / deserialization -} + +instance Binary (BigWord Mod512) where + get = do + a <- fromIntegral <$> (get :: Get Hash256) + b <- fromIntegral <$> (get :: Get Hash256) + return $ (a `shiftL` 256) + b + + put (BigWord i) = do + put $ (fromIntegral (i `shiftR` 256) :: Hash256) + put $ (fromIntegral i :: Hash256) + +instance Binary (BigWord Mod256) 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 + b <- fromIntegral <$> getWord64be + c <- fromIntegral <$> getWord64be + return $ (a `shiftL` 128) + (b `shiftL` 64) + c + + put (BigWord i) = do + putWord32be $ fromIntegral (i `shiftR` 128) + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i + +instance Binary (BigWord Mod128) where + get = do + a <- fromIntegral <$> getWord64be + b <- fromIntegral <$> getWord64be + return $ (a `shiftL` 64) + b + + put (BigWord i) = do + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i + +-- DER encoding of a FieldN element as Integer +-- http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf +instance Binary (BigWord ModN) where + get = do + t <- getWord8 + 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) + return $ fromInteger i + + put (BigWord 0) = error "0 is an invalid FieldN element to serialize" + put (BigWord i) = do + putWord8 0x02 -- Integer type + let b = integerToBS i + l = fromIntegral $ BS.length b + if BS.head b >= 0x80 + then do + putWord8 (l + 1) + putWord8 0x00 + else do + putWord8 l + putByteString b + +instance Binary (BigWord ModP) where + + -- Section 2.3.6 http://www.secg.org/download/aid-780/sec1-v2.pdf + get = do + (BigWord i) <- get :: Get Hash256 + 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 + + +-- curveP = 3 (mod 4), thus Lagrange solutions apply +-- http://en.wikipedia.org/wiki/Quadratic_residue +quadraticResidue :: FieldP -> [FieldP] +quadraticResidue x = guard (y^(2 :: Int) == x) >> [y, (-y)] + where + q = (curveP + 1) `div` 4 + y = x^q + +isIntegerValidKey :: Integer -> Bool +isIntegerValidKey i = i > 0 && i < curveN + diff --git a/Network/Haskoin/Crypto/Bloom.hs b/Network/Haskoin/Crypto/Bloom.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Bloom.hs @@ -0,0 +1,108 @@ +module Network.Haskoin.Crypto.Bloom +( BloomFilter(..) +, BloomFlags(..) +, bloomCreate +, bloomInsert +, bloomContains +, bloomUpdateEmptyFull +, bloomIsValid +) where + +import Data.Word +import Data.Bits +import qualified Data.Foldable as F +import qualified Data.Sequence as S +import qualified Data.ByteString as BS + +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Protocol + +-- 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001% +maxBloomSize :: Int +maxBloomSize = 36000 + +maxHashFuncs :: Word32 +maxHashFuncs = 50 + +ln2Squared :: Double +ln2Squared = 0.4804530139182014246671025263266649717305529515945455 + +ln2 :: Double +ln2 = 0.6931471805599453094172321214581765680755001343602552 + +bitMask :: [Word8] +bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80] + +-- | Build a bloom filter that will provide the given false positive rate when +-- the given number of elements have been inserted. +bloomCreate :: Int -- ^ Number of elements + -> Double -- ^ False positive rate + -> Word32 + -- ^ A random nonce (tweak) for the hash function. It should be + -- a random number but the secureness of the random value is not + -- of geat consequence. + -> BloomFlags -- ^ Bloom filter flags + -> BloomFilter -- ^ Bloom filter +bloomCreate numElem fpRate tweak flags = + BloomFilter (S.replicate bloomSize 0) False False numHashF tweak flags + where + bloomSize = truncate $ (min a b) / 8 + a = -1 / ln2Squared * (fromIntegral numElem) * log fpRate + b = fromIntegral $ maxBloomSize * 8 + numHashF = truncate $ min c (fromIntegral maxHashFuncs) + c = (fromIntegral bloomSize) * 8 / (fromIntegral numElem) * ln2 + +bloomHash :: BloomFilter -> Word32 -> BS.ByteString -> Int +bloomHash bfilter hashNum bs = + fromIntegral (murmurHash3 seed bs) `mod` (S.length (bloomData bfilter) * 8) + where + seed = hashNum * 0xfba4c795 + (bloomTweak bfilter) + +-- | Insert arbitrary data into a bloom filter. Returns the new bloom filter +-- containing the new data. +bloomInsert :: BloomFilter -- ^ Original bloom filter + -> 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 } + where + idxs = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter - 1] + upd s i = S.adjust (.|. bitMask !! (7 .&. i)) (i `shiftR` 3) s + newData = foldl upd (bloomData bfilter) idxs + +-- | Tests if some arbitrary data matches the filter. This can be either because +-- the data was inserted into the filter or because it is a false positive. +bloomContains :: BloomFilter -- ^ Bloom filter + -> BS.ByteString + -- ^ Data that will be checked against the given bloom filter + -> Bool + -- ^ Returns True if the data matches the filter +bloomContains bfilter bs + | bloomFull bfilter = True + | bloomEmpty bfilter = False + | otherwise = and $ map isSet idxs + where + s = bloomData bfilter + idxs = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter - 1] + isSet i = (S.index s (i `shiftR` 3)) .&. (bitMask !! (7 .&. i)) /= 0 + +-- 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 + +-- | Tests if a given bloom filter is valid. +bloomIsValid :: BloomFilter -- ^ Bloom filter to test + -> Bool -- ^ True if the given filter is valid +bloomIsValid bfilter = + (S.length $ bloomData bfilter) <= maxBloomSize && + (bloomHashFuncs bfilter) <= maxHashFuncs + diff --git a/Network/Haskoin/Crypto/Curve.hs b/Network/Haskoin/Crypto/Curve.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Curve.hs @@ -0,0 +1,27 @@ +module Network.Haskoin.Crypto.Curve +( pairG +, curveP +, curveN +, integerB +, integerA +) where + +-- SECP256k1 curve parameters + +pairG :: (Integer, Integer) +pairG = ( 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 + , 0X483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 + ) + +curveP :: Integer +curveP = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f + +curveN :: Integer +curveN = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 + +integerB :: Integer +integerB = 7 + +integerA :: Integer +integerA = 0 + diff --git a/Network/Haskoin/Crypto/ECDSA.hs b/Network/Haskoin/Crypto/ECDSA.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/ECDSA.hs @@ -0,0 +1,214 @@ +-- | ECDSA Signatures +module Network.Haskoin.Crypto.ECDSA +( SecretT +, Signature(..) +, withSource +, devURandom +, devRandom +, signMsg +, detSignMsg +, unsafeSignMsg +, verifySig +, genPrvKey +, isCanonicalHalfOrder +) where + +import System.IO + +import Control.Monad (liftM, guard, unless) +import Control.Monad.Trans (MonadTrans, lift) +import Control.Applicative (Applicative, (<*>), (<$>)) +import qualified Control.Monad.State as S + ( StateT + , evalStateT + , get, put + ) + +import Data.Maybe (fromJust, fromMaybe) +import Data.Binary (Binary, get, put) +import Data.Binary.Put (putWord8, putByteString) +import Data.Binary.Get (getWord8) + +import qualified Data.ByteString as BS + ( ByteString + , length + , hGet + , empty + ) + +import Network.Haskoin.Util +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.Point +import Network.Haskoin.Crypto.BigWord + +-- | Internal state of the 'SecretT' monad +type SecretState m = (WorkingState, (Int -> m BS.ByteString)) + +-- | 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 + +-- | Run a 'SecretT' monad by providing it a source of entropy. You can +-- use 'devURandom', 'devRandom' or provide your own entropy source function. +withSource :: Monad m => (Int -> m BS.ByteString) -> SecretT m a -> m a +withSource f m = do + seed <- f 32 -- Read 256 bits from the random source + nonce <- f 16 -- Read 128 bits from the random source + let ws = hmacDRBGNew seed nonce (stringToBS haskoinUserAgent) + S.evalStateT m (ws,f) + +-- | \/dev\/urandom entropy source. This is only available on machines +-- supporting it. This function is meant to be used together with 'withSource'. +devURandom :: Int -> IO BS.ByteString +devURandom i = withBinaryFile "/dev/urandom" ReadMode $ flip BS.hGet i + +-- | \/dev\/random entropy source. This is only available on machines +-- supporting it. This function is meant to be used together with 'withSource'. +devRandom :: Int -> IO BS.ByteString +devRandom i = withBinaryFile "/dev/random" ReadMode $ flip BS.hGet i + +-- | Generate a new random 'FieldN' value from the 'SecretT' monad. This will +-- invoke the HMAC DRBG routine. Of the internal entropy pool of the HMAC DRBG +-- was stretched too much, this function will reseed it. +nextSecret :: Monad m => SecretT m FieldN +nextSecret = do + (ws,f) <- S.get + let (ws',randM) = hmacDRBGGen ws 32 (stringToBS haskoinUserAgent) + case randM of + (Just rand) -> do + S.put (ws',f) + let randI = bsToInteger rand + if isIntegerValidKey randI + then return $ fromInteger randI + else nextSecret + Nothing -> do + seed <- lift $ f 32 -- Read 256 bits to re-seed the PRNG + let ws0 = hmacDRBGRsd ws' seed (stringToBS haskoinUserAgent) + S.put (ws0,f) + nextSecret + +-- | Produce a new 'PrvKey' randomly from the 'SecretT' monad. +genPrvKey :: Monad m => SecretT m PrvKey +genPrvKey = liftM (fromJust . makePrvKey . toInteger) nextSecret + +-- Section 3.2.1 http://www.secg.org/download/aid-780/sec1-v2.pdf +-- Produce a new private/public key pair from the 'SecretT' monad. +genKeyPair :: Monad m => SecretT m (FieldN, Point) +genKeyPair = do + -- 3.2.1.1 + d <- nextSecret + -- 3.2.1.2 + let q = mulPoint d curveG + -- 3.2.1.3 + return (d,q) + +-- | Data type representing an ECDSA signature. +data Signature = + Signature { sigR :: !FieldN + , sigS :: !FieldN + } + deriving (Show, Eq) + +-- 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 _ (PrvKey 0) = error "signMsg: Invalid private key 0" +signMsg _ (PrvKeyU 0) = error "signMsg: Invalid private key 0" +signMsg h d = do + -- 4.1.3.1 + (k,p) <- genKeyPair + case unsafeSignMsg h (prvKeyFieldN d) (k,p) of + (Just sig) -> return sig + -- If signing failed, retry with a new nonce + Nothing -> signMsg h d + +-- | Sign a message using ECDSA deterministic signatures as defined by +-- RFC 6979 +detSignMsg :: Hash256 -> 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 + where + go ws = case hmacDRBGGen ws 32 BS.empty of + (_, Nothing) -> error "detSignMsg: No suitable K value found" + (ws', Just k) -> + let kI = bsToInteger k + p = mulPoint (fromInteger kI) curveG + sigM = unsafeSignMsg h (prvKeyFieldN d) (fromInteger kI,p) + in if isIntegerValidKey kI + then fromMaybe (go ws') sigM + else go ws' + +-- Signs a message by providing the nonce +-- 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 _ 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 + guard (r /= 0) + -- 4.1.3.4 / 4.1.3.5 + let e = toFieldN h + -- 4.1.3.6 + let s' = (e + r*d)/k + -- Canonicalize signatures: s <= order/2 + -- maxBound/2 = (maxBound+1)/2 = order/2 (because order is odd) + s = if s' > (maxBound `div` 2) then (-s') else s' + guard (s /= 0) + -- 4.1.3.7 + return $ Signature r s + +-- Section 4.1.4 http://www.secg.org/download/aid-780/sec1-v2.pdf +-- | Verify an ECDSA signature +verifySig :: Hash256 -> 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 + where + -- 4.1.4.2 / 4.1.4.3 + e = toFieldN h + -- 4.1.4.4 + s' = inverseN s + u1 = e*s' + u2 = r*s' + -- 4.1.4.5 (u1*G + u2*q) + p = shamirsTrick u1 curveG u2 (pubKeyPoint q) + +-- | Returns True if the S component of a Signature is <= order/2. +-- Signatures need to pass this test to be canonical. +isCanonicalHalfOrder :: Signature -> Bool +isCanonicalHalfOrder (Signature _ s) = s <= maxBound `div` 2 + +instance Binary Signature where + get = do + t <- getWord8 + -- 0x30 is DER sequence type + unless (t == 0x30) (fail $ + "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 + + put (Signature 0 _) = error "0 is an invalid r value in a Signature" + put (Signature _ 0) = error "0 is an invalid s value in a Signature" + put (Signature r s) = do + putWord8 0x30 + let c = runPut' $ put r >> put s + putWord8 (fromIntegral $ BS.length c) + putByteString c + + diff --git a/Network/Haskoin/Crypto/ExtendedKeys.hs b/Network/Haskoin/Crypto/ExtendedKeys.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/ExtendedKeys.hs @@ -0,0 +1,323 @@ +module Network.Haskoin.Crypto.ExtendedKeys +( XPubKey(..) +, XPrvKey(..) +, ChainCode +, makeXPrvKey +, deriveXPubKey +, prvSubKey +, pubSubKey +, primeSubKey +, prvSubKeys +, pubSubKeys +, primeSubKeys +, mulSigSubKey +, mulSigSubKeys +, xPrvIsPrime +, xPubIsPrime +, xPrvChild +, xPubChild +, xPubID +, xPrvID +, xPubFP +, xPrvFP +, xPubAddr +, xPubExport +, xPrvExport +, xPubImport +, xPrvImport +, xPrvWIF +, cycleIndex +, cycleIndex' +) where + +import Control.Monad + ( guard + , unless + , when + , liftM2 + ) +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.Maybe (mapMaybe) +import qualified Data.ByteString as BS + ( ByteString + , append + ) + +import Network.Haskoin.Util +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.Base58 + +{- See BIP32 for details: https://en.bitcoin.it/wiki/BIP_0032 -} + +type ChainCode = Hash256 + +-- | 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 +-- parent node and an index to differentiate it from other siblings. +data XPrvKey = XPrvKey + { xPrvDepth :: !Word8 -- ^ Depth in the tree of key derivations. + , xPrvParent :: !Word32 -- ^ Fingerprint of the parent key. + , xPrvIndex :: !Word32 -- ^ Key derivation index. + , xPrvChain :: !ChainCode -- ^ Chain code. + , xPrvKey :: !PrvKey -- ^ The private key of this extended key node. + } deriving (Eq, Show, Read) + +-- | Data type representing an extended BIP32 public key. +data XPubKey = XPubKey + { xPubDepth :: !Word8 -- ^ Depth in the tree of key derivations. + , xPubParent :: !Word32 -- ^ Fingerprint of the parent key. + , xPubIndex :: !Word32 -- ^ Key derivation index. + , xPubChain :: !ChainCode -- ^ Chain code. + , xPubKey :: !PubKey -- ^ The public key of this extended key node. + } deriving (Eq, Show, Read) + +-- | 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 +makeXPrvKey bs = do + pk' <- makePrvKey $ fromIntegral pk + return $ XPrvKey 0 0 0 c pk' + where (pk,c) = split512 $ hmac512 (stringToBS "Bitcoin seed") bs + +-- | Derive an extended public key from an extended private key. This function +-- will preserve the depth, parent, index and chaincode fields of the extended +-- private keys. +deriveXPubKey :: XPrvKey -> XPubKey +deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k) + +-- | Compute a private, non-prime child key derivation. A private non-prime +-- derivation will allow the equivalent extended public key to derive the +-- public key for this child. Given a parent key /m/ and a derivation index /i/, +-- this function will compute m\/i\/. +-- +-- Non-prime derivations allow for more flexibility such as read-only wallets. +-- However, care must be taken not the leak both the parent extended public +-- key and one of the extended child private keys as this would compromise the +-- extended parent private key. +prvSubKey :: XPrvKey -- ^ Extended parent private key + -> Word32 -- ^ Child derivation index + -> Maybe XPrvKey -- ^ Extended child private key +prvSubKey xkey child = guardIndex child >> do + k <- addPrvKeys (xPrvKey xkey) a + return $ XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k + where pK = xPubKey $ deriveXPubKey xkey + msg = BS.append (encode' pK) (encode' child) + (a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg + +-- | Compute a public, non-prime child key derivation. Given a parent key /M/ +-- and a derivation index /i/, this function will compute M\/i\/. +pubSubKey :: XPubKey -- ^ Extended Parent public key + -> Word32 -- ^ Child derivation index + -> Maybe XPubKey -- ^ Extended child public key +pubSubKey xKey child = guardIndex child >> do + pK <- addPubKeys (xPubKey xKey) a + return $ XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK + where msg = BS.append (encode' $ xPubKey xKey) (encode' child) + (a,c) = split512 $ hmac512 (encode' $ xPubChain xKey) msg + +-- | Compute a prime child key derivation. Prime derivations can only be +-- computed for private keys. Prime derivations do not allow the parent +-- public key to derive the child public keys. However, they are safer as +-- a breach of the parent public key and child private keys does not lead +-- to a breach of the parent private key. Given a parent key /m/ and a +-- derivation index /i/, this function will compute m\/i'\/. +primeSubKey :: XPrvKey -- ^ Extended Parent private key + -> Word32 -- ^ Child derivation index + -> Maybe XPrvKey -- ^ Extended child private key +primeSubKey xkey child = guardIndex child >> do + k <- addPrvKeys (xPrvKey xkey) a + return $ XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k + where i = setBit child 31 + msg = BS.append (bsPadPrvKey $ xPrvKey xkey) (encode' i) + (a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg + +-- | Cyclic list of all private non-prime child key derivations of a parent key +-- starting from an offset index. +prvSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)] +prvSubKeys k i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (prvSubKey k j) (return j) + +-- | Cyclic list of all public non-prime child key derivations of a parent key +-- starting from an offset index. +pubSubKeys :: XPubKey -> Word32 -> [(XPubKey,Word32)] +pubSubKeys k i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (pubSubKey k j) (return j) + +-- | Cyclic list of all prime child key derivations of a parent key starting +-- from an offset index. +primeSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)] +primeSubKeys k i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (primeSubKey k j) (return j) + +-- | Compute a public, non-prime subkey derivation for all of the parent public +-- keys in the input. This function will succeed only if the child key +-- derivations for all the parent keys are valid. +-- +-- This function is intended to be used in the context of multisignature +-- accounts. Parties exchanging their master public keys to create a +-- multisignature account can then individually generate all the receiving +-- multisignature addresses without further communication. +mulSigSubKey :: [XPubKey] -- ^ List of extended parent public keys + -> Word32 -- ^ Child key derivation index + -> Maybe [XPubKey] -- ^ List of extended child public keys +mulSigSubKey pubs i = mapM (flip pubSubKey i) pubs + +-- | Cyclic list of all public, non-prime multisig key derivations of a list +-- of parent keys starting from an offset index. +mulSigSubKeys :: [XPubKey] -> Word32 -> [([XPubKey],Word32)] +mulSigSubKeys pubs i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (mulSigSubKey pubs j) (return j) + +cycleIndex :: Word32 -> [Word32] +cycleIndex i + | i == 0 = cycle [0..0x7fffffff] + | i < 0x80000000 = cycle $ [i..0x7fffffff] ++ [0..(i-1)] + | otherwise = error $ "cycleIndex: invalid index " ++ (show i) + +-- Cycle in reverse +cycleIndex' :: Word32 -> [Word32] +cycleIndex' i + | i == 0 = cycle $ 0 : [0x7fffffff,0x7ffffffe..1] + | i == 0x7fffffff = cycle [0x7fffffff,0x7ffffffe..0] + | i == 0x7ffffffe = cycle $ [0x7ffffffe,0x7ffffffd..0] ++ [0x7fffffff] + | i < 0x80000000 = cycle $ [i,(i-1)..0] ++ [0x7fffffff,0x7ffffffe..(i+1)] + | otherwise = error $ "cycleIndex: invalid index " ++ (show i) + +guardIndex :: Word32 -> Maybe () +guardIndex child = guard $ child >= 0 && child < 0x80000000 + +-- | Returns True if the extended private key was derived through a prime +-- derivation. +xPrvIsPrime :: XPrvKey -> Bool +xPrvIsPrime k = testBit (xPrvIndex k) 31 + +-- | Returns True if the extended public key was derived through a prime +-- derivation. +xPubIsPrime :: XPubKey -> Bool +xPubIsPrime k = testBit (xPubIndex k) 31 + +-- | Returns the derivation index of this extended private key without the +-- prime bit set. +xPrvChild :: XPrvKey -> Word32 +xPrvChild k = clearBit (xPrvIndex k) 31 + +-- | Returns the derivation index of this extended public key without the prime +-- bit set. +xPubChild :: XPubKey -> Word32 +xPubChild k = clearBit (xPubIndex k) 31 + +-- | Computes the key identifier of an extended private key. +xPrvID :: XPrvKey -> Hash160 +xPrvID = xPubID . deriveXPubKey + +-- | Computes the key identifier of an extended public key. +xPubID :: XPubKey -> Hash160 +xPubID = hash160 . hash256BS . encode' . xPubKey + +-- | Computes the key fingerprint of an extended private key. +xPrvFP :: XPrvKey -> Word32 +xPrvFP = fromIntegral . (`shiftR` 128) . xPrvID + +-- | Computes the key fingerprint of an extended public key. +xPubFP :: XPubKey -> Word32 +xPubFP = fromIntegral . (`shiftR` 128) . xPubID + +-- | Computer the 'Address' of an extended public key. +xPubAddr :: XPubKey -> Address +xPubAddr = pubKeyAddr . xPubKey + +-- | Exports an extended private key to the BIP32 key export format (base 58). +xPrvExport :: XPrvKey -> String +xPrvExport = bsToString . encodeBase58Check . encode' + +-- | Exports an extended public key to the BIP32 key export format (base 58). +xPubExport :: XPubKey -> String +xPubExport = bsToString . encodeBase58Check . encode' + +-- | Decodes a BIP32 encoded extended private key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. +xPrvImport :: String -> Maybe XPrvKey +xPrvImport str = decodeToMaybe =<< (decodeBase58Check $ stringToBS str) + +-- | Decodes a BIP32 encoded extended public key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. +xPubImport :: String -> Maybe XPubKey +xPubImport str = decodeToMaybe =<< (decodeBase58Check $ stringToBS str) + +-- | Export an extended private key to WIF (Wallet Import Format). +xPrvWIF :: XPrvKey -> String +xPrvWIF = toWIF . xPrvKey + +instance Binary XPrvKey where + + get = do + ver <- getWord32be + unless (ver == extSecretPrefix) $ fail $ + "Get: Invalid version for extended private key" + dep <- getWord8 + par <- getWord32be + idx <- getWord32be + chn <- get + prv <- getPadPrvKey + return $ XPrvKey dep par idx chn prv + + put k = do + putWord32be extSecretPrefix + putWord8 $ xPrvDepth k + putWord32be $ xPrvParent k + putWord32be $ xPrvIndex k + put $ xPrvChain k + putPadPrvKey $ xPrvKey k + +instance Binary XPubKey where + + get = do + ver <- getWord32be + unless (ver == extPubKeyPrefix) $ fail $ + "Get: Invalid version for extended public key" + dep <- getWord8 + par <- getWord32be + idx <- getWord32be + chn <- get + pub <- get + when (isPubKeyU pub) $ fail $ + "Invalid public key. Only compressed format is supported" + return $ XPubKey dep par idx chn pub + + put k = do + putWord32be extPubKeyPrefix + putWord8 $ xPubDepth k + putWord32be $ xPubParent k + putWord32be $ xPubIndex k + put $ xPubChain k + when (isPubKeyU (xPubKey k)) $ fail $ + "Only compressed public keys are supported" + put $ xPubKey k + +{- Utilities for extended keys -} + +-- De-serialize HDW-specific private key +getPadPrvKey :: Get PrvKey +getPadPrvKey = do + pad <- getWord8 + unless (pad == 0x00) $ fail $ + "Private key must be padded with 0x00" + getPrvKey -- Compressed version + +-- Serialize HDW-specific private key +putPadPrvKey :: PrvKey -> Put +putPadPrvKey p = putWord8 0x00 >> putPrvKey p + +bsPadPrvKey :: PrvKey -> BS.ByteString +bsPadPrvKey = toStrictBS . runPut . putPadPrvKey + diff --git a/Network/Haskoin/Crypto/Hash.hs b/Network/Haskoin/Crypto/Hash.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Hash.hs @@ -0,0 +1,300 @@ +-- | Hashing functions and HMAC DRBG definition +module Network.Haskoin.Crypto.Hash +( Hash512 +, Hash256 +, Hash160 +, CheckSum32 +, hash512 +, hash256 +, hash160 +, hash512BS +, hash256BS +, hash160BS +, doubleHash256 +, doubleHash256BS +, chksum32 +, hmac512 +, hmac512BS +, hmac256 +, hmac256BS +, hmacDRBGNew +, hmacDRBGUpd +, hmacDRBGRsd +, hmacDRBGGen +, WorkingState +, murmurHash3 +, split512 +, join512 +, decodeCompact +, encodeCompact +) where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) + +import Crypto.Hash + ( Digest + , SHA512 + , SHA256 + , RIPEMD160 + , hash + ) +import Crypto.MAC.HMAC (hmac) + +import Data.Word (Word16, Word32) +import Data.Byteable (toBytes) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord32le) +import Data.Bits + ( shiftL + , shiftR + , rotateL + , xor + , (.&.), (.|.) + ) + +import qualified Data.ByteString as BS + ( ByteString + , null + , append + , cons + , concat + , take + , empty + , length + , replicate + , drop + ) + +import Network.Haskoin.Util +import Network.Haskoin.Crypto.BigWord + +-- | Data type representing a 32 bit checksum +newtype CheckSum32 = CheckSum32 Word32 deriving (Show, Eq, Read) + +instance Binary CheckSum32 where + get = CheckSum32 <$> get + put (CheckSum32 w) = put w + +run512 :: BS.ByteString -> BS.ByteString +run512 = (toBytes :: Digest SHA512 -> BS.ByteString) . hash + +run256 :: BS.ByteString -> BS.ByteString +run256 = (toBytes :: Digest SHA256 -> BS.ByteString) . hash + +run160 :: BS.ByteString -> BS.ByteString +run160 = (toBytes :: Digest RIPEMD160 -> BS.ByteString) . hash + +-- | Computes SHA-512. +hash512 :: BS.ByteString -> Hash512 +hash512 bs = runGet' get (run512 bs) + +-- | Computes SHA-512 and returns the result as a bytestring. +hash512BS :: BS.ByteString -> BS.ByteString +hash512BS bs = run512 bs + +-- | Computes SHA-256. +hash256 :: BS.ByteString -> Hash256 +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 RIPEMD-160. +hash160 :: BS.ByteString -> Hash160 +hash160 bs = runGet' get (run160 bs) + +-- | Computes RIPEMD-160 and returns the result as a bytestring. +hash160BS :: BS.ByteString -> BS.ByteString +hash160BS bs = run160 bs + +-- | Computes two rounds of SHA-256. +doubleHash256 :: BS.ByteString -> Hash256 +doubleHash256 bs = runGet' get (run256 $ run256 bs) + +-- | Computes two rounds of SHA-256 and returns the result as a bytestring. +doubleHash256BS :: BS.ByteString -> BS.ByteString +doubleHash256BS bs = run256 $ run256 bs + +{- CheckSum -} + +-- | Computes a 32 bit checksum. +chksum32 :: BS.ByteString -> CheckSum32 +chksum32 bs = CheckSum32 $ fromIntegral $ (doubleHash256 bs) `shiftR` 224 + +{- HMAC -} + +-- | Computes HMAC over SHA-512. +hmac512 :: BS.ByteString -> BS.ByteString -> Hash512 +hmac512 key = decode' . (hmac512BS key) + +-- | Computes HMAC over SHA-512 and return the result as a bytestring. +hmac512BS :: BS.ByteString -> BS.ByteString -> BS.ByteString +hmac512BS key msg = hmac hash512BS 128 key msg + +-- | Computes HMAC over SHA-256. +hmac256 :: BS.ByteString -> BS.ByteString -> Hash256 +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) +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) + +-- | Decode the compact number used in the difficulty target of a block into an +-- Integer. +-- +-- As described in the Satoshi reference implementation /src/bignum.h: +-- +-- The "compact" format is a representation of a whole number N using an +-- unsigned 32bit number similar to a floating point format. The most +-- significant 8 bits are the unsigned exponent of base 256. This exponent can +-- be thought of as "number of bytes of N". The lower 23 bits are the mantissa. +-- Bit number 24 (0x800000) represents the sign of N. +-- +-- > N = (-1^sign) * mantissa * 256^(exponent-3) +decodeCompact :: Word32 -> Integer +decodeCompact c = + if neg then (-res) else res + where + size = fromIntegral $ c `shiftR` 24 + neg = (c .&. 0x00800000) /= 0 + wrd = c .&. 0x007fffff + res | size <= 3 = (toInteger wrd) `shiftR` (8*(3 - size)) + | otherwise = (toInteger wrd) `shiftL` (8*(size - 3)) + +-- | Encode an Integer to the compact number format used in the difficulty +-- target of a block. +encodeCompact :: Integer -> Word32 +encodeCompact i + | i < 0 = c3 .|. 0x00800000 + | otherwise = c3 + where + posi = abs i + s1 = BS.length $ integerToBS posi + c1 | s1 < 3 = posi `shiftL` (8*(3 - s1)) + | otherwise = posi `shiftR` (8*(s1 - 3)) + (s2,c2) | c1 .&. 0x00800000 /= 0 = (s1 + 1, c1 `shiftR` 8) + | otherwise = (s1, c1) + c3 = fromIntegral $ c2 .|. ((toInteger s2) `shiftL` 24) + +{- 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) +-} + +type WorkingState = (BS.ByteString, BS.ByteString, Word16) +type AdditionalInput = BS.ByteString +type ProvidedData = BS.ByteString +type EntropyInput = BS.ByteString +type Nonce = BS.ByteString +type PersString = BS.ByteString + +-- 10.1.2.2 HMAC DRBG Update FUnction +hmacDRBGUpd :: ProvidedData -> BS.ByteString -> BS.ByteString + -> (BS.ByteString, BS.ByteString) +hmacDRBGUpd info k0 v0 + | BS.null info = (k1,v1) -- 10.1.2.2.3 + | otherwise = (k2,v2) -- 10.1.2.2.6 + where + k1 = hmac256BS k0 $ v0 `BS.append` (0 `BS.cons` info) -- 10.1.2.2.1 + v1 = hmac256BS k1 v0 -- 10.1.2.2.2 + k2 = hmac256BS k1 $ v1 `BS.append` (1 `BS.cons` info) -- 10.1.2.2.4 + v2 = hmac256BS k2 v1 -- 10.1.2.2.5 + +-- 10.1.2.3 HMAC DRBG Instantiation +hmacDRBGNew :: EntropyInput -> Nonce -> PersString -> WorkingState +hmacDRBGNew seed nonce info + | (BS.length seed + BS.length nonce) * 8 < 384 = error $ + "Entropy + nonce input length must be at least 384 bit" + | (BS.length seed + BS.length nonce) * 8 > 1000 = error $ + "Entropy + nonce input length can not be greater than 1000 bit" + | BS.length info * 8 > 256 = error $ + "Maximum personalization string length is 256 bit" + | otherwise = (k1,v1,1) -- 10.1.2.3.6 + where + s = BS.concat [seed, nonce, info] -- 10.1.2.3.1 + k0 = BS.replicate 32 0 -- 10.1.2.3.2 + v0 = BS.replicate 32 1 -- 10.1.2.3.3 + (k1,v1) = hmacDRBGUpd s k0 v0 -- 10.1.2.3.4 + +-- 10.1.2.4 HMAC DRBG Reseeding +hmacDRBGRsd :: WorkingState -> EntropyInput -> AdditionalInput -> WorkingState +hmacDRBGRsd (k,v,_) seed info + | BS.length seed * 8 < 256 = error $ + "Entropy input length must be at least 256 bit" + | BS.length seed * 8 > 1000 = error $ + "Entropy input length can not be greater than 1000 bit" + | otherwise = (k0,v0,1) -- 10.1.2.4.4 + where + s = seed `BS.append` info -- 10.1.2.4.1 + (k0,v0) = hmacDRBGUpd s k v -- 10.1.2.4.2 + +-- 10.1.2.5 HMAC DRBG Generation +hmacDRBGGen :: WorkingState -> Word16 -> AdditionalInput + -> (WorkingState, Maybe BS.ByteString) +hmacDRBGGen (k0,v0,c0) bytes info + | bytes * 8 > 7500 = error "Maximum bits per request is 7500" + | c0 > 10000 = ((k0,v0,c0), Nothing) -- 10.1.2.5.1 + | otherwise = ((k2,v3,c1), Just res) -- 10.1.2.5.8 + where + (k1,v1) | BS.null info = (k0,v0) + | otherwise = hmacDRBGUpd info k0 v0 -- 10.1.2.5.2 + (tmp,v2) = go (fromIntegral bytes) k1 v1 BS.empty -- 10.1.2.5.3/4 + res = BS.take (fromIntegral bytes) tmp -- 10.1.2.5.5 + (k2,v3) = hmacDRBGUpd info k1 v2 -- 10.1.2.5.6 + c1 = c0 + 1 -- 10.1.2.5.7 + go l k v acc | BS.length acc >= l = (acc,v) + | otherwise = let vn = hmac256BS k v + in go l k vn (acc `BS.append` vn) + +{- MurmurHash3 -} + +-- | MurmurHash3 (x86_32). For more details, see +-- 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 + where + -- Block and tail sizes + nBlocks = BS.length bs `div` 4 + nTail = BS.length bs `mod` 4 + -- Data objects + blocks = runGet' (replicateM nBlocks getWord32le) bs + bsTail = BS.drop (nBlocks*4) bs `BS.append` BS.replicate (4-nTail) 0 + -- Body + h1 = foldl mix nHashSeed blocks + -- Tail + t1 = runGet' getWord32le bsTail + t2 = t1 * c1 + t3 = t2 `rotateL` 15 + t4 = t3 * c2 + h2 = h1 `xor` t4 + -- Finalization + h3 = h2 `xor` (fromIntegral $ BS.length bs) + h4 = h3 `xor` (h3 `shiftR` 16) + h5 = h4 * 0x85ebca6b + h6 = h5 `xor` (h5 `shiftR` 13) + h7 = h6 * 0xc2b2ae35 + h8 = h7 `xor` (h7 `shiftR` 16) + -- Mix function + mix r1 k1 = r4 + where + k2 = k1 * c1 + k3 = k2 `rotateL` 15 + k4 = k3 * c2 + r2 = r1 `xor` k4 + r3 = r2 `rotateL` 13 + r4 = r3*5 + 0xe6546b64 + -- Constants + c1 = 0xcc9e2d51 + c2 = 0x1b873593 + diff --git a/Network/Haskoin/Crypto/Keys.hs b/Network/Haskoin/Crypto/Keys.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Keys.hs @@ -0,0 +1,258 @@ +module Network.Haskoin.Crypto.Keys +( PubKey(..) +, isValidPubKey +, isPubKeyU +, derivePubKey +, pubKeyAddr +, addPubKeys +, PrvKey(..) +, isValidPrvKey +, makePrvKey +, makePrvKeyU +, fromPrvKey +, isPrvKeyU +, addPrvKeys +, putPrvKey +, getPrvKey +, getPrvKeyU +, fromWIF +, toWIF +, curveG +) where + +import Data.Binary (Binary, get, put) +import Data.Binary.Get (Get, getWord8) +import Data.Binary.Put (Put, putWord8) + +import Control.Monad (when, unless, guard) +import Control.Applicative ((<$>),(<*>)) +import Data.Maybe (isJust, fromJust) + +import qualified Data.ByteString as BS + ( head, tail + , last, init + , cons, snoc + , length + ) +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.Point +import Network.Haskoin.Crypto.Base58 +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Util + +-- | G parameter of the EC curve expressed as a Point +curveG :: Point +curveG = fromJust $ makePoint (fromInteger $ fst pairG) + (fromInteger $ snd pairG) + +-- | Elliptic curve public key type. Two constructors are provided for creating +-- compressed and uncompressed public keys from a Point. The use of compressed +-- keys is preferred as it produces shorter keys without compromising security. +-- Uncompressed keys are supported for backwards compatibility. +data PubKey + -- | Compressed public key + = PubKey { pubKeyPoint :: !Point } + -- | Uncompressed public key + | PubKeyU { pubKeyPoint :: !Point } + deriving (Read, Show) + +instance Eq PubKey where + -- Compression does not matter for InfPoint + (PubKey InfPoint) == (PubKeyU InfPoint) = True + (PubKeyU InfPoint) == (PubKey InfPoint) = True + (PubKey a) == (PubKey b) = a == b + (PubKeyU a) == (PubKeyU b) = a == b + _ == _ = False + +-- | Returns True if the public key is valid. This will check if the public +-- key point lies on the curve. +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 +isPubKeyU (PubKeyU _) = True + +-- | Derives a public key from a private key. This function will preserve +-- information on key compression (PrvKey becomes PubKey and PrvKeyU becomes +-- PubKeyU) +derivePubKey :: PrvKey -> PubKey +derivePubKey k = case k of + (PrvKey d) -> PubKey $ mulPoint d curveG + (PrvKeyU d) -> PubKeyU $ mulPoint d curveG + +instance Binary PubKey where + + -- Section 2.3.4 http://www.secg.org/download/aid-780/sec1-v2.pdf + get = go =<< getWord8 + where + -- skip 2.3.4.1 and fail. InfPoint is an invalid public key + go 0 = fail "InfPoint is not a valid public key" + -- 2.3.4.3 Uncompressed format + go 4 = getUncompressed + -- 2.3.4.2 Compressed format + -- 2 means pY is even, 3 means pY is odd + go y | y == 2 || y == 3 = getCompressed (even y) + | otherwise = fail "Get: Invalid public key encoding" + + -- Section 2.3.3 http://www.secg.org/download/aid-780/sec1-v2.pdf + put pk = case getAffine (pubKeyPoint pk) of + -- 2.3.3.1 + Nothing -> putWord8 0x00 + Just (x,y) -> case pk of + -- Compressed + PubKey _ -> putWord8 (if even y then 2 else 3) >> put x + -- Uncompressed + PubKeyU _ -> putWord8 4 >> put x >> put y + +getUncompressed :: Get PubKey +getUncompressed = do + p <- makePoint <$> get <*> get + unless (isJust p) (fail "Get: Point not on the curve") + return $ PubKeyU $ fromJust $ p + +getCompressed :: Bool -> Get PubKey +getCompressed e = do + -- 2.1 + x <- get :: Get FieldP + -- 2.4.1 (deriving yP) + let a = x ^ (3 :: Integer) + (curveA * x) + curveB + ys = filter matchSign (quadraticResidue a) + -- We found no square root (mod p) + when (null ys) (fail $ "No ECC point for x = " ++ (show x)) + let p = makePoint x (head ys) + -- Additionally, check that the point is on the curve + unless (isJust p) (fail "Get: Point not on the curve") + return $ PubKey $ fromJust $ p + where + matchSign a = (even a) == e + +-- | Computes an Address value from a public key +pubKeyAddr :: PubKey -> Address +pubKeyAddr = PubKeyAddress . hash160 . hash256BS . encode' + +{- Private Keys -} + +-- | Elliptic curve private key type. Two constructors are provided for creating +-- compressed or uncompressed private keys. Compression information is stored +-- in private key WIF formats and needs to be preserved to generate the correct +-- addresses from the corresponding public key. +data PrvKey + -- | Compressed private key + = PrvKey { prvKeyFieldN :: !FieldN } + -- | Uncompressed private key + | PrvKeyU { prvKeyFieldN :: !FieldN } + deriving (Eq, Show, Read) + +-- | 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. +isValidPrvKey :: Integer -> Bool +isValidPrvKey = isIntegerValidKey + +-- | Builds a compressed private key from an Integer value. Returns Nothing if +-- the Integer would not produce a valid private key. For security, the Integer +-- needs to be generated from a random source with sufficient entropy. +makePrvKey :: Integer -> Maybe PrvKey +makePrvKey i + | isValidPrvKey i = Just $ PrvKey $ fromInteger i + | otherwise = Nothing + +-- | Builds an uncompressed private key from an Integer value. Returns Nothing +-- if the Integer would not produce a valid private key. For security, the +-- Integer needs to be generated from a random source with sufficient entropy. +makePrvKeyU :: Integer -> Maybe PrvKey +makePrvKeyU i + | isValidPrvKey i = Just $ PrvKeyU $ fromInteger i + | otherwise = Nothing + +-- | Returns the Integer value of a private key +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 +isPrvKeyU (PrvKeyU _) = True + +-- | Serialize a private key into the Data.Binary.Put monad as a 32 byte +-- big endian ByteString. This is useful when a constant length serialization +-- 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 + +-- | 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 + let res = makePrvKey $ fromIntegral i + unless (isJust res) $ fail "Get: PrivateKey is invalid" + return $ fromJust res + +-- | Deserializes an uncompressed private key from the Data.Binary.Get monad as +-- a 32 byte big endian ByteString +getPrvKeyU :: Get PrvKey +getPrvKeyU = do + i <- get :: Get Hash256 + let res = makePrvKeyU $ fromIntegral i + unless (isJust res) $ fail "Get: PrivateKey is invalid" + return $ fromJust res + +-- | Decodes a private key from a WIF encoded String. This function can fail +-- if the input string does not decode correctly as a base 58 string or if +-- the checksum fails. +-- +fromWIF :: String -> Maybe PrvKey +fromWIF str = do + bs <- decodeBase58Check $ stringToBS str + -- Check that this is a private key + guard (BS.head bs == secretPrefix) + case BS.length bs of + 33 -> do -- Uncompressed format + let i = bsToInteger (BS.tail bs) + makePrvKeyU i + 34 -> do -- Compressed format + guard (BS.last bs == 0x01) + let i = bsToInteger $ BS.tail $ BS.init bs + makePrvKey i + _ -> Nothing -- Bad length + +-- | Encodes a private key into WIF format +toWIF :: PrvKey -> String +toWIF k = bsToString $ encodeBase58Check $ BS.cons secretPrefix enc + where + enc | isPrvKeyU k = bs + | otherwise = BS.snoc bs 0x01 + bs = runPut' $ putPrvKey k + diff --git a/Network/Haskoin/Crypto/Merkle.hs b/Network/Haskoin/Crypto/Merkle.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Merkle.hs @@ -0,0 +1,130 @@ +module Network.Haskoin.Crypto.Merkle +( calcTreeHeight +, calcTreeWidth +, buildMerkleRoot +, calcHash +, buildPartialMerkle +, extractMatches +) where + +import Data.Bits +import Data.Maybe +import qualified Data.ByteString as BS + +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Util + +-- | Computes the height of a merkle tree. +calcTreeHeight :: Int -- ^ Number of transactions (leaf nodes). + -> Int -- ^ Height of the merkle tree. +calcTreeHeight ntx = ceiling $ log (fromIntegral ntx :: Double) / log 2 + +-- | Computes the width of a merkle tree at a specific height. The transactions +-- are at height 0. +calcTreeWidth :: Int -- ^ Number of transactions (leaf nodes). + -> Int -- ^ Height at which we want to compute the width. + -> Int -- ^ Width of the merkle tree. +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 txs = calcHash (calcTreeHeight $ length txs) 0 txs + +hash2 :: Hash256 -> Hash256 -> Hash256 +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. +calcHash height pos txs + | height < 0 || pos < 0 = error "calcHash: Invalid parameters" + | height == 0 = txs !! pos + | otherwise = hash2 left right + where + left = calcHash (height-1) (pos*2) txs + right | pos*2+1 < calcTreeWidth (length txs) (height-1) = + calcHash (height-1) (pos*2+1) txs + | otherwise = left + +-- | Build a partial merkle tree. +buildPartialMerkle + :: [(Hash256,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]) + -- ^ 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 height pos txs + | height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters" + | height == 0 || not match = ([match],[calcHash height pos t]) + | otherwise = (match : lb ++ rb, lh ++ rh) + where + t = map fst txs + s = pos `shiftL` height + e = min (length txs) $ (pos+1) `shiftL` height + match = or $ map snd $ take (e-s) $ drop s txs + (lb,lh) = traverseAndBuild (height-1) (pos*2) txs + (rb,rh) | (pos*2+1) < calcTreeWidth (length txs) (height-1) + = traverseAndBuild (height-1) (pos*2+1) txs + | otherwise = ([],[]) + +traverseAndExtract :: Int -> Int -> Int -> [Bool] -> [Hash256] + -> Maybe (Hash256, [Hash256], Int, Int) +traverseAndExtract height pos ntx flags hashes + | length flags == 0 = Nothing + | height == 0 || not match = leafResult + | isNothing leftM = Nothing + | (pos*2+1) >= calcTreeWidth ntx (height-1) = + Just (hash2 lh lh, lm, lcf+1, lch) + | isNothing rightM = Nothing + | otherwise = + Just (hash2 lh rh, lm ++ rm, lcf+rcf+1, lch+rch) + where + leafResult + | null hashes = Nothing + | otherwise = Just (h,if height == 0 && match then [h] else [],1,1) + (match:fs) = flags + (h:_) = hashes + leftM = traverseAndExtract (height-1) (pos*2) ntx fs hashes + (lh,lm,lcf,lch) = fromJust leftM + rightM = traverseAndExtract (height-1) (pos*2+1) ntx + (drop lcf fs) (drop lch hashes) + (rh,rm,rcf,rch) = fromJust rightM + +-- | 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]) + -- ^ Merkle root and the list of matching transaction hashes. +extractMatches flags hashes ntx + | ntx == 0 = Left $ + "extractMatches: number of transactions can not be 0" + | ntx > maxBlockSize `div` 60 = Left $ + "extractMatches: number of transactions excessively high" + | length hashes > ntx = Left $ + "extractMatches: More hashes provided than the number of transactions" + | length flags < length hashes = Left $ + "extractMatches: At least one bit per node and one bit per hash" + | isNothing resM = Left $ + "extractMatches: traverseAndExtract failed" + | (nBitsUsed+7) `div` 8 /= (length flags+7) `div` 8 = Left $ + "extractMatches: All bits were not consumed" + | nHashUsed /= length hashes = Left $ + "extractMatches: All hashes were not consumed: " ++ (show nHashUsed) + | otherwise = return (merkleRoot, matches) + where + resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes + (merkleRoot, matches, nBitsUsed, nHashUsed) = fromJust resM + + + diff --git a/Network/Haskoin/Crypto/Mnemonic.hs b/Network/Haskoin/Crypto/Mnemonic.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Mnemonic.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Mnemonic keys (BIP-0039) +module Network.Haskoin.Crypto.Mnemonic +( + -- * Data types + WordList +, Entropy +, Mnemonic +, Passphrase +, Seed + + -- * Entropy encoding and decoding +, toMnemonic +, fromMnemonic + + -- * Generating 512-bit seeds +, anyToSeed +, mnemonicToSeed + + -- * Dictionaries +, english + + -- * Helper functions +, getBits +) where + +import Control.Monad (when) +import qualified Crypto.Hash.SHA256 as SHA256 +import Crypto.PBKDF.ByteString (sha512PBKDF2) +import Data.Bits ((.&.), shiftL, shiftR) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +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 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" + 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 + +-- | 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 + 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 + return ms_ent + where + ms_words = T.words $ normalize NFKD 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 + +calcCS :: Int -> Entropy -> Checksum +calcCS len = getBits len . SHA256.hash + +numCS :: Int -> Entropy -> Integer +numCS len = shiftCS . bsToInteger + where + shiftCS = case 8 - len `mod` 8 of + 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. +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) + +-- | 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 +-- 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 + return $ anyToSeed pf mnm + +-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' +-- will be smallest required to hold that many bits, padded with zeroes to the +-- right. +getBits :: Int -> ByteString -> ByteString +getBits b bs + | r == 0 = BS.take q bs + | otherwise = i `BS.snoc` l + where + (q, r) = b `quotRem` 8 + s = (BS.take (q + 1) bs) + 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 + where + i = map (flip elemIndex wl) ws + n = elemIndices Nothing i + w = T.unwords $ map (ws !!) n + +indicesToBS :: [Int] -> Either String ByteString +indicesToBS is = do + when lrg $ Left "indicesToBS: index larger or equal than 2048" + return . pad . integerToBS $ (foldl' f 0 is) `shiftL` shift_width + where + lrg = not . isNothing $ find (>= 2048) is + (q, r) = (length is * 11) `quotRem` 8 + shift_width = if r == 0 then 0 else 8 - r + bl = if r == 0 then q else q + 1 -- length of resulting ByteString + pad bs = BS.append (BS.replicate (bl - BS.length bs) 0x00) bs + f acc x = (acc `shiftL` 11) + fromIntegral x + +bsToIndices :: ByteString -> [Int] +bsToIndices bs = reverse . go q $ bsToInteger bs `shiftR` r + where + (q, r) = (BS.length bs * 8) `quotRem` 11 + 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 = + [ "abandon", "ability", "able", "about", "above", "absent" + , "absorb", "abstract", "absurd", "abuse", "access", "accident" + , "account", "accuse", "achieve", "acid", "acoustic", "acquire" + , "across", "act", "action", "actor", "actress", "actual" + , "adapt", "add", "addict", "address", "adjust", "admit" + , "adult", "advance", "advice", "aerobic", "affair", "afford" + , "afraid", "again", "age", "agent", "agree", "ahead" + , "aim", "air", "airport", "aisle", "alarm", "album" + , "alcohol", "alert", "alien", "all", "alley", "allow" + , "almost", "alone", "alpha", "already", "also", "alter" + , "always", "amateur", "amazing", "among", "amount", "amused" + , "analyst", "anchor", "ancient", "anger", "angle", "angry" + , "animal", "ankle", "announce", "annual", "another", "answer" + , "antenna", "antique", "anxiety", "any", "apart", "apology" + , "appear", "apple", "approve", "april", "arch", "arctic" + , "area", "arena", "argue", "arm", "armed", "armor" + , "army", "around", "arrange", "arrest", "arrive", "arrow" + , "art", "artefact", "artist", "artwork", "ask", "aspect" + , "assault", "asset", "assist", "assume", "asthma", "athlete" + , "atom", "attack", "attend", "attitude", "attract", "auction" + , "audit", "august", "aunt", "author", "auto", "autumn" + , "average", "avocado", "avoid", "awake", "aware", "away" + , "awesome", "awful", "awkward", "axis", "baby", "bachelor" + , "bacon", "badge", "bag", "balance", "balcony", "ball" + , "bamboo", "banana", "banner", "bar", "barely", "bargain" + , "barrel", "base", "basic", "basket", "battle", "beach" + , "bean", "beauty", "because", "become", "beef", "before" + , "begin", "behave", "behind", "believe", "below", "belt" + , "bench", "benefit", "best", "betray", "better", "between" + , "beyond", "bicycle", "bid", "bike", "bind", "biology" + , "bird", "birth", "bitter", "black", "blade", "blame" + , "blanket", "blast", "bleak", "bless", "blind", "blood" + , "blossom", "blouse", "blue", "blur", "blush", "board" + , "boat", "body", "boil", "bomb", "bone", "bonus" + , "book", "boost", "border", "boring", "borrow", "boss" + , "bottom", "bounce", "box", "boy", "bracket", "brain" + , "brand", "brass", "brave", "bread", "breeze", "brick" + , "bridge", "brief", "bright", "bring", "brisk", "broccoli" + , "broken", "bronze", "broom", "brother", "brown", "brush" + , "bubble", "buddy", "budget", "buffalo", "build", "bulb" + , "bulk", "bullet", "bundle", "bunker", "burden", "burger" + , "burst", "bus", "business", "busy", "butter", "buyer" + , "buzz", "cabbage", "cabin", "cable", "cactus", "cage" + , "cake", "call", "calm", "camera", "camp", "can" + , "canal", "cancel", "candy", "cannon", "canoe", "canvas" + , "canyon", "capable", "capital", "captain", "car", "carbon" + , "card", "cargo", "carpet", "carry", "cart", "case" + , "cash", "casino", "castle", "casual", "cat", "catalog" + , "catch", "category", "cattle", "caught", "cause", "caution" + , "cave", "ceiling", "celery", "cement", "census", "century" + , "cereal", "certain", "chair", "chalk", "champion", "change" + , "chaos", "chapter", "charge", "chase", "chat", "cheap" + , "check", "cheese", "chef", "cherry", "chest", "chicken" + , "chief", "child", "chimney", "choice", "choose", "chronic" + , "chuckle", "chunk", "churn", "cigar", "cinnamon", "circle" + , "citizen", "city", "civil", "claim", "clap", "clarify" + , "claw", "clay", "clean", "clerk", "clever", "click" + , "client", "cliff", "climb", "clinic", "clip", "clock" + , "clog", "close", "cloth", "cloud", "clown", "club" + , "clump", "cluster", "clutch", "coach", "coast", "coconut" + , "code", "coffee", "coil", "coin", "collect", "color" + , "column", "combine", "come", "comfort", "comic", "common" + , "company", "concert", "conduct", "confirm", "congress", "connect" + , "consider", "control", "convince", "cook", "cool", "copper" + , "copy", "coral", "core", "corn", "correct", "cost" + , "cotton", "couch", "country", "couple", "course", "cousin" + , "cover", "coyote", "crack", "cradle", "craft", "cram" + , "crane", "crash", "crater", "crawl", "crazy", "cream" + , "credit", "creek", "crew", "cricket", "crime", "crisp" + , "critic", "crop", "cross", "crouch", "crowd", "crucial" + , "cruel", "cruise", "crumble", "crunch", "crush", "cry" + , "crystal", "cube", "culture", "cup", "cupboard", "curious" + , "current", "curtain", "curve", "cushion", "custom", "cute" + , "cycle", "dad", "damage", "damp", "dance", "danger" + , "daring", "dash", "daughter", "dawn", "day", "deal" + , "debate", "debris", "decade", "december", "decide", "decline" + , "decorate", "decrease", "deer", "defense", "define", "defy" + , "degree", "delay", "deliver", "demand", "demise", "denial" + , "dentist", "deny", "depart", "depend", "deposit", "depth" + , "deputy", "derive", "describe", "desert", "design", "desk" + , "despair", "destroy", "detail", "detect", "develop", "device" + , "devote", "diagram", "dial", "diamond", "diary", "dice" + , "diesel", "diet", "differ", "digital", "dignity", "dilemma" + , "dinner", "dinosaur", "direct", "dirt", "disagree", "discover" + , "disease", "dish", "dismiss", "disorder", "display", "distance" + , "divert", "divide", "divorce", "dizzy", "doctor", "document" + , "dog", "doll", "dolphin", "domain", "donate", "donkey" + , "donor", "door", "dose", "double", "dove", "draft" + , "dragon", "drama", "drastic", "draw", "dream", "dress" + , "drift", "drill", "drink", "drip", "drive", "drop" + , "drum", "dry", "duck", "dumb", "dune", "during" + , "dust", "dutch", "duty", "dwarf", "dynamic", "eager" + , "eagle", "early", "earn", "earth", "easily", "east" + , "easy", "echo", "ecology", "economy", "edge", "edit" + , "educate", "effort", "egg", "eight", "either", "elbow" + , "elder", "electric", "elegant", "element", "elephant", "elevator" + , "elite", "else", "embark", "embody", "embrace", "emerge" + , "emotion", "employ", "empower", "empty", "enable", "enact" + , "end", "endless", "endorse", "enemy", "energy", "enforce" + , "engage", "engine", "enhance", "enjoy", "enlist", "enough" + , "enrich", "enroll", "ensure", "enter", "entire", "entry" + , "envelope", "episode", "equal", "equip", "era", "erase" + , "erode", "erosion", "error", "erupt", "escape", "essay" + , "essence", "estate", "eternal", "ethics", "evidence", "evil" + , "evoke", "evolve", "exact", "example", "excess", "exchange" + , "excite", "exclude", "excuse", "execute", "exercise", "exhaust" + , "exhibit", "exile", "exist", "exit", "exotic", "expand" + , "expect", "expire", "explain", "expose", "express", "extend" + , "extra", "eye", "eyebrow", "fabric", "face", "faculty" + , "fade", "faint", "faith", "fall", "false", "fame" + , "family", "famous", "fan", "fancy", "fantasy", "farm" + , "fashion", "fat", "fatal", "father", "fatigue", "fault" + , "favorite", "feature", "february", "federal", "fee", "feed" + , "feel", "female", "fence", "festival", "fetch", "fever" + , "few", "fiber", "fiction", "field", "figure", "file" + , "film", "filter", "final", "find", "fine", "finger" + , "finish", "fire", "firm", "first", "fiscal", "fish" + , "fit", "fitness", "fix", "flag", "flame", "flash" + , "flat", "flavor", "flee", "flight", "flip", "float" + , "flock", "floor", "flower", "fluid", "flush", "fly" + , "foam", "focus", "fog", "foil", "fold", "follow" + , "food", "foot", "force", "forest", "forget", "fork" + , "fortune", "forum", "forward", "fossil", "foster", "found" + , "fox", "fragile", "frame", "frequent", "fresh", "friend" + , "fringe", "frog", "front", "frost", "frown", "frozen" + , "fruit", "fuel", "fun", "funny", "furnace", "fury" + , "future", "gadget", "gain", "galaxy", "gallery", "game" + , "gap", "garage", "garbage", "garden", "garlic", "garment" + , "gas", "gasp", "gate", "gather", "gauge", "gaze" + , "general", "genius", "genre", "gentle", "genuine", "gesture" + , "ghost", "giant", "gift", "giggle", "ginger", "giraffe" + , "girl", "give", "glad", "glance", "glare", "glass" + , "glide", "glimpse", "globe", "gloom", "glory", "glove" + , "glow", "glue", "goat", "goddess", "gold", "good" + , "goose", "gorilla", "gospel", "gossip", "govern", "gown" + , "grab", "grace", "grain", "grant", "grape", "grass" + , "gravity", "great", "green", "grid", "grief", "grit" + , "grocery", "group", "grow", "grunt", "guard", "guess" + , "guide", "guilt", "guitar", "gun", "gym", "habit" + , "hair", "half", "hammer", "hamster", "hand", "happy" + , "harbor", "hard", "harsh", "harvest", "hat", "have" + , "hawk", "hazard", "head", "health", "heart", "heavy" + , "hedgehog", "height", "hello", "helmet", "help", "hen" + , "hero", "hidden", "high", "hill", "hint", "hip" + , "hire", "history", "hobby", "hockey", "hold", "hole" + , "holiday", "hollow", "home", "honey", "hood", "hope" + , "horn", "horror", "horse", "hospital", "host", "hotel" + , "hour", "hover", "hub", "huge", "human", "humble" + , "humor", "hundred", "hungry", "hunt", "hurdle", "hurry" + , "hurt", "husband", "hybrid", "ice", "icon", "idea" + , "identify", "idle", "ignore", "ill", "illegal", "illness" + , "image", "imitate", "immense", "immune", "impact", "impose" + , "improve", "impulse", "inch", "include", "income", "increase" + , "index", "indicate", "indoor", "industry", "infant", "inflict" + , "inform", "inhale", "inherit", "initial", "inject", "injury" + , "inmate", "inner", "innocent", "input", "inquiry", "insane" + , "insect", "inside", "inspire", "install", "intact", "interest" + , "into", "invest", "invite", "involve", "iron", "island" + , "isolate", "issue", "item", "ivory", "jacket", "jaguar" + , "jar", "jazz", "jealous", "jeans", "jelly", "jewel" + , "job", "join", "joke", "journey", "joy", "judge" + , "juice", "jump", "jungle", "junior", "junk", "just" + , "kangaroo", "keen", "keep", "ketchup", "key", "kick" + , "kid", "kidney", "kind", "kingdom", "kiss", "kit" + , "kitchen", "kite", "kitten", "kiwi", "knee", "knife" + , "knock", "know", "lab", "label", "labor", "ladder" + , "lady", "lake", "lamp", "language", "laptop", "large" + , "later", "latin", "laugh", "laundry", "lava", "law" + , "lawn", "lawsuit", "layer", "lazy", "leader", "leaf" + , "learn", "leave", "lecture", "left", "leg", "legal" + , "legend", "leisure", "lemon", "lend", "length", "lens" + , "leopard", "lesson", "letter", "level", "liar", "liberty" + , "library", "license", "life", "lift", "light", "like" + , "limb", "limit", "link", "lion", "liquid", "list" + , "little", "live", "lizard", "load", "loan", "lobster" + , "local", "lock", "logic", "lonely", "long", "loop" + , "lottery", "loud", "lounge", "love", "loyal", "lucky" + , "luggage", "lumber", "lunar", "lunch", "luxury", "lyrics" + , "machine", "mad", "magic", "magnet", "maid", "mail" + , "main", "major", "make", "mammal", "man", "manage" + , "mandate", "mango", "mansion", "manual", "maple", "marble" + , "march", "margin", "marine", "market", "marriage", "mask" + , "mass", "master", "match", "material", "math", "matrix" + , "matter", "maximum", "maze", "meadow", "mean", "measure" + , "meat", "mechanic", "medal", "media", "melody", "melt" + , "member", "memory", "mention", "menu", "mercy", "merge" + , "merit", "merry", "mesh", "message", "metal", "method" + , "middle", "midnight", "milk", "million", "mimic", "mind" + , "minimum", "minor", "minute", "miracle", "mirror", "misery" + , "miss", "mistake", "mix", "mixed", "mixture", "mobile" + , "model", "modify", "mom", "moment", "monitor", "monkey" + , "monster", "month", "moon", "moral", "more", "morning" + , "mosquito", "mother", "motion", "motor", "mountain", "mouse" + , "move", "movie", "much", "muffin", "mule", "multiply" + , "muscle", "museum", "mushroom", "music", "must", "mutual" + , "myself", "mystery", "myth", "naive", "name", "napkin" + , "narrow", "nasty", "nation", "nature", "near", "neck" + , "need", "negative", "neglect", "neither", "nephew", "nerve" + , "nest", "net", "network", "neutral", "never", "news" + , "next", "nice", "night", "noble", "noise", "nominee" + , "noodle", "normal", "north", "nose", "notable", "note" + , "nothing", "notice", "novel", "now", "nuclear", "number" + , "nurse", "nut", "oak", "obey", "object", "oblige" + , "obscure", "observe", "obtain", "obvious", "occur", "ocean" + , "october", "odor", "off", "offer", "office", "often" + , "oil", "okay", "old", "olive", "olympic", "omit" + , "once", "one", "onion", "online", "only", "open" + , "opera", "opinion", "oppose", "option", "orange", "orbit" + , "orchard", "order", "ordinary", "organ", "orient", "original" + , "orphan", "ostrich", "other", "outdoor", "outer", "output" + , "outside", "oval", "oven", "over", "own", "owner" + , "oxygen", "oyster", "ozone", "pact", "paddle", "page" + , "pair", "palace", "palm", "panda", "panel", "panic" + , "panther", "paper", "parade", "parent", "park", "parrot" + , "party", "pass", "patch", "path", "patient", "patrol" + , "pattern", "pause", "pave", "payment", "peace", "peanut" + , "pear", "peasant", "pelican", "pen", "penalty", "pencil" + , "people", "pepper", "perfect", "permit", "person", "pet" + , "phone", "photo", "phrase", "physical", "piano", "picnic" + , "picture", "piece", "pig", "pigeon", "pill", "pilot" + , "pink", "pioneer", "pipe", "pistol", "pitch", "pizza" + , "place", "planet", "plastic", "plate", "play", "please" + , "pledge", "pluck", "plug", "plunge", "poem", "poet" + , "point", "polar", "pole", "police", "pond", "pony" + , "pool", "popular", "portion", "position", "possible", "post" + , "potato", "pottery", "poverty", "powder", "power", "practice" + , "praise", "predict", "prefer", "prepare", "present", "pretty" + , "prevent", "price", "pride", "primary", "print", "priority" + , "prison", "private", "prize", "problem", "process", "produce" + , "profit", "program", "project", "promote", "proof", "property" + , "prosper", "protect", "proud", "provide", "public", "pudding" + , "pull", "pulp", "pulse", "pumpkin", "punch", "pupil" + , "puppy", "purchase", "purity", "purpose", "purse", "push" + , "put", "puzzle", "pyramid", "quality", "quantum", "quarter" + , "question", "quick", "quit", "quiz", "quote", "rabbit" + , "raccoon", "race", "rack", "radar", "radio", "rail" + , "rain", "raise", "rally", "ramp", "ranch", "random" + , "range", "rapid", "rare", "rate", "rather", "raven" + , "raw", "razor", "ready", "real", "reason", "rebel" + , "rebuild", "recall", "receive", "recipe", "record", "recycle" + , "reduce", "reflect", "reform", "refuse", "region", "regret" + , "regular", "reject", "relax", "release", "relief", "rely" + , "remain", "remember", "remind", "remove", "render", "renew" + , "rent", "reopen", "repair", "repeat", "replace", "report" + , "require", "rescue", "resemble", "resist", "resource", "response" + , "result", "retire", "retreat", "return", "reunion", "reveal" + , "review", "reward", "rhythm", "rib", "ribbon", "rice" + , "rich", "ride", "ridge", "rifle", "right", "rigid" + , "ring", "riot", "ripple", "risk", "ritual", "rival" + , "river", "road", "roast", "robot", "robust", "rocket" + , "romance", "roof", "rookie", "room", "rose", "rotate" + , "rough", "round", "route", "royal", "rubber", "rude" + , "rug", "rule", "run", "runway", "rural", "sad" + , "saddle", "sadness", "safe", "sail", "salad", "salmon" + , "salon", "salt", "salute", "same", "sample", "sand" + , "satisfy", "satoshi", "sauce", "sausage", "save", "say" + , "scale", "scan", "scare", "scatter", "scene", "scheme" + , "school", "science", "scissors", "scorpion", "scout", "scrap" + , "screen", "script", "scrub", "sea", "search", "season" + , "seat", "second", "secret", "section", "security", "seed" + , "seek", "segment", "select", "sell", "seminar", "senior" + , "sense", "sentence", "series", "service", "session", "settle" + , "setup", "seven", "shadow", "shaft", "shallow", "share" + , "shed", "shell", "sheriff", "shield", "shift", "shine" + , "ship", "shiver", "shock", "shoe", "shoot", "shop" + , "short", "shoulder", "shove", "shrimp", "shrug", "shuffle" + , "shy", "sibling", "sick", "side", "siege", "sight" + , "sign", "silent", "silk", "silly", "silver", "similar" + , "simple", "since", "sing", "siren", "sister", "situate" + , "six", "size", "skate", "sketch", "ski", "skill" + , "skin", "skirt", "skull", "slab", "slam", "sleep" + , "slender", "slice", "slide", "slight", "slim", "slogan" + , "slot", "slow", "slush", "small", "smart", "smile" + , "smoke", "smooth", "snack", "snake", "snap", "sniff" + , "snow", "soap", "soccer", "social", "sock", "soda" + , "soft", "solar", "soldier", "solid", "solution", "solve" + , "someone", "song", "soon", "sorry", "sort", "soul" + , "sound", "soup", "source", "south", "space", "spare" + , "spatial", "spawn", "speak", "special", "speed", "spell" + , "spend", "sphere", "spice", "spider", "spike", "spin" + , "spirit", "split", "spoil", "sponsor", "spoon", "sport" + , "spot", "spray", "spread", "spring", "spy", "square" + , "squeeze", "squirrel", "stable", "stadium", "staff", "stage" + , "stairs", "stamp", "stand", "start", "state", "stay" + , "steak", "steel", "stem", "step", "stereo", "stick" + , "still", "sting", "stock", "stomach", "stone", "stool" + , "story", "stove", "strategy", "street", "strike", "strong" + , "struggle", "student", "stuff", "stumble", "style", "subject" + , "submit", "subway", "success", "such", "sudden", "suffer" + , "sugar", "suggest", "suit", "summer", "sun", "sunny" + , "sunset", "super", "supply", "supreme", "sure", "surface" + , "surge", "surprise", "surround", "survey", "suspect", "sustain" + , "swallow", "swamp", "swap", "swarm", "swear", "sweet" + , "swift", "swim", "swing", "switch", "sword", "symbol" + , "symptom", "syrup", "system", "table", "tackle", "tag" + , "tail", "talent", "talk", "tank", "tape", "target" + , "task", "taste", "tattoo", "taxi", "teach", "team" + , "tell", "ten", "tenant", "tennis", "tent", "term" + , "test", "text", "thank", "that", "theme", "then" + , "theory", "there", "they", "thing", "this", "thought" + , "three", "thrive", "throw", "thumb", "thunder", "ticket" + , "tide", "tiger", "tilt", "timber", "time", "tiny" + , "tip", "tired", "tissue", "title", "toast", "tobacco" + , "today", "toddler", "toe", "together", "toilet", "token" + , "tomato", "tomorrow", "tone", "tongue", "tonight", "tool" + , "tooth", "top", "topic", "topple", "torch", "tornado" + , "tortoise", "toss", "total", "tourist", "toward", "tower" + , "town", "toy", "track", "trade", "traffic", "tragic" + , "train", "transfer", "trap", "trash", "travel", "tray" + , "treat", "tree", "trend", "trial", "tribe", "trick" + , "trigger", "trim", "trip", "trophy", "trouble", "truck" + , "true", "truly", "trumpet", "trust", "truth", "try" + , "tube", "tuition", "tumble", "tuna", "tunnel", "turkey" + , "turn", "turtle", "twelve", "twenty", "twice", "twin" + , "twist", "two", "type", "typical", "ugly", "umbrella" + , "unable", "unaware", "uncle", "uncover", "under", "undo" + , "unfair", "unfold", "unhappy", "uniform", "unique", "unit" + , "universe", "unknown", "unlock", "until", "unusual", "unveil" + , "update", "upgrade", "uphold", "upon", "upper", "upset" + , "urban", "urge", "usage", "use", "used", "useful" + , "useless", "usual", "utility", "vacant", "vacuum", "vague" + , "valid", "valley", "valve", "van", "vanish", "vapor" + , "various", "vast", "vault", "vehicle", "velvet", "vendor" + , "venture", "venue", "verb", "verify", "version", "very" + , "vessel", "veteran", "viable", "vibrant", "vicious", "victory" + , "video", "view", "village", "vintage", "violin", "virtual" + , "virus", "visa", "visit", "visual", "vital", "vivid" + , "vocal", "voice", "void", "volcano", "volume", "vote" + , "voyage", "wage", "wagon", "wait", "walk", "wall" + , "walnut", "want", "warfare", "warm", "warrior", "wash" + , "wasp", "waste", "water", "wave", "way", "wealth" + , "weapon", "wear", "weasel", "weather", "web", "wedding" + , "weekend", "weird", "welcome", "west", "wet", "whale" + , "what", "wheat", "wheel", "when", "where", "whip" + , "whisper", "wide", "width", "wife", "wild", "will" + , "win", "window", "wine", "wing", "wink", "winner" + , "winter", "wire", "wisdom", "wise", "wish", "witness" + , "wolf", "woman", "wonder", "wood", "wool", "word" + , "work", "world", "worry", "worth", "wrap", "wreck" + , "wrestle", "wrist", "write", "wrong", "yard", "year" + , "yellow", "you", "young", "youth", "zebra", "zero" + , "zone", "zoo" + ] diff --git a/Network/Haskoin/Crypto/NormalizedKeys.hs b/Network/Haskoin/Crypto/NormalizedKeys.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/NormalizedKeys.hs @@ -0,0 +1,292 @@ +module Network.Haskoin.Crypto.NormalizedKeys +( MasterKey(..) +, AccPrvKey(..) +, AccPubKey(..) +, AddrPrvKey(..) +, AddrPubKey(..) +, KeyIndex +, makeMasterKey +, loadMasterKey +, loadPrvAcc +, loadPubAcc +, addr +, accPrvKey +, accPubKey +, extPrvKey +, extPubKey +, intPrvKey +, intPubKey +, accPrvKeys +, accPubKeys +, extPrvKeys +, extPubKeys +, intPrvKeys +, intPubKeys +, extAddr +, intAddr +, extAddrs +, intAddrs +, extAddrs' +, intAddrs' +, extMulSigKey +, intMulSigKey +, extMulSigKeys +, intMulSigKeys +, extMulSigAddr +, intMulSigAddr +, extMulSigAddrs +, intMulSigAddrs +) where + +import Control.Monad (liftM2, guard) +import Control.Applicative ((<$>)) + +import Data.Word (Word32) +import Data.Maybe (mapMaybe, fromJust, isJust) +import qualified Data.ByteString as BS (ByteString) + +import Network.Haskoin.Crypto.ExtendedKeys +import Network.Haskoin.Crypto.Base58 +import Network.Haskoin.Script.Parser + +type KeyIndex = Word32 + +-- | Data type representing an extended private key at the root of the +-- derivation tree. Master keys have depth 0 and no parents. They are +-- represented as m\/ in BIP32 notation. +newtype MasterKey = MasterKey { masterKey :: XPrvKey } + deriving (Eq, Show, Read) + +-- | 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. +-- 'AccPrvKey' is represented as m\/i'\/ in BIP32 notation. +newtype AccPrvKey = AccPrvKey { getAccPrvKey :: XPrvKey } + deriving (Eq, Show, Read) + +-- | 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 +-- BIP32 notation. 'AccPubKey' is used for generating receiving payment +-- addresses without the knowledge of the 'AccPrvKey'. +newtype AccPubKey = AccPubKey { getAccPubKey :: XPubKey } + deriving (Eq, Show, Read) + +-- | 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 +-- payment addresses without knowledge of the private account key. 'AccPrvKey' +-- is represented as m\/i'\/0\/j\/ in BIP32 notation if it is a regular +-- receiving address. Internal (change) addresses are represented as +-- m\/i'\/1\/j\/. Non-prime subtree 0 is used for regular receiving addresses +-- and non-prime subtree 1 for internal (change) addresses. +newtype AddrPrvKey = AddrPrvKey { getAddrPrvKey :: XPrvKey } + deriving (Eq, Show, Read) + +-- | 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 +-- for regular receiving addresses and by M\/i'\/1\/j for internal (change) +-- addresses. +newtype AddrPubKey = AddrPubKey { getAddrPubKey :: XPubKey } + deriving (Eq, Show, Read) + +-- | Create a 'MasterKey' from a seed. +makeMasterKey :: BS.ByteString -> Maybe MasterKey +makeMasterKey bs = MasterKey <$> makeXPrvKey bs + +-- | Load a 'MasterKey' from an 'XPrvKey'. This function will fail if the +-- extended private key does not have the properties of a 'MasterKey'. +loadMasterKey :: XPrvKey -> Maybe MasterKey +loadMasterKey k + | xPrvDepth k == 0 && + xPrvParent k == 0 && + xPrvIndex k == 0 = Just $ MasterKey k + | otherwise = Nothing + +-- | Load a private account key from an 'XPrvKey'. This function will fail if +-- the extended private key does not have the properties of a 'AccPrvKey'. +loadPrvAcc :: XPrvKey -> Maybe AccPrvKey +loadPrvAcc k + | xPrvDepth k == 1 && + xPrvIsPrime k = Just $ AccPrvKey k + | otherwise = Nothing + +-- | Load a public account key from an 'XPubKey'. This function will fail if +-- the extended public key does not have the properties of a 'AccPubKey'. +loadPubAcc :: XPubKey -> Maybe AccPubKey +loadPubAcc k + | xPubDepth k == 1 && + xPubIsPrime k = Just $ AccPubKey k + | otherwise = Nothing + +-- | Computes an 'AccPrvKey' from a 'MasterKey' and a derivation index. +accPrvKey :: MasterKey -> KeyIndex -> Maybe AccPrvKey +accPrvKey (MasterKey par) i = AccPrvKey <$> (f =<< primeSubKey par i) + where f k = guard (isJust $ prvSubKey k 0) >> + guard (isJust $ prvSubKey k 1) >> + return k + +-- | Computes an 'AccPubKey' from a 'MasterKey' and a derivation index. +accPubKey :: MasterKey -> KeyIndex -> Maybe AccPubKey +accPubKey (MasterKey par) i = f <$> primeSubKey par i + where f = AccPubKey . deriveXPubKey + +-- | Computes an external 'AddrPrvKey' from an 'AccPrvKey' and a derivation +-- index. +extPrvKey :: AccPrvKey -> KeyIndex -> Maybe AddrPrvKey +extPrvKey (AccPrvKey par) i = AddrPrvKey <$> prvSubKey extKey i + where extKey = fromJust $ prvSubKey par 0 + +-- | Computes an external 'AddrPubKey' from an 'AccPubKey' and a derivation +-- index. +extPubKey :: AccPubKey -> KeyIndex -> Maybe AddrPubKey +extPubKey (AccPubKey par) i = AddrPubKey <$> pubSubKey extKey i + where extKey = fromJust $ pubSubKey par 0 + +-- | Computes an internal 'AddrPrvKey' from an 'AccPrvKey' and a derivation +-- index. +intPrvKey :: AccPrvKey -> KeyIndex -> Maybe AddrPrvKey +intPrvKey (AccPrvKey par) i = AddrPrvKey <$> prvSubKey intKey i + where intKey = fromJust $ prvSubKey par 1 + +-- | Computes an internal 'AddrPubKey' from an 'AccPubKey' and a derivation +-- index. +intPubKey :: AccPubKey -> KeyIndex -> Maybe AddrPubKey +intPubKey (AccPubKey par) i = AddrPubKey <$> pubSubKey intKey i + where intKey = fromJust $ pubSubKey par 1 + +-- | Cyclic list of all valid 'AccPrvKey' derived from a 'MasterKey' and +-- starting from an offset index. +accPrvKeys :: MasterKey -> KeyIndex -> [(AccPrvKey,KeyIndex)] +accPrvKeys m i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (accPrvKey m j) (return j) + +-- | Cyclic list of all valid 'AccPubKey' derived from a 'MasterKey' and +-- starting from an offset index. +accPubKeys :: MasterKey -> KeyIndex -> [(AccPubKey,KeyIndex)] +accPubKeys m i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (accPubKey m j) (return j) + +-- | Cyclic list of all valid external 'AddrPrvKey' derived from a 'AccPrvKey' +-- and starting from an offset index. +extPrvKeys :: AccPrvKey -> KeyIndex -> [(AddrPrvKey,KeyIndex)] +extPrvKeys a i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (extPrvKey a j) (return j) + +-- | Cyclic list of all valid external 'AddrPubKey' derived from a 'AccPubKey' +-- and starting from an offset index. +extPubKeys :: AccPubKey -> KeyIndex -> [(AddrPubKey,KeyIndex)] +extPubKeys a i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (extPubKey a j) (return j) + +-- | Cyclic list of all internal 'AddrPrvKey' derived from a 'AccPrvKey' and +-- starting from an offset index. +intPrvKeys :: AccPrvKey -> KeyIndex -> [(AddrPrvKey,KeyIndex)] +intPrvKeys a i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (intPrvKey a j) (return j) + +-- | Cyclic list of all internal 'AddrPubKey' derived from a 'AccPubKey' and +-- starting from an offset index. +intPubKeys :: AccPubKey -> KeyIndex -> [(AddrPubKey,KeyIndex)] +intPubKeys a i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (intPubKey a j) (return j) + +{- Generate addresses -} + +-- | Computes an 'Address' from an 'AddrPubKey'. +addr :: AddrPubKey -> Address +addr = xPubAddr . getAddrPubKey + +-- | Computes an external base58 address from an 'AccPubKey' and a +-- derivation index. +extAddr :: AccPubKey -> KeyIndex -> Maybe String +extAddr a i = addrToBase58 . addr <$> extPubKey a i + +-- | Computes an internal base58 addres from an 'AccPubKey' and a +-- derivation index. +intAddr :: AccPubKey -> KeyIndex -> Maybe String +intAddr a i = addrToBase58 . addr <$> intPubKey a i + +-- | Cyclic list of all external base58 addresses derived from a 'AccPubKey' +-- and starting from an offset index. +extAddrs :: AccPubKey -> KeyIndex -> [(String,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' +-- and starting from an offset index. +intAddrs :: AccPubKey -> KeyIndex -> [(String,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' 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' a i = mapMaybe f $ cycleIndex' i + where f j = liftM2 (,) (intAddr a j) (return j) + +{- MultiSig -} + +-- | Computes a list of external 'AddrPubKey' from an 'AccPubKey', a list +-- of thirdparty multisig keys and a derivation index. This is useful for +-- computing the public keys associated with a derivation index for +-- multisig accounts. +extMulSigKey :: AccPubKey -> [XPubKey] -> KeyIndex -> Maybe [AddrPubKey] +extMulSigKey a ps i = (map AddrPubKey) <$> mulSigSubKey keys i + where keys = map (fromJust . (flip pubSubKey 0)) $ (getAccPubKey a) : ps + +-- | Computes a list of internal 'AddrPubKey' from an 'AccPubKey', a list +-- of thirdparty multisig keys and a derivation index. This is useful for +-- computing the public keys associated with a derivation index for +-- multisig accounts. +intMulSigKey :: AccPubKey -> [XPubKey] -> KeyIndex -> Maybe [AddrPubKey] +intMulSigKey a ps i = (map AddrPubKey) <$> mulSigSubKey keys i + where keys = map (fromJust . (flip pubSubKey 1)) $ (getAccPubKey a) : ps + +-- | Cyclic list of all external multisignature 'AddrPubKey' derivations +-- starting from an offset index. +extMulSigKeys :: AccPubKey -> [XPubKey] -> KeyIndex -> [([AddrPubKey],KeyIndex)] +extMulSigKeys a ps i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (extMulSigKey a ps j) (return j) + +-- | Cyclic list of all internal multisignature 'AddrPubKey' derivations +-- starting from an offset index. +intMulSigKeys :: AccPubKey -> [XPubKey] -> KeyIndex -> [([AddrPubKey],KeyIndex)] +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 +-- list of thirdparty multisig keys and a derivation index. +extMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe String +extMulSigAddr a ps r i = do + xs <- (map (xPubKey . getAddrPubKey)) <$> extMulSigKey a ps i + return $ addrToBase58 $ scriptAddr $ sortMulSig $ PayMulSig xs r + +-- | Computes an internal base58 multisig address from an 'AccPubKey', a +-- list of thirdparty multisig keys and a derivation index. +intMulSigAddr :: AccPubKey -> [XPubKey] -> Int -> KeyIndex -> Maybe String +intMulSigAddr a ps r i = do + xs <- (map (xPubKey . getAddrPubKey)) <$> intMulSigKey a ps i + return $ addrToBase58 $ scriptAddr $ sortMulSig $ PayMulSig xs r + +-- | Cyclic list of all external base58 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)] +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 +-- an 'AccPubKey' and a list of thirdparty multisig keys. The list starts +-- at an offset index. +intMulSigAddrs :: AccPubKey -> [XPubKey] -> Int -> KeyIndex + -> [(String,KeyIndex)] +intMulSigAddrs a ps r i = mapMaybe f $ cycleIndex i + where f j = liftM2 (,) (intMulSigAddr a ps r j) (return j) + diff --git a/Network/Haskoin/Crypto/NumberTheory.hs b/Network/Haskoin/Crypto/NumberTheory.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/NumberTheory.hs @@ -0,0 +1,23 @@ +module Network.Haskoin.Crypto.NumberTheory +( extendedModGCD +, mulInverse +) where + +-- Extended euclidean algorithm +-- Calculates the multiplicative inverse modulo p +extendedModGCD :: Integer -> Integer -> Integer -> (Integer, Integer) +extendedModGCD a b p + | b == 0 = (1,0) + | otherwise = (t, (s - q*t) `mod` p) + where + (q,r) = quotRem a b + (s,t) = extendedModGCD b r p + +-- Find multiplicative inverse of a : a*s = 1 (mod p) +mulInverse :: Integer -> Integer -> Integer +mulInverse a p + | a*s `mod` p == 1 = s + | otherwise = error "No multiplicative inverse (mod p) for a" + where + (s,_) = extendedModGCD a p p + diff --git a/Network/Haskoin/Crypto/Point.hs b/Network/Haskoin/Crypto/Point.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Crypto/Point.hs @@ -0,0 +1,147 @@ +module Network.Haskoin.Crypto.Point +( Point( InfPoint ) +, makePoint +, makeInfPoint +, getAffine, getX, getY +, validatePoint +, isInfPoint +, addPoint +, doublePoint +, mulPoint +, shamirsTrick +, curveB +, curveA +) where + +import Data.Bits (shiftR) +import Control.Applicative ((<$>)) + +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Crypto.BigWord + +curveA :: FieldP +curveA = fromInteger integerA + +curveB :: FieldP +curveB = fromInteger integerB + +{-| + Elliptic curves of the form y^2 = x^3 + 7 (mod p) + Point on the elliptic curve in transformed Jacobian coordinates + (X,Y,Z) such that (x,y) = (X/Z^2, Y/Z^3) + InfPoint is the point at infinity +-} +data Point = Point !FieldP !FieldP !FieldP | InfPoint + deriving (Show, Read) + +instance Eq Point where + InfPoint == InfPoint = True + (Point x1 y1 z1) == (Point x2 y2 z2) = a == b && c == d + where + a = x1*z2 ^ (2 :: Int) + b = x2*z1 ^ (2 :: Int) + c = y1*z2 ^ (3 :: Int) + d = y2*z1 ^ (3 :: Int) + _ == _ = False + +-- Create a new point from (x,y) coordinates. +-- Returns Nothing if the point doesn't lie on the curve +makePoint :: FieldP -> FieldP -> Maybe Point +makePoint x y + | validatePoint point = Just point + | otherwise = Nothing + where + point = Point x y 1 + +makeInfPoint :: Point +makeInfPoint = InfPoint + +-- Get the original (x,y) coordinates from the Jacobian triple (X,Y,Z) +getAffine :: Point -> Maybe (FieldP, FieldP) +getAffine point = case point of + InfPoint -> Nothing + (Point _ _ 0) -> Nothing + (Point x y z) -> Just (x/z ^ (2 :: Int), y/z ^ (3 :: Int)) + +getX :: Point -> Maybe FieldP +getX point = fst <$> (getAffine point) + +getY :: Point -> Maybe FieldP +getY point = snd <$> (getAffine point) + +-- Section 3.2.2.1 http://www.secg.org/download/aid-780/sec1-v2.pdf +-- point 3.2.2.1.4 is not necessary as h=1 +validatePoint :: Point -> Bool +validatePoint point = case getAffine point of + -- 3.2.2.1.1 (check that point not equal to InfPoint) + Nothing -> False + -- 3.2.2.1.2 (check that the point lies on the curve) + Just (x,y) -> y ^ (2 :: Int) == x ^ (3 :: Int) + (curveA * x) + curveB + +isInfPoint :: Point -> Bool +isInfPoint InfPoint = True +isInfPoint (Point _ _ 0) = True +isInfPoint _ = False + +-- Elliptic curve point addition +-- http://en.wikibooks.org/wiki/Cryptography/Prime_Curve/Jacobian_Coordinates +addPoint :: Point -> Point -> Point +addPoint InfPoint point = point +addPoint point InfPoint = point +addPoint p1@(Point x1 y1 z1) (Point x2 y2 z2) + | u1 == u2 = if s1 == s2 then doublePoint p1 else InfPoint + | otherwise = Point x3 y3 z3 + where + u1 = x1*z2 ^ (2 :: Int) + u2 = x2*z1 ^ (2 :: Int) + s1 = y1*z2 ^ (3 :: Int) + s2 = y2*z1 ^ (3 :: Int) + h = u2 - u1 + r = s2 - s1 + x3 = r ^ (2 :: Int) - h ^ (3 :: Int) - 2*u1*h ^ (2 :: Int) + y3 = r*(u1 * h ^ (2 :: Int) - x3) - s1 * h ^ (3 :: Int) + z3 = h * z1 * z2 + +-- Elliptic curve point doubling +-- http://en.wikibooks.org/wiki/Cryptography/Prime_Curve/Jacobian_Coordinates +doublePoint :: Point -> Point +doublePoint InfPoint = InfPoint +doublePoint (Point x y z) + | y == 0 = InfPoint + | otherwise = Point x' y' z' + where + s = 4*x*y ^ (2 :: Int) + m = 3*x ^ (2 :: Int) + curveA * z ^ (4 :: Int) + x' = m ^ (2 :: Int) - 2*s + y' = m*(s - x') - 8*y ^ (4 :: Int) + z' = 2*y*z + +-- Elliptic curve point multiplication +-- Double and add method (weak to side channel attacks) +-- http://en.wikipedia.org/wiki/Elliptic_curve_point_multiplication +mulPoint :: FieldN -> Point -> Point +mulPoint 0 _ = InfPoint +mulPoint 1 p = p +mulPoint _ InfPoint = InfPoint +mulPoint n p + | n == 0 = InfPoint + | odd n = addPoint p (mulPoint (n-1) p) + | otherwise = mulPoint (n `shiftR` 1) (doublePoint p) + +-- Efficiently compute r1*p1 + r2*p2 +shamirsTrick :: FieldN -> Point -> FieldN -> Point -> Point +shamirsTrick r1 p1 r2 p2 = go r1 r2 + where + q = addPoint p1 p2 + go 0 0 = InfPoint + go a b + | ea && eb = b2 + | ea = addPoint b2 p2 + | eb = addPoint b2 p1 + | otherwise = addPoint b2 q + where + b2 = doublePoint $ go (a `shiftR` 1) (b `shiftR` 1) + ea = even a + eb = even b + + diff --git a/Network/Haskoin/Protocol.hs b/Network/Haskoin/Protocol.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol.hs @@ -0,0 +1,99 @@ +{-| + This package provides all of the basic types used for the Bitcoin + networking protocol together with Data.Binary instances for efficiently + serializing and de-serializing them. More information on the bitcoin protocol + is available here: +-} +module Network.Haskoin.Protocol +( + -- * Blocks + Block(..) +, BlockLocator +, GetBlocks(..) + + -- * Block Headers +, BlockHeader(..) +, GetHeaders(..) +, Headers(..) +, BlockHeaderCount +, blockid + + -- * Requesting data +, GetData(..) +, Inv(..) +, InvVector(..) +, InvType(..) +, NotFound(..) + + -- *Scripts + -- | More informations on scripts is available here: + -- +, Script(..) +, ScriptOp(..) +, PushDataType(..) +, opPushData +, getScriptOps +, putScriptOps +, decodeScriptOps +, encodeScriptOps + + -- *Transactions +, Tx(..) +, txid +, cbid +, CoinbaseTx(..) +, TxIn(..) +, TxOut(..) +, OutPoint(..) +, encodeTxid +, decodeTxid + + -- * Merkle trees and bloom filters +, MerkleBlock(..) + + -- * Bloom Filter +, BloomFlags(..) +, BloomFilter(..) +, FilterLoad(..) +, FilterAdd(..) + + -- * Network types +, VarInt(..) +, VarString(..) +, NetworkAddress(..) +, Addr(..) +, NetworkAddressTime +, Version(..) +, Ping(..) +, Pong(..) +, Alert(..) + + -- *Messages +, Message(..) +, MessageHeader(..) +, MessageCommand(..) +) 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 + diff --git a/Network/Haskoin/Protocol/Addr.hs b/Network/Haskoin/Protocol/Addr.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Addr.hs @@ -0,0 +1,39 @@ +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) + diff --git a/Network/Haskoin/Protocol/Alert.hs b/Network/Haskoin/Protocol/Alert.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Alert.hs @@ -0,0 +1,21 @@ +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 + diff --git a/Network/Haskoin/Protocol/Block.hs b/Network/Haskoin/Protocol/Block.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Block.hs @@ -0,0 +1,38 @@ +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 + diff --git a/Network/Haskoin/Protocol/BlockHeader.hs b/Network/Haskoin/Protocol/BlockHeader.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/BlockHeader.hs @@ -0,0 +1,63 @@ +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' + diff --git a/Network/Haskoin/Protocol/BloomFilter.hs b/Network/Haskoin/Protocol/BloomFilter.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/BloomFilter.hs @@ -0,0 +1,101 @@ +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 + + diff --git a/Network/Haskoin/Protocol/GetBlocks.hs b/Network/Haskoin/Protocol/GetBlocks.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/GetBlocks.hs @@ -0,0 +1,53 @@ +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 + diff --git a/Network/Haskoin/Protocol/GetData.hs b/Network/Haskoin/Protocol/GetData.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/GetData.hs @@ -0,0 +1,34 @@ +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 + diff --git a/Network/Haskoin/Protocol/GetHeaders.hs b/Network/Haskoin/Protocol/GetHeaders.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/GetHeaders.hs @@ -0,0 +1,46 @@ +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 + diff --git a/Network/Haskoin/Protocol/Headers.hs b/Network/Haskoin/Protocol/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Headers.hs @@ -0,0 +1,36 @@ +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 + diff --git a/Network/Haskoin/Protocol/Inv.hs b/Network/Haskoin/Protocol/Inv.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Inv.hs @@ -0,0 +1,29 @@ +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 + diff --git a/Network/Haskoin/Protocol/InvVector.hs b/Network/Haskoin/Protocol/InvVector.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/InvVector.hs @@ -0,0 +1,54 @@ +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 + + diff --git a/Network/Haskoin/Protocol/MerkleBlock.hs b/Network/Haskoin/Protocol/MerkleBlock.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/MerkleBlock.hs @@ -0,0 +1,67 @@ +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]) + diff --git a/Network/Haskoin/Protocol/Message.hs b/Network/Haskoin/Protocol/Message.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Message.hs @@ -0,0 +1,120 @@ +module Network.Haskoin.Protocol.Message ( Message(..) ) where + +import Control.Monad (unless) +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( lookAhead + , getByteString + ) +import Data.Binary.Put (putByteString) +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.Util +import Network.Haskoin.Crypto.Hash + +-- | 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 +-- serialized with message headers. Serializing a 'Message' value will +-- include the 'MessageHeader' with the correct checksum value automatically. +-- No need to add the 'MessageHeader' separately. +data Message + = MVersion Version + | MVerAck + | MAddr Addr + | MInv Inv + | MGetData GetData + | MNotFound NotFound + | MGetBlocks GetBlocks + | MGetHeaders GetHeaders + | MTx Tx + | MBlock Block + | MHeaders Headers + | MGetAddr + | MFilterLoad FilterLoad + | MFilterAdd FilterAdd + | MFilterClear + | MPing Ping + | MPong Pong + | MAlert Alert + deriving (Eq, Show) + +instance Binary Message where + + get = do + (MessageHeader mgc cmd len chk) <- get + bs <- lookAhead $ getByteString $ fromIntegral len + unless (mgc == networkMagic) + (fail $ "get: Invalid network magic bytes: " ++ (show mgc)) + unless (chksum32 bs == chk) + (fail $ "get: Invalid message checksum: " ++ (show chk)) + if len > 0 + then isolate (fromIntegral len) $ case cmd of + MCVersion -> MVersion <$> get + MCAddr -> MAddr <$> get + MCInv -> MInv <$> get + MCGetData -> MGetData <$> get + MCNotFound -> MNotFound <$> get + MCGetBlocks -> MGetBlocks <$> get + MCGetHeaders -> MGetHeaders <$> get + MCTx -> MTx <$> get + MCBlock -> MBlock <$> get + MCHeaders -> MHeaders <$> get + MCFilterLoad -> MFilterLoad <$> get + MCFilterAdd -> MFilterAdd <$> get + MCPing -> MPing <$> get + MCPong -> MPong <$> get + MCAlert -> MAlert <$> get + _ -> fail $ "get: Invalid command " ++ (show cmd) + else case cmd of + MCGetAddr -> return MGetAddr + MCVerAck -> return MVerAck + MCFilterClear -> return MFilterClear + _ -> fail $ "get: Invalid command " ++ (show cmd) + + 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) + chk = chksum32 payload + len = fromIntegral $ BS.length payload + header = MessageHeader networkMagic cmd len chk + putByteString $ (encode' header) `BS.append` payload + diff --git a/Network/Haskoin/Protocol/MessageHeader.hs b/Network/Haskoin/Protocol/MessageHeader.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/MessageHeader.hs @@ -0,0 +1,134 @@ +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 + diff --git a/Network/Haskoin/Protocol/NetworkAddress.hs b/Network/Haskoin/Protocol/NetworkAddress.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/NetworkAddress.hs @@ -0,0 +1,45 @@ +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: +-- . 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 + diff --git a/Network/Haskoin/Protocol/NotFound.hs b/Network/Haskoin/Protocol/NotFound.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/NotFound.hs @@ -0,0 +1,30 @@ +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 + diff --git a/Network/Haskoin/Protocol/Ping.hs b/Network/Haskoin/Protocol/Ping.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Ping.hs @@ -0,0 +1,37 @@ +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 + diff --git a/Network/Haskoin/Protocol/Script.hs b/Network/Haskoin/Protocol/Script.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Script.hs @@ -0,0 +1,252 @@ +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 + diff --git a/Network/Haskoin/Protocol/Tx.hs b/Network/Haskoin/Protocol/Tx.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Tx.hs @@ -0,0 +1,194 @@ +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 + diff --git a/Network/Haskoin/Protocol/VarInt.hs b/Network/Haskoin/Protocol/VarInt.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/VarInt.hs @@ -0,0 +1,46 @@ +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 + diff --git a/Network/Haskoin/Protocol/VarString.hs b/Network/Haskoin/Protocol/VarString.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/VarString.hs @@ -0,0 +1,29 @@ +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 + diff --git a/Network/Haskoin/Protocol/Version.hs b/Network/Haskoin/Protocol/Version.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Version.hs @@ -0,0 +1,85 @@ +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 + diff --git a/Network/Haskoin/Script.hs b/Network/Haskoin/Script.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script.hs @@ -0,0 +1,56 @@ +{-| + This package provides functions for parsing and evaluating bitcoin + transaction scripts. Data types are provided for building and + deconstructing all of the standard input and output script types. +-} +module Network.Haskoin.Script +( + -- *Script Parsing + -- **Script Outputs + ScriptOutput(..) +, encodeOutput +, decodeOutput +, isPayPK +, isPayPKHash +, isPayMulSig +, isPayScriptHash +, scriptAddr +, sortMulSig + -- **Script Inputs +, ScriptInput(..) +, encodeInput +, decodeInput +, isSpendPK +, isSpendPKHash +, isSpendMulSig + -- **ScriptHash Inputs +, ScriptHashInput(..) +, RedeemScript +, encodeScriptHash +, decodeScriptHash + -- * Helpers +, scriptRecipient +, scriptSender +, intToScriptOp +, scriptOpToInt + +-- *SigHash +-- | For additional information on sighashes, see: +-- +, SigHash(..) +, txSigHash +, encodeSigHash32 +, isSigAll +, isSigNone +, isSigSingle +, isSigUnknown +, TxSignature(..) +, encodeSig +, decodeSig +, decodeCanonicalSig + +) where + +import Network.Haskoin.Script.Parser +import Network.Haskoin.Script.SigHash + diff --git a/Network/Haskoin/Script/Parser.hs b/Network/Haskoin/Script/Parser.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script/Parser.hs @@ -0,0 +1,287 @@ +module Network.Haskoin.Script.Parser +( ScriptOutput(..) +, ScriptInput(..) +, RedeemScript +, ScriptHashInput(..) +, scriptAddr +, scriptRecipient +, scriptSender +, encodeInput +, decodeInput +, encodeOutput +, decodeOutput +, encodeScriptHash +, decodeScriptHash +, sortMulSig +, intToScriptOp +, scriptOpToInt +, isPayPK +, isPayPKHash +, isPayMulSig +, isPayScriptHash +, isSpendPK +, isSpendPKHash +, isSpendMulSig +) where + +import Control.Monad (liftM2) +import Control.Applicative ((<$>),(<*>)) + +import Data.List (sortBy) +import qualified Data.ByteString as BS (head, singleton) + +import Network.Haskoin.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.SigHash + +-- | Data type describing standard transaction output scripts. Output scripts +-- provide the conditions that must be fulfilled for someone to spend the +-- output coins. +data ScriptOutput = + -- | Pay to a public key. + PayPK { getOutputPubKey :: !PubKey } + -- | Pay to a public key hash. + | PayPKHash { getOutputAddress :: !Address } + -- | Pay to multiple public keys. + | PayMulSig { getOutputMulSigKeys :: ![PubKey] + , getOutputMulSigRequired :: !Int + } + -- | Pay to a script hash. + | PayScriptHash { getOutputAddress :: !Address } + deriving (Eq, Show) + +-- | Returns True if the script is a pay to public key output. +isPayPK :: ScriptOutput -> Bool +isPayPK (PayPK _) = True +isPayPK _ = False + +-- | Returns True if the script is a pay to public key hash output. +isPayPKHash :: ScriptOutput -> Bool +isPayPKHash (PayPKHash _) = True +isPayPKHash _ = False + +-- | Returns True if the script is a pay to multiple public keys output. +isPayMulSig :: ScriptOutput -> Bool +isPayMulSig (PayMulSig _ _) = True +isPayMulSig _ = False + +-- | Returns true if the script is a pay to script hash output. +isPayScriptHash :: ScriptOutput -> Bool +isPayScriptHash (PayScriptHash _) = True +isPayScriptHash _ = False + +-- | Computes a script address from a script output. This address can be used +-- in a pay to script hash output. +scriptAddr :: ScriptOutput -> Address +scriptAddr = ScriptAddress . hash160 . hash256BS . toBS + where + toBS = encodeScriptOps . encodeOutput + +-- | Sorts the public keys of a multisignature output in ascending order by +-- comparing their serialized representations. This feature allows for easier +-- multisignature account management as participants in a multisignature wallet +-- will blindly agree on an ordering of the public keys without having to +-- communicate. +sortMulSig :: ScriptOutput -> ScriptOutput +sortMulSig out = case out of + PayMulSig keys r -> PayMulSig (sortBy f keys) r + _ -> error "Can only call orderMulSig on PayMulSig scripts" + where + f a b = encode' a `compare` encode' b + +-- | Computes a 'Script' from a 'ScriptOutput'. The 'Script' is a list of +-- 'ScriptOp' can can be used to build a 'Tx'. +encodeOutput :: ScriptOutput -> Script +encodeOutput s = Script $ case s of + -- Pay to PubKey + (PayPK k) -> [opPushData $ encode' k, OP_CHECKSIG] + -- Pay to PubKey Hash Address + (PayPKHash a) -> case a of + (PubKeyAddress h) -> [ OP_DUP, OP_HASH160, opPushData $ encode' h + , OP_EQUALVERIFY, OP_CHECKSIG + ] + (ScriptAddress _) -> + error "encodeOutput: ScriptAddress is invalid in PayPKHash" + -- Pay to MultiSig Keys + (PayMulSig ps r) + | r <= length ps -> + let opM = intToScriptOp r + opN = intToScriptOp $ length ps + keys = map (opPushData . encode') ps + in opM : keys ++ [opN, OP_CHECKMULTISIG] + | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" + -- Pay to Script Hash Address + (PayScriptHash a) -> case a of + (ScriptAddress h) -> [ OP_HASH160 + , opPushData $ encode' h, OP_EQUAL + ] + (PubKeyAddress _) -> + error "encodeOutput: PubKeyAddress is invalid in PayScriptHash" + +-- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the +-- script is not recognized as any of the standard output types. +decodeOutput :: Script -> Either String ScriptOutput +decodeOutput s = case scriptOps s of + -- Pay to PubKey + [OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> decodeToEither bs + -- Pay to PubKey Hash + [OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] -> + (PayPKHash . PubKeyAddress) <$> decodeToEither bs + -- Pay to Script Hash + [OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] -> + (PayScriptHash . ScriptAddress) <$> decodeToEither bs + -- Pay to MultiSig Keys + _ -> matchPayMulSig s + +-- Match [ OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG ] +matchPayMulSig :: Script -> Either String ScriptOutput +matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of + (m:xs,[n,OP_CHECKMULTISIG]) -> do + (intM,intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n) + if intM <= intN && length xs == intN + then liftM2 PayMulSig (go xs) (return intM) + else Left "matchPayMulSig: Invalid M or N parameters" + _ -> Left "matchPayMulSig: script did not match output template" + where + go (OP_PUSHDATA bs _:xs) = liftM2 (:) (decodeToEither bs) (go xs) + go [] = return [] + go _ = Left "matchPayMulSig: invalid multisig opcode" + +-- | Transforms integers [1 .. 16] to 'ScriptOp' [OP_1 .. OP_16] +intToScriptOp :: Int -> ScriptOp +intToScriptOp i + | i `elem` [1..16] = op + | otherwise = error $ "intToScriptOp: Invalid integer " ++ (show i) + where + op = decode' $ BS.singleton $ fromIntegral $ i + 0x50 + +-- | Decode 'ScriptOp' [OP_1 .. OP_16] to integers [1 .. 16]. This functions +-- fails for other values of 'ScriptOp' +scriptOpToInt :: ScriptOp -> Either String Int +scriptOpToInt s + | res `elem` [1..16] = return res + | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ (show s) + where + res = (fromIntegral $ BS.head $ encode' s) - 0x50 + +-- | Computes the recipient address of a script. This function fails if the +-- script could not be decoded as a pay to public key hash or pay to script +-- hash. +scriptRecipient :: Script -> Either String Address +scriptRecipient s = case decodeOutput s of + Right (PayPKHash a) -> return a + Right (PayScriptHash a) -> return a + Right _ -> Left "scriptRecipient: bad output script type" + _ -> Left "scriptRecipient: non-standard script type" + +-- | Computes the sender address of a script. This function fails if the +-- script could not be decoded as a spend public key hash or script hash +-- input. +scriptSender :: Script -> Either String Address +scriptSender s = case decodeInput s of + Right (SpendPKHash _ key) -> return $ pubKeyAddr key + Right _ -> Left "scriptSender: bad input script type" + _ -> case decodeScriptHash s of + Right (ScriptHashInput _ rdm) -> return $ scriptAddr rdm + _ -> Left "scriptSender: non-standard script type" + +-- | Data type describing standard transaction input scripts. Input scripts +-- provide the signing data required to unlock the coins of the output they are +-- trying to spend. +data ScriptInput = + -- | Spend the coins of a PayPK output. + SpendPK { getInputSig :: !TxSignature } + -- | Spend the coins of a PayPKHash output. + | SpendPKHash { getInputSig :: !TxSignature + , getInputKey :: !PubKey + } + -- | Spend the coins of a PayMulSig output. + | SpendMulSig { getInputMulSigKeys :: ![TxSignature] + , getInputMulSigRequired :: !Int + } + deriving (Eq, Show) + +-- | Returns True if the input script is spending a public key. +isSpendPK :: ScriptInput -> Bool +isSpendPK (SpendPK _) = True +isSpendPK _ = False + +-- | Returns True if the input script is spending a public key hash. +isSpendPKHash :: ScriptInput -> Bool +isSpendPKHash (SpendPKHash _ _) = True +isSpendPKHash _ = False + +-- | Returns True if the input script is spending a multisignature output. +isSpendMulSig :: ScriptInput -> Bool +isSpendMulSig (SpendMulSig _ _) = True +isSpendMulSig _ = False + +-- | Computes a 'Script' from a 'ScriptInput'. The 'Script' is a list of +-- 'ScriptOp' can can be used to build a 'Tx'. +encodeInput :: ScriptInput -> Script +encodeInput s = Script $ case s of + SpendPK ts -> [ 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" + +-- | Decodes a 'ScriptInput' from a 'Script'. This function fails if the +-- script can not be parsed as a standard script input. +decodeInput :: Script -> Either String ScriptInput +decodeInput s = case scriptOps s of + [OP_PUSHDATA bs _] -> SpendPK <$> decodeSig bs + [OP_PUSHDATA sig _, OP_PUSHDATA p _] -> + liftM2 SpendPKHash (decodeSig sig) (decodeToEither p) + (OP_0 : xs) -> matchSpendMulSig $ Script xs + _ -> Left "decodeInput: Script did not match input templates" + +matchSpendMulSig :: Script -> Either String ScriptInput +matchSpendMulSig (Script ops) = + liftM2 SpendMulSig (go ops) (return $ length ops) + where + go (OP_PUSHDATA bs _:xs) = liftM2 (:) (decodeSig bs) (go xs) + go (OP_0:xs) + | all (== OP_0) xs = return [] + | otherwise = Left "matchSpendMulSig: invalid opcode after OP_0" + go [] = return [] + go _ = Left "matchSpendMulSig: invalid multisig opcode" + +type RedeemScript = ScriptOutput + +-- | Data type describing an input script spending a pay to script hash +-- output. To spend a script hash output, an input script must provide +-- both a redeem script and a regular input script spending the redeem +-- script. +data ScriptHashInput = ScriptHashInput + { -- | Input script spending the redeem script + spendSHInput :: ScriptInput + -- | Redeem script + , spendSHOutput :: RedeemScript + } deriving (Eq, Show) + +-- | Compute a 'Script' from a 'ScriptHashInput'. The 'Script' is a list of +-- 'ScriptOp' can can be used to build a 'Tx'. +encodeScriptHash :: ScriptHashInput -> Script +encodeScriptHash (ScriptHashInput i o) = + Script $ (scriptOps si) ++ [opPushData $ encodeScriptOps so] + where + si = encodeInput i + so = encodeOutput o + +-- | Tries to decode a 'ScriptHashInput' from a 'Script'. This function fails +-- if the script can not be parsed as a script hash input. +decodeScriptHash :: Script -> Either String ScriptHashInput +decodeScriptHash (Script ops) = case splitAt (length ops - 1) ops of + (is,[OP_PUSHDATA bs _]) -> + ScriptHashInput <$> (decodeInput $ Script is) + <*> (decodeOutput =<< decodeScriptOps bs) + _ -> Left "decodeScriptHash: Script did not match input template" + diff --git a/Network/Haskoin/Script/SigHash.hs b/Network/Haskoin/Script/SigHash.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Script/SigHash.hs @@ -0,0 +1,199 @@ +module Network.Haskoin.Script.SigHash +( SigHash(..) +, encodeSigHash32 +, isSigAll +, isSigNone +, isSigSingle +, isSigUnknown +, txSigHash +, TxSignature(..) +, encodeSig +, decodeSig +, decodeCanonicalSig +) where + +import Control.Monad (liftM2) + +import Data.Word (Word8) +import Data.Bits (testBit, clearBit, setBit) +import Data.Maybe (fromMaybe) +import Data.Binary (Binary, get, put, getWord8, putWord8) +import qualified Data.ByteString as BS + ( ByteString + , index + , length + , last + , append + , pack + , splitAt + ) + +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.ECDSA +import Network.Haskoin.Protocol.Script +import Network.Haskoin.Protocol.Tx +import Network.Haskoin.Util + +-- | Data type representing the different ways a transaction can be signed. +-- When producing a signature, a hash of the transaction is used as the message +-- to be signed. The 'SigHash' parameter controls which parts of the +-- transaction are used or ignored to produce the transaction hash. The idea is +-- that if some part of a transaction is not used to produce the transaction +-- hash, then you can change that part of the transaction after producing a +-- signature without invalidating that signature. +-- +-- If the anyoneCanPay flag is True, then only the current input is signed. +-- Otherwise, all of the inputs of a transaction are signed. The default value +-- for anyoneCanPay is False. +data SigHash + -- | Sign all of the outputs of a transaction (This is the default value). + -- Changing any of the outputs of the transaction will invalidate the + -- signature. + = SigAll { anyoneCanPay :: Bool } + -- | Sign none of the outputs of a transaction. This allows anyone to + -- change any of the outputs of the transaction. + | SigNone { anyoneCanPay :: Bool } + -- | Sign only the output corresponding the the current transaction input. + -- You care about your own output in the transaction but you don't + -- care about any of the other outputs. + | SigSingle { anyoneCanPay :: Bool } + -- | Unrecognized sighash types will decode to SigUnknown. + | SigUnknown { anyoneCanPay :: Bool + , getSigCode :: Word8 + } + deriving (Eq, Show) + +-- | Returns True if the 'SigHash' has the value SigAll. +isSigAll :: SigHash -> Bool +isSigAll sh = case sh of + SigAll _ -> True + _ -> False + +-- | Returns True if the 'SigHash' has the value SigNone. +isSigNone :: SigHash -> Bool +isSigNone sh = case sh of + SigNone _ -> True + _ -> False + +-- | Returns True if the 'SigHash' has the value SigSingle. +isSigSingle :: SigHash -> Bool +isSigSingle sh = case sh of + SigSingle _ -> True + _ -> False + +-- | Returns True if the 'SigHash' has the value SigUnknown. +isSigUnknown :: SigHash -> Bool +isSigUnknown sh = case sh of + SigUnknown _ _ -> True + _ -> False + +instance Binary SigHash where + + get = getWord8 >>= \w -> + let acp = testBit w 7 + in return $ case clearBit w 7 of + 1 -> SigAll acp + 2 -> SigNone acp + 3 -> SigSingle acp + _ -> SigUnknown acp w + + put sh = putWord8 $ case sh of + SigAll acp -> if acp then 0x81 else 0x01 + SigNone acp -> if acp then 0x82 else 0x02 + SigSingle acp -> if acp then 0x83 else 0x03 + SigUnknown _ w -> w + +-- | Encodes a 'SigHash' to a 32 bit-long bytestring. +encodeSigHash32 :: SigHash -> BS.ByteString +encodeSigHash32 sh = encode' sh `BS.append` BS.pack [0,0,0] + +-- | Computes the hash that will be used for signing a transaction. +txSigHash :: Tx -- ^ Transaction to sign. + -> Script -- ^ Output script that is being spent. + -> Int -- ^ Index of the input that is being signed. + -> SigHash -- ^ What parts of the transaction should be signed. + -> Hash256 -- ^ Result hash to be signed. +txSigHash tx out i sh = do + let newIn = buildInputs (txIn tx) out i sh + -- When SigSingle and input index > outputs, then sign integer 1 + fromMaybe (setBit 0 248) $ do + newOut <- buildOutputs (txOut tx) i sh + let newTx = tx{ txIn = newIn, txOut = newOut } + return $ doubleHash256 $ encode' newTx `BS.append` encodeSigHash32 sh + +-- Builds transaction inputs for computing SigHashes +buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] +buildInputs txins out i sh + | anyoneCanPay sh = (txins !! i) { scriptInput = out } : [] + | isSigAll sh || isSigUnknown sh = single + | otherwise = map noSeq $ zip single [0..] + where + empty = map (\ti -> ti{ scriptInput = Script [] }) txins + single = updateIndex i empty $ \ti -> ti{ scriptInput = out } + noSeq (ti,j) = if i == j then ti else ti{ txInSequence = 0 } + +-- Build transaction outputs for computing SigHashes +buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] +buildOutputs txos i sh + | isSigAll sh || isSigUnknown sh = return txos + | isSigNone sh = return [] + | i >= length txos = Nothing + | otherwise = return $ buffer ++ [txos !! i] + where + buffer = replicate i $ TxOut (-1) $ Script [] + +-- | Data type representing a 'Signature' together with a 'SigHash'. The +-- 'SigHash' is serialized as one byte at the end of a regular ECDSA +-- 'Signature'. All signatures in transaction inputs are of type 'TxSignature'. +data TxSignature = TxSignature + { txSignature :: Signature + , sigHashType :: SigHash + } deriving (Eq, Show) + +-- | Serialize a 'TxSignature' to a ByteString. +encodeSig :: TxSignature -> BS.ByteString +encodeSig (TxSignature sig sh) = runPut' $ put sig >> put sh + +-- | Decode a 'TxSignature' from a ByteString. +decodeSig :: BS.ByteString -> Either String TxSignature +decodeSig bs = do + let (h,l) = BS.splitAt (BS.length bs - 1) bs + liftM2 TxSignature (decodeToEither h) (decodeToEither l) + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- | Decode a 'TxSignature' from a ByteString. This function will check if +-- the signature is canonical and fail if it is not. +decodeCanonicalSig :: BS.ByteString -> Either String TxSignature +decodeCanonicalSig bs + | len < 9 = Left "Non-canonical signature: too short" + | len > 73 = Left "Non-canonical signature: too long" + | hashtype < 1 || hashtype > 3 = + Left" Non-canonical signature: unknown hashtype byte" + | BS.index bs 0 /= 0x30 = Left "Non-canonical signature: wrong type" + | BS.index bs 1 /= len - 3 = + Left "Non-canonical signature: wrong length marker" + | 5 + rlen >= len = Left "Non-canonical signature: S length misplaced" + | rlen + slen + 7 /= len = + Left "Non-canonical signature: R+S length mismatch" + | BS.index bs 2 /= 0x02 = + Left "Non-canonical signature: R value type mismatch" + | rlen == 0 = Left "Non-canonical signature: R length is zero" + | testBit (BS.index bs 4) 7 = + Left "Non-canonical signature: R value negative" + | rlen > 1 && BS.index bs 4 == 0 && not (testBit (BS.index bs 5) 7) = + Left "Non-canonical signature: R value excessively padded" + | BS.index bs (fromIntegral rlen+4) /= 0x02 = + Left "Non-canonical signature: S value type mismatch" + | slen == 0 = Left "Non-canonical signature: S length is zero" + | testBit (BS.index bs (fromIntegral rlen+6)) 7 = + Left "Non-canonical signature: S value negative" + | slen > 1 && BS.index bs (fromIntegral rlen+6) == 0 + && not (testBit (BS.index bs (fromIntegral rlen+7)) 7) = + Left "Non-canonical signature: S value excessively padded" + | otherwise = decodeSig bs + where + len = fromIntegral $ BS.length bs + rlen = BS.index bs 3 + slen = BS.index bs (fromIntegral rlen + 5) + hashtype = clearBit (BS.last bs) 7 + diff --git a/Network/Haskoin/Stratum.hs b/Network/Haskoin/Stratum.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Stratum.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} +module Network.Haskoin.Stratum +( -- * Types + -- ** Bitcoin + Balance(..) +, Coin(..) +, TxHeight(..) + -- ** Stratum data +, 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 +) where + +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.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) + +-- | Bitcoin outpoint information. +data Coin = Coin + { coinOutPoint :: OutPoint -- ^ Coin data. + , coinTxHeight :: TxHeight -- ^ Transaction information. + , coinValue :: Word64 -- ^ Output vale. + } deriving (Show, Eq) + +-- | Balance information. +data Balance = Balance + { balConfirmed :: Word64 -- ^ Confirmed balance. + , balUnconfirmed :: Word64 -- ^ Unconfirmed balance. + } deriving (Show, Eq) + +-- | 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 } + 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) + +data StratumNotif + = NotifAddress { notifAddr :: Address, notifAddrStatus :: Hash256 } + deriving (Eq, Show) + +instance ToJSON StratumNotif where + toJSON (NotifAddress a t) = toJSON (a, hashToJSON 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 FromJSON Balance where + parseJSON (Object o) = do + c <- o .: "confirmed" + u <- o .: "unconfirmed" + return $ Balance c u + parseJSON _ = mzero + +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 ToJSON TxHeight where + toJSON x = object + [ "height" .= txHeightBlock x + , "tx_hash" .= txidToJSON (txHeightId x) + ] + +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 + +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) + ] + +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" + +-- | 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)) + +-- | 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 + +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 + +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 + +-- | 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 + +-- | 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 + +txidToJSON :: Hash256 -> Value +txidToJSON = String . pack . encodeTxid + +txToJSON :: Tx -> Value +txToJSON = String . pack . bsToHex . encode' + +txParse :: Value -> Parser Tx +txParse = withText "bitcoin transaction" $ + return . decode' . fromJust . hexToBS . unpack + +txidParse :: Value -> Parser Hash256 +txidParse = withText "transaction id" $ + return . fromJust . decodeTxid . unpack + +hashToJSON :: Hash256 -> Value +hashToJSON = String . pack . bsToHex . encode' + +hashParse :: Value -> Parser Hash256 +hashParse = withText "hash" $ return . decode' . fromJust . hexToBS . unpack diff --git a/Network/Haskoin/Stratum/Conduit.hs b/Network/Haskoin/Stratum/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Stratum/Conduit.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-} +module Network.Haskoin.Stratum.Conduit +( -- * Types + Session + -- * Functions +, initSession +, newReq +, newNotif +, reqSource +, resConduit +) where + +import Prelude hiding (lines, lookup, map, map, null) +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, readMVar, takeMVar) +import Control.Concurrent.Chan (Chan, getChanContents, newChan, writeChan) +import Control.Monad (unless) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Aeson (ToJSON, eitherDecode, encode) +import Data.Aeson.Types (Parser, parseEither) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy.Char8 (append, fromStrict, toStrict) +import Data.Conduit (Conduit, Source, ($=), (=$=), await, yield) +import Data.Conduit.List (sourceList, map) +import Data.IntMap.Strict (IntMap, delete, empty, insert, lookup, null) +import Network.Haskoin.Stratum.Message +import Network.Haskoin.Util (maybeToEither) + +-- | Parse JSON-RPC ResponseValue to expected Response data type. +type ResponseParser r e v = ResponseValue -> Parser (Response r e v) + +-- | Parse JSON-RPC RequestValue to expectedo Request data type. +type RequestParser j = RequestValue -> Parser (Request j) + +-- | Map of ids to result parsers. +type ParserMap r e v = IntMap (ResponseParser r e v) + +-- | Session state. +data Session q r e v j = Session + (Chan q) -- Requests to be sent. + (MVar Int) -- Last id of sent request. + (MVar (ParserMap r e v)) -- Map of parsers for response result data. + (Maybe (RequestParser j)) -- Parser for requests or notifications. + +-- | Create initial session. +initSession :: MonadIO m + => Maybe (RequestParser j) + -- ^ Parse incoming requests and notifications. + -- Keep connection open. + -> m (Session q r e v j) +initSession d = liftIO $ Session + <$> newChan + <*> newMVar 0 + <*> newMVar empty + <*> return d + +-- | Send a new request. Goes to a channel that is read from reqSource. +newReq :: MonadIO m + => Session q r e v j -- ^ Session state. + -> (Int -> q) -- ^ Request builder. + -> ResponseParser r e v -- ^ Parser for response. + -> m Int -- ^ Output ID of sent request. +newReq (Session rc iv pv _) f g = liftIO $ do + i <- (+1) <$> takeMVar iv + p <- takeMVar pv + putMVar pv (insert i g p) + putMVar iv i + writeChan rc (f i) + return i + +-- | New notification, or request with no id tracking. +newNotif :: MonadIO m + => Session q r e v j -- ^ Session state. + -> q -- ^ Request to send to the network. + -> m () -- ^ No meaningful output. +newNotif (Session rc _ _ _) v = liftIO $ writeChan rc v + +-- | Source of requests to send to the network. +reqSource :: (MonadIO m, ToJSON q) + => Session q r e v j -- ^ Session state. + -> Source m ByteString -- ^ Source with serialized requests. +reqSource (Session rc _ _ _) = do + rs <- liftIO $ getChanContents rc + sourceList rs $= map (toStrict . flip append "\n" . encode) + +-- | Conduit that parses messages from network. +resConduit :: (MonadIO m) + => Session q r e v j -- ^ Session state. + -> Conduit ByteString m (Either String (Message j r e v)) + -- ^ Returns Conduit with parsed data or parsing errors. +resConduit (Session _ _ pv d) = + stopOnNull pv (maybe True (const False) d) =$= decodeConduit pv d + +decodeConduit :: (MonadIO m) + => MVar (ParserMap r e v) + -> Maybe (RequestParser j) + -> Conduit ByteString m (Either String (Message j r e v)) +decodeConduit pv d = do + mx <- await + case mx of + Nothing -> return () + Just x -> do + p <- liftIO $ takeMVar pv + let m = decodeMsg p d x + case m of + Left e -> yield $ Left e + Right (i, t) -> case i of + Nothing -> do + liftIO $ putMVar pv p + yield $ Right t + Just n -> do + liftIO $ putMVar pv $ n `delete` p + yield $ Right t + decodeConduit pv d + +stopOnNull :: MonadIO m + => MVar (IntMap a) + -> Bool + -> Conduit i m i +stopOnNull pv d = do + b <- null <$> liftIO (readMVar pv) + unless (d && b) $ await >>= maybe e (\x -> yield x >> stopOnNull pv d) + where + e = error "Connection closed unexpectedly." + +decodeMsg :: ParserMap r e v + -> Maybe (RequestParser j) + -> ByteString + -> Either String (Maybe Int, Message j r e v) +decodeMsg p d x = do + y <- eitherDecode (fromStrict x) + case y of + MsgRequest r -> do + m <- case d of + Nothing -> Left "No parser for requests" + Just l -> parseEither l r + return $ (Nothing, MsgRequest m) + MsgResponse r -> do + (i, z) <- decodeRes p r + return $ (Just i, MsgResponse z) + +decodeRes :: ParserMap r e v + -> ResponseValue + -> Either String (Int, (Response r e v)) +decodeRes p r = do + i <- case resId r of + Just n -> numericId n + Nothing -> Left "Id is not set." + a <- maybeToEither (e i) (lookup i p) + t <- parseEither a r + return (i, t) + where + e i = "Parser not found for response id " ++ show i ++ "." diff --git a/Network/Haskoin/Stratum/Message.hs b/Network/Haskoin/Stratum/Message.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Stratum/Message.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Implementation of basic JSON-RPC data types. +module Network.Haskoin.Stratum.Message +( -- * Types + Method +, ErrorValue +, RequestValue +, ResponseValue +, MessageValue +, ResultValue +, Id(..) +, Result +, Error(..) + -- * Messages +, Request(..) +, Response(..) +, Message(..) + -- * Errors +, errParse +, errReq +, errMeth +, errParams +, errInternal +, errStr + -- * Helpers +, leftStr +, numericId +) where + +import Control.Applicative ((<|>)) +import Control.Monad (mzero) +import Data.Aeson.Types hiding (Result) +import Data.Text (Text, unpack) +import Text.Read (readEither) + +-- | JSON-RPC method name. +type Method = Text +-- | JSON-RPC result. +type Result r e v = Either (Error e v) r +-- | JSON-RPC error object with default JSON values. +type ErrorValue = Error Value String +-- | JSON-RPC request with default JSON values. +type RequestValue = Request Value +-- | JSON-RPC response with default JSON values. +type ResponseValue = Response Value Value String +-- | JSON-RPC request or response with default JSON values. +type MessageValue = Message Value Value Value String +-- | JSON-RPC result with default JSON values. +type ResultValue = Result Value Value String + +-- | JSON-RPC id in text or integer form. +data Id = IntId { intId :: Int } -- ^ Id in integer form. + | TxtId { txtId :: Text } -- ^ Id in string form (discouraged). + deriving (Eq, Show) + +-- | JSON-RPC error object in v1 or v2 format. +-- Sent inside a JSONRes in case of error. +data Error e v -- | Error object in JSON-RPC version 2 format. + = ErrObj + { errCode :: Int -- ^ Integer error code. + , errMsg :: String -- ^ Error message. + , errData :: Maybe e -- ^ Optional error object. + } + -- | Error object in JSON-RPC version 1 format. + | ErrVal + { errVal :: v -- ^ Usually String. + } + deriving (Eq, Show) + +-- | JSON-RPC request on notification. +data Request j = Request + { reqMethod :: Method -- ^ Request method. + , reqParams :: Maybe j -- ^ Request parameters. Should be Object or Array. + , reqId :: Maybe Id -- ^ Request id. Nothing for notifications. + } deriving (Eq, Show) + +-- | JSON-RPC response or error. +data Response r e v = Response + { resResult :: Result r e v -- ^ Result or error. + , resId :: Maybe Id -- ^ Result id. + } deriving (Eq, Show) + +-- | JSON-RPC message, can contain request or response. +data Message j r e v + -- | Request message container. + = MsgRequest (Request j) + -- | response message container. + | MsgResponse (Response r e v) + deriving (Eq, Show) + +instance FromJSON Id where + parseJSON (String s) = return (TxtId s) + parseJSON (Number n) = do + let (i, d) = properFraction n + if d == 0.0 then return (IntId i) else mzero + parseJSON _ = mzero + +instance ToJSON Id where + toJSON (TxtId s) = toJSON s + toJSON (IntId i) = toJSON i + +instance (FromJSON e, FromJSON v) => FromJSON (Error e v) where + parseJSON v@(Object o) = do + mc <- o .:? "code" + mm <- o .:? "message" + md <- o .:? "data" + case (mc, mm) of + (Just c, Just m) -> return (ErrObj c m md) + _ -> parseJSON v >>= return . ErrVal + parseJSON v = parseJSON v >>= return . ErrVal + +instance (ToJSON e, ToJSON v) => ToJSON (Error e v) where + toJSON (ErrObj c m d) = object + [ "code" .= c + , "message" .= m + , "data" .= d ] + toJSON (ErrVal v) = toJSON v + +instance FromJSON j => FromJSON (Request j) where + parseJSON (Object o) = do + m <- o .: "method" + p <- o .:? "params" + i <- o .:? "id" + return (Request m p i) + parseJSON _ = mzero + +instance ToJSON j => ToJSON (Request j) where + toJSON (Request m p i) = object $ filter f + [ "jsonrpc" .= ("2.0" :: String) + , "method" .= m + , "params" .= p + , "id" .= i ] + where + f (_, Null) = False + f _ = True + +instance (FromJSON r, FromJSON e, FromJSON v) + => FromJSON (Response r e v) + where + parseJSON (Object o) = do + mi <- o .: "id" + me <- o .:? "error" .!= Nothing + mr <- o .:? "result" .!= Nothing + case (me, mr) of + (Just e, _) -> return (Response (Left e) mi) + (_, Just r) -> return (Response (Right r) mi) + _ -> mzero + parseJSON _ = mzero + +instance (ToJSON r, ToJSON e, ToJSON v) + => ToJSON (Response r e v) + where + toJSON (Response (Right r) i) = object + [ "jsonrpc" .= ("2.0" :: String) + , "id" .= i + , "result" .= r + ] + toJSON (Response (Left e) i) = object + [ "jsonrpc" .= ("2.0" :: String) + , "id" .= i + , "error" .= e + ] + +instance (FromJSON j, FromJSON r, FromJSON e, FromJSON v) + => FromJSON (Message j r e v) + where + parseJSON o@(Object _) = q <|> s + where + q = parseJSON o >>= return . MsgRequest + s = parseJSON o >>= return . MsgResponse + parseJSON _ = mzero + +instance (ToJSON j, ToJSON r, ToJSON e, ToJSON v) + => ToJSON (Message j r e v) + where + toJSON (MsgRequest r) = toJSON r + toJSON (MsgResponse r) = toJSON r + +-- | Parse error in JSON-RPC v2 format. +-- Provide optional error object. +errParse :: ToJSON e => Maybe e -> Error e v +errParse = ErrObj (-32700) "Parse error" + +-- | Request error in JSON-RPC v2 format. +-- Provide optional error object. +errReq :: ToJSON e => Maybe e -> Error e v +errReq = ErrObj (-32600) "Invalid request" + +-- | Unknown method error in JSON-RPC v2 format. +-- Provide optional error object. +errMeth :: ToJSON e => Maybe e -> Error e v +errMeth = ErrObj (-32601) "Method not found" + +-- | Invalid parameters error in JSON-RPC v2 format. +-- Provide optional error object. +errParams :: ToJSON e => Maybe e -> Error e v +errParams = ErrObj (-32602) "Invalid params" + +-- | Internal error in JSON-RPC v2 format. +-- Provide optional error object. +errInternal :: ToJSON e => Maybe e -> Error e v +errInternal = ErrObj (-32606) "Internal error" + +-- | Get string from error object. +errStr :: Error e Value -> String +errStr (ErrObj _ m _) = m +errStr (ErrVal v) = either id id . flip parseEither v $ + withText "error string" (return . unpack) + +-- | Map Left error objects to strings. +leftStr :: Either (Error e Value) r -> Either String r +leftStr (Left e) = Left (errStr e) +leftStr (Right r) = Right r + +-- | Force an id into a number or fail if not possible. +numericId :: Id -> Either String Int +numericId (IntId i) = Right i +numericId (TxtId t) = readEither $ unpack t diff --git a/Network/Haskoin/Transaction.hs b/Network/Haskoin/Transaction.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Transaction.hs @@ -0,0 +1,26 @@ +{-| + This package provides functions for building and signing both simple + transactions and multisignature transactions. +-} +module Network.Haskoin.Transaction +( + -- *Build Transactions + buildTx +, buildAddrTx + + -- *Transaction signing +, SigInput(..) +, signTx +, detSignTx +, isTxComplete + + -- *Coin selection +, Coin(..) +, chooseCoins +, chooseMSCoins +, guessTxSize + +) where + +import Network.Haskoin.Transaction.Builder + diff --git a/Network/Haskoin/Transaction/Builder.hs b/Network/Haskoin/Transaction/Builder.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Transaction/Builder.hs @@ -0,0 +1,362 @@ +module Network.Haskoin.Transaction.Builder +( Coin(..) +, buildTx +, buildAddrTx +, SigInput(..) +, signTx +, detSignTx +, verifyTx +, guessTxSize +, chooseCoins +, chooseMSCoins +, getFee +, getMSFee +, isTxComplete +) where + +import Control.Monad (when, guard, liftM2) +import Control.Applicative ((<$>)) +import Control.Monad.Trans (lift) + +import Data.Maybe (catMaybes, maybeToList, fromMaybe) +import Data.List (sortBy, find) +import Data.Word (Word64) +import qualified Data.ByteString as BS (length, replicate) + +import Network.Haskoin.Util +import Network.Haskoin.Crypto +import Network.Haskoin.Protocol +import Network.Haskoin.Script + +-- | A Coin is something that can be spent by a transaction and is +-- represented by a transaction output, an outpoint and optionally a +-- redeem script. +data Coin = + Coin { coinTxOut :: TxOut -- ^ Transaction output + , coinOutPoint :: OutPoint -- ^ Previous outpoint + , coinRedeem :: Maybe Script -- ^ Redeem script + } deriving (Eq, Show) + +-- | Coin selection algorithm for normal (non-multisig) transactions. This +-- function returns the selected coins together with the amount of change to +-- send back to yourself, taking the fee into account. +chooseCoins :: Word64 -- ^ Target price to pay. + -> Word64 -- ^ Fee price per 1000 bytes. + -> [Coin] -- ^ List of coins to choose from. + -> Either String ([Coin],Word64) + -- ^ Coin selection result and change amount. +chooseCoins target kbfee xs + | target > 0 = maybeToEither err $ greedyAdd target (getFee kbfee) xs + | otherwise = Left "chooseCoins: Target must be > 0" + where err = "chooseCoins: No solution found" + +-- | Coin selection algorithm for multisignature transactions. This function +-- returns the selected coins together with the amount of change to send back +-- to yourself, taking the fee into account. This function assumes all the +-- coins are script hash outputs that send funds to a multisignature address. +chooseMSCoins :: Word64 -- ^ Target price to pay. + -> Word64 -- ^ Fee price per 1000 bytes. + -> (Int,Int) -- ^ Multisig parameters m of n (m,n). + -> [Coin] -- ^ List of coins to choose from. + -> Either String ([Coin],Word64) + -- ^ Coin selection result and change amount. +chooseMSCoins target kbfee ms xs + | target > 0 = maybeToEither err $ greedyAdd target (getMSFee kbfee ms) xs + | otherwise = Left "chooseMSCoins: Target must be > 0" + where err = "chooseMSCoins: No solution found" + +-- Select coins greedily by starting from an empty solution +greedyAdd :: Word64 -> (Int -> Word64) -> [Coin] -> Maybe ([Coin],Word64) +greedyAdd target fee xs = go [] 0 [] 0 $ sortBy desc xs + where desc a b = compare (outValue $ coinTxOut b) (outValue $ coinTxOut a) + goal c = target + fee c + go _ _ [] _ [] = Nothing + go _ _ ps pTot [] = return (ps,pTot - (goal $ length ps)) + go acc aTot ps pTot (y:ys) + | val + aTot >= (goal $ length acc + 1) = + if aTot + val - target < pTot - target + then go [] 0 (y:acc) (aTot + val) ys + else return (ps,pTot - (goal $ length ps)) + | otherwise = go (y:acc) (aTot + val) ps pTot ys + where val = outValue $ coinTxOut y + +{- +-- Start from a solution containing all coins and greedily remove them +greedyRem :: Word64 -> (Int -> Word64) -> [Coin] -> Maybe ([Coin],Word64) +greedyRem target fee xs + | s < goal (length xs) = Nothing + | otherwise = return $ go [] s $ sortBy desc xs + where desc a b = compare (outValue $ coinTxOut b) (outValue $ coinTxOut a) + s = sum $ map (outValue . coinTxOut) xs + goal c = target + fee c + go acc tot [] = (acc,tot - (goal $ length acc)) + go acc tot (y:ys) + | tot - val >= (goal $ length ys + length acc) = + go acc (tot - val) ys + | otherwise = go (y:acc) tot ys + where val = outValue $ coinTxOut y +-} + +getFee :: Word64 -> Int -> Word64 +getFee kbfee count = kbfee*((len + 999) `div` 1000) + where len = fromIntegral $ guessTxSize count [] 2 0 + +getMSFee :: Word64 -> (Int,Int) -> Int -> Word64 +getMSFee kbfee ms count = kbfee*((len + 999) `div` 1000) + where len = fromIntegral $ guessTxSize 0 (replicate count ms) 2 0 + +-- | Computes an upper bound on the size of a transaction based on some known +-- properties of the transaction. +guessTxSize :: Int -- ^ Number of regular transaction inputs. + -> [(Int,Int)] + -- ^ For every multisig input in the transaction, provide + -- the multisig parameters m of n (m,n) for that input. + -> Int -- ^ Number of pay to public key hash outputs. + -> Int -- ^ Number of pay to script hash outputs. + -> Int -- ^ Upper bound on the transaction size. +guessTxSize pki msi pkout msout = 8 + inpLen + inp + outLen + out + where inpLen = BS.length $ encode' $ + VarInt $ fromIntegral $ (length msi) + pki + outLen = BS.length $ encode' $ + VarInt $ fromIntegral $ pkout + msout + inp = pki*148 + (sum $ map guessMSSize msi) + -- (20: hash160) + (5: opcodes) + + -- (1: script len) + (8: Word64) + out = pkout*34 + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + msout*32 + +-- Size of a multisig pay2sh input +guessMSSize :: (Int,Int) -> Int + -- OutPoint (36) + Sequence (4) + Script +guessMSSize (m,n) = 40 + (BS.length $ encode' $ VarInt $ fromIntegral scp) + scp + -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG + where rdm = BS.length $ encode' $ opPushData $ BS.replicate (n*34 + 3) 0 + -- Redeem + m*sig + OP_0 + scp = rdm + m*73 + 1 + +{- Build a new Tx -} + +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of recipients addresses and amounts as outputs. +buildAddrTx :: [OutPoint] -> [(String,Word64)] -> Either String Tx +buildAddrTx xs ys = buildTx xs =<< mapM f ys + where f (s,v) = case base58ToAddr s of + Just a@(PubKeyAddress _) -> return (PayPKHash a,v) + Just a@(ScriptAddress _) -> return (PayScriptHash a,v) + _ -> Left $ "buildAddrTx: Invalid address " ++ s + +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of 'ScriptOutput' and amounts as outputs. +buildTx :: [OutPoint] -> [(ScriptOutput,Word64)] -> Either String Tx +buildTx xs ys = mapM fo ys >>= \os -> return $ Tx 1 (map fi xs) os 0 + where fi outPoint = TxIn outPoint (Script []) maxBound + fo (o,v) | v <= 2100000000000000 = return $ TxOut v $ encodeOutput o + | otherwise = Left $ "buildTx: Invalid amount " ++ (show v) + +-- | Data type used to specify the signing parameters of a transaction input. +-- To sign an input, the previous output script, outpoint and sighash are +-- required. When signing a pay to script hash output, an additional redeem +-- script is required. +data SigInput + -- | Parameters for signing a pay to public key hash output. + = SigInput { sigDataOut :: Script -- ^ Output script to spend. + , sigDataOP :: OutPoint + -- ^ Reference to the transaction output to spend. + , sigDataSH :: SigHash -- ^ Signature type. + } + -- | Parameters for signing a pay to script hash output. + | SigInputSH { sigDataOut :: Script + , sigDataOP :: OutPoint + , sigRedeem :: Script -- ^ Redeem script. + , sigDataSH :: SigHash + } deriving (Eq, Show) + +liftSecret :: Monad m => Build a -> SecretT (BuildT m) a +liftSecret = lift . liftBuild + +-- | Returns True if all the inputs of a transactions are non-empty and if +-- all multisignature inputs are fully signed. +isTxComplete :: Tx -> Bool +isTxComplete = isComplete . (mapM toBuildTxIn) . txIn + +-- | Sign a transaction by providing the 'SigInput' signing parameters and a +-- list of private keys. The signature is computed within the 'SecretT' monad +-- to generate the random signing nonce and within the 'BuildT' monad to add +-- information on wether the result was fully or partially signed. +signTx :: Monad m + => Tx -- ^ Transaction to sign + -> [SigInput] -- ^ SigInput signing parameters + -> [PrvKey] -- ^ List of private keys to use for signing + -> SecretT (BuildT m) Tx -- ^ Signed transaction +signTx tx@(Tx _ ti _ _) sigis keys = do + liftSecret $ when (null ti) $ Broken "signTx: Transaction has no inputs" + newIn <- mapM sign $ orderSigInput ti sigis + return tx{ txIn = newIn } + where sign (maybeSI,txin,i) = case maybeSI of + Just sigi -> signTxIn txin sigi tx i keys + _ -> liftSecret $ toBuildTxIn txin + +signTxIn :: Monad m => TxIn -> SigInput -> Tx -> Int -> [PrvKey] + -> SecretT (BuildT m) TxIn +signTxIn txin sigi tx i keys = do + (out,vKeys,pubs,buildf) <- liftSecret $ decodeSigInput sigi keys + let msg = txSigHash tx (encodeOutput out) i sh + sigs <- mapM (signMsg msg) vKeys + liftSecret $ buildf txin tx out i pubs $ map (flip TxSignature sh) sigs + where sh = sigDataSH sigi + +-- | Sign a transaction by providing the 'SigInput' signing paramters and +-- a list of private keys. The signature is computed deterministically as +-- defined in RFC-6979. The signature is computed within the 'Build' monad +-- to add information on wether the result was fully or partially signed. +detSignTx :: Tx -- ^ Transaction to sign + -> [SigInput] -- ^ SigInput signing parameters + -> [PrvKey] -- ^ List of private keys to use for signing + -> Build Tx -- ^ Signed transaction +detSignTx tx@(Tx _ ti _ _) sigis keys = do + when (null ti) $ Broken "detSignTx: Transaction has no inputs" + newIn <- mapM sign $ orderSigInput ti sigis + return tx{ txIn = newIn } + where + sign (maybeSI,txin,i) + | isComplete txinB = txinB + | otherwise = case maybeSI of + Just sigi -> detSignTxIn txin sigi tx i keys + _ -> txinB + where + txinB = toBuildTxIn txin + +detSignTxIn :: TxIn -> SigInput -> Tx -> Int -> [PrvKey] -> Build TxIn +detSignTxIn txin sigi tx i keys = do + (out,vKeys,pubs,buildf) <- decodeSigInput sigi keys + let msg = txSigHash tx (encodeOutput out) i sh + sigs = map (detSignMsg msg) vKeys + buildf txin tx out i pubs $ map (flip TxSignature sh) sigs + where sh = sigDataSH sigi + +{- Helpers for signing transactions -} + +-- |Decides if a TxIn is complete. If the TxIn could not be decoded and it +-- is not empty, we consider it complete. +toBuildTxIn :: TxIn -> Build TxIn +toBuildTxIn txin@(TxIn _ s _) + | null $ scriptOps s = Partial txin + | otherwise = case decodeScriptHash s of + Right (ScriptHashInput (SpendMulSig xs r) _) -> + guardPartial (length xs == r) >> return txin + Right _ -> return txin + Left _ -> case decodeInput s of + Right (SpendMulSig xs r) -> + guardPartial (length xs == r) >> return txin + _ -> return txin + +orderSigInput :: [TxIn] -> [SigInput] -> [(Maybe SigInput, TxIn, Int)] +orderSigInput ti si = zip3 (matchTemplate si ti f) ti [0..] + where f s txin = sigDataOP s == prevOutput txin + +type BuildFunction = TxIn -> Tx -> ScriptOutput -> Int + -> [PubKey] -> [TxSignature] -> Build TxIn + +decodeSigInput :: SigInput -> [PrvKey] -> + Build (ScriptOutput, [PrvKey], [PubKey], BuildFunction) +decodeSigInput sigi keys = case sigi of + SigInput s _ _ -> do + out <- eitherToBuild $ decodeOutput s + (vKeys,pubs) <- sigKeys out keys + return (out,vKeys,pubs,buildTxIn) + SigInputSH s _ sr _ -> do + out <- eitherToBuild $ decodeOutput s + rdm <- eitherToBuild $ decodeOutput sr + (vKeys,pubs) <- sigKeysSH out rdm keys + return (rdm,vKeys,pubs,buildTxInSH) + +buildTxInSH :: BuildFunction +buildTxInSH txin tx rdm i pubs sigs = do + s <- scriptInput <$> buildTxIn txin tx rdm i pubs sigs + res <- either emptyIn return $ + encodeScriptHash . (flip ScriptHashInput rdm) <$> decodeInput s + return txin{ scriptInput = res } + where emptyIn = const $ Partial $ Script [] + +buildTxIn :: BuildFunction +buildTxIn txin tx out i pubs sigs + | null sigs = Partial txin{ scriptInput = Script [] } + | otherwise = buildRes <$> case out of + PayPK _ -> return $ SpendPK $ head sigs + PayPKHash _ -> return $ SpendPKHash (head sigs) (head pubs) + PayMulSig msPubs r -> do + let mSigs = take r $ catMaybes $ matchTemplate aSigs msPubs f + guardPartial $ length mSigs == r + return $ SpendMulSig mSigs r + _ -> Broken "buildTxIn: Can't sign a P2SH script here" + where buildRes res = txin{ scriptInput = encodeInput res } + aSigs = concat + [ sigs + , case decodeScriptHash $ scriptInput txin of + Right (ScriptHashInput (SpendMulSig xs _) _) -> xs + _ -> case decodeInput $ scriptInput txin of + Right (SpendMulSig xs _) -> xs + _ -> [] + ] + f (TxSignature sig sh) pub = + verifySig (txSigHash tx (encodeOutput out) i sh) sig pub + +sigKeysSH :: ScriptOutput -> RedeemScript -> [PrvKey] + -> Build ([PrvKey],[PubKey]) +sigKeysSH out rdm keys = case out of + PayScriptHash a -> if scriptAddr rdm == a + then sigKeys rdm keys + else Broken "sigKeys: Redeem script does not match P2SH script" + _ -> Broken "sigKeys: Can only decode P2SH script here" + +sigKeys :: ScriptOutput -> [PrvKey] -> Build ([PrvKey],[PubKey]) +sigKeys out keys = unzip <$> case out of + PayPK p -> return $ maybeToList $ + find ((== p) . snd) zipKeys + PayPKHash a -> return $ maybeToList $ + find ((== a) . pubKeyAddr . snd) zipKeys + PayMulSig ps r -> return $ take r $ + filter ((`elem` ps) . snd) zipKeys + _ -> Broken "sigKeys: Can't decode P2SH here" + where zipKeys = zip keys $ map derivePubKey keys + +{- Tx verification -} + +-- This is not the final transaction verification function. It is here mainly +-- as a helper for tests. It can only validates standard inputs. +verifyTx :: Tx -> [(Script,OutPoint)] -> Bool +verifyTx tx xs = flip all z3 $ \(maybeS,txin,i) -> fromMaybe False $ do + (out,inp) <- maybeS >>= flip decodeVerifySigInput txin + let so = encodeOutput out + case (out,inp) of + (PayPK pub,SpendPK (TxSignature sig sh)) -> + return $ verifySig (txSigHash tx so i sh) sig pub + (PayPKHash a,SpendPKHash (TxSignature sig sh) pub) -> do + guard $ pubKeyAddr pub == a + return $ verifySig (txSigHash tx so i sh) sig pub + (PayMulSig pubs r,SpendMulSig sigs _) -> + (== r) <$> countMulSig tx so i pubs sigs + _ -> Nothing + where m = map (fst <$>) $ matchTemplate xs (txIn tx) f + f (_,o) txin = o == prevOutput txin + z3 = zip3 m (txIn tx) [0..] + +-- Count the number of valid signatures +countMulSig :: Tx -> Script -> Int -> [PubKey] -> [TxSignature] -> Maybe Int +countMulSig _ _ _ [] _ = return 0 +countMulSig _ _ _ _ [] = return 0 +countMulSig tx so i (pub:pubs) sigs@(TxSignature sig sh:rest) + | verifySig (txSigHash tx so i sh) sig pub = + (+1) <$> countMulSig tx so i pubs rest + | otherwise = countMulSig tx so i pubs sigs + +decodeVerifySigInput :: Script -> TxIn -> Maybe (ScriptOutput, ScriptInput) +decodeVerifySigInput so (TxIn _ si _ ) = case decodeOutput so of + Right (PayScriptHash a) -> do + (ScriptHashInput inp rdm) <- eitherToMaybe $ decodeScriptHash si + guard $ scriptAddr rdm == a + return (rdm,inp) + out -> eitherToMaybe $ liftM2 (,) out (decodeInput si) + diff --git a/Network/Haskoin/Util.hs b/Network/Haskoin/Util.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util.hs @@ -0,0 +1,332 @@ +{-| + This module defines various utility functions used across the + Network.Haskoin modules. +-} +module Network.Haskoin.Util +( + -- * ByteString helpers + toStrictBS +, toLazyBS +, stringToBS +, bsToString +, bsToInteger +, integerToBS +, bsToHex +, hexToBS + + -- * Data.Binary helpers +, encode' +, decode' +, runPut' +, runGet' +, decodeOrFail' +, runGetOrFail' +, fromDecode +, fromRunGet +, decodeToEither +, decodeToMaybe +, isolate + + -- * Maybe and Either monad helpers +, isLeft +, isRight +, fromRight +, fromLeft +, eitherToMaybe +, maybeToEither +, liftEither +, liftMaybe + + -- * Various helpers +, updateIndex +, matchTemplate + + -- Triples +, fst3 +, snd3 +, lst3 + + -- *Build monad +, Build(..) +, isComplete +, isPartial +, isBroken +, eitherToBuild +, buildToEither +, guardPartial + + -- *BuildT transformer monad +, BuildT(..) +, liftBuild + + -- *Constants +, addrPrefix +, scriptPrefix +, secretPrefix +, extPubKeyPrefix +, extSecretPrefix +, networkMagic +, genesisHeader +, maxBlockSize +, walletFile +, haskoinUserAgent + +) where + +import Numeric (readHex) +import Control.Applicative ((<$>)) +import Control.Monad (guard) +import Control.Monad.Trans.Either (EitherT, hoistEither) +import Text.Printf (printf) + +import Data.Monoid (mappend) +import Data.Word (Word8) +import Data.Bits ((.|.), shiftL, shiftR) +import Data.List (unfoldr) +import Data.List.Split (chunksOf) +import Data.Binary.Put (Put, runPut) +import Data.Binary + ( Binary + , encode + , decode + , decodeOrFail + ) +import Data.Binary.Get + ( Get + , runGetOrFail + , getByteString + , ByteOffset + , runGet + ) + +import qualified Data.ByteString.Lazy as BL + ( ByteString + , toChunks + , fromChunks + ) +import qualified Data.ByteString as BS + ( ByteString + , concat + , pack, unpack + , foldl' + , null + ) +import qualified Data.ByteString.Char8 as C + ( pack + , unpack + ) + +import Network.Haskoin.Util.BuildMonad +import Network.Haskoin.Util.Constants + +-- ByteString helpers + +-- | Transforms a lazy bytestring into a strict bytestring +toStrictBS :: BL.ByteString -> BS.ByteString +toStrictBS = BS.concat . BL.toChunks + +-- | Transforms a strict bytestring into a lazy bytestring +toLazyBS :: BS.ByteString -> BL.ByteString +toLazyBS bs = BL.fromChunks [bs] + +-- | Transforms a string into a strict bytestring +stringToBS :: String -> BS.ByteString +stringToBS = C.pack + +-- | Transform a strict bytestring to a string +bsToString :: BS.ByteString -> String +bsToString = C.unpack + +-- | Decode a big endian Integer from a bytestring +bsToInteger :: BS.ByteString -> Integer +bsToInteger = (foldr f 0) . reverse . BS.unpack + where + f w n = (toInteger w) .|. shiftL n 8 + +-- | Encode an Integer to a bytestring as big endian +integerToBS :: Integer -> BS.ByteString +integerToBS 0 = BS.pack [0] +integerToBS i + | i > 0 = BS.pack $ reverse $ unfoldr f i + | otherwise = error "integerToBS not defined for negative values" + where + f 0 = Nothing + f x = Just $ (fromInteger x :: Word8, x `shiftR` 8) + +-- | Encode a bytestring to a base16 (HEX) representation +bsToHex :: BS.ByteString -> String +bsToHex = BS.foldl' (\a x -> mappend a (printf "%02x" x)) "" + +-- | Decode a base16 (HEX) string from a bytestring. This function can fail +-- if the string contains invalid HEX characters +hexToBS :: String -> Maybe BS.ByteString +hexToBS xs = BS.pack <$> mapM hexWord (chunksOf 2 xs) + where + hexWord x = do + guard $ length x == 2 + let (w, s) = head $ readHex x + guard $ s == "" + return w + +-- Data.Binary helpers + +-- | Strict version of @Data.Binary.encode@ +encode' :: Binary a => a -> BS.ByteString +encode' = toStrictBS . encode + +-- | Strict version of @Data.Binary.decode@ +decode' :: Binary a => BS.ByteString -> a +decode' = decode . toLazyBS + +-- | Strict version of @Data.Binary.runGet@ +runGet' :: Binary a => Get a -> BS.ByteString -> a +runGet' m = (runGet m) . toLazyBS + +-- | Strict version of @Data.Binary.runPut@ +runPut' :: Put -> BS.ByteString +runPut' = toStrictBS . runPut + +-- | Strict version of @Data.Binary.decodeOrFail@ +decodeOrFail' :: + Binary a => + BS.ByteString -> + Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) +decodeOrFail' bs = case decodeOrFail $ toLazyBS bs of + Left (lbs,o,err) -> Left (toStrictBS lbs,o,err) + Right (lbs,o,res) -> Right (toStrictBS lbs,o,res) + +-- | Strict version of @Data.Binary.runGetOrFail@ +runGetOrFail' :: + Binary a => Get a -> BS.ByteString -> + Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) +runGetOrFail' m bs = case runGetOrFail m $ toLazyBS bs of + Left (lbs,o,err) -> Left (toStrictBS lbs,o,err) + Right (lbs,o,res) -> Right (toStrictBS lbs,o,res) + +-- | Try to decode a Data.Binary value. If decoding succeeds, apply the function +-- to the result. Otherwise, return the default value. +fromDecode :: Binary a + => BS.ByteString -- ^ The bytestring to decode + -> b -- ^ Default value to return when decoding fails + -> (a -> b) -- ^ Function to apply when decoding succeeds + -> b -- ^ Final result +fromDecode bs def f = either (const def) (f . lst) $ decodeOrFail' bs + where + lst (_,_,c) = c + +-- | Try to run a Data.Binary.Get monad. If decoding succeeds, apply a function +-- to the result. Otherwise, return the default value. +fromRunGet :: Binary a + => Get a -- ^ The Get monad to run + -> BS.ByteString -- ^ The bytestring to decode + -> b -- ^ Default value to return when decoding fails + -> (a -> b) -- ^ Function to apply when decoding succeeds + -> b -- ^ Final result +fromRunGet m bs def f = either (const def) (f . lst) $ runGetOrFail' m bs + where + lst (_,_,c) = c + +-- | Decode a Data.Binary value into the Either monad. A Right value is returned +-- with the result upon success. Otherwise a Left value with the error message +-- is returned. +decodeToEither :: Binary a => BS.ByteString -> Either String a +decodeToEither bs = case decodeOrFail' bs of + Left (_,_,err) -> Left err + Right (_,_,res) -> Right res + +-- | Decode a Data.Binary value into the Maybe monad. A Just value is returned +-- with the result upon success. Otherwise, Nothing is returned. +decodeToMaybe :: Binary a => BS.ByteString -> Maybe a +decodeToMaybe bs = fromDecode bs Nothing Just + +-- | Isolate a Data.Binary.Get monad for the next @Int@ bytes. Only the next +-- @Int@ bytes of the input bytestring will be available for the Get monad to +-- consume. This function will fail if the Get monad fails or some of the input +-- is not consumed. +isolate :: Binary a => Int -> Get a -> Get a +isolate i g = do + bs <- getByteString i + case runGetOrFail' g bs of + Left (_, _, err) -> fail err + Right (unconsumed, _, res) + | BS.null unconsumed -> return res + | otherwise -> fail "Isolate: unconsumed input" + +-- Maybe and Eithre monad helpers + +-- | Returns True if the Either value is Right +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + +-- | Returns True if the Either value is Left +isLeft :: Either a b -> Bool +isLeft = not . isRight + +-- | Extract the Right value from an Either value. Fails if the value is Left +fromRight :: Either a b -> b +fromRight (Right b) = b +fromRight _ = error "Either.fromRight: Left" + +-- | Extract the Left value from an Either value. Fails if the value is Right +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "Either.fromLeft: Right" + +-- | Transforms an Either value into a Maybe value. Right is mapped to Just +-- and Left is mapped to Nothing. The value inside Left is lost. +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing + +-- | Transforms a Maybe value into an Either value. Just is mapped to Right and +-- Nothing is mapped to Left. You also pass in an error value in case Left is +-- returned. +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither err m = maybe (Left err) Right m + +-- | Lift a Either computation into the EitherT monad +liftEither :: Monad m => Either b a -> EitherT b m a +liftEither = hoistEither + +-- | Lift a Maybe computation into the EitherT monad +liftMaybe :: Monad m => b -> Maybe a -> EitherT b m a +liftMaybe err = liftEither . (maybeToEither err) + +-- Various helpers + +-- | Applies a function to only one element of a list defined by it's index. +-- If the index is out of the bounds of the list, the original list is returned +updateIndex :: Int -- ^ The index of the element to change + -> [a] -- ^ The list of elements + -> (a -> a) -- ^ The function to apply + -> [a] -- ^ The result with one element changed +updateIndex i xs f + | i < 0 || i >= length xs = xs + | otherwise = l ++ (f h : r) + where + (l,h:r) = splitAt i xs + +-- | Use the list [b] as a template and try to match the elements of [a] +-- against it. For each element of [b] return the (first) matching element of +-- [a], or Nothing. Output list has same size as [b] and contains results in +-- same order. Elements of [a] can only appear once. +matchTemplate :: [a] -- ^ The input list + -> [b] -- ^ The list to serve as a template + -> (a -> b -> Bool) -- ^ The comparison function + -> [Maybe a] -- ^ Results of the template matching +matchTemplate [] bs _ = replicate (length bs) Nothing +matchTemplate _ [] _ = [] +matchTemplate as (b:bs) f = case break (flip f b) as of + (l,(r:rs)) -> (Just r) : matchTemplate (l ++ rs) bs f + _ -> Nothing : matchTemplate as bs f + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +lst3 :: (a,b,c) -> c +lst3 (_,_,c) = c + diff --git a/Network/Haskoin/Util/BuildMonad.hs b/Network/Haskoin/Util/BuildMonad.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/BuildMonad.hs @@ -0,0 +1,136 @@ +{-| + The Build type, and associated operations. +-} +module Network.Haskoin.Util.BuildMonad +( Build(..) +, BuildT(..) +, isComplete +, isPartial +, isBroken +, eitherToBuild +, buildToEither +, guardPartial +, liftBuild +) where + +import Control.Monad (liftM) +import Control.Monad.Trans + ( MonadTrans + , MonadIO + , lift + , liftIO + ) + +{-| + The Build monad represents computations that can be in one of three states: + + * Complete + + * Partial + + * Broken + + It extends the Either monad with an additional Partial value to describe a + valid computation flagged with a Partial context. The Build monad is useful + when you describe computations where parts of the computation are either + complete, partially complete or broken. Combining only Complete computations + will produce a Complete result. However, if one of the computations is + Partial, the whole computation will be Partial as well. And if some + computation is Broken, the whole computation will be broken as well. + + The Build monad is used by Haskoin to describe the state of the transaction + signing computation. To sign a transaction, all input scripts need to be + signed. The whole transaction will be completely signed only if all the + input scripts are completely signed. If any of the inputs is partially signed, + then the whole transaction will be partially signed as well. And the whole + transaction is broken if one of the inputs failed to parse or is broken. +-} +data Build a + -- | Describes a successful complete computation + = Complete { runBuild :: a } + -- | Describes a successful but partial computation + | Partial { runBuild :: a } + -- | Describes a broken computation + | Broken { runBroken :: String } + deriving Eq + +instance Show a => Show (Build a) where + show (Complete a) = "Complete " ++ (show a) + show (Partial a) = "Partial " ++ (show a) + show (Broken str) = "Broken " ++ str + +instance Functor Build where + fmap f (Complete x) = Complete (f x) + fmap f (Partial x) = Partial (f x) + fmap _ (Broken s) = Broken s + +instance Monad Build where + return = Complete + Complete x >>= f = f x + Partial x >>= f = case f x of + e@(Broken _) -> e + a -> Partial $ runBuild a + Broken s >>= _ = Broken s + +-- | Returns True if the Build value is Complete +isComplete :: Build a -> Bool +isComplete (Complete _) = True +isComplete _ = False + +-- | Returns True if the Build value is Partial +isPartial :: Build a -> Bool +isPartial (Partial _) = True +isPartial _ = False + +-- | Return True if the Build value is Broken +isBroken :: Build a -> Bool +isBroken (Broken _) = True +isBroken _ = False + +-- | Transforms an Either String value into a Build value. Right is mapped to +-- Complete and Left is mapped to Broken +eitherToBuild :: Either String a -> Build a +eitherToBuild m = case m of + Left err -> Broken err + Right res -> Complete res + +-- | Transforms a Build value into an Either String value. Complete and Partial +-- are mapped to Right and Broken is mapped to Left. +buildToEither :: Build a -> Either String a +buildToEither m = case m of + Complete a -> Right a + Partial a -> Right a + Broken err -> Left err + +-- | Binds a Partial value to the computation when the predicate is False. +guardPartial :: Bool -> Build () +guardPartial True = Complete () +guardPartial False = Partial () + +-- | BuildT transformer monad +newtype BuildT m a = BuildT { runBuildT :: m (Build a) } + +mapBuildT :: (m (Build a) -> n (Build b)) -> BuildT m a -> BuildT n b +mapBuildT f = BuildT . f . runBuildT + +instance Functor m => Functor (BuildT m) where + fmap f = mapBuildT (fmap (fmap f)) + +instance Monad m => Monad (BuildT m) where + return = lift . return + x >>= f = BuildT $ do + v <- runBuildT x + case v of Complete a -> runBuildT (f a) + Partial a -> runBuildT (f a) + Broken str -> return $ Broken str + +instance MonadTrans BuildT where + lift = BuildT . liftM Complete + +instance MonadIO m => MonadIO (BuildT m) where + liftIO = lift . liftIO + +-- | Lift a Build computation into the BuildT monad +liftBuild :: Monad m => Build a -> BuildT m a +liftBuild = BuildT . return + diff --git a/Network/Haskoin/Util/Constants.hs b/Network/Haskoin/Util/Constants.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/Constants.hs @@ -0,0 +1,55 @@ +{-| + Declaration of constants used across the bitcoin protocol. +-} +module Network.Haskoin.Util.Constants where + +import Data.Word (Word8,Word32) + +-- | Prefix for base58 PubKey hash address +addrPrefix :: Word8 +addrPrefix = 0 + +-- | Prefix for base58 script hash address +scriptPrefix :: Word8 +scriptPrefix = 5 + +-- | Prefix for private key WIF format +secretPrefix :: Word8 +secretPrefix = 128 + +-- | Prefix for extended public keys (BIP32) +extPubKeyPrefix :: Word32 +extPubKeyPrefix = 0x0488b21e + +-- | Prefix for extended private keys (BIP32) +extSecretPrefix :: Word32 +extSecretPrefix = 0x0488ade4 + +-- | Network magic bytes +networkMagic :: Word32 +networkMagic = 0xf9beb4d9 + +-- | Genesis block header information +genesisHeader :: [Integer] +genesisHeader = + -- Hash = 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f + [ 0x01 + , 0x00 + , 0x3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a + , 1231006505 + , 486604799 + , 2083236893 + ] + +-- | Maximum size of a block in bytes +maxBlockSize :: Int +maxBlockSize = 1000000 + +-- | Wallet database file name +walletFile :: String +walletFile = "walletdb" + +-- | User agent of this haskoin package +haskoinUserAgent :: String +haskoinUserAgent = "/haskoin:0.0.2/" + diff --git a/Network/Haskoin/Util/Constants/Testnet.hs b/Network/Haskoin/Util/Constants/Testnet.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/Constants/Testnet.hs @@ -0,0 +1,55 @@ +{-| + Declaration of constants used across the testnet bitcoin protocol +-} +module Network.Haskoin.Util.Constants.Testnet where + +import Data.Word (Word8,Word32) + +-- | Prefix for base58 PubKey hash address +addrPrefix :: Word8 +addrPrefix = 111 + +-- | Prefix for base58 script hash address +scriptPrefix :: Word8 +scriptPrefix = 196 + +-- | Prefix for private key WIF format +secretPrefix :: Word8 +secretPrefix = 239 + +-- | Prefix for extended public keys (BIP32) +extPubKeyPrefix :: Word32 +extPubKeyPrefix = 0x043587cf + +-- | Prefix for extended private keys (BIP32) +extSecretPrefix :: Word32 +extSecretPrefix = 0x04358394 + +-- | Network magic bytes +networkMagic :: Word32 +networkMagic = 0x0b110907 + +-- | Genesis block header information +genesisHeader :: [Integer] +genesisHeader = + -- Hash = 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 + [ 0x01 + , 0x00 + , 0x3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a + , 1296688602 + , 486604799 + , 414098458 + ] + +-- | Maximum size of a block in bytes +maxBlockSize :: Int +maxBlockSize = 1000000 + +-- | Wallet database file name +walletFile :: String +walletFile = "testwalletdb" + +-- | User agent of this haskoin package +haskoinUserAgent :: String +haskoinUserAgent = "/haskoin:0.0.2/" + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/haskoin.cabal b/haskoin.cabal new file mode 100644 --- /dev/null +++ b/haskoin.cabal @@ -0,0 +1,149 @@ +name: haskoin +version: 0.0.2 +synopsis: Implementation of the Bitcoin protocol. +description: + Haskoin is a package providing an implementation of the Bitcoin protocol + specifications. It provides the cryptographic ECDSA and hashing primitives, + functions for handling BIP32 extended keys, functions for building and + signing various types of regular and multisig transactions and a definition + of the network protocol messages. +homepage: http://github.com/plaprade/haskoin +bug-reports: http://github.com/plaprade/haskoin/issues +stability: experimental +license: PublicDomain +license-file: UNLICENSE +author: Philippe Laprade, Jean-Pierre Rupp +maintainer: plaprade+hackage@gmail.com +category: Bitcoin, Finance, Network +build-type: Simple +cabal-version: >= 1.9.2 +extra-source-files: tests/data/*.json + +source-repository head + type: git + location: git://github.com/plaprade/haskoin.git + + +library + exposed-modules: Network.Haskoin.Util, + Network.Haskoin.Stratum, + Network.Haskoin.Crypto, + Network.Haskoin.Protocol, + Network.Haskoin.Script, + Network.Haskoin.Transaction + other-modules: Network.Haskoin.Util.BuildMonad, + Network.Haskoin.Util.Constants, + Network.Haskoin.Util.Constants.Testnet, + Network.Haskoin.Crypto.NumberTheory, + Network.Haskoin.Crypto.Curve, + Network.Haskoin.Crypto.Hash, + Network.Haskoin.Crypto.BigWord, + Network.Haskoin.Crypto.Point, + Network.Haskoin.Crypto.Base58, + Network.Haskoin.Crypto.Keys, + Network.Haskoin.Crypto.ExtendedKeys, + Network.Haskoin.Crypto.NormalizedKeys, + Network.Haskoin.Crypto.ECDSA, + Network.Haskoin.Crypto.Mnemonic, + Network.Haskoin.Crypto.Merkle, + Network.Haskoin.Crypto.Bloom, + Network.Haskoin.Protocol.Message, + Network.Haskoin.Protocol.VarInt, + Network.Haskoin.Protocol.BlockHeader, + Network.Haskoin.Protocol.Addr, + Network.Haskoin.Protocol.Tx, + Network.Haskoin.Protocol.NotFound, + Network.Haskoin.Protocol.NetworkAddress, + Network.Haskoin.Protocol.Inv, + Network.Haskoin.Protocol.VarString, + Network.Haskoin.Protocol.GetBlocks, + Network.Haskoin.Protocol.Ping, + Network.Haskoin.Protocol.Script, + Network.Haskoin.Protocol.InvVector, + Network.Haskoin.Protocol.Alert, + Network.Haskoin.Protocol.MessageHeader, + Network.Haskoin.Protocol.Block, + Network.Haskoin.Protocol.MerkleBlock, + Network.Haskoin.Protocol.BloomFilter, + Network.Haskoin.Protocol.Version, + Network.Haskoin.Protocol.GetData, + Network.Haskoin.Protocol.Headers, + Network.Haskoin.Protocol.GetHeaders, + Network.Haskoin.Script.Parser, + Network.Haskoin.Script.SigHash, + Network.Haskoin.Stratum.Message, + Network.Haskoin.Stratum.Conduit, + Network.Haskoin.Transaction.Builder + build-depends: aeson >= 0.7 && < 0.8, + base >= 4.6 && < 4.7, + binary >= 0.7 && < 0.8, + byteable >= 0.1 && < 0.2, + bytestring >= 0.10 && < 0.11, + conduit >= 1.1 && < 1.2, + conduit-extra >= 1.1 && < 1.2, + containers >= 0.5 && < 0.6, + cryptohash >= 0.11 && < 0.12, + either >= 4.0 && < 4.1, + mtl >= 2.1 && < 2.2, + pbkdf >= 1.1 && < 1.2, + split >= 0.2 && < 0.3, + text >= 0.11 && < 0.12, + text-icu >= 0.6 && < 0.7, + vector >= 0.10 && < 0.11 + ghc-options: -Wall -fno-warn-orphans + +test-suite test-haskoin + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Network.Haskoin.Util.Tests, + Network.Haskoin.Util.Arbitrary, + Network.Haskoin.Crypto.BigWord.Tests, + Network.Haskoin.Crypto.Point.Tests, + Network.Haskoin.Crypto.ECDSA.Tests, + Network.Haskoin.Crypto.Base58.Tests, + Network.Haskoin.Crypto.Keys.Tests, + Network.Haskoin.Crypto.ExtendedKeys.Tests, + Network.Haskoin.Crypto.ExtendedKeys.Units, + Network.Haskoin.Crypto.Hash.Tests, + Network.Haskoin.Crypto.Hash.Units, + Network.Haskoin.Crypto.Mnemonic.Tests, + Network.Haskoin.Crypto.Mnemonic.Units, + Network.Haskoin.Crypto.Bloom.Tests, + Network.Haskoin.Crypto.Bloom.Units, + Network.Haskoin.Crypto.Merkle.Tests, + Network.Haskoin.Crypto.Merkle.Units, + Network.Haskoin.Crypto.Arbitrary, + Network.Haskoin.Crypto.Units, + Network.Haskoin.Protocol.Arbitrary, + Network.Haskoin.Protocol.Tests, + Network.Haskoin.Protocol.Units, + Network.Haskoin.Script.Arbitrary, + Network.Haskoin.Script.Tests, + Network.Haskoin.Script.Units, + Network.Haskoin.Transaction.Tests, + Network.Haskoin.Transaction.Units, + Network.Haskoin.Transaction.Arbitrary, + Network.Haskoin.Stratum.Units + build-depends: aeson >= 0.7 && < 0.8, + base >= 4.6 && < 4.7, + binary >= 0.7 && < 0.8, + byteable >= 0.1 && < 0.2, + bytestring >= 0.10 && < 0.11, + conduit >= 1.1 && < 1.2, + conduit-extra >= 1.1 && < 1.2, + containers >= 0.5 && < 0.6, + cryptohash >= 0.11 && < 0.12, + either >= 4.0 && < 4.1, + mtl >= 2.1 && < 2.2, + pbkdf >= 1.1 && < 1.2, + split >= 0.2 && < 0.3, + text >= 0.11 && < 0.12, + text-icu >= 0.6 && < 0.7, + HUnit >= 1.2 && < 1.3, + QuickCheck >= 2.6 && < 2.7, + test-framework >= 0.8 && < 0.9, + test-framework-quickcheck2 >= 0.3 && < 0.4, + test-framework-hunit >= 0.3 && < 0.4 + hs-source-dirs: . tests + ghc-options: -Wall -fno-warn-orphans + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,68 @@ +module Main where + +import Test.Framework (defaultMain) + +-- Util tests +import qualified Network.Haskoin.Util.Tests (tests) + +-- Crypto tests +import qualified Network.Haskoin.Crypto.BigWord.Tests (tests) +import qualified Network.Haskoin.Crypto.Point.Tests (tests) +import qualified Network.Haskoin.Crypto.ECDSA.Tests (tests) +import qualified Network.Haskoin.Crypto.Base58.Tests (tests) +import qualified Network.Haskoin.Crypto.Keys.Tests (tests) +import qualified Network.Haskoin.Crypto.ExtendedKeys.Tests (tests) +import qualified Network.Haskoin.Crypto.ExtendedKeys.Units (tests) +import qualified Network.Haskoin.Crypto.Hash.Tests (tests) +import qualified Network.Haskoin.Crypto.Hash.Units (tests) +import qualified Network.Haskoin.Crypto.Mnemonic.Tests (tests) +import qualified Network.Haskoin.Crypto.Mnemonic.Units (tests) +import qualified Network.Haskoin.Crypto.Bloom.Tests (tests) +import qualified Network.Haskoin.Crypto.Bloom.Units (tests) +import qualified Network.Haskoin.Crypto.Merkle.Tests (tests) +import qualified Network.Haskoin.Crypto.Merkle.Units (tests) +import qualified Network.Haskoin.Crypto.Units (tests) + +-- Protocol tests +import qualified Network.Haskoin.Protocol.Tests (tests) +import qualified Network.Haskoin.Protocol.Units (tests) + +-- Script tests +import qualified Network.Haskoin.Script.Tests (tests) +import qualified Network.Haskoin.Script.Units (tests) + +-- Transaction tests +import qualified Network.Haskoin.Transaction.Tests (tests) +import qualified Network.Haskoin.Transaction.Units (tests) + +-- Stratum tests +import qualified Network.Haskoin.Stratum.Units (tests) + +main :: IO () +main = defaultMain + ( Network.Haskoin.Util.Tests.tests + ++ Network.Haskoin.Crypto.BigWord.Tests.tests + ++ Network.Haskoin.Crypto.Point.Tests.tests + ++ Network.Haskoin.Crypto.ECDSA.Tests.tests + ++ Network.Haskoin.Crypto.Base58.Tests.tests + ++ Network.Haskoin.Crypto.Hash.Tests.tests + ++ Network.Haskoin.Crypto.Hash.Units.tests + ++ Network.Haskoin.Crypto.Keys.Tests.tests + ++ Network.Haskoin.Crypto.ExtendedKeys.Tests.tests + ++ Network.Haskoin.Crypto.ExtendedKeys.Units.tests + ++ Network.Haskoin.Crypto.Mnemonic.Tests.tests + ++ Network.Haskoin.Crypto.Mnemonic.Units.tests + ++ Network.Haskoin.Crypto.Bloom.Tests.tests + ++ Network.Haskoin.Crypto.Bloom.Units.tests + ++ Network.Haskoin.Crypto.Merkle.Tests.tests + ++ Network.Haskoin.Crypto.Merkle.Units.tests + ++ Network.Haskoin.Crypto.Units.tests + ++ Network.Haskoin.Protocol.Tests.tests + ++ Network.Haskoin.Protocol.Units.tests + ++ Network.Haskoin.Script.Tests.tests + ++ Network.Haskoin.Script.Units.tests + ++ Network.Haskoin.Transaction.Tests.tests + ++ Network.Haskoin.Transaction.Units.tests + ++ Network.Haskoin.Stratum.Units.tests + ) + diff --git a/tests/Network/Haskoin/Crypto/Arbitrary.hs b/tests/Network/Haskoin/Crypto/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Arbitrary.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-| + QuickCheck Arbitrary instances for Haskoin.Crypto types. +-} +module Network.Haskoin.Crypto.Arbitrary +( Test32 +, TestPrvKeyC(..) +, TestPrvKeyU(..) +, genPrvKeyC +, genPrvKeyU +) where + +import Test.QuickCheck +import Network.Haskoin.Util.Arbitrary() + +import Control.Applicative ((<$>), (<*>)) + +import Data.Maybe + +import Network.Haskoin.Crypto.Point +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.ECDSA +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.Base58 +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Crypto.ExtendedKeys +import Network.Haskoin.Crypto.NormalizedKeys + +data Mod32 +type Test32 = BigWord Mod32 + +instance BigWordMod Mod32 where + rFromInteger i = BigWord $ i `mod` 2 ^ (32 :: Integer) + rBitSize _ = 32 + +instance BigWordMod n => Arbitrary (BigWord n) where + arbitrary = arbitrarySizedBoundedIntegral + +instance Arbitrary CheckSum32 where + arbitrary = chksum32 <$> arbitrary + +instance Arbitrary Point where + arbitrary = frequency + [ (1, return makeInfPoint) + , (9, (flip mulPoint $ curveG) <$> (arbitrary :: Gen FieldN)) + ] + +-- | Generate an arbitrary compressed private key +genPrvKeyC :: Gen PrvKey +genPrvKeyC = do + i <- fromInteger <$> choose (1, curveN-1) + return $ fromJust $ makePrvKey i + +-- | Generate an arbitrary uncompressed private key +genPrvKeyU :: Gen PrvKey +genPrvKeyU = do + i <- fromInteger <$> choose (1, curveN-1) + return $ fromJust $ makePrvKeyU i + +newtype TestPrvKeyC = TestPrvKeyC { getTestPrvKeyC :: PrvKey } + deriving (Eq, Show) + +newtype TestPrvKeyU = TestPrvKeyU { getTestPrvKeyU :: PrvKey } + deriving (Eq, Show) + +instance Arbitrary TestPrvKeyC where + arbitrary = TestPrvKeyC <$> genPrvKeyC + +instance Arbitrary TestPrvKeyU where + arbitrary = TestPrvKeyU <$> genPrvKeyU + +instance Arbitrary PrvKey where + arbitrary = oneof [genPrvKeyC, genPrvKeyU] + +instance Arbitrary PubKey where + arbitrary = derivePubKey <$> arbitrary + +instance Arbitrary Address where + arbitrary = do + i <- fromInteger <$> choose (1,2^(160-1 :: Int)) + elements [ PubKeyAddress i + , ScriptAddress i + ] + +instance Arbitrary Signature where + arbitrary = do + msg <- arbitrary + prv <- prvKeyFieldN <$> arbitrary + non <- prvKeyFieldN <$> arbitrary + let pub = mulPoint non curveG + case unsafeSignMsg msg prv (non,pub) of + (Just sig) -> return sig + Nothing -> arbitrary + +instance Arbitrary XPrvKey where + arbitrary = XPrvKey <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> genPrvKeyC + +instance Arbitrary XPubKey where + arbitrary = deriveXPubKey <$> arbitrary + +instance Arbitrary MasterKey where + arbitrary = fromJust . makeMasterKey <$> arbitrary + +instance Arbitrary AccPrvKey where + arbitrary = do + master <- arbitrary + index <- choose (0,0x7fffffff) + return $ fromJust $ accPrvKey master index + +instance Arbitrary AccPubKey where + arbitrary = do + master <- arbitrary + index <- choose (0,0x7fffffff) + return $ fromJust $ accPubKey master index + +instance Arbitrary AddrPrvKey where + arbitrary = do + accKey <- arbitrary + index <- arbitrary + elements [ fromJust $ extPrvKey accKey index + , fromJust $ intPrvKey accKey index + ] + +instance Arbitrary AddrPubKey where + arbitrary = do + accKey <- arbitrary + index <- arbitrary + elements [ fromJust $ extPubKey accKey index + , fromJust $ intPubKey accKey index + ] + diff --git a/tests/Network/Haskoin/Crypto/Base58/Tests.hs b/tests/Network/Haskoin/Crypto/Base58/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Base58/Tests.hs @@ -0,0 +1,32 @@ +module Network.Haskoin.Crypto.Base58.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe (fromJust) +import qualified Data.ByteString as BS (ByteString) + +import Network.Haskoin.Crypto.Arbitrary() +import Network.Haskoin.Util.Arbitrary() + +import Network.Haskoin.Crypto.Base58 + +tests :: [Test] +tests = + [ testGroup "Address and Base58" + [ testProperty "decode58( encode58(i) ) = i" decodeEncode58 + , testProperty "decode58Chk( encode58Chk(i) ) = i" decodeEncode58Check + , testProperty "decode58( encode58(address) ) = address" decEncAddr + ] + ] + +decodeEncode58 :: BS.ByteString -> Bool +decodeEncode58 bs = (fromJust $ decodeBase58 $ encodeBase58 bs) == bs + +decodeEncode58Check :: BS.ByteString -> Bool +decodeEncode58Check bs = + (fromJust $ decodeBase58Check $ encodeBase58Check bs) == bs + +decEncAddr :: Address -> Bool +decEncAddr a = (fromJust $ base58ToAddr $ addrToBase58 a) == a + diff --git a/tests/Network/Haskoin/Crypto/BigWord/Tests.hs b/tests/Network/Haskoin/Crypto/BigWord/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/BigWord/Tests.hs @@ -0,0 +1,349 @@ +module Network.Haskoin.Crypto.BigWord.Tests (tests) where + +import Test.QuickCheck.Property (Property, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Bits + ( isSigned + , bit + , testBit + , shift + , bitSize + , popCount + , (.&.), (.|.) + , xor, complement + ) +import Data.Word (Word8, Word32) +import qualified Data.ByteString as BS (length, index) + +import Network.Haskoin.Crypto.Arbitrary +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.NumberTheory +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Number Theory" + [ testProperty "a * inv(a) = 1 (mod p)" inverseMod + , testProperty "a * inv(a) = 1 (mod p) in FieldP" inverseModP + , testProperty "a * inv(a) = 1 (mod n) in FieldN" inverseModN + , testProperty "sqrt( a^2 ) = a (mod p)" sqrtP + ], + testGroup "BigWord Numeric" + [ testProperty "BigWord fromInteger" ringFromInteger + , testProperty "BigWord addition" ringAddition + , testProperty "BigWord multiplication" ringMult + , testProperty "BigWord negation" ringNegate + , testProperty "BigWord abs" ringAbs + , testProperty "BigWord signum" ringSignum + ], + testGroup "BigWord Bits" + [ testProperty "BigWord AND" ringAnd + , testProperty "BigWord OR" ringOr + , testProperty "BigWord XOR" ringXor + , testProperty "BigWord Complement" ringComplement + , testProperty "BigWord Shift" ringShift + , testProperty "BigWord Bitsize" ringBitsize + , testProperty "BigWord Testbit" ringTestbit + , testProperty "BigWord Bit" ringBit + , testProperty "BigWord PopCount" ringPopCount + , testProperty "BigWord IsSigned" ringIsSigned + ], + testGroup "BigWord Bounded" + [ testProperty "BigWord minBound" ringMinBound + , testProperty "BigWord maxBound" ringMaxBound + ], + testGroup "BigWord Enum" + [ testProperty "BigWord succ" ringSucc + , testProperty "BigWord pred" ringPred + , testProperty "BigWord toEnum" ringToEnum + , testProperty "BigWord fromEnum" ringFromEnum + ], + testGroup "BigWord Integral" + [ testProperty "BigWord Quot" ringQuot + , testProperty "BigWord Rem" ringRem + , testProperty "BigWord Div" ringDiv + , testProperty "BigWord Mod" ringMod + , testProperty "BigWord QuotRem" ringQuotRem + , testProperty "BigWord DivMod" ringDivMod + , testProperty "BigWord toInteger" ringToInteger + ], + testGroup "BigWord Binary" + [ testProperty "get( put(Word512) ) = Word512" getPutWord512 + , testProperty "get( put(Word256) ) = Word256" getPutWord256 + , testProperty "get( put(Word160) ) = Word160" getPutWord160 + , testProperty "get( put(Word128) ) = Word128" getPutWord128 + , testProperty "get( put(FieldP) ) = FieldP" getPutModP + , testProperty "size( put(FieldP) ) = 32" putModPSize + , testProperty "get( put(FieldN) ) = FieldN" getPutModN + , testProperty "Verify DER of put(FieldN)" putModNSize + ], + testGroup "BigWord Read Show" + [ testProperty "read( show(Word512) ) = Word512" readShowWord512 + , testProperty "read( show(Word256) ) = Word256" readShowWord256 + , testProperty "read( show(Word160) ) = Word160" readShowWord160 + , testProperty "read( show(Word128) ) = Word128" readShowWord128 + , testProperty "read( show(FieldP) ) = FieldP" readShowModP + , testProperty "read( show(FieldN) ) = FieldN" readShowModN + ] + ] + +{- Number Theory -} + +inverseMod :: Integer -> Property +inverseMod i = p > 0 ==> (p * (mulInverse p curveP)) `mod` curveP == 1 + where + p = abs i + +inverseModP :: FieldP -> Property +inverseModP r = r > 0 ==> r/r == 1 + +inverseModN :: FieldN -> Property +inverseModN r = r > 0 ==> r/r == 1 + +sqrtP :: FieldP -> Bool +sqrtP x = (a == x && b == (-x)) || (a == (-x) && b == x) + where + (a:b:_) = quadraticResidue (x^(2 :: Int)) + +{- BigWord Numeric -} + +ringFromInteger :: Integer -> Bool +ringFromInteger i = getBigWordInteger ring == fromIntegral model + where + model = fromInteger i :: Word32 + ring = fromInteger i :: Test32 + +ringAddition :: Integer -> Integer -> Bool +ringAddition i1 i2 = getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) + (fromInteger i2) :: Word32 + ring = (fromInteger i1) + (fromInteger i2) :: Test32 + +ringMult :: Integer -> Integer -> Bool +ringMult i1 i2 = getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) * (fromInteger i2) :: Word32 + ring = (fromInteger i1) * (fromInteger i2) :: Test32 + +ringNegate :: Integer -> Bool +ringNegate i = getBigWordInteger ring == fromIntegral model + where + model = negate (fromInteger i) :: Word32 + ring = negate (fromInteger i) :: Test32 + +ringAbs :: Integer -> Bool +ringAbs i = getBigWordInteger ring == fromIntegral model + where + model = abs (fromInteger i) :: Word32 + ring = abs (fromInteger i) :: Test32 + +ringSignum :: Integer -> Bool +ringSignum i = getBigWordInteger ring == fromIntegral model + where + model = signum (fromInteger i) :: Word32 + ring = signum (fromInteger i) :: Test32 + +{- BigWord Bits -} + +ringAnd :: Integer -> Integer -> Bool +ringAnd i1 i2 = getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) .&. (fromInteger i2) :: Word32 + ring = (fromInteger i1) .&. (fromInteger i2) :: Test32 + +ringOr :: Integer -> Integer -> Bool +ringOr i1 i2 = getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) .|. (fromInteger i2) :: Word32 + ring = (fromInteger i1) .|. (fromInteger i2) :: Test32 + +ringXor :: Integer -> Integer -> Bool +ringXor i1 i2 = getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) `xor` (fromInteger i2) :: Word32 + ring = (fromInteger i1) `xor` (fromInteger i2) :: Test32 + +ringComplement :: Integer -> Bool +ringComplement i = getBigWordInteger ring == fromIntegral model + where + model = complement (fromInteger i) :: Word32 + ring = complement (fromInteger i) :: Test32 + +ringShift :: Integer -> Word8 -> Bool +ringShift i j = getBigWordInteger ring == fromIntegral model + where + model = shift (fromInteger i) (fromIntegral j) :: Word32 + ring = shift (fromInteger i) (fromIntegral j) :: Test32 + +ringBitsize :: Integer -> Bool +ringBitsize i = ring == model + where + model = bitSize ((fromInteger i) :: Word32) + ring = bitSize ((fromInteger i) :: Test32) + +ringTestbit :: Integer -> Word8 -> Bool +ringTestbit i j = ring == model + where + model = testBit ((fromInteger i) :: Word32) (fromIntegral j) + ring = testBit ((fromInteger i) :: Test32) (fromIntegral j) + +ringBit :: Word8 -> Bool +ringBit i = getBigWordInteger ring == fromIntegral model + where + model = bit (fromIntegral i) :: Word32 + ring = bit (fromIntegral i) :: Test32 + +ringPopCount :: Integer -> Bool +ringPopCount i = ring == model + where + model = popCount ((fromInteger i) :: Word32) + ring = popCount ((fromInteger i) :: Test32) + +ringIsSigned :: Integer -> Bool +ringIsSigned i = ring == model + where + model = isSigned ((fromInteger i) :: Word32) + ring = isSigned ((fromInteger i) :: Test32) + +{- BigWord Bounded -} + +ringMinBound :: Test32 -> Bool +ringMinBound _ = (minBound :: Test32) - 1 == (maxBound :: Test32) + +ringMaxBound :: Test32 -> Bool +ringMaxBound _ = (maxBound :: Test32) + 1 == (minBound :: Test32) + +{- BigWord Enum -} + +ringSucc :: Integer -> Property +ringSucc i = (fromIntegral i) /= maxB ==> + getBigWordInteger ring == fromIntegral model + where + model = succ (fromInteger i) :: Word32 + ring = succ (fromInteger i) :: Test32 + maxB = maxBound :: Word32 + +ringPred :: Integer -> Property +ringPred i = (fromIntegral i) /= minB ==> + getBigWordInteger ring == fromIntegral model + where + model = pred (fromInteger i) :: Word32 + ring = pred (fromInteger i) :: Test32 + minB = minBound :: Word32 + +ringToEnum :: Word32 -> Bool +ringToEnum w = getBigWordInteger ring == fromIntegral model + where + model = toEnum (fromIntegral w) :: Word32 + ring = toEnum (fromIntegral w) :: Test32 + +ringFromEnum :: Integer -> Bool +ringFromEnum i = model == ring + where + model = fromEnum ((fromInteger i) :: Word32) + ring = fromEnum ((fromInteger i) :: Test32) + +{- BigWord Integral -} + +ringQuot :: Integer -> Integer -> Property +ringQuot i1 i2 = i2 /= 0 ==> getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) `quot` (fromInteger i2) :: Word32 + ring = (fromInteger i1) `quot` (fromInteger i2) :: Test32 + +ringRem :: Integer -> Integer -> Property +ringRem i1 i2 = i2 /= 0 ==> getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) `rem` (fromInteger i2) :: Word32 + ring = (fromInteger i1) `rem` (fromInteger i2) :: Test32 + +ringDiv :: Integer -> Integer -> Property +ringDiv i1 i2 = i2 /= 0 ==> getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) `div` (fromInteger i2) :: Word32 + ring = (fromInteger i1) `div` (fromInteger i2) :: Test32 + +ringMod :: Integer -> Integer -> Property +ringMod i1 i2 = i2 /= 0 ==> getBigWordInteger ring == fromIntegral model + where + model = (fromInteger i1) `mod` (fromInteger i2) :: Word32 + ring = (fromInteger i1) `mod` (fromInteger i2) :: Test32 + +ringQuotRem :: Integer -> Integer -> Property +ringQuotRem i1 i2 = i2 /= 0 ==> + (getBigWordInteger r1 == fromIntegral m1) && + (getBigWordInteger r2 == fromIntegral m2) + where + (m1,m2) = (fromInteger i1) `quotRem` (fromInteger i2) :: (Word32, Word32) + (r1,r2) = (fromInteger i1) `quotRem` (fromInteger i2) :: (Test32, Test32) + +ringDivMod :: Integer -> Integer -> Property +ringDivMod i1 i2 = i2 /= 0 ==> + (getBigWordInteger r1 == fromIntegral m1) && + (getBigWordInteger r2 == fromIntegral m2) + where + (m1,m2) = (fromInteger i1) `divMod` (fromInteger i2) :: (Word32, Word32) + (r1,r2) = (fromInteger i1) `divMod` (fromInteger i2) :: (Test32, Test32) + +ringToInteger :: Test32 -> Bool +ringToInteger r@(BigWord i) = toInteger r == i + +{- BigWord Binary -} + +getPutWord512 :: Word512 -> Bool +getPutWord512 r = r == (decode' $ encode' r) + +getPutWord256 :: Word256 -> Bool +getPutWord256 r = r == (decode' $ encode' r) + +getPutWord160 :: Word160 -> Bool +getPutWord160 r = r == (decode' $ encode' r) + +getPutWord128 :: Word128 -> Bool +getPutWord128 r = r == (decode' $ encode' r) + +getPutModP :: FieldP -> Bool +getPutModP r = r == (decode' $ encode' r) + +putModPSize :: FieldP -> Bool +putModPSize r = BS.length (encode' r) == 32 + +getPutModN :: FieldN -> Property +getPutModN r = r > 0 ==> r == (decode' $ encode' r) + +putModNSize :: FieldN -> Property +putModNSize r = r > 0 ==> + ( a == 0x02 -- DER type is Integer + && b <= 33 -- Can't be bigger than 32 + 0x00 padding + && l == fromIntegral (b + 2) -- Advertised length matches + && c < 0x80 -- High byte is never 1 + ) + where + bs = encode' r + a = BS.index bs 0 + b = BS.index bs 1 + c = BS.index bs 2 + l = BS.length bs + +{- BigWord Read Show -} + +readShowWord512 :: Word512 -> Bool +readShowWord512 r = r == (read $ show r) + +readShowWord256 :: Word256 -> Bool +readShowWord256 r = r == (read $ show r) + +readShowWord160 :: Word160 -> Bool +readShowWord160 r = r == (read $ show r) + +readShowWord128 :: Word128 -> Bool +readShowWord128 r = r == (read $ show r) + +readShowModP :: FieldP -> Bool +readShowModP r = r == (read $ show r) + +readShowModN :: FieldN -> Property +readShowModN r = r > 0 ==> r == (read $ show r) diff --git a/tests/Network/Haskoin/Crypto/Bloom/Tests.hs b/tests/Network/Haskoin/Crypto/Bloom/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Bloom/Tests.hs @@ -0,0 +1,22 @@ +module Network.Haskoin.Crypto.Bloom.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Network.Haskoin.Protocol.Arbitrary () +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Bloom Filters" + [ testProperty "decode . encode BloomFilter" decodeEncodeBloom + ] + ] + +{- Bloom Filters -} + +decodeEncodeBloom :: BloomFilter -> Bool +decodeEncodeBloom bfilter = (decode' $ encode' bfilter) == bfilter + + diff --git a/tests/Network/Haskoin/Crypto/Bloom/Units.hs b/tests/Network/Haskoin/Crypto/Bloom/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Bloom/Units.hs @@ -0,0 +1,71 @@ +module Network.Haskoin.Crypto.Bloom.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust) + +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ + -- Test cases come from bitcoind /src/test/bloom_tests.cpp + testGroup "Bloom Filters" + [ testCase "Bloom Filter Vector 1" bloomFilter1 + , testCase "Bloom Filter Vector 2" bloomFilter2 + , testCase "Bloom Filter Vector 3" bloomFilter3 + ] + ] + +bloomFilter1 :: Assertion +bloomFilter1 = do + assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1 + assertBool "Bloom filter contains something it should not" $ + not $ bloomContains f1 v2 + assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 + assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 + assertBool "Bloom filter serialization is incorrect" $ (encode' f4) == bs + where + f0 = bloomCreate 3 0.01 0 BloomUpdateAll + f1 = bloomInsert f0 v1 + f3 = bloomInsert f1 v3 + f4 = bloomInsert f3 v4 + v1 = fromJust $ hexToBS "99108ad8ed9bb6274d3980bab5a85c048f0950c8" + v2 = fromJust $ hexToBS "19108ad8ed9bb6274d3980bab5a85c048f0950c8" + v3 = fromJust $ hexToBS "b5a2c786d9ef4658287ced5914b37a1b4aa32eee" + v4 = fromJust $ hexToBS "b9300670b4c5366e95b2699e8b18bc75e5f729c5" + bs = fromJust $ hexToBS "03614e9b050000000000000001" + +bloomFilter2 :: Assertion +bloomFilter2 = do + assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1 + assertBool "Bloom filter contains something it should not" $ + not $ bloomContains f1 v2 + assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 + assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 + assertBool "Bloom filter serialization is incorrect" $ (encode' f4) == bs + where + f0 = bloomCreate 3 0.01 2147483649 BloomUpdateAll + f1 = bloomInsert f0 v1 + f3 = bloomInsert f1 v3 + f4 = bloomInsert f3 v4 + v1 = fromJust $ hexToBS "99108ad8ed9bb6274d3980bab5a85c048f0950c8" + v2 = fromJust $ hexToBS "19108ad8ed9bb6274d3980bab5a85c048f0950c8" + v3 = fromJust $ hexToBS "b5a2c786d9ef4658287ced5914b37a1b4aa32eee" + v4 = fromJust $ hexToBS "b9300670b4c5366e95b2699e8b18bc75e5f729c5" + bs = fromJust $ hexToBS "03ce4299050000000100008001" + +bloomFilter3 :: Assertion +bloomFilter3 = do + assertBool "Bloom filter serialization is incorrect" $ (encode' f2) == bs + where + f0 = bloomCreate 2 0.001 0 BloomUpdateAll + f1 = bloomInsert f0 $ encode' p + f2 = bloomInsert f1 $ encode' $ getAddrHash $ pubKeyAddr p + k = fromJust $ fromWIF "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C" + p = derivePubKey k + bs = fromJust $ hexToBS "038fc16b080000000000000001" + diff --git a/tests/Network/Haskoin/Crypto/ECDSA/Tests.hs b/tests/Network/Haskoin/Crypto/ECDSA/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/ECDSA/Tests.hs @@ -0,0 +1,97 @@ +module Network.Haskoin.Crypto.ECDSA.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck.Property ((==>), Property) + +import Data.Bits (testBit) +import qualified Data.ByteString as BS + +import Network.Haskoin.Crypto.Arbitrary + +import Network.Haskoin.Crypto.ECDSA +import Network.Haskoin.Crypto.Point +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "ECDSA signatures" + [ testProperty "verify( sign(msg) ) = True" signAndVerify + , testProperty "verify( detSign(msg) ) = True" signAndVerifyD + , testProperty "S component <= order/2" halfOrderSig + ], + testGroup "ECDSA Binary" + [ testProperty "get( put(Sig) ) = Sig" getPutSig + , testProperty "Encoded signature is canonical" testIsCanonical + ] + ] + +{- ECDSA Signatures -} + +signAndVerify :: Hash256 -> FieldN -> FieldN -> Property +signAndVerify msg k n = k > 0 && n > 0 ==> case sM of + (Just s) -> verifySig msg s (PubKey kP) + Nothing -> True -- very bad luck + where kP = mulPoint k curveG + nP = mulPoint n curveG + sM = unsafeSignMsg msg k (n,nP) + +signAndVerifyD :: Hash256 -> TestPrvKeyC -> Bool +signAndVerifyD msg (TestPrvKeyC k) = verifySig msg (detSignMsg msg k) p + where p = derivePubKey k + +halfOrderSig :: Signature -> Bool +halfOrderSig sig@(Signature _ (BigWord s)) = + s <= (curveN `div` 2) && isCanonicalHalfOrder sig + +{- ECDSA Binary -} + +getPutSig :: Signature -> Bool +getPutSig sig = (decode' $ encode' sig) == sig + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- from function IsCanonicalSignature +testIsCanonical :: Signature -> Bool +testIsCanonical sig = not $ + -- Non-canonical signature: too short + (len < 8) || + -- Non-canonical signature: too long + (len > 72) || + -- Non-canonical signature: wrong type + (BS.index s 0 /= 0x30) || + -- Non-canonical signature: wrong length marker + (BS.index s 1 /= len - 2) || + -- Non-canonical signature: S length misplaced + (5 + rlen >= len) || + -- Non-canonical signature: R+S length mismatch + (rlen + slen + 6 /= len) || + -- Non-canonical signature: R value type mismatch + (BS.index s 2 /= 0x02) || + -- Non-canonical signature: R length is zero + (rlen == 0) || + -- Non-canonical signature: R value negative + (testBit (BS.index s 4) 7) || + -- Non-canonical signature: R value excessively padded + ( rlen > 1 + && BS.index s 4 == 0 + && not (testBit (BS.index s 5) 7) + ) || + -- Non-canonical signature: S value type mismatch + (BS.index s (fromIntegral rlen+4) /= 0x02) || + -- Non-canonical signature: S length is zero + (slen == 0) || + -- Non-canonical signature: S value negative + (testBit (BS.index s (fromIntegral rlen+6)) 7) || + -- Non-canonical signature: S value excessively padded + ( slen > 1 + && BS.index s (fromIntegral rlen+6) == 0 + && not (testBit (BS.index s (fromIntegral rlen+7)) 7) + ) + where s = encode' sig + len = fromIntegral $ BS.length s + rlen = BS.index s 3 + slen = BS.index s (fromIntegral rlen + 5) + diff --git a/tests/Network/Haskoin/Crypto/ExtendedKeys/Tests.hs b/tests/Network/Haskoin/Crypto/ExtendedKeys/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/ExtendedKeys/Tests.hs @@ -0,0 +1,66 @@ +module Network.Haskoin.Crypto.ExtendedKeys.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Monad (liftM2) +import Control.Applicative ((<$>)) + +import Data.Word (Word32) +import Data.Bits ((.&.)) +import Data.Maybe (fromJust) + +import Network.Haskoin.Crypto +import Network.Haskoin.Crypto.Arbitrary() +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "HDW Extended Keys" + [ testProperty "prvSubKey(k,c)*G = pubSubKey(k*G,c)" subkeyTest + , testProperty "decode . encode prvKey" binXPrvKey + , testProperty "decode . encode pubKey" binXPubKey + , testProperty "fromB58 . toB58 prvKey" b58PrvKey + , testProperty "fromB58 . toB58 pubKey" b58PubKey + ] + , testGroup "HDW Normalized Keys" + [ testProperty "decode . encode masterKey" decEncMaster + , testProperty "decode . encode prvAccKey" decEncPrvAcc + , testProperty "decode . encode pubAccKey" decEncPubAcc + ] + ] + +{- HDW Extended Keys -} + +subkeyTest :: XPrvKey -> Word32 -> Bool +subkeyTest k i = fromJust $ liftM2 (==) + (deriveXPubKey <$> prvSubKey k i') (pubSubKey (deriveXPubKey k) i') + where i' = fromIntegral $ i .&. 0x7fffffff -- make it a public derivation + +binXPrvKey :: XPrvKey -> Bool +binXPrvKey k = (decode' $ encode' k) == k + +binXPubKey :: XPubKey -> Bool +binXPubKey k = (decode' $ encode' k) == k + +b58PrvKey :: XPrvKey -> Bool +b58PrvKey k = (fromJust $ xPrvImport $ xPrvExport k) == k + +b58PubKey :: XPubKey -> Bool +b58PubKey k = (fromJust $ xPubImport $ xPubExport k) == k + +{- HDW Normalized Keys -} + +decEncMaster :: MasterKey -> Bool +decEncMaster k = (fromJust $ loadMasterKey $ decode' bs) == k + where bs = encode' $ masterKey k + +decEncPrvAcc :: AccPrvKey -> Bool +decEncPrvAcc k = (fromJust $ loadPrvAcc $ decode' bs) == k + where bs = encode' $ getAccPrvKey k + +decEncPubAcc :: AccPubKey -> Bool +decEncPubAcc k = (fromJust $ loadPubAcc $ decode' bs) == k + where bs = encode' $ getAccPubKey k + + diff --git a/tests/Network/Haskoin/Crypto/ExtendedKeys/Units.hs b/tests/Network/Haskoin/Crypto/ExtendedKeys/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/ExtendedKeys/Units.hs @@ -0,0 +1,250 @@ +module Network.Haskoin.Crypto.ExtendedKeys.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust, catMaybes) + +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "BIP32 derivation vector 1" + [ testCase "Chain m" $ runXKeyVec (xKeyVec !! 0) + , testCase "Chain m/0'" $ runXKeyVec (xKeyVec !! 1) + , testCase "Chain m/0'/1" $ runXKeyVec (xKeyVec !! 2) + , testCase "Chain m/0'/1/2'" $ runXKeyVec (xKeyVec !! 3) + , testCase "Chain m/0'/1/2'/2" $ runXKeyVec (xKeyVec !! 4) + , testCase "Chain m/0'/1/2'/2/1000000000" $ + runXKeyVec (xKeyVec !! 5) + ] + , testGroup "BIP32 subkey derivation vector 2" + [ testCase "Chain m" $ runXKeyVec (xKeyVec2 !! 0) + , testCase "Chain m/0" $ runXKeyVec (xKeyVec2 !! 1) + , testCase "Chain m/0/2147483647'" $ + runXKeyVec (xKeyVec2 !! 2) + , testCase "Chain m/0/2147483647'/1" $ + runXKeyVec (xKeyVec2 !! 3) + , testCase "Chain m/0/2147483647'/1/2147483646'" $ + runXKeyVec (xKeyVec2 !! 4) + , testCase "Chain m/0/2147483647'/1/2147483646'/2" $ + runXKeyVec (xKeyVec2 !! 5) + ] + ] + + +runXKeyVec :: ([String],XPrvKey) -> Assertion +runXKeyVec (v,m) = do + assertBool "xPrvID" $ (bsToHex $ encode' $ xPrvID m) == v !! 0 + assertBool "xPrvFP" $ (bsToHex $ encode' $ xPrvFP m) == v !! 1 + assertBool "xPrvAddr" $ + (addrToBase58 $ xPubAddr $ deriveXPubKey m) == v !! 2 + assertBool "prvKey" $ (bsToHex $ runPut' $ putPrvKey $ xPrvKey m) == v !! 3 + assertBool "xPrvWIF" $ xPrvWIF m == v !! 4 + assertBool "pubKey" $ + (bsToHex $ encode' $ xPubKey $ deriveXPubKey m) == v !! 5 + assertBool "chain code" $ (bsToHex $ encode' $ xPrvChain m) == v !! 6 + assertBool "Hex PubKey" $ (bsToHex $ encode' $ deriveXPubKey m) == v !! 7 + assertBool "Hex PrvKey" $ (bsToHex $ encode' m) == v !! 8 + assertBool "Base58 PubKey" $ (xPubExport $ deriveXPubKey m) == v !! 9 + assertBool "Base58 PrvKey" $ xPrvExport m == v !! 10 + +-- BIP 0032 Test Vectors +-- https://en.bitcoin.it/wiki/BIP_0032_TestVectors + +xKeyVec :: [([String],XPrvKey)] +xKeyVec = zip xKeyResVec $ catMaybes $ foldl f [m] der + where f acc d = acc ++ [d =<< last acc] + m = makeXPrvKey $ fromJust $ hexToBS m0 + der = [ flip primeSubKey 0 + , flip prvSubKey 1 + , flip primeSubKey 2 + , flip prvSubKey 2 + , flip prvSubKey 1000000000 + ] + +xKeyVec2 :: [([String],XPrvKey)] +xKeyVec2 = zip xKeyResVec2 $ catMaybes $ foldl f [m] der + where f acc d = acc ++ [d =<< last acc] + m = makeXPrvKey $ fromJust $ hexToBS m1 + der = [ flip prvSubKey 0 + , flip primeSubKey 2147483647 + , flip prvSubKey 1 + , flip primeSubKey 2147483646 + , flip prvSubKey 2 + ] + +m0 :: String +m0 = "000102030405060708090a0b0c0d0e0f" + +xKeyResVec :: [[String]] +xKeyResVec = + [ + -- m + [ "3442193e1bb70916e914552172cd4e2dbc9df811" + , "3442193e" + , "15mKKb2eos1hWa6tisdPwwDC1a5J1y9nma" + , "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" + , "L52XzL2cMkHxqxBXRyEpnPQZGUs3uKiL3R11XbAdHigRzDozKZeW" + , "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" + , "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508" + , "0488b21e000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d5080339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" + , "0488ade4000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d50800e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" + , "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8" + , "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi" + ] + -- m/0' + , [ "5c1bd648ed23aa5fd50ba52b2457c11e9e80a6a7" + , "5c1bd648" + , "19Q2WoS5hSS6T8GjhK8KZLMgmWaq4neXrh" + , "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" + , "L5BmPijJjrKbiUfG4zbiFKNqkvuJ8usooJmzuD7Z8dkRoTThYnAT" + , "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" + , "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141" + , "0488b21e013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" + , "0488ade4013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae623614100edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" + , "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw" + , "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7" + ] + -- m/0'/1 + , [ "bef5a2f9a56a94aab12459f72ad9cf8cf19c7bbe" + , "bef5a2f9" + , "1JQheacLPdM5ySCkrZkV66G2ApAXe1mqLj" + , "3c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" + , "KyFAjQ5rgrKvhXvNMtFB5PCSKUYD1yyPEe3xr3T34TZSUHycXtMM" + , "03501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" + , "2a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19" + , "0488b21e025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c1903501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" + , "0488ade4025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19003c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" + , "xpub6ASuArnXKPbfEwhqN6e3mwBcDTgzisQN1wXN9BJcM47sSikHjJf3UFHKkNAWbWMiGj7Wf5uMash7SyYq527Hqck2AxYysAA7xmALppuCkwQ" + , "xprv9wTYmMFdV23N2TdNG573QoEsfRrWKQgWeibmLntzniatZvR9BmLnvSxqu53Kw1UmYPxLgboyZQaXwTCg8MSY3H2EU4pWcQDnRnrVA1xe8fs" + ] + -- m/0'/1/2' + , [ "ee7ab90cde56a8c0e2bb086ac49748b8db9dce72" + , "ee7ab90c" + , "1NjxqbA9aZWnh17q1UW3rB4EPu79wDXj7x" + , "cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" + , "L43t3od1Gh7Lj55Bzjj1xDAgJDcL7YFo2nEcNaMGiyRZS1CidBVU" + , "0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" + , "04466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f" + , "0488b21e03bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" + , "0488ade403bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f00cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" + , "xpub6D4BDPcP2GT577Vvch3R8wDkScZWzQzMMUm3PWbmWvVJrZwQY4VUNgqFJPMM3No2dFDFGTsxxpG5uJh7n7epu4trkrX7x7DogT5Uv6fcLW5" + , "xprv9z4pot5VBttmtdRTWfWQmoH1taj2axGVzFqSb8C9xaxKymcFzXBDptWmT7FwuEzG3ryjH4ktypQSAewRiNMjANTtpgP4mLTj34bhnZX7UiM" + ] + -- m/0'/1/2'/2 + , [ "d880d7d893848509a62d8fb74e32148dac68412f" + , "d880d7d8" + , "1LjmJcdPnDHhNTUgrWyhLGnRDKxQjoxAgt" + , "0f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" + , "KwjQsVuMjbCP2Zmr3VaFaStav7NvevwjvvkqrWd5Qmh1XVnCteBR" + , "02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" + , "cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd" + , "0488b21e04ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" + , "0488ade404ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd000f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" + , "xpub6FHa3pjLCk84BayeJxFW2SP4XRrFd1JYnxeLeU8EqN3vDfZmbqBqaGJAyiLjTAwm6ZLRQUMv1ZACTj37sR62cfN7fe5JnJ7dh8zL4fiyLHV" + , "xprvA2JDeKCSNNZky6uBCviVfJSKyQ1mDYahRjijr5idH2WwLsEd4Hsb2Tyh8RfQMuPh7f7RtyzTtdrbdqqsunu5Mm3wDvUAKRHSC34sJ7in334" + ] + -- m/0'/1/2'/2/1000000000 + , [ "d69aa102255fed74378278c7812701ea641fdf32" + , "d69aa102" + , "1LZiqrop2HGR4qrH1ULZPyBpU6AUP49Uam" + , "471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" + , "Kybw8izYevo5xMh1TK7aUr7jHFCxXS1zv8p3oqFz3o2zFbhRXHYs" + , "022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" + , "c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e" + , "0488b21e05d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" + , "0488ade405d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e00471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" + , "xpub6H1LXWLaKsWFhvm6RVpEL9P4KfRZSW7abD2ttkWP3SSQvnyA8FSVqNTEcYFgJS2UaFcxupHiYkro49S8yGasTvXEYBVPamhGW6cFJodrTHy" + , "xprvA41z7zogVVwxVSgdKUHDy1SKmdb533PjDz7J6N6mV6uS3ze1ai8FHa8kmHScGpWmj4WggLyQjgPie1rFSruoUihUZREPSL39UNdE3BBDu76" + ] + ] + +m1 :: String +m1 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" + +xKeyResVec2 :: [[String]] +xKeyResVec2 = + [ + -- m + [ "bd16bee53961a47d6ad888e29545434a89bdfe95" + , "bd16bee5" + , "1JEoxevbLLG8cVqeoGKQiAwoWbNYSUyYjg" + , "4b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" + , "KyjXhyHF9wTphBkfpxjL8hkDXDUSbE3tKANT94kXSyh6vn6nKaoy" + , "03cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" + , "60499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689" + , "0488b21e00000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd968903cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" + , "0488ade400000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689004b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" + , "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB" + , "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U" + ] + -- m/0 + , [ "5a61ff8eb7aaca3010db97ebda76121610b78096" + , "5a61ff8e" + , "19EuDJdgfRkwCmRzbzVBHZWQG9QNWhftbZ" + , "abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" + , "L2ysLrR6KMSAtx7uPqmYpoTeiRzydXBattRXjXz5GDFPrdfPzKbj" + , "02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" + , "f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c" + , "0488b21e01bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" + , "0488ade401bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c00abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" + , "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH" + , "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt" + ] + -- m/0/2147483647' + , [ "d8ab493736da02f11ed682f88339e720fb0379d1" + , "d8ab4937" + , "1Lke9bXGhn5VPrBuXgN12uGUphrttUErmk" + , "877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" + , "L1m5VpbXmMp57P3knskwhoMTLdhAAaXiHvnGLMribbfwzVRpz2Sr" + , "03c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" + , "be17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d9" + , "0488b21e025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d903c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" + , "0488ade4025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d900877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" + , "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a" + , "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9" + ] + -- m/0/2147483647'/1 + , [ "78412e3a2296a40de124307b6485bd19833e2e34" + , "78412e3a" + , "1BxrAr2pHpeBheusmd6fHDP2tSLAUa3qsW" + , "704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" + , "KzyzXnznxSv249b4KuNkBwowaN3akiNeEHy5FWoPCJpStZbEKXN2" + , "03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" + , "f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb" + , "0488b21e03d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" + , "0488ade403d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb00704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" + , "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon" + , "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef" + ] + -- m/0/2147483647'/1/2147483646' + , [ "31a507b815593dfc51ffc7245ae7e5aee304246e" + , "31a507b8" + , "15XVotxCAV7sRx1PSCkQNsGw3W9jT9A94R" + , "f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" + , "L5KhaMvPYRW1ZoFmRjUtxxPypQ94m6BcDrPhqArhggdaTbbAFJEF" + , "02d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" + , "637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e29" + , "0488b21e0478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2902d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" + , "0488ade40478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2900f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" + , "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL" + , "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc" + ] + -- m/0/2147483647'/1/2147483646'/2 + , [ "26132fdbe7bf89cbc64cf8dafa3f9f88b8666220" + , "26132fdb" + , "14UKfRV9ZPUp6ZC9PLhqbRtxdihW9em3xt" + , "bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" + , "L3WAYNAZPxx1fr7KCz7GN9nD5qMBnNiqEJNJMU1z9MMaannAt4aK" + , "024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" + , "9452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271" + , "0488b21e0531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" + , "0488ade40531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed27100bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" + , "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt" + , "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j" + ] + ] + diff --git a/tests/Network/Haskoin/Crypto/Hash/Tests.hs b/tests/Network/Haskoin/Crypto/Hash/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Hash/Tests.hs @@ -0,0 +1,30 @@ +module Network.Haskoin.Crypto.Hash.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.Arbitrary() + +tests :: [Test] +tests = + [ testGroup "Hash tests" + [ testProperty "join512( split512(h) ) == h" joinSplit512 + , testProperty "decodeCompact . encodeCompact i == i" decEncCompact + ] + ] + +joinSplit512 :: Hash512 -> Bool +joinSplit512 h = (join512 $ split512 h) == h + +-- After encoding and decoding, we may loose precision so the new result is >= +-- to the old one. +decEncCompact :: Integer -> Bool +decEncCompact i + -- Integer completely fits inside the mantisse + | (abs i) <= 0x007fffff = (decodeCompact $ encodeCompact i) == i + -- Otherwise precision will be lost and the decoded result will + -- be smaller than the original number + | i >= 0 = (decodeCompact $ encodeCompact i) < i + | otherwise = (decodeCompact $ encodeCompact i) > i + diff --git a/tests/Network/Haskoin/Crypto/Hash/Units.hs b/tests/Network/Haskoin/Crypto/Hash/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Hash/Units.hs @@ -0,0 +1,1300 @@ +module Network.Haskoin.Crypto.Hash.Units (tests) where + +import Test.HUnit (assertBool, Assertion) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust) +import Data.Word (Word32) + +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Util + +-- Test vectors from NIST +-- http://csrc.nist.gov/groups/STM/cavp/documents/drbg/drbgtestvectors.zip +-- About 1/3 of HMAC DRBG SHA-256 test vectors are tested here + +tests :: [Test] +tests = + [ testGroup "HMAC DRBG Suite 1" [mapDRBG t1] + , testGroup "HMAC DRBG Suite 2" [mapDRBG t2] + , testGroup "HMAC DRBG Suite 3" [mapDRBG t3] + , testGroup "HMAC DRBG Suite 4" [mapDRBG t4] + , testGroup "HMAC DRBG Suite 5 (Reseed)" [mapDRBGRsd r1] + , testGroup "HMAC DRBG Suite 6 (Reseed)" [mapDRBGRsd r2] + , testGroup "HMAC DRBG Suite 7 (Reseed)" [mapDRBGRsd r3] + , testGroup "HMAC DRBG Suite 8 (Reseed)" [mapDRBGRsd r4] + , testGroup "Murmur Hash 3" + (map mapMurmurVector $ zip murmurVectors [0..]) + , testGroup "Compact number representation" + [ testCase "Compact number representations" testCompact ] + ] + +type TestVector = [String] + +mapDRBG :: [TestVector] -> Test.Framework.Test +mapDRBG vs = testCase "HMAC DRBG Vectors" $ mapM_ testDRBG $ zip vs [0..] + +mapDRBGRsd :: [TestVector] -> Test.Framework.Test +mapDRBGRsd vs = testCase "HMAC DRBG Vectors" $ mapM_ testDRBGRsd $ zip vs [0..] + +testDRBG :: (TestVector,Int) -> Assertion +testDRBG (s,i) = do + let w1 = hmacDRBGNew (v !! 0) (v !! 1) (v !! 2) + (w2,_) = hmacDRBGGen w1 128 (v !! 3) + (_,r) = hmacDRBGGen w2 128 (v !! 4) + assertBool name $ fromJust r == (v !! 5) + where v = map (fromJust . hexToBS) s + name = " > HMAC DRBG Vector " ++ (show i) + +testDRBGRsd :: (TestVector,Int) -> Assertion +testDRBGRsd (s,i) = do + let w1 = hmacDRBGNew (v !! 0) (v !! 1) (v !! 2) + w2 = hmacDRBGRsd w1 (v !! 3) (v !! 4) + (w3,_) = hmacDRBGGen w2 128 (v !! 5) + (_,r) = hmacDRBGGen w3 128 (v !! 6) + assertBool name $ fromJust r == (v !! 7) + where v = map (fromJust . hexToBS) s + name = " > HMAC DRBG Vector " ++ (show i) + +mapMurmurVector :: ((Word32,Word32,String),Int) -> Test.Framework.Test +mapMurmurVector (_,i) = + testCase ("MurmurHash3 Vector " ++ (show i)) func + where + func = testMurmurVector $ murmurVectors !! i + +testMurmurVector :: (Word32,Word32,String) -> Assertion +testMurmurVector (expected,seed,str) = + assertBool " > MurmurHash3 " $ hash == expected + where + hash = murmurHash3 seed (fromJust $ hexToBS str) + +murmurVectors :: [(Word32,Word32,String)] +murmurVectors = + [ (0x00000000, 0x00000000, "") + , (0x6a396f08, 0xFBA4C795, "") + , (0x81f16f39, 0xffffffff, "") + , (0x514e28b7, 0x00000000, "00") + , (0xea3f0b17, 0xFBA4C795, "00") + , (0xfd6cf10d, 0x00000000, "ff") + , (0x16c6b7ab, 0x00000000, "0011") + , (0x8eb51c3d, 0x00000000, "001122") + , (0xb4471bf8, 0x00000000, "00112233") + , (0xe2301fa8, 0x00000000, "0011223344") + , (0xfc2e4a15, 0x00000000, "001122334455") + , (0xb074502c, 0x00000000, "00112233445566") + , (0x8034d2a0, 0x00000000, "0011223344556677") + , (0xb4698def, 0x00000000, "001122334455667788") + ] + +testCompact :: Assertion +testCompact = do + assertBool "Vector 1" $ (encodeCompact 0x1234560000) == 0x05123456 + assertBool "Vector 2" $ (decodeCompact 0x05123456) == 0x1234560000 + assertBool "Vector 3" $ (encodeCompact 0xc0de000000) == 0x0600c0de + assertBool "Vector 4" $ (decodeCompact 0x0600c0de) == 0xc0de000000 + assertBool "Vector 5" $ (encodeCompact (-0x40de000000)) == 0x05c0de00 + assertBool "Vector 6" $ (decodeCompact 0x05c0de00) == (-0x40de000000) + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +t1 :: [TestVector] +t1 = + [ + -- COUNT = 0 + [ "ca851911349384bffe89de1cbdc46e6831e44d34a4fb935ee285dd14b71a7488" + , "659ba96c601dc69fc902940805ec0ca8" + , "" + , "" + , "" + , "e528e9abf2dece54d47c7e75e5fe302149f817ea9fb4bee6f4199697d04d5b89d54fbb978a15b5c443c9ec21036d2460b6f73ebad0dc2aba6e624abf07745bc107694bb7547bb0995f70de25d6b29e2d3011bb19d27676c07162c8b5ccde0668961df86803482cb37ed6d5c0bb8d50cf1f50d476aa0458bdaba806f48be9dcb8" + ], + -- COUNT = 1 + [ "79737479ba4e7642a221fcfd1b820b134e9e3540a35bb48ffae29c20f5418ea3" + , "3593259c092bef4129bc2c6c9e19f343" + , "" + , "" + , "" + , "cf5ad5984f9e43917aa9087380dac46e410ddc8a7731859c84e9d0f31bd43655b924159413e2293b17610f211e09f770f172b8fb693a35b85d3b9e5e63b1dc252ac0e115002e9bedfb4b5b6fd43f33b8e0eafb2d072e1a6fee1f159df9b51e6c8da737e60d5032dd30544ec51558c6f080bdbdab1de8a939e961e06b5f1aca37" + ], + -- COUNT = 2 + [ "b340907445b97a8b589264de4a17c0bea11bb53ad72f9f33297f05d2879d898d" + , "65cb27735d83c0708f72684ea58f7ee5" + , "" + , "" + , "" + , "75183aaaf3574bc68003352ad655d0e9ce9dd17552723b47fab0e84ef903694a32987eeddbdc48efd24195dbdac8a46ba2d972f5808f23a869e71343140361f58b243e62722088fe10a98e43372d252b144e00c89c215a76a121734bdc485486f65c0b16b8963524a3a70e6f38f169c12f6cbdd169dd48fe4421a235847a23ff" + ], + -- COUNT = 3 + [ "8e159f60060a7d6a7e6fe7c9f769c30b98acb1240b25e7ee33f1da834c0858e7" + , "c39d35052201bdcce4e127a04f04d644" + , "" + , "" + , "" + , "62910a77213967ea93d6457e255af51fc79d49629af2fccd81840cdfbb4910991f50a477cbd29edd8a47c4fec9d141f50dfde7c4d8fcab473eff3cc2ee9e7cc90871f180777a97841597b0dd7e779eff9784b9cc33689fd7d48c0dcd341515ac8fecf5c55a6327aea8d58f97220b7462373e84e3b7417a57e80ce946d6120db5" + ], + -- COUNT = 4 + [ "74755f196305f7fb6689b2fe6835dc1d81484fc481a6b8087f649a1952f4df6a" + , "c36387a544a5f2b78007651a7b74b749" + , "" + , "" + , "" + , "b2896f3af4375dab67e8062d82c1a005ef4ed119d13a9f18371b1b873774418684805fd659bfd69964f83a5cfe08667ddad672cafd16befffa9faed49865214f703951b443e6dca22edb636f3308380144b9333de4bcb0735710e4d9266786342fc53babe7bdbe3c01a3addb7f23c63ce2834729fabbd419b47beceb4a460236" + ], + -- COUNT = 5 + [ "4b222718f56a3260b3c2625a4cf80950b7d6c1250f170bd5c28b118abdf23b2f" + , "7aed52d0016fcaef0b6492bc40bbe0e9" + , "" + , "" + , "" + , "a6da029b3665cd39fd50a54c553f99fed3626f4902ffe322dc51f0670dfe8742ed48415cf04bbad5ed3b23b18b7892d170a7dcf3ef8052d5717cb0c1a8b3010d9a9ea5de70ae5356249c0e098946030c46d9d3d209864539444374d8fbcae068e1d6548fa59e6562e6b2d1acbda8da0318c23752ebc9be0c1c1c5b3cf66dd967" + ], + -- COUNT = 6 + [ "b512633f27fb182a076917e39888ba3ff35d23c3742eb8f3c635a044163768e0" + , "e2c39b84629a3de5c301db5643af1c21" + , "" + , "" + , "" + , "fb931d0d0194a97b48d5d4c231fdad5c61aedf1c3a55ac24983ecbf38487b1c93396c6b86ff3920cfa8c77e0146de835ea5809676e702dee6a78100da9aa43d8ec0bf5720befa71f82193205ac2ea403e8d7e0e6270b366dc4200be26afd9f63b7e79286a35c688c57cbff55ac747d4c28bb80a2b2097b3b62ea439950d75dff" + ], + -- COUNT = 7 + [ "aae3ffc8605a975befefcea0a7a286642bc3b95fb37bd0eb0585a4cabf8b3d1e" + , "9504c3c0c4310c1c0746a036c91d9034" + , "" + , "" + , "" + , "2819bd3b0d216dad59ddd6c354c4518153a2b04374b07c49e64a8e4d055575dfbc9a8fcde68bd257ff1ba5c6000564b46d6dd7ecd9c5d684fd757df62d85211575d3562d7814008ab5c8bc00e7b5a649eae2318665b55d762de36eba00c2906c0e0ec8706edb493e51ca5eb4b9f015dc932f262f52a86b11c41e9a6d5b3bd431" + ], + -- COUNT = 8 + [ "b9475210b79b87180e746df704b3cbc7bf8424750e416a7fbb5ce3ef25a82cc6" + , "24baf03599c10df6ef44065d715a93f7" + , "" + , "" + , "" + , "ae12d784f796183c50db5a1a283aa35ed9a2b685dacea97c596ff8c294906d1b1305ba1f80254eb062b874a8dfffa3378c809ab2869aa51a4e6a489692284a25038908a347342175c38401193b8afc498077e10522bec5c70882b7f760ea5946870bd9fc72961eedbe8bff4fd58c7cc1589bb4f369ed0d3bf26c5bbc62e0b2b2" + ], + -- COUNT = 9 + [ "27838eb44ceccb4e36210703ebf38f659bc39dd3277cd76b7a9bcd6bc964b628" + , "39cfe0210db2e7b0eb52a387476e7ea1" + , "" + , "" + , "" + , "e5e72a53605d2aaa67832f97536445ab774dd9bff7f13a0d11fd27bf6593bfb52309f2d4f09d147192199ea584503181de87002f4ee085c7dc18bf32ce5315647a3708e6f404d6588c92b2dda599c131aa350d18c747b33dc8eda15cf40e95263d1231e1b4b68f8d829f86054d49cfdb1b8d96ab0465110569c8583a424a099a" + ], + -- COUNT = 10 + [ "d7129e4f47008ad60c9b5d081ff4ca8eb821a6e4deb91608bf4e2647835373a5" + , "a72882773f78c2fc4878295840a53012" + , "" + , "" + , "" + , "0cbf48585c5de9183b7ff76557f8fc9ebcfdfde07e588a8641156f61b7952725bbee954f87e9b937513b16bba0f2e523d095114658e00f0f3772175acfcb3240a01de631c19c5a834c94cc58d04a6837f0d2782fa53d2f9f65178ee9c837222494c799e64c60406069bd319549b889fa00a0032dd7ba5b1cc9edbf58de82bfcd" + ], + -- COUNT = 11 + [ "67fe5e300c513371976c80de4b20d4473889c9f1214bce718bc32d1da3ab7532" + , "e256d88497738a33923aa003a8d7845c" + , "" + , "" + , "" + , "b44660d64ef7bcebc7a1ab71f8407a02285c7592d755ae6766059e894f694373ed9c776c0cfc8594413eefb400ed427e158d687e28da3ecc205e0f7370fb089676bbb0fa591ec8d916c3d5f18a3eb4a417120705f3e2198154cd60648dbfcfc901242e15711cacd501b2c2826abe870ba32da785ed6f1fdc68f203d1ab43a64f" + ], + -- COUNT = 12 + [ "de8142541255c46d66efc6173b0fe3ffaf5936c897a3ce2e9d5835616aafa2cb" + , "d01f9002c407127bc3297a561d89b81d" + , "" + , "" + , "" + , "64d1020929d74716446d8a4e17205d0756b5264867811aa24d0d0da8644db25d5cde474143c57d12482f6bf0f31d10af9d1da4eb6d701bdd605a8db74fb4e77f79aaa9e450afda50b18d19fae68f03db1d7b5f1738d2fdce9ad3ee9461b58ee242daf7a1d72c45c9213eca34e14810a9fca5208d5c56d8066bab1586f1513de7" + ], + -- COUNT = 13 + [ "4a8e0bd90bdb12f7748ad5f147b115d7385bb1b06aee7d8b76136a25d779bcb7" + , "7f3cce4af8c8ce3c45bdf23c6b181a00" + , "" + , "" + , "" + , "320c7ca4bbeb7af977bc054f604b5086a3f237aa5501658112f3e7a33d2231f5536d2c85c1dad9d9b0bf7f619c81be4854661626839c8c10ae7fdc0c0b571be34b58d66da553676167b00e7d8e49f416aacb2926c6eb2c66ec98bffae20864cf92496db15e3b09e530b7b9648be8d3916b3c20a3a779bec7d66da63396849aaf" + ], + -- COUNT = 14 + [ "451ed024bc4b95f1025b14ec3616f5e42e80824541dc795a2f07500f92adc665" + , "2f28e6ee8de5879db1eccd58c994e5f0" + , "" + , "" + , "" + , "3fb637085ab75f4e95655faae95885166a5fbb423bb03dbf0543be063bcd48799c4f05d4e522634d9275fe02e1edd920e26d9accd43709cb0d8f6e50aa54a5f3bdd618be23cf73ef736ed0ef7524b0d14d5bef8c8aec1cf1ed3e1c38a808b35e61a44078127c7cb3a8fd7addfa50fcf3ff3bc6d6bc355d5436fe9b71eb44f7fd" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +t2 :: [TestVector] +t2 = + [ + -- COUNT = 0 + [ "d3cc4d1acf3dde0c4bd2290d262337042dc632948223d3a2eaab87da44295fbd" + , "0109b0e729f457328aa18569a9224921" + , "" + , "3c311848183c9a212a26f27f8c6647e40375e466a0857cc39c4e47575d53f1f6" + , "fcb9abd19ccfbccef88c9c39bfb3dd7b1c12266c9808992e305bc3cff566e4e4" + , "9c7b758b212cd0fcecd5daa489821712e3cdea4467b560ef5ddc24ab47749a1f1ffdbbb118f4e62fcfca3371b8fbfc5b0646b83e06bfbbab5fac30ea09ea2bc76f1ea568c9be0444b2cc90517b20ca825f2d0eccd88e7175538b85d90ab390183ca6395535d34473af6b5a5b88f5a59ee7561573337ea819da0dcc3573a22974" + ], + -- COUNT = 1 + [ "f97a3cfd91faa046b9e61b9493d436c4931f604b22f1081521b3419151e8ff06" + , "11f3a7d43595357d58120bd1e2dd8aed" + , "" + , "517289afe444a0fe5ed1a41dbbb5eb17150079bdd31e29cf2ff30034d8268e3b" + , "88028d29ef80b4e6f0fe12f91d7449fe75062682e89c571440c0c9b52c42a6e0" + , "c6871cff0824fe55ea7689a52229886730450e5d362da5bf590dcf9acd67fed4cb32107df5d03969a66b1f6494fdf5d63d5b4d0d34ea7399a07d0116126d0d518c7c55ba46e12f62efc8fe28a51c9d428e6d371d7397ab319fc73ded4722e5b4f30004032a6128df5e7497ecf82ca7b0a50e867ef6728a4f509a8c859087039c" + ], + -- COUNT = 2 + [ "0f2f23d64f481cabec7abb01db3aabf125c3173a044b9bf26844300b69dcac8b" + , "9a5ae13232b43aa19cfe8d7958b4b590" + , "" + , "ec4c7a62acab73385f567da10e892ff395a0929f959231a5628188ce0c26e818" + , "6b97b8c6b6bb8935e676c410c17caa8042aa3145f856d0a32b641e4ae5298648" + , "7480a361058bd9afa3db82c9d7586e42269102013f6ec5c269b6d05f17987847748684766b44918fd4b65e1648622fc0e0954178b0279dfc9fa99b66c6f53e51c4860131e9e0644287a4afe4ca8e480417e070db68008a97c3397e4b320b5d1a1d7e1d18a95cfedd7d1e74997052bf649d132deb9ec53aae7dafdab55e6dae93" + ], + -- COUNT = 3 + [ "53c56660c78481be9c63284e005fcc14fbc7fb27732c9bf1366d01a426765a31" + , "dc7a14d0eb5b0b3534e717a0b3c64614" + , "" + , "3aa848706ecb877f5bedf4ffc332d57c22e08747a47e75cff6f0fd1316861c95" + , "9a401afa739b8f752fddacd291e0b854f5eff4a55b515e20cb319852189d3722" + , "5c0eb420e0bf41ce9323e815310e4e8303cd677a8a8b023f31f0d79f0ca15aeb636099a369fd074d69889865eac1b72ab3cbfebdb8cf460b00072802e2ec648b1349a5303be4ccaadd729f1a9ea17482fd026aaeb93f1602bc1404b9853adde40d6c34b844cf148bc088941ecfc1642c8c0b9778e45f3b07e06e21ee2c9e0300" + ], + -- COUNT = 4 + [ "f63c804404902db334c54bb298fc271a21d7acd9f770278e089775710bf4fdd7" + , "3e45009ea9cb2a36ba1aa4bf39178200" + , "" + , "d165a13dc8cc43f3f0952c3f5d3de4136954d983683d4a3e6d2dc4c89bf23423" + , "75106bc86d0336df85097f6af8e80e2da59046a03fa65b06706b8bbc7ffc6785" + , "6363139bba32c22a0f5cd23ca6d437b5669b7d432f786b8af445471bee0b2d24c9d5f2f93717cbe00d1f010cc3b9c515fc9f7336d53d4d26ba5c0d76a90186663c8582eb739c7b6578a3328bf68dc2cec2cd89b3a90201f6993adcc854df0f5c6974d0f5570765a15fe03dbce28942dd2fd16ba2027e68abac83926969349af8" + ], + -- COUNT = 5 + [ "2aaca9147da66c176615726b69e3e851cc3537f5f279fe7344233d8e44cfc99d" + , "4e171f080af9a6081bee9f183ac9e340" + , "" + , "d75a2a6eb66c3833e50f5ec3d2e434cf791448d618026d0c360806d120ded669" + , "b643b74c15b37612e6577ed7ca2a4c67a78d560af9eb50a4108fca742e87b8d6" + , "501dcdc977f4ba856f24eaa4968b374bebb3166b280334cb510232c31ebffde10fa47b7840ef3fe3b77725c2272d3a1d4219baf23e0290c622271edcced58838cf428f0517425d2e19e0d8c89377eecfc378245f283236fafa466c914b99672ceafab369e8889a0c866d8bd639db9fb797254262c6fd44cfa9045ad6340a60ef" + ], + -- COUNT = 6 + [ "a2e4cd48a5cf918d6f55942d95fcb4e8465cdc4f77b7c52b6fae5b16a25ca306" + , "bef036716440db6e6d333d9d760b7ca8" + , "" + , "bfa591c7287f3f931168f95e38869441d1f9a11035ad8ea625bb61b9ea17591c" + , "c00c735463bca215adc372cb892b05e939bf669583341c06d4e31d0e5b363a37" + , "e7d136af69926a5421d4266ee0420fd729f2a4f7c295d3c966bdfa05268180b508b8a2852d1b3a06fd2ab3e13c54005123ef319f42d0c6d3a575e6e7e1496cb28aacadbcf83740fba8f35fcee04bb2ed8a51db3d3362b01094a62fb57e33c99a432f29fce6676cffbbcc05107e794e75e44a02d5e6d9d748c5fbff00a0178d65" + ], + -- COUNT = 7 + [ "95a67771cba69011a79776e713145d309edae56fad5fd6d41d83eaff89df6e5e" + , "be5b5164e31ecc51ba6f7c3c5199eb33" + , "" + , "065f693b229a7c4fd373cd15b3807552dd9bf98c5485cef361949d4e7d774b53" + , "9afb62406f0e812c4f156d58b19a656c904813c1b4a45a0029ae7f50731f8014" + , "f61b61a6e79a41183e8ed6647899d2dc85cdaf5c3abf5c7f3bf37685946dc28f4923dc842f2d4326bd6ce0d50a84cb3ba869d72a36e246910eba6512ba36cd7ed3a5437c9245b00a344308c792b668b458d3c3e16dee2fbec41867da31084d46d8ec168de2148ef64fc5b72069abf5a6ada1ead2b7146bb793ff1c9c3690fa56" + ], + -- COUNT = 8 + [ "a459e1815cbca4514ec8094d5ab2414a557ba6fe10e613c345338d0521e4bf90" + , "62221392e2552e76cd0d36df6e6068eb" + , "" + , "0a3642b02b23b3ef62c701a63401124022f5b896de86dab6e6c7451497aa1dcc" + , "c80514865901371c45ba92d9f95d50bb7c9dd1768cb3dfbc45b968da94965c6e" + , "464e6977b8adaef307c9623e41c357013249c9ffd77f405f3925cebb69f151ce8fbb6a277164002aee7858fc224f6499042aa1e6322deee9a5d133c31d640e12a7487c731ba03ad866a24675badb1d79220c40be689f79c2a0be93cb4dada3e0eac4ab140cb91998b6f11953e68f2319b050c40f71c34de9905ae41b2de1c2f6" + ], + -- COUNT = 9 + [ "252c2cad613e002478162861880979ee4e323025eebb6fb2e0aa9f200e28e0a1" + , "d001bc9a8f2c8c242e4369df0c191989" + , "" + , "9bcfc61cb2bc000034bb3db980eb47c76fb5ecdd40553eff113368d639b947fd" + , "8b0565c767c2610ee0014582e9fbecb96e173005b60e9581503a6dca5637a26e" + , "e96c15fe8a60692b0a7d67171e0195ff6e1c87aab844221e71700d1bbee75feea695f6a740c9760bbe0e812ecf4061d8f0955bc0195e18c4fd1516ebca50ba6a6db86881737dbab8321707675479b87611db6af2c97ea361a5484555ead454defb1a64335de964fc803d40f3a6f057893d2afc25725754f4f00abc51920743dc" + ], + -- COUNT = 10 + [ "8be0ca6adc8b3870c9d69d6021bc1f1d8eb9e649073d35ee6c5aa0b7e56ad8a5" + , "9d1265f7d51fdb65377f1e6edd6ae0e4" + , "" + , "da86167ac997c406bb7979f423986a84ec6614d6caa7afc10aff0699a9b2cf7f" + , "e4baa3c555950b53e2bfdba480cb4c94b59381bac1e33947e0c22e838a9534cf" + , "64384ecc4ea6b458efc227ca697eac5510092265520c0a0d8a0ccf9ed3ca9d58074671188c6a7ad16d0b050cdc072c125d7298d3a31d9f044a9ee40da0089a84fea28cc7f05f1716db952fad29a0e779635cb7a912a959be67be2f0a4170aace2981802e2ff6467e5b46f0ffbff3b42ba5935fd553c82482ac266acf1cd247d7" + ], + -- COUNT = 11 + [ "d43a75b6adf26d60322284cb12ac38327792442aa8f040f60a2f331b33ac4a8f" + , "0682f8b091f811afacaacaec9b04d279" + , "" + , "7fd3b8f512940da7de5d80199d9a7b42670c04a945775a3dba869546cbb9bc65" + , "2575db20bc7aafc2a90a5dabab760db851d754777bc9f05616af1858b24ff3da" + , "0da7a8dc73c163014bf0841913d3067806456bbca6d5de92b85534c6545467313648d71ef17c923d090dc92cff8d4d1a9a2bb63e001dc2e8ab1a597999be3d6cf70ff63fee9985801395fbd4f4990430c4259fcae4fa1fcd73dc3187ccc102d04af7c07532885e5a226fc42809c48f22eecf4f6ab996ae4fcb144786957d9f41" + ], + -- COUNT = 12 + [ "64352f236af5d32067a529a8fd05ba00a338c9de306371a0b00c36e610a48d18" + , "df99ed2c7608c870624b962a5dc68acd" + , "" + , "da416335e7aaf60cf3d06fb438735ce796aad09034f8969c8f8c3f81e32fef24" + , "a28c07c21a2297311adf172c19e83ca0a87731bdffb80548978d2d1cd82cf8a3" + , "132b9f25868729e3853d3c51f99a3b5fae6d4204bea70890daf62e042b776a526c8fb831b80a6d5d3f153237df1fd39b6fd9137963f5516d9cdd4e3f9195c46e9972c15d3edc6606e3368bde1594977fb88d0ca6e6f5f3d057ccadc7d7dab77dfc42658a1e972aa446b20d418286386a52dfc1c714d2ac548713268b0b709729" + ], + -- COUNT = 13 + [ "282f4d2e05a2cd30e9087f5633089389449f04bac11df718c90bb351cd3653a5" + , "90a7daf3c0de9ea286081efc4a684dfb" + , "" + , "2630b4ccc7271cc379cb580b0aaede3d3aa8c1c7ba002cf791f0752c3d739007" + , "c31d69de499f1017be44e3d4fa77ecebc6a9b9934749fcf136f267b29115d2cc" + , "c899094520e0197c37b91dd50778e20a5b950decfb308d39f1db709447ae48f6101d9abe63a783fbb830eec1d359a5f61a2013728966d349213ee96382614aa4135058a967627183810c6622a2158cababe3b8ab99169c89e362108bf5955b4ffc47440f87e4bad0d36bc738e737e072e64d8842e7619f1be0af1141f05afe2d" + ], + -- COUNT = 14 + [ "13c752b9e745ce77bbc7c0dbda982313d3fe66f903e83ebd8dbe4ff0c11380e9" + , "f1a533095d6174164bd7c82532464ae7" + , "" + , "4f53db89b9ba7fc00767bc751fb8f3c103fe0f76acd6d5c7891ab15b2b7cf67c" + , "582c2a7d34679088cca6bd28723c99aac07db46c332dc0153d1673256903b446" + , "6311f4c0c4cd1f86bd48349abb9eb930d4f63df5e5f7217d1d1b91a71d8a6938b0ad2b3e897bd7e3d8703db125fab30e03464fad41e5ddf5bf9aeeb5161b244468cfb26a9d956931a5412c97d64188b0da1bd907819c686f39af82e91cfeef0cbffb5d1e229e383bed26d06412988640706815a6e820796876f416653e464961" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +t3 :: [TestVector] +t3 = + [ + -- COUNT = 0 + [ "5cacc68165a2e2ee20812f35ec73a79dbf30fd475476ac0c44fc6174cdac2b55" + , "6f885496c1e63af620becd9e71ecb824" + , "e72dd8590d4ed5295515c35ed6199e9d211b8f069b3058caa6670b96ef1208d0" + , "" + , "" + , "f1012cf543f94533df27fedfbf58e5b79a3dc517a9c402bdbfc9a0c0f721f9d53faf4aafdc4b8f7a1b580fcaa52338d4bd95f58966a243cdcd3f446ed4bc546d9f607b190dd69954450d16cd0e2d6437067d8b44d19a6af7a7cfa8794e5fbd728e8fb2f2e8db5dd4ff1aa275f35886098e80ff844886060da8b1e7137846b23b" + ], + -- COUNT = 1 + [ "8df013b4d103523073917ddf6a869793059e9943fc8654549e7ab22f7c29f122" + , "da2625af2ddd4abcce3cf4fa4659d84e" + , "b571e66d7c338bc07b76ad3757bb2f9452bf7e07437ae8581ce7bc7c3ac651a9" + , "" + , "" + , "b91cba4cc84fa25df8610b81b641402768a2097234932e37d590b1154cbd23f97452e310e291c45146147f0da2d81761fe90fba64f94419c0f662b28c1ed94da487bb7e73eec798fbcf981b791d1be4f177a8907aa3c401643a5b62b87b89d66b3a60e40d4a8e4e9d82af6d2700e6f535cdb51f75c321729103741030ccc3a56" + ], + -- COUNT = 2 + [ "565b2b77937ba46536b0f693b3d5e4a8a24563f9ef1f676e8b5b2ef17823832f" + , "4ef3064ec29f5b7f9686d75a23d170e3" + , "3b722433226c9dba745087270ab3af2c909425ba6d39f5ce46f07256068319d9" + , "" + , "" + , "d144ee7f8363d128872f82c15663fe658413cd42651098e0a7c51a970de75287ec943f9061e902280a5a9e183a7817a44222d198fbfab184881431b4adf35d3d1019da5a90b3696b2349c8fba15a56d0f9d010a88e3f9eeedb67a69bcaa71281b41afa11af576b765e66858f0eb2e4ec4081609ec81da81df0a0eb06787340ea" + ], + -- COUNT = 3 + [ "fc3832a91b1dcdcaa944f2d93cbceb85c267c491b7b59d017cde4add79a836b6" + , "d5e76ce9eabafed06e33a913e395c5e0" + , "ffc5f6eefd51da64a0f67b5f0cf60d7ab43fc7836bca650022a0cee57a43c148" + , "" + , "" + , "0e713c6cc9a4dbd4249201d12b7bf5c69c3e18eb504bf3252db2f43675e17d99b6a908400cea304011c2e54166dae1f20260008efe4e06a87e0ce525ca482bca223a902a14adcf2374a739a5dfeaf14cadd72efa4d55d15154c974d9521535bcb70658c5b6c944020afb04a87b223b4b8e5d89821704a9985bb010405ba8f3d4" + ], + -- COUNT = 4 + [ "8009eb2cb49fdf16403bcdfd4a9f952191062acb9cc111eca019f957fb9f4451" + , "355598866952394b1eddd85d59f81c9d" + , "09ff1d4b97d83b223d002e05f754be480d13ba968e5aac306d71cc9fc49cc2dd" + , "" + , "" + , "9550903c2f02cf77c8f9c9a37041d0040ee1e3ef65ba1a1fbbcf44fb7a2172bd6b3aaabe850281c3a1778277bacd09614dfefececac64338ae24a1bf150cbf9d9541173a82ecba08aa19b75abb779eb10efa4257d5252e8afcac414bc3bb5d3006b6f36fb9daea4c8c359ef6cdbeff27c1068571dd3c89dc87eda9190086888d" + ], + -- COUNT = 5 + [ "a6e4c9a8bd6da23b9c2b10a7748fd08c4f782fadbac7ea501c17efdc6f6087bd" + , "acdc47edf1d3b21d0aec7631abb6d7d5" + , "c16ee0908a5886dccf332fbc61de9ec7b7972d2c4c83c477409ce8a15c623294" + , "" + , "" + , "a52f93ccb363e2bdf0903622c3caedb7cffd04b726052b8d455744c71b76dee1b71db9880dc3c21850489cb29e412d7d80849cfa9151a151dcbf32a32b4a54cac01d3200200ed66a3a5e5c131a49655ffbf1a8824ff7f265690dffb4054df46a707b9213924c631c5bce379944c856c4f7846e281ac89c64fad3a49909dfb92b" + ], + -- COUNT = 6 + [ "59d6307460a9bdd392dfc0904973991d585696010a71e52d590a5039b4849fa4" + , "34a0aafb95917cbf8c38fc5548373c05" + , "0407b7c57bc11361747c3d67526c36e228028a5d0b145d66ab9a2fe4b07507a0" + , "" + , "" + , "299aba0661315211b09d2861855d0b4b125ab24649461341af6abd903ed6f025223b3299f2126fcad44c675166d800619cf49540946b12138989417904324b0ddad121327211a297f11259c9c34ce4c70c322a653675f78d385e4e2443f8058d141195e17e0bd1b9d44bf3e48c376e6eb44ef020b11cf03eb141c46ecb43cf3d" + ], + -- COUNT = 7 + [ "9ae3506aadbc8358696ba1ba17e876e1157b7048235921503d36d9211b430342" + , "9abf7d66afee5d2b811cba358bbc527d" + , "0d645f6238e9ceb038e4af9772426ca110c5be052f8673b8b5a65c4e53d2f519" + , "" + , "" + , "5f032c7fec6320fe423b6f38085cbad59d826085afe915247b3d546c4c6b174554dd4877c0d671de9554b505393a44e71f209b70f991ac8aa6e08f983fff2a4c817b0cd26c12b2c929378506489a75b2025b358cb5d0400821e7e252ac6376cd94a40c911a7ed8b6087e3de5fa39fa6b314c3ba1c593b864ce4ff281a97c325b" + ], + -- COUNT = 8 + [ "96ae3b8775b36da2a29b889ad878941f43c7d51295d47440cd0e3c4999193109" + , "1fe022a6fc0237b055d4d6a7036b18d5" + , "1e40e97362d0a823d3964c26b81ab53825c56446c5261689011886f19b08e5c2" + , "" + , "" + , "e707cd14b06ce1e6dbcceaedbf08d88891b03f44ad6a797bd12fdeb557d0151df9346a028dec004844ca46adec3051dafb345895fa9f4604d8a13c8ff66ae093fa63c4d9c0816d55a0066d31e8404c841e87b6b2c7b5ae9d7afb6840c2f7b441bf2d3d8bd3f40349c1c014347c1979213c76103e0bece26ad7720601eff42275" + ], + -- COUNT = 9 + [ "33f5120396336e51ee3b0b619b5f873db05ca57cda86aeae2964f51480d14992" + , "6f1f6e9807ba5393edcf3cb4e4bb6113" + , "3709605af44d90196867c927512aa8ba31837063337b4879408d91a05c8efa9f" + , "" + , "" + , "8b8291126ded9acef12516025c99ccce225d844308b584b872c903c7bc6467599a1cead003dc4c70f6d519f5b51ce0da57f53da90dbe8f666a1a1dde297727fee2d44cebd1301fc1ca75956a3fcae0d374e0df6009b668fd21638d2b733e6902d22d5bfb4af1b455975e08eef0ebe4dc87705801e7776583c8de11672729f723" + ], + -- COUNT = 10 + [ "ad300b799005f290fee7f930eebce158b98fb6cb449987fe433f955456b35300" + , "06aa2514e4bd114edf7ac105cfef2772" + , "87ada711465e4169da2a74c931afb9b5a5b190d07b7af342aa99570401c3ee8a" + , "" + , "" + , "80d7c606ff49415a3a92ba1f2943235c01339c8f9cd0b0511fbfdf3ef23c42ffff008524193faaa4b7f2f2eb0cfa221d9df89bd373fe4e158ec06fad3ecf1eb48b8239b0bb826ee69d773883a3e8edac66254610ff70b6609836860e39ea1f3bfa04596fee1f2baca6cebb244774c6c3eb4af1f02899eba8f4188f91776de16f" + ], + -- COUNT = 11 + [ "130b044e2c15ab89375e54b72e7baae6d4cad734b013a090f4df057e634f6ff0" + , "65fd6ac602cd44107d705dbc066e52b6" + , "f374aba16f34d54aae5e494505b67d3818ef1c08ea24967a76876d4361379aec" + , "" + , "" + , "5d179534fb0dba3526993ed8e27ec9f915183d967336bb24352c67f4ab5d7935d3168e57008da851515efbaecb69904b6d899d3bfa6e9805659aef2942c4903875b8fcbc0d1d24d1c075f0ff667c1fc240d8b410dff582fa71fa30878955ce2ed786ef32ef852706e62439b69921f26e84e0f54f62b938f04905f05fcd7c2204" + ], + -- COUNT = 12 + [ "716430e999964b35459c17921fe5f60e09bd9ab234cb8f4ba4932bec4a60a1d5" + , "9533b711e061b07d505da707cafbca03" + , "372ae616d1a1fc45c5aecad0939c49b9e01c93bfb40c835eebd837af747f079d" + , "" + , "" + , "a80d6a1b2d0ce01fe0d26e70fb73da20d45841cf01bfbd50b90d2751a46114c0e758cb787d281a0a9cf62f5c8ce2ee7ca74fefff330efe74926acca6d6f0646e4e3c1a1e52fce1d57b88beda4a5815896f25f38a652cc240deb582921c8b1d03a1da966dd04c2e7eee274df2cd1837096b9f7a0d89a82434076bc30173229a60" + ], + -- COUNT = 13 + [ "7679f154296e6d580854826539003a82d1c54e2e062c619d00da6c6ac820789b" + , "55d12941b0896462e7d888e5322a99a3" + , "ba4d1ed696f58ef64596c76cee87cc1ca83069a79e7982b9a06f9d62f4209faf" + , "" + , "" + , "10dc7cd2bb68c2c28f76d1b04ae2aa287071e04c3b688e1986b05cc1209f691daa55868ebb05b633c75a40a32b49663185fe5bb8f906008347ef51590530948b87613920014802e5864e0758f012e1eae31f0c4c031ef823aecfb2f8a73aaa946fc507037f9050b277bdeaa023123f9d22da1606e82cb7e56de34bf009eccb46" + ], + -- COUNT = 14 + [ "8ca4a964e1ff68753db86753d09222e09b888b500be46f2a3830afa9172a1d6d" + , "a59394e0af764e2f21cf751f623ffa6c" + , "eb8164b3bf6c1750a8de8528af16cffdf400856d82260acd5958894a98afeed5" + , "" + , "" + , "fc5701b508f0264f4fdb88414768e1afb0a5b445400dcfdeddd0eba67b4fea8c056d79a69fd050759fb3d626b29adb8438326fd583f1ba0475ce7707bd294ab01743d077605866425b1cbd0f6c7bba972b30fbe9fce0a719b044fcc1394354895a9f8304a2b5101909808ddfdf66df6237142b6566588e4e1e8949b90c27fc1f" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +t4 :: [TestVector] +t4 = + [ + -- COUNT = 0 + [ "5d3286bc53a258a53ba781e2c4dcd79a790e43bbe0e89fb3eed39086be34174b" + , "c5422294b7318952ace7055ab7570abf" + , "2dba094d008e150d51c4135bb2f03dcde9cbf3468a12908a1b025c120c985b9d" + , "793a7ef8f6f0482beac542bb785c10f8b7b406a4de92667ab168ecc2cf7573c6" + , "2238cdb4e23d629fe0c2a83dd8d5144ce1a6229ef41dabe2a99ff722e510b530" + , "d04678198ae7e1aeb435b45291458ffde0891560748b43330eaf866b5a6385e74c6fa5a5a44bdb284d436e98d244018d6acedcdfa2e9f499d8089e4db86ae89a6ab2d19cb705e2f048f97fb597f04106a1fa6a1416ad3d859118e079a0c319eb95686f4cbcce3b5101c7a0b010ef029c4ef6d06cdfac97efb9773891688c37cf" + ], + -- COUNT = 1 + [ "c2a566a9a1817b15c5c3b778177ac87c24e797be0a845f11c2fe399dd37732f2" + , "cb1894eb2b97b3c56e628329516f86ec" + , "13ce4d8dd2db9796f94156c8e8f0769b0aa1c82c1323b61536603bca37c9ee29" + , "413dd83fe56835abd478cb9693d67635901c40239a266462d3133b83e49c820b" + , "d5c4a71f9d6d95a1bedf0bd2247c277d1f84a4e57a4a8825b82a2d097de63ef1" + , "b3a3698d777699a0dd9fa3f0a9fa57832d3cefac5df24437c6d73a0fe41040f1729038aef1e926352ea59de120bfb7b073183a34106efed6278ff8ad844ba0448115dfddf3319a82de6bb11d80bd871a9acd35c73645e1270fb9fe4fa88ec0e465409ea0cba809fe2f45e04943a2e396bbb7dd2f4e0795303524cc9cc5ea54a1" + ], + -- COUNT = 2 + [ "a33288a96f41dd54b945e060c8bd0c094f1e28267cc1dcbba52063c1a9d54c4d" + , "36918c977e1a7276a2bb475591c367b7" + , "6aa528c940962638dc2201738850fd1fe6f5d0eb9f687ff1af39d9c7b36830d9" + , "37ee633a635e43af59abdb1762c7ea45bfe060ec1d9077ecd2a43a658673f3c7" + , "2eb96f2e28fa9f674bb03ade703b8f791ee5356e2ee85c7ed5bda96325256c61" + , "db2f91932767eb846961ce5321c7003431870508e8c6f8d432ca1f9cee5cdc1aed6e0f133d317eb6990c4b3b0a360cdfb5b43a6e712bd46bca04c414868fab22c6a49c4b89c812697c3a7fbfc8ddf10c8aa5ebf13a09fd114eb2a02a07f69786f3ce7fd30231f22779bc8db103b13fa546dbc45a89a86275281172761683d384" + ], + -- COUNT = 3 + [ "5f37b6e47e1776e735adc03d4b999879477ff4a206231924033d94c0114f911b" + , "7d12d62c79c9f6234ae0314156947459" + , "92d4d9fab5f8bf5119f2663a9df7334f50dcde74fb9d7732f7eba56501e60d54" + , "c9aef0d7a9ba7345d08b6d5b5ce5645c7495b8685e6b93846ffcf470f5abd40d" + , "50d9d1f5074f7d9f1a24a9c63aa47b94da5ba78db1b0f18e4d4fe45c6875813c" + , "20d942bbd7d98700faa37e94d53bf74f2d6bd1d8c95c0b88d842c4857797d59e7c8788aeeac29740122f208f703bf35dc32b0035db0648384feb6aa17a3274bc09b2d2b746c5a06fd82f4469fb86131a49482cb7be7d9b4b95042394cfb18b13f333ec0fe5c227bf1d8f33ecb2e42e358b6c3e034cb585331bd1d27f638029b9" + ], + -- COUNT = 4 + [ "2311c5afd64c584484b2729e84db80c0b4063fe9ca7edc83350488d7e67264a0" + , "6a6dfd975a0dc7b72df1f107c4b3b3a6" + , "2abd870ec5fe26ed14dfa57a3309f920131b70580c3639af2645cd1af93db1b1" + , "c6e532a3b25653b6002aed5269cc2118749306e736bde039d4d569d4f967773f" + , "5e7d26c4da769c373092b2b4f72b109fe34bdb7d169ea38f78ebae5df4a15759" + , "cacaeb1b4ac2305d8714eb50cbe1c67c5a2c0bbc7938fdfdcafef7c85fc40becbf777a4cfb6f14c6eee320943a493d2b0a744a6eb3c256ee9a3763037437df9adce3e2260f0c35e958af0edb5a81debd8bdaf2b8bb2b98b9186e5a222a21609ff58df4cbe1d4898d10d6e7c46f31f5cb1041bfd83a5fb27d5c56c961e91403fc" + ], + -- COUNT = 5 + [ "362ece9d330e1172a8f9e50258476d0c79c3ee50346524ba12d970ee3a6ef8c5" + , "cf11bcb4d9d51311ceacfca8705e833f" + , "abb5a8edde02e526449284ecc31bc713383df3ed085f752e3b6a32f305861eed" + , "746302ab1f4a86b17546bea762e929360f2e95c7788a63545a264ef997c8c65e" + , "b907c5b2a8833a48e56e819228ce9a050b41b3309f5ca37bed720311d92b33af" + , "73c7131a558350590053580873ef956ff952f2aa6ff1bea452e013d1bc2afddea2311756dbe756e63ba6258480c48f3f6c1319b5f572f67ca530af09e39413d1d432bea8f89206619618cb0e7c88e9f2033639d0eb0efc20616b64f940da99b88231984c3fb23f19e890576f555fde394dbd4351f17a7ffd5c369379001bda03" + ], + -- COUNT = 6 + [ "cf614bc29946bc0095f415e8bdeda10aab05392f9cc9187a86ea6ec95ee422e1" + , "77fb5ec22dc0432cc13f4693e2e3bd9a" + , "e4ce77914ffbc5fddf1fb51edfafdc196109139b84c741354135ec8d314c7c43" + , "e1e83ee1205acaf6164dc287aec08e5b32789e5be818078db39e53cad589db51" + , "4e20c0226d5e1e7e805679f03f72452b5bea2d0ba41e0c12329bf60eb3016dd1" + , "838fdf1418a746aa52ae4005d90c3fd301f648c5770ffef2a9f3912e37a93850cc4b8bfcce910aead0cb75958823b1a62e283901c5e4a3980e4ea36257458e2e4953555819b8852a26489b1d74821f80c9908469b43f124ff7ea62497c36159a47353098a1b9ec32e54800d6704371cc37f357ad74aacc203e9b6db97f94d0c4" + ], + -- COUNT = 7 + [ "a8da1d3e233f393fd44d204c200202f7d01896e72c5ac652940cfd15b5d4b0bd" + , "0a112b4cb0890af0a495e0f49fcf6874" + , "d2e32799bc822b8d033299bdf63dc35774f7649e935d25be5b10512c430d1bda" + , "920a82d76fcd2cd106ada64bba232b7b2344f3afe6b1d1d20ee8795144571009" + , "eeaac5878275372025f8231febed64db6a11273c3c00d625fc80a95f18ad7d3f" + , "5f6dae489b53d89027b2cc333c700f090152d77b3eaf01d47f56ce6eca9893ef877b4cb560fab0fbdb34e3d1c6cd8480b33c053d2661a10aa531df4961b97d659c7492584236582b3fe701055efa59c328194cd1e07fcffd910d9ee01b7b9e8c8fda7f7ac01a8e203b8b26eb8078a9b9a5021562c44af24089e3ef84c1d5a6bd" + ], + -- COUNT = 8 + [ "a77b1ed4ecaa650374e1052c405f1d88881c25c87d13dbe1334d8c1a847fa76b" + , "05c143e2f145db216fe7be9ed23635d0" + , "b5c750968ff09ed251d4a1c05342ac843db5246b19045728a634fa4f6e752e54" + , "ff5937bcd01a363696bf8e40adc8e4ab3e56dbf7e7d09451c99e538785fe6697" + , "4acb34eea8266badcf8f6557a0eecf3eb4d7a295c876d6175598cb66a388efb8" + , "ec13eadfcc84e77d2a2efa1a2cd8b1355587cb27feb3d19d75b37f0446333ddb8236e751c63b7a6e595ec24a25051a696dbe8c062dd8896d1446db228a2f10e8094ee07e7ee648ed6bebb2f5ec5aae24c9c640665c28355cc11c116795ecc070790f7fdfc4398900311b6695d5da0175091ed1828d2731085bfb4a20bd86cce0" + ], + -- COUNT = 9 + [ "491686c781e83eb4e21d9989e8d718100b0d21a2c56295888baef1a65f219651" + , "499085296d21065feabf3106101c8d6f" + , "d208a72f9ae34f0817669fb04f49239dd31700f3dc9a93db8d75fb79f9b686c1" + , "9ffc61893a293a864008fdd56d3292600d9e2ec8a1ea8f34ac5931e968905a23" + , "4ff3a397dfdae0912032a302a5e7a07dceca8d9013a21545689319b7c024cd07" + , "3c258ebf2203fca3b322ad1b016e21c7f5c148425f81e4fb0a0e462dce9dfa569c37a006527768297a5b68461b08912642a341b88c85597e30e7561206886098c4e2d861f11513f0ffdbbc78d3a2dd60c105abbb33c5e05ae27081b690fb8b3610917aa9bf1a4ad74481b5ff8334f14e5ad6a6a1eb2259476078076fb7e3a992" + ], + -- COUNT = 10 + [ "36a5267eeeb5a1a7d46de0f8f9281f73cd9611f01198fdaa78c5315205e5a177" + , "b66b5337970df36219321badacc624eb" + , "c2a7b164949da102bece44a423197682ff97627d1fe9654266b8527f64e5b386" + , "a977e2d8637b019c74063d163bb25387dc56f4eb40e502cefc5ae6ad26a6abdc" + , "c5c9819557b1e7d8a86fa8c60be42993edc3ef539c13d9a51fb64b0de06e145e" + , "b471711a4fc7ab7247e65d2c2fe49a50169187187b7978cd2fdb0f8318be3ec55fc68ed4577ad9b42cbb57100b5d35ac86c244c4c93a5b28c1a11c2dfe905d608ec7804dec5bb15cf8d79695534d5e13a6a7e18a887ec9cf184da0cbbc6267f3a952a769403bafcdbb559401be0d8b3300ea7258b4026fc892175efd55ba1a67" + ], + -- COUNT = 11 + [ "a76b0366df89e4073a6b6b9c04da1d6817ce26f1c4825cad4097bdf4d7b9445e" + , "773d3cc3290176773847869be528d1a4" + , "1bfd3bcfb9287a5ad055d1b2b8615fa81c94ac24bc1c219a0f8de58789e0404a" + , "edd879fa56f21d93029da875b683ce50f6fdc4c0da41da051d000eed2afefefa" + , "f528ffd29160039260133ed9654589ce60e39e7f667c34f82cda65ddcf5fff14" + , "39d1ff8848e74dd2cdc6b818ad69823878062116fdf1679942f892c7e191be1c4b6ea268ecdff001b22af0d510f30c2c25b90fc34927f46e3f45d36b0e1848b3a5d54c36c7c65ee7287d325dfbb51b56a438feb6650ce13df88bf06b87ac4a35d2a199ea888629fb0d83f82f0ea160dc79ed220d8ef195b9e80c542f60c2d320" + ], + -- COUNT = 12 + [ "46571e1df43e5e141235e2a9ec85bb0faf1dc0566031e14d41a2fbd0315653ec" + , "b60ef6a3347967519aabeaf748e4e991" + , "759fd8593e3688b23c4a003b655311770d670789878570eb3b155a8e6c2d8c45" + , "033128460b449e1accb0e9c54508759ddc2538bc64b51e6277553f0c60a02723" + , "a5e4a717240bdeac18a0c0e231a11dc04a47d7550f342fa9a7a5ff334eb9327d" + , "9d222df1d530ea7f8f2297a0c79d637da570b48042ecddded75956bba0f0e70b271ffa3c9a53bada6ee1b8a4203c22bfde82a5e2eb1b150f54c6483458569422c1a34a8997d42cc09750167a78bf52a0bd158397af9f83caabe689185c099bf0a9a4853dd3cf8b8e89efebb6a27dba873e65e9927741b22968f2875789b44e01" + ], + -- COUNT = 13 + [ "d63980e63bbe4ac08d2ac5646bf085b82c75995e3fdfc23bb9cc734cd85ca7d2" + , "d33ed1dcae13fb634ba08272d6697590" + , "acd0da070072a5340c4f5f4395568e1a36374e074196ae87f3692ee40487e1df" + , "f567677b5e12e26f3544be3da9314c88fc475bf84804a89a51f12b191392c02b" + , "c01cc7873e93c86e2bfb8fc984cfc2eab5cc58eeef018fedb5cba5aedd386156" + , "b133446f633bcb40724bbf9fa187c39a44b9c094a0a0d40e98977e5466dc2c9adf62a5f4551eeb6406a14658de8a0ed7487c3bf6277e811101284a941745ce16176acc875f1435e14161772fa84609e8123c53dd03cbb868030835c0d11d8d6aa04a1b6f908248b028997737f54735ec4ed7a81fc868199ffb61a779d9340334" + ], + -- COUNT = 14 + [ "3d99f9b7ac3a2fbe9cf15d960bf41f5588fc4db1e0d2a5c9c0fe9059f03593fb" + , "411f504bb63a9b3afa7ffa1357bb48be" + , "0bb5ebd55981a25ba69164da49fa92f2871fd3fc65eb30d0f0d0b8d798a4f8f2" + , "288e948a551284eb3cb23e26299955c2fb8f063c132a92683c1615ecaed80f30" + , "d975b22f79e34acf5db25a2a167ef60a10682dd9964e15533d75f7fa9efc5dcb" + , "ee8d707eea9bc7080d58768c8c64a991606bb808600cafab834db8bc884f866941b4a7eb8d0334d876c0f1151bccc7ce8970593dad0c1809075ce6dbca54c4d4667227331eeac97f83ccb76901762f153c5e8562a8ccf12c8a1f2f480ec6f1975ac097a49770219107d4edea54fb5ee23a8403874929d073d7ef0526a647011a" + ] + ] + +{- Reseed test vectors -} + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +r1 :: [TestVector] +r1 = + [ + -- COUNT = 0 + [ "06032cd5eed33f39265f49ecb142c511da9aff2af71203bffaf34a9ca5bd9c0d" + , "0e66f71edc43e42a45ad3c6fc6cdc4df" + , "" + , "01920a4e669ed3a85ae8a33b35a74ad7fb2a6bb4cf395ce00334a9c9a5a5d552" + , "" + , "" + , "" + , "76fc79fe9b50beccc991a11b5635783a83536add03c157fb30645e611c2898bb2b1bc215000209208cd506cb28da2a51bdb03826aaf2bd2335d576d519160842e7158ad0949d1a9ec3e66ea1b1a064b005de914eac2e9d4f2d72a8616a80225422918250ff66a41bd2f864a6a38cc5b6499dc43f7f2bd09e1e0f8f5885935124" + ], + -- COUNT = 1 + [ "aadcf337788bb8ac01976640726bc51635d417777fe6939eded9ccc8a378c76a" + , "9ccc9d80c89ac55a8cfe0f99942f5a4d" + , "" + , "03a57792547e0c98ea1776e4ba80c007346296a56a270a35fd9ea2845c7e81e2" + , "" + , "" + , "" + , "17d09f40a43771f4a2f0db327df637dea972bfff30c98ebc8842dc7a9e3d681c61902f71bffaf5093607fbfba9674a70d048e562ee88f027f630a78522ec6f706bb44ae130e05c8d7eac668bf6980d99b4c0242946452399cb032cc6f9fd96284709bd2fa565b9eb9f2004be6c9ea9ff9128c3f93b60dc30c5fc8587a10de68c" + ], + -- COUNT = 2 + [ "62cda441dd802c7652c00b99cac3652a64fc75388dc9adcf763530ac31df9214" + , "5fdc897a0c1c482204ef07e0805c014b" + , "" + , "bd9bbf717467bf4b5db2aa344dd0d90997c8201b2265f4451270128f5ac05a1a" + , "" + , "" + , "" + , "7e41f9647a5e6750eb8acf13a02f23f3be77611e51992cedb6602c314531aff2a6e4c557da0777d4e85faefcb143f1a92e0dbac8de8b885ced62a124f0b10620f1409ae87e228994b830eca638ccdceedd3fcd07d024b646704f44d5d9c4c3a7b705f37104b45b9cfc2d933ae43c12f53e3e6f798c51be5f640115d45cf919a4" + ], + -- COUNT = 3 + [ "6bdc6ca8eef0e3533abd02580ebbc8a92f382c5b1c8e3eaa12566ecfb90389a3" + , "8f8481cc7735827477e0e4acb7f4a0fa" + , "" + , "72eca6f1560720e6bd1ff0152c12eeff1f959462fd62c72b7dde96abcb7f79fb" + , "" + , "" + , "" + , "d5a2e2f254b5ae65590d4fd1ff5c758e425be4bacdeede7989669f0a22d34274fdfc2bf87135e30abdae2691629c2f6f425bd4e119904d4785ecd9328f15259563e5a71f915ec0c02b66655471067b01016fdf934a47b017e07c21332641400bbe5719050dba22c020b9b2d2cdb933dbc70f76fec4b1d83980fd1a13c4565836" + ], + -- COUNT = 4 + [ "096ef37294d369face1add3eb8b425895e921626495705c5a03ee566b34158ec" + , "6e2e0825534d2989715cc85956e0148d" + , "" + , "1b4f7125f472c253837fa787d5acf0382a3b89c3f41c211d263052402dcc62c5" + , "" + , "" + , "" + , "4541f24f759b5f2ac2b57b51125077cc740b3859a719a9bab1196e6c0ca2bd057af9d3892386a1813fc8875d8d364f15e7fd69d1cc6659470415278164df656295ba9cfcee79f6cbe26ee136e6b45ec224ad379c6079b10a2e0cb5f7f785ef0ab7a7c3fcd9cb6506054d20e2f3ec610cbba9b045a248af56e4f6d3f0c8d96a23" + ], + -- COUNT = 5 + [ "a7dccdd431ae5726b83585b54eae4108f7b7a25c70187c0acbb94c96cc277aa8" + , "94c8f4b8e195a47356a89a50d1389ab5" + , "" + , "51733eee2e922f4055e53939e222e71fae730eb037443db2c7679708abb86a65" + , "" + , "" + , "" + , "99ba2691a622afecc9472418e6a8f9f1cdc1e3583c3bc7a2a650a1ab79dcbccbd656636c573179276e782569420c97438c06be898867f628b1c01eb570263d2c0f09c7aab536f6fba7df6aad19e05c236b645674667c03d1b6a04d7fc11177fe78933b309679f5bf26a4632b9a13e314c4bf4532428d3d95c689002b6dc1fbb1" + ], + -- COUNT = 6 + [ "c286425ecf543a49bcc9196b0db1a80bc54e4948adba6f41712a350a02891fa6" + , "957a659a4ec2e0b7ad185483c220fd61" + , "" + , "08c2129813eea0776fba72788fdf2718759cc3c4207fa20a5fe23ac6e32cc28e" + , "" + , "" + , "" + , "8e1020a4fd84c99e0fc7e3f7ce48de5ed9ec9a5c2ccd624dbe6f30e2f688a31dc55957630357a5d48ca2a456241a28bfb16d8bb000877697a7ce24d9ad4d22b0c15117996f1f270b94f46d7a9bdfa7608fa1dd849177a9b8049e51b6b7a2742623854a1fddb5efc447eed1ea1aed6f02b4b2754ecf71ea0509da2e54f524a7e7" + ], + -- COUNT = 7 + [ "02818bd7c1ec456ace55beeba99f646a6d3aa0ea78356ea726b763ff0dd2d656" + , "c482687d508c9b5c2a75f7ce390014e8" + , "" + , "cf319bfa63980e3cb997fd28771bb5614e3acb1149ba45c133ffbbab17433193" + , "" + , "" + , "" + , "19a231ff26c1865ce75d7a7185c30dd0b333126433d0c8cbf1be0d2b384d4eb3a8aff03540fbfa5f5496521a4e4a64071b44c78bd0b7e68fac9e5695c5c13fd3b9dbe7f7739781a4c8f0b980f1b17d99bce17ceb52b56866ae02456ffef83399c8cf7826f3c45c8a19315890919d20f40fc4e18d07e9c8ccd16c3327b5988f71" + ], + -- COUNT = 8 + [ "77a5c86d99be7bc2502870f4025f9f7563e9174ec67c5f481f21fcf2b41cae4b" + , "ed044ad72ee822506a6d0b1211502967" + , "" + , "778100749f01a4d35c3b4a958aafe296877e0acafd089f50bc7797a42a33ab71" + , "" + , "" + , "" + , "831a4da566f46289904893ef1cc1cd4ad19ee48f3857e2b69e936d10afbdc29822e85d02663d346ef3e09a848b1d9cc04f4c4c6e3b3b0e56a034e2334d34ca08f8097be307ba41d020bc94f8c1937fe85644eeb5592c2b5a2138f7ded9a5b44b200c8b5beb27597c790f94d660eb61e8248391edc3ae2d77656cbe8354275b13" + ], + -- COUNT = 9 + [ "0ea458cff8bfd1dd8b1addcba9c01317d53039e533104e32f96e7d342e6c7b9b" + , "935a4b66fc74c2a48757a99c399e64e3" + , "" + , "6c5f3708e7b714c4ed139b4fa9e8c763af01773484005109a85e33653bb0ce98" + , "" + , "" + , "" + , "373a37af84fddec13645a9768d6a785ae5a2589d64cd9b37980dde2541499210c4f408335de1d585349064f3f53a2b4c5ec6dc2a09591f99ad9fad528ac83474164b45497bf167f81e66fa08463ffea917f6891e48f149fafc20622bb1172f34886feb45c26fd446a4a4e2891b4bc594186896141aaaeeb301b49e7c1a26fec7" + ], + -- COUNT = 10 + [ "bfb68be4ce1756d25bdfad5e0c2f8bec29360901cc4da51d423d1591cc57e1ba" + , "98afe4bd194c143e099680c504cceaab" + , "" + , "b97caf210e82498c3408790d41c320dd4a72007778389b44b7bc3c1c4b8c53f8" + , "" + , "" + , "" + , "409e0aa949fb3b38231bf8732e7959e943a338ea399026b744df15cbfeff8d71b3da023dcce059a88cf0d4b7475f628e4764c8bef13c70cfbbbb6da2a18aabcad919db09d04fc59765edb165147c88dd473a0f3c5ee19237ca955697e001ba654c5ee0bd26761b49333154426bc63286298a8be634fe0d72cfdeef0f3fc48eca" + ], + -- COUNT = 11 + [ "4f6880a64610004463031d67d7924fa446c39138d4d41007e8df3d65691a9367" + , "6b33b2c13600f4b1df6ca3d1960e8dd4" + , "" + , "57b87b8c8f48312b5333d43b367730c0a5ad4725a16778fcb53fe136d136cbfd" + , "" + , "" + , "" + , "73d0f324ed186e2ad06bd1800e262bdbda79ba54e626761bd60f74f43e3bb62958ec1e2f1d940af163e1cadc124e7ebaba2f72e67efd746c7f6d0cad53ef03d859d93cff778a32ee5be172fe7fdbdc232ded360d704a6fa0f70bebe942e56478345492f49dc5c6fc346b88a58947ad250e688e8c626fe1efe7624620e571976e" + ], + -- COUNT = 12 + [ "aae352e111843219cae8f70e7b8f6eb9bb53d246cbec1e4f07d42757143295b4" + , "b84485dccd1bf93210e322eafcbebcd9" + , "" + , "f9237f00d744d8fbff21b9d0043c258e8731817e6a5fb7b4bf5011680e5bc642" + , "" + , "" + , "" + , "cfb28b93522c7d61d8d3ce3f080e435e4c83c7e13a9dab788db8fef0407267a14fbc9324e090e24df5491fedfa81116869983938d4d4d7324a310c3af33a6f7938f602c5e4e63f1771cdaabdab0782b5affb54eb53047c109a9606739dd0065bd21eca33132986554878354f5f9f852e674dd690163b0ff74c7a25e6bae8ce39" + ], + -- COUNT = 13 + [ "589e79e339b7d2a1b879f0b0e1a7d1ad2474eaa8025b070f1ffa877b7124d4ff" + , "0961ed64dbd62065d96e75de6d2ff9d6" + , "" + , "e928388d3af48c2968527a4d2f9c2626fbc3f3f5a5d84e0583ab6f78e7f8b081" + , "" + , "" + , "" + , "fce6ced1ecf474d181ab331f79c3d2cc8a768ec2818de5b3fc7cf418322716d6a6853733561a497c0c25cb288d2c9fcfbca891bafd5a834c85f3603f402acf1a7b1ea92db847ed5c252a862ad4ab5e259715f1fc81da67f5230bf8be50ee8069758095f7d0e559e03f2c6072290e61794458437609e473eb66580cddaad19b71" + ], + -- COUNT = 14 + [ "714277d408ad87fde317f0a94732fce62f1352bdc90936673b4f1daa0925aa26" + , "d16582a99f23010b4248b88d86485419" + , "" + , "bd9fc7cb2fd5063b2c3c0c4f346ad2e3879371a9c805e59b9f2cd2cc2a40894f" + , "" + , "" + , "" + , "62ef7a431288252e0d736c1d4e36cc9ac37107dcd0d0e971a22444a4adae73a41eff0b11c8625e118dbc9226142fd0a6aa10ac9b190919bda44e7248d6c88874612abd77fb3716ea515a2d563237c446e2a282e7c3b0a3aef27d3427cc7d0a7d38714659c3401dbc91d3595159318ebca01ae7d7fd1c89f6ad6b604173b0c744" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +r2 :: [TestVector] +r2 = + [ + -- COUNT = 0 + [ "05ac9fc4c62a02e3f90840da5616218c6de5743d66b8e0fbf833759c5928b53d" + , "2b89a17904922ed8f017a63044848545" + , "" + , "2791126b8b52ee1fd9392a0a13e0083bed4186dc649b739607ac70ec8dcecf9b" + , "43bac13bae715092cf7eb280a2e10a962faf7233c41412f69bc74a35a584e54c" + , "3f2fed4b68d506ecefa21f3f5bb907beb0f17dbc30f6ffbba5e5861408c53a1e" + , "529030df50f410985fde068df82b935ec23d839cb4b269414c0ede6cffea5b68" + , "02ddff5173da2fcffa10215b030d660d61179e61ecc22609b1151a75f1cbcbb4363c3a89299b4b63aca5e581e73c860491010aa35de3337cc6c09ebec8c91a6287586f3a74d9694b462d2720ea2e11bbd02af33adefb4a16e6b370fa0effd57d607547bdcfbb7831f54de7073ad2a7da987a0016a82fa958779a168674b56524" + ], + -- COUNT = 1 + [ "1bea3296f24e9242b96ed00648ac6255007c91f7c1a5088b2482c28c834942bf" + , "71073136a5cc1eb5b5fa09e1790a0bed" + , "" + , "d714329f3fbea1df9d0b0b0d88dfe3774beb63d011935923d048e521b710dc6f" + , "4ef872fd211a426ea1085ab39eb220cc698fdfeabe49b8835d620ab7885de7a4" + , "d74d1669e89875852d9ccbf11c20fe3c13a621ebcb3f7edeea39a2b3379fdcf5" + , "0c8aa67ca310bd8e58c16aba35880f747266dbf624e88ec8f9ee9be5d08fdeb1" + , "ce95b98f13adcdf7a32aa34709d6e02f658ae498d2ab01ce920f69e7e42c4be1d005acf0ca6b17891dfafc620dd4cd3894f8492a5c846089b9b452483eb0b91f3649ec0b6f98d1aaabc2e42cd39c2b25081b85ab50cb723007a0fd83550f32c210b7c4150b5a6bb3b0c9e3c971a09d43acb48e410a77f824b957092aa8ef98bc" + ], + -- COUNT = 2 + [ "a7ea449b49db48601fc3a3d5d77081fab092b8d420ed1b266f704f94352dd726" + , "d11a159b60af8d20a0e37d27e6c74aa3" + , "" + , "50916ab47e8cb5dc843f9fba80639103711f86be8e3aa94f8a64a3fe0e6e5b35" + , "e2bb6768120555e7b9e0d573537a82f8f32f54560e1050b6abb1588fb3441e66" + , "a50cec9d1ecddb2c163d24019e81c31a2b350ccd3ad8181fd31bb8d1f64fa50e" + , "591dbbd48b51abced67f9c6269cf0133cd3dcbb5cfafcb6ef758569c555a5773" + , "0a464abcc8685158372d544635b953fcb1d3821c30aaa93982f9b788935f00f88115aad61d5cee003b3d1cb50f3e961a501e2dd0fc7e1724778b184a4bdf9f64e110dda7446e5544a30bd49a400ea1a5411800e1edfeea349323618afc5dc5782dc4b71d2da4d6a4785f8dd346feb9c8740ffd26bf644e3e4323ff24c30b9f10" + ], + -- COUNT = 3 + [ "14683ec508a29d7812e0f04a3e9d87897000dc07b4fbcfda58eb7cdabc492e58" + , "b2243e744eb980b3ece25ce76383fd46" + , "" + , "18590e0ef4ee2bdae462f76d9324b3002559f74c370cfccf96a571d6955703a7" + , "9ea3ccca1e8d791d22fcda621fc4d51b882df32d94ea8f20ee449313e6909b78" + , "16366a578b5ea4d0cb547790ef5b4fd45d7cd845bc8a7c45e99419c8737debb4" + , "a68caa29a53f1ba857e484d095805dc319fe6963e4c4daaf355f722eba746b92" + , "c4e7532ee816789c2d3da9ff9f4b37139a8515dbf8f9e1d0bf00c12addd79ebbd76236f75f2aa705a09f7955038ebff0d566911c5ea13214e2c2eeb46d23ad86a33b60f7b9448d63eec3e1d59f48b39552857447dc5d7944667a230e3dbfa30ca322f6eacaf7536a286706a627c5083c32de0658b9073857c30fb1d86eb8ad1b" + ], + -- COUNT = 4 + [ "fa261fb230e2822458532ca2d5c39758750e6819a6fcebef10579ba995096959" + , "564e1c9fbcb12878df2bd49202cbf821" + , "" + , "bf7de29e99e7f0e1b9f96f3b1902fb4049c8c6234d20de8316ebe66d97725457" + , "8b7326621f6afbd44a726de48d03bcc5331f7306026c229ea9523497fbeaa88d" + , "33b00b31623d6160c4c6740363a96481be14b19bc47be95641227284c366922a" + , "2d812c8203575790ad6b6f2ed91a49d57460de779a3e881bef3be12e8766dc91" + , "5574e0b4efc17e8ce136e592beabfe32551072bddd740929e698467b40b3991f028a22c760f7034853cc53007e3793e3c4a600d9e9d94528f8dc09aeba86146cdde2b7f71255ae0efc529b49be2205979dba6525bfe155e8819e8e2aeeaa285704242da90b4c4535101cc47d94b0e388a1b2e63ad0cbe158b9e1bbae9cc0007c" + ], + -- COUNT = 5 + [ "61f1471ced56aa04c57e1b512307d4cb92497d9592d7e9e35356e99d585cab1b" + , "84714e960c403a4fac06b2828cc564d9" + , "" + , "7bf97db3c102edc81596d4757045fe6bdc008f35792fc6290b77d889c09c33a8" + , "5b8bdc41f76d98cfa71ed976ea3994706375c8841adb8b6b3b6418e3132e8832" + , "94c8a8fdf38a6ccb8571c89420d899adab169214bb0dfcd43a04622e289935b2" + , "8a4b46e0a7a55907365f82d4ab9376509bd44728cab8cbafb0da901012ad8dcd" + , "933eb159a6af7455b60e40586c064f05f1970f564281b1ebc4662701ac1f299e4eb908c4afcb2e065191281ab576f684aefedd6904bad04d96bd93c0516c62a496c3073a0cda0676a11cc08866b0cc74f62cb9d3db48673b2c3fbeada69f922b4b795ccba22df12ef7125909381f7d681f6b9caba02fb913c5437b98c040c576" + ], + -- COUNT = 6 + [ "a1d5bb7d70621dee6b668b28c56d5610c2f8ced30284cc3e0e48de331af05062" + , "88a49e3e54c5ea54c98b95de81bcc807" + , "" + , "b4e2426e98f6eed97a6cdf690a89ee109e84c3dca16c883c26fa4ac671638d8d" + , "5bd1e086ed228cfd8b55c1731fea40c3a63d022599ca2da4bb23118f4821ba62" + , "b754b53ac226e8ebe47a3d31496ec822de06fca2e7ef5bf1dec6c83d05368ec3" + , "fa7e76b2805d90b3d89fff545010d84f67aa3a2c9eb2ba232e75f4d53267dac3" + , "df6b2460688fa537df3ddfe5575fca5eb8abad56cbc4e5a618a2b4a7daf6e215c3a497974c502f9d0ec35de3fc2ea5d4f10de9b2aee66dcc7e7ae6357983095959b817f0383e3030771bd2ed97406acf78a1a4a5f30fa0992289c9202e69e3eb1eabe227c11409ff430f6dfca1a923a8b17bc4b87e908007f5e9759c41482b01" + ], + -- COUNT = 7 + [ "68f21d14525d56233c7e263482d344c388a840103a77fb20ac60ce463cabdc79" + , "59fa80ae570f3e0c60ac7e2578cec3cb" + , "" + , "7584b4166530442f06e241dd904f562167e2fdae3247ab853a4a9d4884a5fa46" + , "f6a5482f139045c5389c9246d772c782c4ebf79c3a84b5cf779f458a69a52914" + , "9d37b1ce99f8079993ddf0bd54bab218016685b22655a678ce4300105f3a45b7" + , "4c97c67026ff43c2ee730e7b2ce8cce4794fd0588deb16185fa6792ddd0d46de" + , "e5f8874be0a8345aabf2f829a7c06bb40e60869508c2bdef071d73692c0265f6a5bf9ca6cf47d75cbd9df88b9cb236cdfce37d2fd4913f177dbd41887dae116edfbdad4fd6e4c1a51aad9f9d6afe7fcafced45a4913d742a7ec00fd6170d63a68f986d8c2357765e4d38835d3fea301afab43a50bd9edd2dec6a979732b25292" + ], + -- COUNT = 8 + [ "7988146cbf9598d74cf88dc314af6b25c3f7de96ae9892fb0756318cea01987e" + , "280bc1ae9bfdf8a73c2df07b82a32c9c" + , "" + , "2bbc607085232e5e12ccf7c0c19a5dc80e45eb4b3d4a147fe941fa6c13333474" + , "f3f5c1bb5da59252861753c4980c23f72be1732f899fdea7183b5c024c858a12" + , "44d0cfc4f56ab38fa465a659151b3461b65b2462d1ad6b3463b5cf96ad9dc577" + , "34fb9a3cdacc834ff6241474c4f6e73ed6f5d9ea0337ab2b7468f01ad8a26e93" + , "4caec9e760c4d468e47613fe50de4a366ae20ba76793744a4e14433ea4de79dc188601eb86c803b094641ab2337b99d459d37decc7d27473057be45ba848868ee0fb5f1cf303d2fcd0b3e0c36f65a65f81b3fee8778a1f22302e25dfe34e6d587fa8864e621121880f7cd55f350531c4ce0530099eec2d0059706dcd657708d9" + ], + -- COUNT = 9 + [ "1c974c953fa2a057c9fc9409a6843f6f839aa544bca4fa11e48afd77931d4656" + , "ed7c08285464af7a5dbdc10b944a1270" + , "" + , "78146ad135acb836360d36afc50653dcc36c21662da2a6f6ae05222e75f34000" + , "263c4984c238ded333c86472866353817379502157172cfa51371d82b1efd7b5" + , "79b591529f9a26a0d7c8f8fd64e354b0c134ef1f757e43f9463b3dbb7a3da1ab" + , "7d8f7204b0b5401ddce9e88dcf5facb9a44660a9f5f1c862748e7269c29f7964" + , "72e2ca257b9edaf59b50e05a144f56fb517832fb9ad3489b1e664e3d5412cbf6b2883e891703b2e73aff9ab56da1009fcdef010ab4cdab996795c8f7c47fb1192bb160353997ad39d7d5fd0e2efc9103a7c3f158246afd53fe53ca6782f809698ef5f1f0d85536780a3fd6a8bafa475891c09213088bd1a3dc169257c34a517a" + ], + -- COUNT = 10 + [ "56216d71984a77154569122c777ce57e1d101a6025b28163a25971d39c1c5d0f" + , "5cd148ba7e54f4975ac8e3e0f9b5d06a" + , "" + , "3580f8ca974626c77259c6e37383cb8150b4d0ab0b30e377bed0dc9d1ff1a1bf" + , "15633e3a62b21594d49d3d26c4c3509f96011d4dbb9d48bbbea1b61c453f6abe" + , "6068eaca85c14165b101bb3e8c387c41d3f298918c7f3da2a28786ab0738a6fc" + , "e34f92d2b6aeeeea4ff49bfe7e4b1f462eabb853f0e86fbae0e8b3d51409ce49" + , "587fdb856abc19ede9078797ecb44099e07aadcd83acdcb2b090601d653f4a14c68ab2ebdda63578c5633a825bae4c0c818f89aac58d30fd7b0b5d459a0f3d86fcad78f4bb14dfff08ad81e4ea9f487cb426e91d6e80dfed436ba38fce8d6f21ca2151c92dd5c323b077d6139c66395558f0537026c4a028affa271ef4e7ea23" + ], + -- COUNT = 11 + [ "83eb48bedc1e9294866ab8e5322ef83f6f271f8188e8fdabe5817788bd31570d" + , "d6ed90bc692237f132441ede857a6629" + , "" + , "a4e5e127f992bd5ca79ee56bb8a9bccf74c21814bfaf97ffd052211e802e12e4" + , "84136e403d9ed7f4515c188213abcfaca35715fa55de6d734aec63c4606a68f1" + , "fe9d8ef26e2d2e94b99943148392b2b33a581b4b97a8d7a0ecd41660a61dd10b" + , "594dad642183ce2cdc9494d6bcb358e0e7b767c5a0fa33e456971b8754a9abd5" + , "86715d43ba95fbbca9b7193ea977a820f4b61ba1b7e3b8d161b6c51b09dfd5040d94c04338b14d97ed25af577186b36ae7251a486c8a2d24a35e84a95c89d669d49e307b4a368b72164135ac54d020a970a180dfbed135d2c86f01270846d5301bd73db2c431a8aa10a0a3d03d146e5fafb9a2aa0b4efc80edab06ff3b532236" + ], + -- COUNT = 12 + [ "ba2c94203dab2e6499d8c50dca7b5c34a6b4764834f9816631aa21b9f9c37361" + , "67db133bdefb25e395085bceee5a0afc" + , "" + , "fa8984d16d35302cda35a3a355ab9242ec96fec0652d39282d4a0abf0a80df87" + , "b6fed10255a3fea6772ae1ae6d9f6cbb9bfaa34804e58a5b786f9bc60b348ccd" + , "445e072244edc716d3528f0e0a20ff0cd8f819c0d031736c8da122748f24d6c6" + , "1f856e403c4fa035bac9aa81a20e347c7d8b213aab699d69d9d6186a06ac45c1" + , "79f33fc36b3b47d9ac805bdbbe699909a8d0beb689a8b2723c291bd5bf7f3ce61343d4722a14e4add36312dbb0594910c8828aff1abc159915d498106f9ffb31147478d8c9ef75d1536ba5036506b313f6e85033f8f6fea2a4de817c867a59378c53c70a2f108275daedd415c05b61c4fd5d48c54be9adb9dea6c40a2ec99ee0" + ], + -- COUNT = 13 + [ "0db4c51492db4fe973b4bb1c52a1e873b58fc6bb37a3a4bfc252b03b994495d1" + , "a2a3900f169bba3f78a42526c700de62" + , "" + , "29d5aab356876447e3a20d81c7e3fc6975e2b984180a91493044442999e1ca3a" + , "40b34183b4e72cdff5952b317b3d45943d0fdcfa0527f3563055f7c73ae8f892" + , "dc94220c99ffb595c7c4d6de8de5a6bb4b38847169e24a557ef6d879ad84149d" + , "b2376626fd2f5218b3ed4a5609b43aa24d371cd2176ea017c2b99cf868060021" + , "f0bd6bc4c506d9427a09352d9c1970b146360732841a6323f4cb602c87dedfb5ff7e6964b9144933af3c5c83017ccd6a94bdca467a504564aaa7b452591a16ff6a1e7e94ddc98f9a58016cdcb8caaed6c80671ba48cc81a832d341093dda1d4e5001ec6bf66348b21e3692a13df92538ad572bb2023822072fc95f9590293ffc" + ], + -- COUNT = 14 + [ "593845f0adfeffa7c169f8a610147ae8a08c0072fc0c14c3977d3de0d00b55af" + , "9e0eb2507342ee01c02beadee7d077bd" + , "" + , "aefe591697eab678c52e20013aa424b95cfd217b259757fbe17335563f5b5706" + , "cbb5be0ef9bf0555ee58955c4d971fb9baa6d6070c3f7244a4eb88b48f0793bf" + , "6dd878394abdc0402146ba07005327c55f4d821bfebca08d04e66824e3760ab4" + , "ba86a691d6cbf452b1e2fd1dfb5d31ef9ea5b8be92c4988dc5f560733b371f69" + , "00735cbfafac5df82e5cb28fc619b01e2ba9571dc0023d26f09c37fb37d0e809066165a97e532bf86fa7d148078e865fe1a09e27a6889be1533b459cd9cd229494b5cf4d2abf28c38180278d47281f13820276ec85effb8d45284eb9eef5d179ab4880023ab2bd08ee3f766f990286bf32430c042f5521bbfd0c7ee09e2254d7" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +r3 :: [TestVector] +r3 = + [ + -- COUNT = 0 + [ "fa0ee1fe39c7c390aa94159d0de97564342b591777f3e5f6a4ba2aea342ec840" + , "dd0820655cb2ffdb0da9e9310a67c9e5" + , "f2e58fe60a3afc59dad37595415ffd318ccf69d67780f6fa0797dc9aa43e144c" + , "e0629b6d7975ddfa96a399648740e60f1f9557dc58b3d7415f9ba9d4dbb501f6" + , "" + , "" + , "" + , "f92d4cf99a535b20222a52a68db04c5af6f5ffc7b66a473a37a256bd8d298f9b4aa4af7e8d181e02367903f93bdb744c6c2f3f3472626b40ce9bd6a70e7b8f93992a16a76fab6b5f162568e08ee6c3e804aefd952ddd3acb791c50f2ad69e9a04028a06a9c01d3a62aca2aaf6efe69ed97a016213a2dd642b4886764072d9cbe" + ], + -- COUNT = 1 + [ "cff72f345115376a57f4db8a5c9f64053e7379171a5a1e81e82aad3448d17d44" + , "d1e971ec795d098b3dae14ffcbeecfd9" + , "6ec0c798c240f22740cad7e27b41f5e42dccaf66def3b7f341c4d827294f83c9" + , "45ec80f0c00cad0ff0b7616d2a930af3f5cf23cd61be7fbf7c65be0031e93e38" + , "" + , "" + , "" + , "17a7901e2550de088f472518d377cc4cc6979f4a64f4975c74344215e4807a1234eefef99f64cb8abc3fb86209f6fc7ddd03e94f83746c5abe5360cdde4f2525ccf7167e6f0befae05b38fd6089a2ab83719874ce8f670480d5f3ed9bf40538a15aaad112db1618a58b10687b68875f00f139a72bdf043f736e4a320c06efd2c" + ], + -- COUNT = 2 + [ "b7099b06fc7a8a74c58219729db6b0f780d7b4fa307bc3d3f9f22bfb763596a3" + , "b8772059a135a6b61da72f375411de26" + , "2ac1bfb24e0b8c6ac2803e89261822b7f72a0320df2b199171b79bcbdb40b719" + , "9aec4f56ec5e96fbd96048b9a63ac8d047aedbbeea7712e241133b1a357ecfc4" + , "" + , "" + , "" + , "0e1f2bfef778f5e5be671ecb4971624ec784ed2732abc4fbb98a8b482fb68737df91fd15acfad2951403ac77c5ca3edffc1e03398ae6cf6ac24a91678db5c7290abc3fa001aa02d50399326f85d2b8942199a1575f6746364740a5910552c639804d7530c0d41339345a58ff0080eccf1711895192a3817a8dc3f00f28cc10cc" + ], + -- COUNT = 3 + [ "7ba02a734c8744b15ef8b4074fe639b32e4431762ab5b7cd4d5df675ea90672b" + , "8a424f32108607c8f1f45d97f500ee12" + , "3ad627433f465187c48141e30c2678106091e7a680229a534b851b8d46feb957" + , "d8f02b59b6a3dd276bc69cba68efcf11ab83ead1397afd9841786bd1bb5da97a" + , "" + , "" + , "" + , "1fb91186ba4b4459d994b4b9f4ca252c7be6294d6cdb5fe56f8ff784d4b190a1c6456e0a41223bbbdf83ed8e7cfbfa765d9d8bc7ea5f4d79ea7eccb4928081a21de4cca36620d6267f55d9a352b76fc0a57375884112c31f65ff28e76d315698c29e6c4c05cb58b0a07ae66143b4abc78b9d25c78b4121e1e45bef1a6c1793e2" + ], + -- COUNT = 4 + [ "9a8865dfe053ae77cb6a9365b88f34eec17ea5cbfb0b1f04d1459e7fa9c4f3cb" + , "180c0a74da3ec464df11fac172d1c632" + , "336372ec82d0d68befad83691966ef6ffc65105388eb2d6eed826c2285037c77" + , "75b95108eff1fabe83613e1c4de575e72a5cdc4bb9311dd006f971a052386692" + , "" + , "" + , "" + , "3c683f6d4f8f5a4018d01633dfee74266aaa68ed6fc649e81b64dfdf5f75e75d5c058d66cf5fd01a4f143a6ff695517a4a43bd3adfd1fb2c28ba9a41063140bedbffdb4d21b1ace1550d59209ec61f1e2dbacb2a9116a79cb1410bf2deca5218080aacd9c68e1d6557721a8913e23f617e30f2e594f61267d5ed81464ee730b2" + ], + -- COUNT = 5 + [ "22c1af2f2a4c885f06988567da9fc90f34f80f6dd5101c281beef497a6a1b2f8" + , "3fafdecf79a4174801f133131629037b" + , "80327dac486111b8a8b2c8e8381fb2d713a67695c2e660b2b0d4af696cc3e1de" + , "f95a0e4bd24f0e2e9e444f511b7632868ead0d5bb3846771264e03f8ab8ed074" + , "" + , "" + , "" + , "77a7fea2f35a188f6d1bfdd49b569d8c45e2dd431d35a18c6f432c724f1e33ae92cb89a9cf91519e50705a53199f5b572dc85c1aef8f28fb52dc7986228f66954d54eda84a86962cf25cf765bd9949876349291b1aae5f88fcf4b376912d205add4f53b2770c657946c0d824281f441509153f48356d9d43f8a927e0693db8fc" + ], + -- COUNT = 6 + [ "d0840e3a8d629d5b883d33e053a341b21c674e67e1999f068c497ecfaabfd6f6" + , "071de7244ecb2fdf7ab27f2d84aa7b7a" + , "90d609527fad96ffe64ab153860346f3d237c8940555ae17b47842d82d3b0943" + , "1dd1a8b59856c49a388f594c5f42cc2e4a56b3ccb8a65e7066e44c12f4344d50" + , "" + , "" + , "" + , "7ab28a9b2d3ae999195553e6550cced4c2daccbe7ec9dcbb0d467fabba185b727fbfd9830242cd098f4db3cf4a85e8bf8e8d5974b62b28550922b32ed5bfc1a522b6605cf93bf8d90bdec1c5b9e59c6fc37a817d437068a87254be1f7c4618ada46fbc3a2efb02e44524e21d91be7534cf05fbfd858304b706d6a91ea1cc6ad5" + ], + -- COUNT = 7 + [ "2e2dd56869104492767a59778652831919e1c8b970f84e824ae4116597a0ab7f" + , "01c42a7e983641de46c82fd09b4f2f76" + , "bcd9e1508fcc22820a8be07180fea5045367333b569e111b011cd57dc1858765" + , "7306507cd3ca7eec667e640d270cfbb033063d97520b6b7e38ff3cea0e79d12b" + , "" + , "" + , "" + , "b915726c7b8c5dc3975f1a334684b973abf6a9495d930088cf5d071548e4fd29a67b55cc561ed6949ad28150a9fb4307c1fa5f783a7ea872e8d7c7e67ff0c2906081ee915737d813c25be5c30b952a36f393e6baa56ab01adc2b4776ad7b5d036a53659877c7a4e5220a897d6c0799af37beeed91173fbe9c613c3b6b9bb28e5" + ], + -- COUNT = 8 + [ "d1aab0f16bd47a5ccd67c22e094daa3735eae21aa57f0bcd9e053d9d0d545cb8" + , "199310dfe1b01265b8c0d2b46d6c7c9f" + , "625b4b8f4de72ea9cb6f70556322dc2a19d6b2b32de623f557e419a084ba60fd" + , "f50cabae4e060f3971096b78e550cda2837a26a693d905db2d992d589b268f44" + , "" + , "" + , "" + , "987e1fdfe004c619cf1e9034576707eccd849400e19c87a1fef5b0179ec51c42a2f8c45d7942d0023a023c89f188b2634362703985695369863322f58619c50a7385a2dc91fc78f94b59f0131dc2b56a0d7c699d427285da1c104b0ad1739da10d8071c23993787045dc21f0070e1e9aa1658fc8e3add73dac7262e80e0aa2ee" + ], + -- COUNT = 9 + [ "449480eaa100aff6f48dc6286a5a81b9728b084864f78a9da98f606a00a6a41f" + , "e53c6c5ac3da9f4726389a03f97bb640" + , "6b8fedc084d8e28d333aef6db3702b6351f0d24e30908cccb63794282655886b" + , "73a6d64e1966ae324388dc12c14544e9dc5ae4fcb331e99d350c456ff16f9aa0" + , "" + , "" + , "" + , "a06912d362da7eb25598857f6d65344c3e23ec3deb80c6e43158845b95eaeca241c0bbbd67ac385e24693444455cc1c2c08c1134d956b8bc93b28be9c2d3322b3e09252979dfb8d39d04c94f81bebda5c73110605a237b561216bda9ee9bdee1cc0c7728bcc8304682334ca944e467a27a85313fa5395a9c790e35defd2edb12" + ], + -- COUNT = 10 + [ "9a6174166e97aa4981ddf580bc01c96754b9f0ba042750aabfda1cffe56e8581" + , "d7512ff6b7db7ce141b2bb01dcd0425e" + , "ed75288f23275f9422444da5d3b53ccb3c4ac8acfb659a1e9b7655c2db52f879" + , "6888b9277e57dc57663d402eba8d03cf56a070dc868e6a128b18040002baf690" + , "" + , "" + , "" + , "03519dfb2ff88cc2b53eecc48ae2a18ddcf91a5d69d5aefcdda8444e6df790a5240e67b2a4de75b4bb8a31f0f8aeb5e785ffb7a1341bb52fe00a05ee66fa2d44ea9956e055f9ffa6647c3bfe851ab364ade71a0d356de710ddafb7622b1da1bc53fd4d3210407289c68d8aeb346bf15806dbe787e781b94f63da3e1f61b5ac60" + ], + -- COUNT = 11 + [ "9c6ae1002ee1b0add0be563ce50f899da936e13efa620d08c2688c192514763a" + , "fde7db5160c73044be73e9d4c1b22d86" + , "8fdaaeffd64e53f7b4374d902d441209964e12b65d29afec258e65db6de167ca" + , "bcc28fd58e397f53f494ad8132df82c5d8c4c22ea0b7139bd81eeba65667bb69" + , "" + , "" + , "" + , "021d938c9b4db780c7d8134aeff1053e5b8843370b8ae9a6749fca7199d809810f1bc8dfa49426470c30c3616f903e35fbacb23420a32f1bee567cc32300f704246ddc0217f236ef52c3ec9e2433ca66f05c25721f7661c43f22c1a125ed5db531bd0836eb435c27eefc7424ce9d845e1d4cc4c503097b4ffca788e674a5cb53" + ], + -- COUNT = 12 + [ "fe96a85b69d46b540918927bb609dc57642eeaefd46bb5da2163a0bc60294b58" + , "22195a410d24db45589448dfe979d3fd" + , "20f698833a4472fd7b78fb9b0c4eb68604f166a2694c4af48dac2b2376790e1e" + , "09cb870879d3f734214f6a4bd2e08c62a2a954bebe559416d8c3551aafe71d6a" + , "" + , "" + , "" + , "d3e96dbe29e1fcb8ed83b19dbfb240e6f41679fbe83853aa71446617e63e5af78cf98b331d15bccb8c673c4e5d5dcec467a1fe26a6cd1696d0c9bc49f78139d051287df7f3ae0dbb4bbf581cb8211931063c3f4612ced53f59d1b4ebb875729139f5d2a7d60642e8f2835eed888b7e3e49c0dffd012cd746abfa3e1c5c2308c6" + ], + -- COUNT = 13 + [ "a4fd693ff0a8af24bcec352d3196549fd0da5ee5d99ca58416ca03ce4c50f38e" + , "8cd67f2bf71d4366ce61396642531ff5" + , "368969c15a4849d7593be8b162113b9298a535c148ff668a9e8b147fb3af4eba" + , "83d2be9a0d74e6a42159ae630acebf4e15271ef7f14f3de14752be0e0e822b11" + , "" + , "" + , "" + , "e9188fc0eaec74b2608e21e3a40be94aaf4ae08eb684de8f8bba2d5fd3b073aa5531c938c0fc628da65725c54b5c68bb91d7d326565e96685e0a4e7b220c50e0caf1628edba5bd755b31894f8cb90afa76e88c5eb9e61b4932444c1397dee3e32241a3fb70a3929e49f6da02eea54812abb3d6b5cee18f03af1e0b4958430ab3" + ], + -- COUNT = 14 + [ "254ff5687a6dad3f1d237dc762f58d24ef2e2c084d0a48d26a3dc81e5490cda3" + , "f2ec392acca491e03ce47b95963a49fc" + , "f806b9b4a56682c61b55cb6a334caf87ffe135adfea6d0c3fc22b39898fbd078" + , "b8494b1c1f1752fb6f80d732a89b08115857f7cc96e7dff05ebb822706889917" + , "" + , "" + , "" + , "0e527e00494d55564f9d9b28e7110f9a61ce36c883b5be2dcb055444164cdddd1a9f2731716f22d6ff476ce413c77abfc0e946871d5481345c2e97b4bfdd12ac03df606fc56bdb99ac7b71a69b5b9160373bbec3e9dde477180af454e7acc6bc58dc0afb4281c0de4354c1bf599054e3800c6d60d892858865b5361f50bfca9b" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +r4 :: [TestVector] +r4 = + [ + -- COUNT = 0 + [ "cdb0d9117cc6dbc9ef9dcb06a97579841d72dc18b2d46a1cb61e314012bdf416" + , "d0c0d01d156016d0eb6b7e9c7c3c8da8" + , "6f0fb9eab3f9ea7ab0a719bfa879bf0aaed683307fda0c6d73ce018b6e34faaa" + , "8ec6f7d5a8e2e88f43986f70b86e050d07c84b931bcf18e601c5a3eee3064c82" + , "1ab4ca9014fa98a55938316de8ba5a68c629b0741bdd058c4d70c91cda5099b3" + , "16e2d0721b58d839a122852abd3bf2c942a31c84d82fca74211871880d7162ff" + , "53686f042a7b087d5d2eca0d2a96de131f275ed7151189f7ca52deaa78b79fb2" + , "dda04a2ca7b8147af1548f5d086591ca4fd951a345ce52b3cd49d47e84aa31a183e31fbc42a1ff1d95afec7143c8008c97bc2a9c091df0a763848391f68cb4a366ad89857ac725a53b303ddea767be8dc5f605b1b95f6d24c9f06be65a973a089320b3cc42569dcfd4b92b62a993785b0301b3fc452445656fce22664827b88f" + ], + -- COUNT = 1 + [ "3e42348bf76c0559cce9a44704308c85d9c205b676af0ac6ba377a5da12d3244" + , "9af783973c632a490f03dbb4b4852b1e" + , "2e51c7a8ac70adc37fc7e40d59a8e5bf8dfd8f7b027c77e6ec648bd0c41a78de" + , "45718ac567fd2660b91c8f5f1f8f186c58c6284b6968eadc9810b7beeca148a1" + , "63a107246a2070739aa4bed6746439d8c2ce678a54fc887c5aba29c502da7ba9" + , "e4576291b1cde51c5044fdc5375624cebf63333c58c7457ca7490da037a9556e" + , "b5a3fbd57784b15fd875e0b0c5e59ec5f089829fac51620aa998fff003534d6f" + , "c624d26087ffb8f39836c067ba37217f1977c47172d5dcb7d40193a1cfe20158b774558cbee8eb6f9c62d629e1bcf70a1439e46c5709ba4c94a006ba94994796e10660d6cb1e150a243f7ba5d35c8572fd96f43c08490131797e86d3ed8467b692f92f668631b1d32862c3dc43bfba686fe72fdd947db2792463e920522eb4bc" + ], + -- COUNT = 2 + [ "b63fdd83c674699ba473faab9c358434771c5fa0348ca0faf7ebd7cf5891826b" + , "5fd204e2598d9626edab4158a8cfd95f" + , "2a5dfad8494306d9d4648a805c4602216a746ae3493492693a50a86d1ba05c64" + , "adea5ba92f8010bb1a6a4b6fae2caa0b384165adf721253afd635d6021f764af" + , "07c69d8d2b8aa1454c5c48083dd41477fda6bfcf0385638379933a60ed2e0a77" + , "a14e902247a3d6493d3fbc8519518b71a660e5502cf7ecfc796cfaa5b4ee4baa" + , "60e690e4a1eba14aec5187112a383e9991347fab7bac7cb2a40a52579a0d2718" + , "792b47b6ed221623bb187d63e3f039c6983d94efd5771dc9b4c40bee65924513485a6332baeda6a96f9bb431f592d73462b61d9d914a72b56fa9d87597426fb246424ebcd7abd51b2eefec8f5b839c0b3c34015342ace296b5f2218fa194b50aea1c89663460292c92c45f112ddbf6b9406f6e7ccee9c47ed2d90a27be5dd73e" + ], + -- COUNT = 3 + [ "dab85f98eaf0cfba013b97de4d9c264ca6fe120366cb83e8b3113c68b34e39d5" + , "d05108e1028ae67b4ea63bdc6d75eb88" + , "09fed3822f6f5e5b9e575d31dc215de1607b0dfc927412618c2d8f79166dbaba" + , "1794885a64470744198b7d0bc24472ffe8daf3c7eb219df6ddf180e484fe0aa5" + , "8d74d01b582f70b92f53b43468084e1586d9b36465d333d5faaf6911e62fe40e" + , "ef7f6b6eb479ab05b3f9ab6dd72eac8b1e86d887f1bcae363cae386d0275a06f" + , "7442b2a792a6a29559bb8a515d56916ee18200580aa02e1237dd358619382d8f" + , "49d2cbfa0897b7d961c293c1e572fb26f28e7b956e746f6eda90454c1370a29e25303ceadc7837514dc638553b487ef9487c977c10625409178ad6506d103c487a66655d08659d92a4d5994d1c8ddb28fe60f2e49577d6e80cae1478068c98268f45e6293c9326c7f726ec89601351c0a26fd3a6549f8a41c6f58692c86594c0" + ], + -- COUNT = 4 + [ "0f0aa84ef12e10ae2b279e799c683441862457b9bc25581c2cd3d5b58a5b3246" + , "f74f4230c2427a52f01f39e825d250ac" + , "d02b2f53da48b923c2921e0f75bd7e6139d7030aead5aeebe46c20b9ca47a38a" + , "5222b26e79f7c3b7066d581185b1a1f6376796f3d67f59d025dd2a7b1886d258" + , "d11512457bf3b92d1b1c0923989911f58f74e136b1436f00bad440dd1d6f1209" + , "54d9ea7d40b7255ef3d0ab16ea9fdf29b9a281920962b5c72d97b0e371b9d816" + , "601cef261da8864f1e30196c827143e4c363d3fa865b808e9450b13e251d47fa" + , "e9847cefea3b88062ea63f92dc9e96767ce9202a6e049c98dc1dcbc6d707687bd0e98ed2cc215780c454936292e44a7c6856d664581220b8c8ca1d413a2b81120380bfd0da5ff2bf737b602727709523745c2ced8daef6f47d1e93ef9bc141a135674cba23045e1f99aa78f8cead12eeffff20de2008878b1f806a2652db565a" + ], + -- COUNT = 5 + [ "6a868ce39a3adcd189bd704348ba732936628f083de8208640dbd42731447d4e" + , "efdde4e22b376e5e7385e79024350699" + , "f7285cd5647ff0e2c71a9b54b57f04392641a4bde4a4024fa11c859fecaad713" + , "0174f7f456ac06c1d789facc071701f8b60e9accebced73a634a6ad0e1a697d4" + , "5463bb2241d10c970b68c3abc356c0fe5ef87439fc6457c5ee94be0a3fb89834" + , "3ab62cdbc638c1b2b50533d28f31b1758c3b8435fe24bb6d4740005a73e54ce6" + , "2dbf4c9123e97177969139f5d06466c272f60d067fefadf326ccc47971115469" + , "8afce49dccc4ff64c65a83d8c0638bd8e3b7c13c52c3c59d110a8198753e96da512c7e03aeed30918706f3ad3b819e6571cfa87369c179fb9c9bbc88110baa490032a9d41f9931434e80c40ae0051400b7498810d769fb42dddbc7aa19bdf79603172efe9c0f5d1a65372b463a31178cbae581fa287f39c4fbf8434051b7419f" + ], + -- COUNT = 6 + [ "bb6b339eae26072487084ec9e4b53f2f1d4267d205042e74c77fb9ca0591ba50" + , "c0e7bf6eb07feccbc494af4098e59d30" + , "34aeec7ed0cae83701b6477709c8654a1114212401dc91cbe7de39d71f0c06e1" + , "f47fc60afbeb807236f7974d837335bc0b22288ef09ddfcb684e16b4c36a050b" + , "e8071ccd84ac4527e5c6e85b0709ed867776f25ae0e04180dcb7105ecd3e3490" + , "fbac45b5952200ad7c4232500f2417a1c14723bdd1cc078821bc2fe138b86597" + , "c4292d7dbef3ba7c18bf46bcf26776add22ab8ee206d6c722665dec6576b1bc0" + , "228aa2a314fcbfe63089ce953ac457093deaa39dd9ce2a4ece56a6028a476a98129be516d6979eff5587c032cdf4739d7ac712970f600fa781a8e542e399661183e34e4b90c59ec5dc5cad86f91083529d41c77b8f36c5a8e28ba1a548223a02eaed8426f6fe9f349ebec11bc743e767482e3472ec2799c1f530ebdc6c03bc4b" + ], + -- COUNT = 7 + [ "be658e56f80436039e2a9c0a62952dd7d70842244b5ab10f3b8a87d36104e629" + , "33c9627455dfde91865aee93e5071147" + , "d3a6eb29b180b791984deb056d72c0608a2c9044237aecf100ccb03700064c5e" + , "bef24dc9a5aa23003d3825f9b2b00e7dab571ea6ad86415dbd30c0bbdce7b972" + , "047c29e4d1584fa70cb66e2aa148a2aa29837c5eee64dcac60fdba356cdf90bb" + , "41c4792161b1b00d410cb79cd56bd311a714fb78dc3471c25bdd7479f2e9a952" + , "cd4936d7bc3ea0e7201bcbefbc908215a97680ca6ce8672360aea600b6564308" + , "2c25557f6db07db057f56ad5b6dc0427d1a0e825c48c19a526f9a65087c6d1ead7c78363a61616c84f1022653af65173a3f9ec3275f2b0a0d0bc750194673c0eaa6c623cd88abb0c8979baee4cd85bfce2e4a20bfebf2c3be61676563767dfe229e0b7be67ad6fcd116dd0b460708b1b0e5c3d60f3dd8138030404d197375d75" + ], + -- COUNT = 8 + [ "ae537f31a28ca14500e759716bc207983bfeab60b25079fa30b77b8d41244cb9" + , "fca9e27d8ab84cf9b9ce491ec5d8cb67" + , "8c9cb2b19aa3abe83c8fe7da96e9c11648252653a29dcd5bf0ac334ac587f032" + , "1eb52777be480f05115ae6370f30159a94d50ffcc64454678ab1d1ac6f166fa7" + , "9cdf6f1a2bc07acd4b0f43b5f2b892a1153e2669f237d257923636094fb40b54" + , "692d512722de6ba720fd23c8994ac63179b5f7e611addf9cfacd60e06e144a6a" + , "bbeea7b2bea821f339f494947c0b4bae8056119db69a3cbef21914953729cdef" + , "c0c4fb7080c0fbe425c1b756fb3a090cb0d08c7027d1bb82ed3b07613e2a757f83a78d42f9d8653954b489f800a5e058ebc4f5a1747526541d8448cb72e2232db20569dc96342c36672c4be625b363b4587f44557e58cedb4597cb57d006fda27e027818ae89e15b4c6382b9e7a4453290ea43163b4f9cae38b1023de6a47f7b" + ], + -- COUNT = 9 + [ "2f8994c949e08862db0204008f55d3561f3e0362df13b9d9a70fda39938f2d33" + , "1bf3e94ea858160b832fe85d301256f5" + , "b46671cf7fa142e7012ed261e1fe86714711c246c7d1c0330fa692141e86d5d1" + , "5ecdb1e8fe12260b9bfe12d6e6f161474fa2311e12e39b0beb0fcd92a6737b73" + , "3ce9a29f0207d079e6dc81fb830356e555f96a23ea71424972ea9308965786d3" + , "db950000c0776cc0e049929ce021020adc42d29cd9b5d8f7117fbe6bde3e594f" + , "fc18ee6dd3dac2306774f0ac36cd789e33462d72a8c75df9057123db33e5f7bc" + , "8546362cc8af9b78dd6e8eb2c37db96e70708852bfd9380abedc7f324575a167bea18f632f3e19d099cfbf310773f9719eec036d2e09f393a023add8ebdc4fb87af43b2fe6c7eaa4d39f8022ce247aa45fdc84d1b92cacce6eae8252a03ec2ec5330c01f56d113fd2ec3d0240af0afcf13ddde205bb5e7c2d912dcb4aee5dcf3" + ], + -- COUNT = 10 + [ "0c85e31487de1d7ba4a7b998ac56dc42c6dc0eae7bf5c8aaf1e4e78875f5fb47" + , "de878f728f73f83dc2a2f550b96c8b97" + , "9aac37bce1a6a81dc7934e23747991e3cf48c55ffe5a57781c41768a35220a01" + , "2d5ca8af1a70cfdccd015ee3bf0665dd1941fc6a7317b9d0d06658f5744cfbd9" + , "db881e6d0dc3b62793d7da5fe5a18e33be9b93f4a63a00a878dfbecf0d383bd2" + , "f743ce1b72f3de4c901369eed581c626ed3081ca707e6634fdaff46721ce0878" + , "cd52da3ec8a839c537dacdea8506a3eeee879de388ff5e513322d6d1bb3ff694" + , "a5bdd57cb8fde6298e7c5e563afcca60dd472eca484bd8c3cc17f3307be09b601744dd3ab9e8a44107c5868824575f850c0f399b280cf198006f83ede8c0b537e9be227fa140b65995ad9dfa1f2303d560c3b7f59bedd93c1282ea263924469411c2653f87fd814c74cb91c148430481d64bad0fec3cbb3dd1f39aa55c36f81b" + ], + -- COUNT = 11 + [ "93161b2dc08cb0fd50171141c865a841ca935cfdd2b5907d6ff8ab0348c4ceb0" + , "5cb9f6e5912b90c3349a50ab881b35a1" + , "0dceb4a36326c4df1685df43fddeecb5d0c76f00eb44826694f27e610290f6e1" + , "d8e9be44b5f293482548d4787762ebfb03c73c40e45385e8b98907cd66f493dd" + , "105a8f85d6959f3e043ef508cfea21d52123f03b7aea8034c4eec761eaba1fee" + , "bf781f7e489d9b4b5aa5ee6d1796468af672a8d25f311edf3c4b4dbf433d703f" + , "c81d6bcf1e5bf37e39dda1735c6f193df115b1a854a12e7cafe060afe4589335" + , "4306628124d0100fade7eaaf5edf227d50771f9e5f2e1e983800eef9a39fde0b0c280e63c8728d836b5b93ea794a32c1c04cfc54bd5300e3febb5fe2e1023eded8d7cd180279a598f76823e8d5a7dffcc93a09deec5d1f80838e938fba4de9f47e94b99382ae55f116df9c3b3ddf7e50516e203645852a415796f03a86418107" + ], + -- COUNT = 12 + [ "1ae12a5e4e9a4a5bfa79da30a9e6c62ffc639572ef1254194d129a16eb53c716" + , "5399b3481fdf24d373222267790a0fec" + , "8280cfdcd7a575816e0199e115da0ea77cae9d30b49c891a6c225e9037ba67e2" + , "681554ff702658122e91ba017450cfdfc8e3f4911153f7bcc428403e9c7b9d68" + , "226732b7a457cf0ac0ef09fd4f81296573b49a68de5e7ac3070e148c95e8e323" + , "45942b5e9a1a128e85e12c34596374ddc85fd7502e5633c7390fc6e6f1e5ef56" + , "6fc59929b41e77072886aff45f737b449b105ed7eacbd74c7cbfedf533dbeaa1" + , "b7547332e1509663fcfea2128f7f3a3df484cd8df034b00199157d35d61e35f1a9d481c7d2e81305616d70fc371ee459b0b2267d627e928590edcac3231898b24ef378aa9c3d381619f665379be76c7c1bd535505c563db3725f034786e35bdd90429305fd71d7bf680e8cdd6d4c348d97078f5cf5e89dee2dc410fad4f2a30f" + ], + -- COUNT = 13 + [ "29e20d724dfa459960df21c6ec76b1e6cabd23a9e9456d6c591d7e4529da0ef8" + , "95df1f837eba47a1687aa5c4ddcf8aaf" + , "3713b601e164b1a51dda1ca9242ff477514648e90d311a06e10ce5aa15da5d7f" + , "2a2a312626ca3e20034fc4f28033c7d573f66ef61ab2ea0c7bf0411a9d247264" + , "ec68be33ac8ff3dd127e051604898c0f9a501271859376653a0516336180993d" + , "9935499661d699a00c622a875441b4df5204958fe95892c8ce67f7dfb2be3e4a" + , "256a4ba9e8f439d5487fa5eb45efcf1bc1120491724db3abe328d951f2739fc9" + , "73114cb3624d687d4cd49a6e769dfc7a3f8901dc41f6ad1df4ce480536fa82e52ae958d0528640d92b8bb981b755058e32c4733682e5c4c0df41f3505a1643a0dd49cfdeaf7a18adffca88256c6d2cceb838af6c92a64bc21cb7a760a0391291bfe3575e014fc156323f8eb5e86518c669dad8d29ad5fd4ef6e296f4a0764c26" + ], + -- COUNT = 14 + [ "1353f3543eb1134980e061fc4382394975dbc74f1f1ea5ecc02780a813ac5ee6" + , "cf584db2447afbe2c8fa0c15575ee391" + , "345b0cc016f2765a8c33fc24f1dcfa182cbe29d7eacbcdc9bcda988521458fc2" + , "ba60219332a67b95d90ec9de6b8453d4c8af991ae9277461ff3af1b92fc985d3" + , "6964b9b9842aec9c7ec2aad926d701f30eec76fe699265ae2a7765d716958069" + , "6a03c28a9365c558c33d3fdc7e5ebf0b4d32caac70df71403fd70ced09757528" + , "a58546c72a0b4d47c9bd6c19e7cf4ab73b2d7ba36c6c6dc08606f608795ebd29" + , "5b029ef68b6799868b04dc28dbea26bc2fa9fcc8c2b2795aafeed0127b7297fa19a4ef2ba60c42ff8259d5a759f92bd90fdfb27145e82d798bb3ab7fd60bfaefb7aefb116ca2a4fa8b01d96a03c47c8d987fdd33c460e560b138891278313bb619d0c3c6f9d7c5a37e88fce83e94943705c6ff68e00484e74ad4097b0c9e5f10" + ] + ] + diff --git a/tests/Network/Haskoin/Crypto/Keys/Tests.hs b/tests/Network/Haskoin/Crypto/Keys/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Keys/Tests.hs @@ -0,0 +1,133 @@ +module Network.Haskoin.Crypto.Keys.Tests (tests) where + +import Test.QuickCheck.Property (Property, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe (fromJust, isNothing) +import Data.Binary.Get (runGet) +import Data.Binary.Put (runPut) +import qualified Data.ByteString as BS (ByteString, length, index) + +import Network.Haskoin.Crypto.Arbitrary + +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.Point +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.Curve +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "PubKey Binary" + [ testProperty "get( put(PubKey) ) = PubKey" getPutPubKey + , testProperty "is public key canonical" isCanonicalPubKey + , testProperty "makeKey( toKey(k) ) = k" makeToKey + , testProperty "makeKeyU( toKey(k) ) = k" makeToKeyU + , testProperty "decoded PubKey is always valid" decodePubKey + ], + testGroup "Key formats" + [ testProperty "fromWIF( toWIF(i) ) = i" fromToWIF + , testProperty "get( put(PrvKey) )" getPutPrv + ], + testGroup "Key compression" + [ testProperty "Compressed public key" testCompressed + , testProperty "Uncompressed public key" testUnCompressed + , testProperty "Compressed private key" testPrivateCompressed + , testProperty "Uncompressed private key" testPrivateUnCompressed + ], + testGroup "Public Key" + [ testProperty "Derived public key valid" testDerivedPubKey + , testProperty "Derived public key from Integer valid" deriveFromInt + ], + testGroup "Key properties" + [ testProperty "PubKey addition" testAddPubKey + , testProperty "PrvKey addition" testAddPrvKey + ] + ] + +{- Public Key Binary -} + +getPutPubKey :: PubKey -> Bool +getPutPubKey p = p == (decode' $ encode' p) + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- from function IsCanonicalPubKey +isCanonicalPubKey :: PubKey -> Bool +isCanonicalPubKey p = not $ + -- Non-canonical public key: too short + (BS.length bs < 33) || + -- Non-canonical public key: invalid length for uncompressed key + (BS.index bs 0 == 4 && BS.length bs /= 65) || + -- Non-canonical public key: invalid length for compressed key + (BS.index bs 0 `elem` [2,3] && BS.length bs /= 33) || + -- Non-canonical public key: compressed nor uncompressed + (not $ BS.index bs 0 `elem` [2,3,4]) + where bs = encode' p + +makeToKey :: FieldN -> Property +makeToKey i = i /= 0 ==> + (fromPrvKey $ makeKey (fromIntegral i)) == (fromIntegral i) + where makeKey = fromJust . makePrvKey + +makeToKeyU :: FieldN -> Property +makeToKeyU i = i /= 0 ==> + (fromPrvKey $ makeKey (fromIntegral i)) == (fromIntegral i) + where makeKey = fromJust . makePrvKeyU + +decodePubKey :: BS.ByteString -> Bool +decodePubKey bs = fromDecode bs True isValidPubKey + +{- Key formats -} + +fromToWIF :: PrvKey -> Bool +fromToWIF pk = pk == (fromJust $ fromWIF $ toWIF pk) + +getPutPrv :: PrvKey -> Bool +getPutPrv k@(PrvKey _) = k == runGet getPrvKey (runPut $ putPrvKey k) +getPutPrv k@(PrvKeyU _) = k == runGet getPrvKeyU (runPut $ putPrvKey k) + +{- Key Compression -} + +testCompressed :: FieldN -> Property +testCompressed n = n > 0 ==> + not $ isPubKeyU $ derivePubKey $ fromJust $ makePrvKey $ fromIntegral n + +testUnCompressed :: FieldN -> Property +testUnCompressed n = n > 0 ==> + isPubKeyU $ derivePubKey $ fromJust $ makePrvKeyU $ fromIntegral n + +testPrivateCompressed :: FieldN -> Property +testPrivateCompressed n = n > 0 ==> + not $ isPrvKeyU $ fromJust $ makePrvKey $ fromIntegral n + +testPrivateUnCompressed :: FieldN -> Property +testPrivateUnCompressed n = n > 0 ==> + isPrvKeyU $ fromJust $ makePrvKeyU $ fromIntegral n + +testDerivedPubKey :: PrvKey -> Bool +testDerivedPubKey k = isValidPubKey $ derivePubKey k + +deriveFromInt :: Integer -> Bool +deriveFromInt i = maybe True (isValidPubKey . derivePubKey) $ makePrvKey i + +{- Key properties -} + +testAddPubKey :: TestPrvKeyC -> Hash256 -> Bool +testAddPubKey (TestPrvKeyC key) i + | toInteger i >= curveN = isNothing res + | model == InfPoint = isNothing res + | otherwise = PubKey model == fromJust res + where pub = derivePubKey key + pt = mulPoint (toFieldN i) curveG + model = addPoint (pubKeyPoint pub) pt + res = addPubKeys pub i + +testAddPrvKey :: TestPrvKeyC -> Hash256 -> Bool +testAddPrvKey (TestPrvKeyC key) i + | toInteger i >= curveN = isNothing res + | model == 0 = isNothing res + | otherwise = PrvKey model == fromJust res + where model = (prvKeyFieldN key) + (toFieldN i) + res = addPrvKeys key i + diff --git a/tests/Network/Haskoin/Crypto/Merkle/Tests.hs b/tests/Network/Haskoin/Crypto/Merkle/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Merkle/Tests.hs @@ -0,0 +1,36 @@ +module Network.Haskoin.Crypto.Merkle.Tests (tests) where + +import Test.QuickCheck.Property (Property, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Network.Haskoin.Crypto.Arbitrary () +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Merkle Trees" + [ testProperty "Width of tree at maxmum height = 1" testTreeWidth + , testProperty "Width of tree at height 0 is # txns" testBaseWidth + , testProperty "extract . build partial merkle tree" buildExtractTree + ] + ] + +{- Merkle Trees -} + +testTreeWidth :: Int -> Property +testTreeWidth i = i > 0 ==> calcTreeWidth i (calcTreeHeight i) == 1 + +testBaseWidth :: Int -> Property +testBaseWidth i = i > 0 ==> calcTreeWidth i 0 == i + +buildExtractTree :: [(Hash256,Bool)] -> Property +buildExtractTree txs = not (null txs) ==> + r == (buildMerkleRoot hashes) && m == (map fst $ filter snd txs) + where + (f,h) = buildPartialMerkle txs + (r,m) = fromRight $ extractMatches f h (length txs) + hashes = map fst txs + + diff --git a/tests/Network/Haskoin/Crypto/Merkle/Units.hs b/tests/Network/Haskoin/Crypto/Merkle/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Merkle/Units.hs @@ -0,0 +1,113 @@ +module Network.Haskoin.Crypto.Merkle.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust) +import qualified Data.ByteString as BS (reverse) + +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Merkle Roots" + (map mapMerkleVectors $ zip merkleVectors [0..]) + ] + +mapMerkleVectors :: ((String,[String]),Int) -> Test.Framework.Test +mapMerkleVectors (v,i) = + testCase name $ runMerkleVector v + where + name = "MerkleRoot vector " ++ (show i) + +runMerkleVector :: (String,[String]) -> Assertion +runMerkleVector (r,hs) = do + assertBool " > Merkle Vector" $ buildMerkleRoot (map f hs) == (f r) + where + f = decode' . BS.reverse . fromJust . hexToBS + +merkleVectors :: [(String,[String])] +merkleVectors = + -- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1 + [ ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f" + , [ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52" + , "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9" + , "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41" + , "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f" + , "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6" + , "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc" + , "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3" + , "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66" + , "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f" + , "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4" + , "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3" + ] + ) + -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4 + , ( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c" + , [ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e" + , "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51" + , "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a" + , "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e" + , "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471" + , "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3" + , "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030" + , "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13" + , "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2" + , "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8" + ] + ) + -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048 + , ( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" + , [ "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" ] + ) + -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c + , ( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c" + , [ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028" + , "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b" + ] + ) + -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e + , ( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c" + , [ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549" + , "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb" + , "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633" + ] + ) + -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021 + , ( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2" + , [ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81" + , "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92" + , "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27" + , "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a" + , "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924" + , "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2" + , "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95" + , "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4" + , "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d" + , "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f" + , "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909" + , "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d" + , "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53" + , "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b" + , "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174" + , "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494" + , "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4" + , "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa" + , "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d" + , "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6" + , "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9" + , "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55" + , "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776" + , "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d" + , "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666" + , "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f" + , "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9" + , "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4" + , "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f" + ] + ) + ] + diff --git a/tests/Network/Haskoin/Crypto/Mnemonic/Tests.hs b/tests/Network/Haskoin/Crypto/Mnemonic/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Mnemonic/Tests.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Haskoin.Crypto.Mnemonic.Tests (tests) where + +import Data.Bits ((.&.), shiftR) +import Data.Binary (Binary) +import qualified Data.Text as T +import Data.Word (Word32) +import qualified Data.ByteString as BS +import Network.Haskoin.Crypto.Arbitrary() +import Network.Haskoin.Crypto.Mnemonic +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Util (encode', fromRight) +import Test.QuickCheck (Arbitrary, Property, arbitrary, choose, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + + +tests :: [Test] +tests = + [ testGroup "Encode mnemonic" + [ testProperty "128-bit entropy -> 12 words" toMnemonic128 + , testProperty "160-bit entropy -> 18 words" toMnemonic160 + , testProperty "256-bit entropy -> 24 words" toMnemonic256 + , testProperty "512-bit entropy -> 48 words" toMnemonic512 + , testProperty "n-bit entropy -> m words" toMnemonicVar + ] + , testGroup "Encode/Decode Mnemonic" + [ testProperty "128-bit entropy" fromToMnemonic128 + , testProperty "160-bit entropy" fromToMnemonic160 + , testProperty "256-bit entropy" fromToMnemonic256 + , testProperty "512-bit entropy" fromToMnemonic512 + , testProperty "n-bit entropy" fromToMnemonicVar + ] + , testGroup "Mnemonic to seed" + [ testProperty "128-bit entropy" mnemonicToSeed128 + , testProperty "160-bit entropy" mnemonicToSeed160 + , testProperty "256-bit entropy" mnemonicToSeed256 + , testProperty "512-bit entropy" mnemonicToSeed512 + , testProperty "n-bit entropy" mnemonicToSeedVar + ] + , testGroup "Get bits from ByteString" + [ testProperty "Byte count" getBitsByteCount + , testProperty "End bits" getBitsEndBits + ] + ] + +binWordsToBS :: Binary a => [a] -> BS.ByteString +binWordsToBS = foldr f BS.empty + where + f b a = a `BS.append` encode' b + +{- Encode mnemonic -} + +toMnemonic128 :: Word128 -> Bool +toMnemonic128 x = l == 12 + where + bs = encode' x + l = length . T.words . fromRight $ toMnemonic english bs + +toMnemonic160 :: Word160 -> Bool +toMnemonic160 x = l == 15 + where + bs = encode' x + l = length . T.words . fromRight $ toMnemonic english bs + +toMnemonic256 :: Word256 -> Bool +toMnemonic256 x = l == 24 + where + bs = encode' x + l = length . T.words . fromRight $ toMnemonic english bs + +toMnemonic512 :: Word512 -> Bool +toMnemonic512 x = l == 48 + where + bs = encode' x + l = length . T.words . fromRight $ toMnemonic english bs + +toMnemonicVar :: [Word32] -> Property +toMnemonicVar ls = not (length ls > 8) ==> l == wc + where + bs = binWordsToBS ls + bl = BS.length bs + cb = bl `div` 4 + wc = (cb + bl * 8) `div` 11 + l = length . T.words . fromRight $ toMnemonic english bs + +{- Encode/Decode -} + +fromToMnemonic128 :: Word128 -> Bool +fromToMnemonic128 x = bs == bs' + where + bs = encode' x + bs' = fromRight (fromMnemonic english =<< toMnemonic english bs) + +fromToMnemonic160 :: Word160 -> Bool +fromToMnemonic160 x = bs == bs' + where + bs = encode' x + bs' = fromRight (fromMnemonic english =<< toMnemonic english bs) + +fromToMnemonic256 :: Word256 -> Bool +fromToMnemonic256 x = bs == bs' + where + bs = encode' x + bs' = fromRight (fromMnemonic english =<< toMnemonic english bs) + +fromToMnemonic512 :: Word512 -> Bool +fromToMnemonic512 x = bs == bs' + where + bs = encode' x + bs' = fromRight (fromMnemonic english =<< toMnemonic english bs) + +fromToMnemonicVar :: [Word32] -> Property +fromToMnemonicVar ls = not (length ls > 8) ==> bs == bs' + where + bs = binWordsToBS ls + bs' = fromRight (fromMnemonic english =<< toMnemonic english bs) + +{- Mnemonic to seed -} + +mnemonicToSeed128 :: Word128 -> Bool +mnemonicToSeed128 x = l == 64 + where + bs = encode' x + seed = fromRight (mnemonicToSeed english "" =<< toMnemonic english bs) + l = BS.length seed + +mnemonicToSeed160 :: Word160 -> Bool +mnemonicToSeed160 x = l == 64 + where + bs = encode' x + seed = fromRight (mnemonicToSeed english "" =<< toMnemonic english bs) + l = BS.length seed + +mnemonicToSeed256 :: Word256 -> Bool +mnemonicToSeed256 x = l == 64 + where + bs = encode' x + seed = fromRight (mnemonicToSeed english "" =<< toMnemonic english bs) + l = BS.length seed + +mnemonicToSeed512 :: Word512 -> Bool +mnemonicToSeed512 x = l == 64 + where + bs = encode' x + seed = fromRight (mnemonicToSeed english "" =<< toMnemonic english bs) + l = BS.length seed + +mnemonicToSeedVar :: [Word32] -> Property +mnemonicToSeedVar ls = not (length ls > 16) ==> l == 64 + where + bs = binWordsToBS ls + seed = fromRight (mnemonicToSeed english "" =<< toMnemonic english bs) + l = BS.length seed + +{- Get bits from ByteString -} + +data ByteCountGen = ByteCountGen BS.ByteString Int deriving Show + +instance Arbitrary ByteCountGen where + arbitrary = do + bs <- arbitrary + i <- choose (0, BS.length bs * 8) + return $ ByteCountGen bs i + +getBitsByteCount :: ByteCountGen -> Bool +getBitsByteCount (ByteCountGen bs i) = BS.length bits == l + where + (q, r) = i `quotRem` 8 + bits = getBits i bs + l = if r == 0 then q else q + 1 + +getBitsEndBits :: ByteCountGen -> Bool +getBitsEndBits (ByteCountGen bs i) = mask + where + r = i `mod` 8 + bits = getBits i bs + mask = if r == 0 then True else BS.last bits .&. (0xff `shiftR` r) == 0x00 + diff --git a/tests/Network/Haskoin/Crypto/Mnemonic/Units.hs b/tests/Network/Haskoin/Crypto/Mnemonic/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Mnemonic/Units.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Haskoin.Crypto.Mnemonic.Units (tests) where + +import Test.HUnit (assertEqual) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Network.Haskoin.Crypto.Mnemonic +import Network.Haskoin.Util (hexToBS, bsToHex, fromRight) + +tests :: [Test] +tests = + [ testGroup "Entropy to mnemonic sentence" toMnemonicTest + , testGroup "Mnemonic sentence to entropy" fromMnemonicTest + , testGroup "Mnemonic sentence to seed" mnemonicToSeedTest + ] + +toMnemonicTest :: [Test] +toMnemonicTest = map f $ zip ents mss + where + f (e, m) = g e . assertEqual "" m . h $ e + g = testCase + h = fromRight . toMnemonic english . fromJust . hexToBS + +fromMnemonicTest :: [Test] +fromMnemonicTest = map f $ zip ents mss + where + f (e, m) = g e . assertEqual "" e . h $ m + g = testCase + h = bsToHex . fromRight . fromMnemonic english + +mnemonicToSeedTest :: [Test] +mnemonicToSeedTest = map f $ zip mss seeds + where + f (m, s) = g s . assertEqual "" s . h $ m + g = testCase . (++ "...") . take 50 + h = bsToHex . fromRight . mnemonicToSeed english "TREZOR" + + +ents :: [String] +ents = + [ "00000000000000000000000000000000" + , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" + , "80808080808080808080808080808080" + , "ffffffffffffffffffffffffffffffff" + , "000000000000000000000000000000000000000000000000" + , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" + , "808080808080808080808080808080808080808080808080" + , "ffffffffffffffffffffffffffffffffffffffffffffffff" + , "0000000000000000000000000000000000000000000000000000000000000000" + , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" + , "8080808080808080808080808080808080808080808080808080808080808080" + , "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + , "77c2b00716cec7213839159e404db50d" + , "b63a9c59a6e641f288ebc103017f1da9f8290b3da6bdef7b" + , "3e141609b97933b66a060dcddc71fad1d91677db872031e85f4c015c5e7e8982" + , "0460ef47585604c5660618db2e6a7e7f" + , "72f60ebac5dd8add8d2a25a797102c3ce21bc029c200076f" + , "2c85efc7f24ee4573d2b81a6ec66cee209b2dcbd09d8eddc51e0215b0b68e416" + , "eaebabb2383351fd31d703840b32e9e2" + , "7ac45cfe7722ee6c7ba84fbc2d5bd61b45cb2fe5eb65aa78" + , "4fa1a8bc3e6d80ee1316050e862c1812031493212b7ec3f3bb1b08f168cabeef" + , "18ab19a9f54a9274f03e5209a2ac8a91" + , "18a2e1d81b8ecfb2a333adcb0c17a5b9eb76cc5d05db91a4" + , "15da872c95a13dd738fbf50e427583ad61f18fd99f628c417a61cf8343c90419" + ] + +mss :: [T.Text] +mss = + [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon about" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ yellow" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage above" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo wrong" + , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon agent" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal will" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter always" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ when" + , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon art" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal winner thank year wave sausage\ + \ worth title" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ + \ amount doctor acoustic bless" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo zoo zoo zoo zoo vote" + , "jelly better achieve collect unaware mountain thought cargo oxygen act\ + \ hood bridge" + , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ + \ fault little machine walk stumble urge swap" + , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ + \ multiply desk host tomato cradle drill spread actor shine dismiss\ + \ champion exotic" + , "afford alter spike radar gate glance object seek swamp infant panel\ + \ yellow" + , "indicate race push merry suffer human cruise dwarf pole review arch keep\ + \ canvas theme poem divorce alter left" + , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ + \ recipe series open hour vintage deposit universe tip job dress radar\ + \ refuse motion taste" + , "turtle front uncle idea crush write shrug there lottery flower risk\ + \ shell" + , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ + \ void custom frequent obey nut hole price segment" + , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ + \ catch course end lucky hurt sentence oven short ball bird grab wing top" + , "board flee heavy tunnel powder denial science ski answer betray cargo\ + \ cat" + , "board blade invite damage undo sun mimic interest slam gaze truly\ + \ inherit resist great inject rocket museum chief" + , "beyond stage sleep clip because twist token leaf atom beauty genius food\ + \ business side grid unable middle armed observe pair crouch tonight away\ + \ coconut" + ] + +seeds :: [String] +seeds = + [ "c55257c360c07c72029aebc1b53c05ed0362ada38ead3e3e9efa3708e53495531f09a69\ + \87599d18264c1e1c92f2cf141630c7a3c4ab7c81b2f001698e7463b04" + , "2e8905819b8723fe2c1d161860e5ee1830318dbf49a83bd451cfb8440c28bd6fa457fe1\ + \296106559a3c80937a1c1069be3a3a5bd381ee6260e8d9739fce1f607" + , "d71de856f81a8acc65e6fc851a38d4d7ec216fd0796d0a6827a3ad6ed5511a30fa280f1\ + \2eb2e47ed2ac03b5c462a0358d18d69fe4f985ec81778c1b370b652a8" + , "ac27495480225222079d7be181583751e86f571027b0497b5b5d11218e0a8a133325729\ + \17f0f8e5a589620c6f15b11c61dee327651a14c34e18231052e48c069" + , "035895f2f481b1b0f01fcf8c289c794660b289981a78f8106447707fdd9666ca06da5a9\ + \a565181599b79f53b844d8a71dd9f439c52a3d7b3e8a79c906ac845fa" + , "f2b94508732bcbacbcc020faefecfc89feafa6649a5491b8c952cede496c214a0c7b3c3\ + \92d168748f2d4a612bada0753b52a1c7ac53c1e93abd5c6320b9e95dd" + , "107d7c02a5aa6f38c58083ff74f04c607c2d2c0ecc55501dadd72d025b751bc27fe913f\ + \fb796f841c49b1d33b610cf0e91d3aa239027f5e99fe4ce9e5088cd65" + , "0cd6e5d827bb62eb8fc1e262254223817fd068a74b5b449cc2f667c3f1f985a76379b43\ + \348d952e2265b4cd129090758b3e3c2c49103b5051aac2eaeb890a528" + , "bda85446c68413707090a52022edd26a1c9462295029f2e60cd7c4f2bbd3097170af7a4\ + \d73245cafa9c3cca8d561a7c3de6f5d4a10be8ed2a5e608d68f92fcc8" + , "bc09fca1804f7e69da93c2f2028eb238c227f2e9dda30cd63699232578480a4021b146a\ + \d717fbb7e451ce9eb835f43620bf5c514db0f8add49f5d121449d3e87" + , "c0c519bd0e91a2ed54357d9d1ebef6f5af218a153624cf4f2da911a0ed8f7a09e2ef61a\ + \f0aca007096df430022f7a2b6fb91661a9589097069720d015e4e982f" + , "dd48c104698c30cfe2b6142103248622fb7bb0ff692eebb00089b32d22484e1613912f0\ + \a5b694407be899ffd31ed3992c456cdf60f5d4564b8ba3f05a69890ad" + , "b5b6d0127db1a9d2226af0c3346031d77af31e918dba64287a1b44b8ebf63cdd52676f6\ + \72a290aae502472cf2d602c051f3e6f18055e84e4c43897fc4e51a6ff" + , "9248d83e06f4cd98debf5b6f010542760df925ce46cf38a1bdb4e4de7d21f5c39366941\ + \c69e1bdbf2966e0f6e6dbece898a0e2f0a4c2b3e640953dfe8b7bbdc5" + , "ff7f3184df8696d8bef94b6c03114dbee0ef89ff938712301d27ed8336ca89ef9635da2\ + \0af07d4175f2bf5f3de130f39c9d9e8dd0472489c19b1a020a940da67" + , "65f93a9f36b6c85cbe634ffc1f99f2b82cbb10b31edc7f087b4f6cb9e976e9faf76ff41\ + \f8f27c99afdf38f7a303ba1136ee48a4c1e7fcd3dba7aa876113a36e4" + , "3bbf9daa0dfad8229786ace5ddb4e00fa98a044ae4c4975ffd5e094dba9e0bb289349db\ + \e2091761f30f382d4e35c4a670ee8ab50758d2c55881be69e327117ba" + , "fe908f96f46668b2d5b37d82f558c77ed0d69dd0e7e043a5b0511c48c2f1064694a956f\ + \86360c93dd04052a8899497ce9e985ebe0c8c52b955e6ae86d4ff4449" + , "bdfb76a0759f301b0b899a1e3985227e53b3f51e67e3f2a65363caedf3e32fde42a66c4\ + \04f18d7b05818c95ef3ca1e5146646856c461c073169467511680876c" + , "ed56ff6c833c07982eb7119a8f48fd363c4a9b1601cd2de736b01045c5eb8ab4f57b079\ + \403485d1c4924f0790dc10a971763337cb9f9c62226f64fff26397c79" + , "095ee6f817b4c2cb30a5a797360a81a40ab0f9a4e25ecd672a3f58a0b5ba0687c096a6b\ + \14d2c0deb3bdefce4f61d01ae07417d502429352e27695163f7447a8c" + , "6eff1bb21562918509c73cb990260db07c0ce34ff0e3cc4a8cb3276129fbcb300bddfe0\ + \05831350efd633909f476c45c88253276d9fd0df6ef48609e8bb7dca8" + , "f84521c777a13b61564234bf8f8b62b3afce27fc4062b51bb5e62bdfecb23864ee6ecf0\ + \7c1d5a97c0834307c5c852d8ceb88e7c97923c0a3b496bedd4e5f88a9" + , "b15509eaa2d09d3efd3e006ef42151b30367dc6e3aa5e44caba3fe4d3e352e65101fbdb\ + \86a96776b91946ff06f8eac594dc6ee1d3e82a42dfe1b40fef6bcc3fd" + ] diff --git a/tests/Network/Haskoin/Crypto/Point/Tests.hs b/tests/Network/Haskoin/Crypto/Point/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Point/Tests.hs @@ -0,0 +1,103 @@ +module Network.Haskoin.Crypto.Point.Tests (tests) where + +import Test.QuickCheck.Property (Property, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe (fromJust) + +import Network.Haskoin.Crypto.Arbitrary() +import Network.Haskoin.Crypto.Point +import Network.Haskoin.Crypto.BigWord + +tests :: [Test] +tests = + [ testGroup "Elliptic curve point arithmetic" + [ testProperty "P is on the curve" checkOnCurve + , testProperty "P1 + P2 is on the curve" addOnCurve + , testProperty "n*P is on the curve" mulOnCurve + , testProperty "makePoint (getAffine P) = P" fromToAffine + , testProperty "P + InfPoint = P" addInfPoint + , testProperty "InfPoint + P = P" addInfPoint' + , testProperty "P1 + P2 = P2 + P1" addCommutative + , testProperty "(P1 + P2) + P3 = P1 + (P2 + P3)" addAssoc + , testProperty "(x,y) + (x,-y) = InfPoint" addInverseY + , testProperty "double P = P + P" doubleAddPoint + , testProperty "double P = 2*P" doubleMulPoint + , testProperty "n*P = P + (n-1)*P" mulPointInduction + , testProperty "a*P + b*P = (a + b)*P" mulDistributivity + , testProperty "shamirsTrick = n1*P1 + n2*P2" testShamirsTrick + , testProperty "point equality" testPointEqual + ] + ] + +{- Elliptic curve point arithmetic -} + +checkOnCurve :: Point -> Bool +checkOnCurve InfPoint = True +checkOnCurve p = validatePoint p + +addOnCurve :: Point -> Point -> Bool +addOnCurve p1 p2 = case addPoint p1 p2 of + InfPoint -> True + p -> validatePoint p + +mulOnCurve :: Point -> FieldN -> Bool +mulOnCurve p1 n = case mulPoint n p1 of + InfPoint -> True + p -> validatePoint p + +fromToAffine :: Point -> Property +fromToAffine p = not (isInfPoint p) ==> (fromJust $ makePoint x y) == p + where + (x,y) = fromJust $ getAffine p + +addInfPoint :: Point -> Bool +addInfPoint p = addPoint p makeInfPoint == p + +addInfPoint' :: Point -> Bool +addInfPoint' p = addPoint makeInfPoint p == p + +addCommutative :: Point -> Point -> Bool +addCommutative p1 p2 = addPoint p1 p2 == addPoint p2 p1 + +addAssoc :: Point -> Point -> Point -> Bool +addAssoc p1 p2 p3 = + addPoint (addPoint p1 p2) p3 == addPoint p1 (addPoint p2 p3) + +addInverseY :: Point -> Bool +addInverseY p1 = case (getAffine p1) of + (Just (x,y)) -> addPoint p1 (fromJust $ makePoint x (-y)) == makeInfPoint + Nothing -> True + +doubleAddPoint :: Point -> Bool +doubleAddPoint p = doublePoint p == addPoint p p + +doubleMulPoint :: Point -> Bool +doubleMulPoint p = doublePoint p == mulPoint 2 p + +mulPointInduction :: FieldN -> Point -> Property +mulPointInduction i p = i > 2 ==> + mulPoint i p == addPoint p (mulPoint (i-1) p) + +mulDistributivity :: FieldN -> FieldN -> Point -> Bool +mulDistributivity a b p = + (addPoint (mulPoint a p) (mulPoint b p)) == mulPoint (a + b) p + +testShamirsTrick :: FieldN -> Point -> FieldN -> Point -> Bool +testShamirsTrick n1 p1 n2 p2 = shamirRes == normalRes + where + shamirRes = shamirsTrick n1 p1 n2 p2 + normalRes = addPoint (mulPoint n1 p1) (mulPoint n2 p2) + +testPointEqual :: Point -> Point -> Bool +testPointEqual p1@InfPoint p2@InfPoint = p1 == p2 +testPointEqual p1 p2@InfPoint = p1 /= p2 +testPointEqual p1@InfPoint p2 = p1 /= p2 +testPointEqual p1 p2 + | x1 == x2 && y1 == y2 = p1 == p2 + | otherwise = p1 /= p2 + where + (x1,y1) = fromJust $ getAffine p1 + (x2,y2) = fromJust $ getAffine p2 + diff --git a/tests/Network/Haskoin/Crypto/Units.hs b/tests/Network/Haskoin/Crypto/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Crypto/Units.hs @@ -0,0 +1,264 @@ +module Network.Haskoin.Crypto.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Control.Monad (replicateM_) +import Control.Monad.Trans (liftIO) + +import Data.Maybe +import Data.Binary +import qualified Data.ByteString as BS + +import Network.Haskoin.Crypto.Keys +import Network.Haskoin.Crypto.BigWord +import Network.Haskoin.Crypto.ECDSA +import Network.Haskoin.Crypto.Hash +import Network.Haskoin.Crypto.Base58 +import Network.Haskoin.Util + +-- Unit tests copied from bitcoind implementation +-- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_tests.cpp + +strSecret1 :: String +strSecret1 = "5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" + +strSecret2 :: String +strSecret2 = "5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" + +strSecret1C :: String +strSecret1C = "Kwr371tjA9u2rFSMZjTNun2PXXP3WPZu2afRHTcta6KxEUdm1vEw" + +strSecret2C :: String +strSecret2C = "L3Hq7a8FEQwJkW1M2GNKDW28546Vp5miewcCzSqUD9kCAXrJdS3g" + +addr1 :: String +addr1 = "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ" + +addr2 :: String +addr2 = "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ" + +addr1C :: String +addr1C = "1NoJrossxPBKfCHuJXT4HadJrXRE9Fxiqs" + +addr2C :: String +addr2C = "1CRj2HyM1CXWzHAXLQtiGLyggNT9WQqsDs" + +strAddressBad :: String +strAddressBad = "1HV9Lc3sNHZxwj4Zk6fB38tEmBryq2cBiF" + +sigMsg :: [String] +sigMsg = [ ("Very secret message " ++ (show (i :: Int)) ++ ": 11") + | i <- [0..15] + ] + +sec1 :: PrvKey +sec1 = fromJust $ fromWIF strSecret1 + +sec2 :: PrvKey +sec2 = fromJust $ fromWIF strSecret2 + +sec1C :: PrvKey +sec1C = fromJust $ fromWIF strSecret1C + +sec2C :: PrvKey +sec2C = fromJust $ fromWIF strSecret2C + +pub1 :: PubKey +pub1 = derivePubKey sec1 + +pub2 :: PubKey +pub2 = derivePubKey sec2 + +pub1C :: PubKey +pub1C = derivePubKey sec1C + +pub2C :: PubKey +pub2C = derivePubKey sec2C + +tests :: [Test] +tests = + [ testGroup "ECDSA PRNG unit tests" + [ testCase "signMsg produces unique sigantures" uniqueSigs + , testCase "genPrvKey produces unique keys" uniqueKeys + ] + , testGroup "bitcoind /src/test/key_tests.cpp" $ + [ testCase "Decode Valid WIF" checkPrivkey + , testCase "Decode Invalid WIF" checkInvalidKey + , testCase "Check private key compression" checkPrvKeyCompressed + , testCase "Check public key compression" checkKeyCompressed + , testCase "Check matching address" checkMatchingAddress + ] ++ + ( map (\x -> (testCase ("Check sig: " ++ (show x)) + (checkSignatures $ doubleHash256 $ stringToBS x))) sigMsg ) + , testGroup "Trezor RFC 6979 Test Vectors" + [ testCase "RFC 6979 Test Vector 1" (testDetSigning $ detVec !! 0) + , testCase "RFC 6979 Test Vector 2" (testDetSigning $ detVec !! 1) + , testCase "RFC 6979 Test Vector 3" (testDetSigning $ detVec !! 2) + , testCase "RFC 6979 Test Vector 4" (testDetSigning $ detVec !! 3) + , testCase "RFC 6979 Test Vector 5" (testDetSigning $ detVec !! 4) + , testCase "RFC 6979 Test Vector 6" (testDetSigning $ detVec !! 5) + , testCase "RFC 6979 Test Vector 7" (testDetSigning $ detVec !! 6) + , testCase "RFC 6979 Test Vector 8" (testDetSigning $ detVec !! 7) + , testCase "RFC 6979 Test Vector 9" (testDetSigning $ detVec !! 8) + , testCase "RFC 6979 Test Vector 10" (testDetSigning $ detVec !! 9) + , testCase "RFC 6979 Test Vector 11" (testDetSigning $ detVec !! 10) + , testCase "RFC 6979 Test Vector 12" (testDetSigning $ detVec !! 11) + ] + ] + +{- ECDSA PRNG unit tests -} + +uniqueSigs :: Assertion +uniqueSigs = do + let msg = hash256 $ BS.pack [0..19] + prv = fromJust $ makePrvKey 0x987654321 + ((r1,s1),(r2,s2),(r3,s3)) <- liftIO $ withSource devURandom $ do + (Signature a b) <- signMsg msg prv + (Signature c d) <- signMsg msg prv + replicateM_ 20 $ signMsg msg prv + (Signature e f) <- signMsg msg prv + return $ ((a,b),(c,d),(e,f)) + assertBool "DiffSig" $ + r1 /= r2 && r1 /= r3 && r2 /= r3 && + s1 /= s2 && s1 /= s3 && s2 /= s3 + +uniqueKeys :: Assertion +uniqueKeys = do + (k1,k2,k3) <- liftIO $ withSource devURandom $ do + a <- genPrvKey + b <- genPrvKey + replicateM_ 20 genPrvKey + c <- genPrvKey + return (a,b,c) + assertBool "DiffKey" $ k1 /= k2 && k1 /= k3 && k2 /= k3 + +{- bitcoind /src/test/key_tests.cpp -} + +checkPrivkey :: Assertion +checkPrivkey = do + assertBool "Key 1" $ isJust $ fromWIF strSecret1 + assertBool "Key 2" $ isJust $ fromWIF strSecret2 + assertBool "Key 1C" $ isJust $ fromWIF strSecret1C + assertBool "Key 2C" $ isJust $ fromWIF strSecret2C + +checkInvalidKey :: Assertion +checkInvalidKey = + assertBool "Bad key" $ isNothing $ fromWIF strAddressBad + + +checkPrvKeyCompressed :: Assertion +checkPrvKeyCompressed = do + assertBool "Key 1" $ isPrvKeyU sec1 + assertBool "Key 2" $ isPrvKeyU sec2 + assertBool "Key 1C" $ not $ isPrvKeyU sec1C + assertBool "Key 2C" $ not $ isPrvKeyU sec2C + +checkKeyCompressed :: Assertion +checkKeyCompressed = do + assertBool "Key 1" $ isPubKeyU pub1 + assertBool "Key 2" $ isPubKeyU pub2 + assertBool "Key 1C" $ not $ isPubKeyU pub1C + assertBool "Key 2C" $ not $ isPubKeyU pub2C + +checkMatchingAddress :: Assertion +checkMatchingAddress = do + assertBool "Key 1" $ addr1 == (addrToBase58 $ pubKeyAddr pub1) + assertBool "Key 2" $ addr2 == (addrToBase58 $ pubKeyAddr pub2) + assertBool "Key 1C" $ addr1C == (addrToBase58 $ pubKeyAddr pub1C) + assertBool "Key 2C" $ addr2C == (addrToBase58 $ pubKeyAddr pub2C) + +checkSignatures :: Hash256 -> Assertion +checkSignatures h = do + (sign1, sign2, sign1C, sign2C) <- liftIO $ withSource devURandom $ do + a <- signMsg h sec1 + b <- signMsg h sec2 + c <- signMsg h sec1C + d <- signMsg h sec2C + return (a,b,c,d) + assertBool "Key 1, Sign1" $ verifySig h sign1 pub1 + assertBool "Key 1, Sign2" $ not $ verifySig h sign2 pub1 + assertBool "Key 1, Sign1C" $ verifySig h sign1C pub1 + assertBool "Key 1, Sign2C" $ not $ verifySig h sign2C pub1 + assertBool "Key 2, Sign1" $ not $ verifySig h sign1 pub2 + assertBool "Key 2, Sign2" $ verifySig h sign2 pub2 + assertBool "Key 2, Sign1C" $ not $ verifySig h sign1C pub2 + assertBool "Key 2, Sign2C" $ verifySig h sign2C pub2 + assertBool "Key 1C, Sign1" $ verifySig h sign1 pub1C + assertBool "Key 1C, Sign2" $ not $ verifySig h sign2 pub1C + assertBool "Key 1C, Sign1C" $ verifySig h sign1C pub1C + assertBool "Key 1C, Sign2C" $ not $ verifySig h sign2C pub1C + assertBool "Key 2C, Sign1" $ not $ verifySig h sign1 pub2C + assertBool "Key 2C, Sign2" $ verifySig h sign2 pub2C + assertBool "Key 2C, Sign1C" $ not $ verifySig h sign1C pub2C + assertBool "Key 2C, Sign2C" $ verifySig h sign2C pub2C + + +{- Trezor RFC 6979 Test Vectors -} +-- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py + +detVec :: [(Integer,String,String)] +detVec = + [ + ( 0x1 + , "Satoshi Nakamoto" + , "934b1ea10a4b3c1757e2b0c017d0b6143ce3c9a7e6a4a49860d7a6ab210ee3d82442ce9d2b916064108014783e923ec36b49743e2ffa1c4496f01a512aafd9e5" + ) + , ( 0x1 + , "All those moments will be lost in time, like tears in rain. Time to die..." + , "8600dbd41e348fe5c9465ab92d23e3db8b98b873beecd930736488696438cb6b547fe64427496db33bf66019dacbf0039c04199abb0122918601db38a72cfc21" + ) + , ( 0Xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140 + , "Satoshi Nakamoto" + , "fd567d121db66e382991534ada77a6bd3106f0a1098c231e47993447cd6af2d06b39cd0eb1bc8603e159ef5c20a5c8ad685a45b06ce9bebed3f153d10d93bed5" + ) + , ( 0xf8b8af8ce3c7cca5e300d33939540c10d45ce001b8f252bfbc57ba0342904181 + , "Alan Turing" + , "7063ae83e7f62bbb171798131b4a0564b956930092b33b07b395615d9ec7e15c58dfcc1e00a35e1572f366ffe34ba0fc47db1e7189759b9fb233c5b05ab388ea" + ) + , ( 0xe91671c46231f833a6406ccbea0e3e392c76c167bac1cb013f6f1013980455c2 + , "There is a computer disease that anybody who works with computers knows about. It's a very serious disease and it interferes completely with the work. The trouble with computers is that you 'play' with them!" + , "b552edd27580141f3b2a5463048cb7cd3e047b97c9f98076c32dbdf85a68718b279fa72dd19bfae05577e06c7c0c1900c371fcd5893f7e1d56a37d30174671f6" + ) + , ( 0x0000000000000000000000000000000000000000000000000000000000000001 + , "Everything should be made as simple as possible, but not simpler." + , "33a69cd2065432a30f3d1ce4eb0d59b8ab58c74f27c41a7fdb5696ad4e6108c96f807982866f785d3f6418d24163ddae117b7db4d5fdf0071de069fa54342262" + ) + , ( 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140 + , "Equations are more important to me, because politics is for the present, but an equation is something for eternity." + , "54c4a33c6423d689378f160a7ff8b61330444abb58fb470f96ea16d99d4a2fed07082304410efa6b2943111b6a4e0aaa7b7db55a07e9861d1fb3cb1f421044a5" + ) + , ( 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140 + , "Not only is the Universe stranger than we think, it is stranger than we can think." + , "ff466a9f1b7b273e2f4c3ffe032eb2e814121ed18ef84665d0f515360dab3dd06fc95f5132e5ecfdc8e5e6e616cc77151455d46ed48f5589b7db7771a332b283" + ) + , ( 0x0000000000000000000000000000000000000000000000000000000000000001 + , "How wonderful that we have met with a paradox. Now we have some hope of making progress." + , "c0dafec8251f1d5010289d210232220b03202cba34ec11fec58b3e93a85b91d375afdc06b7d6322a590955bf264e7aaa155847f614d80078a90292fe205064d3" + ) + , ( 0x69ec59eaa1f4f2e36b639716b7c30ca86d9a5375c7b38d8918bd9c0ebc80ba64 + , "Computer science is no more about computers than astronomy is about telescopes." + , "7186363571d65e084e7f02b0b77c3ec44fb1b257dee26274c38c928986fea45d0de0b38e06807e46bda1f1e293f4f6323e854c86d58abdd00c46c16441085df6" + ) + , ( 0x00000000000000000000000000007246174ab1e92e9149c6e446fe194d072637 + , "...if you aren't, at any given time, scandalized by code you wrote five or even three years ago, you're not learning anywhere near enough" + , "fbfe5076a15860ba8ed00e75e9bd22e05d230f02a936b653eb55b61c99dda4870e68880ebb0050fe4312b1b1eb0899e1b82da89baa5b895f612619edf34cbd37" + ) + , ( 0x000000000000000000000000000000000000000000056916d0f9b31dc9b637f3 + , "The question of whether computers can think is like the question of whether submarines can swim." + , "cde1302d83f8dd835d89aef803c74a119f561fbaef3eb9129e45f30de86abbf906ce643f5049ee1f27890467b77a6a8e11ec4661cc38cd8badf90115fbd03cef" + ) + ] + +testDetSigning :: (Integer, String, String) -> Assertion +testDetSigning (prv,msg,str) = do + assertBool "RFC 6979 Vector" $ res == (fromJust $ hexToBS str) + assertBool "Valid sig" $ verifySig msg' sig (derivePubKey prv') + where sig@(Signature r s) = detSignMsg msg' prv' + msg' = hash256 $ stringToBS msg + prv' = fromJust $ makePrvKey prv + res = runPut' $ put (fromIntegral r :: Hash256) >> + put (fromIntegral s :: Hash256) + + diff --git a/tests/Network/Haskoin/Protocol/Arbitrary.hs b/tests/Network/Haskoin/Protocol/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Protocol/Arbitrary.hs @@ -0,0 +1,237 @@ +{-| + This package provides QuickCheck Arbitrary instances for all the protocol + data types defined in 'Network.Haskoin.Protocol'. +-} +module Network.Haskoin.Protocol.Arbitrary () where + +import Test.QuickCheck +import Network.Haskoin.Util.Arbitrary (nonEmptyBS) +import Network.Haskoin.Crypto.Arbitrary() + +import Control.Monad +import Control.Applicative + +import qualified Data.Sequence as S (fromList) + +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto + +instance Arbitrary VarInt where + arbitrary = VarInt <$> arbitrary + +instance Arbitrary VarString where + arbitrary = VarString <$> arbitrary + +instance Arbitrary NetworkAddress where + arbitrary = do + s <- arbitrary + a <- liftM2 (,) arbitrary arbitrary + p <- arbitrary + return $ NetworkAddress s a p + +instance Arbitrary InvType where + arbitrary = elements [InvError, InvTx, InvBlock, InvMerkleBlock] + +instance Arbitrary InvVector where + arbitrary = InvVector <$> arbitrary <*> (hash256 <$> arbitrary) + +instance Arbitrary Inv where + arbitrary = Inv <$> listOf arbitrary + +instance Arbitrary Version where + arbitrary = Version <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Addr where + arbitrary = Addr <$> listOf arbitrary + +instance Arbitrary Alert where + arbitrary = Alert <$> arbitrary <*> arbitrary + +instance Arbitrary BlockHeader where + arbitrary = BlockHeader <$> arbitrary + <*> (hash256 <$> arbitrary) + <*> (hash256 <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Script where + arbitrary = do + i <- choose (1,10) + Script <$> (vectorOf i arbitrary) + +instance Arbitrary Tx where + arbitrary = do + v <- arbitrary + tin <- do + l <- choose (0,10) + vectorOf l arbitrary + tout <- do + l <- choose (0,10) + vectorOf l arbitrary + t <- arbitrary + return $ Tx v tin tout t + +instance Arbitrary CoinbaseTx where + arbitrary = CoinbaseTx <$> arbitrary + <*> (return $ OutPoint 0 0xffffffff) + <*> arbitrary + <*> (return $ 0xffffffff) + <*> (listOf arbitrary) + <*> arbitrary + +instance Arbitrary TxIn where + arbitrary = TxIn <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary TxOut where + arbitrary = TxOut <$> (choose (0,2100000000000000)) + <*> arbitrary + +instance Arbitrary OutPoint where + arbitrary = OutPoint <$> arbitrary + <*> arbitrary + +instance Arbitrary Block where + arbitrary = do + h <- arbitrary + c <- arbitrary + t <- do + l <- choose (0,10) + vectorOf l arbitrary + return $ Block h c t + +instance Arbitrary MerkleBlock where + arbitrary = do + h <- arbitrary + ntx <- arbitrary + hashes <- arbitrary + c <- choose (1,10) + flags <- vectorOf (c*8) arbitrary + return $ MerkleBlock h ntx hashes flags + +instance Arbitrary PushDataType where + arbitrary = elements [ OPCODE, OPDATA1, OPDATA2, OPDATA4 ] + +instance Arbitrary ScriptOp where + arbitrary = oneof [ opPushData <$> nonEmptyBS + , return OP_0 + , return OP_1NEGATE + , return OP_1 + , return OP_2, return OP_3, return OP_4, return OP_5 + , return OP_6, return OP_7, return OP_8, return OP_9 + , return OP_10, return OP_11, return OP_12, return OP_13 + , return OP_14, return OP_15, return OP_16 + , return OP_VERIFY + , return OP_DUP + , return OP_EQUAL + , return OP_EQUALVERIFY + , return OP_HASH160 + , return OP_CHECKSIG + , return OP_CHECKMULTISIG + , OP_PUBKEY <$> arbitrary + , return $ OP_INVALIDOPCODE 0xff + ] + +instance Arbitrary GetBlocks where + arbitrary = GetBlocks <$> arbitrary + <*> (listOf arbitrary) + <*> arbitrary + +instance Arbitrary GetData where + arbitrary = GetData <$> (listOf arbitrary) + +instance Arbitrary GetHeaders where + arbitrary = GetHeaders <$> arbitrary + <*> (listOf arbitrary) + <*> arbitrary + +instance Arbitrary Headers where + arbitrary = Headers <$> (listOf (liftM2 (,) arbitrary arbitrary)) + +instance Arbitrary NotFound where + arbitrary = NotFound <$> (listOf arbitrary) + +instance Arbitrary Ping where + arbitrary = Ping <$> arbitrary + +instance Arbitrary Pong where + arbitrary = Pong <$> arbitrary + +instance Arbitrary MessageCommand where + arbitrary = elements [ MCVersion + , MCVerAck + , MCAddr + , MCInv + , MCGetData + , MCNotFound + , MCGetBlocks + , MCGetHeaders + , MCTx + , MCBlock + , MCHeaders + , MCGetAddr + , MCFilterLoad + , MCFilterAdd + , MCFilterClear + , MCPing + , MCPong + , MCAlert + ] + +instance Arbitrary MessageHeader where + arbitrary = MessageHeader <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Message where + arbitrary = oneof [ MVersion <$> arbitrary + , return MVerAck + , MAddr <$> arbitrary + , MInv <$> arbitrary + , MGetData <$> arbitrary + , MNotFound <$> arbitrary + , MGetBlocks <$> arbitrary + , MGetHeaders <$> arbitrary + , MTx <$> arbitrary + , MBlock <$> arbitrary + , MHeaders <$> arbitrary + , return MGetAddr + , MFilterLoad <$> arbitrary + , MFilterAdd <$> arbitrary + , return MFilterClear + , MPing <$> arbitrary + , MPong <$> arbitrary + , MAlert <$> arbitrary + ] + +instance Arbitrary BloomFlags where + arbitrary = elements [ BloomUpdateNone + , BloomUpdateAll + , BloomUpdateP2PubKeyOnly + ] + +instance Arbitrary BloomFilter where + arbitrary = BloomFilter <$> (S.fromList <$> arbitrary) + <*> (return False) + <*> (return False) + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary FilterLoad where + arbitrary = FilterLoad <$> arbitrary + +instance Arbitrary FilterAdd where + arbitrary = FilterAdd <$> arbitrary + diff --git a/tests/Network/Haskoin/Protocol/Tests.hs b/tests/Network/Haskoin/Protocol/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Protocol/Tests.hs @@ -0,0 +1,59 @@ +module Network.Haskoin.Protocol.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +import Network.Haskoin.Protocol.Arbitrary() +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto + +tests :: [Test] +tests = + [ testGroup "Serialize & de-serialize protocol messages" + [ testProperty "VarInt" (metaGetPut :: VarInt -> Bool) + , testProperty "VarString" (metaGetPut :: VarString -> Bool) + , testProperty "NetworkAddress" (metaGetPut :: NetworkAddress -> Bool) + , testProperty "InvType" (metaGetPut :: InvType -> Bool) + , testProperty "InvVector" (metaGetPut :: InvVector -> Bool) + , testProperty "Inv" (metaGetPut :: Inv -> Bool) + , testProperty "Version" (metaGetPut :: Version -> Bool) + , testProperty "Addr" (metaGetPut :: Addr -> Bool) + , testProperty "Alert" (metaGetPut :: Alert -> Bool) + , testProperty "TxIn" (metaGetPut :: TxIn -> Bool) + , testProperty "TxOut" (metaGetPut :: TxOut -> Bool) + , testProperty "OutPoint" (metaGetPut :: OutPoint -> Bool) + , testProperty "ScriptOp" (metaGetPut :: ScriptOp -> Bool) + , testProperty "Script" (metaGetPut :: Script -> Bool) + , testProperty "Tx" (metaGetPut :: Tx -> Bool) + , testProperty "CoinbaseTx" (metaGetPut :: CoinbaseTx -> Bool) + , testProperty "BlockHeader" (metaGetPut :: BlockHeader -> Bool) + , testProperty "Block" (metaGetPut :: Block -> Bool) + , testProperty "MerkleBlock" (metaGetPut :: MerkleBlock -> Bool) + , testProperty "GetBlocks" (metaGetPut :: GetBlocks -> Bool) + , testProperty "GetData" (metaGetPut :: GetData -> Bool) + , testProperty "GetHeaders" (metaGetPut :: GetHeaders -> Bool) + , testProperty "Headers" (metaGetPut :: Headers -> Bool) + , testProperty "FilterLoad" (metaGetPut :: FilterLoad -> Bool) + , testProperty "FilterAdd" (metaGetPut :: FilterAdd -> Bool) + , testProperty "NotFound" (metaGetPut :: NotFound -> Bool) + , testProperty "Ping" (metaGetPut :: Ping -> Bool) + , testProperty "Pong" (metaGetPut :: Pong -> Bool) + , testProperty "MessageCommand" (metaGetPut :: MessageCommand -> Bool) + , testProperty "MessageHeader" (metaGetPut :: MessageHeader -> Bool) + , testProperty "Message" (metaGetPut :: Message -> Bool) + ] + , testGroup "Transactions" + [ testProperty "decode . encode Txid" decEncTxid ] + ] + +metaGetPut :: (Binary a, Eq a) => a -> Bool +metaGetPut x = (runGet get (runPut $ put x)) == x + +decEncTxid :: Hash256 -> Bool +decEncTxid h = (fromJust $ decodeTxid $ encodeTxid h) == h + diff --git a/tests/Network/Haskoin/Protocol/Units.hs b/tests/Network/Haskoin/Protocol/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Protocol/Units.hs @@ -0,0 +1,44 @@ +module Network.Haskoin.Protocol.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe + +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Computing TxID from Tx" + ( map mapTxIDVec $ zip txIDVec [0..] ) + ] + +mapTxIDVec :: ((String,String),Int) -> Test.Framework.Test +mapTxIDVec (v,i) = testCase name $ runTxIDVec v + where + name = "Compute TxID " ++ (show i) + +runTxIDVec :: (String,String) -> Assertion +runTxIDVec (tid,tx) = assertBool "TxID" $ + (encodeTxid $ txid txBS) == tid + where + txBS = decode' $ fromJust $ hexToBS tx + +txIDVec :: [(String,String)] +txIDVec = + [ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63" + , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" + ) + , ( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73" + , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d00000000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac00000000" + ) + , ( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb" + , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332adfca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a4730440220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f81e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df32949d4646dfa10a92458cfaa88ac00000000" + ) + , ( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae" + , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c59da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbea097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf950650802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e18217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a3788dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9cfdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa34b26f62db4a88ac00000000" + ) + ] + diff --git a/tests/Network/Haskoin/Script/Arbitrary.hs b/tests/Network/Haskoin/Script/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Script/Arbitrary.hs @@ -0,0 +1,85 @@ +{-| + This module provides arbitrary instances for data types in + 'Network.Haskoin.Script'. +-} +module Network.Haskoin.Script.Arbitrary where + +import Test.QuickCheck + ( Gen + , Arbitrary + , arbitrary + , oneof + , choose + , vectorOf + , elements + ) +import Network.Haskoin.Crypto.Arbitrary() + +import Control.Monad (liftM2) +import Control.Applicative ((<$>),(<*>)) + +import Data.Bits (testBit, clearBit) +import Data.Word (Word8) + +import Network.Haskoin.Script +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto + +instance Arbitrary TxSignature where + arbitrary = liftM2 TxSignature arbitrary arbitrary + +instance Arbitrary SigHash where + arbitrary = do + w <- arbitrary :: Gen Word8 + let acp = testBit w 7 + return $ case clearBit w 7 of + 1 -> SigAll acp + 2 -> SigNone acp + 3 -> SigSingle acp + _ -> SigUnknown acp w + +instance Arbitrary ScriptOutput where + arbitrary = oneof + [ PayPK <$> arbitrary + , (PayPKHash . pubKeyAddr) <$> arbitrary + , genPayMulSig + , (PayScriptHash . scriptAddr) <$> arbitrary + ] + +-- | Generate an arbitrary 'ScriptOutput' of value PayMulSig. +genPayMulSig :: Gen ScriptOutput +genPayMulSig = do + n <- choose (1,16) + m <- choose (1,n) + PayMulSig <$> (vectorOf n arbitrary) <*> (return m) + +instance Arbitrary ScriptInput where + arbitrary = oneof + [ SpendPK <$> arbitrary + , SpendPKHash <$> arbitrary <*> arbitrary + , genSpendMulSig + ] + +-- | Generate an arbitrary 'ScriptInput' of value SpendMulSig. +genSpendMulSig :: Gen ScriptInput +genSpendMulSig = do + m <- choose (1,16) + s <- choose (1,m) + SpendMulSig <$> (vectorOf s arbitrary) <*> (return m) + +instance Arbitrary ScriptHashInput where + arbitrary = ScriptHashInput <$> arbitrary <*> arbitrary + +-- | Data type for generating an arbitrary 'ScriptOp' with a value in +-- [OP_1 .. OP_16] +data ScriptOpInt = ScriptOpInt ScriptOp + deriving (Eq, Show) + +instance Arbitrary ScriptOpInt where + arbitrary = ScriptOpInt <$> elements + [ OP_1, OP_2, OP_3, OP_4 + , OP_5, OP_6, OP_7, OP_8 + , OP_9, OP_10, OP_11, OP_12 + , OP_13, OP_14, OP_15, OP_16 + ] + diff --git a/tests/Network/Haskoin/Script/Tests.hs b/tests/Network/Haskoin/Script/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Script/Tests.hs @@ -0,0 +1,116 @@ +module Network.Haskoin.Script.Tests (tests) where + +import Test.QuickCheck.Property (Property, (==>)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Applicative ((<$>)) + +import Data.Bits (setBit, testBit) +import Data.Binary (Word8) +import qualified Data.ByteString as BS + ( singleton + , length + , tail + , head + , pack + ) + +import Network.Haskoin.Protocol.Arbitrary () +import Network.Haskoin.Script.Arbitrary (ScriptOpInt(..)) + +import Network.Haskoin.Script +import Network.Haskoin.Crypto +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Script Parser" + [ testProperty "decode . encode OP_1 .. OP_16" testScriptOpInt + , testProperty "decode . encode ScriptOutput" testScriptOutput + , testProperty "decode . encode ScriptInput" testScriptInput + , testProperty "decode . encode ScriptHashInput" testScriptHashInput + , testProperty "sorting MultiSig scripts" testSortMulSig + ] + , testGroup "Script SigHash" + [ testProperty "canonical signatures" testCanonicalSig + , testProperty "decode . encode SigHash" binSigHash + , testProperty "decode SigHash from Word8" binSigHashByte + , testProperty "encodeSigHash32 is 4 bytes long" testEncodeSH32 + , testProperty "decode . encode TxSignature" binTxSig + , testProperty "decodeCanonical . encode TxSignature" binTxSigCanonical + , testProperty "Testing txSigHash with SigSingle" testSigHashOne + ] + ] + +{- Script Parser -} + +testScriptOpInt :: ScriptOpInt -> Bool +testScriptOpInt (ScriptOpInt i) = (intToScriptOp <$> scriptOpToInt i) == Right i + +testScriptOutput :: ScriptOutput -> Bool +testScriptOutput so = (decodeOutput $ encodeOutput so) == Right so + +testScriptInput :: ScriptInput -> Bool +testScriptInput si = (decodeInput $ encodeInput si) == Right si + +testScriptHashInput :: ScriptHashInput -> Bool +testScriptHashInput sh = (decodeScriptHash $ encodeScriptHash sh) == Right sh + +testSortMulSig :: ScriptOutput -> Bool +testSortMulSig out = case out of + (PayMulSig _ _) -> check $ sortMulSig out + _ -> True + where check (PayMulSig ps _) + | length ps <= 1 = True + | otherwise = snd $ foldl f (head ps,True) $ tail ps + check _ = False + f (a,t) b | t && encode' a <= encode' b = (b,True) + | otherwise = (b,False) + +{- Script SigHash -} + +testCanonicalSig :: TxSignature -> Bool +testCanonicalSig ts@(TxSignature _ sh) + | isSigUnknown sh = isLeft $ decodeCanonicalSig bs + | otherwise = isRight (decodeCanonicalSig bs) && + isCanonicalHalfOrder (txSignature ts) + where bs = encodeSig ts + +binSigHash :: SigHash -> Bool +binSigHash sh = (decode' $ encode' sh) == sh + +binSigHashByte :: Word8 -> Bool +binSigHashByte w + | w == 0x01 = res == SigAll False + | w == 0x02 = res == SigNone False + | w == 0x03 = res == SigSingle False + | w == 0x81 = res == SigAll True + | w == 0x82 = res == SigNone True + | w == 0x83 = res == SigSingle True + | testBit w 7 = res == SigUnknown True w + | otherwise = res == SigUnknown False w + where res = decode' $ BS.singleton w + +testEncodeSH32 :: SigHash -> Bool +testEncodeSH32 sh = BS.length bs == 4 && BS.head bs == w && BS.tail bs == zs + where bs = encodeSigHash32 sh + w = BS.head $ encode' sh + zs = BS.pack [0,0,0] + +binTxSig :: TxSignature -> Bool +binTxSig ts = (fromRight $ decodeSig $ encodeSig ts) == ts + +binTxSigCanonical :: TxSignature -> Bool +binTxSigCanonical ts@(TxSignature _ sh) + | isSigUnknown sh = isLeft $ decodeCanonicalSig $ encodeSig ts + | otherwise = (fromRight $ decodeCanonicalSig $ encodeSig ts) == ts + +testSigHashOne :: Tx -> Script -> Bool -> Property +testSigHashOne tx s acp = not (null $ txIn tx) ==> + if length (txIn tx) > length (txOut tx) + then res == (setBit 0 248) + else res /= (setBit 0 248) + where res = txSigHash tx s (length (txIn tx) - 1) (SigSingle acp) + diff --git a/tests/Network/Haskoin/Script/Units.hs b/tests/Network/Haskoin/Script/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Script/Units.hs @@ -0,0 +1,100 @@ +module Network.Haskoin.Script.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe (fromJust) + +import Network.Haskoin.Script +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Canonical signatures" + (map canonicalVectorsMap $ zip canonicalVectors [0..]) + , testGroup "Non canonical sigatures" + (map notCanonicalVectorsMap $ zip notCanonicalVectors [0..]) + , testGroup "Multi Signatures" + (map mapMulSigVector $ zip mulSigVectors [0..]) + ] + +canonicalVectorsMap :: (String,Int) -> Test.Framework.Test +canonicalVectorsMap (_,i) = + testCase ("Canonical Sig " ++ (show i)) func + where + func = testCanonicalSig $ canonicalVectors !! i + +notCanonicalVectorsMap :: (String,Int) -> Test.Framework.Test +notCanonicalVectorsMap (_,i) = + testCase ("Not canonical Sig " ++ (show i)) func + where + func = testNotCanonicalSig $ notCanonicalVectors !! i + +testCanonicalSig :: String -> Assertion +testCanonicalSig str = + assertBool " > Canonical Sig" $ isRight $ decodeCanonicalSig bs + where + bs = fromJust $ hexToBS str + +testNotCanonicalSig :: String -> Assertion +testNotCanonicalSig str = + assertBool " > Not canonical sig" $ isLeft $ decodeCanonicalSig bs + where + bs = fromJust $ hexToBS str + +mapMulSigVector :: ((String,String),Int) -> Test.Framework.Test +mapMulSigVector (v,i) = + testCase name $ runMulSigVector v + where + name = "MultiSignature vector " ++ (show i) + +runMulSigVector :: (String,String) -> Assertion +runMulSigVector (a,ops) = + assertBool " > MultiSig Vector" $ a == b + where + s = Script $ runGet' getScriptOps $ fromJust $ hexToBS ops + b = addrToBase58 $ scriptAddr $ fromRight $ decodeOutput s + +{- Canonical Signatures -} + +-- Test vectors from bitcoind +-- http://github.com/bitcoin/bitcoin/blob/master/src/test/data/sig_canonical.json + +canonicalVectors :: [String] +canonicalVectors = + [ "300602010102010101" -- Changed 0x00 to 0x01 as 0x00 is invalid + , "3008020200ff020200ff01" + , "304402203932c892e2e550f3af8ee4ce9c215a87f9bb831dcac87b2838e2c2eaa891df0c022030b61dd36543125d56b9f9f3a1f9353189e5af33cdda8d77a5209aec03978fa001" + , "30450220076045be6f9eca28ff1ec606b833d0b87e70b2a630f5e3a496b110967a40f90a0221008fffd599910eefe00bc803c688c2eca1d2ba7f6b180620eaa03488e6585db6ba01" + , "3046022100876045be6f9eca28ff1ec606b833d0b87e70b2a630f5e3a496b110967a40f90a0221008fffd599910eefe00bc803c688c2eca1d2ba7f6b180620eaa03488e6585db6ba01" + ] + +notCanonicalVectors :: [String] +notCanonicalVectors = + [ "30050201ff020001" + , "30470221005990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba6105022200002d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed11" + , "314402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304502205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "301f01205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb101" + , "304502205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed0001" + , "304401205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "3024020002202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304402208990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "30450221005990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610502202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba610501202d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "302402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba6105020001" + , "304402205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba61050220fd5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + , "304502205990e0584b2b238e1dfaad8d6ed69ecc1a4a13ac85fc0b31d0df395eb1ba61050221002d5876262c288beb511d061691bf26777344b702b00f8fe28621fe4e566695ed01" + ] + +mulSigVectors :: [(String,String)] +mulSigVectors = + [ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC" + , "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccffef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f9974ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f322a1863d4621353ae" + ) + ] + diff --git a/tests/Network/Haskoin/Stratum/Units.hs b/tests/Network/Haskoin/Stratum/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Stratum/Units.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Haskoin.Stratum.Units (tests) where + +import Control.Monad (liftM) +import Data.Aeson (decode) +import Data.ByteString.Lazy.Char8 (pack) +import Network.Haskoin.Stratum.Message +import Test.Framework (Test, testGroup, buildTest) +import Test.Framework.Providers.HUnit (testCase) +import qualified Test.HUnit as HUnit + +tests :: [Test] +tests = + [ testFile "Decode JSON-RPC request" + isRequest "tests/data/requests.json" + , testFile "Decode JSON-RPC notification" + isNotif "tests/data/notifications.json" + , testFile "Decode JSON-RPC response" + isResponse "tests/data/responses.json" + , testFile "Decode JSON-RPC error" + isError "tests/data/errors.json" + , testFile "Decode invalid JSON-RPC" + isInvalid "tests/data/invalid.json" + ] + +testFile :: String -> (Maybe MessageValue -> Bool) -> String -> Test +testFile label f file = buildTest $ do + vectors <- liftM lines $ readFile file + let test = g vectors + return test + where + g vectors = testGroup label $ do + (vector, count) <- zip vectors [0..] + let msg = decode $ pack vector + lbl = label ++ " " ++ show (count :: Int) + return . testCase lbl . HUnit.assertBool (failure vector) $ f msg + failure vector = "Failed to decode: " ++ vector + +isRequest :: Maybe MessageValue -> Bool +isRequest (Just (MsgRequest (Request _ _ (Just _)))) = True +isRequest _ = False + +isNotif :: Maybe MessageValue -> Bool +isNotif (Just (MsgRequest (Request _ _ Nothing))) = True +isNotif _ = False + +isResponse :: Maybe MessageValue -> Bool +isResponse (Just (MsgResponse (Response (Right _) _))) = True +isResponse _ = False + +isError :: Maybe MessageValue -> Bool +isError (Just (MsgResponse (Response (Left _) _))) = True +isError _ = False + +isInvalid :: Maybe MessageValue -> Bool +isInvalid Nothing = True +isInvalid _ = False diff --git a/tests/Network/Haskoin/Transaction/Arbitrary.hs b/tests/Network/Haskoin/Transaction/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Transaction/Arbitrary.hs @@ -0,0 +1,162 @@ +{-| + Arbitrary instances for transaction package +-} +module Network.Haskoin.Transaction.Arbitrary +( genPubKeyC +, genMulSigInput +, genRegularInput +, genAddrOutput +, RegularTx(..) +, MSParam(..) +, PKHashSigTemplate(..) +, MulSigTemplate(..) +) where + +import Test.QuickCheck + ( Gen + , Arbitrary + , arbitrary + , vectorOf + , oneof + , choose + ) + +import Control.Monad (liftM) +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word64) +import Data.List (permutations, nubBy) + +import Network.Haskoin.Crypto.Arbitrary +import Network.Haskoin.Protocol.Arbitrary () +import Network.Haskoin.Script.Arbitrary () + +import Network.Haskoin.Transaction +import Network.Haskoin.Script +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +-- | Data type for generating arbitrary valid multisignature parameters (m of n) +data MSParam = MSParam Int Int deriving (Eq, Show) + +instance Arbitrary MSParam where + arbitrary = do + n <- choose (1,16) + m <- choose (1,n) + return $ MSParam m n + +-- | Data type for generating arbitrary transaction with inputs and outputs +-- consisting only of script hash or pub key hash scripts. +data RegularTx = RegularTx Tx deriving (Eq, Show) + +-- | Generate an arbitrary compressed public key. +genPubKeyC :: Gen PubKey +genPubKeyC = derivePubKey <$> genPrvKeyC + +-- | Generate an arbitrary script hash input spending a multisignature +-- pay to script hash. +genMulSigInput :: Gen ScriptHashInput +genMulSigInput = do + (MSParam m n) <- arbitrary + rdm <- PayMulSig <$> (vectorOf n genPubKeyC) <*> (return m) + inp <- SpendMulSig <$> (vectorOf m arbitrary) <*> (return m) + return $ ScriptHashInput inp rdm + +-- | Generate an arbitrary transaction input spending a public key hash or +-- script hash output. +genRegularInput :: Gen TxIn +genRegularInput = do + op <- arbitrary + sq <- arbitrary + sc <- oneof [ encodeScriptHash <$> genMulSigInput + , encodeInput <$> (SpendPKHash <$> arbitrary <*> genPubKeyC) + ] + return $ TxIn op sc sq + +-- | Generate an arbitrary output paying to a public key hash or script hash +-- address. +genAddrOutput :: Gen TxOut +genAddrOutput = do + v <- choose (1,2100000000000000) + sc <- oneof [ (PayPKHash . pubKeyAddr) <$> arbitrary + , (PayScriptHash . scriptAddr) <$> arbitrary + ] + return $ TxOut v $ encodeOutput sc + +instance Arbitrary RegularTx where + arbitrary = do + x <- choose (1,10) + y <- choose (1,10) + liftM RegularTx $ Tx <$> arbitrary + <*> (vectorOf x genRegularInput) + <*> (vectorOf y genAddrOutput) + <*> arbitrary + +instance Arbitrary Coin where + arbitrary = Coin <$> arbitrary <*> arbitrary <*> arbitrary + +data PKHashSigTemplate = PKHashSigTemplate Tx [SigInput] [PrvKey] + deriving (Eq, Show) + +data MulSigTemplate = MulSigTemplate Tx [SigInput] [PrvKey] + deriving (Eq, Show) + +-- Generates a private key that can sign a input using the OutPoint and SigInput +genPKHashData :: Gen (OutPoint, SigInput, PrvKey) +genPKHashData = do + op <- arbitrary + prv <- arbitrary + sh <- arbitrary + let pub = derivePubKey prv + script = encodeOutput $ PayPKHash $ pubKeyAddr pub + sigi = SigInput script op sh + return (op, sigi, prv) + +-- Generates private keys that can sign an input using the OutPoint and SigInput +genMSData :: Gen (OutPoint, SigInput, [PrvKey]) +genMSData = do + (MSParam m n) <- arbitrary + prv <- vectorOf n arbitrary + perm <- choose (0,n-1) + op <- arbitrary + sh <- arbitrary + let pub = map derivePubKey prv + rdm = PayMulSig pub m + script = encodeOutput $ PayScriptHash $ scriptAddr rdm + sigi = SigInputSH script op (encodeOutput rdm) sh + perPrv = permutations prv !! perm + return (op, sigi, take m perPrv) + +genPayTo :: Gen (String,Word64) +genPayTo = do + v <- choose (1,2100000000000000) + sc <- oneof [ PubKeyAddress <$> arbitrary + , ScriptAddress <$> arbitrary + ] + return (addrToBase58 sc, v) + +-- Generates data for signing a PKHash transaction +instance Arbitrary PKHashSigTemplate where + arbitrary = do + inC <- choose (0,5) + outC <- choose (0,10) + dat <- nubBy (\a b -> fst3 a == fst3 b) <$> vectorOf inC genPKHashData + perm <- choose (0,max 0 $ length dat - 1) + payTo <- vectorOf outC genPayTo + let tx = fromRight $ buildAddrTx (map fst3 dat) payTo + perI = permutations (map snd3 dat) !! perm + return $ PKHashSigTemplate tx perI (map lst3 dat) + +-- Generates data for signing a P2SH transactions +instance Arbitrary MulSigTemplate where + arbitrary = do + inC <- choose (0,5) + outC <- choose (0,10) + dat <- nubBy (\a b -> fst3 a == fst3 b) <$> vectorOf inC genMSData + perm <- choose (0,max 0 $ length dat - 1) + payTo <- vectorOf outC genPayTo + let tx = fromRight $ buildAddrTx (map fst3 dat) payTo + perI = permutations (map snd3 dat) !! perm + return $ MulSigTemplate tx perI (concat $ map lst3 dat) + diff --git a/tests/Network/Haskoin/Transaction/Tests.hs b/tests/Network/Haskoin/Transaction/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Transaction/Tests.hs @@ -0,0 +1,114 @@ +module Network.Haskoin.Transaction.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Word (Word64) +import qualified Data.ByteString as BS (length) + +import Network.Haskoin.Transaction.Arbitrary +import Network.Haskoin.Transaction.Builder +import Network.Haskoin.Protocol +import Network.Haskoin.Script +import Network.Haskoin.Crypto +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Building Transactions" + [ testProperty "building address tx" testBuildAddrTx + , testProperty "testing guessTxSize function" testGuessSize + , testProperty "testing chooseCoins function" testChooseCoins + , testProperty "testing chooseMSCoins function" testChooseMSCoins + ] + , testGroup "Signing Transactions" + [ testProperty "Sign and validate PKHash transactions" testSignTx + , testProperty "Sign and validate Multisig transactions" testSignMS + ] + ] + +{- Building Transactions -} + +testBuildAddrTx :: [OutPoint] -> Address -> Word64 -> Bool +testBuildAddrTx os a v + | v <= 2100000000000000 = isRight tx && case a of + x@(PubKeyAddress _) -> Right (PayPKHash x) == out + x@(ScriptAddress _) -> Right (PayScriptHash x) == out + | otherwise = isLeft tx + where tx = buildAddrTx os [(addrToBase58 a,v)] + out = decodeOutput $ scriptOutput $ txOut (fromRight tx) !! 0 + +testGuessSize :: RegularTx -> Bool +testGuessSize (RegularTx tx) = + -- We compute an upper bound but it should be close enough to the real size + -- We give 3 bytes of slack on every signature (1 on r and 2 on s) + guess >= len && guess - 3*delta <= len + where delta = pki + (sum $ map fst msi) + guess = guessTxSize pki msi pkout msout + len = BS.length $ encode' tx + rIns = map (decodeInput . scriptInput) $ txIn tx + mIns = map (decodeScriptHash . scriptInput) $ txIn tx + pki = length $ filter (isSpendPKHash . fromRight) $ + filter isRight rIns + msi = concat $ map (shData . fromRight) $ filter isRight mIns + shData (ScriptHashInput _ (PayMulSig keys r)) = [(r,length keys)] + shData _ = [] + out = map (fromRight . decodeOutput . scriptOutput) $ txOut tx + pkout = length $ filter isPayPKHash out + msout = length $ filter isPayScriptHash out + +testChooseCoins :: Word64 -> Word64 -> [Coin] -> Bool +testChooseCoins target kbfee xs = case chooseCoins target kbfee xs of + Right (chosen,change) -> + let outSum = sum $ map (outValue . coinTxOut) chosen + fee = getFee kbfee (length chosen) + in outSum == target + change + fee + Left _ -> + let fee = getFee kbfee (length xs) + in target == 0 || s < target || s < target + fee + where s = sum $ map (outValue . coinTxOut) xs + +testChooseMSCoins :: Word64 -> Word64 -> MSParam -> [Coin] -> Bool +testChooseMSCoins target kbfee (MSParam m n) xs = + case chooseMSCoins target kbfee (m,n) xs of + Right (chosen,change) -> + let outSum = sum $ map (outValue . coinTxOut) chosen + fee = getMSFee kbfee (m,n) (length chosen) + in outSum == target + change + fee + Left _ -> + let fee = getMSFee kbfee (m,n) (length xs) + in target == 0 || s < target + fee + where s = sum $ map (outValue . coinTxOut) xs + +{- Signing Transactions -} + +testSignTx :: PKHashSigTemplate -> Bool +testSignTx (PKHashSigTemplate tx sigi prv) + | null $ txIn tx = isBroken txSig && isBroken txSigP + | otherwise = (not $ verifyTx tx verData) + && isComplete txSig + && verifyTx (runBuild txSig) verData + && isPartial txSigP + && (not $ verifyTx (runBuild txSigP) verData) + && isComplete txSigC + && verifyTx (runBuild txSigC) verData + where txSig = detSignTx tx sigi prv + txSigP = detSignTx tx sigi (tail prv) + txSigC = detSignTx (runBuild txSigP) sigi [head prv] + verData = map (\(SigInput s o _) -> (s,o)) sigi + +testSignMS :: MulSigTemplate -> Bool +testSignMS (MulSigTemplate tx sigi prv) + | null $ txIn tx = isBroken txSig && isBroken txSigP + | otherwise = (not $ verifyTx tx verData) + && isComplete txSig + && verifyTx (runBuild txSig) verData + && isPartial txSigP + && (not $ verifyTx (runBuild txSigP) verData) + && isComplete txSigC + && verifyTx (runBuild txSigC) verData + where txSig = detSignTx tx sigi prv + txSigP = detSignTx tx sigi (tail prv) + txSigC = detSignTx (runBuild txSigP) sigi [head prv] + verData = map (\(SigInputSH s o _ _) -> (s,o)) sigi + diff --git a/tests/Network/Haskoin/Transaction/Units.hs b/tests/Network/Haskoin/Transaction/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Transaction/Units.hs @@ -0,0 +1,214 @@ +module Network.Haskoin.Transaction.Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Word (Word32, Word64) +import Data.Maybe (fromJust) +import Data.Binary.Get (getWord32le) +import qualified Data.ByteString as BS (reverse) + +import Network.Haskoin.Transaction.Builder +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Build PKHash Transaction (generated from bitcoind)" + ( map mapPKHashVec $ zip pkHashVec [0..] ) + , testGroup "Verify transaction (bitcoind /test/data/tx_valid.json)" + ( map mapVerifyVec $ zip verifyVec [0..] ) + ] + +mapPKHashVec :: (([(String,Word32)],[(String,Word64)],String),Int) + -> Test.Framework.Test +mapPKHashVec (v,i) = testCase name $ runPKHashVec v + where name = "Build PKHash Tx " ++ (show i) + +runPKHashVec :: ([(String,Word32)],[(String,Word64)],String) -> Assertion +runPKHashVec (xs,ys,res) = + assertBool "Build PKHash Tx" $ (bsToHex $ encode' tx) == res + where tx = fromRight $ buildAddrTx (map f xs) ys + f (tid,ix) = OutPoint (fromJust $ decodeTxid tid) ix + + +mapVerifyVec :: (([(String,String,String)],String),Int) + -> Test.Framework.Test +mapVerifyVec (v,i) = testCase name $ runVerifyVec v i + where name = "Verify Tx " ++ (show i) + +runVerifyVec :: ([(String,String,String)],String) -> Int -> Assertion +runVerifyVec (is,bsTx) i = + assertBool name $ verifyTx tx $ map f is + where name = " > Verify transaction " ++ (show i) + tx = decode' (fromJust $ hexToBS bsTx) + f (o1,o2,bsScript) = + let ops = runGet' getScriptOps (fromJust $ hexToBS bsScript) + op = OutPoint (decode' $ BS.reverse $ fromJust $ hexToBS o1) + (runGet' getWord32le $ fromJust $ hexToBS o2) + in (Script ops,op) + +-- These test vectors have been generated from bitcoind raw transaction api + +pkHashVec :: [([(String,Word32)],[(String,Word64)],String)] +pkHashVec = + [ + ( [("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",14)] + , [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",90000000)] + , "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac00000000" + ) + , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0) + , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647) + ] + , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1) + , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000) + ] + , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" + ) + , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0) + , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647) + ] + , [] + , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0000000000" + ) + , ( [] + , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1) + , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000) + ] + , "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" + ) + ] + +{- Test vectors from bitcoind -} +-- github.com/bitcoin/bitcoin/blob/master/src/test/data/tx_valid.json + +verifyVec :: [([(String,String,String)],String)] +verifyVec = + [ + -- It is of particular interest because it contains an invalidly-encoded signature which OpenSSL accepts + ( [ + ( "60a20bd93aa49ab4b28d514ec10b06e1829ce6818ec06cd3aabd013ebcdc4bb1" + , "00000000" + , "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af52ae" + ) + ] + , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" + ) + -- It has an arbitrary extra byte stuffed into the signature at pos length - 2 + , ( [ + ( "60a20bd93aa49ab4b28d514ec10b06e1829ce6818ec06cd3aabd013ebcdc4bb1" + , "00000000" + , "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af52ae" + ) + ] + , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba260000000004A0048304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2bab01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" + ) + -- it is of interest because it contains a 0-sequence as well as a signature of SIGHASH type 0 (which is not a real type) + , ( [ + ( "406b2b06bcd34d3c8733e6b79f7a394c8a431fbf4ff5ac705c93f4076bb77602" + , "00000000" + , "76a914dc44b1164188067c3a32d4780f5996fa14a4f2d988ac" + ) + ] + , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d00000000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac00000000" + ) + -- It caught a bug in the workaround for 23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63 in an overly simple implementation + , ( [ + ( "b464e85df2a238416f8bdae11d120add610380ea07f4ef19c5f9dfd472f96c3d" + , "00000000" + , "76a914bef80ecf3a44500fda1bc92176e442891662aed288ac" + ) + , ( "b7978cc96e59a8b13e0865d3f95657561a7f725be952438637475920bac9eb21" + , "01000000" + , "76a914bef80ecf3a44500fda1bc92176e442891662aed288ac" + ) + ] + , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332adfca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a4730440220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f81e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df32949d4646dfa10a92458cfaa88ac00000000" + ) + -- It results in signing the constant 1, instead of something generated based on the transaction, + -- when the input doing the signing has an index greater than the maximum output index + , ( [ + ( "0000000000000000000000000000000000000000000000000000000000000100" + , "00000000" + , "76a914e52b482f2faa8ecbf0db344f93c84ac908557f3388ac" + ) + , ( "0000000000000000000000000000000000000000000000000000000000000200" + , "00000000" + , "76a914751e76e8199196d454941c45d1b3a323f1433bd688ac" + ) + ] + , "01000000020002000000000000000000000000000000000000000000000000000000000000000000006a47304402200469f169b8091cd18a2770136be7411f079b3ac2b5c199885eb66a80aa3ed75002201fa89f3e6f80974e1b3474e70a0fbe907c766137ff231e4dd05a555d8544536701210279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798ffffffff0001000000000000000000000000000000000000000000000000000000000000000000006b483045022100c9cdd08798a28af9d1baf44a6c77bcc7e279f47dc487c8c899911bc48feaffcc0220503c5c50ae3998a733263c5c0f7061b483e2b56c4c41b456e7d2f5a78a74c077032102d5c25adb51b61339d2b05315791e21bbe80ea470a49db0135720983c905aace0ffffffff010000000000000000015100000000" + ) + -- A valid P2SH Transaction using the standard transaction type put forth in BIP 16 + , ( [ + ( "0000000000000000000000000000000000000000000000000000000000000100" + , "00000000" + , "a9148febbed40483661de6958d957412f82deed8e2f787" + ) + ] + , "01000000010001000000000000000000000000000000000000000000000000000000000000000000006e493046022100c66c9cdf4c43609586d15424c54707156e316d88b0a1534c9e6b0d4f311406310221009c0fe51dbc9c4ab7cc25d3fdbeccf6679fe6827f08edf2b4a9f16ee3eb0e438a0123210338e8034509af564c62644c07691942e0c056752008a173c89f60ab2a88ac2ebfacffffffff010000000000000000015100000000" + ) + -- MAX_MONEY output + , ( [ + ( "0000000000000000000000000000000000000000000000000000000000000100" + , "00000000" + , "a91432afac281462b822adbec5094b8d4d337dd5bd6a87" + ) + ] + , "01000000010001000000000000000000000000000000000000000000000000000000000000000000006e493046022100e1eadba00d9296c743cb6ecc703fd9ddc9b3cd12906176a226ae4c18d6b00796022100a71aef7d2874deff681ba6080f1b278bac7bb99c61b08a85f4311970ffe7f63f012321030c0588dc44d92bdcbf8e72093466766fdc265ead8db64517b0c542275b70fffbacffffffff010040075af0750700015100000000" + ) + -- MAX_MONEY output + 0 output + , ( [ + ( "0000000000000000000000000000000000000000000000000000000000000100" + , "00000000" + , "a914b558cbf4930954aa6a344363a15668d7477ae71687" + ) + ] + , "01000000010001000000000000000000000000000000000000000000000000000000000000000000006d483045022027deccc14aa6668e78a8c9da3484fbcd4f9dcc9bb7d1b85146314b21b9ae4d86022100d0b43dece8cfb07348de0ca8bc5b86276fa88f7f2138381128b7c36ab2e42264012321029bb13463ddd5d2cc05da6e84e37536cb9525703cfd8f43afdb414988987a92f6acffffffff020040075af075070001510000000000000000015100000000" + ) + -- Simple transaction with first input is signed with SIGHASH_ALL, second with SIGHASH_ANYONECANPAY + , ( [ + ( "0000000000000000000000000000000000000000000000000000000000000100" + , "00000000" + , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac" + ) + , ( "0000000000000000000000000000000000000000000000000000000000000200" + , "00000000" + , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac" + ) + ] + , "010000000200010000000000000000000000000000000000000000000000000000000000000000000049483045022100d180fd2eb9140aeb4210c9204d3f358766eb53842b2a9473db687fa24b12a3cc022079781799cd4f038b85135bbe49ec2b57f306b2bb17101b17f71f000fcab2b6fb01ffffffff0002000000000000000000000000000000000000000000000000000000000000000000004847304402205f7530653eea9b38699e476320ab135b74771e1c48b81a5d041e2ca84b9be7a802200ac8d1f40fb026674fe5a5edd3dea715c27baa9baca51ed45ea750ac9dc0a55e81ffffffff010100000000000000015100000000" + ) + -- Same as above, but we change the sequence number of the first input to check that SIGHASH_ANYONECANPAY is being followed + , ( [ + ( "0000000000000000000000000000000000000000000000000000000000000100" + , "00000000" + , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac" + ) + , ( "0000000000000000000000000000000000000000000000000000000000000200" + , "00000000" + , "21035e7f0d4d0841bcd56c39337ed086b1a633ee770c1ffdd94ac552a95ac2ce0efcac" + ) + ] + , "01000000020001000000000000000000000000000000000000000000000000000000000000000000004948304502203a0f5f0e1f2bdbcd04db3061d18f3af70e07f4f467cbc1b8116f267025f5360b022100c792b6e215afc5afc721a351ec413e714305cb749aae3d7fee76621313418df101010000000002000000000000000000000000000000000000000000000000000000000000000000004847304402205f7530653eea9b38699e476320ab135b74771e1c48b81a5d041e2ca84b9be7a802200ac8d1f40fb026674fe5a5edd3dea715c27baa9baca51ed45ea750ac9dc0a55e81ffffffff010100000000000000015100000000" + ) + -- several SIGHASH_SINGLE signatures + , ( [ + ( "63cfa5a09dc540bf63e53713b82d9ea3692ca97cd608c384f2aa88e51a0aac70" + , "00000000" + , "76a914dcf72c4fd02f5a987cf9b02f2fabfcac3341a87d88ac" + ) + , ( "04e8d0fcf3846c6734477b98f0f3d4badfb78f020ee097a0be5fe347645b817d" + , "01000000" + , "76a914dcf72c4fd02f5a987cf9b02f2fabfcac3341a87d88ac" + ) + , ( "ee1377aff5d0579909e11782e1d2f5f7b84d26537be7f5516dd4e43373091f3f" + , "01000000" + , "76a914dcf72c4fd02f5a987cf9b02f2fabfcac3341a87d88ac" + ) + ] + , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c59da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbea097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf950650802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e18217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a3788dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9cfdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa34b26f62db4a88ac00000000" + ) + ] + diff --git a/tests/Network/Haskoin/Util/Arbitrary.hs b/tests/Network/Haskoin/Util/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Util/Arbitrary.hs @@ -0,0 +1,43 @@ +{-| + QuickCheck Arbitrary instances for various utility data types +-} +module Network.Haskoin.Util.Arbitrary (nonEmptyBS) where + +import Test.QuickCheck + ( Arbitrary + , Gen + , arbitrary + , choose + , oneof + ) +import qualified Data.ByteString as BS + ( ByteString + , pack + , drop + , null + ) + +import Control.Applicative + +import Network.Haskoin.Util.BuildMonad (Build(..)) + +-- Arbitrary instance for strict ByteStrings +instance Arbitrary BS.ByteString where + arbitrary = do + bs <- BS.pack `fmap` arbitrary + n <- choose (0, 2) + return $ BS.drop n bs -- to give us some with non-0 offset + +-- | Generate non-empty strict ByteStrings +nonEmptyBS :: Gen BS.ByteString +nonEmptyBS = do + bs <- arbitrary + return $ if BS.null bs then BS.pack [0] else bs + +-- Arbitrary instance for the Build monad +instance Arbitrary a => Arbitrary (Build a) where + arbitrary = oneof [ Complete <$> arbitrary + , Partial <$> arbitrary + , return $ Broken "Arbitrary: Broken" + ] + diff --git a/tests/Network/Haskoin/Util/Tests.hs b/tests/Network/Haskoin/Util/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Util/Tests.hs @@ -0,0 +1,115 @@ +module Network.Haskoin.Util.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.List (permutations) +import Data.Maybe (fromJust, catMaybes) +import Data.Foldable (toList) +import qualified Data.Sequence as Seq (update, fromList) +import qualified Data.ByteString as BS (ByteString) + +import Network.Haskoin.Util +import Network.Haskoin.Util.Arbitrary() + +tests :: [Test] +tests = + [ testGroup "Utility functions" + [ testProperty "toStrict( toLazy(bs) ) = bs" fromToLazy + , testProperty "get( put(Integer) ) = Integer" getPutInteger + , testProperty "stringToBS( bsToString(s) ) = s" fromToString + , testProperty "decode'( encode'(s) ) = s" decEncBS + , testProperty "decodeOrFail'( encode'(s) ) = s" decEncFailBS + , testProperty "fromHex( toHex(bs) ) = bs" fromToHex + , testProperty "testing decodeEither" testFromDecode + , testProperty "compare updateIndex with Data.Sequence" testUpdateIndex + , testProperty "testing matchTemplate" testMatchTemplate + , testProperty + "testing matchTemplate with two lists" testMatchTemplateLen + , testProperty "Testing either helper functions" testEither + ] + , testGroup "Build Monad" + [ testProperty "Build monadic composition" testBuildCompose + , testProperty "Testing guardPartial" testGuardPartial + ] + ] + +{- Various utilities -} + +fromToLazy :: BS.ByteString -> Bool +fromToLazy bs = (toStrictBS $ toLazyBS bs) == bs + +fromToString :: BS.ByteString -> Bool +fromToString bs = (stringToBS $ bsToString bs) == bs + +decEncBS :: BS.ByteString -> Bool +decEncBS bs = (decode' $ encode' bs) == bs + +decEncFailBS :: BS.ByteString -> Bool +decEncFailBS bs = case (decodeOrFail' $ encode' bs) of + (Left _) -> False + (Right (_, _, res)) -> res == bs + +getPutInteger :: Integer -> Bool +getPutInteger i = (bsToInteger $ integerToBS p) == p + where + p = abs i + +fromToHex :: BS.ByteString -> Bool +fromToHex bs = (fromJust $ hexToBS $ bsToHex bs) == bs + +testFromDecode :: BS.ByteString -> Integer -> Integer -> Bool +testFromDecode bs def v = case decodeOrFail' bs of + (Left _) -> fromDecode bs def (*v) == def + (Right (_,_,res)) -> fromDecode bs def (*v) == res*v + +testUpdateIndex :: [Int] -> Int -> Int -> Bool +testUpdateIndex xs v i = + (updateIndex i xs $ const v) == (toList $ Seq.update i v s) + where + s = Seq.fromList xs + +testMatchTemplate :: [Int] -> Int -> Bool +testMatchTemplate as i = catMaybes res == bs + where + res = matchTemplate as bs (==) + idx = if length as == 0 then 0 else i `mod` length as + bs = (permutations as) !! idx + +testMatchTemplateLen :: [Int] -> [Int] -> Bool +testMatchTemplateLen as bs = length bs == length res + where + res = matchTemplate as bs (==) + +testEither :: Either String Int -> Bool +testEither e = case e of + (Right v) -> (isRight e) + && (not $ isLeft e) + && (fromRight e == v) + && (eitherToMaybe e == Just v) + (Left v) -> (isLeft e) + && (not $ isRight e) + && (fromLeft e == v) + && (eitherToMaybe e == Nothing) + +{- Build Monad -} + +testBuildCompose :: Build Int -> Build Int -> Bool +testBuildCompose ma mb + | isBroken ma || isBroken mb = isBroken res + | isPartial ma || isPartial mb = isPartial res + | otherwise = isComplete res + where + res = ma >>= (\a -> mb >>= (\b -> return $ a + b )) + +testGuardPartial :: Build Int -> Build Int -> Bool +testGuardPartial ma mb + | isBroken ma || isBroken mb = isBroken res + | otherwise = isPartial res + where + res = do + a <- ma + guardPartial False + b <- mb + return $ a + b + diff --git a/tests/data/errors.json b/tests/data/errors.json new file mode 100644 --- /dev/null +++ b/tests/data/errors.json @@ -0,0 +1,7 @@ +{"id": 3, "error": "unknown method:blockchain.foo"} +{"jsonrpc": "2.0", "error": {"code": -32601, "message": "Method not found"}, "id": "1"} +{"jsonrpc": "2.0", "error": {"code": -32700, "message": "Parse error"}, "id": null} +{"jsonrpc": "2.0", "error": {"code": -32600, "message": "Invalid Request"}, "id": null} +{"jsonrpc": "2.0", "error": {"code": -32700, "message": "Parse error"}, "id": null} +{"jsonrpc": "2.0", "error": {"code": -32600, "message": "Invalid Request"}, "id": null} +{"jsonrpc": "2.0", "error": {"code": -32601, "message": "Method not found"}, "id": "5"} diff --git a/tests/data/invalid.json b/tests/data/invalid.json new file mode 100644 --- /dev/null +++ b/tests/data/invalid.json @@ -0,0 +1,6 @@ +{"jsonrpc": "2.0", "method": "foobar, "params": "bar", "baz] +{"jsonrpc": "2.0", "method": 1, "params": "bar"} +{"jsonrpc": "2.0", "method" +[] +[1,2,3] +{"foo": "boo"} diff --git a/tests/data/notifications.json b/tests/data/notifications.json new file mode 100644 --- /dev/null +++ b/tests/data/notifications.json @@ -0,0 +1,7 @@ +{"method": "handleMessage", "params": ["user1", "we were just talking"], "id": null} +{"method": "handleMessage", "params": ["user3", "sorry, gotta go now, ttyl"], "id": null} +{"method": "userLeft", "params": ["user3"], "id": null} +{"jsonrpc": "2.0", "method": "update", "params": [1,2,3,4,5]} +{"jsonrpc": "2.0", "method": "foobar"} +{"jsonrpc": "2.0", "method": "notify_hello", "params": [7]} +{"jsonrpc": "2.0", "method": "notify_sum", "params": [1,2,4]} diff --git a/tests/data/requests.json b/tests/data/requests.json new file mode 100644 --- /dev/null +++ b/tests/data/requests.json @@ -0,0 +1,12 @@ +{ "method": "echo", "params": ["Hello JSON-RPC"], "id": 1} +{"method": "postMessage", "params": ["Hello all!"], "id": 99} +{"method": "postMessage", "params": ["I have a question:"], "id": 101} +{"jsonrpc": "2.0", "method": "subtract", "params": [42, 23], "id": 1} +{"jsonrpc": "2.0", "method": "subtract", "params": [23, 42], "id": 2} +{"jsonrpc": "2.0", "method": "subtract", "params": {"subtrahend": 23, "minuend": 42}, "id": 3} +{"jsonrpc": "2.0", "method": "subtract", "params": {"minuend": 42, "subtrahend": 23}, "id": 4} +{"jsonrpc": "2.0", "method": "foobar", "id": "1"} +{"jsonrpc": "2.0", "method": "sum", "params": [1,2,4], "id": "1"} +{"jsonrpc": "2.0", "method": "subtract", "params": [42,23], "id": "2"} +{"jsonrpc": "2.0", "method": "foo.get", "params": {"name": "myself"}, "id": "5"} +{"jsonrpc": "2.0", "method": "get_data", "id": "9"} diff --git a/tests/data/responses.json b/tests/data/responses.json new file mode 100644 --- /dev/null +++ b/tests/data/responses.json @@ -0,0 +1,10 @@ +{ "result": "Hello JSON-RPC", "error": null, "id": 1} +{"result": 1, "error": null, "id": 99} +{"result": 1, "error": null, "id": 101} +{"jsonrpc": "2.0", "result": 19, "id": 1} +{"jsonrpc": "2.0", "result": -19, "id": 2} +{"jsonrpc": "2.0", "result": 19, "id": 3} +{"jsonrpc": "2.0", "result": 19, "id": 4} +{"jsonrpc": "2.0", "result": 7, "id": "1"} +{"jsonrpc": "2.0", "result": 19, "id": "2"} +{"jsonrpc": "2.0", "result": ["hello", 5], "id": "9"}