diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.16.2 +### Changed +- Debugging disabled by default (use `--debug` to enable). + ## 0.16.1 ### Added - Cache mempool transactions. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -51,6 +51,7 @@ , configPeers :: ![(Host, Maybe Port)] , configVersion :: !Bool , configCache :: !FilePath + , configDebug :: !Bool } defPort :: Int @@ -93,6 +94,8 @@ value "" configVersion <- switch $ long "version" <> short 'v' <> help "Show version" + configDebug <- + switch $ long "debug" <> help "Show debug messages" return Config {..} networkReader :: String -> Either String Network @@ -124,15 +127,14 @@ {-# NOINLINE myDirectory #-} main :: IO () -main = - runStderrLoggingT $ do - conf <- liftIO (execParser opts) - when (configVersion conf) . liftIO $ do - putStrLn $ showVersion P.version - exitSuccess - when (null (configPeers conf) && not (configDiscover conf)) . liftIO $ - die "ERROR: Specify peers to connect or enable peer discovery." - run conf +main = do + conf <- liftIO (execParser opts) + when (configVersion conf) . liftIO $ do + putStrLn $ showVersion P.version + exitSuccess + when (null (configPeers conf) && not (configDiscover conf)) . liftIO $ + die "ERROR: Specify peers to connect or enable peer discovery." + run conf where opts = info (helper <*> config) $ @@ -144,15 +146,16 @@ cacheDir net "" = Nothing cacheDir net ch = Just (ch getNetworkName net "cache") -run :: (MonadLoggerIO m, MonadUnliftIO m) => Config -> m () +run :: MonadUnliftIO m => Config -> m () run Config { configPort = port , configNetwork = net , configDiscover = disc , configPeers = peers , configCache = cache_path , configDir = db_dir + , configDebug = deb } = - flip finally clear $ do + runStderrLoggingT . filterLogger l . flip finally clear $ do $(logInfoS) "Main" $ "Creating working directory if not found: " <> cs wd createDirectoryIfMissing True wd @@ -209,6 +212,9 @@ } in runWeb wcfg where + l _ lvl + | deb = True + | otherwise = LevelWarn <= lvl clear = case cd of Nothing -> return () diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 7bbe7347a0126be9bd8aec84b19b635f8acc5701fa8600737ea7d974fa5db2ea +-- hash: 00fb171c8008a878671ef153786dde3c35e1dffa240f03a0565c7229c5f6b047 name: haskoin-store -version: 0.16.1 +version: 0.16.2 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network @@ -117,6 +117,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Haskoin.StoreSpec Paths_haskoin_store hs-source-dirs: test @@ -151,3 +152,4 @@ , unliftio , unordered-containers default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/StoreSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Haskoin.StoreSpec (spec) where + +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Trans +import Data.Maybe +import Database.RocksDB (DB) +import Database.RocksDB as R +import Haskoin +import Haskoin.Node +import Haskoin.Store +import NQE +import Test.Hspec +import UnliftIO + +data TestStore = TestStore + { testStoreDB :: !LayeredDB + , testStoreBlockStore :: !BlockStore + , testStoreChain :: !Chain + , testStoreEvents :: !(Inbox StoreEvent) + } + +spec :: Spec +spec = do + let net = btcTest + describe "Download" $ do + it "gets 8 blocks" $ + withTestStore net "eight-blocks" $ \TestStore {..} -> do + bs <- + replicateM 8 . receiveMatch testStoreEvents $ \case + StoreBestBlock b -> Just b + _ -> Nothing + let bestHash = last bs + bestNodeM <- chainGetBlock bestHash testStoreChain + bestNodeM `shouldSatisfy` isJust + let bestNode = fromJust bestNodeM + bestHeight = nodeHeight bestNode + bestHeight `shouldBe` 8 + it "get a block and its transactions" $ + withTestStore net "get-block-txs" $ \TestStore {..} -> + withLayeredDB testStoreDB $ do + let h1 = + "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22" + h2 = + "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c" + get_the_block h = + receive testStoreEvents >>= \case + StoreBestBlock b + | h == 0 -> return b + | otherwise -> + get_the_block ((h :: Int) - 1) + _ -> get_the_block h + bh <- get_the_block 380 + m <- getBlock bh + let bd = fromMaybe (error "Could not get block") m + t1 <- getTransaction h1 + t2 <- getTransaction h2 + lift $ do + blockDataHeight bd `shouldBe` 381 + length (blockDataTxs bd) `shouldBe` 2 + head (blockDataTxs bd) `shouldBe` h1 + last (blockDataTxs bd) `shouldBe` h2 + t1 `shouldSatisfy` isJust + txHash (transactionData (fromJust t1)) `shouldBe` h1 + t2 `shouldSatisfy` isJust + txHash (transactionData (fromJust t2)) `shouldBe` h2 + +withTestStore :: + MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a +withTestStore net t f = + withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> + runNoLoggingT $ do + x <- newInbox + db <- + open + w + defaultOptions + { createIfMissing = True + , errorIfExists = True + , compression = SnappyCompression + } + let ldb = + LayeredDB + { layeredDB = + BlockDB + { blockDB = db + , blockDBopts = defaultReadOptions + } + , layeredCache = Nothing + } + let cfg = + StoreConfig + { storeConfMaxPeers = 20 + , storeConfInitPeers = [] + , storeConfDiscover = True + , storeConfDB = ldb + , storeConfNetwork = net + , storeConfListen = (`sendSTM` x) + } + withStore cfg $ \Store {..} -> + lift $ + f + TestStore + { testStoreDB = ldb + , testStoreBlockStore = storeBlock + , testStoreChain = storeChain + , testStoreEvents = x + } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,109 +1,1 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -import Control.Monad -import Control.Monad.Logger -import Control.Monad.Trans -import Data.Maybe -import Database.RocksDB (DB) -import Database.RocksDB as R -import Haskoin -import Haskoin.Node -import Haskoin.Store -import NQE -import Test.Hspec -import UnliftIO - -data TestStore = TestStore - { testStoreDB :: !LayeredDB - , testStoreBlockStore :: !BlockStore - , testStoreChain :: !Chain - , testStoreEvents :: !(Inbox StoreEvent) - } - -main :: IO () -main = do - let net = btcTest - hspec . describe "Download" $ do - it "gets 8 blocks" $ - withTestStore net "eight-blocks" $ \TestStore {..} -> do - bs <- - replicateM 8 . receiveMatch testStoreEvents $ \case - StoreBestBlock b -> Just b - _ -> Nothing - let bestHash = last bs - bestNodeM <- chainGetBlock bestHash testStoreChain - bestNodeM `shouldSatisfy` isJust - let bestNode = fromJust bestNodeM - bestHeight = nodeHeight bestNode - bestHeight `shouldBe` 8 - it "get a block and its transactions" $ - withTestStore net "get-block-txs" $ \TestStore {..} -> - withLayeredDB testStoreDB $ do - let h1 = - "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22" - h2 = - "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c" - get_the_block h = - receive testStoreEvents >>= \case - StoreBestBlock b - | h == 0 -> return b - | otherwise -> - get_the_block ((h :: Int) - 1) - _ -> get_the_block h - bh <- get_the_block 380 - m <- getBlock bh - let bd = fromMaybe (error "Could not get block") m - t1 <- getTransaction h1 - t2 <- getTransaction h2 - lift $ do - blockDataHeight bd `shouldBe` 381 - length (blockDataTxs bd) `shouldBe` 2 - head (blockDataTxs bd) `shouldBe` h1 - last (blockDataTxs bd) `shouldBe` h2 - t1 `shouldSatisfy` isJust - txHash (transactionData (fromJust t1)) `shouldBe` h1 - t2 `shouldSatisfy` isJust - txHash (transactionData (fromJust t2)) `shouldBe` h2 - -withTestStore :: - MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a -withTestStore net t f = - withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> - runNoLoggingT $ do - x <- newInbox - db <- - open - w - defaultOptions - { createIfMissing = True - , errorIfExists = True - , compression = SnappyCompression - } - let ldb = - LayeredDB - { layeredDB = - BlockDB - { blockDB = db - , blockDBopts = defaultReadOptions - } - , layeredCache = Nothing - } - let cfg = - StoreConfig - { storeConfMaxPeers = 20 - , storeConfInitPeers = [] - , storeConfDiscover = True - , storeConfDB = ldb - , storeConfNetwork = net - , storeConfListen = (`sendSTM` x) - } - withStore cfg $ \Store {..} -> - lift $ - f - TestStore - { testStoreDB = ldb - , testStoreBlockStore = storeBlock - , testStoreChain = storeChain - , testStoreEvents = x - } +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}