diff --git a/network-bitcoin.cabal b/network-bitcoin.cabal --- a/network-bitcoin.cabal +++ b/network-bitcoin.cabal @@ -1,5 +1,5 @@ Name: network-bitcoin -Version: 1.8.3 +Version: 1.9.1 Synopsis: An interface to bitcoind. Description: This can be used to send Bitcoins, query balances, etc. It @@ -9,26 +9,25 @@ > import Network.Bitcoin > > main = do - > balance <- getBalance auth + > client <- getClient "http://127.0.0.1:8332" "user" "password" + > balance <- getBalance client > putStrLn $ show balance ++ " BTC" - > where - > auth = Auth "http://127.0.0.1:8332" "user" "password" . To learn more about Bitcoin, see . License: BSD3 License-file: LICENSE Author: Michael Hendricks Clark Gaebel -Maintainer: Clark Gaebel -Homepage: http://github.com/cgaebel/network-bitcoin -Bug-reports: http://github.com/cgaebel/network-bitcoin/issues +Maintainer: Matt Wraith +Homepage: http://github.com/bitnomial/network-bitcoin +Bug-reports: http://github.com/bitnomial/network-bitcoin/issues Copyright: 2012 Michael Hendricks 2013 Clark Gaebel Stability: experimental Category: Network Build-type: Simple Cabal-version: >=1.8 -tested-with: GHC ==7.4.1, GHC ==7.6.2, GHC ==7.6.3 +tested-with: GHC ==8.4.3 Library hs-source-dirs: src @@ -63,12 +62,11 @@ Source-repository head type: git - location: git://github.com/wowus/network-bitcoin.git + location: git://github.com/bitnomial/network-bitcoin.git Test-suite network-bitcoin-tests - hs-source-dirs: src - ghc-options: -Wall - main-is: Test/Main.hs + hs-source-dirs: src/Test + main-is: Main.hs type: exitcode-stdio-1.0 build-depends: aeson >= 0.8, @@ -84,5 +82,7 @@ base == 4.*, time >= 1.4.2, QuickCheck >= 2.6, + tasty >= 1.0, + tasty-quickcheck >= 0.10, http-client >= 0.4.6, network-bitcoin diff --git a/src/Network/Bitcoin.hs b/src/Network/Bitcoin.hs --- a/src/Network/Bitcoin.hs +++ b/src/Network/Bitcoin.hs @@ -30,6 +30,8 @@ , importPrivateKey , dumpPrivateKey -- * Mining Operations + , generate + , generateToAddress , getGenerate , setGenerate , getHashesPerSec @@ -47,6 +49,9 @@ , getConnectionCount , PeerInfo(..) , getPeerInfo + , AddNodeCommand(..) + , addNode + , disconnectNode -- * Raw Transaction Operations , RawTransaction , getRawTransaction @@ -90,6 +95,8 @@ , moveBitcoins , sendFromAccount , sendMany + , EstimationMode (..) + , estimateSmartFee -- , createMultiSig , ReceivedByAddress(..) , listReceivedByAddress diff --git a/src/Network/Bitcoin/BlockChain.hs b/src/Network/Bitcoin/BlockChain.hs --- a/src/Network/Bitcoin/BlockChain.hs +++ b/src/Network/Bitcoin/BlockChain.hs @@ -14,6 +14,7 @@ , setTransactionFee , getRawMemoryPool , BlockHash + , BlockHeight , getBlockHash , Block(..) , getBlock @@ -29,7 +30,7 @@ import Network.Bitcoin.RawTransaction -- | Returns the number of blocks in the longest block chain. -getBlockCount :: Client -> IO Integer +getBlockCount :: Client -> IO BlockHeight getBlockCount client = callApi client "getblockcount" [] -- | Returns the proof-of-work difficulty as a multiple of the minimum @@ -51,10 +52,11 @@ -- | The hash of a given block. type BlockHash = HexString +type BlockHeight = Integer -- | Returns the hash of the block in best-block-chain at the given index. getBlockHash :: Client - -> Integer -- ^ Block index. + -> BlockHeight -- ^ Block index. -> IO BlockHash getBlockHash client idx = callApi client "getblockhash" [ tj idx ] @@ -65,7 +67,7 @@ -- | The size of the block. , blkSize :: Integer -- | The "height" of the block. TODO: Clarify this. - , blkHeight :: Integer + , blkHeight :: BlockHeight -- | The version of the block. , blkVersion :: Integer -- | The hash of the block at the root of the merkle tree @@ -79,7 +81,7 @@ , blkNonce :: Integer , blkBits :: HexString -- | How hard was this block to mine? - , blkDifficulty :: Integer + , blkDifficulty :: Double -- | A pointer to the next block in the chain. , nextBlock :: Maybe BlockHash -- | A pointer to the previous block in the chain. @@ -87,6 +89,13 @@ } deriving ( Show, Read, Ord, Eq ) +-- Missing from data type: +-- - strippedsize +-- - weight +-- - versionHex +-- - mediantime +-- - nTx +-- - chainwork instance FromJSON Block where parseJSON (Object o) = Block <$> o .: "hash" <*> o .: "confirmations" @@ -110,6 +119,8 @@ -- | Information on the unspent transaction in the output set. data OutputSetInfo = OutputSetInfo { osiBestBlock :: BlockHash + -- | The height of the best block chain + , osiHeight :: BlockHeight -- | The number of transactions in the output set. , numTransactions :: Integer -- | The number of outputs for the transactions. @@ -121,6 +132,7 @@ instance FromJSON OutputSetInfo where parseJSON (Object o) = OutputSetInfo <$> o .: "bestblock" + <*> o .: "height" <*> o .: "transactions" <*> o .: "txouts" <*> o .: "bytes_serialized" @@ -140,7 +152,7 @@ -- | The public key of the sender. , oiScriptPubKey :: ScriptPubKey -- | The version of this transaction. - , oiVersion :: Integer + , oiVersion :: Maybe Integer -- | Is this transaction part of the coin base? , oiCoinBase :: Bool } @@ -151,7 +163,7 @@ <*> o .: "confirmations" <*> o .: "value" <*> o .: "scriptPubKey" - <*> o .: "version" + <*> o .:? "version" <*> o .: "coinbase" parseJSON _ = mzero @@ -159,5 +171,5 @@ getOutputInfo :: Client -> TransactionID -> Integer -- ^ The index we're looking at. - -> IO OutputInfo + -> IO (Maybe OutputInfo) getOutputInfo client txid n = callApi client "gettxout" [ tj txid, tj n ] diff --git a/src/Network/Bitcoin/Internal.hs b/src/Network/Bitcoin/Internal.hs --- a/src/Network/Bitcoin/Internal.hs +++ b/src/Network/Bitcoin/Internal.hs @@ -72,7 +72,7 @@ -> BS.ByteString -> IO Client getClient url user pass = do - url' <- parseUrl url + url' <- parseUrlThrow url mgr <- newManager defaultManagerSettings let baseReq = applyBasicAuth user pass url' { method = "POST" @@ -101,9 +101,9 @@ callApi client cmd params = readVal =<< client jsonRpcReqBody where readVal bs = case decode' bs of - Just r@(BitcoinRpcResponse {btcError=NoError}) + Just r@BitcoinRpcResponse {btcError=NoError} -> return $ btcResult r - Just (BitcoinRpcResponse {btcError=BitcoinRpcError code msg}) + Just BitcoinRpcResponse {btcError=BitcoinRpcError code msg} -> throw $ BitcoinApiError code msg Nothing -> throw $ BitcoinResultTypeError bs @@ -116,18 +116,18 @@ {-# INLINE callApi #-} -- | Used to allow "null" to decode to a tuple. -data Nil = Nil { unNil :: () } +newtype Nil = Nil { unNil :: () } instance FromJSON Nil where parseJSON Null = return $ Nil () parseJSON x = fail $ "\"null\" was expected, but " ++ show x ++ " was recieved." -- | Used to parse "null" or [HexString] -data NilOrArray = NilOrArray {unArr :: Maybe [HexString]} +newtype NilOrArray = NilOrArray {unArr :: Maybe [HexString]} instance FromJSON NilOrArray where parseJSON Null = return $ NilOrArray Nothing - parseJSON a@(Array _) = liftM NilOrArray $ parseJSON a + parseJSON a@(Array _) = NilOrArray <$> parseJSON a parseJSON x = fail $ "Expected \"null\" or array, but " ++ show x ++ " was recieved." -- | A handy shortcut for toJSON, because I'm lazy. @@ -140,7 +140,7 @@ {-# INLINE tjm #-} tja :: ToJSON a => Maybe a -> [Value] -tja m = fromMaybe [] $ pure . tj <$> m +tja = maybe [] (pure . tj) {-# INLINE tja #-} -- | A wrapper for a vector of address:amount pairs. The RPC expects that as diff --git a/src/Network/Bitcoin/Mining.hs b/src/Network/Bitcoin/Mining.hs --- a/src/Network/Bitcoin/Mining.hs +++ b/src/Network/Bitcoin/Mining.hs @@ -31,9 +31,15 @@ , submitBlock ) where +import Control.Exception (catch, throw) import Control.Monad import Data.Aeson as A import Network.Bitcoin.Internal +import Network.Bitcoin.Wallet (getNewAddress) +import Network.HTTP.Client (HttpException (..), + HttpExceptionContent (..), + responseStatus) +import Network.HTTP.Types (status500) -- | Returns whether or not bitcoind is generating bitcoins. getGenerate :: Client -- ^ bitcoind RPC client @@ -70,10 +76,14 @@ -> IO [HexString] -- ^ An array containing the block header -- hashes of the generated blocks -- (may be empty if used with generate 0) -generate client blocks Nothing = - callApi client "generate" [ tj blocks ] -generate client blocks (Just maxTries) = - callApi client "generate" [ tj blocks, tj maxTries] +generate client blocks maxTries = + callApi client "generate" args `catch` onFail + where + args = tj blocks : maybe [] (pure . tj) maxTries + onFail (HttpExceptionRequest _ (StatusCodeException rsp _)) + | responseStatus rsp == status500 + = getNewAddress client Nothing >>= flip (generateToAddress client blocks) maxTries + onFail e = throw e -- | The generatetoaddress RPC mines blocks immediately to a specified address. -- See https://bitcoin.org/en/developer-reference#generatetoaddress for more details. @@ -189,8 +199,7 @@ <*> o .: "sigops" parseJSON _ = mzero -data CoinBaseAux = CoinBaseAux { cbFlags :: HexString - } +newtype CoinBaseAux = CoinBaseAux { cbFlags :: HexString } deriving ( Show, Read, Ord, Eq ) instance FromJSON CoinBaseAux where @@ -255,7 +264,7 @@ -- the string "rejected" on failure. -- -- We use 'StupidReturnValue' to parse this ridiculous API. -data StupidReturnValue = SRV { unStupid :: Bool } +newtype StupidReturnValue = SRV { unStupid :: Bool } instance FromJSON StupidReturnValue where parseJSON Null = return $ SRV True diff --git a/src/Network/Bitcoin/Net.hs b/src/Network/Bitcoin/Net.hs --- a/src/Network/Bitcoin/Net.hs +++ b/src/Network/Bitcoin/Net.hs @@ -11,6 +11,9 @@ , getConnectionCount , PeerInfo(..) , getPeerInfo + , AddNodeCommand(..) + , addNode + , disconnectNode ) where import Control.Monad @@ -70,3 +73,21 @@ -- | Returns data about all connected peer nodes. getPeerInfo :: Client -> IO [PeerInfo] getPeerInfo client = callApi client "getpeerinfo" [] + + +data AddNodeCommand = Add | Remove | OneTry + deriving (Show, Read, Eq) + + +instance ToJSON AddNodeCommand where + toJSON Add = String "add" + toJSON Remove = String "remove" + toJSON OneTry = String "onetry" + + +addNode :: Client -> Text -> AddNodeCommand -> IO () +addNode client url com = unNil <$> callApi client "addnode" [tj url, tj com] + + +disconnectNode :: Client -> Maybe Text -> Maybe Int -> IO () +disconnectNode client url nodeId = unNil <$> callApi client "disconnectnode" [tj url, tj nodeId] diff --git a/src/Network/Bitcoin/RawTransaction.hs b/src/Network/Bitcoin/RawTransaction.hs --- a/src/Network/Bitcoin/RawTransaction.hs +++ b/src/Network/Bitcoin/RawTransaction.hs @@ -51,7 +51,7 @@ getRawTransaction :: Client -> TransactionID -> IO RawTransaction getRawTransaction client txid = callApi client "getrawtransaction" [ tj txid, tj verbose ] - where verbose = 0 :: Int + where verbose = False -- | A transaction into an account. This can either be a coinbase transaction, -- or a standard transaction with another account. @@ -217,7 +217,7 @@ getRawTransactionInfo :: Client -> TransactionID -> IO RawTransactionInfo getRawTransactionInfo client txid = callApi client "getrawtransaction" [ tj txid, tj verbose ] - where verbose = 1 :: Int + where verbose = True data UnspentTransaction = UnspentTransaction { unspentTransactionId :: TransactionID @@ -241,9 +241,9 @@ -- Instance used in 'createRawTransaction'. instance ToJSON UnspentTransaction where - toJSON (UnspentTransaction{..}) = object [ "txid" .= unspentTransactionId - , "vout" .= outIdx - ] + toJSON UnspentTransaction{..} = object [ "txid" .= unspentTransactionId + , "vout" .= outIdx + ] -- | Returns an array of unspent transaction outputs with between minconf and -- maxconf (inclusive) confirmations. If addresses are given, the result will @@ -306,7 +306,7 @@ newtype UnspentForSigning = UFS UnspentTransaction instance ToJSON UnspentForSigning where - toJSON (UFS (UnspentTransaction{..})) + toJSON (UFS UnspentTransaction{..}) | isNothing redeemScript = object [ "txid" .= unspentTransactionId , "vout" .= outIdx diff --git a/src/Network/Bitcoin/Wallet.hs b/src/Network/Bitcoin/Wallet.hs --- a/src/Network/Bitcoin/Wallet.hs +++ b/src/Network/Bitcoin/Wallet.hs @@ -35,6 +35,8 @@ , moveBitcoins , sendFromAccount , sendMany + , EstimationMode (..) + , estimateSmartFee -- , createMultiSig , ReceivedByAddress(..) , listReceivedByAddress @@ -63,13 +65,17 @@ , isAddressValid ) where +import Control.Exception (throw) import Control.Monad import Data.Aeson as A +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.HashMap.Lazy as HM import Data.Maybe import Data.Text import Data.Time.Clock.POSIX import Data.Vector as V hiding ((++)) +import Data.Word import Network.Bitcoin.BlockChain (BlockHash) import Network.Bitcoin.Internal import Network.Bitcoin.RawTransaction (RawTransaction) @@ -129,6 +135,8 @@ parseJSON _ = mzero -- | Returns an object containing various state info. +-- +-- /Availability:/ @< 0.16@ getBitcoindInfo :: Client -> IO BitcoindInfo getBitcoindInfo client = callApi client "getinfo" [] @@ -357,7 +365,7 @@ instance FromJSON ReceivedByAddress where parseJSON (Object o) = ReceivedByAddress <$> o .: "address" - <*> o .: "account" + <*> o .: "label" <*> o .: "amount" <*> o .: "confirmations" parseJSON _ = mzero @@ -531,9 +539,9 @@ -- transaction can be returned as 'sbLastBlockHash'. This does -- not in any way affect which transactions are returned -- (see https://github.com/bitcoin/bitcoin/pull/199#issuecomment-1514952) - -> IO (SinceBlock) -listSinceBlock client blockHash conf = - listSinceBlock' client (Just blockHash) conf + -> IO SinceBlock +listSinceBlock client blockHash = + listSinceBlock' client (Just blockHash) -- | Gets all transactions in blocks since the given block, or all -- transactions if ommited. @@ -545,7 +553,7 @@ -- transaction can be returned as 'sbLastBlockHash'. This does -- not in any way affect which transactions are returned -- (see https://github.com/bitcoin/bitcoin/pull/199#issuecomment-1514952) - -> IO (SinceBlock) + -> IO SinceBlock listSinceBlock' client mblockHash mminConf = callApi client "listsinceblock" $ tja mblockHash ++ tja mminConf @@ -677,7 +685,7 @@ getTransaction :: Client -> TransactionID - -> IO (DetailedTransaction) + -> IO DetailedTransaction getTransaction client txid = callApi client "gettransaction" [ tj txid ] @@ -736,7 +744,7 @@ -- | Just a handy wrapper to help us get only the "isvalid" field of the JSON. -- The structure is much too complicated for what it needs to do. -data IsValid = IsValid { getValid :: Bool } +newtype IsValid = IsValid { getValid :: Bool } instance FromJSON IsValid where parseJSON (Object o) = IsValid <$> o .: "isvalid" @@ -745,3 +753,24 @@ -- | Checks if a given address is a valid one. isAddressValid :: Client -> Address -> IO Bool isAddressValid client addr = getValid <$> callApi client "validateaddress" [ tj addr ] + + +-- | Possible fee estimation modes +data EstimationMode + = Economical + | Conservative + deriving Eq + + +instance ToJSON EstimationMode where + toJSON Economical = toJSON ("ECONOMICAL" :: String) + toJSON Conservative = toJSON ("CONSERVATIVE" :: String) + + +-- | Estimate the fee per kb to send a transaction +estimateSmartFee :: Client -> Word32 -> Maybe EstimationMode -> IO Double +estimateSmartFee client target mode = + parse =<< callApi client "estimatesmartfee" (catMaybes [ Just $ tj target, tj <$> mode ]) + where + parse = either (throw . BitcoinResultTypeError . BSL8.pack) pure . parseEither parseResp + parseResp = withObject "estimatesmartfee response" (.: "feerate") diff --git a/src/Test/Main.hs b/src/Test/Main.hs --- a/src/Test/Main.hs +++ b/src/Test/Main.hs @@ -1,50 +1,110 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + module Main where -import Data.Vector (empty) +import Control.Monad (void) +import Data.Either (isRight) +import Data.Text (Text) +import Data.Vector (empty) +import qualified Data.Vector as V import Network.Bitcoin +import Network.Bitcoin.Internal (callApi, tj) +import qualified Network.Bitcoin.Mining as M import Test.QuickCheck import Test.QuickCheck.Monadic +import Test.Tasty (TestName, TestTree, defaultMain, + testGroup) +import Test.Tasty.QuickCheck main :: IO () -main = mapM_ qcOnce [ canGetInfo - , canListUnspent - , canGetOutputInfo - ] +main = defaultMain . testGroup "network-bitcoin tests" $ + [ canGenerateBlocks + , canListUnspent + , canGetBlock + , canGetOutputInfo + , canGetRawTransaction + , canGetAddress + , canSendPayment + ] -qcOnce :: Property -> IO () -qcOnce = quickCheckWith stdArgs { maxSuccess = 1 - , maxSize = 1 - , maxDiscardRatio = 1 - } +client :: IO Client +client = getClient "http://127.0.0.1:18444" "bitcoinrpc" "bitcoinrpcpassword" -client :: IO Client -client = getClient "http://127.0.0.1:18332" "bitcoinrpc" "bitcoinrpcpassword" +nbTest name = testProperty name . once . monadicIO -canGetInfo :: Property -canGetInfo = monadicIO $ do - info <- run $ getBitcoindInfo =<< client - let checks = [ bitcoinVersion info > 80000 - , onTestNetwork info - , bitcoindErrors info == "" - ] - assert $ and checks +canGenerateBlocks :: TestTree +canGenerateBlocks = nbTest "generateToAddress" $ do + void . run $ do + c <- client + rewardAddr <- getNewAddress c Nothing + M.generateToAddress c 101 rewardAddr Nothing + assert True -canListUnspent :: Property -canListUnspent = monadicIO $ do - _ <- run $ (\c -> listUnspent c Nothing Nothing Data.Vector.empty) =<< client +canListUnspent :: TestTree +canListUnspent = nbTest "listUnspent" $ do + void . run $ do + c <- client + listUnspent c Nothing Nothing Data.Vector.empty assert True -canGetOutputInfo :: Property -canGetOutputInfo = monadicIO $ do - info <- run $ (\c-> getOutputInfo c "ab8e26fd95fa371ac15b43684d0c6797fb573757095e7d763ba86ad315f7db04" 1) =<< client - _ <- run $ print info +getTopBlock :: Client -> IO Block +getTopBlock c = getBlockCount c >>= getBlockHash c >>= getBlock c + + +canGetBlock :: TestTree +canGetBlock = nbTest "getBlockCount / getBlockHash / getBlock" $ do + run $ client >>= getTopBlock assert True + + +canGetRawTransaction :: TestTree +canGetRawTransaction = nbTest "getRawTransactionInfo" $ do + run $ do + c <- client + b <- getTopBlock c + getRawTransactionInfo c (subTransactions b V.! 0) + assert True + + +canGetOutputInfo :: TestTree +canGetOutputInfo = nbTest "getOutputInfo" $ do + run $ do + c <- client + b <- getTopBlock c + getOutputInfo c (subTransactions b V.! 0) 0 + assert True + + +canGetAddress :: TestTree +canGetAddress = nbTest "getNewAddress" $ do + run $ do + c <- client + getNewAddress c Nothing + assert True + + +canSendPayment :: TestTree +canSendPayment = nbTest "send payment" $ do + c <- run client + bal <- run $ getBalance c + amt <- pick . suchThat arbitrary $ \x -> x < bal && x > 0 + + (addr, recv) <- run $ do + addr <- getNewAddress c Nothing + sendToAddress c addr amt Nothing Nothing + M.generate c 6 Nothing + (addr,) <$> listReceivedByAddress c + + assert . V.elem (addr, amt) . fmap f $ recv + where + f = (,) <$> recvAddress <*> recvAmount