haskoin-store 0.21.1 → 0.21.2
raw patch · 13 files changed
+426/−325 lines, 13 files
Files
- CHANGELOG.md +4/−0
- app/Main.hs +79/−32
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +55/−11
- src/Network/Haskoin/Store/CacheWriter.hs +148/−142
- src/Network/Haskoin/Store/Common.hs +10/−6
- src/Network/Haskoin/Store/Data/CacheReader.hs +25/−44
- src/Network/Haskoin/Store/Data/DatabaseReader.hs +21/−12
- src/Network/Haskoin/Store/Data/DatabaseWriter.hs +20/−11
- src/Network/Haskoin/Store/Data/MemoryDatabase.hs +46/−34
- src/Network/Haskoin/Store/Web.hs +4/−1
- test/Haskoin/StoreSpec.hs +10/−5
- test/Network/Haskoin/Store/Data/CacheReaderSpec.hs +2/−25
CHANGELOG.md view
@@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.21.2+### Added+- Complete support for Redis xpub cache.+ ## 0.21.1 ### Fixed - Latest version of secp256k1-haskell works with Debian 9.
app/Main.hs view
@@ -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
haskoin-store.cabal view
@@ -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
src/Haskoin/Store.hs view
@@ -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
src/Network/Haskoin/Store/CacheWriter.hs view
@@ -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 =
src/Network/Haskoin/Store/Common.hs view
@@ -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]
src/Network/Haskoin/Store/Data/CacheReader.hs view
@@ -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'+ ]
src/Network/Haskoin/Store/Data/DatabaseReader.hs view
@@ -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
src/Network/Haskoin/Store/Data/DatabaseWriter.hs view
@@ -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
src/Network/Haskoin/Store/Data/MemoryDatabase.hs view
@@ -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)
src/Network/Haskoin/Store/Web.hs view
@@ -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
test/Haskoin/StoreSpec.hs view
@@ -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
test/Network/Haskoin/Store/Data/CacheReaderSpec.hs view
@@ -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