haskoin-store 0.16.1 → 0.16.2
raw patch · 5 files changed
+138/−122 lines, 5 files
Files
- CHANGELOG.md +4/−0
- app/Main.hs +17/−11
- haskoin-store.cabal +4/−2
- test/Haskoin/StoreSpec.hs +112/−0
- test/Spec.hs +1/−109
CHANGELOG.md view
@@ -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.
app/Main.hs view
@@ -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 ()
haskoin-store.cabal view
@@ -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
+ test/Haskoin/StoreSpec.hs view
@@ -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+ }
test/Spec.hs view
@@ -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 #-}