easy-bitcoin (empty) → 0.0.0.2
raw patch · 20 files changed
+3477/−0 lines, 20 filesdep +aesondep +basedep +base16-bytestringsetup-changed
Dependencies added: aeson, base, base16-bytestring, binary, byteable, bytestring, cryptohash, deepseq, lens, postgresql-simple, safe, text
Files
- LICENSE +30/−0
- Network/EasyBitcoin.hs +265/−0
- Network/EasyBitcoin/Address.hs +100/−0
- Network/EasyBitcoin/BitcoinUnits.hs +73/−0
- Network/EasyBitcoin/Internal/Base58.hs +122/−0
- Network/EasyBitcoin/Internal/ByteString.hs +148/−0
- Network/EasyBitcoin/Internal/CurveConstants.hs +32/−0
- Network/EasyBitcoin/Internal/HashFunctions.hs +171/−0
- Network/EasyBitcoin/Internal/InstanciationHelpers.hs +52/−0
- Network/EasyBitcoin/Internal/Keys.hs +209/−0
- Network/EasyBitcoin/Internal/Script.hs +496/−0
- Network/EasyBitcoin/Internal/Signatures.hs +168/−0
- Network/EasyBitcoin/Internal/Transaction.hs +341/−0
- Network/EasyBitcoin/Internal/Words.hs +371/−0
- Network/EasyBitcoin/Keys.hs +328/−0
- Network/EasyBitcoin/NetworkParams.hs +49/−0
- Network/EasyBitcoin/Script.hs +168/−0
- Network/EasyBitcoin/Transaction.hs +294/−0
- Setup.hs +2/−0
- easy-bitcoin.cabal +58/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Alejandro D.P.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alejandro D.P. nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/EasyBitcoin.hs view
@@ -0,0 +1,265 @@+{-|+Module : EasyBitcoin+Description : Libray to parse and compose bitcoin transactions, keys, addresses and escrows. +Copyright : (c) Alejandro Durán Pallarés, 2015+License : BSD3+Maintainer : vwwv@correo.ugr.es+Stability : experimental+++EasyBitcoin is a simple haskell library providing types and class-instances for bitcoin related code; +it also include an small set of functions to handle addresses, transactions and escrows.++Some small examples can be found <https://github.com/vwwv/easy-bitcoin/tree/master/Examples here> .++-}++{-# LANGUAGE DataKinds, GADTs #-}+++module Network.EasyBitcoin( -- * Usage Example:+ -- $example ++ -- * Addresses:+ Address()+ , Addressable(..)+ , isPay2SH + , isPay2PKH+ , addressFromUncompressed+ ++ -- * Keys: + , Key()+ , Visibility(..)+ , derive+ , derivePublic+ , deriveHardened+ , deriveRoot+ , showAsCompressedSingletonKey+ , showAsUncompressedSingletonKey+ , serializeCompressedSingleton+ , serializeUncompressedSingleton+ , (===)+++ -- * Transactions:+ , Outpoint (..)+ , Txid()+ , txid+ , Tx ()+ , transaction+ , unsignedTransaction+ , txOutputs+ , txInputs++ -- * Escrows and Signatures:+ , RedeemScript(..)+ , ScriptSig()+ , SigHash(..)+ , TxSignature()+ , sigHashType+ , signTxAt+ , scriptSig+ , escrowSignatures+ , escrowSignaturesFor+ , simpleSignature + , checkInput+ , checkSignatureAt+ , createSignature+ , createSignatureAs++ , BTC()+ , btc+ , mBTC+ , satoshis+ , asBtc+ , asMbtc+ , asSatoshis+ , showAsBtc+ , showAsMbtc+ , showAsSatoshis++ -- * Network Parameters:+ , ProdNet+ , TestNet+ , BlockNetwork(..)+ , Params(..)+ ) where+++import Network.EasyBitcoin.Address ( Address+ , Addressable(..)+ , isPay2SH + , isPay2PKH+ , addressFromUncompressed+ )++import Network.EasyBitcoin.Script ( RedeemScript(..)+ )++import Network.EasyBitcoin.NetworkParams( ProdNet+ , TestNet+ , BlockNetwork(..)+ , Params(..)+ )++import Network.EasyBitcoin.Internal.Transaction+ ( Outpoint (..)+ , Txid+ , txid+ , Tx()+ , sigHashType+ )++import Network.EasyBitcoin.Transaction ( transaction+ , txOutputs+ , txInputs+ , unsignedTransaction+ , ScriptSig()+ , TxSignature()+ , signTxAt+ , scriptSig+ , escrowSignatures+ , escrowSignaturesFor+ , simpleSignature + , checkInput+ , checkSignatureAt+ , createSignature+ , createSignatureAs+ , SigHash(..)+ )++import Network.EasyBitcoin.Keys ( Key()+ , Visibility(..)+ , derive+ , derivePublic+ , deriveHardened+ , deriveRoot+ , (===)+ , showAsCompressedSingletonKey+ , showAsUncompressedSingletonKey+ , serializeCompressedSingleton+ , serializeUncompressedSingleton+ )++import Network.EasyBitcoin.BitcoinUnits( BTC()+ , btc+ , mBTC+ , satoshis+ , asBtc+ , asMbtc+ , asSatoshis+ , showAsBtc+ , showAsMbtc+ , showAsSatoshis+ )++{- $example++++ As a toy example, let's imagine the following scenario:+ + * On a blog, there's a donation address @mm8LjcoUYdPNKgWshGs7dueFu33aK56ckb@ (private key @__91vaDsoxZACAZeGM89Y7dBnbTB7wrvtBeEkMTpL2sCgEtHf4RBn__@). ++ * The blog is written by blogger A, who wrote __70%__ of the posts, and blogger B, who wrote the remaining __30%__.++ * They want split the donation proportionally to the number of posts they have written.++ * Blogger A has as personal address @__miHWju2dzq9RcUPESzYBgVWa3W3swTXtLo__@ .++ * Blogger B has as personal address @__mvsXpubWQSw2dK2L85iYFppnNjGm439aWK__@ .++ As this is an example, we won't use real bitcoin, but testnet bitcoin, also, we'll use Coinbase's+ public bitcoin client, Toshi, so we don't have to install anything in our computer:+++ @++ {-# LANGUAGE DataKinds, OverloadedStrings #-}++ import Network.EasyBitcoin+ import Control.Monad(forever)+ import Network.HTTP.Client(HttpException(StatusCodeException))+ import Network.Wreq(get,post,statusCode,responseBody)+ import Control.Exception(handleJust)+ import Control.Lens+ import Data.Aeson.Lens+ import Data.Aeson+ import Safe+ import Control.Applicative+ import Control.Monad+ import Control.Concurrent+++ ----------------------------------------------------------------------------------------------+ incoming = read "91vaDsoxZACAZeGM89Y7dBnbTB7wrvtBeEkMTpL2sCgEtHf4RBn" :: Key Private TestNet + outgoingA = read "miHWju2dzq9RcUPESzYBgVWa3W3swTXtLo" :: Address TestNet+ outgoingB = read "mvsXpubWQSw2dK2L85iYFppnNjGm439aWK" :: Address TestNet+ ----------------------------------------------------------------------------------------------+ fee = btc 0.0001 -- the miner fee to use.+ threshold = btc 0.2 -- won't send any transaction till reach this amount. This is important+ -- to avoid creating "dust" transactions.++ server = "https://testnet3.toshi.io/" -- The Coinbase Toshi client testnet url.+ secondsToPool = 20+ ----------------------------------------------------------------------------------------------++ -- General workflow:+ -- each 20 seconds:+ -- - read from Toshi all unspent outpoints.+ -- - if not enough funds holds on the unspent outpoints:+ -- continue next iteration.+ -- - else:+ -- combining all available outpoints into a transaction to miHWju2dzq9RcUPESzYBgVWa3W3swTXtLo and mvsXpubWQSw2dK2L85iYFppnNjGm439aWK+ -- send this transaction to Toshi to be broad-casted into the network.++ main::IO ()+ main = do putStrLn $ "Rebrodcasting from " ++ show (address incoming) ++ " to "++ show outgoingA ++ " and " ++ show outgoingB+ forever $ do readToshi >>= maybe (return ()) sendToshi . createTransaction + threadDelay (secondsToPool*1000000)++++ -- If not enough funds, returns Nothing, otherwise, returns the transaction to be sent.+ createTransaction :: [(Outpoint, BTC TestNet)] -> Maybe (Tx TestNet)+ createTransaction inputs = if amount > threshold then Just txToSend+ else Nothing+ where+ amount = sum (fmap snd inputs) - fee + amountToA = btc (asBtc amount * 0.7)+ amountToB = amount - amountToA+ + txToSend = transaction [ (outpoint,incoming) | (outpoint, _ ) <- inputs]+ (outgoingA,amountToA) [(outgoingB,amountToB)]+++ sendToshi :: Tx TestNet -> IO ()+ sendToshi tx = do putStrLn $ "Sending tx: " ++ show (txid tx)+ post (server ++ "/api/v0/transactions") (toJSON$show tx)+ return ()++ -- Querying and parsing the Toshi client about the unspent_outputs holds on the address defined by the private key + -- 91vaDsoxZACAZeGM89Y7dBnbTB7wrvtBeEkMTpL2sCgEtHf4RBn (that is mm8LjcoUYdPNKgWshGs7dueFu33aK56ckb).+ readToshi :: IO [(Outpoint, BTC TestNet)]+ readToshi = handleJust isNotFound (const$ return []) + + $ do body <- get $ server ++ "api/v0/addresses/"++ show (address incoming) ++ "/unspent_outputs" + return $ body ^.. responseBody . values . to parseOutpoint . _Just+ where+ -- Toshi returns 404 if the address has never received any tx+ isNotFound ex = case ex of + StatusCodeException s _ _+ | s ^. statusCode == 404 -> Just ()+ _ -> Nothing ++ parseOutpoint val = do vout <- (val ^? key "output_index" ._JSON)+ txid <- (val ^? key "transaction_hash" ._JSON. to readMay._Just)+ amount <- (val ^? key "amount" ._JSON. to satoshis)+ + Just (Outpoint txid vout, amount)+++ @++-}
+ Network/EasyBitcoin/Address.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Network.EasyBitcoin.Address + where+++import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.Base58 ( encodeBase58+ , decodeBase58+ , addRedundancy+ , liftRedundacy+ )++import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.InstanciationHelpers+import Network.EasyBitcoin.Internal.HashFunctions+import Network.EasyBitcoin.Internal.Keys (PrvKey(), PubKey(),Compressed(..))+import Network.EasyBitcoin.Keys+import Network.EasyBitcoin.NetworkParams+import qualified Data.ByteString as BS+import Data.Char(isSpace)+import Data.Word++-- | Bitcoin address, either Pay2PKH or Pay2SH+data Address net = PubKeyAddress { getAddrHash :: Word160 }+ | ScriptAddress { getAddrHash :: Word160 }+ deriving (Eq, Ord)++++-- | Values from where an address can be derived. Keys, are interpreted as compressed by default, if need to derive an address from+-- an uncompressed key, use 'addressFromUncompressed' instead.+class Addressable add where+ address :: (BlockNetwork net) => add net -> Address net ++-- | As addresses are obtained from public keys hashes, when deriving from a private key, it will first get derived to public +--+-- prop> address key = address (derivePublic key)+-- +-- Addresses derived from Keys will always be Pay2PKH addresses:+--+-- prop> isPay2PKH (address key) = True+instance Addressable (Key v) where+ address = PubKeyAddress . hash160 . hash256BS . encode' . Compressed True. pub_key . derivePublic+ ++-- | Derive an address from a key as uncompressed.+addressFromUncompressed:: Key v net -> Address net+addressFromUncompressed = PubKeyAddress . hash160 . hash256BS . encode' . Compressed False . pub_key . derivePublic++++-- | Address was derived from an script hash. Though these addresses can represent the hash of any script, only redeem+-- scripts for multi-signature are currently supported.+isPay2SH :: Address net -> Bool+isPay2SH addr = case addr of + PubKeyAddress _ -> True+ _ -> False++-- | Address was derived from a public key hash.+isPay2PKH :: Address net -> Bool+isPay2PKH addr = case addr of + ScriptAddress _ -> True+ _ -> False+---------------------------------------------------------------------------------------------------------------------------------+instance (BlockNetwork net ) => Show (Address net) where+ show = show_aux+ where+ show_aux :: forall net . (BlockNetwork net ) => Address net -> String+ show_aux addr = let params = (valuesOf :: Params net)+ in case addr of+ PubKeyAddress payload -> show_ (addrPrefix params) payload+ ScriptAddress payload -> show_ (scriptPrefix params) payload++ +instance (BlockNetwork net ) => Read (Address net) where+ readsPrec _ = read_aux+ where+ read_aux :: forall net . (BlockNetwork net ) => ReadS (Address net)+ read_aux str = let params = (valuesOf :: Params net)+ + in case readsPrec_ str of++ ( Just (prefix, payload), rest) + | addrPrefix params == prefix -> [(PubKeyAddress payload, rest)]+ | scriptPrefix params == prefix -> [(ScriptAddress payload, rest)]++ _ -> []+++----------------------------------------------------------------------------------------------------------------------------------++++++++++
+ Network/EasyBitcoin/BitcoinUnits.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.EasyBitcoin.BitcoinUnits + ( btc+ , mBTC+ , satoshis+ , asBtc+ , asMbtc+ , asSatoshis+ , showAsBtc+ , showAsMbtc+ , showAsSatoshis+ , BTC()+ )where+++import Network.EasyBitcoin.NetworkParams+import Network.EasyBitcoin.Internal.InstanciationHelpers+import Control.Arrow(first)+import Control.Applicative((<$>))+++-- | Bitcoins are represented internally as an integer value, but showed and read as a decimal values.+-- When importing them, extra significative digits will be silently dropped.++newtype BTC a = Satoshis Int deriving (Eq,Ord,Num)++btc :: Double -> BTC net+btc x = Satoshis $ round (x*100000000) ++mBTC :: Double -> BTC net+mBTC x = Satoshis $ round (x*100000) ++satoshis :: Int -> BTC net+satoshis = Satoshis ++asBtc :: BTC net -> Double+asBtc (Satoshis x) = fromIntegral x/100000000 ++asMbtc :: BTC net -> Double+asMbtc (Satoshis x) = fromIntegral x /100000 ++asSatoshis :: BTC net -> Int+asSatoshis (Satoshis x) = x +++showAsBtc :: BTC net -> String+showAsBtc (Satoshis x) = let str = reverse (show x) ++ replicate 9 '0'+ (smallers,biggers) = splitAt 8 str+ in if all (=='0') biggers+ then "0." ++ reverse smallers + else dropWhile (=='0') $ reverse biggers ++ "." ++ reverse smallers+++showAsMbtc :: BTC net -> String+showAsMbtc (Satoshis x) = let str = reverse (show x) ++ replicate 6 '0'+ (smallers,biggers) = splitAt 5 str+ in if all (=='0') biggers+ then "0." ++ reverse smallers + else dropWhile (=='0') $ reverse biggers ++ "." ++ reverse smallers++++showAsSatoshis :: BTC net -> String+showAsSatoshis = show.asSatoshis+++instance Show (BTC a) where+ show = showAsBtc++instance Read (BTC a) where+ readsPrec n str = first btc <$> (readsPrec n str:: [(Double,String)])++
+ Network/EasyBitcoin/Internal/Base58.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}++++module Network.EasyBitcoin.Internal.Base58 + ( encodeBase58+ , decodeBase58+ , addRedundancy+ , liftRedundacy+ )+ where++import qualified Data.ByteString as BS+import Data.Char (ord, chr)+import Data.Word (Word8)+import Data.Maybe (fromJust, isJust, listToMaybe)+import Numeric (showIntAtBase, readInt)+import Data.String (fromString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import Control.Applicative+import Data.Bits+import Data.List(unfoldr)++import Numeric (showIntAtBase, readInt)+import Network.EasyBitcoin.Internal.HashFunctions+import Network.EasyBitcoin.Internal.ByteString+++++-------------------------------------------------------------------------------+-----------------------------------------------------+++++addRedundancy :: BS.ByteString -> BS.ByteString +addRedundancy bs = BS.append bs (encode' $ chksum32 bs)+++liftRedundacy :: BS.ByteString -> Maybe BS.ByteString+liftRedundacy bs = let (original,extra) = BS.splitAt (BS.length bs - 4) bs ++ in if encode' (chksum32 original) == extra+ + then Just original+ else Nothing+++++encodeBase58::BS.ByteString -> String+encodeBase58 bs = l++r+ where + (z,b) = BS.span (== 0) bs+ l = replicate (BS.length z) '1' -- preserve leading 0's+ + r | BS.null b = ""+ | otherwise = encodeBase58I $ bsToInteger b++decodeBase58::String -> Maybe BS.ByteString+decodeBase58 str = r >>= return . (BS.append prefix)+ where+ (z,b) = span (== '1') $ str+ prefix = BS.replicate (length z) 0 -- preserve leading 1's++ r | null b = Just BS.empty+ | otherwise = integerToBS <$> decodeBase58I b+++---------------------------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------------++b58Data :: BS.ByteString+b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"+++b58 :: Word8 -> Word8+b58 i = BS.index b58Data (fromIntegral i)++b58' :: Word8 -> Maybe Word8+b58' w = fromIntegral <$> BS.elemIndex w b58Data+++encodeBase58I :: Integer -> String+encodeBase58I i = showIntAtBase (58 :: Integer) f (fromIntegral i) ""+ where+ f = chr . fromIntegral . b58 . fromIntegral++decodeBase58I :: String -> Maybe Integer+decodeBase58I s = case listToMaybe $ readInt 58 p f s of+ Just (r,[]) -> Just r+ _ -> Nothing+ where+ c = b58' . fromIntegral . ord+ p = isJust . c+ f = fromIntegral . fromJust . c+++------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------+++-- | Transforms a string into a strict bytestring+stringToBS :: String -> BS.ByteString+stringToBS = B8.pack++++-- | Transform a strict bytestring to a string+bsToString :: BS.ByteString -> String+bsToString = B8.unpack++++++++
+ Network/EasyBitcoin/Internal/ByteString.hs view
@@ -0,0 +1,148 @@+module Network.EasyBitcoin.Internal.ByteString+ where++import Data.Binary+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as C ( pack, unpack)+import Control.Monad (guard,(<=<))+import Control.Applicative+import Data.List (unfoldr)+import Data.Bits ((.|.), shiftL, shiftR)+import Data.Binary.Put (Put, runPut)+import qualified Data.ByteString.Lazy as BL+import Data.Binary.Get ( Get, runGetOrFail, getByteString, ByteOffset, runGet)+import Data.Binary.Get ( getWord64be+ , getWord32be+ , getWord64le+ , getWord8+ , getWord16le+ , getWord32le+ , getByteString+ , Get+ )+import Data.Binary.Put( putWord64be+ , putWord32be+ , putWord32le+ , putWord64le+ , putWord16le+ , putWord8+ , putByteString+ )++encode' :: Binary a => a -> BS.ByteString+encode' = toStrictBS . encode++++decode' :: Binary a => BS.ByteString -> a+decode' = decode . toLazyBS++-- ByteString helpers+-- | Transforms a lazy bytestring into a strict bytestring+toStrictBS :: BL.ByteString -> BS.ByteString+toStrictBS = BS.concat . BL.toChunks++++decodeToMaybe :: Binary a => BS.ByteString -> Maybe a+decodeToMaybe bs = case decodeOrFail $ toLazyBS bs of+ Left (lbs,o,err) -> Nothing+ Right (lbs,o,res) -> Just res+++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)++-- | 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++++bsToHex :: BS.ByteString -> String+bsToHex = C.unpack . B16.encode++hexToBS :: String -> Maybe BS.ByteString+hexToBS xs = guard (bad == BS.empty) >> return x+ where+ (x, bad) = B16.decode $ C.pack xs++++--bsToString :: BS.ByteString -> String+--bsToString = C.unpack+++-- | Strict version of @Data.Binary.runPut@+runPut' :: Put -> BS.ByteString+runPut' = toStrictBS . runPut+++++-- | 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"++++++-- | Strict version of @Data.Binary.runGet@+runGet' :: Binary a => Get a -> BS.ByteString -> a+runGet' m = runGet m . toLazyBS+++++++newtype VarInt = VarInt { getVarInt :: Int } deriving (Eq, Show, Read)++instance Binary VarInt where++ get = VarInt <$> ( getWord8 >>= go )+ where+ go 0xff = fromIntegral <$> getWord64le+ go 0xfe = fromIntegral <$> getWord32le+ go 0xfd = fromIntegral <$> getWord16le+ go x = fromIntegral <$> return x++ put (VarInt x)+ | x < 0xfd = putWord8 (fromIntegral x)+ | x <= 0xffff = putWord8 0xfd >> putWord16le (fromIntegral x)+ | x <= 0xffffffff = putWord8 0xfe >> putWord32le (fromIntegral x)+ | otherwise = putWord8 0xff >> putWord64le (fromIntegral x)++----------------------------------------------------------------------------------------------+-- | Transforms a strict bytestring into a lazy bytestring+toLazyBS :: BS.ByteString -> BL.ByteString+toLazyBS bs = BL.fromChunks [bs]++++++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)+
+ Network/EasyBitcoin/Internal/CurveConstants.hs view
@@ -0,0 +1,32 @@+module Network.EasyBitcoin.Internal.CurveConstants + 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+++++++++++
+ Network/EasyBitcoin/Internal/HashFunctions.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE PackageImports #-}+module Network.EasyBitcoin.Internal.HashFunctions + where+++import "cryptohash" Crypto.Hash ( Digest+ , SHA512+ , SHA256+ , SHA1+ , RIPEMD160+ , hash+ )++import "cryptohash" Crypto.MAC.HMAC (hmac)+import Data.Word (Word16, Word32)+import Data.Byteable (toBytes)+import Data.Binary (Binary, get)+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.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.ByteString+import Data.Word +import qualified Data.ByteString as BS+++++type CheckSum32 = Word32+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++++++hmac512 :: BS.ByteString -> BS.ByteString -> Word512+hmac512 key = decode' . (hmac512BS key)++hash160 :: BS.ByteString -> Word160+hash160 bs = runGet' get (run160 bs)++run160 :: BS.ByteString -> BS.ByteString+run160 = (toBytes :: Digest RIPEMD160 -> BS.ByteString) . hash++run256 :: BS.ByteString -> BS.ByteString+run256 = (toBytes :: Digest SHA256 -> BS.ByteString) . hash++run512 :: BS.ByteString -> BS.ByteString+run512 = (toBytes :: Digest SHA512 -> BS.ByteString) . hash+-- | Computes SHA-512 and returns the result as a bytestring.+hash512BS :: BS.ByteString -> BS.ByteString+hash512BS bs = run512 bs++-- | 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++++++doubleHash256 :: BS.ByteString -> Word256+doubleHash256 bs = runGet' get (run256 $ run256 bs)++++-- | Computes SHA-256 and returns the result as a bytestring.+hash256BS :: BS.ByteString -> BS.ByteString+hash256BS bs = run256 bs++++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++++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+++-- | 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++++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)+++chksum32 :: BS.ByteString -> CheckSum32+chksum32 bs = fromIntegral $ (doubleHash256 bs) `shiftR` 224++++++++++++++++++++++
+ Network/EasyBitcoin/Internal/InstanciationHelpers.hs view
@@ -0,0 +1,52 @@+module Network.EasyBitcoin.Internal.InstanciationHelpers + where++++import Network.EasyBitcoin.Internal.Base58 ( encodeBase58+ , decodeBase58+ , addRedundancy+ , liftRedundacy+ )++import Network.EasyBitcoin.Internal.ByteString+import Data.Binary++import qualified Data.ByteString as BS+import Data.Char(isSpace)+import Safe++readsPrec_ str = let (word , rest) = span (not.isSpace)$ dropWhile isSpace str++ in (decodeToMaybe =<< liftRedundacy =<< decodeBase58 word ,rest)++++show_ prefix = encodeBase58 . addRedundancy . BS.cons prefix . encode' ++++++showAsBinary::(Binary a) => a -> String+showAsBinary = bsToHex.encode'++readsPrecAsBinary :: (Binary a) => Int -> ReadS a+readsPrecAsBinary _ str = case readsPrec__ str of + ( Just result, rest) -> [(result,rest)]+ _ -> []+++ where+ readsPrec__ str = let (word , rest) = span (not.isSpace)$ dropWhile isSpace str+ in ( decodeToMaybe =<< hexToBS word ,rest)++++showAsBinary58::(Binary a) => a -> String+showAsBinary58 = encodeBase58 . addRedundancy . encode' ++readsPrecAsBinary58 :: (Binary a) => Int -> ReadS a+readsPrecAsBinary58 _ str = case readsPrec_ str of + ( Just result, rest) -> [(result,rest)]+ _ -> []
+ Network/EasyBitcoin/Internal/Keys.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-}+module Network.EasyBitcoin.Internal.Keys + where+++import Network.EasyBitcoin.Internal.Words(Word256,FieldN,FieldP,Word160)+import Network.EasyBitcoin.Internal.InstanciationHelpers+import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.CurveConstants+import Network.EasyBitcoin.Internal.HashFunctions+import Network.EasyBitcoin.NetworkParams+import Data.Binary+import Control.Applicative+import Control.Monad++newtype PrvKey net = PrvKey FieldN deriving (Eq, Ord,Num,Enum,Real,Integral) +data PubKey net = PubKey {pubKeyPoint::Point} deriving Eq++instance Binary (PubKey net) where+ get = fmap fromCompressed get+ put = put.Compressed True+++derivePubKey_ :: PrvKey net -> PubKey net+derivePubKey_ (PrvKey k) = PubKey $ mulPoint k curveG+++addPrvKeys_ :: PrvKey net -> Word256 -> PrvKey net +addPrvKeys_ key i = key + fromIntegral i++addPubKeys_ :: PubKey net -> Word256 -> PubKey net+addPubKeys_ (PubKey pub) i = PubKey $ addPoint pub $ mulPoint (fromIntegral i) curveG +++-- | Computes the key identifier of an extended private key.+xPrvID :: PrvKey net -> Word160+xPrvID = xPubID . derivePubKey_+-- | Computes the key identifier of an extended public key.+xPubID :: PubKey net -> Word160+xPubID = hash160 . hash256BS . encode' . Compressed True+++------------------------------------------------------------------------------------------------------------------+data Compressed key = Compressed{ isCompressed :: Bool+ , fromCompressed :: key+ } +++instance Show (Compressed (PubKey net)) where+ show = showAsBinary++instance Read (Compressed (PubKey net)) where+ readsPrec = readsPrecAsBinary++instance (BlockNetwork net) => Show (Compressed (PrvKey net)) where+ show = showAsBinary58++instance (BlockNetwork net) => Read (Compressed (PrvKey net)) where+ readsPrec = readsPrecAsBinary58++instance Binary (Compressed (PubKey net)) where++ get = do index <- getWord8+ case index of + 2 -> Compressed True . PubKey <$> (compressedWith True =<< get)+ 3 -> Compressed True . PubKey <$> (compressedWith False =<< get) + 4 -> Compressed False . PubKey <$> (makePoint <$> get <*> get)+ _ -> fail $ "Get: Invalid public key encoding: " ++ where+ compressedWith isEven x = let a = x ^ (3 :: Integer) + (curveA * x) + curveB+ ys = filter ((== isEven) . even) (quadraticResidue a)+ + in case ys of+ y:_ -> return $ makePoint x y + _ -> fail $ "No ECC point for x = " ++ (show x)++ put (Compressed comp (PubKey point)) = let (x,y) = getAffine point + in case comp of+ True + | even y -> putWord8 2 >> put x+ | otherwise -> putWord8 3 >> put x+ False -> putWord8 4 >> put x >> put y+++quadraticResidue :: FieldP -> [FieldP]+quadraticResidue x = guard (y^(2 :: Int) == x) >> [y, (-y)]+ where+ q = (curveP + 1) `div` 4+ y = x^q+++++++++instance (BlockNetwork net) => Binary (Compressed (PrvKey net)) where+ get = get_+ where+ get_ :: forall x. (BlockNetwork x) => Get (Compressed (PrvKey x))+ get_ = let params = valuesOf:: Params x+ in getPriv (wifFormat params)+ + put = put_+ where+ put_ :: forall x. (BlockNetwork x) => Compressed (PrvKey x) -> Put+ put_ = let params = valuesOf:: Params x+ in putPriv (wifFormat params)++---- wifFormatMainNet+---- wifFormatTestNet3++getPriv prefix = do mark <- getWord8+ payload <- fromIntegral <$> (get::Get Word256)+ compressed <- (getWord8 >>= (guard.(==0x01)) >> return True ) <|> (return False)+ guard (mark == prefix)++ return (Compressed compressed$PrvKey payload)++putPriv prefix (Compressed c (PrvKey k)) = case c of + True -> putWord8 prefix >> put (fromIntegral k::Word256) >> putWord8 0x01+ False -> putWord8 prefix >> put (fromIntegral k::Word256)+++--------------------------------------------------------------------------------------------------------------------++data Point = Point !FieldP !FieldP !FieldP deriving(Show) -- add extra field for performance++--Use the jacobian in the correct way...¿memoization of the right values for faster comparison?+-- this equal instance is wrong...+instance Eq Point where+ (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)+++getAffine :: Point -> (FieldP, FieldP)+getAffine (Point x y z) = (x/z ^ (2 :: Int), y/z ^ (3 :: Int))+++++++-- ¿create here the Q point?+++-- Elliptic curve point addition+addPoint :: Point -> Point -> Point+addPoint p1@(Point x1 y1 z1) (Point x2 y2 z2) = 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+doublePoint :: Point -> Point+doublePoint (Point x y z) = 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+++mulPoint :: FieldN -> Point -> Point+mulPoint 0 p = error "please change this!!"-- p -- this is not correct...+mulPoint 1 p = p+mulPoint n p | odd n = addPoint p (mulPoint (n-1) p)+ | otherwise = mulPoint (n `div` 2) (doublePoint p)++++++++-------------------------------------------------------------------------------------+-------------------------------------------------------------------------------------+-- change the name+curveG :: Point+curveG = makePoint (fromInteger $ fst pairG)+ (fromInteger $ snd pairG)+++curveA :: FieldP+curveA = fromInteger integerA++curveB :: FieldP+curveB = fromInteger integerB++----------------------------------------------------------------------------------------+----------------------------------------------------------------------------------------++makePoint :: FieldP -> FieldP -> Point +makePoint x y = Point x y 1
+ Network/EasyBitcoin/Internal/Script.hs view
@@ -0,0 +1,496 @@+module Network.EasyBitcoin.Internal.Script + where++++import Data.Word+import qualified Data.ByteString as BS+import Data.List (nub) -- not to use nub!! TODO+++import Data.Binary (Binary, get, put)+import Data.Binary.Get ( getWord64be+ , getWord32be+ , getWord8+ , getWord16le+ , getWord32le+ , getByteString+ , Get+ , isEmpty + )+import Data.Binary.Put( putWord64be+ , putWord32be+ , putWord32le+ , putWord16le+ , putWord8+ , putByteString+ )+import Control.Monad (unless, guard,replicateM,forM_,liftM2)+import Control.Applicative((<$>))++++newtype Script = Script{scriptOps::[ScriptOp]} + deriving (Eq, Show, Ord,Read)+++-- | Data type representing all of the operators allowed inside a 'Script'.+data ScriptOp = OP_PUSHDATA { pushContent :: !BS.ByteString+ , pushOpCode :: !PushDataType+ }+ -- OP__ 0+ + | OP_1NEGATE+ | OP_RESERVED+ | OP__ Word8 -- from 0 to 16 inclusive+ + -- ^ Flow control+ | OP_NOP+ | OP_VER -- reserved+ | OP_IF+ | OP_NOTIF+ | OP_VERIF -- resreved+ | OP_VERNOTIF -- reserved+ | OP_ELSE+ | OP_ENDIF+ | OP_VERIFY+ | OP_RETURN+ + -- ^Stack operations+ | OP_TOALTSTACK+ | OP_FROMALTSTACK+ | OP_IFDUP+ | OP_DEPTH+ | OP_DROP+ | OP_DUP+ | OP_NIP+ | OP_OVER+ | OP_PICK+ | OP_ROLL+ | OP_ROT+ | OP_SWAP+ | OP_TUCK+ | OP_2DROP+ | OP_2DUP+ | OP_3DUP+ | OP_2OVER+ | OP_2ROT+ | OP_2SWAP+ + -- ^ Splice+ | OP_CAT+ | OP_SUBSTR+ | OP_LEFT+ | OP_RIGHT+ | OP_SIZE+ + -- ^ Bitwise logic+ | OP_INVERT+ | OP_AND+ | OP_OR+ | OP_XOR+ | OP_EQUAL+ | OP_EQUALVERIFY+ | OP_RESERVED1+ | OP_RESERVED2+ + -- ^ Arithmetic+ | OP_1ADD+ | OP_1SUB+ | OP_2MUL+ | OP_2DIV+ | OP_NEGATE+ | OP_ABS+ | OP_NOT+ | OP_0NOTEQUAL+ | OP_ADD+ | OP_SUB+ | OP_MUL+ | OP_DIV+ | OP_MOD+ | OP_LSHIFT+ | OP_RSHIFT+ | OP_BOOLAND+ | OP_BOOLOR+ | OP_NUMEQUAL+ | OP_NUMEQUALVERIFY+ | OP_NUMNOTEQUAL+ | OP_LESSTHAN+ | OP_GREATERTHAN+ | OP_LESSTHANOREQUAL+ | OP_GREATERTHANOREQUAL+ | OP_MIN+ | OP_MAX+ | OP_WITHIN+ + -- ^ Crypto+ | OP_RIPEMD160+ | OP_SHA1+ | OP_SHA256+ | OP_HASH160+ | OP_HASH256+ | OP_CODESEPARATOR+ | OP_CHECKSIG+ | OP_CHECKSIGVERIFY+ | OP_CHECKMULTISIG+ | OP_CHECKMULTISIGVERIFY+ + -- ^ Expansion+ | OP_NOP1 | OP_NOP2 | OP_NOP3 | OP_NOP4 | OP_NOP5+ | OP_NOP6 | OP_NOP7 | OP_NOP8 | OP_NOP9 | OP_NOP10+ + -- ^ Other+ | OP_PUBKEYHASH+ | OP_PUBKEY+ | OP_INVALIDOPCODE !Word8 + deriving (Show, Read, Ord,Eq)++++-- | Data type representing the type of an OP_PUSHDATA opcode.+data PushDataType = OPCODE -- ^ The next opcode bytes is data to be pushed onto the stack++ -- | 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, Ord,Read, Eq)++++++----------------------------------------------------------------------------------------------------------+----------------------------------------------------------------------------------------------------------++op:: Int -> ScriptOp+op n = let n_ = min 16 (max 0 n) + in OP__ (fromIntegral n) ++++opPushData :: BS.ByteString -> ScriptOp+opPushData bs = case BS.length bs of + len | 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"+++++opNumber :: ScriptOp -> Maybe Int+opNumber (OP__ n) = Just (fromIntegral n)+opNumber _ = Nothing ++opContent :: ScriptOp -> Maybe BS.ByteString+opContent (OP_PUSHDATA content _) = Just content+opContent _ = Nothing +++---------------------------------------------------------------------------------------------------++instance Binary Script where+ + get = Script <$> getScriptOps+ where + getScriptOps = do empty <- isEmpty+ if empty+ then return []+ else liftM2 (:) get getScriptOps+ + put (Script ops) = forM_ ops put+++++instance Binary ScriptOp where+ get = do op <- getWord8+ case op of+ 0x00 -> return $ OP__ 0++ _ | op <= 0x4b -> do payload <- getByteString (fromIntegral op)+ return $ OP_PUSHDATA payload OPCODE+ + 0x4c -> do len <- getWord8+ payload <- getByteString (fromIntegral len)+ return $ OP_PUSHDATA payload OPDATA1+ + 0x4d -> do len <- getWord16le+ payload <- getByteString (fromIntegral len)+ return $ OP_PUSHDATA payload OPDATA2+ + 0x4e -> do len <- getWord32le+ payload <- getByteString (fromIntegral len)+ return $ OP_PUSHDATA payload OPDATA4+++ 0x4f -> return $ OP_1NEGATE+ 0x50 -> return $ OP_RESERVED+ _ | op < 0x61 -> return $ OP__ (op - 0x50)+ -- Flow control+ 0x61 -> return $ OP_NOP+ 0x62 -> return $ OP_VER -- reserved+ 0x63 -> return $ OP_IF+ 0x64 -> return $ OP_NOTIF+ 0x65 -> return $ OP_VERIF -- reserved+ 0x66 -> return $ OP_VERNOTIF -- reserved+ 0x67 -> return $ OP_ELSE+ 0x68 -> return $ OP_ENDIF+ 0x69 -> return $ OP_VERIFY+ 0x6a -> return $ OP_RETURN+ -- Stack+ 0x6b -> return $ OP_TOALTSTACK+ 0x6c -> return $ OP_FROMALTSTACK+ 0x6d -> return $ OP_2DROP+ 0x6e -> return $ OP_2DUP+ 0x6f -> return $ OP_3DUP+ 0x70 -> return $ OP_2OVER+ 0x71 -> return $ OP_2ROT+ 0x72 -> return $ OP_2SWAP+ 0x73 -> return $ OP_IFDUP+ 0x74 -> return $ OP_DEPTH+ 0x75 -> return $ OP_DROP+ 0x76 -> return $ OP_DUP+ 0x77 -> return $ OP_NIP+ 0x78 -> return $ OP_OVER+ 0x79 -> return $ OP_PICK+ 0x7a -> return $ OP_ROLL+ 0x7b -> return $ OP_ROT+ 0x7c -> return $ OP_SWAP+ 0x7d -> return $ OP_TUCK+ -- Splice+ 0x7e -> return $ OP_CAT+ 0x7f -> return $ OP_SUBSTR+ 0x80 -> return $ OP_LEFT+ 0x81 -> return $ OP_RIGHT+ 0x82 -> return $ OP_SIZE+ -- Bitwise logic+ 0x83 -> return $ OP_INVERT+ 0x84 -> return $ OP_AND+ 0x85 -> return $ OP_OR+ 0x86 -> return $ OP_XOR+ 0x87 -> return $ OP_EQUAL+ 0x88 -> return $ OP_EQUALVERIFY+ 0x89 -> return $ OP_RESERVED1+ 0x8a -> return $ OP_RESERVED2+ -- Arithmetic+ 0x8b -> return $ OP_1ADD+ 0x8c -> return $ OP_1SUB+ 0x8d -> return $ OP_2MUL+ 0x8e -> return $ OP_2DIV+ 0x8f -> return $ OP_NEGATE+ 0x90 -> return $ OP_ABS+ 0x91 -> return $ OP_NOT+ 0x92 -> return $ OP_0NOTEQUAL+ 0x93 -> return $ OP_ADD+ 0x94 -> return $ OP_SUB+ 0x95 -> return $ OP_MUL+ 0x96 -> return $ OP_DIV+ 0x97 -> return $ OP_MOD+ 0x98 -> return $ OP_LSHIFT+ 0x99 -> return $ OP_RSHIFT+ 0x9a -> return $ OP_BOOLAND+ 0x9b -> return $ OP_BOOLOR+ 0x9c -> return $ OP_NUMEQUAL+ 0x9d -> return $ OP_NUMEQUALVERIFY+ 0x9e -> return $ OP_NUMNOTEQUAL+ 0x9f -> return $ OP_LESSTHAN+ 0xa0 -> return $ OP_GREATERTHAN+ 0xa1 -> return $ OP_LESSTHANOREQUAL+ 0xa2 -> return $ OP_GREATERTHANOREQUAL+ 0xa3 -> return $ OP_MIN+ 0xa4 -> return $ OP_MAX+ 0xa5 -> return $ OP_WITHIN+ -- Crypto+ 0xa6 -> return $ OP_RIPEMD160+ 0xa7 -> return $ OP_SHA1+ 0xa8 -> return $ OP_SHA256+ 0xa9 -> return $ OP_HASH160+ 0xaa -> return $ OP_HASH256+ 0xab -> return $ OP_CODESEPARATOR+ 0xac -> return $ OP_CHECKSIG+ 0xad -> return $ OP_CHECKSIGVERIFY+ 0xae -> return $ OP_CHECKMULTISIG+ 0xaf -> return $ OP_CHECKMULTISIGVERIFY+ -- More NOPs+ 0xb0 -> return $ OP_NOP1+ 0xb1 -> return $ OP_NOP2+ 0xb2 -> return $ OP_NOP3+ 0xb3 -> return $ OP_NOP4+ 0xb4 -> return $ OP_NOP5+ 0xb5 -> return $ OP_NOP6+ 0xb6 -> return $ OP_NOP7+ 0xb7 -> return $ OP_NOP8+ 0xb8 -> return $ OP_NOP9+ 0xb9 -> return $ OP_NOP10+ -- Constants+ 0xfd -> return $ OP_PUBKEYHASH+ 0xfe -> return $ OP_PUBKEY+ _ -> return $ OP_INVALIDOPCODE op++ put op = case op of+ (OP_PUSHDATA payload optype)-> do let len = BS.length payload+ case optype of+ OPCODE -> do unless (len <= 0x4b) $ fail "OP_PUSHDATA OPCODE: Payload size too big"+ putWord8 $ fromIntegral len+ + OPDATA1 -> do unless (len <= 0xff) $ fail "OP_PUSHDATA OPDATA1: Payload size too big"+ putWord8 0x4c+ putWord8 $ fromIntegral len+ + OPDATA2 -> do unless (len <= 0xffff) $ fail "OP_PUSHDATA OPDATA2: Payload size too big"+ putWord8 0x4d+ putWord16le $ fromIntegral len+ + OPDATA4 -> do unless (len <= 0x7fffffff) $ fail "OP_PUSHDATA OPDATA4: Payload size too big"+ putWord8 0x4e+ putWord32le $ fromIntegral len+ putByteString payload+ -- Constants+ OP__ 0 -> putWord8 0x00+ OP_1NEGATE -> putWord8 0x4f+ OP_RESERVED -> putWord8 0x50+ OP__ n -> putWord8 (0x50+n) -- n should be between 1 and 16 inclusive+ -- Crypto Constants+ OP_PUBKEY -> putWord8 0xfe+ OP_PUBKEYHASH -> putWord8 0xfd+ -- Invalid Opcodes+ (OP_INVALIDOPCODE x) -> putWord8 x+ -- Flow Control+ OP_NOP -> putWord8 0x61+ OP_VER -> putWord8 0x62+ OP_IF -> putWord8 0x63+ OP_NOTIF -> putWord8 0x64+ OP_VERIF -> putWord8 0x65+ OP_VERNOTIF -> putWord8 0x66+ OP_ELSE -> putWord8 0x67+ OP_ENDIF -> putWord8 0x68+ OP_VERIFY -> putWord8 0x69+ OP_RETURN -> putWord8 0x6a+ -- Stack Operations+ OP_TOALTSTACK -> putWord8 0x6b+ OP_FROMALTSTACK -> putWord8 0x6c+ OP_2DROP -> putWord8 0x6d+ OP_2DUP -> putWord8 0x6e+ OP_3DUP -> putWord8 0x6f+ OP_2OVER -> putWord8 0x70+ OP_2ROT -> putWord8 0x71+ OP_2SWAP -> putWord8 0x72+ OP_IFDUP -> putWord8 0x73+ OP_DEPTH -> putWord8 0x74+ OP_DROP -> putWord8 0x75+ OP_DUP -> putWord8 0x76+ OP_NIP -> putWord8 0x77+ OP_OVER -> putWord8 0x78+ OP_PICK -> putWord8 0x79+ OP_ROLL -> putWord8 0x7a+ OP_ROT -> putWord8 0x7b+ OP_SWAP -> putWord8 0x7c+ OP_TUCK -> putWord8 0x7d+ -- Splice+ OP_CAT -> putWord8 0x7e+ OP_SUBSTR -> putWord8 0x7f+ OP_LEFT -> putWord8 0x80+ OP_RIGHT -> putWord8 0x81+ OP_SIZE -> putWord8 0x82+ -- Bitwise Logic+ OP_INVERT -> putWord8 0x83+ OP_AND -> putWord8 0x84+ OP_OR -> putWord8 0x85+ OP_XOR -> putWord8 0x86+ OP_EQUAL -> putWord8 0x87+ OP_EQUALVERIFY -> putWord8 0x88+ OP_RESERVED1 -> putWord8 0x89+ OP_RESERVED2 -> putWord8 0x8a+ -- Arithmetic+ OP_1ADD -> putWord8 0x8b+ OP_1SUB -> putWord8 0x8c+ OP_2MUL -> putWord8 0x8d+ OP_2DIV -> putWord8 0x8e+ OP_NEGATE -> putWord8 0x8f+ OP_ABS -> putWord8 0x90+ OP_NOT -> putWord8 0x91+ OP_0NOTEQUAL -> putWord8 0x92+ OP_ADD -> putWord8 0x93+ OP_SUB -> putWord8 0x94+ OP_MUL -> putWord8 0x95+ OP_DIV -> putWord8 0x96+ OP_MOD -> putWord8 0x97+ OP_LSHIFT -> putWord8 0x98+ OP_RSHIFT -> putWord8 0x99+ OP_BOOLAND -> putWord8 0x9a+ OP_BOOLOR -> putWord8 0x9b+ OP_NUMEQUAL -> putWord8 0x9c+ OP_NUMEQUALVERIFY -> putWord8 0x9d+ OP_NUMNOTEQUAL -> putWord8 0x9e+ OP_LESSTHAN -> putWord8 0x9f+ OP_GREATERTHAN -> putWord8 0xa0+ OP_LESSTHANOREQUAL -> putWord8 0xa1+ OP_GREATERTHANOREQUAL-> putWord8 0xa2+ OP_MIN -> putWord8 0xa3+ OP_MAX -> putWord8 0xa4+ OP_WITHIN -> putWord8 0xa5+ -- Crypto+ OP_RIPEMD160 -> putWord8 0xa6+ OP_SHA1 -> putWord8 0xa7+ OP_SHA256 -> putWord8 0xa8+ OP_HASH160 -> putWord8 0xa9+ OP_HASH256 -> putWord8 0xaa+ OP_CODESEPARATOR -> putWord8 0xab+ OP_CHECKSIG -> putWord8 0xac+ OP_CHECKSIGVERIFY -> putWord8 0xad+ OP_CHECKMULTISIG -> putWord8 0xae+ OP_CHECKMULTISIGVERIFY -> putWord8 0xaf+ -- More NOPs+ OP_NOP1 -> putWord8 0xb0+ OP_NOP2 -> putWord8 0xb1+ OP_NOP3 -> putWord8 0xb2+ OP_NOP4 -> putWord8 0xb3+ OP_NOP5 -> putWord8 0xb4+ OP_NOP6 -> putWord8 0xb5+ OP_NOP7 -> putWord8 0xb6+ OP_NOP8 -> putWord8 0xb7+ OP_NOP9 -> putWord8 0xb8+ OP_NOP10 -> putWord8 0xb9++++++++++++++++++++++++++++++++++
+ Network/EasyBitcoin/Internal/Signatures.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DataKinds,GADTs #-}+module Network.EasyBitcoin.Internal.Signatures + ( detSignMsg+ , Signature()+ , checkSig+ )where+++import Network.EasyBitcoin.Keys+import Network.EasyBitcoin.Internal.Keys+import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.CurveConstants+import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.HashFunctions+import qualified Data.ByteString as BS+import Data.Binary (Binary, get, put, Word64,Word32,Word16)+import Data.Binary.Get ( getWord64be+ , getWord32be+ , getWord64le+ , getWord8+ , getWord16le+ , getWord32le+ , getByteString+ , Get+ )+import Data.Binary.Put( putWord64be+ , putWord32be+ , putWord32le+ , putWord64le+ , putWord16le+ , putWord8+ , putByteString+ )+import Control.Monad+import GHC.Word+import Control.Applicative+import Data.Bits++import Control.DeepSeq (NFData, rnf)+import Control.Monad (unless, guard)+import Data.Maybe+-- | Sign a message using ECDSA deterministic signatures as defined by+-- RFC 6979 <http://tools.ietf.org/html/rfc6979>+++detSignMsg :: Word256 -> Key Private net -> Signature+detSignMsg n (ExtendedPrv _ _ _ _ (PrvKey x)) = detSignMsg_ n x ++detSignMsg_ :: Word256 -> FieldN -> Signature+detSignMsg_ h d = go $ hmacDRBGNew (enc d) (encode' h) BS.empty+ + where+ enc::FieldN -> BS.ByteString+ enc x = encode' (fromIntegral x ::Word256) + + go ws = case hmacDRBGGen ws 32 BS.empty of ++ (ws', Just k) -> let kI = bsToInteger k+ p = mulPoint (fromInteger kI) curveG+ sigM = unsafeSignMsg h d (fromInteger kI,p)+ + in if (isIntegerValidKey kI) + then fromMaybe (go ws') sigM + else go ws' ++ (_ , Nothing) -> error "detSignMsg: No suitable K value found"++++-- Signs a message by providing the nonce+unsafeSignMsg :: Word256 -> FieldN -> (FieldN, Point) -> Maybe Signature+unsafeSignMsg _ 0 _ = Nothing+unsafeSignMsg h d (k,p) = do let (x,_) = getAffine p+ -- 4.1.3.3+ r = (fromIntegral x :: FieldN)+ --guard (r /= 0) -- is it necesary?+ e = (fromIntegral h :: FieldN) -- double check this work!+ 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'+ + -- 4.1.3.4 / 4.1.3.5+ --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+checkSig :: Word256 -> Signature -> Key Public net -> Bool+checkSig h sig ( ExtendedPub _ _ _ _ key) = checkSig_ h sig key+ where+-- 4.1.4.1 (r and s can not be zero)+ checkSig_ _ (Signature 0 _) _ = False+ checkSig_ _ (Signature _ 0) _ = False+ checkSig_ h (Signature r s) q = case Just $ getAffine p of+ Nothing -> False+ Just (x,_) -> (fromIntegral x :: FieldN) == r+ where + -- 4.1.4.2 / 4.1.4.3+ e = (fromIntegral h :: FieldN)+ -- 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)+++data Signature = Signature { sigR :: !FieldN+ , sigS :: !FieldN+ } deriving (Read, Show, Eq)++++--------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------++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+ isolate (fromIntegral l) $ 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)+ -- error .show $ (r,s)+ putByteString c++++shamirsTrick :: FieldN -> Point -> FieldN -> Point -> Point+shamirsTrick r1 p1 r2 p2 = addPoint (mulPoint r1 p1) (mulPoint r2 p2)++++------------------------------------------------------------------------------------------------------------------------------++++quadraticResidue :: FieldP -> [FieldP]+quadraticResidue x = guard (y^(2 :: Int) == x) >> [y, (-y)]+ where+ q = (curveP + 1) `div` 4+ y = x^q+++++++++++
+ Network/EasyBitcoin/Internal/Transaction.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE TypeFamilies #-}++module Network.EasyBitcoin.Internal.Transaction + where+++import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.Base58 ( encodeBase58+ , decodeBase58+ , addRedundancy+ , liftRedundacy+ )++import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.InstanciationHelpers+import Network.EasyBitcoin.Internal.Signatures+import Network.EasyBitcoin.Keys+import Network.EasyBitcoin.BitcoinUnits+import Network.EasyBitcoin.Address+import Network.EasyBitcoin.Internal.Script+import Network.EasyBitcoin.Internal.InstanciationHelpers+import Network.EasyBitcoin.Internal.HashFunctions+import Data.Bits (testBit, clearBit, setBit)+import Control.Applicative+import Control.Monad(replicateM,forM_)+import qualified Data.ByteString as BS+import Data.Char+import Data.Binary+import Data.Binary.Get ( getWord64be+ , getWord32be+ , getWord64le+ , getWord8+ , getWord16le+ , getWord32le+ , getByteString+ , Get+ )+import Data.Binary.Put( putWord64be+ , putWord32be+ , putWord32le+ , putWord64le+ , putWord16le+ , putWord8+ , putByteString+ )++import Data.Maybe(fromMaybe)++++++++++ +--------------------------------------------------------------------------------+-- | Bitcoin transaction. +-- When parsed, only syntax validation is performanced, particulary, signature validation is not.++data Tx net = Tx { txVersion :: Int -- !Word32+ , txIn :: [TxIn]+ , txOut :: [TxOut]+ , txLockTime :: Int -- Either a b -- Word32+ } deriving (Eq)+++data TxIn = TxIn { prevOutput :: Outpoint -- ^ Reference the previous transaction output (hash + position)+ , scriptInput :: Script+ , txInSequence :: Int+ } deriving (Show,Eq)++data TxOut = TxOut { outValue :: Int -- Word64 -- change to ¿BTC?+ , scriptOutput :: Script+ } deriving (Show,Eq)++++++++instance Binary (Tx net) where+ + get = Tx <$> (fmap fromIntegral getWord32le)+ <*> (replicateList =<< get)+ <*> (replicateList =<< get)+ <*> (fmap fromIntegral getWord32le)+ + where+ replicateList (VarInt c) = replicateM (fromIntegral c) get++ put (Tx v is os l) = do putWord32le (fromIntegral v)+ put $ VarInt $ fromIntegral $ length is+ forM_ is put+ + put $ VarInt $ fromIntegral $ length os+ + forM_ os put+ putWord32le (fromIntegral l)+++++instance Binary TxOut where++ get = do val <- getWord64le+ VarInt len <- get+ raw_script <- getByteString $ fromIntegral len+ + case decodeToMaybe raw_script of++ Just script -> return$TxOut (fromIntegral val) script+ _ -> fail "could not decode the pub-script" +++ put (TxOut o s) = do putWord64le (fromIntegral o)+ let s_ = encode' s+ put $ VarInt $ BS.length s_+ putByteString s_+++instance Binary TxIn where++ get = do outpoint <- get + VarInt len <- get+ raw_script <- getByteString $ fromIntegral len+ val <- getWord32le++ case decodeToMaybe raw_script of++ Just script -> return$TxIn outpoint script (fromIntegral val)+ _ -> fail "could not decode the sig-script"+++ put (TxIn o s q) = do put o+ let s_ = encode' s+ put $ VarInt $ BS.length s_+ putByteString s_+ putWord32le (fromIntegral q)++++-- | Represents a reference to a transaction output, that is, a transaction hash ('Txid') plus the output position +-- within the output vector of the referenced transaction.+data Outpoint = Outpoint Txid Int deriving (Eq,Show,Ord,Read)+++-- | A transaction identification as a hash of the transaction. 2 transaction are consider different if they have different+-- 'Txid's. In some cases, it might be possible for a peer to modify a transaction into an equivalent one having a different+-- 'Txid', for futher info read about the "transaction-malleability-issue".++--------------------------------------------------------------------------------------------------------------------------------------+-- | A transaction hash used to indentify a transaction. Notice that due to the "transaction-malleability-issue", it is possible for an adversary,+-- to derivated a new equivalent transaction with a different Txid.+data Txid = Txid{ txidHash :: Word256} deriving (Eq,Ord)+++-- | Compute the 'Txid' of a given transaction.+txid:: Tx net -> Txid+txid = Txid . fromIntegral . doubleHash256 . encode' +++instance Show (Txid) where+ show (Txid x) = bsToHex . BS.reverse $ encode' x++instance Read Txid where++ readsPrec _ str = case readsPrec__ str of + ( Just result, rest) -> [(result,rest)]+ _ -> []++ where+ readsPrec__ str = let (word , rest) = span (not.isSpace)$ dropWhile isSpace str+ in (fmap Txid . decodeToMaybe . BS.reverse =<< hexToBS word ,rest)+++instance Binary Txid where+ get = Txid <$> get+ put = put . txidHash ++++instance Binary Outpoint where++ get = Outpoint <$> get <*> (fromIntegral<$>getWord32le)++ put (Outpoint h i) = put h >> putWord32le (fromIntegral i)+++instance Show (Tx net) where+ show = showAsBinary++instance Read (Tx net) where+ readsPrec = readsPrecAsBinary+---------------------------------------------------------------------------------------------------------------------------------------+++--------------------------------------------------------------------------------++---------------------------------------------------------------------------------+-- Todo, create here the function "signatureOfTransaction..." so it does not need to export txSigHash+++++txSigHash :: Tx net -- ^ 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.+ -> Word256 -- ^ Result hash to be signed.++txSigHash tx out i sh = do let newIn = buildInputs (txIn tx) out i sh + fromMaybe (setBit 0 248) -- When SigSingle and input index > outputs, then sign integer 1+ $ do newOut <- buildOutputs (txOut tx) i sh+ let newTx = tx{ txIn = newIn, txOut = newOut }+ return $ doubleHash256 $ encode' newTx `BS.append` encodeSigHash32 sh+ -- error $ (bsToHex $ encode' newTx) -- `BS.append` encodeSigHash32 sh)+ -- ++ " ------------------------ " +++ -- (bsToHex.encode'.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) + | i == j = ti + | otherwise = 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 [])++updateIndex::Int -> [a] -> (a->a) -> [a]+updateIndex i xs f+ | i < 0 || i >= length xs = xs+ | otherwise = l ++ (f h : r)+ where+ (l,h:r) = splitAt i xs++-- | Encodes a 'SigHash' to a 32 bit-long bytestring.+encodeSigHash32 :: SigHash -> BS.ByteString+encodeSigHash32 sh = encode' sh `BS.append` BS.pack [0,0,0]++------------------------------------------------------------------------------------------------------++-- | A SigHash stands for Signature Hash Type, and it describes what parts of the transaction shall be signed. +-- <https://bitcoin.org/en/developer-guide#signature-hash-types Check the docs for more info > +data SigHash = SigAll { anyoneCanPay :: !Bool }+ | SigNone { anyoneCanPay :: !Bool }+ | SigSingle { anyoneCanPay :: !Bool }+ | SigUnknown { anyoneCanPay :: !Bool+ , getSigCode :: !Word8+ } + deriving (Eq, Show, Read)++-- | A 'TxSignature' is a combination of a ecdsa signature and the 'SigHash' used while signing.+data TxSignature = TxSignature { txSignature :: !Signature+ , sigHashType :: !SigHash+ } deriving (Eq, Show, Read)++++instance Binary TxSignature where+++ put (TxSignature sig sh) = put sig >> put sh ++ get = TxSignature <$> get <*> get++instance Binary SigHash where++ get = do w <- getWord8 + let acp = testBit w 7+ 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 + | acp -> 0x81 + | otherwise -> 0x01+ + SigNone acp + | acp -> 0x82 + | otherwise -> 0x02+ + SigSingle acp + | acp -> 0x83 + | otherwise -> 0x03+ + SigUnknown _ w -> w+++-------------------------------------------------------------------------------------------------------+-- 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
+ Network/EasyBitcoin/Internal/Words.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE FlexibleInstances, EmptyDataDecls, ScopedTypeVariables #-}++module Network.EasyBitcoin.Internal.Words + where+++import Network.EasyBitcoin.Internal.CurveConstants(curveP,curveN)+import Network.EasyBitcoin.Internal.ByteString+import Numeric+import Control.Arrow+import Control.Applicative+import Data.Ratio (numerator, denominator)+import Data.Bits (shiftR , shiftL, Bits(..))+import Data.Binary(Binary(..))+import qualified Data.ByteString as BS+import Control.Monad+import Data.Binary.Get ( getWord64be+ , getWord32be+ , getWord8+ , getByteString+ , Get+ )+import Data.Binary.Put( putWord64be+ , putWord32be+ , putWord8+ , putByteString+ )++--import Network.Haskoin.Util++-- | Type representing a transaction hash.+type TxHash = BigWord Mod256Tx+++-- | Type representing a block hash.+type BlockHash = BigWord Mod256Block+++-- | Data type representing a 512 bit unsigned integer.+-- It is implemented as an Integer modulo 2^512.+type Word512 = BigWord Mod512+++-- | Data type representing a 256 bit unsigned integer.+-- It is implemented as an Integer modulo 2^256.+type Word256 = BigWord Mod256+++-- | Data type representing a 160 bit unsigned integer.+-- It is implemented as an Integer modulo 2^160.+type Word160 = BigWord Mod160+++-- | 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 Mod256Tx+data Mod256Block+data Mod160+data Mod128+data ModP+data ModN++newtype BigWord n = BigWord { getBigWordInteger :: Integer + } deriving (Eq, Ord) -- change the read and show instances....++class BigWordMod a where+ maxVal ::BigWord a -> Integer + maxVal x = 2 ^ rBitSize x + + rBitSize :: BigWord a -> Int+ -- = ds++instance BigWordMod Mod512 where+ rBitSize _ = 512++instance BigWordMod Mod256 where+ rBitSize _ = 256++instance BigWordMod Mod256Tx where+ rBitSize _ = 256++instance BigWordMod Mod256Block where+ rBitSize _ = 256++instance BigWordMod Mod160 where+ rBitSize _ = 160++instance BigWordMod Mod128 where+ rBitSize _ = 128++instance BigWordMod ModP where+ maxVal _ = curveP+ rBitSize _ = 256+++instance BigWordMod ModN where+ maxVal _ = curveN+ rBitSize _ = 256+++---------------------------------------------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------------------------------++instance (BigWordMod a) => Show (BigWord a) where+ + show x@(BigWord x_) = let digits = rBitSize x `div` 4 + in ("0x"++). reverse . take digits $ (reverse $ showHex x_ "") ++ repeat '0'+++instance Read (BigWord a) where+ readsPrec k x = first BigWord <$> readsPrec k x++++------------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------++++rFromInteger :: forall a . (BigWordMod a) => Integer -> BigWord a +rFromInteger x = let max = maxVal (undefined :: BigWord a) + in BigWord $ ((x `mod` max) + max) `mod` max -- make sure it yields the correct value for negative integers!++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 => 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+++inverseP :: FieldP -> FieldP+inverseP (BigWord i) = fromInteger $ mulInverse i curveP+++inverseN :: FieldN -> FieldN+inverseN (BigWord i) = fromInteger $ mulInverse i curveN+++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 -}+++++--isIntegerValidKey :: Integer -> Bool+--isIntegerValidKey i = i > 0 && i < curveN+++-- 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+++-- TODO, make this not necesary?+isIntegerValidKey :: Integer -> Bool+isIntegerValidKey i = i > 0 && i < curveN++--------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------++instance Binary (BigWord Mod256) where+ --get = error "dddd"+ get = do a <- fromIntegral <$> getWord64be+ -- error $ show a+ 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+++ {-+- Recheck twice!! + -}+ -- This one is wrong!!+instance Binary (BigWord ModN) where+ get = do t <- getWord8+ + unless (t == 0x02) (fail $ "Bad DER identifier byte " ++ (show t) ++ ". Expecting 0x02" )+ + l <- getWord8+ i <- bsToInteger <$> getByteString (fromIntegral l)+ + unless (i > 0 && i < curveN) $ fail $ "Invalid fieldN element: " ++ (show i) -- shouldn't be that a >= instead of a > ?++ 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 -- recheck if this works fine, also see how this affect whether is compressed or not....+ + if BS.head b >= 0x80+ then putWord8 (l + 1) >> putWord8 0x00+ else putWord8 l+ + putByteString b -- so here finally the error is !!!!!!!!!!!!!!!+++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 Word256+ unless (i>= 0 && 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 (fromIntegral r :: Word256)+++instance Binary (BigWord Mod512) where+ get = do a <- fromIntegral <$> (get :: Get Word256)+ b <- fromIntegral <$> (get :: Get Word256)+ return $ (a `shiftL` 256) + b++ put (BigWord i) = do put $ (fromIntegral (i `shiftR` 256) :: Word256)+ put $ (fromIntegral i :: Word256)+++---------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------++-- | Split a 'Word512' into a pair of 'Word256'.+split512 :: Word512 -> (Word256, Word256)+split512 i = (fromIntegral $ i `shiftR` 256, fromIntegral i)+++-- | Join a pair of 'Word256' into a 'Word512'.+join512 :: (Word256, Word256) -> Word512+join512 (a,b) = ((fromIntegral a :: Word512) `shiftL` 256) + (fromIntegral b :: Word512)++++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++++++++++++++++++++
+ Network/EasyBitcoin/Keys.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE DataKinds+ , KindSignatures+ , ScopedTypeVariables+ , GADTs+ , StandaloneDeriving+ , FlexibleInstances + #-}++module Network.EasyBitcoin.Keys + ( Key(..)+ , Visibility(..)+ , derive+ , derivePublic+ , deriveHardened+ , deriveRoot+ , showAsCompressedSingletonKey+ , showAsUncompressedSingletonKey+ , serializeCompressedSingleton+ , serializeUncompressedSingleton+ -- , decodeCheckingCompression+ , (===)+ ) where+++import qualified Data.ByteString as BS+import GHC.Word+import Data.Bits(shiftR,setBit)+import Data.Binary++import Network.EasyBitcoin.Internal.Keys (PrvKey(), PubKey(),derivePubKey_,xPrvID,xPubID,addPrvKeys_,addPubKeys_,Compressed(..))+import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.HashFunctions(hmac512)+import Network.EasyBitcoin.NetworkParams+import Network.EasyBitcoin.Internal.InstanciationHelpers+import Control.Monad+import Data.Binary.Put+import Data.Binary.Get+import Control.Applicative+type ChainCode = Word256+++-- | 'Key's represents public and private bitcoin keys. +-- +-- 'Key's can be used either as singleton keys or as hierarchical deterministic keys+-- as defined on BIP0032. It supports compressed and uncompressed keys.+-- It has an additional phantom type to describe on which network this key is supposed to be used .+--+-- Its 'Read' instance understands the WIF format for singleton private keys, the BIP0032 format for private and public hierarchical +-- deterministic keys, and for singleton public keys it also understands hexadecimal representation of binary serialized OpenSSL public keys.+--+-- When parsing a key, if no information about its hierarchal position is available, for example when reading from a WIF format, it is consider to be root.+--+-- Its 'Show' instance works always as defined on BIP0032 In case you need to show it as singleton, you can use+-- the functions 'showAsSingletonKey' and 'showAsSingletonKeyUncompressed'.++data Key (visibility::Visibility) net where++ ExtendedPrv :: { prv_depth :: Word8+ , prv_parent :: Word32 + , prv_index :: Word32+ , prv_chain :: ChainCode+ , prv_key :: PrvKey net+ } -> Key Private net + + ExtendedPub :: { pub_depth :: Word8+ , pub_parent :: Word32 + , pub_index :: Word32+ , pub_chain :: ChainCode+ , pub_key :: PubKey net+ } -> Key Public net++deriving instance Eq (Key v net)++-- | @'Key' 'Public' net@ represents public keys, @'Key' 'Private' net@ represents private keys.+data Visibility = Private + | Public++-- | Derives the n-th child of a key, keeping it public if the parent was public, otherwise private.+derive :: Int -> Key v net -> Key v net+derive n key = case key of + r@(ExtendedPrv _ _ _ _ _) -> prvSubKey r (fromIntegral n)+ r@(ExtendedPub _ _ _ _ _) -> pubSubKey r (fromIntegral n)++-- | Transform a private key into a public key, or does nothing if it was already a public key.+--+-- prop> derive n . derivePublic = derivePublic . derive n +--+derivePublic :: Key v net -> Key Public net+derivePublic k = case k of + r@(ExtendedPub _ _ _ _ _) -> r + ExtendedPrv d p i c k -> ExtendedPub d p i c (derivePubKey_ k)++++-- | Like 'derive' but derives a hardened child. Hardened child can only be derived from private keys.+deriveHardened :: Int -> Key Private net -> Key Private net +deriveHardened n k = primeSubKey k (fromIntegral n)+++-- | Takes a hierarchical key keeping its ECSDA point or exponent, but setting it as root.+-- +-- It is equivalent to: +-- +-- prop> deriveRoot = read . showAsSingletonKey +-- +deriveRoot :: Key v net -> Key v net +deriveRoot (ExtendedPrv _ _ _ _ k) = ExtendedPrv 0 0 0 0 k +deriveRoot (ExtendedPub _ _ _ _ k) = ExtendedPub 0 0 0 0 k ++-- | Compares 2 keys not taking into account their hierarchical position.+--+-- +-- prop> k1 === k2 = deriveRoot k1 == deriveRoot k2+-- ++(===) :: Key v net -> Key v net -> Bool+k1 === k2 = deriveRoot k1 == deriveRoot k2+++++-- | Show the key as a singleton compressed key as defined by the WIF format for private keys and+-- as hexadecimal representation of the OpenSSL binary serialization for public keys. +showAsCompressedSingletonKey :: (BlockNetwork net) => Key v net -> String+showAsCompressedSingletonKey key = case key of + ExtendedPrv _ _ _ _ k -> show $ Compressed True k+ ExtendedPub _ _ _ _ k -> show $ Compressed True k++-- | Like 'showAsCompressedSingletonKey' but interpreting the keys as uncompressed. Notice this function is+-- for legacy keys, as currently most software only use compressed keys.+showAsUncompressedSingletonKey :: (BlockNetwork net) => Key v net -> String+showAsUncompressedSingletonKey key = case key of + ExtendedPrv _ _ _ _ k -> show $ Compressed False k+ ExtendedPub _ _ _ _ k -> show $ Compressed False k+++serializeCompressedSingleton :: (BlockNetwork net) => Key v net -> BS.ByteString+serializeCompressedSingleton key = case key of + ExtendedPrv _ _ _ _ k -> encode' $ Compressed True k+ ExtendedPub _ _ _ _ k -> encode' $ Compressed True k+++serializeUncompressedSingleton ::(BlockNetwork net) => Key v net -> BS.ByteString+serializeUncompressedSingleton key = case key of + ExtendedPrv _ _ _ _ k -> encode' $ Compressed False k+ ExtendedPub _ _ _ _ k -> encode' $ Compressed False k+++--decodeCheckingCompression :: (Visibility_ v,BlockNetwork net) => BS.ByteString -> Maybe (Key v net,Bool)+--decodeCheckingCompression = decodeCheckingCompression_+++class Visibility_ (a::Visibility) where+ decodeCheckingCompression_ ::(BlockNetwork net) => BS.ByteString -> Maybe (Key a net,Bool)+++instance Visibility_ Private where+ decodeCheckingCompression_ bs = do Compressed b k <- decodeToMaybe bs+ Just $ (ExtendedPrv 0 0 0 0 k, b)+++instance Visibility_ Public where+ decodeCheckingCompression_ bs = do Compressed b k <- decodeToMaybe bs+ Just $ (ExtendedPub 0 0 0 0 k, b)+++--data Get (n::Visibility) = Get{get_ :: Visibility}++------------------------------------------------------------------------------------------------------------------------+---- Private functions:+++prvSubKey :: Key Private a -> Word32 -> Key Private a +prvSubKey xkey child = ExtendedPrv (prv_depth xkey + 1) (xPrvFP xkey) child c k + where ++ k = addPrvKeys_ (prv_key xkey) a++ msg = BS.append (encode'. Compressed True . derivePubKey_ $ prv_key xkey)+ $ (encode'$ child)++ (a,c) = split512 $ hmac512 (encode' $ prv_chain xkey) msg+++pubSubKey :: Key Public a -> Word32 -> Key Public a +pubSubKey xKey child = ExtendedPub (pub_depth xKey + 1) (xPubFP xKey) child c pK+ where + + pK = addPubKeys_ (pub_key xKey) a++ msg = BS.append (encode'. Compressed True $ pub_key xKey) (encode' child)+ (a,c) = split512 $ hmac512 (encode' $ pub_chain xKey) msg++++primeSubKey :: Key Private a -> Word32 -> Key Private a +primeSubKey xkey child = ExtendedPrv (prv_depth xkey + 1) (xPrvFP xkey) i c k --checked+ where++ k = addPrvKeys_ (prv_key xkey) a+ -- problem found!!!...?? -----------------> TODO: find what happened here :(+ i = setBit child 31 :: Word32+ msg = BS.cons 0x00 $ BS.append (encode'(fromIntegral . prv_key $ xkey :: Word256)) (encode' i)+ (a,c) = split512 $ hmac512 (encode' $ prv_chain xkey) msg++{- +++----------------------------------------------------------------------------------------------------------------------+++-}+----------------------------------------------------------------------------------------------------------------------+instance (BlockNetwork net) => Show (Key Private net) where+ show = showAsBinary58++instance (BlockNetwork net) => Show (Key Public net) where+ show = showAsBinary58++++instance (BlockNetwork net) => Binary (Key Public net) where+ + get = get_aux + where+ get_aux :: forall net. (BlockNetwork net) => Get (Key Public net)+ get_aux = do let params = (valuesOf :: Params net)+ (version,k) <- (get_aux1 <|> get_aux2)+ case version of + Just v+ | v == extPubKeyPrefix params -> return k+ | otherwise -> fail "wrong version. are you using the same network for this key?" + Nothing -> return k + ++ get_aux1 = do ver <- getWord32be+ dep <- getWord8+ par <- getWord32be+ idx <- getWord32be+ chn <- get+ Compressed compression pub <- get+ + unless compression $ fail $ "Get: Extended key using an uncompressed public key"+ + return (Just ver,ExtendedPub dep par idx chn pub)+ + get_aux2 = do Compressed _ pub <- get + return (Nothing, ExtendedPub 0 0 0 0 pub)++++ put = put_aux+ where + put_aux :: forall net. (BlockNetwork net) => Key Public net -> Put + put_aux key = do let params = (valuesOf :: Params net) + putWord32be $ extPubKeyPrefix params+ putWord8 $ pub_depth key+ putWord32be $ pub_parent key+ putWord32be $ pub_index key+ put $ pub_chain key+ put $ Compressed True (pub_key key)+++instance (BlockNetwork net) => Binary (Key Private net) where+ + get = get_aux1 <|> get_aux2+ where+ get_aux1 :: forall net. (BlockNetwork net) => Get (Key Private net)+ get_aux1 = do let params = (valuesOf :: Params net)+ + ver <- getWord32be+ + unless (ver == extPrvKeyPrefix params) $ fail "Get: Invalid version for extended private key"+ + dep <- getWord8+ par <- getWord32be+ idx <- getWord32be+ chn <- get+ prv <- getPadPrvKey+ + return $ ExtendedPrv dep par idx chn prv+ + get_aux2 = do Compressed _ prv <- get + return $ ExtendedPrv 0 0 0 0 prv+++ getPadPrvKey::Get (PrvKey net_)+ getPadPrvKey = do pad <- getWord8+ guard $ pad == 0x00+ fromIntegral <$> (get :: Get Word256)++ put = put_aux+ where + put_aux :: forall net. (BlockNetwork net) => Key Private net -> Put + put_aux key = do let params = (valuesOf :: Params net) + + putWord32be $ extPrvKeyPrefix params+ putWord8 $ prv_depth key+ putWord32be $ prv_parent key+ putWord32be $ prv_index key+ put $ prv_chain key+ putPadPrvKey $ prv_key key+++ putPadPrvKey k = putWord8 0x00 >> put (fromIntegral k :: Word256)+++-------------------------------+++++instance (BlockNetwork net) => Read (Key Private net) where+ readsPrec = readsPrecAsBinary58+++instance (BlockNetwork net) => Read (Key Public net) where+ readsPrec n s = readsPrecAsBinary58 n s ++ readsPrecAsBinary n s++ +----------------------------------------------------------------------------------------------------------------------+xPubFP :: Key Public a -> Word32+xPubFP = fromIntegral . (`shiftR` 128) . xPubID . pub_key++xPrvFP :: Key Private a -> Word32+xPrvFP = fromIntegral . (`shiftR` 128) . xPrvID . prv_key+
+ Network/EasyBitcoin/NetworkParams.hs view
@@ -0,0 +1,49 @@+module Network.EasyBitcoin.NetworkParams + ( -- * Network Parameters+ Params(..)+ , ProdNet+ + -- ** Instances+ , TestNet+ , BlockNetwork(..)+ ) where++import Data.Word (Word8, Word32, Word64)+++-- | Network parameters to adapt the library to work with different networks, such when using it for different alt-coins.++data Params net = Params { addrPrefix :: Word8 -- ^ Prefix for base58 PubKey hash address+ , scriptPrefix :: Word8 -- ^ Prefix for base58 script hash address+ , wifFormat :: Word8 -- ^ Prefix for private key WIF format+ , extPubKeyPrefix :: Word32 -- ^ Prefix for extended public keys (BIP0032)+ , extPrvKeyPrefix :: Word32 -- ^ Prefix for extended private keys (BIP0032)+ } deriving Show++-- | Original bitcoin network, where "real" bitcoin used on production system.+data ProdNet++-- | Bitcoin network for test, where "fake" bitcoins can be used to test systems.+data TestNet++class BlockNetwork net where+ valuesOf :: Params net ++instance BlockNetwork ProdNet where+ valuesOf = Params { addrPrefix = 0x00 + , scriptPrefix = 0x05+ , wifFormat = 0x80+ , extPubKeyPrefix = 0x0488b21e+ , extPrvKeyPrefix = 0x0488ade4+ }++instance BlockNetwork TestNet where+ valuesOf = Params { addrPrefix = 0x6F+ , scriptPrefix = 0xc4+ , wifFormat = 0xEF+ , extPubKeyPrefix = 0x043587CF+ , extPrvKeyPrefix = 0x04358394+ }++---------------------------------------------------------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------------------------------------------------------------------------------------------------
+ Network/EasyBitcoin/Script.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DataKinds, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}+module Network.EasyBitcoin.Script + where++++import Network.EasyBitcoin.Internal.Script+import Network.EasyBitcoin.Keys+import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.Transaction+import Network.EasyBitcoin.Internal.Signatures+import Network.EasyBitcoin.Internal.Keys+import Data.Word+import qualified Data.ByteString as BS+import Data.List (nub) -- not to use nub!! TODO++import Network.EasyBitcoin.Internal.InstanciationHelpers+import Data.Binary (Binary, get, put)+import Data.Binary.Get ( getWord64be+ , getWord32be+ , getWord8+ , getWord16le+ , getWord32le+ , getByteString+ , Get+ , isEmpty + )+import Data.Binary.Put( putWord64be+ , putWord32be+ , putWord32le+ , putWord16le+ , putWord8+ , putByteString+ )+import Database.PostgreSQL.Simple.ToField+import Control.Monad (unless, guard,replicateM,forM_,liftM2)+import Control.Applicative((<$>))+import Network.EasyBitcoin.Address+import Network.EasyBitcoin.Internal.HashFunctions+import Network.EasyBitcoin.NetworkParams+import Network.EasyBitcoin.BitcoinUnits+++++-- | Contains:+-- * number of requiered signatures.+-- * public keys allowed to use for signing.+-- The signature order does matter, it should sign using the keys from the tail of the list+-- till the button, so for eaxample, given @RedeemScript 2 [k_a,k_b,key_c] @,+-- @ signA.signB @ , @ signA.signC @ and @ signB.signC @ would valid combination, but+-- @ signB.signA @ would not.+data RedeemScript net = RedeemScript { numRequired :: Int + , redeemSignatures :: [Key Public net]+ } deriving (Eq)+++newtype ScriptSig = ScriptSig Script deriving(Eq,Ord,Binary)++instance Show ScriptSig where+ show (ScriptSig x) = showAsBinary x ++instance Read ScriptSig where+ readsPrec n = fmap (\(a,b)->(ScriptSig a,b)) . readsPrecAsBinary n +++instance (BlockNetwork net) => Show (RedeemScript net) where+ show = showAsBinary++instance (BlockNetwork net) => Read (RedeemScript net) where+ readsPrec = readsPrecAsBinary+++generalScript (RedeemScript minKeys keys) = Script $ [ op minKeys ] + ++ [ opPushData $ serializeCompressedSingleton k | k <- keys]+ ++ [ op $ length keys, OP_CHECKMULTISIG]++interpret (Script (opMin : rest )) = case splitAt (length rest -2) rest of++ (rest_, [opMax,OP_CHECKMULTISIG]) -> do op_min <- opNumber opMin+ op_max <- opNumber opMax+ compressed <- mapM getPubKeys rest_+ + if op_max == length rest_ && op_min <= op_max + + then return $ RedeemScript op_min compressed+ else Nothing+ + _ -> Nothing+ where+ getPubKeys scriptOp = do content <- opContent scriptOp+ Compressed _ pub <- decodeToMaybe content+ return $ ExtendedPub 0 0 0 0 pub++instance Addressable RedeemScript where+ address = ScriptAddress . hash160 . hash256BS . encode' ++------------------------------------------------------------------------------------------------------------------------------------++encodeOutput :: Address net -> Script+encodeOutput addr = case addr of++ PubKeyAddress payload -> Script [ OP_DUP+ , OP_HASH160+ , opPushData (encode' payload)+ , OP_EQUALVERIFY+ , OP_CHECKSIG+ ]++ ScriptAddress payload -> Script [ OP_HASH160+ , opPushData (encode' payload)+ , OP_EQUAL+ ]+++------------------------------------------------------------------------------------------------------------------------------------+encodeInputPayPKH :: TxSignature -> PubKey a -> Script+encodeInputPayPKH ts p = Script $ [ opPushData$encode' ts, opPushData$encode' p]++------------------------------------------------------------------------------------------------------------------------------------++++decodeOutput :: forall net. BlockNetwork net => Script -> Maybe (Address net)+decodeOutput (Script script) = case script of + + [OP_DUP, OP_HASH160, OP_PUSHDATA payload _, OP_EQUALVERIFY, OP_CHECKSIG] + | Just content <- decodeToMaybe payload -> Just $ PubKeyAddress content+ + [OP_HASH160, OP_PUSHDATA payload _, OP_EQUAL] + | Just content <- decodeToMaybe payload -> Just $ ScriptAddress content + _ -> Nothing+++++decodeInput :: forall net. BlockNetwork net => Script -> Maybe (Address net)+decodeInput (Script script) = case script of + [OP_PUSHDATA _ _ , OP_PUSHDATA content _] -> Just . PubKeyAddress . hash160 $ hash256BS content+ + OP__ 0 : rest + | (OP_PUSHDATA content _: _) <- reverse rest+ , Just redeem <- decodeToMaybe content -> Just $address (redeem::RedeemScript net)+ + _ -> Nothing++++-------------------------------------------------------------------------------------------------------------++---------------------------------------------------------------------------------------------------------------++++++dncodeInputPayPKH :: Script -> Maybe (TxSignature, Key Public a)+dncodeInputPayPKH (Script script) = case script of + [OP_PUSHDATA payload1 _, OP_PUSHDATA payload2 _] + | Just sign <- decodeToMaybe payload1+ , Just pubk <- decodeToMaybe payload2 -> Just $ (sign, ExtendedPub 0 0 0 0 pubk) + _ -> Nothing++-------------------------------------------------------------------------------------------------------------+instance (BlockNetwork net) => Binary (RedeemScript net) where+ get = get >>= maybe (fail "This script is not an standard multisg redeem script") return . interpret + put = put . generalScript
+ Network/EasyBitcoin/Transaction.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE DataKinds, TypeFamilies, RankNTypes #-}++module Network.EasyBitcoin.Transaction+ ( Outpoint (..)+ , Txid()+ , txid+ , Tx ()+ , transaction+ , unsignedTransaction+ , txOutputs+ , txInputs+ , checkInput++ -- * Escrows and Signatures:+ , RedeemScript(..)+ , ScriptSig()+ , TxSignature()+ , signTxAt+ , scriptSig+ , escrowSignatures+ , escrowSignaturesFor+ , simpleSignature + , checkSignatureAt+ , createSignature+ , createSignatureAs+ , SigHash(..)+ , sigHashType+ ) where++import Network.EasyBitcoin.Internal.ByteString+import Network.EasyBitcoin.Internal.Words+import Network.EasyBitcoin.Internal.Transaction+import Network.EasyBitcoin.Internal.Signatures+import Network.EasyBitcoin.BitcoinUnits+import Network.EasyBitcoin.Script+import Network.EasyBitcoin.Internal.Script++import Network.EasyBitcoin.Address+import Network.EasyBitcoin.Keys+import Network.EasyBitcoin.NetworkParams+import Control.Applicative+import Control.Lens+--------------------------------------------------------------------------------+++-- | Creates a transaction ready to be broadcasted.+transaction::(BlockNetwork net) + => [(Outpoint, Key Private net)] -- ^ Transaction's inputs + -> (Address net,BTC net) -- ^ Transaction's output+ -> [(Address net,BTC net)] -- ^ Additional optional outputs+ -> Tx net++transaction ins x xs = let unsigned_tx = unsignedTransaction (map fst ins) (x:xs)+ in Tx 1 + [ TxIn out (encodeInputPayPKH signat (pub_key key') ) maxBound+ | ((out,key),n) <- zip ins [0..]+ , let key' = derivePublic key+ signat = simpletTxSignature n key out unsigned_tx+ ] + [ TxOut (fromIntegral$asSatoshis btc) (encodeOutput addr) | (addr,btc) <- (x:xs)+ ]+ 0 ++ ++-- | Returns those 'Outpoint's used by the transaction's inputs+txInputs::Tx net -> [Outpoint]+txInputs (Tx _ inns _ _) = [ out | TxIn out _ _ <- inns ]++txInputs_::Tx net -> [(Outpoint, ScriptSig )]+txInputs_ (Tx v inns outs lock) = [ (out, ScriptSig script) | TxIn out script seq <- inns ]+++-- | Return's the amount spent for each transaction's output and its address in case it can be parsed (Pay2PKH or Pay2SH).+txOutputs::(BlockNetwork net) => Tx net -> [(Maybe (Address net), BTC net )]+txOutputs (Tx v inns outs lock) = [ (decodeOutput script, satoshis value )+ | TxOut value script <- outs+ ] ++++-------------------------------------------------------------------------------------------------------------------------+-- Private Functions:+++-- We should try to minimize going from private to public several times....+simpletTxSignature :: (BlockNetwork net) => Int -> Key Private net -> Outpoint -> Tx net -> TxSignature+simpletTxSignature i key out tx = let sh = SigAll False+ msg = txSigHash tx (encodeOutput $ address key) i sh+ + in TxSignature (detSignMsg msg key) sh+ ++simpletTxSignatureCheck :: (BlockNetwork net) => Int -> Key Public net -> Outpoint -> Tx net -> TxSignature -> Bool+simpletTxSignatureCheck i key out tx (TxSignature sig sh)+ | SigAll False /= sh = False+ | otherwise = let msg = txSigHash tx (encodeOutput $ address key) i sh+ in checkSig msg sig key++-- in detSignTx rawTx ins+++-- | Return a transaction without signatures so it can be signed later on or by other participants (in case of multisignature escrows).+unsignedTransaction :: [Outpoint] -> [(Address net,BTC net)] -> Tx net+unsignedTransaction xs ys = Tx 1 + [ TxIn point (Script []) maxBound | point <- xs] + [ TxOut (asSatoshis btc) (encodeOutput addr) | (addr,btc) <- ys] + 0++------------------------------------------------------------------------------------------------------------------------------+++-- | Sign an specific input of a transaction.+signTxAt :: (BlockNetwork net) => Tx net -- ^ Transaction to sign + -> Outpoint -- ^ Reference the input within the transaction to be signed.+ -> Maybe (RedeemScript net) -- ^ If using to see multisig-escrow, this should contain the redeemScript defining that+ -- escrow.+ -> Key Private net -- ^ Key to sign+ -> Tx net+signTxAt tx out redeem_ key = let signa = createSignature tx out redeem_ key :: TxSignature + + in case redeem_ of+ -- change this branch for a more intuitive behaviour+ Just redeem -> tx & scriptSig out . escrowSignaturesFor redeem %~ (signa:) ++ Nothing -> tx & scriptSig out .~ + ( (signa, derivePublic key) ^. re simpleSignature :: ScriptSig) ++-- | Check an specific input of a transaction is fully signed, it understand both, Pay2PKH and Pay2SH for multisig-escrow. for other kinds of+-- transaction it will return always 'False'.+--+-- In case of multisig-escrow, it also check signatures use the right order defined on the RedeemScript.+--+checkInput :: (BlockNetwork net) => Tx net -> Outpoint -> Address net -> Bool+checkInput tx out addr = case [ sig_script | (out',sig_script) <- txInputs_ tx] of++ [script]++++ | Just (sig,key) <- script ^? simpleSignature+ , address key == addr+ , checkSignatureAt tx out Nothing sig key -> True+ + | Just (sigs ,Just redeem@(RedeemScript n keys) ) <- script ^? escrowSignatures + , address redeem == addr + , n == length sigs+ , check redeem sigs keys -> True++ _ -> False+ where+ check redeem sigs keys = go (reverse sigs) (reverse keys)+ where+ go [] _ = True+ go _ [] = False+ go (x:xs) keys = go xs . drop 1 $ dropWhile (not.checkSignatureAt tx out (Just redeem) x) keys ++++-- | A Traversal focusing on the ScriptSig of a transaction at a particular input referenced by an 'Outpoint' +-- Notice, a valid transaction will always have exactly 0 or 1 scriptSig for a given 'Outpoint'; invalid transactions+-- might have more than one.+scriptSig :: Outpoint -> Traversal' (Tx net) ScriptSig -- Lens' (Tx net) ScriptSig +scriptSig out f (Tx v inn txOuts lock) = let appF (TxIn out' script seq) + | out' == out = (\(ScriptSig script') -> TxIn out' script' seq) <$> f (ScriptSig script ) + | otherwise = pure (TxIn out' script seq) + + in (\x -> Tx v x txOuts lock ) <$> traverse appF inn +++-- | The prism successes when the scriptSig is either empty, partially or full signed escrow-multisig; unless it is empty, +-- it will also require than the redeem used by the scriptSig is an specific one.+escrowSignaturesFor :: (BlockNetwork net) => RedeemScript net -> Prism' ScriptSig [TxSignature] +escrowSignaturesFor redeem = prism (fromEscrowFor redeem) (toEscrowFor redeem) +++-- | The prism successes when the scriptSig is either empty, partially or full signed escrow-multisig.+escrowSignatures ::(BlockNetwork net) => Prism' ScriptSig ([TxSignature],Maybe (RedeemScript net))+escrowSignatures = prism fromEscrow toEscrow++++-- | The prism successes when the scriptSig is from an already signed Pay2PKH, it does not check whether this signature is valid or not.+simpleSignature :: Prism' ScriptSig (TxSignature, Key Public net) +simpleSignature = prism fromSimple toSimple+ where++ fromSimple (sig,key) = ScriptSig $ encodeInputPayPKH sig (pub_key key)++ toSimple x@(ScriptSig script) = maybe (Left x) Right $ dncodeInputPayPKH script +++++++fromEscrow :: (BlockNetwork net) => ([TxSignature],Maybe (RedeemScript net)) -> ScriptSig+fromEscrow (sigs,Just redeem) = ScriptSig . Script $ OP__ 0 : (opPushData . encode' <$> sigs) ++ [opPushData . encode' $ redeem ]+ +fromEscrow ([],Nothing) = ScriptSig . Script $ []++-- This branch makes no sense, but we'll need to behave this+-- way to obey the prism laws!+fromEscrow (sigs,Nothing) = ScriptSig . Script $ OP__ 0 : (opPushData . encode' <$> sigs)+++toEscrow :: (BlockNetwork net) => ScriptSig -> Either ScriptSig ([TxSignature],Maybe (RedeemScript net))+toEscrow x@(ScriptSig (Script script)) = case script of+ OP__ 0 : rest ++ | (OP_PUSHDATA content _: signatures) <- reverse rest+ , Just redeem@(RedeemScript n pks) <- decodeToMaybe content + , all pushData signatures ++ , Just signed <- sequence+ [ decodeToMaybe payload + | OP_PUSHDATA payload _ <- signatures+ ] -> Right (reverse signed,Just redeem)+++ -- This branch makes no sense, but we'll need to behave this+ -- way to obey the prism laws!+ | all pushData rest + , Just signed <- sequence+ [ decodeToMaybe payload + | OP_PUSHDATA payload _ <- rest+ ] -> Right (signed, Nothing)++ [] -> Right ([] , Nothing)++ _ -> Left x++ where+ pushData (OP_PUSHDATA _ _) = True+ pushData _ = False++++fromEscrowFor :: (BlockNetwork net) => RedeemScript net -> [TxSignature] -> ScriptSig+fromEscrowFor redeem sigs = fromEscrow (sigs,Just redeem)+++toEscrowFor :: (BlockNetwork net) => RedeemScript net -> ScriptSig -> Either ScriptSig [TxSignature]+toEscrowFor redeem script = case toEscrow script of + Right (sigs,Just redeem')+ | redeem == redeem' -> Right sigs+ + Right ([],Nothing) -> Right []++ Left script' -> Left script'++++++-- | Creates an specif type of signature for a transaction's input.+createSignatureAs ::(BlockNetwork net) => SigHash -> Tx net -> Outpoint -> Maybe (RedeemScript net) -> Key Private net -> TxSignature+createSignatureAs sh tx out redeem_ key = let msg = createMessage_ sh tx out (maybe (Left key) Right redeem_)+ in TxSignature (detSignMsg msg key) sh+++createMessage_ :: (BlockNetwork net) => SigHash + -> Tx net + -> Outpoint + -> Either (Key v net) (RedeemScript net) + -> Word256+createMessage_ sh tx@(Tx _ inn _ _) out fromInn = txSigHash tx output i sh+ where+ output = either (encodeOutput.address) generalScript fromInn + i = case [ i | (i, TxIn out' _ _) <- zip [0..] inn , out' == out] of + [x] -> x + _ -> 0++-- | Creates a "sig-all" signature of a transaction input.+createSignature :: (BlockNetwork net) => Tx net + -> Outpoint + -> Maybe (RedeemScript net) + -> Key Private net + -> TxSignature+createSignature = createSignatureAs (SigAll False) ++++-- | Verify a signature for a transaction input was done using an specific key.+checkSignatureAt :: (BlockNetwork net) => Tx net -- ^ Transaction to verify.+ -> Outpoint -- ^ Reference the input within the transaction to be verified.+ -> Maybe (RedeemScript net) -- ^ In case of multisig-escrow this should contain the RedeemScript.+ -> TxSignature -- ^ The signature to verify.+ -> Key v net -- ^ The signature's key. + -> Bool+checkSignatureAt tx out fromInn (TxSignature sig sh) key = let msg = createMessage_ sh tx out $ maybe (Left key) Right fromInn+ in checkSig msg sig (derivePublic key)++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ easy-bitcoin.cabal view
@@ -0,0 +1,58 @@+-- Initial easy-bitcoin.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: easy-bitcoin+version: 0.0.0.2+synopsis: types and functions for bitcoin applications++description: EasyBitcoin is a simple library providing types and class-instances for bitcoin related code; + it also include an small set of functions to handle addresses, transactions and escrows.++homepage: https://github.com/vwwv/easy-bitcoin+license: BSD3+license-file: LICENSE+author: Alejandro D.P.+maintainer: vwwv@correo.ugr.es+-- copyright: +category: Network+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Network.EasyBitcoin++ other-modules: Network.EasyBitcoin.Address,+ Network.EasyBitcoin.BitcoinUnits, + Network.EasyBitcoin.NetworkParams, + Network.EasyBitcoin.Keys, + Network.EasyBitcoin.Internal.InstanciationHelpers, + Network.EasyBitcoin.Internal.Base58, + Network.EasyBitcoin.Internal.Words, + Network.EasyBitcoin.Internal.ByteString, + Network.EasyBitcoin.Internal.Keys, + Network.EasyBitcoin.Internal.CurveConstants,+ Network.EasyBitcoin.Script,+ Network.EasyBitcoin.Transaction,+ Network.EasyBitcoin.Internal.HashFunctions,+ Network.EasyBitcoin.Internal.Script,+ Network.EasyBitcoin.Internal.Signatures,+ Network.EasyBitcoin.Internal.Transaction+ ++ other-extensions: DataKinds, GADTs, ScopedTypeVariables, KindSignatures, StandaloneDeriving, PolyKinds, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts, RankNTypes, StandaloneDeriving, EmptyDataDecls+ + build-depends: base >= 2 && < 5, + bytestring >=0.10, + binary >=0.7 , + postgresql-simple >=0.4 , + safe >=0.3 , + text >=1.0 , + base16-bytestring >=0.1,+ aeson >= 0.6,+ byteable >= 0.1,+ deepseq >= 1.0,+ lens >= 4.3,+ cryptohash >= 0.11+ -- hs-source-dirs: + default-language: Haskell2010