haskoin-store 0.64.19 → 0.65.0

raw patch · 10 files changed

+301/−366 lines, 10 filesdep +hashtablesdep ~haskoin-store-dataPVP ok

version bump matches the API change (PVP)

Dependencies added: hashtables

Dependency ranges changed: haskoin-store-data

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• app/Main.hs +32/−4
• haskoin-store.cabal +7/−4
• src/Haskoin/Store.hs +0/−1
• src/Haskoin/Store/Common.hs +2/−24
• src/Haskoin/Store/Database/Reader.hs +8/−13
• src/Haskoin/Store/Database/Types.hs +0/−24
• src/Haskoin/Store/Database/Writer.hs +137/−214
• src/Haskoin/Store/Logic.hs +39/−20
• src/Haskoin/Store/Web.hs +69/−62

@@ -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.

@@ -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

@@ -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 <https://github.com/haskoin/haskoin-store#readme> 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

@@ -26,7 +26,6 @@     -- * Useful Fuctions     getTransaction,     getDefaultBalance,-    getSpenders,     getActiveTxData,     blockAtOrBefore, 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)