diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/EasyBitcoin.hs b/Network/EasyBitcoin.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin.hs @@ -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 . + +-} + +{-# 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) + + + @ + +-} diff --git a/Network/EasyBitcoin/Address.hs b/Network/EasyBitcoin/Address.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Address.hs @@ -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)] + + _ -> [] + + +---------------------------------------------------------------------------------------------------------------------------------- + + + + + + + + + + diff --git a/Network/EasyBitcoin/BitcoinUnits.hs b/Network/EasyBitcoin/BitcoinUnits.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/BitcoinUnits.hs @@ -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)]) + + diff --git a/Network/EasyBitcoin/Internal/Base58.hs b/Network/EasyBitcoin/Internal/Base58.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/Base58.hs @@ -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 + + + + + + + + diff --git a/Network/EasyBitcoin/Internal/ByteString.hs b/Network/EasyBitcoin/Internal/ByteString.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/ByteString.hs @@ -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) + diff --git a/Network/EasyBitcoin/Internal/CurveConstants.hs b/Network/EasyBitcoin/Internal/CurveConstants.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/CurveConstants.hs @@ -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 + + + + + + + + + + + diff --git a/Network/EasyBitcoin/Internal/HashFunctions.hs b/Network/EasyBitcoin/Internal/HashFunctions.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/HashFunctions.hs @@ -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 + + + + + + + + + + + + + + + + + + + + + + diff --git a/Network/EasyBitcoin/Internal/InstanciationHelpers.hs b/Network/EasyBitcoin/Internal/InstanciationHelpers.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/InstanciationHelpers.hs @@ -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)] + _ -> [] diff --git a/Network/EasyBitcoin/Internal/Keys.hs b/Network/EasyBitcoin/Internal/Keys.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/Keys.hs @@ -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 diff --git a/Network/EasyBitcoin/Internal/Script.hs b/Network/EasyBitcoin/Internal/Script.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/Script.hs @@ -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 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Network/EasyBitcoin/Internal/Signatures.hs b/Network/EasyBitcoin/Internal/Signatures.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/Signatures.hs @@ -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 + + +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 + + + + + + + + + + + diff --git a/Network/EasyBitcoin/Internal/Transaction.hs b/Network/EasyBitcoin/Internal/Transaction.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/Transaction.hs @@ -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. +-- +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 diff --git a/Network/EasyBitcoin/Internal/Words.hs b/Network/EasyBitcoin/Internal/Words.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Internal/Words.hs @@ -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 + + + + + + + + + + + + + + + + + + + + diff --git a/Network/EasyBitcoin/Keys.hs b/Network/EasyBitcoin/Keys.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Keys.hs @@ -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 + diff --git a/Network/EasyBitcoin/NetworkParams.hs b/Network/EasyBitcoin/NetworkParams.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/NetworkParams.hs @@ -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 + } + +--------------------------------------------------------------------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------------------------------------------------------------------- diff --git a/Network/EasyBitcoin/Script.hs b/Network/EasyBitcoin/Script.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Script.hs @@ -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 diff --git a/Network/EasyBitcoin/Transaction.hs b/Network/EasyBitcoin/Transaction.hs new file mode 100644 --- /dev/null +++ b/Network/EasyBitcoin/Transaction.hs @@ -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) + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/easy-bitcoin.cabal b/easy-bitcoin.cabal new file mode 100644 --- /dev/null +++ b/easy-bitcoin.cabal @@ -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