diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.5.16 +version: 1.6.2 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -52,10 +52,10 @@ , deepseq >=1.4.4.0 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 - , haskoin-core >=1.0.0 - , haskoin-node >=1.0.0 - , haskoin-store-data ==1.5.16 - , hedis >=0.12.13 + , haskoin-core >=1.3.0 + , haskoin-node >=1.4.3 + , haskoin-store-data ==1.6.0 + , hedis >=0.16.1 , http-types >=0.12.3 , lens >=4.18.1 , monad-control >=1.0.2.3 @@ -64,8 +64,8 @@ , network >=3.1.1.1 , nqe >=0.6.5 , random >=1.1 - , rocksdb-haskell-jprupp >=2.1.3 - , rocksdb-query >=0.4.0 + , rocksdb-haskell-jprupp >=2.3.0 + , rocksdb-query >=0.6.0 , scotty >=0.22 , statsd-rupp >=0.4 , stm >=2.5.0.0 @@ -105,11 +105,11 @@ , filepath , hashable >=1.3.0.0 , hashtables >=1.2.4.2 - , haskoin-core >=1.0.0 - , haskoin-node >=1.0.0 + , haskoin-core >=1.3.0 + , haskoin-node >=1.4.3 , haskoin-store - , haskoin-store-data ==1.5.16 - , hedis >=0.12.13 + , haskoin-store-data ==1.6.0 + , hedis >=0.16.1 , http-types >=0.12.3 , lens >=4.18.1 , monad-control >=1.0.2.3 @@ -119,8 +119,8 @@ , nqe >=0.6.5 , optparse-applicative , random >=1.1 - , rocksdb-haskell-jprupp >=2.1.3 - , rocksdb-query >=0.4.0 + , rocksdb-haskell-jprupp >=2.3.0 + , rocksdb-query >=0.6.0 , scotty >=0.22 , statsd-rupp >=0.4 , stm >=2.5.0.0 @@ -164,11 +164,11 @@ , deepseq >=1.4.4.0 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 - , haskoin-core >=1.0.0 - , haskoin-node >=1.0.0 + , haskoin-core >=1.3.0 + , haskoin-node >=1.4.3 , haskoin-store - , haskoin-store-data ==1.5.16 - , hedis >=0.12.13 + , haskoin-store-data ==1.6.0 + , hedis >=0.16.1 , hspec >=2.7.1 , http-types >=0.12.3 , lens >=4.18.1 @@ -178,8 +178,8 @@ , network >=3.1.1.1 , nqe >=0.6.5 , random >=1.1 - , rocksdb-haskell-jprupp >=2.1.3 - , rocksdb-query >=0.4.0 + , rocksdb-haskell-jprupp >=2.3.0 + , rocksdb-query >=0.6.0 , scotty >=0.22 , statsd-rupp >=0.4 , stm >=2.5.0.0 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} + module Haskoin.Store ( Store (..), StoreConfig (..), diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -126,7 +126,6 @@ ( Chain, OnlinePeer (..), Peer (..), - PeerException (..), PeerMgr, chainBlockMain, chainGetAncestor, @@ -269,7 +268,7 @@ setHeadersHeight :: (MonadIO m) => BlockT m () setHeadersHeight = void $ runMaybeT $ do m <- MaybeT (asks (.metrics)) - n <- chainGetBest =<< asks (.config.chain) + n <- liftIO . chainGetBest =<< asks (.config.chain) setGauge m.headers (fromIntegral n.height) setPendingTxs :: (MonadIO m) => BlockT m () @@ -281,7 +280,7 @@ setPeersConnected :: (MonadIO m) => BlockT m () setPeersConnected = void $ runMaybeT $ do m <- MaybeT (asks (.metrics)) - p <- getPeers =<< asks (.config.peerMgr) + p <- liftIO . getPeers =<< asks (.config.peerMgr) setGauge m.peers (length p) setMempoolSize :: (MonadIO m) => BlockT m () @@ -473,7 +472,7 @@ $(logErrorS) "BlockStore" "Block database uninitialized" throwIO Uninitialized Just bb -> do - cb <- asks (.config.chain) >>= chainGetBest + cb <- asks (.config.chain) >>= liftIO . chainGetBest if headerHash cb.header == bb then clearSyncingState >> return True else return False @@ -494,7 +493,7 @@ $(logDebugS) "BlockStore" $ "Requesting mempool from peer: " <> p.label atomically . modifyTVar m $ HashSet.insert p.label - MMempool `sendMessage` p + liftIO $ MMempool `sendMessage` p processBlock :: (MonadUnliftIO m, MonadLoggerIO m) => @@ -508,9 +507,9 @@ $(logErrorS) "BlockStore" $ "Non-syncing peer " <> peer.label - <> " sent me a block: " + <> " sent block " <> blockHashToHex blockhash - PeerMisbehaving "Sent unexpected block" `killPeer` peer + killPeer peer mzero node <- getBlockNode blockhash >>= \case @@ -519,14 +518,14 @@ $(logErrorS) "BlockStore" $ "Peer " <> peer.label - <> " sent unknown block: " + <> " sent unknown block " <> blockHashToHex blockhash - PeerMisbehaving "Sent unknown block" `killPeer` peer + killPeer peer mzero $(logDebugS) "BlockStore" $ - "Processing block: " + "Processing block " <> blockText node Nothing - <> " from peer: " + <> " from peer " <> peer.label net <- lift getNetwork ctx <- lift getCtx @@ -557,7 +556,7 @@ <> peer.label <> ": " <> cs (show e) - killPeer (PeerMisbehaving (show e)) peer + killPeer peer setSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => @@ -607,8 +606,9 @@ (MonadLoggerIO m, MonadReader BlockStore m) => BlockHash -> m (Maybe BlockNode) -getBlockNode blockhash = - chainGetBlock blockhash =<< asks (.config.chain) +getBlockNode blockhash = do + ch <- asks (.config.chain) + liftIO $ chainGetBlock ch blockhash processNoBlocks :: (MonadLoggerIO m) => @@ -626,7 +626,7 @@ <> blockHashToHex h <> " not found by peer: " <> p.label - killPeer (PeerMisbehaving "Did not find requested block(s)") p + killPeer p processTx :: (MonadLoggerIO m) => Peer -> Tx -> BlockT m () processTx p tx = guardMempool $ do @@ -832,22 +832,22 @@ pruneMempool :: (MonadLoggerIO m) => BlockT m () pruneMempool = guardMempool . notify Nothing $ do - days <- asks (.config.mempoolTimeout) - when (days > 0) $ do - mempool <- reverse <$> getMempool - time <- (floor . utcTimeToPOSIXSeconds) <$> liftIO getCurrentTime - let thresh = time - (fromIntegral days * 24 * 60 * 60) - txs = take 1000 $ map snd $ takeWhile ((< thresh) . fst) mempool - net <- getNetwork - ctx <- getCtx - when (length txs > 0) $ do - $(logInfoS) "BlockStore" $ - "Deleting " <> cs (show (length txs)) <> " old transactions from mempool" - runImport net ctx (mapM_ (deleteUnconfirmedTx False) txs) >>= \case - Left e -> - $(logErrorS) "BlockStore" $ - "Error pruning mempool: " <> cs (show e) - Right () -> return () + days <- asks (.config.mempoolTimeout) + when (days > 0) $ do + mempool <- reverse <$> getMempool + time <- (floor . utcTimeToPOSIXSeconds) <$> liftIO getCurrentTime + let thresh = time - (fromIntegral days * 24 * 60 * 60) + txs = take 1000 $ map snd $ takeWhile ((< thresh) . fst) mempool + net <- getNetwork + ctx <- getCtx + when (length txs > 0) $ do + $(logInfoS) "BlockStore" $ + "Deleting " <> cs (show (length txs)) <> " old transactions from mempool" + runImport net ctx (mapM_ (deleteUnconfirmedTx False) txs) >>= \case + Left e -> + $(logErrorS) "BlockStore" $ + "Error pruning mempool: " <> cs (show e) + Right () -> return () processTxs :: (MonadLoggerIO m) => @@ -908,7 +908,7 @@ let inv = if net.segWit then InvWitnessTx else InvTx vec = map (InvVector inv . (.get)) xs msg = MGetData (GetData vec) - msg `sendMessage` p + liftIO $ msg `sendMessage` p touchPeer :: ( MonadIO m, @@ -940,7 +940,7 @@ when (now `diffUTCTime` t > peer_time_out) $ do $(logErrorS) "BlockStore" $ "Syncing peer timeout: " <> p.label - killPeer PeerTimeout p + killPeer p revertToMainChain :: (MonadLoggerIO m) => BlockT m () revertToMainChain = do @@ -948,7 +948,7 @@ ch <- asks (.config.chain) net <- getNetwork ctx <- getCtx - chainBlockMain h ch >>= \x -> unless x $ do + liftIO (chainBlockMain ch h) >>= \x -> unless x $ do $(logWarnS) "BlockStore" $ "Reverting best block: " <> blockHashToHex h @@ -972,7 +972,7 @@ $(logErrorS) "BlockStore" "No best block set" throwIO Uninitialized ch <- asks (.config.chain) - chainGetBlock bb ch >>= \case + liftIO (chainGetBlock ch bb) >>= \case Just x -> return x Nothing -> do $(logErrorS) "BlockStore" $ @@ -992,7 +992,7 @@ throwIO Uninitialized hs -> return $ last hs ch <- asks (.config.chain) - chainGetBlock bb ch >>= \case + liftIO (chainGetBlock ch bb) >>= \case Just x -> return x Nothing -> do $(logErrorS) "BlockStore" $ @@ -1028,7 +1028,7 @@ <> " blocks from peer: " <> p.label addSyncingBlocks $ map (headerHash . (.header)) bns - MGetData (GetData iv) `sendMessage` p + liftIO $ MGetData (GetData iv) `sendMessage` p where getiv bns = do w <- asks (.config.net.segWit) @@ -1036,12 +1036,12 @@ f = InvVector i . (.get) . headerHash . (.header) return $ map f bns getbh = - chainGetBest =<< asks (.config.chain) + liftIO . chainGetBest =<< asks (.config.chain) sel bb bh = do let sh = geth bb bh t <- top sh bh ch <- asks (.config.chain) - ps <- chainGetParents (bb.height + 1) t ch + ps <- liftIO $ chainGetParents ch (bb.height + 1) t return $ if 500 > length ps then ps <> [bh] @@ -1060,7 +1060,7 @@ m BlockNode findAncestor height target = do ch <- asks (.config.chain) - chainGetAncestor height target ch >>= \case + liftIO (chainGetAncestor ch height target) >>= \case Just ancestor -> return ancestor Nothing -> do let h = headerHash target.header @@ -1086,7 +1086,7 @@ reset_it box = do atomically $ writeTVar box Nothing $(logDebugS) "BlockStore" $ "Releasing peer: " <> p.label - setFree p + liftIO $ setFree p trySetPeer :: (MonadLoggerIO m) => Peer -> BlockT m Bool trySetPeer p = @@ -1095,7 +1095,7 @@ Nothing -> set_it where set_it = - setBusy p >>= \case + liftIO (setBusy p) >>= \case False -> return False True -> do $(logDebugS) "BlockStore" $ @@ -1126,7 +1126,7 @@ False -> recurse ps True -> syncMe online_peer = do - ops <- getPeers =<< asks (.config.peerMgr) + ops <- liftIO . getPeers =<< asks (.config.peerMgr) let ps = map (.mailbox) ops recurse ps diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -56,6 +56,7 @@ import Data.HashSet qualified as HashSet import Data.IntMap.Strict qualified as I import Data.List (sort) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Maybe ( catMaybes, @@ -629,9 +630,9 @@ xs <- fxs return [ (k, v) - | (k', v') <- xs, - let k = fromRight undefined $ decode k', - let v = fromRight undefined $ decode v' + | (k', v') <- xs, + let k = fromRight undefined $ decode k', + let v = fromRight undefined $ decode v' ] data CacheWriterMessage @@ -718,7 +719,10 @@ Redis.SetOpts { Redis.setSeconds = Just 300, Redis.setMilliseconds = Nothing, - Redis.setCondition = Just Redis.Nx + Redis.setUnixSeconds = Nothing, + Redis.setUnixMilliseconds = Nothing, + Redis.setCondition = Just Redis.Nx, + Redis.setKeepTTL = False } Redis.setOpts l "locked" opts @@ -728,12 +732,15 @@ Redis.SetOpts { Redis.setSeconds = Just 300, Redis.setMilliseconds = Nothing, - Redis.setCondition = Just Redis.Xx + Redis.setUnixSeconds = Nothing, + Redis.setUnixMilliseconds = Nothing, + Redis.setCondition = Just Redis.Xx, + Redis.setKeepTTL = False } Redis.setOpts l "locked" opts unlockIt :: (MonadLoggerIO m) => ByteString -> CacheX m () -unlockIt l = void $ runRedis (Redis.del [l]) +unlockIt l = void . runRedis . Redis.del $ NonEmpty.singleton l withLock :: (MonadLoggerIO m, MonadUnliftIO m) => @@ -861,10 +868,14 @@ Redis.SetOpts { Redis.setSeconds = Just 600, Redis.setMilliseconds = Nothing, - Redis.setCondition = Just Redis.Nx + Redis.setUnixSeconds = Nothing, + Redis.setUnixMilliseconds = Nothing, + Redis.setCondition = Just Redis.Nx, + Redis.setKeepTTL = False } red = Redis.setOpts key "1" opts - unset_index y = when y . void . runRedis $ Redis.del [key] + unset_index y = + when y . void . runRedis . Redis.del $ NonEmpty.singleton key set_index = do conn <- asks (.redis) liftIO (Redis.runRedis conn red) <&> isRight @@ -877,7 +888,7 @@ Nothing -> return False Just bb -> do ch <- asks (.chain) - cb <- chainGetBest ch + cb <- liftIO $ chainGetBest ch return $ cb.height > 0 && headerHash cb.header == bb newBlockC :: @@ -908,18 +919,18 @@ Just best_block_hash -> get_block_node best_block_hash get_block_node block_hash = do ch <- asks (.chain) - chainGetBlock block_hash ch + liftIO $ chainGetBlock ch block_hash get_blocks left_node right_node = do ch <- asks (.chain) - split_node <- chainGetSplitBlock left_node right_node ch + split_node <- liftIO $ chainGetSplitBlock ch left_node right_node let split_node_hash = headerHash split_node.header right_node_hash = headerHash right_node.header if split_node_hash == right_node_hash then return [] else do let fork_height = split_node.height + 1 - left_parents <- chainGetParents fork_height left_node ch - right_parents <- chainGetParents fork_height right_node ch + left_parents <- liftIO $ chainGetParents ch fork_height left_node + right_parents <- liftIO $ chainGetParents ch fork_height right_node let blocks = reverse left_parents <> right_parents <> pure right_node return $ map (headerHash . (.header)) blocks @@ -1251,8 +1262,10 @@ redisRemFromMempool :: (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer) -redisRemFromMempool [] = return (pure 0) -redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs +redisRemFromMempool xs = + case NonEmpty.nonEmpty xs of + Nothing -> return (pure 0) + Just xs' -> zrem mempoolSetKey $ NonEmpty.map encode xs' redisSetAddrInfo :: (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ()) @@ -1287,13 +1300,13 @@ where go addrs = do addrcount <- - case addrs of - [] -> return (pure 0) - _ -> Redis.del (map ((addrPfx <>) . encode) addrs) - txsetcount <- Redis.del [txSetPfx <> encode xpub] - utxocount <- Redis.del [utxoPfx <> encode xpub] - balcount <- Redis.del [balancesPfx <> encode xpub] - x <- Redis.zrem maxKey [encode xpub] + case NonEmpty.nonEmpty addrs of + Nothing -> return (pure 0) + Just addrs' -> Redis.del $ NonEmpty.map ((addrPfx <>) . encode) addrs' + txsetcount <- Redis.del $ NonEmpty.singleton (txSetPfx <> encode xpub) + utxocount <- Redis.del $ NonEmpty.singleton (utxoPfx <> encode xpub) + balcount <- Redis.del $ NonEmpty.singleton (balancesPfx <> encode xpub) + x <- Redis.zrem maxKey $ NonEmpty.singleton (encode xpub) return $ do _ <- x addrs' <- addrcount @@ -1311,8 +1324,10 @@ redisRemXPubTxs :: (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer) -redisRemXPubTxs _ [] = return (pure 0) -redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs) +redisRemXPubTxs xpub txhs = + case NonEmpty.nonEmpty txhs of + Nothing -> return (pure 0) + Just txhs' -> zrem (txSetPfx <> encode xpub) (NonEmpty.map encode txhs') redisAddXPubUnspents :: (Applicative f, RedisCtx m f) => @@ -1330,23 +1345,26 @@ redisRemXPubUnspents _ [] = return (pure 0) redisRemXPubUnspents xpub ops = - zrem (utxoPfx <> encode xpub) (map encode ops) + case NonEmpty.nonEmpty ops of + Nothing -> return (pure 0) + Just ops' -> zrem (utxoPfx <> encode xpub) (NonEmpty.map encode ops') redisAddXPubBalances :: (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) -redisAddXPubBalances _ [] = return (pure ()) -redisAddXPubBalances xpub bals = do - xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries - ys <- forM bals $ \b -> - redisSetAddrInfo - b.balance.address - AddressXPub - { spec = xpub, - path = b.path - } - return $ sequence_ xs >> sequence_ ys - where - entries = map (\b -> (encode b.path, encode b.balance)) bals +redisAddXPubBalances xpub bals = + case NonEmpty.nonEmpty bals of + Nothing -> return (pure ()) + Just bals' -> do + let bs = NonEmpty.map (\b -> (encode b.path, encode b.balance)) bals' + Redis.hset (balancesPfx <> encode xpub) bs + ys <- forM bals' $ \b -> + redisSetAddrInfo + b.balance.address + AddressXPub + { spec = xpub, + path = b.path + } + return $ sequence_ ys redisSetHead :: (RedisCtx m f) => BlockHash -> m (f Redis.Status) redisSetHead bh = Redis.set bestBlockKey (encode bh) @@ -1375,13 +1393,13 @@ | otherwise = zipWith f addrs list where - haschange = any ((== 1) . head . (.path)) xbals + haschange = any ((== 1) . (!! 0) . (.path)) xbals f a p = (a, AddressXPub {spec = xpub, path = p}) - dchain = head addrinfo.path - fbals = filter ((== dchain) . head . (.path)) xbals - maxidx = maximum (map (head . tail . (.path)) fbals) + dchain = addrinfo.path !! 0 + fbals = filter ((== dchain) . (!! 0) . (.path)) xbals + maxidx = maximum (map ((!! 1) . (.path)) fbals) xpub = addrinfo.spec - aidx = (head . tail) addrinfo.path + aidx = addrinfo.path !! 1 ixs = if gap > maxidx - aidx then [maxidx + 1 .. aidx + gap] @@ -1440,8 +1458,7 @@ f t s = ((scoreBlockRef s).timestamp, t) xpubText :: - ( StoreReadBase m - ) => + (StoreReadBase m) => XPubSpec -> CacheX m Text xpubText xpub = do diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -27,16 +27,8 @@ where import Conduit - ( ConduitT, - dropWhileC, - lift, - mapC, - runConduit, - sinkList, - (.|), - ) -import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) +import Control.Monad (forM_) +import Control.Monad.Reader import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits ((.&.)) import Data.ByteString qualified as BS @@ -47,28 +39,14 @@ import Data.Ord (Down (..)) import Data.Serialize (encode) import Data.Word (Word32) -import Database.RocksDB - ( ColumnFamily, - Config (..), - DB (..), - Iterator, - withDBCF, - withIterCF, - ) +import Database.RocksDB hiding (withDB) import Database.RocksDB.Query - ( insert, - matching, - matchingAsListCF, - matchingSkip, - retrieve, - retrieveCF, - ) import Haskoin import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types import System.Metrics.StatsD -import UnliftIO (MonadIO, MonadUnliftIO, bracket_, liftIO) +import UnliftIO type DatabaseReaderT = ReaderT DatabaseReader @@ -96,7 +74,7 @@ dataIters :: !StatGauge } -createDataMetrics :: (MonadIO m) => Stats -> m DataMetrics +createDataMetrics :: Stats -> IO DataMetrics createDataMetrics s = do dataBestCount <- newStatCounter s "db.best_block" n dataBlockCount <- newStatCounter s "db.blocks" n @@ -134,19 +112,20 @@ Maybe DataMetrics -> DatabaseReaderT m a -> m a -withDatabaseReader net ctx igap gap dir bloom stats f = - withDBCF dir cfg (columnFamilyConfig bloom) $ \db -> do - let bdb = - DatabaseReader - { db = db, - maxGap = gap, - net = net, - initGap = igap, - metrics = stats, - ctx = ctx - } - initRocksDB bdb - runReaderT f bdb +withDatabaseReader net ctx igap gap dir bloom stats m = + withRunInIO $ \run -> + withDBCF dir cfg (columnFamilyConfig bloom) $ \db -> do + let bdb = + DatabaseReader + { db = db, + maxGap = gap, + net = net, + initGap = igap, + metrics = stats, + ctx = ctx + } + initRocksDB bdb + run $ runReaderT m bdb where cfg = def {createIfMissing = True} @@ -163,7 +142,7 @@ ] addrTxCF :: DB -> ColumnFamily -addrTxCF = head . columnFamilies +addrTxCF db = columnFamilies db !! 0 addrOutCF :: DB -> ColumnFamily addrOutCF db = columnFamilies db !! 1 @@ -183,81 +162,93 @@ balanceCF :: DB -> ColumnFamily balanceCF db = columnFamilies db !! 7 -initRocksDB :: (MonadIO m) => DatabaseReader -> m () -initRocksDB DatabaseReader {db = db} = do - e <- - runExceptT $ - retrieve db VersionKey >>= \case - Just v - | v == dataVersion -> return () - | otherwise -> throwError "Incorrect RocksDB database version" - Nothing -> setInitRocksDB db - case e of - Left s -> error s - Right () -> return () +initRocksDB :: DatabaseReader -> IO () +initRocksDB DatabaseReader {db = db} = + retrieve db VersionKey >>= \case + Just v + | v == dataVersion -> return () + | otherwise -> error "Incorrect RocksDB database version" + Nothing -> setInitRocksDB db -setInitRocksDB :: (MonadIO m) => DB -> m () +setInitRocksDB :: DB -> IO () setInitRocksDB db = insert db VersionKey dataVersion addressConduit :: - (MonadUnliftIO m) => + (MonadIO m) => Address -> Maybe Start -> Iterator -> ConduitT i TxRef (DatabaseReaderT m) () -addressConduit a s it = - x .| mapC (uncurry f) +addressConduit a s it = do + pipe .| mapC (uncurry f) where f (AddrTxKey _ t) () = t f _ _ = undefined - x = case s of + pipe = case s of Nothing -> - matching it (AddrTxKeyA a) + readerC $ \_ -> + transPipe liftIO $ + matching it (AddrTxKeyA a) Just (AtBlock bh) -> - matchingSkip - it - (AddrTxKeyA a) - (AddrTxKeyB a (BlockRef bh maxBound)) + readerC $ \_ -> + transPipe liftIO $ + matchingSkip + it + (AddrTxKeyA a) + (AddrTxKeyB a (BlockRef bh maxBound)) Just (AtTx txh) -> lift (getTxData txh) >>= \case Just TxData {block = b@BlockRef {}} -> - matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) + readerC $ \_ -> + transPipe liftIO $ + matchingSkip + it + (AddrTxKeyA a) + (AddrTxKeyB a b) Just TxData {block = MemRef {}} -> let cond (AddrTxKey _ (TxRef MemRef {} th)) = th /= txh cond (AddrTxKey _ (TxRef BlockRef {} _)) = False cond _ = undefined - in matching it (AddrTxKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) + in readerC $ \_ -> + transPipe liftIO $ + matching it (AddrTxKeyA a) + .| (dropWhileC (cond . fst) >> mapC id) Nothing -> return () unspentConduit :: - (MonadUnliftIO m) => + (MonadIO m) => Ctx -> Address -> Maybe Start -> Iterator -> ConduitT i Unspent (DatabaseReaderT m) () unspentConduit ctx a s it = - x .| mapC (uncurry (toUnspent ctx)) + x .| mapC (uncurry (toUnspent ctx)) .| concatC where x = case s of Nothing -> - matching it (AddrOutKeyA a) + readerC $ \_ -> transPipe liftIO $ matching it (AddrOutKeyA a) Just (AtBlock h) -> - matchingSkip - it - (AddrOutKeyA a) - (AddrOutKeyB a (BlockRef h maxBound)) + readerC $ \_ -> + transPipe liftIO $ + matchingSkip + it + (AddrOutKeyA a) + (AddrOutKeyB a (BlockRef h maxBound)) Just (AtTx txh) -> lift (getTxData txh) >>= \case Just TxData {block = b@BlockRef {}} -> - matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) + readerC $ \_ -> + transPipe liftIO $ + matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) Just TxData {block = MemRef {}} -> let cond (AddrOutKey _ MemRef {} p) = p.hash /= txh cond (AddrOutKey _ BlockRef {} _) = False cond _ = undefined - in matching it (AddrOutKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) + in readerC $ \_ -> + transPipe liftIO $ + matching it (AddrOutKeyA a) + .| (dropWhileC (cond . fst) >> mapC id) Nothing -> return () withIterCFStat :: @@ -266,10 +257,16 @@ ColumnFamily -> (Iterator -> DatabaseReaderT m a) -> DatabaseReaderT m a -withIterCFStat db cf = bracket_ open close . withIterCF db cf +withIterCFStat db cf f = do + m <- asks (.metrics) + bracket_ (open m) (close m) go where - open = asks (.metrics) >>= mapM_ (\m -> incrementGauge m.dataIters 1) - close = asks (.metrics) >>= mapM_ (\m -> decrementGauge m.dataIters 1) + open (Just m) = incrementGauge m.dataIters 1 + open Nothing = return () + close (Just m) = decrementGauge m.dataIters 1 + close Nothing = return () + go = withRunInIO $ \run -> + withIterCF db cf $ \it -> run (f it) withManyIters :: (MonadUnliftIO m) => @@ -297,7 +294,7 @@ getTxData th = do db <- asks (.db) - retrieveCF db (txCF db) (TxKey th) >>= \case + liftIO (retrieveCF db (txCF db) (TxKey th)) >>= \case Nothing -> return Nothing Just t -> do withMetrics $ \s -> incrementCounter s.dataTxCount 1 @@ -311,7 +308,7 @@ getUnspent p = do db <- asks (.db) ctx <- asks (.ctx) - val <- retrieveCF db (unspentCF db) (UnspentKey p) + val <- liftIO (retrieveCF db (unspentCF db) (UnspentKey p)) case fmap (valToUnspent ctx p) val of Nothing -> return Nothing Just u -> do @@ -321,20 +318,20 @@ getBalance a = do db <- asks (.db) withMetrics $ \s -> incrementCounter s.dataBalanceCount 1 - fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) + fmap (valToBalance a) <$> liftIO (retrieveCF db (balanceCF db) (BalKey a)) getMempool = do db <- asks (.db) withMetrics $ \s -> incrementCounter s.dataMempoolCount 1 - fromMaybe [] <$> retrieve db MemKey + fromMaybe [] <$> liftIO (retrieve db MemKey) getBestBlock = do withMetrics $ \s -> incrementCounter s.dataBestCount 1 - asks (.db) >>= (`retrieve` BestKey) + asks (.db) >>= liftIO . (`retrieve` BestKey) getBlocksAtHeight h = do db <- asks (.db) - retrieveCF db (heightCF db) (HeightKey h) >>= \case + liftIO (retrieveCF db (heightCF db) (HeightKey h)) >>= \case Nothing -> return [] Just ls -> do withMetrics $ \s -> incrementCounter s.dataBlockCount (length ls) @@ -342,7 +339,7 @@ getBlock h = do db <- asks (.db) - retrieveCF db (blockCF db) (BlockKey h) >>= \case + liftIO (retrieveCF db (blockCF db) (BlockKey h)) >>= \case Nothing -> return Nothing Just b -> do withMetrics $ \s -> incrementCounter s.dataBlockCount 1 @@ -395,17 +392,16 @@ getInitialGap = asks (.initGap) - getNumTxData i = do - db <- asks (.db) + getNumTxData i = ReaderT $ \r -> do let (sk, w) = decodeTxKey i - ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk) + ls <- liftIO $ matchingAsListCF r.db (txCF r.db) (TxKeyS sk) let f t = let bs = encode $ txHash t.tx b = BS.head (BS.drop 6 bs) w' = b .&. 0xf8 in w == w' txs = filter f $ map snd ls - withMetrics $ \s -> incrementCounter s.dataTxCount (length txs) + forM_ r.metrics $ \s -> incrementCounter s.dataTxCount (length txs) return txs getBalances as = do @@ -416,8 +412,8 @@ xPubBals xpub = do ctx <- asks (.ctx) - igap <- getInitialGap - gap <- getMaxGap + igap <- asks (.initGap) + gap <- asks (.maxGap) ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv ctx 0 0)) if all nullxb ext1 then do diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} @@ -77,38 +78,26 @@ -- | Database key for an address transaction. data AddrTxKey = -- | key for a transaction affecting an address - AddrTxKey - { address :: !Address, - tx :: !TxRef - } + AddrTxKey !Address !TxRef | -- | short key that matches all entries - AddrTxKeyA - { address :: !Address - } - | AddrTxKeyB - { address :: !Address, - block :: !BlockRef - } + AddrTxKeyA !Address + | AddrTxKeyB !Address !BlockRef | AddrTxKeyS deriving (Show, Eq, Ord, Generic, Hashable) instance Serialize AddrTxKey where -- 0x05 · Address · BlockRef · TxHash - put - AddrTxKey - { address = a, - tx = TxRef {block = b, txid = t} - } = do - put AddrTxKeyB {address = a, block = b} - put t + put (AddrTxKey a TxRef {block = b, txid = t}) = do + put (AddrTxKeyB a b) + put t -- 0x05 · Address - put AddrTxKeyA {address = a} = do + put (AddrTxKeyA a) = do put AddrTxKeyS put a -- 0x05 · Address · BlockRef - put AddrTxKeyB {address = a, block = b} = do - put AddrTxKeyA {address = a} + put (AddrTxKeyB a b) = do + put (AddrTxKeyA a) put b -- 0x05 put AddrTxKeyS = putWord8 0x05 @@ -117,11 +106,7 @@ a <- get b <- get t <- get - return - AddrTxKey - { address = a, - tx = TxRef {block = b, txid = t} - } + return $ AddrTxKey a TxRef {block = b, txid = t} instance Key AddrTxKey @@ -130,34 +115,25 @@ -- | Database key for an address output. data AddrOutKey = -- | full key - AddrOutKey - { address :: !Address, - block :: !BlockRef, - outpoint :: !OutPoint - } + AddrOutKey !Address !BlockRef !OutPoint | -- | short key for all spent or unspent outputs - AddrOutKeyA - { address :: !Address - } - | AddrOutKeyB - { address :: !Address, - block :: !BlockRef - } + AddrOutKeyA !Address + | AddrOutKeyB !Address !BlockRef | AddrOutKeyS deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize AddrOutKey where -- 0x06 · StoreAddr · BlockRef · OutPoint - put AddrOutKey {address = a, block = b, outpoint = p} = do - put AddrOutKeyB {address = a, block = b} + put (AddrOutKey a b p) = do + put (AddrOutKeyB a b) put p -- 0x06 · StoreAddr · BlockRef - put AddrOutKeyB {address = a, block = b} = do - put AddrOutKeyA {address = a} + put (AddrOutKeyB a b) = do + put (AddrOutKeyA a) put b -- 0x06 · StoreAddr - put AddrOutKeyA {address = a} = do + put (AddrOutKeyA a) = do put AddrOutKeyS put a -- 0x06 @@ -168,18 +144,15 @@ instance Key AddrOutKey -data OutVal = OutVal - { value :: !Word64, - script :: !ByteString - } +data OutVal = OutVal !Word64 !ByteString deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) instance KeyValue AddrOutKey OutVal -- | Transaction database key. data TxKey - = TxKey {txid :: TxHash} - | TxKeyS {short :: (Word32, Word16)} + = TxKey !TxHash + | TxKeyS !(Word32, Word16) deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize TxKey where @@ -200,11 +173,14 @@ wb = masked `shift` 11 bs = runPut (putWord64be wb) g = do - w1 <- getWord32be - w2 <- getWord16be - w3 <- getWord8 - return (w1, w2, w3) - Right (w1, w2, w3) = runGet g bs + w1' <- getWord32be + w2' <- getWord16be + w3' <- getWord8 + return (w1', w2', w3') + (w1, w2, w3) = + case runGet g bs of + Right x -> x + Left e -> error e in ((w1, w2), w3) instance Key TxKey @@ -213,19 +189,19 @@ -- | Unspent output database key. data UnspentKey - = UnspentKey {outpoint :: !OutPoint} - | UnspentKeyS {txid :: !TxHash} + = UnspentKey !OutPoint + | UnspentKeyS !TxHash | UnspentKeyB deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize UnspentKey where -- 0x09 · TxHash · Index - put UnspentKey {outpoint = OutPoint {hash = h, index = i}} = do + put (UnspentKey OutPoint {hash = h, index = i}) = do putWord8 0x09 put h put i -- 0x09 · TxHash - put UnspentKeyS {txid = t} = do + put (UnspentKeyS t) = do putWord8 0x09 put t -- 0x09 @@ -240,15 +216,17 @@ instance KeyValue UnspentKey UnspentVal -toUnspent :: Ctx -> AddrOutKey -> OutVal -> Unspent -toUnspent ctx AddrOutKey {..} OutVal {..} = - Unspent - { block = block, - value = value, - script = script, - outpoint = outpoint, - address = eitherToMaybe (scriptToAddressBS ctx script) - } +toUnspent :: Ctx -> AddrOutKey -> OutVal -> Maybe Unspent +toUnspent ctx (AddrOutKey _address block outpoint) (OutVal value script) = + Just + Unspent + { block = block, + value = value, + script = script, + outpoint = outpoint, + address = eitherToMaybe (scriptToAddressBS ctx script) + } +toUnspent _ _ _ = Nothing -- | Mempool transaction database key. data MemKey @@ -267,9 +245,7 @@ instance KeyValue MemKey [(UnixTime, TxHash)] -- | Block entry database key. -newtype BlockKey = BlockKey - { hash :: BlockHash - } +newtype BlockKey = BlockKey BlockHash deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BlockKey where @@ -286,9 +262,7 @@ instance KeyValue BlockKey BlockData -- | Block height database key. -newtype HeightKey = HeightKey - { height :: BlockHeight - } +newtype HeightKey = HeightKey BlockHeight deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize HeightKey where @@ -306,9 +280,7 @@ -- | Address balance database key. data BalKey - = BalKey - { address :: !Address - } + = BalKey !Address | BalKeyS deriving (Show, Read, Eq, Ord, Generic, Hashable) @@ -328,8 +300,7 @@ instance KeyValue BalKey BalVal -- | Key for best block in database. -data BestKey - = BestKey +data BestKey = BestKey deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BestKey where @@ -344,8 +315,7 @@ instance KeyValue BestKey BlockHash -- | Key for database version. -data VersionKey - = VersionKey +data VersionKey = VersionKey deriving (Eq, Show, Read, Ord, Generic, Hashable) instance Serialize VersionKey where diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -124,7 +124,7 @@ liftIO $ H.insert outputTable k (Just v) where k = (a, u.block, u.outpoint) - v = OutVal {value = u.value, script = u.script} + v = OutVal u.value u.script deleteAddrUnspent a u = ReaderT $ \Writer {memory = Memory {..}} -> liftIO $ H.insert outputTable k Nothing @@ -169,7 +169,7 @@ hm <- newMemory net ctx mempool x <- R.runReaderT f Writer {reader = bdb, memory = hm} ops <- hashMapOps db hm - writeBatch db ops + liftIO $ writeBatch db ops return x hashMapOps :: (MonadIO m) => DB -> Memory -> m [BatchOp] @@ -229,21 +229,12 @@ f (a, b, p) (Just l) = insertOpCF (addrOutCF db) - ( AddrOutKey - { address = a, - block = b, - outpoint = p - } - ) + (AddrOutKey a b p) l f (a, b, p) Nothing = deleteOpCF (addrOutCF db) - AddrOutKey - { address = a, - block = b, - outpoint = p - } + (AddrOutKey a b p) mempoolOp :: (MonadIO m) => MempoolTable -> m [BatchOp] mempoolOp t = diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -173,12 +173,12 @@ insertBlock bd {main = False} $(logDebugS) "BlockStore" $ "Updated as not in main chain: " <> blockHashToHex bh - forM_ (tail tds) unConfirmTx + forM_ (drop 1 tds) unConfirmTx $(logDebugS) "BlockStore" $ "Unconfirmed " <> cs (show (length tds)) <> " transactions" - deleteConfirmedTx (txHash (head tds).tx) + deleteConfirmedTx (txHash (tds !! 0).tx) $(logDebugS) "BlockStore" $ - "Deleted coinbase: " <> txHashToHex (txHash (head tds).tx) + "Deleted coinbase: " <> txHashToHex (txHash (tds !! 0).tx) checkNewBlock :: (MonadImport m) => Block -> BlockNode -> m () checkNewBlock b n = @@ -267,7 +267,7 @@ return (bd, tds) where ts_out_val = - sum $ map (sum . map (.value) . (.outputs)) $ tail $ b.txs + sum $ map (sum . map (.value) . (.outputs)) (drop 1 b.txs) w = let f t = (t :: Tx) {witness = []} b' = (b :: Block) {txs = map f b.txs} diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -98,6 +98,7 @@ MonadUnliftIO, STM, atomically, + liftIO, link, withAsync, ) @@ -196,7 +197,7 @@ DatabaseReaderT m a -> m a connectDB cfg f = do - stats <- mapM createDataMetrics cfg.stats + stats <- liftIO $ mapM createDataMetrics cfg.stats withDatabaseReader cfg.net cfg.ctx @@ -347,15 +348,15 @@ MNotFound (NotFound is) -> do let blocks = [ BlockHash h - | InvVector t h <- is, - t == InvBlock || t == InvWitnessBlock + | InvVector t h <- is, + t == InvBlock || t == InvWitnessBlock ] unless (null blocks) $ blockStoreNotFoundSTM p blocks b MInv (Inv is) -> do let txs = [ TxHash h - | InvVector t h <- is, - t == InvTx || t == InvWitnessTx + | InvVector t h <- is, + t == InvTx || t == InvWitnessTx ] publishSTM (StoreTxAnnounce p txs) pub unless (null txs) $ blockStoreTxHashSTM p txs b diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -87,7 +87,6 @@ ( encodingToLazyByteString, list, ) -import Data.Aeson.Text (encodeToLazyText) import Data.Base16.Types (assertBase16) import Data.ByteString.Base16 (decodeBase16, isBase16) import Data.ByteString.Builder (lazyByteString) @@ -120,7 +119,6 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Text.Lazy (toStrict) import Data.Text.Lazy qualified as TL import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) @@ -526,7 +524,7 @@ healthCheckLoop v = forever $ do threadDelay (config.healthCheckInterval * 1000 * 1000) runHealthCheck >>= atomically . writeTVar v - opts = def {S.settings = settings defaultSettings} + opts = S.defaultOptions {S.settings = settings defaultSettings} settings = setPort config.port . setHost (fromString config.host) getRates :: @@ -1185,15 +1183,15 @@ Tx -> m () publishTx cfg tx = do - ps <- getPeers cfg.store.peerMgr + ps <- liftIO $ getPeers cfg.store.peerMgr let c = max 1 (length ps `div` 2) forM_ (take c ps) $ \p -> do - sendMessage (MTx tx) p.mailbox + liftIO $ sendMessage (MTx tx) p.mailbox void . async $ do threadDelay (5 * 1000 * 1000) let v = if cfg.store.net.segWit then InvWitnessTx else InvTx g = MGetData (GetData [InvVector v (txHash tx).get]) - sendMessage g p.mailbox + liftIO $ sendMessage g p.mailbox -- GET Mempool / Events -- @@ -1482,7 +1480,7 @@ getChainHeight :: (MonadUnliftIO m) => ActionT m H.BlockHeight getChainHeight = - fmap (.height) $ chainGetBest =<< askl (.config.store.chain) + fmap (.height) $ liftIO . chainGetBest =<< askl (.config.store.chain) scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => ActionT m () scottyBinfoUnspent = @@ -2073,7 +2071,7 @@ withMetrics (.binfoQaddressfirstseen) $ do a <- getAddress =<< S.captureParam "addr" ch <- askl (.config.store.chain) - bb <- chainGetBest ch + bb <- liftIO $ chainGetBest ch let top = bb.height bot = 0 i <- go ch bb a bot top @@ -2093,7 +2091,7 @@ | z -> go ch bb a mid top | otherwise -> return 0 getblocktime ch bb h = - chainGetAncestor h bb ch >>= \case + liftIO (chainGetAncestor ch h bb) >>= \case Just b -> return b.header.timestamp Nothing -> do lift . $(logErrorS) "Web" $ @@ -2331,7 +2329,7 @@ scottyBinfoGetBlockCount = withMetrics (.binfoQgetblockcount) $ do ch <- askl (.config.store.chain) - bn <- chainGetBest ch + bn <- liftIO $ chainGetBest ch setHeaders S.text $ TL.pack $ show bn.height @@ -2339,7 +2337,7 @@ scottyBinfoLatestHash = withMetrics (.binfoQlatesthash) $ do ch <- askl (.config.store.chain) - bn <- chainGetBest ch + bn <- liftIO $ chainGetBest ch setHeaders S.text $ TL.fromStrict $ H.blockHashToHex $ H.headerHash bn.header @@ -2348,7 +2346,7 @@ withMetrics (.binfoQbcperblock) $ do ch <- askl (.config.store.chain) net <- askl (.config.store.net) - bn <- chainGetBest ch + bn <- liftIO $ chainGetBest ch setHeaders S.text $ cs $ @@ -2362,7 +2360,13 @@ withMetrics (.binfoQaddresstohash) $ do addr <- getAddress =<< S.captureParam "addr" setHeaders - S.text $ encodeHexLazy $ runPutL $ serialize addr.hash160 + if + | Just h <- addressHash160 addr -> + S.text $ encodeHexLazy $ runPutL $ serialize h + | Just h <- addressHash256 addr -> + S.text $ encodeHexLazy $ runPutL $ serialize h + | otherwise -> + return () scottyBinfoHashToAddr :: (MonadUnliftIO m) => ActionT m () scottyBinfoHashToAddr = @@ -2444,7 +2448,13 @@ Nothing -> raise $ UserError "Could not decode public key" Just pk -> return $ pubKeyAddr ctx pk setHeaders - S.text $ encodeHexLazy $ runPutL $ serialize addr.hash160 + if + | Just h <- addressHash160 addr -> + S.text $ encodeHexLazy $ runPutL $ serialize h + | Just h <- addressHash256 addr -> + S.text $ encodeHexLazy $ runPutL $ serialize h + | otherwise -> + return () -- GET Network Information -- @@ -2460,7 +2470,7 @@ getPeersInformation :: (MonadLoggerIO m) => PeerMgr -> m [PeerInfo] getPeersInformation mgr = - mapMaybe toInfo <$> getPeers mgr + mapMaybe toInfo <$> liftIO (getPeers mgr) where toInfo op = do ver <- op.version @@ -2487,7 +2497,7 @@ m BlockHealth blockHealthCheck cfg = do let ch = cfg.store.chain - headers <- (.height) <$> chainGetBest ch + headers <- (.height) <$> liftIO (chainGetBest ch) blocks <- maybe 0 (.height) <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock) @@ -2505,7 +2515,7 @@ m TimeHealth lastBlockHealthCheck ch WebLimits {blockTimeout} = do n <- round <$> liftIO getPOSIXTime - t <- fromIntegral . (.header.timestamp) <$> chainGetBest ch + t <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch) return TimeHealth { age = n - t, @@ -2518,7 +2528,7 @@ m TimeHealth lastTxHealthCheck WebConfig {noMempool, store = store', limits} = do n <- round <$> liftIO getPOSIXTime - b <- fromIntegral . (.header.timestamp) <$> chainGetBest ch + b <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch) t <- getMempool >>= \case t : _ -> @@ -2554,13 +2564,11 @@ WebConfig -> m CountHealth peerHealthCheck cfg = do - count <- fromIntegral . length <$> getPeers cfg.store.peerMgr + count <- fromIntegral . length <$> liftIO (getPeers cfg.store.peerMgr) return CountHealth {min = fromIntegral cfg.minPeers, count} healthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m HealthCheck + (MonadUnliftIO m, StoreReadBase m) => WebConfig -> m HealthCheck healthCheck cfg = do blocks <- blockHealthCheck cfg lastBlock <- lastBlockHealthCheck cfg.store.chain cfg.limits @@ -2568,23 +2576,19 @@ pendingTxs <- pendingTxsHealthCheck cfg peers <- peerHealthCheck cfg time <- round <$> liftIO getPOSIXTime - let check = - HealthCheck - { network = cfg.store.net.name, - version = cfg.version, - .. - } - unless (isOK check) $ do - let t = toStrict $ encodeToLazyText check - $(logErrorS) "Web" $ "Health check failed: " <> t - return check + return + HealthCheck + { network = cfg.store.net.name, + version = cfg.version, + .. + } scottyDbStats :: (MonadUnliftIO m) => ActionT m () scottyDbStats = withMetrics (.db) $ do setHeaders db <- askl (.config.store.db.db) - statsM <- lift (getProperty db Stats) + statsM <- liftIO (getProperty db Stats) S.text $ maybe "Could not get stats" cs statsM ----------------------- diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -18,7 +18,7 @@ import Data.ByteString.Base64 import Data.Either import Data.List (find) -import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe) +import Data.Maybe import Data.Serialize import Data.Time.Clock.POSIX import Data.Word @@ -47,7 +47,7 @@ StoreBestBlock b -> Just b _ -> Nothing let bestHash = last bs - bestNodeM <- chainGetBlock bestHash testStoreChain + bestNodeM <- liftIO $ chainGetBlock testStoreChain bestHash bestNodeM `shouldSatisfy` isJust let bestNode = fromJust bestNodeM bestHeight = bestNode.height @@ -70,9 +70,8 @@ lift $ do bd.height `shouldBe` 15 length bd.txs `shouldBe` 1 - head bd.txs `shouldBe` h1 - t1 `shouldSatisfy` isJust - txHash (transactionData (fromJust t1)) `shouldBe` h1 + listToMaybe bd.txs `shouldBe` Just h1 + fmap (txHash . transactionData) t1 `shouldBe` Just h1 withTestStore :: (MonadUnliftIO m) =>