diff --git a/bitcoin-api.cabal b/bitcoin-api.cabal --- a/bitcoin-api.cabal +++ b/bitcoin-api.cabal @@ -1,6 +1,6 @@ name: bitcoin-api category: Network, Finance -version: 0.9.0 +version: 0.10.0 license: MIT license-file: LICENSE copyright: (c) 2015 Leon Mergen @@ -50,6 +50,11 @@ , lens-aeson , unordered-containers , wreq + , conduit + , transformers + , stm + , stm-chans + , stm-conduit , bitcoin-types , bitcoin-block @@ -63,19 +68,25 @@ hs-source-dirs: test main-is: Main.hs - other-modules: Network.Bitcoin.ClientSpec + other-modules: Network.Bitcoin.Api.TestUtil + Network.Bitcoin.Api.ClientSpec + Network.Bitcoin.Api.BlockchainSpec + Network.Bitcoin.Api.MiningSpec + Network.Bitcoin.Api.WalletSpec + Network.Bitcoin.Api.DumpSpec + Network.Bitcoin.Api.MiscSpec Spec Main build-depends: base >= 4.3 && < 5 - , groom , bytestring , text , base58string , http-client - , wreq + , wreq , lens + , conduit , hspec diff --git a/src/Network/Bitcoin/Api/Blockchain.hs b/src/Network/Bitcoin/Api/Blockchain.hs --- a/src/Network/Bitcoin/Api/Blockchain.hs +++ b/src/Network/Bitcoin/Api/Blockchain.hs @@ -12,17 +12,25 @@ import qualified Network.Bitcoin.Api.Internal as I import qualified Network.Bitcoin.Api.Types as T +-- | Gets the amount of blocks currently in the blockchain, also known as the +-- 'height' of the blockchain. getBlockCount :: T.Client -> IO Integer getBlockCount client = I.call client "getblockcount" emptyArray -getBlockHash :: T.Client -> Integer -> IO BT.BlockHash +-- | Get the hash of a block based on its offset (height). +getBlockHash :: T.Client -- ^ Our client context + -> Integer -- ^ The height/offset of the block. 0 is the genesis block. + -> IO BT.BlockHash -- ^ The hash of the block getBlockHash client offset = let configuration = [toJSON offset] in I.call client "getblockhash" configuration -getBlock :: T.Client -> HS.HexString -> IO Btc.Block +-- | Gets a block based on its hash. +getBlock :: T.Client -- ^ Our session context + -> HS.HexString -- ^ Hexadecimal representation of the hash of a block + -> IO Btc.Block -- ^ The block getBlock client hash = let configuration = [toJSON hash, toJSON False] diff --git a/src/Network/Bitcoin/Api/Transaction.hs b/src/Network/Bitcoin/Api/Transaction.hs --- a/src/Network/Bitcoin/Api/Transaction.hs +++ b/src/Network/Bitcoin/Api/Transaction.hs @@ -12,18 +12,32 @@ import Data.Maybe (fromMaybe) import Control.Lens ((^.), (^?)) +import qualified Data.Conduit as C (Source) +import Control.Concurrent (forkIO, + killThread, + myThreadId, + threadDelay) +import Control.Concurrent.STM.TBMQueue (isClosedTBMQueue, + newTBMQueue, + writeTBMQueue) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.STM (atomically) +import Data.Conduit.TQueue (sourceTBMQueue) + import qualified Data.Base58String as B58S -import qualified Data.Bitcoin.Transaction as Btc import qualified Data.Bitcoin.Block as Btc (Block (..)) +import qualified Data.Bitcoin.Transaction as Btc -import qualified Network.Bitcoin.Api.Blockchain as Blockchain import qualified Data.Bitcoin.Types as BT +import qualified Network.Bitcoin.Api.Blockchain as Blockchain import qualified Network.Bitcoin.Api.Internal as I import qualified Network.Bitcoin.Api.Types as T -import Network.Bitcoin.Api.Types.UnspentTransaction +import Network.Bitcoin.Api.Types.UnspentTransaction hiding (confirmations) + -- | Creates a new transaction, but does not sign or submit it yet. You provide -- a set of unspent transactions that you have the authority to spend, and you -- provide a destination for all your bitcoins. @@ -114,12 +128,66 @@ -- | Returns a list of transactions that occured since a certain block height. -- If no block height was provided, the genisis block with height 0 is assumed. -- The transactions returned are listed chronologically. -list :: T.Client - -> Maybe Integer +list :: T.Client -- ^ Our client session context + -> Maybe Integer -- ^ The offset / height we should start listing transactions + -> Maybe Integer -- ^ Minimum amount of confirmations for a transaction to have. Should be 1 or higher. + -- A default value of 6 is used. -> IO [Btc.Transaction] -list client Nothing = list client (Just 0) -list client (Just offset) = do +list client Nothing confirmations = list client (Just 0) confirmations +list client offset Nothing = list client offset (Just 6) +list client (Just offset) (Just confirmations) = do limit <- Blockchain.getBlockCount client - blocks <- mapM (Blockchain.getBlock client) =<< mapM (Blockchain.getBlockHash client) [offset..limit - 1] + blocks <- mapM (Blockchain.getBlock client) =<< mapM (Blockchain.getBlockHash client) [offset..limit - confirmations] return $ foldl (\lhs rhs -> lhs ++ Btc.blockTxns rhs) [] blocks + +-- | Watches incoming transactions and yields new transactions as soon as they +-- are are inside a block. Note that this launches a background thread which +-- stops as soon as the Conduit is closed. +watch :: T.Client -- ^ Our client session context + -> Maybe Integer -- ^ Minimum amount of confirmations. Should be 1 or higher. A default value of 6 is used. + -> C.Source IO Btc.Transaction -- ^ Conduit that generates transactions +watch client Nothing = watch client (Just 6) +watch client (Just confirmations) = do + chan <- liftIO $ atomically $ newTBMQueue 16 + curHeight <- liftIO blockHeight + _ <- liftIO $ forkIO $ watchNext chan curHeight + + sourceTBMQueue chan + + where + + -- | Calculates the height of the block we currently are looking for + blockHeight = do + limit <- Blockchain.getBlockCount client + return (limit - confirmations) + + -- | Watches the current height of the block chain, and continues only + -- when the height changes. + watchNext chan height = do + cur <- blockHeight + + if cur > height + then go chan (height + 1) + else threadDelay 1000000 >> watchNext chan height + + -- | Fills the chan with all transactions from the block at `height`, + -- and then continues waiting until a next block is available. + go chan height = do + block <- Blockchain.getBlock client =<< Blockchain.getBlockHash client height + tid <- myThreadId + + + result <- mapM (insert chan) (Btc.blockTxns block) + let isClosed = False `elem` result + + if isClosed + then killThread tid + else watchNext chan height + + -- | Inserts a transaction into the queue. Blocks if the queue is full. + -- Returns True if write succeeded, False is the queue was closed. + insert chan tx = atomically $ do + isClosed <- isClosedTBMQueue chan + unless isClosed (writeTBMQueue chan tx) + return isClosed diff --git a/test/Network/Bitcoin/Api/BlockchainSpec.hs b/test/Network/Bitcoin/Api/BlockchainSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/BlockchainSpec.hs @@ -0,0 +1,27 @@ +module Network.Bitcoin.Api.BlockchainSpec where + +import qualified Network.Bitcoin.Api.Blockchain as Blockchain +import Network.Bitcoin.Api.TestUtil (testClient) +import Test.Hspec + +spec :: Spec +spec = do + describe "when testing blockchain functions" $ do + it "can request blockcount" $ do + r <- testClient Blockchain.getBlockCount + + r `shouldSatisfy` (>= 100) + + it "can request block hashes" $ do + testClient $ \client -> do + count <- Blockchain.getBlockCount client + hashes <- mapM (Blockchain.getBlockHash client) [0..count - 1] + + fromIntegral (length (hashes)) `shouldBe` count + + it "can request blocks" $ do + testClient $ \client -> do + count <- Blockchain.getBlockCount client + blocks <- mapM (Blockchain.getBlock client) =<< mapM (Blockchain.getBlockHash client) [0..count - 1] + + fromIntegral (length (blocks)) `shouldBe` count diff --git a/test/Network/Bitcoin/Api/ClientSpec.hs b/test/Network/Bitcoin/Api/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/ClientSpec.hs @@ -0,0 +1,20 @@ +module Network.Bitcoin.Api.ClientSpec where + +import qualified Data.Text as T (pack) + +import Network.Bitcoin.Api.Client + +import qualified Network.Bitcoin.Api.Misc as Misc + +import Network.Bitcoin.Api.TestUtil (isStatusCodeException, + testClient) +import Test.Hspec + +spec :: Spec +spec = do + describe "when creating a new client session" $ do + it "callback returns generated value" $ do + testClient (\_ -> return "foo") `shouldReturn` "foo" + + it "fails when providing invalid authentication credentials" $ do + withClient "127.0.0.1" 18332 (T.pack "invaliduser") (T.pack "invalidpass") Misc.getInfo `shouldThrow` isStatusCodeException 401 diff --git a/test/Network/Bitcoin/Api/DumpSpec.hs b/test/Network/Bitcoin/Api/DumpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/DumpSpec.hs @@ -0,0 +1,18 @@ +module Network.Bitcoin.Api.DumpSpec where + +import qualified Network.Bitcoin.Api.Dump as Dump +import qualified Network.Bitcoin.Api.Wallet as Wallet + +import Network.Bitcoin.Api.TestUtil (testClient) +import Test.Hspec + +spec :: Spec +spec = do + describe "when testing import/dump functions" $ do + it "should be able to dump private key" $ do + testClient $ \client -> do + addr <- Wallet.newAddress client + r <- Dump.getPrivateKey client addr + + putStrLn ("r = " ++ show r) + True `shouldBe` True diff --git a/test/Network/Bitcoin/Api/MiningSpec.hs b/test/Network/Bitcoin/Api/MiningSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/MiningSpec.hs @@ -0,0 +1,19 @@ +module Network.Bitcoin.Api.MiningSpec where + +import qualified Network.Bitcoin.Api.Blockchain as Blockchain +import qualified Network.Bitcoin.Api.Mining as Mining +import Network.Bitcoin.Api.TestUtil (testClient) +import Test.Hspec + +spec :: Spec +spec = do + describe "when testing mining functions" $ do + it "can generate blocks" $ do + countBefore <- testClient Blockchain.getBlockCount + r <- testClient $ \client -> do + Mining.generate client 1 + + countAfter <- testClient Blockchain.getBlockCount + + length r `shouldBe` 1 + (countBefore + 1) `shouldBe` countAfter diff --git a/test/Network/Bitcoin/Api/MiscSpec.hs b/test/Network/Bitcoin/Api/MiscSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/MiscSpec.hs @@ -0,0 +1,17 @@ +module Network.Bitcoin.Api.MiscSpec where + +import Control.Lens ((^.)) +import qualified Data.Text as T (pack) + +import qualified Network.Bitcoin.Api.Misc as Misc +import Network.Bitcoin.Api.TestUtil (testClient) +import Test.Hspec + +spec :: Spec +spec = do + describe "when testing miscelaneous functions" $ do + it "should be able to return server info" $ do + r <- testClient Misc.getInfo + + r ^. Misc.bitcoinVersion `shouldBe` 100100 + r ^. Misc.bitcoindErrors `shouldBe` (T.pack "") diff --git a/test/Network/Bitcoin/Api/TestUtil.hs b/test/Network/Bitcoin/Api/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/TestUtil.hs @@ -0,0 +1,31 @@ +module Network.Bitcoin.Api.TestUtil (testClient, isStatusCodeException) where + +import qualified Data.Bitcoin.Script as Btc +import qualified Data.Bitcoin.Transaction as Btc +import qualified Data.List as L (find) +import Data.Maybe (isJust, mapMaybe) + +import qualified Data.Text as T (pack) +import Control.Lens ((^.)) + +import Network.HTTP.Client (HttpException (..)) + +import Network.Bitcoin.Api.Client + +import qualified Network.Bitcoin.Api.Blockchain as Blockchain +import qualified Network.Bitcoin.Api.Dump as Dump +import qualified Network.Bitcoin.Api.Mining as Mining +import qualified Network.Bitcoin.Api.Misc as Misc +import qualified Network.Bitcoin.Api.Transaction as Transaction +import Network.Bitcoin.Api.Types.UnspentTransaction (address, amount) +import qualified Network.Bitcoin.Api.Wallet as Wallet +import Network.Wreq.Lens (statusCode) + +import Test.Hspec + +testClient :: (Client -> IO a) -> IO a +testClient = withClient "127.0.0.1" 18332 (T.pack "user") (T.pack "pass") + +isStatusCodeException :: Int -> HttpException -> Bool +isStatusCodeException code (StatusCodeException s _ _) = s ^. statusCode == code +isStatusCodeException _ _ = False diff --git a/test/Network/Bitcoin/Api/WalletSpec.hs b/test/Network/Bitcoin/Api/WalletSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bitcoin/Api/WalletSpec.hs @@ -0,0 +1,45 @@ +module Network.Bitcoin.Api.WalletSpec where + +import qualified Data.List as L (find) +import Data.Maybe (isJust) +import qualified Data.Text as T (pack) + +import qualified Network.Bitcoin.Api.Wallet as Wallet +import Network.Bitcoin.Api.TestUtil (testClient) +import Test.Hspec + +spec :: Spec +spec = do + describe "when testing wallet functions" $ do + it "should be able list unspent transactions" $ do + r <- testClient Wallet.listUnspent + length r `shouldSatisfy` (>= 1) + + it "should be able list all accounts" $ do + r <- testClient Wallet.listAccounts + length r `shouldSatisfy` (>= 1) + + it "should be able to create a new address under the default account" $ do + testClient $ \client -> do + addr <- Wallet.newAddress client + acc <- Wallet.getAddressAccount client addr + + acc `shouldBe` (T.pack "") + + it "should be able to create a new address under a specific account" $ do + testClient $ \client -> do + addr <- Wallet.newAddressWith client (T.pack "testAccount") + acc <- Wallet.getAddressAccount client addr + + acc `shouldBe` (T.pack "testAccount") + + -- Extra validation that the account also appears in the wallet + list <- Wallet.listAccounts client + L.find (\(needle, _) -> needle == T.pack "testAccount") list `shouldSatisfy` isJust + + it "should be able to create a change address" $ do + testClient $ \client -> do + addr <- Wallet.newChangeAddress client + acc <- Wallet.getAddressAccount client addr + + acc `shouldBe` (T.pack "") diff --git a/test/Network/Bitcoin/ClientSpec.hs b/test/Network/Bitcoin/ClientSpec.hs deleted file mode 100644 --- a/test/Network/Bitcoin/ClientSpec.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Network.Bitcoin.ClientSpec where - -import qualified Data.Bitcoin.Script as Btc -import qualified Data.Bitcoin.Transaction as Btc -import qualified Data.List as L (find) -import Data.Maybe (isJust, mapMaybe) - -import qualified Data.Text as T (pack) - -import Network.HTTP.Client (HttpException (..)) - -import Control.Lens ((^.)) -import Network.Bitcoin.Api.Client - -import qualified Network.Bitcoin.Api.Blockchain as Blockchain -import qualified Network.Bitcoin.Api.Dump as Dump -import qualified Network.Bitcoin.Api.Mining as Mining -import qualified Network.Bitcoin.Api.Misc as Misc -import qualified Network.Bitcoin.Api.Transaction as Transaction -import Network.Bitcoin.Api.Types.UnspentTransaction (address, amount) -import qualified Network.Bitcoin.Api.Wallet as Wallet -import Network.Wreq.Lens (statusCode) - -import Test.Hspec - -testClient :: (Client -> IO a) -> IO a -testClient = withClient "127.0.0.1" 18332 (T.pack "user") (T.pack "pass") - -isStatusCodeException :: Int -> HttpException -> Bool -isStatusCodeException code (StatusCodeException s _ _) = s ^. statusCode == code -isStatusCodeException _ _ = False - -spec :: Spec -spec = do - describe "when creating a new client session" $ do - it "callback returns generated value" $ do - testClient (\_ -> return "foo") `shouldReturn` "foo" - - it "fails when providing invalid authentication credentials" $ do - withClient "127.0.0.1" 18332 (T.pack "invaliduser") (T.pack "invalidpass") Misc.getInfo `shouldThrow` isStatusCodeException 401 - - describe "when testing miscelaneous functions" $ do - it "should be able to return server info" $ do - r <- testClient Misc.getInfo - - r ^. Misc.bitcoinVersion `shouldBe` 100100 - r ^. Misc.bitcoindErrors `shouldBe` (T.pack "") - - describe "when testing mining functions" $ do - it "can generate blocks" $ do - countBefore <- testClient Blockchain.getBlockCount - r <- testClient $ \client -> do - Mining.generate client 1 - - countAfter <- testClient Blockchain.getBlockCount - - length r `shouldBe` 1 - (countBefore + 1) `shouldBe` countAfter - - describe "when testing blockchain functions" $ do - it "can request blockcount" $ do - r <- testClient Blockchain.getBlockCount - - r `shouldSatisfy` (>= 100) - - it "can request block hashes" $ do - testClient $ \client -> do - count <- Blockchain.getBlockCount client - hashes <- mapM (Blockchain.getBlockHash client) [0..count - 1] - - fromIntegral (length (hashes)) `shouldBe` count - - it "can request blocks" $ do - testClient $ \client -> do - count <- Blockchain.getBlockCount client - blocks <- mapM (Blockchain.getBlock client) =<< mapM (Blockchain.getBlockHash client) [0..count - 1] - - fromIntegral (length (blocks)) `shouldBe` count - - describe "when testing wallet functions" $ do - it "should be able list unspent transactions" $ do - r <- testClient Wallet.listUnspent - length r `shouldSatisfy` (>= 1) - - it "should be able list all accounts" $ do - r <- testClient Wallet.listAccounts - length r `shouldSatisfy` (>= 1) - - it "should be able to create a new address under the default account" $ do - testClient $ \client -> do - addr <- Wallet.newAddress client - acc <- Wallet.getAddressAccount client addr - - acc `shouldBe` (T.pack "") - - it "should be able to create a new address under a specific account" $ do - testClient $ \client -> do - addr <- Wallet.newAddressWith client (T.pack "testAccount") - acc <- Wallet.getAddressAccount client addr - - acc `shouldBe` (T.pack "testAccount") - - -- Extra validation that the account also appears in the wallet - list <- Wallet.listAccounts client - L.find (\(needle, _) -> needle == T.pack "testAccount") list `shouldSatisfy` isJust - - it "should be able to create a change address" $ do - testClient $ \client -> do - addr <- Wallet.newChangeAddress client - acc <- Wallet.getAddressAccount client addr - - acc `shouldBe` (T.pack "") - - describe "when testing transaction functions" $ do - it "can create transaction" $ do - testClient $ \client -> do - utxs <- Wallet.listUnspent client - addr <- Wallet.newAddress client - tx <- Transaction.create client utxs [(addr, 50)] - - case tx of - (Btc.Transaction 1 _ [(Btc.TransactionOut 5000000000 (Btc.Script _))] 0) -> return () - _ -> expectationFailure ("Result does not match expected: " ++ show tx) - - it "can sign transaction without providing any input transactions" $ do - testClient $ \client -> do - utxs <- Wallet.listUnspent client - addr <- Wallet.newAddress client - tx <- Transaction.create client utxs [(addr, 50)] - (_, completed) <- Transaction.sign client tx Nothing Nothing - - completed `shouldBe` True - - it "can sign transaction when providing any input transactions" $ do - testClient $ \client -> do - utxs <- Wallet.listUnspent client - addr <- Wallet.newAddress client - tx <- Transaction.create client utxs [(addr, 50)] - (_, completed) <- Transaction.sign client tx (Just utxs) Nothing - - completed `shouldBe` True - - it "can sign transaction when providing any explicit signing key" $ do - testClient $ \client -> do - utxs <- Wallet.listUnspent client - addr <- Wallet.newAddress client - - -- Generates an array of private keys of all the input addresses we use - keys <- mapM (Dump.getPrivateKey client) $ mapMaybe (^. address) utxs - - tx <- Transaction.create client utxs [(addr, 50)] - (_, completed) <- Transaction.sign client tx Nothing (Just keys) - - -- This is an important check, since it validates that we are using the - -- correct keys and our manual signing works properly. - completed `shouldBe` True - - it "can send a transaction" $ do - testClient $ \client -> do - utxs <- Wallet.listUnspent client - - (length utxs) `shouldSatisfy` (>= 1) - - -- Calculate the total BTC of all unspent transactions - let btc = foldr (+) 0 $ map (^. amount) utxs - - addr <- Wallet.newAddress client - tx <- Transaction.create client utxs [(addr, (btc - 0.0001))] - (tx', completed) <- Transaction.sign client tx (Just utxs) Nothing - - completed `shouldBe` True - - txid <- Transaction.send client tx' - putStrLn ("txid = " ++ show txid) - True `shouldBe` True - - it "can list transactions" $ do - -- Generate some blocks, so we know for sure that some transactions are in - -- some blocks. - _ <- testClient $ \client -> Mining.generate client 10 - txs <- testClient $ \client -> Transaction.list client Nothing - - -- :TODO: validate that there transactions are in chronological order - length (txs) `shouldSatisfy` (>= 1) - - describe "when testing import/dump functions" $ do - it "should be able to dump private key" $ do - testClient $ \client -> do - addr <- Wallet.newAddress client - r <- Dump.getPrivateKey client addr - - putStrLn ("r = " ++ show r) - True `shouldBe` True