upgrades tests to use tasty

README.md

@@ -6,8 +6,9 @@ See the [Hackage documentation](http://hackage.haskell.org/package/network-bitco
 Testing
 ----
 
-The tests expect to run against a `bitcoind` node synced to testnet.  Invoke `bitcoind` with:
+The tests expect to run against a `bitcoind` node running in regtest mode.
+Invoke `bitcoind` with:
 
 ```shell
-$ bitcoind -rpcuser -rpcpassword -testnet
+$ bitcoind -regtest -rpcuser=bitcoinrpc -rpcpassword=bitcoinrpcpassword -rpcport=18444
 ```

network-bitcoin.cabal

@@ -66,9 +66,8 @@ Source-repository head
   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 +83,7 @@ Test-suite network-bitcoin-tests
     base == 4.*,
     time >= 1.4.2,
     QuickCheck >= 2.6,
+    tasty >= 1.0,
+    tasty-quickcheck >= 0.10,
     http-client >= 0.4.6,
     network-bitcoin

src/Network/Bitcoin/Internal.hs

@@ -101,9 +101,9 @@ callApi :: FromJSON v
 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

src/Test/Main.hs

@@ -1,93 +1,98 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+
 
 module Main where
 
 
-import           Data.Fixed              (Fixed (MkFixed))
-import           Data.Vector             (empty)
-import qualified Data.Vector             as V
+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           Test.QuickCheck
 import           Test.QuickCheck.Monadic
+import           Test.Tasty               (TestName, TestTree, defaultMain,
+                                           testGroup)
+import           Test.Tasty.QuickCheck
 
 
 main :: IO ()
-main = mapM_ qcOnce [ canListUnspent
-                    , canGetBlock
-                    , canGetOutputInfo
-                    , canGetRawTransaction
-                    , canGetAddress
-                    , canSendPayment
-                    , canEstimateFees
-                    ]
+main = defaultMain . testGroup "network-bitcoin tests" $
+    [ 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
 
 
-canListUnspent :: Property
-canListUnspent = monadicIO $ do
-    _ <- run $ (\c -> listUnspent c Nothing Nothing Data.Vector.empty) =<< client
+canListUnspent :: TestTree
+canListUnspent = nbTest "listUnspent" $ do
+    _ <- run $ do
+        c <- client
+        listUnspent c Nothing Nothing Data.Vector.empty
     assert True
 
 
 getTopBlock :: Client -> IO Block
 getTopBlock c = getBlockCount c >>= getBlockHash c >>= getBlock c
 
 
-canGetBlock :: Property
-canGetBlock = monadicIO $ do
-    run $ client >>=
-        getTopBlock >>=
-        print
-    assert True
+canGetBlock :: TestTree
+canGetBlock = nbTest "getBlockCount / getBlockHash / getBlock" $ do
+        run $ client >>= getTopBlock
+        assert True
 
 
-canGetRawTransaction :: Property
-canGetRawTransaction = monadicIO $ do
+canGetRawTransaction :: TestTree
+canGetRawTransaction = nbTest "getRawTransactionInfo" $ do
     run $ do
         c <- client
         b <- getTopBlock c
-        getRawTransactionInfo c (subTransactions b V.! 0) >>= print
+        getRawTransactionInfo c (subTransactions b V.! 0)
     assert True
 
 
-canGetOutputInfo :: Property
-canGetOutputInfo = monadicIO $ do
+canGetOutputInfo :: TestTree
+canGetOutputInfo = nbTest "getOutputInfo" $ do
     run $ do
         c <- client
         b <- getTopBlock c
-        getOutputInfo c (subTransactions b V.! 0) 0 >>= print
+        getOutputInfo c (subTransactions b V.! 0) 0
     assert True
 
 
-canEstimateFees :: Property
-canEstimateFees = monadicIO $ do
-    run $ client >>= \c ->
-        estimateSmartFee c 10 Nothing >>= print
-    assert True
-
-
-canGetAddress :: Property
-canGetAddress = monadicIO $ do
+canGetAddress :: TestTree
+canGetAddress = nbTest "getNewAddress" $ do
     run $ do
         c <- client
-        getNewAddress c Nothing >>= print
+        getNewAddress c Nothing
     assert True
 
 
-canSendPayment :: Property
-canSendPayment = monadicIO $ do
-    run $ do
-        c <- client
+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 (MkFixed 10000000) Nothing Nothing >>= print
-    assert True
+        sendToAddress c addr amt Nothing Nothing
+        _ :: [Text] <- callApi c "generate" [ tj (2 :: Int) ]
+        (addr,) <$> listReceivedByAddress c
+
+    assert . V.elem (addr, amt) . fmap f $ recv
+  where
+    f = (,) <$> recvAddress <*> recvAmount