diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.21.2 +### Added +- Complete support for Redis xpub cache. + ## 0.21.1 ### Fixed - Latest version of secp256k1-haskell works with Debian 9. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} module Main where import Control.Arrow (second) @@ -12,14 +13,17 @@ import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.Version (showVersion) +import Database.Redis (defaultConnectInfo, parseConnectInfo, + withCheckedConnect) import Haskoin (Network (..), allNets, bch, bchRegTest, bchTest, btc, btcRegTest, btcTest) import Haskoin.Node (Host, Port) -import Haskoin.Store (MaxLimits (..), StoreConfig (..), +import Haskoin.Store (CacheReaderConfig (..), + MaxLimits (..), StoreConfig (..), Timeouts (..), WebConfig (..), connectRocksDB, runWeb, withStore) -import NQE (PublisherMessage (..), sendSTM, +import NQE (inboxToMailbox, newInbox, withPublisher) import Options.Applicative (Parser, auto, eitherReader, execParser, fullDesc, header, help, @@ -31,7 +35,7 @@ import System.FilePath (()) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) -import UnliftIO (MonadUnliftIO, liftIO) +import UnliftIO (MonadUnliftIO, liftIO, withRunInIO) import UnliftIO.Directory (createDirectoryIfMissing, getAppUserDataDirectory) @@ -46,6 +50,8 @@ , configReqLog :: !Bool , configMaxLimits :: !MaxLimits , configTimeouts :: !Timeouts + , configRedis :: !Bool + , configRedisURL :: !String } defPort :: Int @@ -64,6 +70,7 @@ , maxLimitFull = 5000 , maxLimitOffset = 50000 , maxLimitDefault = 2000 + , maxLimitGap = 32 } defTimeouts :: Timeouts @@ -119,6 +126,11 @@ help "Default limit (0 for max)" <> showDefault <> value (maxLimitDefault defMaxLimits) + maxLimitGap <- + option auto $ + metavar "MAXGAP" <> long "maxgap" <> help "Max gap for xpub queries" <> + showDefault <> + value (maxLimitGap defMaxLimits) blockTimeout <- option auto $ metavar "BLOCKSECONDS" <> long "blocktimeout" <> @@ -131,6 +143,11 @@ help "Last transaction broadcast timeout (0 for infinite)" <> showDefault <> value (txTimeout defTimeouts) + configRedis <- + switch $ long "cache" <> help "Redis cache for extended public keys" + configRedisURL <- + strOption $ + metavar "URL" <> long "redis" <> help "URL for Redis cache" <> value "" pure Config { configMaxLimits = MaxLimits {..} @@ -192,41 +209,71 @@ , configMaxLimits = limits , configReqLog = reqlog , configTimeouts = tos + , configRedis = redis + , configRedisURL = redisurl } = runStderrLoggingT . filterLogger l $ do $(logInfoS) "Main" $ "Creating working directory if not found: " <> cs wd createDirectoryIfMissing True wd - db <- connectRocksDB (wd "db") - withPublisher $ \pub -> - let scfg = - StoreConfig - { storeConfMaxPeers = 20 - , storeConfInitPeers = - map - (second (fromMaybe (getDefaultPort net))) - peers - , storeConfDiscover = disc - , storeConfDB = db - , storeConfNetwork = net - , storeConfListen = (`sendSTM` pub) . Event - , storeConfCache = Nothing - } - in withStore scfg $ \st -> - let wcfg = - WebConfig - { webPort = port - , webNetwork = net - , webDB = db - , webPublisher = pub - , webStore = st - , webMaxLimits = limits - , webReqLog = reqlog - , webTimeouts = tos - , webCache = Nothing - } - in runWeb wcfg + db <- connectRocksDB (maxLimitGap limits) (wd "db") + withcache $ \maybecache -> + withPublisher $ \pub -> + let scfg = + StoreConfig + { storeConfMaxPeers = 20 + , storeConfInitPeers = + map + (second (fromMaybe (getDefaultPort net))) + peers + , storeConfDiscover = disc + , storeConfDB = db + , storeConfNetwork = net + , storeConfPublisher = pub + , storeConfCache = maybecache + , storeConfGap = maxLimitGap limits + } + in withStore scfg $ \st -> + let crcfg = + case maybecache of + Nothing -> Nothing + Just (conn, mbox) -> + Just + CacheReaderConfig + { cacheReaderConn = conn + , cacheReaderWriter = + inboxToMailbox mbox + , cacheReaderGap = + maxLimitGap limits + } + wcfg = + WebConfig + { webPort = port + , webNetwork = net + , webDB = db + , webPublisher = pub + , webStore = st + , webMaxLimits = limits + , webReqLog = reqlog + , webTimeouts = tos + , webCache = crcfg + } + in runWeb wcfg where + withcache f = + if redis + then do + conninfo <- + if null redisurl + then return defaultConnectInfo + else case parseConnectInfo redisurl of + Left e -> error e + Right r -> return r + cachembox <- newInbox + withRunInIO $ \r -> + withCheckedConnect conninfo $ \conn -> + r $ f (Just (conn, cachembox)) + else f Nothing l _ lvl | deb = True | otherwise = LevelInfo <= lvl diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2e843405a9f98ad1eb3b6b7815fab64fdb90647695e9155b1dabf4c64bf429d1 +-- hash: b98d31fe2b2c6cc80285d6d64684d5d4e1cd4432ebca24c5ce34f93928b9e933 name: haskoin-store -version: 0.21.1 +version: 0.21.2 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -5,9 +5,12 @@ , module X ) where -import Control.Monad (unless, when) +import Control.Monad (forever, unless, + when) import Control.Monad.Logger (MonadLoggerIO) import Data.Serialize (decode) +import Data.Word (Word32) +import Database.Redis (Connection) import Haskoin (BlockHash (..), Inv (..), InvType (..), @@ -43,10 +46,15 @@ import Network.Socket (SockAddr (..)) import NQE (Inbox, Listen, Process (..), + Publisher, + PublisherMessage (Event), inboxToMailbox, - newInbox, sendSTM, - withProcess) -import UnliftIO (MonadUnliftIO, link, + newInbox, receive, + send, sendSTM, + withProcess, + withSubscription) +import UnliftIO (MonadIO, + MonadUnliftIO, link, withAsync) -- | Configuration for a 'Store'. @@ -62,10 +70,12 @@ -- ^ RocksDB database handler , storeConfNetwork :: !Network -- ^ network constants - , storeConfListen :: !(Listen StoreEvent) - -- ^ listen to store events - , storeConfCache :: !(Maybe CacheReaderConfig) + , storeConfPublisher :: !(Publisher StoreEvent) + -- ^ publish store events + , storeConfCache :: !(Maybe (Connection, CacheWriterInbox)) -- ^ Redis cache configuration + , storeConfGap :: !Word32 + -- ^ gap for extended public keys } withStore :: @@ -101,7 +111,7 @@ , nodeConfDB = databaseHandle (storeConfDB cfg) , nodeConfPeers = storeConfInitPeers cfg , nodeConfDiscover = storeConfDiscover cfg - , nodeConfEvents = storeDispatch b l + , nodeConfEvents = storeDispatch b ((`sendSTM` l) . Event) , nodeConfNetAddr = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)) , nodeConfNet = storeConfNetwork cfg @@ -113,16 +123,50 @@ BlockStoreConfig { blockConfChain = inboxToMailbox chi , blockConfManager = inboxToMailbox mgri - , blockConfListener = l + , blockConfListener = (`sendSTM` l) . Event , blockConfDB = storeConfDB cfg , blockConfNet = storeConfNetwork cfg } case storeConfCache cfg of Nothing -> blockStore bcfg bsi - Just cacheconf -> undefined + Just cacheinfo -> do + let cwm = inboxToMailbox (snd cacheinfo) + crconf = + CacheReaderConfig + { cacheReaderConn = fst cacheinfo + , cacheReaderWriter = cwm + , cacheReaderGap = storeConfGap cfg + } + cwconf = + CacheWriterConfig + { cacheWriterReader = crconf + , cacheWriterChain = c + , cacheWriterMailbox = snd cacheinfo + , cacheWriterNetwork = storeConfNetwork cfg + } + cw = + withDatabaseReader + (storeConfDB cfg) + (cacheWriter cwconf) + withAsync cw $ \w -> + withSubscription l $ \evts -> do + link w + withAsync (cacheWriterEvents evts cwm) $ \cwd -> do + link cwd + blockStore bcfg bsi where - l = storeConfListen cfg + l = storeConfPublisher cfg b = inboxToMailbox bsi + c = inboxToMailbox chi + +cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m () +cacheWriterEvents evts cwm = forever $ receive evts >>= (`cacheWriterDispatch` cwm) + +cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m () +cacheWriterDispatch (StoreBestBlock _) = send CacheNewBlock +cacheWriterDispatch (StoreMempoolNew txh) = send (CacheNewTx txh) +cacheWriterDispatch (StoreTxDeleted txh) = send (CacheDelTx txh) +cacheWriterDispatch _ = const (return ()) -- | Dispatcher of node events. storeDispatch :: BlockStore -> Listen StoreEvent -> Listen NodeEvent diff --git a/src/Network/Haskoin/Store/CacheWriter.hs b/src/Network/Haskoin/Store/CacheWriter.hs --- a/src/Network/Haskoin/Store/CacheWriter.hs +++ b/src/Network/Haskoin/Store/CacheWriter.hs @@ -1,38 +1,46 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Network.Haskoin.Store.CacheWriter where -import Control.Monad (forM_, forever, unless, +import Control.Monad (forM, forM_, forever, void, when) +import Control.Monad.Logger (MonadLoggerIO, + logErrorS, logInfoS, + logWarnS) import Control.Monad.Reader (ReaderT (..), asks) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import qualified Data.IntMap.Strict as IntMap -import Data.List (nub, partition, (\\)) +import Data.List (nub, (\\)) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe) import Data.Serialize (encode) -import Database.Redis (RedisCtx, runRedis, - zadd, zrem) +import Data.String.Conversions (cs) +import Database.Redis (RedisCtx, hmset, + runRedis, zadd, zrem) import qualified Database.Redis as Redis import Haskoin (Address, BlockHash, BlockHeader (..), BlockNode (..), DerivPathI (..), - KeyIndex, + KeyIndex, Network, OutPoint (..), Tx (..), TxHash, TxIn (..), TxOut (..), + blockHashToHex, derivePubPath, headerHash, pathToList, scriptToAddressBS, - txHash) + txHash, txHashToHex) import Haskoin.Node (Chain, chainGetAncestor, chainGetBlock, chainGetSplitBlock) -import Network.Haskoin.Store.Common (BlockData (..), +import Network.Haskoin.Store.Common (Balance (..), + BlockData (..), BlockRef (..), BlockTx (..), CacheWriterMessage (..), @@ -54,14 +62,11 @@ balancesPfx, bestBlockKey, blockRefScore, - chgIndexPfx, - extIndexPfx, + cacheGetXPubBalances, mempoolSetKey, - pathScore, redisGetAddrInfo, redisGetHead, redisGetMempool, - redisGetXPubIndex, txSetPfx, utxoPfx, withCacheReader) import NQE (Inbox, receive) @@ -74,11 +79,12 @@ { cacheWriterReader :: !CacheReaderConfig , cacheWriterChain :: !Chain , cacheWriterMailbox :: !CacheWriterInbox + , cacheWriterNetwork :: !Network } type CacheWriterT = ReaderT CacheWriterConfig -instance (MonadIO m, StoreRead m) => StoreRead (CacheWriterT m) where +instance (MonadLoggerIO m, StoreRead m) => StoreRead (CacheWriterT m) where getBestBlock = lift getBestBlock getBlocksAtHeight = lift . getBlocksAtHeight getBlock = lift . getBlock @@ -101,60 +107,57 @@ runCacheReaderT (xPubUnspents xpub start offset limit) xPubTxs xpub start offset limit = runCacheReaderT (xPubTxs xpub start offset limit) + getMaxGap = asks (cacheReaderGap . cacheWriterReader) runCacheReaderT :: StoreRead m => CacheReaderT m a -> CacheWriterT m a runCacheReaderT f = ReaderT (\CacheWriterConfig {cacheWriterReader = r} -> withCacheReader r f) -cacheWriter :: (MonadUnliftIO m, StoreRead m) => CacheWriterConfig -> m () +cacheWriter :: + (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) + => CacheWriterConfig + -> m () cacheWriter cfg@CacheWriterConfig {cacheWriterMailbox = inbox} = runReaderT (forever (receive inbox >>= cacheWriterReact)) cfg cacheWriterReact :: - (MonadUnliftIO m, StoreRead m) => CacheWriterMessage -> CacheWriterT m () + (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) + => CacheWriterMessage + -> CacheWriterT m () cacheWriterReact CacheNewBlock = newBlockC cacheWriterReact (CacheXPub xpub) = newXPubC xpub cacheWriterReact (CacheNewTx txh) = newTxC txh cacheWriterReact (CacheDelTx txh) = removeTxC txh newXPubC :: - (MonadUnliftIO m, StoreRead m) + (MonadLoggerIO m, MonadUnliftIO m, StoreRead m) => XPubSpec -> CacheWriterT m () newXPubC xpub = do - present <- (> 0) <$> cacheGetXPubIndex xpub False - unless present $ do + empty <- null <$> runCacheReaderT (cacheGetXPubBalances xpub) + when empty $ do bals <- lift $ xPubBals xpub - unless (null bals) $ go bals + go bals where go bals = do - utxo <- xPubUnspents xpub Nothing 0 Nothing - xtxs <- xPubTxs xpub Nothing 0 Nothing - let (external, change) = - partition (\b -> head (xPubBalPath b) == 0) bals - extindex = - case external of - [] -> 0 - _ -> last (xPubBalPath (last external)) - chgindex = - case change of - [] -> 0 - _ -> last (xPubBalPath (last change)) + utxo <- lift $ xPubUnspents xpub Nothing 0 Nothing + xtxs <- lift $ xPubTxs xpub Nothing 0 Nothing cacheAddXPubBalances xpub bals cacheAddXPubUnspents xpub (map ((\u -> (unspentPoint u, unspentBlock u)) . xPubUnspent) utxo) cacheAddXPubTxs xpub xtxs - cacheSetXPubIndex xpub False extindex - cacheSetXPubIndex xpub True chgindex -newBlockC :: (MonadIO m, StoreRead m) => CacheWriterT m () +newBlockC :: (MonadLoggerIO m, StoreRead m) => CacheWriterT m () newBlockC = lift getBestBlock >>= \case - Nothing -> return () - Just newhead -> + Nothing -> $(logErrorS) "Cache" "Best block not set yet" + Just newhead -> do + $(logErrorS) "Cache" $ "Best block: " <> blockHashToHex newhead cacheGetHead >>= \case - Nothing -> importBlockC newhead + Nothing -> do + $(logInfoS) "Cache" "Cache has no best block set" + importBlockC newhead Just cachehead -> go newhead cachehead where go newhead cachehead @@ -162,13 +165,29 @@ | otherwise = do ch <- asks cacheWriterChain chainGetBlock newhead ch >>= \case - Nothing -> return () + Nothing -> do + $(logErrorS) "Cache" $ + "No header for new head: " <> blockHashToHex newhead + throwIO . LogicError . cs $ + "No header for new head: " <> blockHashToHex newhead Just newheadnode -> chainGetBlock cachehead ch >>= \case - Nothing -> return () + Nothing -> do + $(logErrorS) "Cache" $ + "No header for cache head: " <> + blockHashToHex cachehead + error . cs $ + "No header for cache head: " <> + blockHashToHex cachehead Just cacheheadnode -> go2 newheadnode cacheheadnode go2 newheadnode cacheheadnode - | nodeHeight cacheheadnode > nodeHeight newheadnode = return () + | nodeHeight cacheheadnode > nodeHeight newheadnode = do + $(logErrorS) "Cache" $ + "Cache head is above new best block: " <> + blockHashToHex (headerHash (nodeHeader newheadnode)) + throwIO . LogicError . cs $ + "Cache head is above new best block: " <> + blockHashToHex (headerHash (nodeHeader newheadnode)) | otherwise = do ch <- asks cacheWriterChain split <- chainGetSplitBlock cacheheadnode newheadnode ch @@ -180,42 +199,53 @@ else removeHeadC >> newBlockC go3 newheadnode cacheheadnode = do ch <- asks cacheWriterChain - ma <- chainGetAncestor (nodeHeight cacheheadnode + 1) newheadnode ch - case ma of + chainGetAncestor (nodeHeight cacheheadnode + 1) newheadnode ch >>= \case Nothing -> do - throwIO (LogicError "Could not get expected ancestor block") + $(logErrorS) "Cache" $ + "Could not get expected ancestor block at height " <> + cs (show (nodeHeight cacheheadnode + 1)) <> + " for: " <> + blockHashToHex (headerHash (nodeHeader newheadnode)) + throwIO $ LogicError "Could not get expected ancestor block" Just a -> do importBlockC (headerHash (nodeHeader a)) newBlockC -newTxC :: (MonadIO m, StoreRead m) => TxHash -> CacheWriterT m () +newTxC :: (MonadLoggerIO m, StoreRead m) => TxHash -> CacheWriterT m () newTxC th = lift (getTxData th) >>= \case Just txd -> importTxC txd - Nothing -> return () + Nothing -> + $(logErrorS) "Cache" $ "Transaction not found: " <> txHashToHex th -removeTxC :: (MonadIO m, StoreRead m) => TxHash -> CacheWriterT m () +removeTxC :: (MonadLoggerIO m, StoreRead m) => TxHash -> CacheWriterT m () removeTxC th = lift (getTxData th) >>= \case Just txd -> deleteTxC txd - Nothing -> return () + Nothing -> + $(logWarnS) "Cache" $ "Transaction not found: " <> txHashToHex th --------------- -- Importing -- --------------- -importBlockC :: (StoreRead m, MonadIO m) => BlockHash -> CacheWriterT m () +importBlockC :: (StoreRead m, MonadLoggerIO m) => BlockHash -> CacheWriterT m () importBlockC bh = lift (getBlock bh) >>= \case - Nothing -> return () - Just bd -> go bd + Nothing -> do + $(logErrorS) "Cache" $ "Could not get block: " <> blockHashToHex bh + throwIO . LogicError . cs $ + "Could not get block: " <> blockHashToHex bh + Just bd -> do + $(logInfoS) "Cache" $ "Importing block: " <> blockHashToHex bh + go bd where go bd = do let ths = blockDataTxs bd tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths forM_ tds importTxC -removeHeadC :: (StoreRead m, MonadIO m) => CacheWriterT m () +removeHeadC :: (StoreRead m, MonadLoggerIO m) => CacheWriterT m () removeHeadC = void . runMaybeT $ do bh <- MaybeT cacheGetHead @@ -224,11 +254,12 @@ tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) (blockDataTxs bd) + $(logWarnS) "Cache" $ "Reverting head: " <> blockHashToHex bh forM_ (reverse (map (txHash . txData) tds)) removeTxC cacheSetHead (prevBlock (blockDataHeader bd)) syncMempoolC -importTxC :: (StoreRead m, MonadIO m) => TxData -> CacheWriterT m () +importTxC :: (StoreRead m, MonadLoggerIO m) => TxData -> CacheWriterT m () importTxC txd = do updateAddressesC addrs is <- mapM cacheGetAddrInfo addrs @@ -256,8 +287,10 @@ utxos = txUnspent txd addrs = nub (map fst spnts <> map fst utxos) -deleteTxC :: (StoreRead m, MonadIO m) => TxData -> CacheWriterT m () +deleteTxC :: (StoreRead m, MonadLoggerIO m) => TxData -> CacheWriterT m () deleteTxC txd = do + $(logWarnS) "Cache" $ + "Deleting transaction: " <> txHashToHex (txHash (txData txd)) updateAddressesC addrs is <- mapM cacheGetAddrInfo addrs let aim = Map.fromList (catMaybes (zipWith (\a i -> (a, ) <$> i) addrs is)) @@ -280,48 +313,38 @@ addrs = nub (map fst spnts <> map fst utxos) updateAddressesC :: - (StoreRead m, MonadIO m) => [Address] -> CacheWriterT m () + (StoreRead m, MonadLoggerIO m) => [Address] -> CacheWriterT m () updateAddressesC as = do is <- mapM cacheGetAddrInfo as let ais = catMaybes (zipWith (\a i -> (a, ) <$> i) as is) - forM_ (catMaybes is) $ \i -> updateAddressGapC i + forM_ ais $ \(a, i) -> do + updateBalanceC a i + updateAddressGapC i let as' = as \\ map fst ais when (length as /= length as') (updateAddressesC as') updateAddressGapC :: - (StoreRead m, MonadIO m) + (StoreRead m, MonadLoggerIO m) => AddressXPub -> CacheWriterT m () updateAddressGapC i = do - current <- cacheGetXPubIndex (addressXPubSpec i) change - gap <- asks (cacheReaderGap . cacheWriterReader) - let ns = addrsToAddC (addressXPubSpec i) change current new gap - forM_ ns (uncurry updateBalanceC) - case ns of - [] -> return () - _ -> - cacheSetXPubIndex - (addressXPubSpec i) - change - (last (addressXPubPath (snd (last ns)))) - where - change = - case head (addressXPubPath i) of - 1 -> True - 0 -> False - _ -> undefined - new = last (addressXPubPath i) + bals <- runCacheReaderT (cacheGetXPubBalances (addressXPubSpec i)) + gap <- getMaxGap + let ns = addrsToAddC gap i bals + mapM_ (uncurry updateBalanceC) ns updateBalanceC :: - (StoreRead m, MonadIO m) => Address -> AddressXPub -> CacheWriterT m () + (StoreRead m, MonadLoggerIO m) + => Address + -> AddressXPub + -> CacheWriterT m () updateBalanceC a i = do - cacheSetAddrInfo a i b <- lift (getBalance a) cacheAddXPubBalances (addressXPubSpec i) [XPubBal {xPubBalPath = addressXPubPath i, xPubBal = b}] -syncMempoolC :: (MonadIO m, StoreRead m) => CacheWriterT m () +syncMempoolC :: (MonadLoggerIO m, StoreRead m) => CacheWriterT m () syncMempoolC = do nodepool <- map blockTxHash <$> lift getMempool cachepool <- map blockTxHash <$> cacheGetMempool @@ -368,21 +391,6 @@ Left e -> throwIO (RedisError e) Right () -> return () -cacheGetXPubIndex :: MonadIO m => XPubSpec -> Bool -> CacheWriterT m KeyIndex -cacheGetXPubIndex xpub change = do - conn <- asks (cacheReaderConn . cacheWriterReader) - liftIO (runRedis conn (redisGetXPubIndex xpub change)) >>= \case - Left e -> throwIO (RedisError e) - Right x -> return x - -cacheSetXPubIndex :: - MonadIO m => XPubSpec -> Bool -> KeyIndex -> CacheWriterT m () -cacheSetXPubIndex xpub change index = do - conn <- asks (cacheReaderConn . cacheWriterReader) - liftIO (runRedis conn (redisSetXPubIndex xpub change index)) >>= \case - Left e -> throwIO (RedisError e) - Right () -> return () - cacheGetMempool :: MonadIO m => CacheWriterT m [BlockTx] cacheGetMempool = do conn <- asks (cacheReaderConn . cacheWriterReader) @@ -427,13 +435,6 @@ Left e -> throwIO (RedisError e) Right i -> return i -cacheSetAddrInfo :: MonadIO m => Address -> AddressXPub -> CacheWriterT m () -cacheSetAddrInfo a i = do - conn <- asks (cacheReaderConn . cacheWriterReader) - liftIO (runRedis conn (redisSetAddrInfo a i)) >>= \case - Left e -> throwIO (RedisError e) - Right () -> return () - redisAddToMempool :: (Monad m, Monad f, RedisCtx m f) => BlockTx -> m (f ()) redisAddToMempool btx = do f <- @@ -459,8 +460,11 @@ map (\t -> (blockRefScore (blockTxBlock t), encode (blockTxHash t))) btxs - f <- zadd (txSetPfx <> encode xpub) entries - return $ f >> return () + if null entries + then return (return ()) + else do + f <- zadd (txSetPfx <> encode xpub) entries + return $ f >> return () redisRemXPubTxs :: (Monad f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f ()) redisRemXPubTxs xpub txhs = do @@ -471,8 +475,11 @@ (Monad f, RedisCtx m f) => XPubSpec -> [(OutPoint, BlockRef)] -> m (f ()) redisAddXPubUnspents xpub utxo = do let entries = map (\(p, r) -> (blockRefScore r, encode p)) utxo - f <- zadd (utxoPfx <> encode xpub) entries - return $ f >> return () + if null entries + then return (return ()) + else do + f <- zadd (utxoPfx <> encode xpub) entries + return $ f >> return () redisRemXPubUnspents :: (Monad f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f ()) @@ -484,19 +491,20 @@ (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) redisAddXPubBalances xpub bals = do let entries = - map (\b -> (pathScore (xPubBalPath b), encode (xPubBal b))) bals - f <- zadd (balancesPfx <> encode xpub) entries - return $ f >> return () - -redisSetXPubIndex :: (Monad f, RedisCtx m f) => XPubSpec -> Bool -> KeyIndex -> m (f ()) -redisSetXPubIndex xpub change index = do - f <- Redis.set (pfx <> encode xpub) (encode index) - return $ f >> return () - where - pfx = - if change - then chgIndexPfx - else extIndexPfx + map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals + if null entries + then return (return ()) + else do + f <- hmset (balancesPfx <> encode xpub) entries + gs <- + forM bals $ \b -> + redisSetAddrInfo + (balanceAddress (xPubBal b)) + AddressXPub + { addressXPubSpec = xpub + , addressXPubPath = xPubBalPath b + } + return $ f >> sequence gs >> return () redisSetHead :: (Monad m, Monad f, RedisCtx m f) => BlockHash -> m (f ()) redisSetHead bh = do @@ -504,34 +512,32 @@ return $ f >> return () addrsToAddC :: - XPubSpec - -> Bool - -> KeyIndex - -> KeyIndex - -> KeyIndex + KeyIndex + -> AddressXPub + -> [XPubBal] -> [(Address, AddressXPub)] -addrsToAddC xpub change current new gap - | new <= current = [] - | otherwise = - let top = new + gap - indices = [current + 1 .. top] - paths = - map - (Deriv :/ - (if change - then 1 - else 0) :/) - indices - keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths - list = map pathToList paths - xpubf = xPubAddrFunction (xPubDeriveType xpub) - addrs = map xpubf keys - in zipWith - (\a p -> - ( a - , AddressXPub {addressXPubSpec = xpub, addressXPubPath = p})) - addrs - list +addrsToAddC gap i bals = + let headi = head (addressXPubPath i) + maxi = + maximum $ + map (head . tail . xPubBalPath) $ + filter ((== headi) . head . xPubBalPath) bals + xpub = addressXPubSpec i + newi = head (tail (addressXPubPath i)) + genixs = + if maxi - newi < gap + then [maxi + 1 .. newi + gap] + else [] + paths = map (Deriv :/ headi :/) genixs + keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths + list = map pathToList paths + xpubf = xPubAddrFunction (xPubDeriveType xpub) + addrs = map xpubf keys + in zipWith + (\a p -> + (a, AddressXPub {addressXPubSpec = xpub, addressXPubPath = p})) + addrs + list sortTxData :: [TxData] -> [TxData] sortTxData tds = diff --git a/src/Network/Haskoin/Store/Common.hs b/src/Network/Haskoin/Store/Common.hs --- a/src/Network/Haskoin/Store/Common.hs +++ b/src/Network/Haskoin/Store/Common.hs @@ -175,8 +175,10 @@ getMempool :: m [BlockTx] xPubBals :: XPubSpec -> m [XPubBal] xPubBals xpub = do + gap <- getMaxGap ext <- derive_until_gap + gap 0 (deriveAddresses (deriveFunction (xPubDeriveType xpub)) @@ -184,6 +186,7 @@ 0) chg <- derive_until_gap + gap 1 (deriveAddresses (deriveFunction (xPubDeriveType xpub)) @@ -192,15 +195,14 @@ return (ext ++ chg) where xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b} - derive_until_gap _ [] = return [] - derive_until_gap m as = do - let n = 32 - let (as1, as2) = splitAt n as + derive_until_gap _ _ [] = return [] + derive_until_gap gap m as = do + let (as1, as2) = splitAt (fromIntegral gap) as bs <- getBalances (map snd as1) let xbs = zipWith (xbalance m) bs (map fst as1) if all nullBalance bs then return xbs - else (xbs <>) <$> derive_until_gap m as2 + else (xbs <>) <$> derive_until_gap gap m as2 xPubSummary :: XPubSpec -> m XPubSummary xPubSummary xpub = do bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub @@ -256,6 +258,8 @@ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts return $ applyOffsetLimit offset limit ts' + getMaxGap :: m Word32 + getMaxGap = return 32 class StoreWrite m where setBest :: BlockHash -> m () @@ -1072,7 +1076,7 @@ data XPubBal = XPubBal { xPubBalPath :: ![KeyIndex] , xPubBal :: !Balance - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Ord, Eq, Generic, NFData) -- | JSON serialization for 'XPubBal'. xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv] diff --git a/src/Network/Haskoin/Store/Data/CacheReader.hs b/src/Network/Haskoin/Store/Data/CacheReader.hs --- a/src/Network/Haskoin/Store/Data/CacheReader.hs +++ b/src/Network/Haskoin/Store/Data/CacheReader.hs @@ -14,12 +14,14 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Short as BSS import Data.Either (rights) +import Data.List (sort) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe) import Data.Serialize (Serialize, decode, encode) -import Data.Word (Word64) +import Data.Word (Word32, Word64) import Database.Redis (Connection, RedisCtx, Reply, - runRedis, zrangeWithscores, + hgetall, runRedis, + zrangeWithscores, zrangebyscoreWithscoresLimit) import qualified Database.Redis as Redis import GHC.Generics (Generic) @@ -37,8 +39,8 @@ data CacheReaderConfig = CacheReaderConfig { cacheReaderConn :: !Connection - , cacheReaderGap :: !KeyIndex , cacheReaderWriter :: !CacheWriter + , cacheReaderGap :: !Word32 } @@ -75,6 +77,7 @@ xPubBals = getXPubBalances xPubUnspents = getXPubUnspents xPubTxs = getXPubTxs + getMaxGap = asks cacheReaderGap withCacheReader :: StoreRead m => CacheReaderConfig -> CacheReaderT m a -> m a withCacheReader s f = runReaderT f s @@ -86,14 +89,6 @@ cacheVerCurrent :: ByteString cacheVerCurrent = "1" --- External max index -extIndexPfx :: ByteString -extIndexPfx = "e" - --- Change max index -chgIndexPfx :: ByteString -chgIndexPfx = "c" - -- Ordered set of transaction ids in mempool mempoolSetKey :: ByteString mempoolSetKey = "mempool" @@ -248,12 +243,12 @@ redisGetXPubBalances :: (Monad f, RedisCtx m f) => XPubSpec -> m (f [XPubBal]) redisGetXPubBalances xpub = do - xs <- getFromSortedSet (balancesPfx <> encode xpub) Nothing 0 Nothing + fxs <- getAllFromMap (balancesPfx <> encode xpub) return $ do - xs' <- xs - return (map (uncurry f) xs') + xs <- fxs + return (sort $ map (uncurry f) xs) where - f b s = XPubBal {xPubBalPath = scorePath s, xPubBal = b} + f p b = XPubBal {xPubBalPath = p, xPubBal = b} redisGetXPubTxs :: (Monad f, RedisCtx m f) @@ -295,20 +290,6 @@ where f o s = (scoreBlockRef s, o) -redisGetXPubIndex :: (Monad f, RedisCtx m f) => XPubSpec -> Bool -> m (f KeyIndex) -redisGetXPubIndex xpub change = do - f <- Redis.get (pfx <> encode xpub) - return $ f >>= \case - Nothing -> return 0 - Just x -> case decode x of - Left e -> error e - Right n -> return n - where - pfx = - if change - then chgIndexPfx - else extIndexPfx - blockRefScore :: BlockRef -> Double blockRefScore BlockRef {blockRefHeight = h, blockRefPos = p} = fromIntegral (0x001fffffffffffff - (h' .|. p')) @@ -329,21 +310,6 @@ h = fromIntegral (m `shift` (-26)) p = fromIntegral (m .&. 0x03ffffff) -pathScore :: [KeyIndex] -> Double -pathScore [m, n] - | m == 0 || m == 1 = fromIntegral (toInteger n .|. toInteger m `shift` 32) - | otherwise = undefined -pathScore _ = undefined - -scorePath :: Double -> [KeyIndex] -scorePath s - | s < 0 = undefined - | s > 0x01ffffffff = undefined - | otherwise = - [ fromInteger (round s `shift` (-32)) - , fromInteger (round s .&. 0xffffffff) - ] - getFromSortedSet :: (Monad f, RedisCtx m f, Serialize a) => ByteString @@ -383,3 +349,18 @@ return $ do ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs return (rights ys) + +getAllFromMap :: + (Monad f, RedisCtx m f, Serialize k, Serialize v) + => ByteString + -> m (f [(k, v)]) +getAllFromMap n = do + fxs <- hgetall n + return $ do + xs <- fxs + return + [ (k, v) + | (k', v') <- xs + , let Right k = decode k' + , let Right v = decode v' + ] diff --git a/src/Network/Haskoin/Store/Data/DatabaseReader.hs b/src/Network/Haskoin/Store/Data/DatabaseReader.hs --- a/src/Network/Haskoin/Store/Data/DatabaseReader.hs +++ b/src/Network/Haskoin/Store/Data/DatabaseReader.hs @@ -6,7 +6,8 @@ mapC, runConduit, runResourceT, sinkList, (.|)) import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Reader (ReaderT, ask, asks, + runReaderT) import Data.Function (on) import Data.IntMap (IntMap) import qualified Data.IntMap.Strict as I @@ -48,22 +49,29 @@ DatabaseReader { databaseHandle :: !DB , databaseReadOptions :: !ReadOptions + , databaseMaxGap :: !Word32 } dataVersion :: Word32 dataVersion = 16 -connectRocksDB :: MonadIO m => FilePath -> m DatabaseReader -connectRocksDB dir = do - bdb <- open - dir - defaultOptions - { createIfMissing = True - , compression = SnappyCompression - , maxOpenFiles = -1 - , writeBufferSize = 2 ^ (30 :: Integer) - } >>= \db -> - return DatabaseReader {databaseReadOptions = defaultReadOptions, databaseHandle = db} +connectRocksDB :: MonadIO m => Word32 -> FilePath -> m DatabaseReader +connectRocksDB gap dir = do + bdb <- + open + dir + defaultOptions + { createIfMissing = True + , compression = SnappyCompression + , maxOpenFiles = -1 + , writeBufferSize = 2 ^ (30 :: Integer) + } >>= \db -> + return + DatabaseReader + { databaseReadOptions = defaultReadOptions + , databaseHandle = db + , databaseMaxGap = gap + } initRocksDB bdb return bdb @@ -255,3 +263,4 @@ getOrphans = ask >>= getOrphansDB getAddressUnspents a b c = ask >>= getAddressUnspentsDB a b c getAddressTxs a b c = ask >>= getAddressTxsDB a b c + getMaxGap = asks databaseMaxGap diff --git a/src/Network/Haskoin/Store/Data/DatabaseWriter.hs b/src/Network/Haskoin/Store/Data/DatabaseWriter.hs --- a/src/Network/Haskoin/Store/Data/DatabaseWriter.hs +++ b/src/Network/Haskoin/Store/Data/DatabaseWriter.hs @@ -39,6 +39,7 @@ import Network.Haskoin.Store.Data.DatabaseReader (DatabaseReader (..), withDatabaseReader) import Network.Haskoin.Store.Data.MemoryDatabase (MemoryDatabase (..), + MemoryState (..), emptyMemoryDatabase, getMempoolH, getOrphanTxH, @@ -58,20 +59,27 @@ SpenderKey (..), TxKey (..), UnspentKey (..)) -import UnliftIO (MonadIO, TVar, - newTVarIO, +import UnliftIO (MonadIO, newTVarIO, readTVarIO) data DatabaseWriter = DatabaseWriter { databaseWriterReader :: !DatabaseReader - , databaseWriterState :: !(TVar MemoryDatabase) + , databaseWriterState :: !MemoryState } runDatabaseWriter :: - (MonadIO m, MonadError e m) => DatabaseReader -> ReaderT DatabaseWriter m a -> m a -runDatabaseWriter bdb@DatabaseReader {databaseHandle = db} f = do + (MonadIO m, MonadError e m) + => DatabaseReader + -> ReaderT DatabaseWriter m a + -> m a +runDatabaseWriter bdb@DatabaseReader {databaseHandle = db, databaseMaxGap = gap} f = do hm <- newTVarIO emptyMemoryDatabase - x <- R.runReaderT f DatabaseWriter {databaseWriterReader = bdb, databaseWriterState = hm} + let ms = MemoryState {memoryDatabase = hm, memoryMaxGap = gap} + x <- + R.runReaderT + f + DatabaseWriter + {databaseWriterReader = bdb, databaseWriterState = ms} ops <- hashMapOps <$> readTVarIO hm writeBatch db ops return x @@ -270,19 +278,19 @@ getOrphanTxI h DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where - f = getOrphanTxH h <$> readTVarIO hm + f = getOrphanTxH h <$> readTVarIO (memoryDatabase hm) g = Just <$> withDatabaseReader db (getOrphanTx h) getSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Spender) getSpenderI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where - f = getSpenderH op <$> readTVarIO hm + f = getSpenderH op <$> readTVarIO (memoryDatabase hm) g = Just <$> withDatabaseReader db (getSpender op) getSpendersI :: MonadIO m => TxHash -> DatabaseWriter -> m (IntMap Spender) getSpendersI t DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = do - hsm <- getSpendersH t <$> readTVarIO hm + hsm <- getSpendersH t <$> readTVarIO (memoryDatabase hm) dsm <- I.map Just <$> withDatabaseReader db (getSpenders t) return . I.map fromJust . I.filter isJust $ hsm <> dsm @@ -313,7 +321,7 @@ getUnspentI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where - f = getUnspentH op <$> readTVarIO hm + f = getUnspentH op <$> readTVarIO (memoryDatabase hm) g = Just <$> withDatabaseReader db (getUnspent op) insertUnspentI :: MonadIO m => Unspent -> DatabaseWriter -> m () @@ -329,7 +337,7 @@ => DatabaseWriter -> m [BlockTx] getMempoolI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} = - getMempoolH <$> readTVarIO hm >>= \case + getMempoolH <$> readTVarIO (memoryDatabase hm) >>= \case Just xs -> return xs Nothing -> withDatabaseReader db getMempool @@ -347,6 +355,7 @@ getAddressesTxs = undefined getAddressesUnspents = undefined getOrphans = undefined + getMaxGap = R.asks (databaseMaxGap . databaseWriterReader) instance MonadIO m => StoreWrite (ReaderT DatabaseWriter m) where setBest h = R.ask >>= setBestI h diff --git a/src/Network/Haskoin/Store/Data/MemoryDatabase.hs b/src/Network/Haskoin/Store/Data/MemoryDatabase.hs --- a/src/Network/Haskoin/Store/Data/MemoryDatabase.hs +++ b/src/Network/Haskoin/Store/Data/MemoryDatabase.hs @@ -16,6 +16,7 @@ import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, maybeToList) +import Data.Word (Word32) import Haskoin (Address, BlockHash, BlockHeight, OutPoint (..), Tx, TxHash, headerHash, @@ -33,7 +34,17 @@ import Network.Haskoin.Store.Data.Types (OutVal (..)) import UnliftIO -withMemoryDatabase :: MonadIO m => TVar MemoryDatabase -> ReaderT (TVar MemoryDatabase) m a -> m a +data MemoryState = + MemoryState + { memoryDatabase :: !(TVar MemoryDatabase) + , memoryMaxGap :: !Word32 + } + +withMemoryDatabase :: + MonadIO m + => MemoryState + -> ReaderT MemoryState m a + -> m a withMemoryDatabase = flip R.runReaderT data MemoryDatabase = MemoryDatabase @@ -293,99 +304,100 @@ (hUnspent db) } -instance MonadIO m => StoreRead (ReaderT (TVar MemoryDatabase) m) where +instance MonadIO m => StoreRead (ReaderT MemoryState m) where getBestBlock = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getBestBlockH v getBlocksAtHeight h = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getBlocksAtHeightH h v getBlock b = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getBlockH b v getTxData t = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getTxDataH t v getSpender t = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return . join $ getSpenderH t v getSpenders t = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return . I.map fromJust . I.filter isJust $ getSpendersH t v getOrphanTx h = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return . join $ getOrphanTxH h v getUnspent p = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return . join $ getUnspentH p v getBalance a = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getBalanceH a v getMempool = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return . fromMaybe [] $ getMempoolH v getAddressesTxs addr start limit = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getAddressesTxsH addr start limit v getAddressesUnspents addr start limit = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getAddressesUnspentsH addr start limit v getOrphans = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getOrphansH v getAddressTxs addr start limit = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getAddressTxsH addr start limit v getAddressUnspents addr start limit = do - v <- R.ask >>= readTVarIO + v <- R.asks memoryDatabase >>= readTVarIO return $ getAddressUnspentsH addr start limit v + getMaxGap = R.asks memoryMaxGap -instance (MonadIO m) => StoreWrite (ReaderT (TVar MemoryDatabase) m) where +instance MonadIO m => StoreWrite (ReaderT MemoryState m) where setBest h = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (setBestH h) insertBlock b = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertBlockH b) setBlocksAtHeight h g = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (setBlocksAtHeightH h g) insertTx t = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertTxH t) insertSpender p s = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertSpenderH p s) deleteSpender p = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (deleteSpenderH p) insertAddrTx a t = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertAddrTxH a t) deleteAddrTx a t = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (deleteAddrTxH a t) insertAddrUnspent a u = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertAddrUnspentH a u) deleteAddrUnspent a u = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (deleteAddrUnspentH a u) setMempool xs = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (setMempoolH xs) insertOrphanTx t u = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertOrphanTxH t u) deleteOrphanTx h = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (deleteOrphanTxH h) setBalance b = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (setBalanceH b) insertUnspent h = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (insertUnspentH h) deleteUnspent p = do - v <- R.ask + v <- R.asks memoryDatabase atomically $ modifyTVar v (deleteUnspentH p) diff --git a/src/Network/Haskoin/Store/Web.hs b/src/Network/Haskoin/Store/Web.hs --- a/src/Network/Haskoin/Store/Web.hs +++ b/src/Network/Haskoin/Store/Web.hs @@ -204,6 +204,7 @@ , maxLimitFull :: !Word32 , maxLimitOffset :: !Word32 , maxLimitDefault :: !Word32 + , maxLimitGap :: !Word32 } deriving (Eq, Show) @@ -284,7 +285,8 @@ (getAddressesUnspents addrs start limit) getOrphans = runInWebReader getOrphans getOrphans xPubBals xpub = runInWebReader (xPubBals xpub) (xPubBals xpub) - xPubSummary xpub = runInWebReader (xPubSummary xpub) (xPubSummary xpub) + xPubSummary xpub = + runInWebReader (xPubSummary xpub) (xPubSummary xpub) xPubUnspents xpub start offset limit = runInWebReader (xPubUnspents xpub start offset limit) @@ -315,6 +317,7 @@ xPubUnspents xpub start offset limit = lift (xPubUnspents xpub start offset limit) xPubTxs xpub start offset limit = lift (xPubTxs xpub start offset limit) + getMaxGap = lift $ asks (maxLimitGap . webMaxLimits) defHandler :: Monad m => Except -> WebT m () defHandler e = do diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -8,6 +8,7 @@ import Control.Monad.Logger import Control.Monad.Trans import Data.Maybe +import Data.Word import Database.RocksDB import Haskoin import Haskoin.Node @@ -72,8 +73,7 @@ MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a withTestStore net t f = withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> - runNoLoggingT $ do - x <- newInbox + runNoLoggingT $ withPublisher $ \pub -> do db <- open w @@ -86,6 +86,7 @@ DatabaseReader { databaseHandle = db , databaseReadOptions = defaultReadOptions + , databaseMaxGap = gap } let cfg = StoreConfig @@ -94,15 +95,19 @@ , storeConfDiscover = True , storeConfDB = bdb , storeConfNetwork = net - , storeConfListen = (`sendSTM` x) + , storeConfPublisher = pub , storeConfCache = Nothing + , storeConfGap = gap } - withStore cfg $ \Store {..} -> + withStore cfg $ \Store {..} -> withSubscription pub $ \sub -> lift $ f TestStore { testStoreDB = bdb , testStoreBlockStore = storeBlock , testStoreChain = storeChain - , testStoreEvents = x + , testStoreEvents = sub } + +gap :: Word32 +gap = 32 diff --git a/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs b/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs --- a/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs +++ b/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs @@ -1,16 +1,12 @@ module Network.Haskoin.Store.Data.CacheReaderSpec (spec) where import Data.List (sort) -import Haskoin (KeyIndex) import Network.Haskoin.Store.Common (BlockRef (..)) import Network.Haskoin.Store.Data.CacheReader (blockRefScore, - pathScore, - scoreBlockRef, - scorePath) + scoreBlockRef) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Gen, arbitrary, choose, - elements, forAll, +import Test.QuickCheck (Gen, choose, forAll, listOf, oneof) spec :: Spec @@ -25,25 +21,6 @@ let score = blockRefScore b ref = scoreBlockRef score in ref == b - describe "Score for derivation path" $ do - prop "sorts correctly" $ - forAll arbitraryDerivationPaths $ \ds -> - let scores = map pathScore (sort ds) - in sort scores == scores - prop "respects identity" $ - forAll arbitraryDerivationPath $ \d -> - let score = pathScore d - d' = scorePath score - in d' == d - -arbitraryDerivationPaths :: Gen [[KeyIndex]] -arbitraryDerivationPaths = listOf arbitraryDerivationPath - -arbitraryDerivationPath :: Gen [KeyIndex] -arbitraryDerivationPath = do - x <- elements [0, 1] - y <- arbitrary - return [x, y] arbitraryBlockRefs :: Gen [BlockRef] arbitraryBlockRefs = listOf arbitraryBlockRef