diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,13 @@ 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.65.0 +### Changed +- Spenders now embedded into tx objects in database for performance. +- Use faster IORef instead of slow TVar when ingesting. +- Use mutable hash tables when ingesting. +- Allow to disable unscalable API endpoints. + ## 0.64.19 ### Added - Allow to set query timeouts. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -118,7 +118,9 @@ configStatsdPrefix :: !String, configWebPriceGet :: !Int, configWebTickerURL :: !String, - configWebHistoryURL :: !String + configWebHistoryURL :: !String, + configWebNoBlockchain :: !Bool, + configWebNoSlow :: !Bool } instance Default Config where @@ -153,7 +155,9 @@ configStatsdPrefix = defStatsdPrefix, configWebPriceGet = defWebPriceGet, configWebTickerURL = defWebTickerURL, - configWebHistoryURL = defWebHistoryURL + configWebHistoryURL = defWebHistoryURL, + configWebNoBlockchain = defWebNoBlockchain, + configWebNoSlow = defWebNoSlow } defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a @@ -262,6 +266,18 @@ } {-# NOINLINE defWebLimits #-} +defWebNoBlockchain :: Bool +defWebNoBlockchain = + unsafePerformIO $ + defEnv "NO_BLOCKCHAIN" False parseBool +{-# NOINLINE defWebNoBlockchain #-} + +defWebNoSlow :: Bool +defWebNoSlow = + unsafePerformIO $ + defEnv "NO_SLOW" False parseBool +{-# NOINLINE defWebNoSlow #-} + defWebTimeouts :: WebTimeouts defWebTimeouts = unsafePerformIO $ do block_timeout <- defEnv "BLOCK_TIMEOUT" (blockTimeout def) readMaybe @@ -614,6 +630,10 @@ <> help "How often to retrieve price information" <> showDefault <> value (configWebPriceGet def) + configWebNoBlockchain <- + flag (configWebNoBlockchain def) False $ + long "no-blockchain" + <> help "Disable Blockchain.info compatibility layer" configWebTickerURL <- strOption $ metavar "URL" @@ -628,6 +648,10 @@ <> help "Blockchain.info price history URL" <> showDefault <> value (configWebHistoryURL def) + configWebNoSlow <- + flag (configWebNoSlow def) False $ + long "no-slow" + <> help "Disable non-scalable API calls (recommend also --no-blockchain)" pure Config { configWebLimits = WebLimits {..}, @@ -708,7 +732,9 @@ configStatsdPrefix = statsdpfx, configWebPriceGet = wpget, configWebTickerURL = wturl, - configWebHistoryURL = whurl + configWebHistoryURL = whurl, + configWebNoSlow = no_slow, + configWebNoBlockchain = no_blockchain } = runStderrLoggingT . filterLogger l . with_stats $ \stats -> do net <- case networkReader net_str of @@ -757,7 +783,9 @@ webStats = stats, webPriceGet = wpget, webTickerURL = wturl, - webHistoryURL = whurl + webHistoryURL = whurl, + webSlow = not no_slow, + webBlockchain = not no_blockchain } where with_stats go diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 0.64.19 +version: 0.65.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -58,9 +58,10 @@ , ekg-statsd >=0.2.5 , foldl >=1.4.10 , hashable >=1.3.0.0 + , hashtables >=1.2.4.2 , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.64.19 + , haskoin-store-data ==0.65.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -113,10 +114,11 @@ , filepath , foldl >=1.4.10 , hashable >=1.3.0.0 + , hashtables >=1.2.4.2 , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.64.19 + , haskoin-store-data ==0.65.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -174,10 +176,11 @@ , ekg-statsd >=0.2.5 , foldl >=1.4.10 , hashable >=1.3.0.0 + , hashtables >=1.2.4.2 , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.64.19 + , haskoin-store-data ==0.65.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -26,7 +26,6 @@ -- * Useful Fuctions getTransaction, getDefaultBalance, - getSpenders, getActiveTxData, blockAtOrBefore, diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -19,7 +19,6 @@ getActiveBlock, getActiveTxData, getDefaultBalance, - getSpenders, getTransaction, getNumTransaction, blockAtOrAfter, @@ -178,8 +177,6 @@ insertBlock :: BlockData -> m () setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m () insertTx :: TxData -> m () - insertSpender :: OutPoint -> Spender -> m () - deleteSpender :: OutPoint -> m () insertAddrTx :: Address -> TxRef -> m () deleteAddrTx :: Address -> TxRef -> m () insertAddrUnspent :: Address -> Unspent -> m () @@ -190,16 +187,6 @@ insertUnspent :: Unspent -> m () deleteUnspent :: OutPoint -> m () -getSpenders :: StoreReadBase m => TxHash -> m (IntMap Spender) -getSpenders th = - getActiveTxData th >>= \case - Nothing -> return I.empty - Just td -> - I.fromList . catMaybes - <$> mapM get_spender [0 .. length (txOut (txData td)) - 1] - where - get_spender i = fmap (i,) <$> getSpender (OutPoint th (fromIntegral i)) - getActiveBlock :: StoreReadExtra m => BlockHash -> m (Maybe BlockData) getActiveBlock bh = getBlock bh >>= \case @@ -246,18 +233,11 @@ getTransaction :: (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) -getTransaction h = runMaybeT $ do - d <- MaybeT $ getTxData h - sm <- lift $ getSpenders h - return $ toTransaction d sm +getTransaction h = fmap toTransaction <$> getTxData h getNumTransaction :: (Monad m, StoreReadExtra m) => Word64 -> m [Transaction] -getNumTransaction i = do - ds <- getNumTxData i - forM ds $ \d -> do - sm <- getSpenders (txHash (txData d)) - return $ toTransaction d sm +getNumTransaction i = map toTransaction <$> getNumTxData i blockAtOrAfter :: (MonadIO m, StoreReadExtra m) => @@ -437,7 +417,6 @@ { dataBestCount :: !Counter, dataBlockCount :: !Counter, dataTxCount :: !Counter, - dataSpenderCount :: !Counter, dataMempoolCount :: !Counter, dataBalanceCount :: !Counter, dataUnspentCount :: !Counter, @@ -453,7 +432,6 @@ dataBestCount <- Metrics.createCounter "data.best_block" s dataBlockCount <- Metrics.createCounter "data.blocks" s dataTxCount <- Metrics.createCounter "data.txs" s - dataSpenderCount <- Metrics.createCounter "data.spenders" s dataMempoolCount <- Metrics.createCounter "data.mempool" s dataBalanceCount <- Metrics.createCounter "data.balances" s dataUnspentCount <- Metrics.createCounter "data.unspents" s 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 @@ -12,7 +12,6 @@ addrTxCF, addrOutCF, txCF, - spenderCF, unspentCF, blockCF, heightCF, @@ -33,10 +32,12 @@ ) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits ((.&.)) import qualified Data.ByteString as BS import Data.Default (def) import Data.Function (on) +import qualified Data.IntMap.Strict as IntMap import Data.List (sortOn) import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) @@ -97,7 +98,7 @@ Nothing -> return () dataVersion :: Word32 -dataVersion = 17 +dataVersion = 18 withDatabaseReader :: MonadUnliftIO m => @@ -128,7 +129,7 @@ [ ("addr-tx", def {prefixLength = Just 22, bloomFilter = True}), ("addr-out", def {prefixLength = Just 22, bloomFilter = True}), ("tx", def {prefixLength = Just 33, bloomFilter = True}), - ("spender", def {prefixLength = Just 33, bloomFilter = True}), + ("spender", def {prefixLength = Just 33, bloomFilter = True}), -- unused ("unspent", def {prefixLength = Just 37, bloomFilter = True}), ("block", def {prefixLength = Just 33, bloomFilter = True}), ("height", def {prefixLength = Nothing, bloomFilter = True}), @@ -144,9 +145,6 @@ txCF :: DB -> ColumnFamily txCF db = columnFamilies db !! 2 -spenderCF :: DB -> ColumnFamily -spenderCF db = columnFamilies db !! 3 - unspentCF :: DB -> ColumnFamily unspentCF db = columnFamilies db !! 4 @@ -268,13 +266,10 @@ incrementCounter dataTxCount 1 return (Just t) - getSpender op = do - db <- asks databaseHandle - retrieveCF db (spenderCF db) (SpenderKey op) >>= \case - Nothing -> return Nothing - Just s -> do - incrementCounter dataSpenderCount 1 - return (Just s) + getSpender op = runMaybeT $ do + td <- MaybeT $ getTxData (outPointHash op) + let i = fromIntegral (outPointIndex op) + MaybeT . return $ i `IntMap.lookup` txDataSpenders td getUnspent p = do db <- asks databaseHandle 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 @@ -11,7 +11,6 @@ BalKey (..), HeightKey (..), MemKey (..), - SpenderKey (..), TxKey (..), decodeTxKey, UnspentKey (..), @@ -211,29 +210,6 @@ instance Key TxKey instance KeyValue TxKey TxData - -data SpenderKey - = SpenderKey {outputPoint :: !OutPoint} - | SpenderKeyS {outputKeyS :: !TxHash} - deriving (Show, Read, Eq, Ord, Generic, Hashable) - -instance Serialize SpenderKey where - -- 0x10 · TxHash · Index - put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do - put (SpenderKeyS h) - put i - -- 0x10 · TxHash - put (SpenderKeyS h) = do - putWord8 0x10 - put h - get = do - guard . (== 0x10) =<< getWord8 - op <- OutPoint <$> get <*> get - return $ SpenderKey op - -instance Key SpenderKey - -instance KeyValue SpenderKey Spender -- | Unspent output database key. data UnspentKey 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 @@ -2,13 +2,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Haskoin.Store.Database.Writer (WriterT, runWriter) where +import Control.Monad (join) import Control.Monad.Reader (ReaderT (..)) import qualified Control.Monad.Reader as R import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M +import qualified Data.HashTable.IO as H +import qualified Data.IntMap.Strict as IntMap import Data.List (sortOn) import Data.Ord (Down (..)) import Data.Tuple (swap) @@ -35,18 +39,23 @@ import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Types import UnliftIO - ( MonadIO, + ( IORef, + MonadIO, TVar, atomically, liftIO, + modifyIORef, modifyTVar, + newIORef, newTVarIO, + readIORef, readTVarIO, + writeIORef, ) data Writer = Writer { getReader :: !DatabaseReader, - getState :: !(TVar Memory) + getState :: !Memory } type WriterT = ReaderT Writer @@ -62,102 +71,93 @@ getBalance = getBalanceI getMempool = getMempoolI +type NetRef = IORef (Maybe Network) + +type BestRef = IORef (Maybe (Maybe BlockHash)) + +type BlockTable = H.BasicHashTable BlockHash (Maybe BlockData) + +type HeightTable = H.BasicHashTable BlockHeight [BlockHash] + +type TxTable = H.BasicHashTable TxHash (Maybe TxData) + +type UnspentTable = H.BasicHashTable OutPoint (Maybe Unspent) + +type BalanceTable = H.BasicHashTable Address (Maybe Balance) + +type AddrTxTable = H.BasicHashTable (Address, TxRef) (Maybe ()) + +type AddrOutTable = H.BasicHashTable (Address, BlockRef, OutPoint) (Maybe OutVal) + +type MempoolTable = H.BasicHashTable TxHash UnixTime + data Memory = Memory - { hNet :: - !(Maybe Network), - hBest :: - !(Maybe (Maybe BlockHash)), - hBlock :: - !(HashMap BlockHash (Maybe BlockData)), - hHeight :: - !(HashMap BlockHeight [BlockHash]), - hTx :: - !(HashMap TxHash (Maybe TxData)), - hSpender :: - !(HashMap OutPoint (Maybe Spender)), - hUnspent :: - !(HashMap OutPoint (Maybe Unspent)), - hBalance :: - !(HashMap Address (Maybe Balance)), - hAddrTx :: - !(HashMap (Address, TxRef) (Maybe ())), - hAddrOut :: - !(HashMap (Address, BlockRef, OutPoint) (Maybe OutVal)), - hMempool :: - !(HashMap TxHash UnixTime) + { hNet :: !NetRef, + hBest :: !BestRef, + hBlock :: !BlockTable, + hHeight :: !HeightTable, + hTx :: !TxTable, + hUnspent :: !UnspentTable, + hBalance :: !BalanceTable, + hAddrTx :: !AddrTxTable, + hAddrOut :: !AddrOutTable, + hMempool :: !MempoolTable } - deriving (Eq, Show) instance MonadIO m => StoreWrite (WriterT m) where setBest h = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - setBestH h + liftIO $ writeIORef (hBest s) (Just (Just h)) insertBlock b = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - insertBlockH b + liftIO $ H.insert (hBlock s) (headerHash (blockDataHeader b)) (Just b) setBlocksAtHeight h g = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - setBlocksAtHeightH h g + liftIO $ H.insert (hHeight s) g h insertTx t = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - insertTxH t - insertSpender p s' = - ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - insertSpenderH p s' - deleteSpender p = - ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteSpenderH p + liftIO $ H.insert (hTx s) (txHash (txData t)) (Just t) insertAddrTx a t = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - insertAddrTxH a t + liftIO $ H.insert (hAddrTx s) (a, t) (Just ()) deleteAddrTx a t = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteAddrTxH a t + liftIO $ H.insert (hAddrTx s) (a, t) Nothing insertAddrUnspent a u = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - insertAddrUnspentH a u + liftIO $ H.insert (hAddrOut s) k (Just v) + where + k = (a, unspentBlock u, unspentPoint u) + v = OutVal {outValAmount = unspentAmount u, outValScript = unspentScript u} deleteAddrUnspent a u = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteAddrUnspentH a u + liftIO $ H.insert (hAddrOut s) k Nothing + where + k = (a, unspentBlock u, unspentPoint u) addToMempool x t = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - addToMempoolH x t + liftIO $ H.insert (hMempool s) x t deleteFromMempool x = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteFromMempoolH x + liftIO $ H.delete (hMempool s) x setBalance b = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - setBalanceH b - insertUnspent h = + liftIO $ H.insert (hBalance s) (balanceAddress b) (Just b) + insertUnspent u = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - insertUnspentH h + liftIO $ H.insert (hUnspent s) (fst (unspentToVal u)) (Just u) deleteUnspent p = ReaderT $ \Writer {getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteUnspentH p + liftIO $ H.insert (hUnspent s) p Nothing getLayered :: MonadIO m => - (Memory -> Maybe a) -> + (Memory -> IO (Maybe a)) -> DatabaseReaderT m a -> WriterT m a getLayered f g = - ReaderT $ \Writer {getReader = db, getState = tmem} -> - f <$> readTVarIO tmem >>= \case + ReaderT $ \Writer {getReader = db, getState = s} -> + liftIO (f s) >>= \case Just x -> return x Nothing -> runReaderT g db @@ -167,72 +167,66 @@ WriterT m a -> m a runWriter bdb@DatabaseReader {databaseHandle = db} f = do - mem <- runReaderT getMempool bdb - hm <- newTVarIO (newMemory mem) + mempool <- runReaderT getMempool bdb + hm <- newMemory mempool x <- R.runReaderT f Writer {getReader = bdb, getState = hm} - mem' <- readTVarIO hm - let ops = hashMapOps db mem' + ops <- hashMapOps db hm writeBatch db ops return x -hashMapOps :: DB -> Memory -> [BatchOp] +hashMapOps :: MonadIO m => DB -> Memory -> m [BatchOp] hashMapOps db mem = - bestBlockOp (hBest mem) - <> blockHashOps db (hBlock mem) - <> blockHeightOps db (hHeight mem) - <> txOps db (hTx mem) - <> spenderOps db (hSpender mem) - <> balOps db (hBalance mem) - <> addrTxOps db (hAddrTx mem) - <> addrOutOps db (hAddrOut mem) - <> mempoolOp (hMempool mem) - <> unspentOps db (hUnspent mem) + mconcat + <$> sequence + [ bestBlockOp (hBest mem), + blockHashOps db (hBlock mem), + blockHeightOps db (hHeight mem), + txOps db (hTx mem), + balOps db (hBalance mem), + addrTxOps db (hAddrTx mem), + addrOutOps db (hAddrOut mem), + mempoolOp (hMempool mem), + unspentOps db (hUnspent mem) + ] -bestBlockOp :: Maybe (Maybe BlockHash) -> [BatchOp] -bestBlockOp Nothing = [] -bestBlockOp (Just Nothing) = [deleteOp BestKey] -bestBlockOp (Just (Just b)) = [insertOp BestKey b] +bestBlockOp :: MonadIO m => BestRef -> m [BatchOp] +bestBlockOp r = + readIORef r >>= \case + Nothing -> return [] + Just Nothing -> return [deleteOp BestKey] + Just (Just b) -> return [insertOp BestKey b] -blockHashOps :: DB -> HashMap BlockHash (Maybe BlockData) -> [BatchOp] -blockHashOps db = map (uncurry f) . M.toList +blockHashOps :: MonadIO m => DB -> BlockTable -> m [BatchOp] +blockHashOps db t = map (uncurry f) <$> liftIO (H.toList t) where f k (Just d) = insertOpCF (blockCF db) (BlockKey k) d f k Nothing = deleteOpCF (blockCF db) (BlockKey k) -blockHeightOps :: DB -> HashMap BlockHeight [BlockHash] -> [BatchOp] -blockHeightOps db = map (uncurry f) . M.toList +blockHeightOps :: MonadIO m => DB -> HeightTable -> m [BatchOp] +blockHeightOps db t = map (uncurry f) <$> liftIO (H.toList t) where f = insertOpCF (heightCF db) . HeightKey -txOps :: DB -> HashMap TxHash (Maybe TxData) -> [BatchOp] -txOps db = map (uncurry f) . M.toList +txOps :: MonadIO m => DB -> TxTable -> m [BatchOp] +txOps db t = map (uncurry f) <$> liftIO (H.toList t) where f k (Just t) = insertOpCF (txCF db) (TxKey k) t f k Nothing = deleteOpCF (txCF db) (TxKey k) -spenderOps :: DB -> HashMap OutPoint (Maybe Spender) -> [BatchOp] -spenderOps db = map (uncurry f) . M.toList - where - f o (Just s) = insertOpCF (spenderCF db) (SpenderKey o) s - f o Nothing = deleteOpCF (spenderCF db) (SpenderKey o) - -balOps :: DB -> HashMap Address (Maybe Balance) -> [BatchOp] -balOps db = map (uncurry f) . M.toList +balOps :: MonadIO m => DB -> BalanceTable -> m [BatchOp] +balOps db t = map (uncurry f) <$> liftIO (H.toList t) where f a (Just b) = insertOpCF (balanceCF db) (BalKey a) (balanceToVal b) f a Nothing = deleteOpCF (balanceCF db) (BalKey a) -addrTxOps :: DB -> HashMap (Address, TxRef) (Maybe ()) -> [BatchOp] -addrTxOps db = map (uncurry f) . M.toList +addrTxOps :: MonadIO m => DB -> AddrTxTable -> m [BatchOp] +addrTxOps db t = map (uncurry f) <$> liftIO (H.toList t) where f (a, t) (Just ()) = insertOpCF (addrTxCF db) (AddrTxKey a t) () f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t) -addrOutOps :: - DB -> - HashMap (Address, BlockRef, OutPoint) (Maybe OutVal) -> - [BatchOp] -addrOutOps db = map (uncurry f) . M.toList +addrOutOps :: MonadIO m => DB -> AddrOutTable -> m [BatchOp] +addrOutOps db t = map (uncurry f) <$> liftIO (H.toList t) where f (a, b, p) (Just l) = insertOpCF @@ -253,11 +247,12 @@ addrOutKeyP = p } -mempoolOp :: HashMap TxHash UnixTime -> [BatchOp] -mempoolOp = return . insertOp MemKey . sortOn Down . map swap . M.toList +mempoolOp :: MonadIO m => MempoolTable -> m [BatchOp] +mempoolOp t = + return . insertOp MemKey . sortOn Down . map swap <$> liftIO (H.toList t) -unspentOps :: DB -> HashMap OutPoint (Maybe Unspent) -> [BatchOp] -unspentOps db = map (uncurry f) . M.toList +unspentOps :: MonadIO m => DB -> UnspentTable -> m [BatchOp] +unspentOps db t = map (uncurry f) <$> liftIO (H.toList t) where f p (Just u) = insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u)) @@ -265,7 +260,7 @@ deleteOpCF (unspentCF db) (UnspentKey p) getNetworkI :: MonadIO m => WriterT m Network -getNetworkI = getLayered hNet getNetwork +getNetworkI = getLayered (liftIO . readIORef . hNet) getNetwork getBestBlockI :: MonadIO m => WriterT m (Maybe BlockHash) getBestBlockI = getLayered getBestBlockH getBestBlock @@ -291,118 +286,46 @@ getMempoolI :: MonadIO m => WriterT m [(UnixTime, TxHash)] getMempoolI = - ReaderT $ \Writer {getState = tmem} -> - getMempoolH <$> readTVarIO tmem - -newMemory :: [(UnixTime, TxHash)] -> Memory -newMemory mem = - Memory - { hNet = Nothing, - hBest = Nothing, - hBlock = M.empty, - hHeight = M.empty, - hTx = M.empty, - hSpender = M.empty, - hUnspent = M.empty, - hBalance = M.empty, - hAddrTx = M.empty, - hAddrOut = M.empty, - hMempool = M.fromList (map swap mem) - } - -getBestBlockH :: Memory -> Maybe (Maybe BlockHash) -getBestBlockH = hBest - -getBlocksAtHeightH :: BlockHeight -> Memory -> Maybe [BlockHash] -getBlocksAtHeightH h = M.lookup h . hHeight - -getBlockH :: BlockHash -> Memory -> Maybe (Maybe BlockData) -getBlockH h = M.lookup h . hBlock - -getTxDataH :: TxHash -> Memory -> Maybe (Maybe TxData) -getTxDataH t = M.lookup t . hTx - -getSpenderH :: OutPoint -> Memory -> Maybe (Maybe Spender) -getSpenderH op db = M.lookup op (hSpender db) - -getBalanceH :: Address -> Memory -> Maybe (Maybe Balance) -getBalanceH a = M.lookup a . hBalance - -getMempoolH :: Memory -> [(UnixTime, TxHash)] -getMempoolH = sortOn Down . map swap . M.toList . hMempool - -setBestH :: BlockHash -> Memory -> Memory -setBestH h db = db {hBest = Just (Just h)} - -insertBlockH :: BlockData -> Memory -> Memory -insertBlockH bd db = - db - { hBlock = - M.insert - (headerHash (blockDataHeader bd)) - (Just bd) - (hBlock db) - } - -setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> Memory -> Memory -setBlocksAtHeightH hs g db = - db {hHeight = M.insert g hs (hHeight db)} - -insertTxH :: TxData -> Memory -> Memory -insertTxH tx db = - db {hTx = M.insert (txHash (txData tx)) (Just tx) (hTx db)} - -insertSpenderH :: OutPoint -> Spender -> Memory -> Memory -insertSpenderH op s db = - db {hSpender = M.insert op (Just s) (hSpender db)} - -deleteSpenderH :: OutPoint -> Memory -> Memory -deleteSpenderH op db = - db {hSpender = M.insert op Nothing (hSpender db)} - -setBalanceH :: Balance -> Memory -> Memory -setBalanceH bal db = - db {hBalance = M.insert (balanceAddress bal) (Just bal) (hBalance db)} + ReaderT $ \Writer {getState = s} -> + liftIO $ map swap <$> H.toList (hMempool s) -insertAddrTxH :: Address -> TxRef -> Memory -> Memory -insertAddrTxH a tr db = - db {hAddrTx = M.insert (a, tr) (Just ()) (hAddrTx db)} +newMemory :: MonadIO m => [(UnixTime, TxHash)] -> m Memory +newMemory mempool = do + hNet <- newIORef Nothing + hBest <- newIORef Nothing + hBlock <- liftIO H.new + hHeight <- liftIO H.new + hTx <- liftIO H.new + hUnspent <- liftIO H.new + hBalance <- liftIO H.new + hAddrTx <- liftIO H.new + hAddrOut <- liftIO H.new + hMempool <- liftIO $ H.fromList (map swap mempool) + return Memory {..} -deleteAddrTxH :: Address -> TxRef -> Memory -> Memory -deleteAddrTxH a tr db = - db {hAddrTx = M.insert (a, tr) Nothing (hAddrTx db)} +getBestBlockH :: Memory -> IO (Maybe (Maybe BlockHash)) +getBestBlockH = readIORef . hBest -insertAddrUnspentH :: Address -> Unspent -> Memory -> Memory -insertAddrUnspentH a u db = - let k = (a, unspentBlock u, unspentPoint u) - v = - OutVal - { outValAmount = unspentAmount u, - outValScript = unspentScript u - } - in db {hAddrOut = M.insert k (Just v) (hAddrOut db)} +getBlocksAtHeightH :: BlockHeight -> Memory -> IO (Maybe [BlockHash]) +getBlocksAtHeightH h s = H.lookup (hHeight s) h -deleteAddrUnspentH :: Address -> Unspent -> Memory -> Memory -deleteAddrUnspentH a u db = - let k = (a, unspentBlock u, unspentPoint u) - in db {hAddrOut = M.insert k Nothing (hAddrOut db)} +getBlockH :: BlockHash -> Memory -> IO (Maybe (Maybe BlockData)) +getBlockH h s = H.lookup (hBlock s) h -addToMempoolH :: TxHash -> UnixTime -> Memory -> Memory -addToMempoolH h t db = - db {hMempool = M.insert h t (hMempool db)} +getTxDataH :: TxHash -> Memory -> IO (Maybe (Maybe TxData)) +getTxDataH t s = H.lookup (hTx s) t -deleteFromMempoolH :: TxHash -> Memory -> Memory -deleteFromMempoolH h db = - db {hMempool = M.delete h (hMempool db)} +getSpenderH :: OutPoint -> Memory -> IO (Maybe (Maybe Spender)) +getSpenderH op s = do + fmap (join . fmap f) <$> getTxDataH (outPointHash op) s + where + f = IntMap.lookup (fromIntegral (outPointIndex op)) . txDataSpenders -getUnspentH :: OutPoint -> Memory -> Maybe (Maybe Unspent) -getUnspentH op db = M.lookup op (hUnspent db) +getBalanceH :: Address -> Memory -> IO (Maybe (Maybe Balance)) +getBalanceH a s = H.lookup (hBalance s) a -insertUnspentH :: Unspent -> Memory -> Memory -insertUnspentH u db = - let k = fst (unspentToVal u) - in db {hUnspent = M.insert k (Just u) (hUnspent db)} +getMempoolH :: Memory -> IO [(UnixTime, TxHash)] +getMempoolH s = sortOn Down . map swap <$> H.toList (hMempool s) -deleteUnspentH :: OutPoint -> Memory -> Memory -deleteUnspentH op db = - db {hUnspent = M.insert op Nothing (hUnspent db)} +getUnspentH :: OutPoint -> Memory -> IO (Maybe (Maybe Unspent)) +getUnspentH p s = H.lookup (hUnspent s) p 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 @@ -323,7 +323,8 @@ txDataPrevs = ps, txDataDeleted = False, txDataRBF = rbf, - txDataTime = tt + txDataTime = tt, + txDataSpenders = I.empty } where mkprv u = Prev (unspentScript u) (unspentAmount u) @@ -508,20 +509,22 @@ throwError TxConfirmed | rbfcheck -> isRBF (txDataBlock td) (txData td) >>= \case - True -> return $ Just $ txData td + True -> return $ Just td False -> do $(logErrorS) "BlockStore" $ "Double-spending transaction: " <> txHashToHex th throwError DoubleSpend - | otherwise -> return $ Just $ txData td + | otherwise -> return $ Just td go txs pdg = do - txs1 <- HashSet.fromList . catMaybes <$> mapM get_tx (HashSet.toList pdg) - pdg1 <- - HashSet.fromList . concatMap (map spenderHash . I.elems) - <$> mapM getSpenders (HashSet.toList pdg) - let txs' = txs1 <> txs - pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs' + tds <- catMaybes <$> mapM get_tx (HashSet.toList pdg) + let txsn = HashSet.fromList $ fmap txData tds + pdgn = + HashSet.fromList + . concatMap (map spenderHash . I.elems) + $ fmap txDataSpenders tds + txs' = txsn <> txs + pdg' = pdgn `HashSet.difference` HashSet.map txHash txs' if HashSet.null pdg' then return $ HashSet.toList txs' else go txs' pdg' @@ -533,17 +536,17 @@ $(logErrorS) "BlockStore" $ "Already deleted: " <> txHashToHex th throwError TxNotFound - Just td -> do - $(logDebugS) "BlockStore" $ - "Deleting tx: " <> txHashToHex th - getSpenders th >>= \case - m - | I.null m -> commitDelTx td - | otherwise -> do - $(logErrorS) "BlockStore" $ - "Tried to delete spent tx: " - <> txHashToHex th - throwError TxSpent + Just td -> + if I.null (txDataSpenders td) + then do + $(logDebugS) "BlockStore" $ + "Deleting tx: " <> txHashToHex th + commitDelTx td + else do + $(logErrorS) "BlockStore" $ + "Tried to delete spent tx: " + <> txHashToHex th + throwError TxSpent commitDelTx :: MonadImport m => TxData -> m () commitDelTx = commitModTx False @@ -672,6 +675,22 @@ getTxOut i tx = do guard (fromIntegral i < length (txOut tx)) return $ txOut tx !! fromIntegral i + +insertSpender :: MonadImport m => OutPoint -> Spender -> m () +insertSpender op s = do + td <- getImportTxData (outPointHash op) + let p = txDataSpenders td + p' = I.insert (fromIntegral (outPointIndex op)) s p + td' = td {txDataSpenders = p'} + insertTx td' + +deleteSpender :: MonadImport m => OutPoint -> m () +deleteSpender op = do + td <- getImportTxData (outPointHash op) + let p = txDataSpenders td + p' = I.delete (fromIntegral (outPointIndex op)) p + td' = td {txDataSpenders = p'} + insertTx td' spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m () spendOutput th ix op = do 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 @@ -271,7 +271,9 @@ webStats :: !(Maybe Metrics.Store), webPriceGet :: !Int, webTickerURL :: !String, - webHistoryURL :: !String + webHistoryURL :: !String, + webSlow :: !Bool, + webBlockchain :: !Bool } data WebState = WebState @@ -550,7 +552,9 @@ webStats = stats, webPriceGet = pget, webTickerURL = turl, - webMaxLimits = WebLimits {..} + webMaxLimits = WebLimits {..}, + webSlow = slow, + webBlockchain = blockchain } = do ticker <- newTVarIO HashMap.empty metrics <- mapM createMetrics stats @@ -563,7 +567,7 @@ webWreqSession = session } net = storeNetwork store' - withAsync (price net session turl pget ticker) $ + withAsync (when blockchain $ price net session turl pget ticker) $ const $ do reqLogger <- logIt metrics runner <- askRunInIO @@ -573,7 +577,7 @@ S.middleware (reqSizeLimit maxLimitBody) when (maxLimitTimeout > 0) $ S.middleware (reqTimeout maxLimitTimeout) S.defaultHandler defHandler - handlePaths + handlePaths slow blockchain S.notFound $ raise ThingNotFound where opts = def {S.settings = settings defaultSettings} @@ -669,20 +673,22 @@ handlePaths :: (MonadUnliftIO m, MonadLoggerIO m) => + Bool -> + Bool -> S.ScottyT Except (ReaderT WebState m) () -handlePaths = do +handlePaths slow blockchain = do -- Block Paths pathCompact (GetBlock <$> paramLazy <*> paramDef) scottyBlock blockDataToEncoding blockDataToJSON - pathCompact + when slow $ pathCompact (GetBlocks <$> param <*> paramDef) (fmap SerialList . scottyBlocks) (\n -> list (blockDataToEncoding n) . getSerialList) (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetBlockRaw <$> paramLazy) scottyBlockRaw (const toEncoding) @@ -692,12 +698,12 @@ scottyBlockBest blockDataToEncoding blockDataToJSON - pathCompact + when slow $ pathCompact (GetBlockBestRaw & return) scottyBlockBestRaw (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetBlockLatest <$> paramDef) (fmap SerialList . scottyBlockLatest) (\n -> list (blockDataToEncoding n) . getSerialList) @@ -707,12 +713,12 @@ (fmap SerialList . scottyBlockHeight) (\n -> list (blockDataToEncoding n) . getSerialList) (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetBlockHeights <$> param <*> paramDef) (fmap SerialList . scottyBlockHeights) (\n -> list (blockDataToEncoding n) . getSerialList) (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetBlockHeightRaw <$> paramLazy) scottyBlockHeightRaw (const toEncoding) @@ -722,7 +728,7 @@ scottyBlockTime blockDataToEncoding blockDataToJSON - pathCompact + when slow $ pathCompact (GetBlockTimeRaw <$> paramLazy) scottyBlockTimeRaw (const toEncoding) @@ -732,7 +738,7 @@ scottyBlockMTP blockDataToEncoding blockDataToJSON - pathCompact + when slow $ pathCompact (GetBlockMTPRaw <$> paramLazy) scottyBlockMTPRaw (const toEncoding) @@ -743,7 +749,7 @@ scottyTx transactionToEncoding transactionToJSON - pathCompact + when slow $ pathCompact (GetTxs <$> param) (fmap SerialList . scottyTxs) (\n -> list (transactionToEncoding n) . getSerialList) @@ -753,22 +759,22 @@ scottyTxRaw (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetTxsRaw <$> param) scottyTxsRaw (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetTxsBlock <$> paramLazy) (fmap SerialList . scottyTxsBlock) (\n -> list (transactionToEncoding n) . getSerialList) (\n -> json_list transactionToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetTxsBlockRaw <$> paramLazy) scottyTxsBlockRaw (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetTxAfter <$> paramLazy <*> paramLazy) scottyTxAfter (const toEncoding) @@ -789,17 +795,17 @@ (fmap SerialList . scottyAddrTxs) (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetAddrsTxs <$> param <*> parseLimits) (fmap SerialList . scottyAddrsTxs) (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetAddrTxsFull <$> paramLazy <*> parseLimits) (fmap SerialList . scottyAddrTxsFull) (\n -> list (transactionToEncoding n) . getSerialList) (\n -> json_list transactionToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetAddrsTxsFull <$> param <*> parseLimits) (fmap SerialList . scottyAddrsTxsFull) (\n -> list (transactionToEncoding n) . getSerialList) @@ -809,7 +815,7 @@ scottyAddrBalance balanceToEncoding balanceToJSON - pathCompact + when slow $ pathCompact (GetAddrsBalance <$> param) (fmap SerialList . scottyAddrsBalance) (\n -> list (balanceToEncoding n) . getSerialList) @@ -819,38 +825,38 @@ (fmap SerialList . scottyAddrUnspent) (\n -> list (unspentToEncoding n) . getSerialList) (\n -> json_list unspentToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetAddrsUnspent <$> param <*> parseLimits) (fmap SerialList . scottyAddrsUnspent) (\n -> list (unspentToEncoding n) . getSerialList) (\n -> json_list unspentToJSON n . getSerialList) -- XPubs - pathCompact + when slow $ pathCompact (GetXPub <$> paramLazy <*> paramDef <*> paramDef) scottyXPub (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) (fmap SerialList . scottyXPubTxs) (const toEncoding) (const toJSON) - pathCompact + when slow $ pathCompact (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) (fmap SerialList . scottyXPubTxsFull) (\n -> list (transactionToEncoding n) . getSerialList) (\n -> json_list transactionToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef) (fmap SerialList . scottyXPubBalances) (\n -> list (xPubBalToEncoding n) . getSerialList) (\n -> json_list xPubBalToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) (fmap SerialList . scottyXPubUnspent) (\n -> list (xPubUnspentToEncoding n) . getSerialList) (\n -> json_list xPubUnspentToJSON n . getSerialList) - pathCompact + when slow $ pathCompact (DelCachedXPub <$> paramLazy <*> paramDef) scottyDelXPub (const toEncoding) @@ -869,39 +875,40 @@ S.get "/events" scottyEvents S.get "/dbstats" scottyDbStats -- Blockchain.info - S.post "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/balance" scottyShortBal - S.post "/blockchain/balance" scottyShortBal - S.get "/blockchain/rawaddr/:addr" scottyRawAddr - S.get "/blockchain/address/:addr" scottyRawAddr - S.get "/blockchain/xpub/:addr" scottyRawAddr - S.post "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/rawtx/:txid" scottyBinfoTx - S.get "/blockchain/rawblock/:block" scottyBinfoBlock - S.get "/blockchain/latestblock" scottyBinfoLatest - S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool - S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight - S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay - S.get "/blockchain/export-history" scottyBinfoHistory - S.post "/blockchain/export-history" scottyBinfoHistory - S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash - S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr - S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey - S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr - S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey - S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount - S.get "/blockchain/q/latesthash" scottyBinfoLatestHash - S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy - S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut - S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput - S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees - S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult - S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived - S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent - S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance - S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen + when blockchain $ do + S.post "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/balance" scottyShortBal + S.post "/blockchain/balance" scottyShortBal + S.get "/blockchain/rawaddr/:addr" scottyRawAddr + S.get "/blockchain/address/:addr" scottyRawAddr + S.get "/blockchain/xpub/:addr" scottyRawAddr + S.post "/blockchain/unspent" scottyBinfoUnspent + S.get "/blockchain/unspent" scottyBinfoUnspent + S.get "/blockchain/rawtx/:txid" scottyBinfoTx + S.get "/blockchain/rawblock/:block" scottyBinfoBlock + S.get "/blockchain/latestblock" scottyBinfoLatest + S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool + S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight + S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay + S.get "/blockchain/export-history" scottyBinfoHistory + S.post "/blockchain/export-history" scottyBinfoHistory + S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash + S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr + S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey + S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr + S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey + S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount + S.get "/blockchain/q/latesthash" scottyBinfoLatestHash + S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy + S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut + S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput + S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees + S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult + S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived + S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent + S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance + S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen where json_list f net = toJSONList . map (f net)