haskoin-store 0.32.3 → 0.33.0
raw patch · 9 files changed
+360/−448 lines, 9 filesdep ~haskoin-storedep ~haskoin-store-data
Dependency ranges changed: haskoin-store, haskoin-store-data
Files
- haskoin-store.cabal +6/−6
- src/Haskoin/Store.hs +5/−1
- src/Haskoin/Store/BlockStore.hs +8/−8
- src/Haskoin/Store/Cache.hs +46/−51
- src/Haskoin/Store/Common.hs +49/−19
- src/Haskoin/Store/Database/Reader.hs +26/−38
- src/Haskoin/Store/Database/Writer.hs +101/−206
- src/Haskoin/Store/Logic.hs +98/−98
- src/Haskoin/Store/Web.hs +21/−21
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b126ca9e0b24c8a0034623014cee613cf8f8493a1e4b2f3c9ea53899ed3996f1+-- hash: fe5bce5595173d04931b03f64216979f6d0c288b443e63e489e4a5af75b1d804 name: haskoin-store-version: 0.32.3+version: 0.33.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@@ -53,7 +53,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1- , haskoin-store-data ==0.32.3+ , haskoin-store-data ==0.33.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32@@ -96,7 +96,7 @@ , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 , haskoin-store- , haskoin-store-data ==0.32.3+ , haskoin-store-data ==0.33.0 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1@@ -135,8 +135,8 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1- , haskoin-store ==0.32.3- , haskoin-store-data ==0.32.3+ , haskoin-store ==0.33.0+ , haskoin-store-data ==0.33.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store.hs view
@@ -16,11 +16,15 @@ , isInCache , evictFromCache -- * Store Reader- , StoreRead(..)+ , StoreReadBase(..)+ , StoreReadExtra(..) , Limits(..) , Start(..) -- * Useful Fuctions , getTransaction+ , getDefaultBalance+ , getSpenders+ , getActiveTxData , blockAtOrBefore -- * Other Data , PubExcept(..)
src/Haskoin/Store/BlockStore.hs view
@@ -171,11 +171,7 @@ runRocksDB f = ReaderT $ runReaderT f . blockConfDB . myConfig -instance MonadIO m => StoreRead (BlockT m) where- getMaxGap =- runRocksDB getMaxGap- getInitialGap =- runRocksDB getInitialGap+instance MonadIO m => StoreReadBase (BlockT m) where getNetwork = runRocksDB getNetwork getBestBlock =@@ -188,14 +184,18 @@ runRocksDB . getTxData getSpender = runRocksDB . getSpender- getSpenders =- runRocksDB . getSpenders getUnspent = runRocksDB . getUnspent getBalance = runRocksDB . getBalance getMempool = runRocksDB getMempool++instance MonadIO m => StoreReadExtra (BlockT m) where+ getMaxGap =+ runRocksDB getMaxGap+ getInitialGap =+ runRocksDB getInitialGap getAddressesTxs as = runRocksDB . getAddressesTxs as getAddressesUnspents as =@@ -447,7 +447,7 @@ fulfill p = p {pendingDeps = HashSet.delete th (pendingDeps p)} updateOrphans- :: ( StoreRead m+ :: ( StoreReadBase m , MonadLoggerIO m , MonadReader BlockRead m )
src/Haskoin/Store/Cache.hs view
@@ -70,10 +70,7 @@ import Haskoin.Node (Chain, chainBlockMain, chainGetAncestor, chainGetBest, chainGetBlock)-import Haskoin.Store.Common (Limits (..), Start (..),- StoreRead (..), sortTxs, xPubBals,- xPubBalsTxs, xPubBalsUnspents,- xPubTxs)+import Haskoin.Store.Common import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), DeriveType (..), Prev (..), TxData (..), TxRef (..),@@ -120,23 +117,25 @@ Right r -> return r liftIO (checkedConnect conninfo) -instance (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) =>- StoreRead (CacheT m) where+instance (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ StoreReadBase (CacheT m) where getNetwork = lift getNetwork getBestBlock = lift getBestBlock getBlocksAtHeight = lift . getBlocksAtHeight getBlock = lift . getBlock getTxData = lift . getTxData- getSpenders = lift . getSpenders getSpender = lift . getSpender getBalance = lift . getBalance+ getUnspent = lift . getUnspent+ getMempool = lift getMempool++instance (MonadUnliftIO m , MonadLoggerIO m, StoreReadExtra m) =>+ StoreReadExtra (CacheT m) where getBalances = lift . getBalances getAddressesTxs addrs = lift . getAddressesTxs addrs getAddressTxs addr = lift . getAddressTxs addr- getUnspent = lift . getUnspent getAddressUnspents addr = lift . getAddressUnspents addr getAddressesUnspents addrs = lift . getAddressesUnspents addrs- getMempool = lift getMempool xPubBals xpub = ask >>= \case Nothing -> lift (xPubBals xpub)@@ -152,7 +151,7 @@ getMaxGap = lift getMaxGap getInitialGap = lift getInitialGap -withCache :: StoreRead m => Maybe CacheConfig -> CacheT m a -> m a+withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a withCache s f = runReaderT f s balancesPfx :: ByteString@@ -165,10 +164,8 @@ utxoPfx = "u" getXPubTxs ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => XPubSpec- -> Limits- -> CacheX m [TxRef]+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => XPubSpec -> Limits -> CacheX m [TxRef] getXPubTxs xpub limits = do xpubtxt <- xpubText xpub $(logDebugS) "Cache" $ "Getting xpub txs for " <> xpubtxt@@ -194,10 +191,8 @@ lift $ xPubBalsTxs bals limits getXPubUnspents ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => XPubSpec- -> Limits- -> CacheX m [XPubUnspent]+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => XPubSpec -> Limits -> CacheX m [XPubUnspent] getXPubUnspents xpub limits = do xpubtxt <- xpubText xpub $(logDebugS) "Cache" $ "Getting utxo for xpub " <> xpubtxt@@ -244,9 +239,8 @@ return xpubutxo getXPubBalances ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => XPubSpec- -> CacheX m [XPubBal]+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => XPubSpec -> CacheX m [XPubBal] getXPubBalances xpub = do xpubtxt <- xpubText xpub $(logDebugS) "Cache" $ "Getting balances for xpub " <> xpubtxt@@ -280,7 +274,7 @@ return bals cacheGetXPubTxs ::- (StoreRead m, MonadLoggerIO m)+ (StoreReadBase m, MonadLoggerIO m) => XPubSpec -> Limits -> CacheX m [TxRef]@@ -308,7 +302,7 @@ f t s = TxRef {txRefHash = t, txRefBlock = scoreBlockRef s} cacheGetXPubUnspents ::- (StoreRead m, MonadLoggerIO m)+ (StoreReadBase m, MonadLoggerIO m) => XPubSpec -> Limits -> CacheX m [(BlockRef, OutPoint)]@@ -455,10 +449,8 @@ xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr cacheWriter ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => CacheConfig- -> CacheWriterInbox- -> m ()+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => CacheConfig -> CacheWriterInbox -> m () cacheWriter cfg inbox = runReaderT go cfg where go = do@@ -549,7 +541,8 @@ threadDelay r go -pruneDB :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m Integer+pruneDB :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => CacheX m Integer pruneDB = isAnythingCached >>= \case True -> do@@ -583,9 +576,8 @@ void <$> Redis.zadd maxKey (map ((realToFrac now, ) . encode) xpubs) cacheWriterReact ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => CacheWriterMessage- -> CacheX m ()+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => CacheWriterMessage -> CacheX m () cacheWriterReact CacheNewBlock = newBlockC cacheWriterReact (CacheNewTx th) = newTxC th cacheWriterReact CachePing = syncMempoolC@@ -594,9 +586,8 @@ lenNotNull bals = length $ filter (not . nullBalance . xPubBal) bals newXPubC ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => XPubSpec- -> CacheX m ([XPubBal], Bool)+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => XPubSpec -> CacheX m ([XPubBal], Bool) newXPubC xpub = cachePrime >>= \case Nothing -> do@@ -647,8 +638,8 @@ return $ b >> c >> d >> e >> return () $(logDebugS) "Cache" $ "Done caching xpub: " <> xpubtxt -newTxC ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => TxHash -> CacheX m ()+newTxC :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => TxHash -> CacheX m () newTxC th = withLockWait importLockKey $ isAnythingCached >>= \case@@ -670,7 +661,8 @@ $(logDebugS) "Cache" $ "Tx already in cache: " <> txHashToHex th -newBlockC :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m ()+newBlockC :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => CacheX m () newBlockC = withLockWait importLockKey f where f =@@ -732,7 +724,8 @@ Just newcachenode -> importBlockC (headerHash (nodeHeader newcachenode)) >> f -importBlockC :: (MonadUnliftIO m, StoreRead m, MonadLoggerIO m) => BlockHash -> CacheX m ()+importBlockC :: (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m)+ => BlockHash -> CacheX m () importBlockC bh = lift (getBlock bh) >>= \case Nothing -> do@@ -756,7 +749,8 @@ blockHashToHex bh cacheSetHead bh -removeHeadC :: (StoreRead m, MonadUnliftIO m, MonadLoggerIO m) => CacheX m ()+removeHeadC :: (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m)+ => CacheX m () removeHeadC = void . runMaybeT $ do bh <- MaybeT cacheGetHead@@ -773,9 +767,8 @@ cacheSetHead (prevBlock (blockDataHeader bd)) importMultiTxC ::- (MonadUnliftIO m, StoreRead m, MonadLoggerIO m)- => [TxData]- -> CacheX m ()+ (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m)+ => [TxData] -> CacheX m () importMultiTxC txs = do $(logDebugS) "Cache" $ "Processing " <> cs (show (length txs)) <> " txs…" $(logDebugS) "Cache" $@@ -825,7 +818,7 @@ HashMap.fromList . catMaybes . zipWith (\p -> fmap (p, )) allops <$> lift (mapM getUnspent allops) getbalances addrs =- HashMap.fromList . zip addrs <$> mapM (lift . getBalance) addrs+ HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs getxbals xpubs = do bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do@@ -913,7 +906,7 @@ XPubBal {xPubBalPath = addressXPubPath ainfo, xPubBal = bal} cacheAddAddresses ::- (StoreRead m, MonadUnliftIO m, MonadLoggerIO m)+ (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) => [(Address, AddressXPub)] -> CacheX m () cacheAddAddresses [] = $(logDebugS) "Cache" "No further addresses to add"@@ -962,7 +955,7 @@ let f b = ( addressXPubSpec i , [XPubBal {xPubBal = b, xPubBalPath = addressXPubPath i}])- in f <$> lift (getBalance a)+ in f <$> lift (getDefaultBalance a) getutxo a i = let f us = ( addressXPubSpec i@@ -985,7 +978,8 @@ Nothing -> [] Just bals -> addrsToAdd gap bals a -syncMempoolC :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m ()+syncMempoolC :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => CacheX m () syncMempoolC = do nodepool <- HashSet.fromList . map txRefHash <$> lift getMempool cachepool <- HashSet.fromList . map txRefHash <$> cacheGetMempool@@ -1017,7 +1011,7 @@ cacheGetHead = runRedis redisGetHead cachePrime ::- (StoreRead m, MonadUnliftIO m, MonadLoggerIO m)+ (StoreReadBase m, MonadUnliftIO m, MonadLoggerIO m) => CacheX m (Maybe BlockHash) cachePrime = cacheGetHead >>= \case@@ -1048,7 +1042,7 @@ return Nothing Just cachehead -> return (Just cachehead) -cacheSetHead :: (MonadLoggerIO m, StoreRead m) => BlockHash -> CacheX m ()+cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m () cacheSetHead bh = do $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh void $ runRedis (redisSetHead bh)@@ -1074,7 +1068,7 @@ redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i) evictFromCache ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => [XPubSpec] -> CacheT m () evictFromCache xpubs = ask >>= \case@@ -1082,7 +1076,7 @@ Just cfg -> void (runReaderT (delXPubKeys xpubs) cfg) delXPubKeys ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => [XPubSpec] -> CacheX m Integer delXPubKeys [] = return 0@@ -1233,7 +1227,8 @@ where f t s = TxRef {txRefBlock = scoreBlockRef s, txRefHash = t} -xpubText :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => XPubSpec -> CacheX m Text+xpubText :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => XPubSpec -> CacheX m Text xpubText xpub = do net <- lift getNetwork return . cs $ xPubExport net (xPubSpecKey xpub)
src/Haskoin/Store/Common.hs view
@@ -5,15 +5,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module Haskoin.Store.Common ( Limits(..) , Start(..)- , StoreRead(..)+ , StoreReadBase(..)+ , StoreReadExtra(..) , StoreWrite(..) , StoreEvent(..) , PubExcept(..) , getActiveBlock , getActiveTxData+ , getDefaultBalance+ , getSpenders , xPubBalsTxs , xPubBalsUnspents , getTransaction@@ -37,8 +41,9 @@ import Data.Hashable (Hashable) import qualified Data.HashSet as H import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I import Data.List (sortBy)-import Data.Maybe (listToMaybe)+import Data.Maybe (catMaybes, listToMaybe) import Data.Serialize (Serialize (..)) import Data.Word (Word32, Word64) import GHC.Generics (Generic)@@ -58,7 +63,8 @@ TxRef (..), UnixTime, Unspent (..), XPubBal (..), XPubSpec (..), XPubSummary (..), XPubUnspent (..),- nullBalance, toTransaction)+ nullBalance, toTransaction,+ zeroBalance) type DeriveAddr = XPubKey -> KeyIndex -> Address @@ -86,28 +92,30 @@ instance Default Limits where def = defaultLimits -class Monad m =>- StoreRead m- where+class Monad m => StoreReadBase m where getNetwork :: m Network getBestBlock :: m (Maybe BlockHash) getBlocksAtHeight :: BlockHeight -> m [BlockHash] getBlock :: BlockHash -> m (Maybe BlockData) getTxData :: TxHash -> m (Maybe TxData)- getSpenders :: TxHash -> m (IntMap Spender) getSpender :: OutPoint -> m (Maybe Spender)- getBalance :: Address -> m Balance- getBalance a = head <$> getBalances [a]+ getBalance :: Address -> m (Maybe Balance)+ getUnspent :: OutPoint -> m (Maybe Unspent)+ getMempool :: m [TxRef]++class StoreReadBase m => StoreReadExtra m where getBalances :: [Address] -> m [Balance]- getBalances = mapM getBalance+ getBalances as =+ zipWith f as <$> mapM getBalance as+ where+ f a Nothing = zeroBalance a+ f _ (Just b) = b getAddressesTxs :: [Address] -> Limits -> m [TxRef] getAddressTxs :: Address -> Limits -> m [TxRef] getAddressTxs a = getAddressesTxs [a]- getUnspent :: OutPoint -> m (Maybe Unspent) getAddressUnspents :: Address -> Limits -> m [Unspent] getAddressUnspents a = getAddressesUnspents [a] getAddressesUnspents :: [Address] -> Limits -> m [Unspent]- getMempool :: m [TxRef] xPubBals :: XPubSpec -> m [XPubBal] xPubBals xpub = do igap <- getInitialGap@@ -191,18 +199,38 @@ 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 . zipWith f [0..]+ <$> mapM getSpender (ops td) -getActiveBlock :: StoreRead m => BlockHash -> m (Maybe BlockData)+ where+ f i m = (i, ) <$> m+ ops td =+ let tx = txData td+ outs = txOut tx+ op i _ = OutPoint th i+ in zipWith op [0..] outs++getActiveBlock :: StoreReadExtra m => BlockHash -> m (Maybe BlockData) getActiveBlock bh = getBlock bh >>= \case Just b | blockDataMainChain b -> return (Just b) _ -> return Nothing -getActiveTxData :: StoreRead m => TxHash -> m (Maybe TxData)+getActiveTxData :: StoreReadBase m => TxHash -> m (Maybe TxData) getActiveTxData th = getTxData th >>= \case Just td | not (txDataDeleted td) -> return (Just td) _ -> return Nothing -xUns :: StoreRead f => Limits -> [XPubBal] -> f [XPubUnspent]+getDefaultBalance :: StoreReadBase m => Address -> m Balance+getDefaultBalance a = getBalance a >>= \case+ Nothing -> return $ zeroBalance a+ Just b -> return b++xUns :: StoreReadExtra f => Limits -> [XPubBal] -> f [XPubUnspent] xUns limits bs = concat <$> mapM g bs where f p t = XPubUnspent {xPubUnspentPath = p, xPubUnspent = t}@@ -219,7 +247,7 @@ deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i xPubBalsUnspents ::- StoreRead m+ StoreReadExtra m => [XPubBal] -> Limits -> m [XPubUnspent]@@ -230,7 +258,7 @@ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0 xPubBalsTxs ::- StoreRead m+ StoreReadExtra m => [XPubBal] -> Limits -> m [TxRef]@@ -241,13 +269,15 @@ return $ applyLimits limits ts' getTransaction ::- (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)+ (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) getTransaction h = runMaybeT $ do d <- MaybeT $ getTxData h sm <- lift $ getSpenders h return $ toTransaction d sm -blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)+blockAtOrBefore :: (Monad m, StoreReadExtra m)+ => UnixTime+ -> m (Maybe BlockData) blockAtOrBefore q = runMaybeT $ do a <- g 0 b <- MaybeT getBestBlock >>= MaybeT . getBlock
src/Haskoin/Store/Database/Reader.hs view
@@ -13,8 +13,6 @@ import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) import Data.Function (on)-import Data.IntMap (IntMap)-import qualified Data.IntMap.Strict as I import Data.List (sortBy) import Data.Maybe (fromMaybe) import Data.Word (Word32)@@ -26,13 +24,11 @@ matchingSkip, retrieve) import Haskoin (Address, BlockHash, BlockHeight, Network, OutPoint (..), TxHash)-import Haskoin.Store.Common (Limits (..), Start (..),- StoreRead (..), applyLimits,- applyLimitsC, deOffset, nub')+import Haskoin.Store.Common import Haskoin.Store.Data (Balance, BlockData,- BlockRef (..), TxRef (..),- Spender, TxData (..),- Unspent (..), zeroBalance)+ BlockRef (..), Spender,+ TxData (..), TxRef (..),+ Unspent (..)) import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..), BalKey (..), BestKey (..), BlockKey (..), HeightKey (..),@@ -130,19 +126,11 @@ getSpenderDB op DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = retrieve db opts $ SpenderKey op -getSpendersDB :: MonadIO m => TxHash -> DatabaseReader -> m (IntMap Spender)-getSpendersDB th DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- I.fromList . map (uncurry f) <$>- liftIO (matchingAsList db opts (SpenderKeyS th))- where- f (SpenderKey op) s = (fromIntegral (outPointIndex op), s)- f _ _ = undefined--getBalanceDB :: MonadIO m => Address -> DatabaseReader -> m Balance+getBalanceDB :: MonadIO m => Address -> DatabaseReader -> m (Maybe Balance) getBalanceDB a DatabaseReader { databaseReadOptions = opts , databaseHandle = db } =- maybe (zeroBalance a) (valToBalance a) <$> retrieve db opts (BalKey a)+ fmap (valToBalance a) <$> retrieve db opts (BalKey a) getMempoolDB :: MonadIO m => DatabaseReader -> m [TxRef] getMempoolDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =@@ -188,7 +176,7 @@ (AddrTxKeyA a) (AddrTxKeyB a (BlockRef bh maxBound)) f AddrTxKey {addrTxKeyT = t} () = t- f _ _ = undefined+ f _ _ = undefined getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent) getUnspentDB p DatabaseReader { databaseReadOptions = opts@@ -221,32 +209,32 @@ liftIO . runResourceT . runConduit $ x .| applyLimitsC limits .| mapC (uncurry toUnspent) .| sinkList where- x =- case start limits of- Nothing -> matching db opts (AddrOutKeyA a)- Just (AtBlock h) ->- matchingSkip- db- opts- (AddrOutKeyA a)- (AddrOutKeyB a (BlockRef h maxBound))- Just (AtTx txh) ->- getTxDataDB txh bdb >>= \case- Just TxData {txDataBlock = b@BlockRef {}} ->- matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a b)- _ -> matching db opts (AddrOutKeyA a)+ x = case start limits of+ Nothing -> matching db opts (AddrOutKeyA a)+ Just (AtBlock h) ->+ matchingSkip+ db+ opts+ (AddrOutKeyA a)+ (AddrOutKeyB a (BlockRef h maxBound))+ Just (AtTx txh) ->+ getTxDataDB txh bdb >>= \case+ Just TxData {txDataBlock = b@BlockRef {}} ->+ matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a b)+ _ -> matching db opts (AddrOutKeyA a) -instance MonadIO m => StoreRead (DatabaseReaderT m) where+instance MonadIO m => StoreReadBase (DatabaseReaderT m) where getNetwork = asks databaseNetwork- getBestBlock = ask >>= getBestDatabaseReader- getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h- getBlock b = ask >>= getDatabaseReader b getTxData t = ask >>= getTxDataDB t getSpender p = ask >>= getSpenderDB p- getSpenders t = ask >>= getSpendersDB t getUnspent a = ask >>= getUnspentDB a getBalance a = ask >>= getBalanceDB a getMempool = ask >>= getMempoolDB+ getBestBlock = ask >>= getBestDatabaseReader+ getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h+ getBlock b = ask >>= getDatabaseReader b++instance MonadIO m => StoreReadExtra (DatabaseReaderT m) where getAddressesTxs as limits = ask >>= getAddressesTxsDB as limits getAddressesUnspents as limits = ask >>= getAddressesUnspentsDB as limits getAddressUnspents a limits = ask >>= getAddressUnspentsDB a limits
src/Haskoin/Store/Database/Writer.hs view
@@ -20,31 +20,20 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as I-import Data.Maybe (fromJust, isJust, maybeToList)+import Data.Maybe (maybeToList) import Database.RocksDB (BatchOp) import Database.RocksDB.Query (deleteOp, insertOp, writeBatch) import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), TxHash,+ Network, OutPoint (..), TxHash, headerHash, txHash)-import Haskoin.Store.Common (StoreRead (..), StoreWrite (..))+import Haskoin.Store.Common import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), Spender, TxData (..), TxRef (..), Unspent (..))-import Haskoin.Store.Database.Reader (DatabaseReader (..),- withDatabaseReader)-import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..),- BalKey (..), BalVal (..),- BestKey (..), BlockKey (..),- HeightKey (..), MemKey (..),- OutVal (..), SpenderKey (..),- TxKey (..), UnspentKey (..),- UnspentVal (..), balanceToVal,- unspentToVal, valToBalance,- valToUnspent)+import Haskoin.Store.Database.Reader+import Haskoin.Store.Database.Types import UnliftIO (MonadIO, STM, TVar, atomically, modifyTVar, newTVarIO, readTVar, readTVarIO)@@ -62,11 +51,9 @@ type MemoryTx = ReaderT (TVar Memory) STM type WriterT = ReaderT Writer -instance MonadIO m => StoreRead (WriterT m) where- getInitialGap =- R.asks $ databaseInitialGap . getReader+instance MonadIO m => StoreReadBase (WriterT m) where getNetwork =- R.asks $ databaseNetwork . getReader+ R.ask >>= getNetworkI getBestBlock = R.ask >>= getBestBlockI getBlocksAtHeight h =@@ -77,23 +64,17 @@ R.ask >>= getTxDataI t getSpender p = R.ask >>= getSpenderI p- getSpenders t =- R.ask >>= getSpendersI t getUnspent a = R.ask >>= getUnspentI a getBalance a = R.ask >>= getBalanceI a getMempool = R.ask >>= getMempoolI- getAddressesTxs =- undefined- getAddressesUnspents =- undefined- getMaxGap =- R.asks $ databaseMaxGap . getReader data Memory = Memory- { hBest+ { hNet+ :: !Network+ , hBest :: !(Maybe BlockHash) , hBlock :: !(HashMap BlockHash BlockData)@@ -102,20 +83,15 @@ , hTx :: !(HashMap TxHash TxData) , hSpender- :: !(HashMap TxHash- (IntMap (Dirty Spender)))+ :: !(HashMap OutPoint (Dirty Spender)) , hUnspent- :: !(HashMap TxHash- (IntMap (Dirty UnspentVal)))+ :: !(HashMap OutPoint (Dirty UnspentVal)) , hBalance :: !(HashMap Address BalVal) , hAddrTx- :: !(HashMap Address- (HashMap TxRef (Dirty ())))+ :: !(HashMap (Address, TxRef) (Dirty ())) , hAddrOut- :: !(HashMap Address- (HashMap BlockRef- (HashMap OutPoint (Dirty OutVal))))+ :: !(HashMap (Address, BlockRef, OutPoint) (Dirty OutVal)) , hMempool :: !(Maybe [TxRef]) } deriving (Eq, Show)@@ -164,19 +140,25 @@ ReaderT $ \v -> modifyTVar v $ deleteUnspentH p -instance StoreRead MemoryTx where- getInitialGap =- error "Cannot query initial gap in STM"+instance StoreReadBase MemoryTx where getNetwork =- error "Cannot query network in STM"+ ReaderT $ fmap hNet . readTVar getBestBlock =- error "Cannot query best block in STM"- getBlocksAtHeight _ =- error "Cannot query block heights in STM"- getBlock _ =- error "Cannot query block in STM"+ ReaderT $ \v -> getBestH <$> readTVar v >>= \case+ Nothing -> error "Best block not set in STM"+ Just b -> return (Just b)+ getBlocksAtHeight h =+ ReaderT $ \v -> getBlocksAtHeightH h <$> readTVar v >>= \case+ Nothing -> error "Blocks at height not set in STM"+ Just hs -> return hs+ getBlock h =+ ReaderT $ \v -> getBlockH h <$> readTVar v >>= \case+ Nothing -> error "Block not set in STM"+ Just b -> return (Just b) getTxData t =- ReaderT $ fmap (getTxDataH t) . readTVar+ ReaderT $ \v -> getTxDataH t <$> readTVar v >>= \case+ Nothing -> error "Tx data not set in STM"+ Just d -> return (Just d) getSpender op = ReaderT $ \v -> do m <- getSpenderH op <$> readTVar v@@ -184,8 +166,6 @@ Just (Modified s) -> return (Just s) Just Deleted -> return Nothing Nothing -> return Nothing- getSpenders _ =- error "Cannot query spenders in STM" getUnspent op = ReaderT $ \v -> do m <- getUnspentH op <$> readTVar v@@ -194,28 +174,21 @@ Just Deleted -> return Nothing Nothing -> return Nothing getBalance a =- ReaderT $ \v -> do- m <- getBalanceH a <$> readTVar v- case m of- Just b -> return $ valToBalance a b- Nothing -> error "Balance not pre-loaded"+ ReaderT $ \v -> getBalanceH a <$> readTVar v >>= \case+ Just b -> return $ Just (valToBalance a b)+ Nothing -> error "Balance not set in STM" getMempool =- ReaderT $ \v -> do- m <- getMempoolH <$> readTVar v- case m of+ ReaderT $ \v -> getMempoolH <$> readTVar v >>= \case Just mp -> return mp- Nothing -> error "Mempool not pre-loaded"- getAddressesTxs = undefined- getAddressesUnspents = undefined- getMaxGap = error "Cannot query max gap in STM"+ Nothing -> error "Mempool not set in STM" runWriter :: MonadIO m => DatabaseReader -> WriterT m a -> m a-runWriter bdb@DatabaseReader{databaseHandle = db} f = do- hm <- newTVarIO emptyMemory+runWriter bdb@DatabaseReader{databaseHandle = db, databaseNetwork = net} f = do+ hm <- newTVarIO (emptyMemory net) x <- R.runReaderT f Writer {getReader = bdb, getState = hm} ops <- hashMapOps <$> readTVarIO hm writeBatch db ops@@ -253,45 +226,37 @@ where f = insertOp . TxKey -spenderOps :: HashMap TxHash (IntMap (Dirty Spender))+spenderOps :: HashMap OutPoint (Dirty Spender) -> [BatchOp]-spenderOps = concatMap (uncurry f) . M.toList+spenderOps = map (uncurry f) . M.toList where- f h = map (uncurry (g h)) . I.toList- g h i (Modified s) =- insertOp (SpenderKey (OutPoint h (fromIntegral i))) s- g h i Deleted =- deleteOp (SpenderKey (OutPoint h (fromIntegral i)))+ f o (Modified s) =+ insertOp (SpenderKey o) s+ f o Deleted =+ deleteOp (SpenderKey o) balOps :: HashMap Address BalVal -> [BatchOp] balOps = map (uncurry f) . M.toList where f = insertOp . BalKey -addrTxOps :: HashMap Address (HashMap TxRef (Dirty ()))- -> [BatchOp]-addrTxOps = concatMap (uncurry f) . M.toList+addrTxOps :: HashMap (Address, TxRef) (Dirty ()) -> [BatchOp]+addrTxOps = map (uncurry f) . M.toList where- f a = map (uncurry (g a)) . M.toList- g a t (Modified ()) = insertOp (AddrTxKey a t) ()- g a t Deleted = deleteOp (AddrTxKey a t)+ f (a, t) (Modified ()) = insertOp (AddrTxKey a t) ()+ f (a, t) Deleted = deleteOp (AddrTxKey a t) addrOutOps- :: HashMap Address- (HashMap BlockRef- (HashMap OutPoint (Dirty OutVal)))- -> [BatchOp]-addrOutOps = concat . concatMap (uncurry f) . M.toList+ :: HashMap (Address, BlockRef, OutPoint) (Dirty OutVal) -> [BatchOp]+addrOutOps = map (uncurry f) . M.toList where- f a = map (uncurry (g a)) . M.toList- g a b = map (uncurry (h a b)) . M.toList- h a b p (Modified l) =+ f (a, b, p) (Modified l) = insertOp (AddrOutKey { addrOutKeyA = a , addrOutKeyB = b , addrOutKeyP = p }) l- h a b p Deleted =+ f (a, b, p) Deleted = deleteOp AddrOutKey { addrOutKeyA = a , addrOutKeyB = b , addrOutKeyP = p }@@ -302,16 +267,19 @@ map (\TxRef { txRefBlock = MemRef t , txRefHash = h } -> (t, h)) -unspentOps :: HashMap TxHash (IntMap (Dirty UnspentVal))+unspentOps :: HashMap OutPoint (Dirty UnspentVal) -> [BatchOp]-unspentOps = concatMap (uncurry f) . M.toList+unspentOps = map (uncurry f) . M.toList where- f h = map (uncurry (g h)) . I.toList- g h i (Modified u) =- insertOp (UnspentKey (OutPoint h (fromIntegral i))) u- g h i Deleted =- deleteOp (UnspentKey (OutPoint h (fromIntegral i)))+ f p (Modified u) =+ insertOp (UnspentKey p) u+ f p Deleted =+ deleteOp (UnspentKey p) +getNetworkI :: MonadIO m => Writer -> m Network+getNetworkI Writer {getState = hm} =+ hNet <$> readTVarIO hm+ getBestBlockI :: MonadIO m => Writer -> m (Maybe BlockHash) getBestBlockI Writer {getState = hm, getReader = db} = runMaybeT $ MaybeT f <|> MaybeT g@@ -325,8 +293,8 @@ -> m [BlockHash] getBlocksAtHeightI bh Writer {getState = hm, getReader = db} = getBlocksAtHeightH bh <$> readTVarIO hm >>= \case- Just bs -> return bs- Nothing -> withDatabaseReader db $ getBlocksAtHeight bh+ Just bs -> return bs+ Nothing -> withDatabaseReader db $ getBlocksAtHeight bh getBlockI :: MonadIO m => BlockHash@@ -355,19 +323,10 @@ Just Deleted -> return Nothing Nothing -> withDatabaseReader db (getSpender op) -getSpendersI :: MonadIO m => TxHash -> Writer -> m (IntMap Spender)-getSpendersI t Writer {getReader = db, getState = hm} = do- hsm <- fmap to_maybe . getSpendersH t <$> readTVarIO hm- dsm <- fmap Just <$> withDatabaseReader db (getSpenders t)- return $ I.map fromJust $ I.filter isJust $ hsm <> dsm- where- to_maybe Deleted = Nothing- to_maybe (Modified x) = Just x--getBalanceI :: MonadIO m => Address -> Writer -> m Balance+getBalanceI :: MonadIO m => Address -> Writer -> m (Maybe Balance) getBalanceI a Writer {getReader = db, getState = hm} = getBalanceH a <$> readTVarIO hm >>= \case- Just b -> return $ valToBalance a b+ Just b -> return $ Just (valToBalance a b) Nothing -> withDatabaseReader db $ getBalance a getUnspentI :: MonadIO m@@ -376,8 +335,8 @@ -> m (Maybe Unspent) getUnspentI op Writer {getReader = db, getState = hm} = getUnspentH op <$> readTVarIO hm >>= \case- Just Deleted -> return Nothing Just (Modified u) -> return (Just (valToUnspent op u))+ Just Deleted -> return Nothing Nothing -> withDatabaseReader db (getUnspent op) getMempoolI :: MonadIO m => Writer -> m [TxRef]@@ -389,17 +348,20 @@ runTx :: MonadIO m => MemoryTx a -> WriterT m a runTx f = ReaderT $ atomically . runReaderT f . getState -emptyMemory :: Memory-emptyMemory = Memory { 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 = Nothing }+emptyMemory :: Network -> Memory+emptyMemory net =+ Memory { hNet = net+ , 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 = Nothing+ } getBestBlockH :: Memory -> Maybe BlockHash getBestBlockH = hBest@@ -414,12 +376,7 @@ getTxDataH t = M.lookup t . hTx getSpenderH :: OutPoint -> Memory -> Maybe (Dirty Spender)-getSpenderH op db = do- m <- M.lookup (outPointHash op) (hSpender db)- I.lookup (fromIntegral (outPointIndex op)) m--getSpendersH :: TxHash -> Memory -> IntMap (Dirty Spender)-getSpendersH t = M.lookupDefault I.empty t . hSpender+getSpenderH op db = M.lookup op (hSpender db) getBalanceH :: Address -> Memory -> Maybe BalVal getBalanceH a = M.lookup a . hBalance@@ -427,6 +384,9 @@ getMempoolH :: Memory -> Maybe [TxRef] getMempoolH = hMempool +getBestH :: Memory -> Maybe BlockHash+getBestH = hBest+ setBestH :: BlockHash -> Memory -> Memory setBestH h db = db {hBest = Just h} @@ -447,29 +407,11 @@ insertSpenderH :: OutPoint -> Spender -> Memory -> Memory insertSpenderH op s db =- db- { hSpender =- M.insertWith- (<>)- (outPointHash op)- (I.singleton- (fromIntegral (outPointIndex op))- (Modified s))- (hSpender db)- }+ db { hSpender = M.insert op (Modified s) (hSpender db) } deleteSpenderH :: OutPoint -> Memory -> Memory deleteSpenderH op db =- db- { hSpender =- M.insertWith- (<>)- (outPointHash op)- (I.singleton- (fromIntegral (outPointIndex op))- Deleted)- (hSpender db)- }+ db { hSpender = M.insert op Deleted (hSpender db) } setBalanceH :: Balance -> Memory -> Memory setBalanceH bal db =@@ -478,83 +420,36 @@ b = balanceToVal bal insertAddrTxH :: Address -> TxRef -> Memory -> Memory-insertAddrTxH a btx db =- db- { hAddrTx =- M.insertWith- (<>)- a- (M.singleton btx (Modified ()))- (hAddrTx db)- }+insertAddrTxH a tr db =+ db { hAddrTx = M.insert (a, tr) (Modified ()) (hAddrTx db) } deleteAddrTxH :: Address -> TxRef -> Memory -> Memory-deleteAddrTxH a btx db =- db- { hAddrTx =- M.insertWith- (<>)- a- (M.singleton btx Deleted)- (hAddrTx db)- }+deleteAddrTxH a tr db =+ db { hAddrTx = M.insert (a, tr) Deleted (hAddrTx db) } insertAddrUnspentH :: Address -> Unspent -> Memory -> Memory insertAddrUnspentH a u db =- let uns = OutVal { outValAmount = unspentAmount u- , outValScript = B.Short.fromShort (unspentScript u) }- s = M.singleton- a- (M.singleton- (unspentBlock u)- (M.singleton (unspentPoint u) (Modified uns)))- in db { hAddrOut =- M.unionWith- (M.unionWith M.union)- s- (hAddrOut db)- }+ let k = (a, unspentBlock u, unspentPoint u)+ v = OutVal { outValAmount = unspentAmount u+ , outValScript = B.Short.fromShort (unspentScript u) }+ in db { hAddrOut = M.insert k (Modified v) (hAddrOut db) } deleteAddrUnspentH :: Address -> Unspent -> Memory -> Memory deleteAddrUnspentH a u db =- let s =- M.singleton- a- (M.singleton- (unspentBlock u)- (M.singleton (unspentPoint u) Deleted))- in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)}+ let k = (a, unspentBlock u, unspentPoint u)+ in db { hAddrOut = M.insert k Deleted (hAddrOut db) } setMempoolH :: [TxRef] -> Memory -> Memory-setMempoolH xs db = db {hMempool = Just xs}+setMempoolH xs db = db { hMempool = Just xs } getUnspentH :: OutPoint -> Memory -> Maybe (Dirty UnspentVal)-getUnspentH op db = do- m <- M.lookup (outPointHash op) (hUnspent db)- I.lookup (fromIntegral (outPointIndex op)) m+getUnspentH op db = M.lookup op (hUnspent db) insertUnspentH :: Unspent -> Memory -> Memory insertUnspentH u db =- db- { hUnspent =- M.insertWith- (<>)- (outPointHash (unspentPoint u))- (I.singleton- (fromIntegral (outPointIndex (unspentPoint u)))- (Modified (snd (unspentToVal u))))- (hUnspent db)- }+ let (k, v) = unspentToVal u+ in db { hUnspent = M.insert k (Modified v) (hUnspent db) } deleteUnspentH :: OutPoint -> Memory -> Memory deleteUnspentH op db =- db- { hUnspent =- M.insertWith- (<>)- (outPointHash op)- (I.singleton- (fromIntegral (outPointIndex op))- Deleted)- (hUnspent db)- }+ db { hUnspent = M.insert op Deleted (hUnspent db) }
src/Haskoin/Store/Logic.hs view
@@ -16,8 +16,8 @@ , deleteUnconfirmedTx ) where -import Control.Monad (forM_, guard, void, when,- zipWithM_, (<=<), (>=>))+import Control.Monad (forM_, guard, unless, void,+ when, zipWithM_, (<=<)) import Control.Monad.Except (ExceptT (..), MonadError, runExceptT, throwError) import Control.Monad.Logger (LoggingT (..),@@ -28,12 +28,16 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Short as B.Short import Data.Either (rights)+import qualified Data.HashSet as S import qualified Data.IntMap.Strict as I import Data.List (nub, sortOn) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Ord (Down (Down)) import Data.Serialize (encode)+import Data.String (IsString (..))+import Data.String.Conversions (ConvertibleStrings, cs)+import Data.Text (Text) import Data.Word (Word32, Word64) import Haskoin (Address, Block (..), BlockHash, BlockHeader (..),@@ -46,8 +50,7 @@ isGenesis, nullOutPoint, scriptToAddressBS, txHash, txHashToHex)-import Haskoin.Store.Common (StoreRead (..), StoreWrite (..),- getActiveTxData, nub', sortTxs)+import Haskoin.Store.Common import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), Prev (..), Spender (..), TxData (..),@@ -108,7 +111,7 @@ $(logDebugS) "BlockStore" "Importing Genesis block" importBlock (genesisBlock net) (genesisNode net) -getOldMempool :: StoreRead m => UnixTime -> m [TxHash]+getOldMempool :: StoreReadBase m => UnixTime -> m [TxHash] getOldMempool now = map txRefHash . filter f <$> getMempool where@@ -119,7 +122,7 @@ getActiveTxData (txHash tx) >>= \case Just _ -> return False Nothing -> do- freeOutputs True True tx+ freeOutputs True True [tx] preLoadMemory [tx] rbf <- isRBF (MemRef w) tx checkNewTx tx@@ -134,7 +137,7 @@ liftIO (runLoggingT (runReaderT go r) l) where go = do- prev_asyncs <- mapM (async . loadPrevOutputs) txs+ prev_asyncs <- mapM (async . mapM_ loadPrevOut . prevOuts) txs out_asyncs <- mapM (async . loadOutputBalances) txs mapM_ wait $ prev_asyncs <> out_asyncs runTx . setMempool =<< getMempool@@ -189,7 +192,7 @@ importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> WriterT m () importOrConfirm bn txs = do- mapM_ (freeOutputs True False) txs+ freeOutputs True False txs preLoadMemory txs mapM_ (uncurry action) (sortTxs txs) where@@ -278,7 +281,7 @@ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx) throwError UnexpectedCoinbase- when (orphanTest us tx) $ do+ when (length (prevOuts tx) > length us) $ do $(logErrorS) "BlockStore" $ "Orphan: " <> txHashToHex (txHash tx) throwError Orphan@@ -291,57 +294,43 @@ outputs = sum (map outValue (txOut tx)) unique_inputs = length (nub' (map prevOutput (txIn tx))) -orphanTest :: [Unspent] -> Tx -> Bool-orphanTest us tx = length (prevOuts tx) > length us--getUnspentOutputs :: StoreRead m => Tx -> m [Unspent]+getUnspentOutputs :: StoreReadBase m => Tx -> m [Unspent] getUnspentOutputs tx = catMaybes <$> mapM getUnspent (prevOuts tx) -loadPrevOutputs :: MonadLoggerIO m => Tx -> WriterT m ()-loadPrevOutputs tx =- mapM_ go ops+loadUnspentOutput :: MonadLoggerIO m => Unspent -> WriterT m ()+loadUnspentOutput u = do+ mbal <- mapM getDefaultBalance (unspentAddress u)+ runTx $ do+ insertUnspent u+ mapM_ setBalance mbal++loadTxData :: MonadLoggerIO m => TxData -> WriterT m ()+loadTxData td = do+ runTx (insertTx td)+ bals <- mapM getDefaultBalance addrs+ ss <- getSpenders (txHash (txData td))+ runTx $ do+ mapM_ setBalance bals+ forM_ (I.toList ss) $ \(i, s) -> do+ let op = OutPoint (txHash (txData td)) (fromIntegral i)+ insertSpender op s where- ops = prevOuts tx- go op =- getUnspent op >>= \case- Just u ->- insert_unspent u- Nothing -> do- insert_tx (outPointHash op)- insert_spender op- insert_tx h =- getActiveTxData h >>= \case- Nothing -> return ()- Just t -> do- let addrs = get_addrs (txData t)- bals <- mapM getBalance addrs- $(logDebugS) "BlockStore" $- "Preloading tx: " <> txHashToHex h- runTx $ do- insertTx t- mapM_ setBalance bals- get_addrs tx' =- let f i o =- if OutPoint (txHash tx') i `elem` ops- then eitherToMaybe . scriptToAddressBS $ scriptOutput o- else Nothing- in catMaybes $ zipWith f [0..] (txOut tx')- insert_spender op =- getSpender op >>= \case- Nothing -> return ()- Just x ->- runTx $ insertSpender op x- insert_unspent u = do- mbal <- mapM getBalance (unspentAddress u)- runTx $ do- insertUnspent u- mapM_ setBalance mbal+ addrs =+ let f = eitherToMaybe . scriptToAddressBS . scriptOutput+ in mapMaybe f (txOut (txData td)) +loadPrevOut :: MonadLoggerIO m => OutPoint -> WriterT m ()+loadPrevOut op = getUnspent op >>= \case+ Just u -> loadUnspentOutput u+ Nothing -> getActiveTxData (outPointHash op) >>= \case+ Just td -> loadTxData td+ Nothing -> return ()+ loadOutputBalances :: MonadIO m => Tx -> WriterT m () loadOutputBalances tx = do let f = eitherToMaybe . scriptToAddressBS . scriptOutput let addrs = mapMaybe f (txOut tx)- forM_ addrs $ runTx . setBalance <=< getBalance+ forM_ addrs $ runTx . setBalance <=< getDefaultBalance prepareTxData :: Bool -> BlockRef -> Word64 -> [Unspent] -> Tx -> TxData prepareTxData rbf br tt us tx =@@ -374,22 +363,18 @@ replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do deleteAddrTx a- TxRef- { txRefBlock = txDataBlock t- , txRefHash = txHash (txData t)- }+ TxRef { txRefBlock = txDataBlock t+ , txRefHash = txHash (txData t) } insertAddrTx a- TxRef- { txRefBlock = new- , txRefHash = txHash (txData t)- }+ TxRef { txRefBlock = new+ , txRefHash = txHash (txData t) } adjustAddressOutput :: OutPoint -> TxOut -> BlockRef -> BlockRef -> MemoryTx () adjustAddressOutput op o old new = do let pk = scriptOutput o- s <- getSpender op- when (isNothing s) $ replace_unspent pk+ u <- getUnspent op+ when (isJust u) $ replace_unspent pk where replace_unspent pk = do let ma = eitherToMaybe (scriptToAddressBS pk)@@ -407,21 +392,21 @@ deleteAddrUnspent a Unspent- { unspentBlock = old- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort pk- , unspentAddress = Just a- }+ { unspentBlock = old+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort pk+ , unspentAddress = Just a+ } insertAddrUnspent a Unspent- { unspentBlock = new- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort pk- , unspentAddress = Just a- }+ { unspentBlock = new+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort pk+ , unspentAddress = Just a+ } decreaseBalance (confirmed old) a (outValue o) increaseBalance (confirmed new) a (outValue o) @@ -442,14 +427,26 @@ :: MonadImport m => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF- -> Tx+ -> [Tx] -> WriterT m ()-freeOutputs memonly rbfcheck tx =- forM_ (prevOuts tx) $ getSpender >=> \case- Nothing -> return ()- Just Spender { spenderHash = h }- | h == txHash tx -> return ()- | otherwise -> deleteTx memonly rbfcheck h+freeOutputs memonly rbfcheck txs =+ forM_ txs $ \tx ->+ forM_ (prevOuts tx) $ \op ->+ unless (outPointHash op `S.member` ths) $+ loadPrevOut op >>+ getUnspent op >>= \case+ Just _ -> return ()+ Nothing -> getSpender op >>= \case+ Just Spender { spenderHash = h }+ | h == txHash tx -> return ()+ | otherwise -> deleteTx memonly rbfcheck h+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Missing unspent output for tx: "+ <> txHashToHex (txHash tx)+ throwError Orphan+ where+ ths = S.fromList (map txHash txs) deleteConfirmedTx :: MonadImport m => TxHash -> WriterT m () deleteConfirmedTx = deleteTx False False@@ -578,7 +575,7 @@ [0 ..] (txOut (txData td)) -isRBF :: StoreRead m+isRBF :: StoreReadBase m => BlockRef -> Tx -> m Bool@@ -697,9 +694,9 @@ increaseBalance (confirmed (unspentBlock u)) a (outValue o) modifyReceived :: Address -> (Word64 -> Word64) -> MemoryTx ()-modifyReceived a f =- getBalance a >>= \b ->- setBalance b {balanceTotalReceived = f (balanceTotalReceived b)}+modifyReceived a f = do+ b <- getDefaultBalance a+ setBalance b { balanceTotalReceived = f (balanceTotalReceived b) } decreaseBalance :: Bool -> Address -> Word64 -> MemoryTx () decreaseBalance conf = modBalance conf False@@ -713,8 +710,9 @@ -> Address -> Word64 -> MemoryTx ()-modBalance conf add a val =- getBalance a >>= \b -> setBalance ((g . f) b)+modBalance conf add a val = do+ b <- getDefaultBalance a+ setBalance $ (g . f) b where g b = b { balanceUnspentCount = m 1 (balanceUnspentCount b) } f b | conf = b { balanceAmount = m val (balanceAmount b) }@@ -723,8 +721,8 @@ | otherwise = subtract modAddressCount :: Bool -> Address -> MemoryTx ()-modAddressCount add a =- getBalance a >>= \b ->+modAddressCount add a = do+ b <- getDefaultBalance a setBalance b {balanceTxCount = f (balanceTxCount b)} where f | add = (+ 1)@@ -749,12 +747,14 @@ prevOuts :: Tx -> [OutPoint] prevOuts tx = filter (/= nullOutPoint) (map prevOutput (txIn tx)) -testPresent :: StoreRead m => Tx -> m Bool-testPresent tx =- case prevOuts tx of- [] -> isJust <$> getActiveTxData (txHash tx)- op : _ -> getSpender op >>= \case- Nothing ->- return False- Just Spender { spenderHash = s } ->- return $ s == txHash tx+testPresent :: StoreReadBase m => Tx -> m Bool+testPresent tx = isJust <$> getActiveTxData (txHash tx)++logOutput :: ( ConvertibleStrings Text a+ , ConvertibleStrings String a+ , Semigroup a+ , IsString a+ )+ => OutPoint+ -> a+logOutput (OutPoint h i) = cs (txHashToHex h) <> ":" <> cs (show i)
src/Haskoin/Store/Web.hs view
@@ -54,10 +54,7 @@ getPeers, sendMessage) import Haskoin.Store.Cache (CacheT, evictFromCache, withCache)-import Haskoin.Store.Common (Limits (..), PubExcept (..),- Start (..), StoreEvent (..),- StoreRead (..), blockAtOrBefore,- getTransaction)+import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Reader (DatabaseReader (..), DatabaseReaderT,@@ -127,20 +124,22 @@ def = WebTimeouts {txTimeout = 300, blockTimeout = 7200} instance (MonadUnliftIO m, MonadLoggerIO m) =>- StoreRead (ReaderT WebConfig m) where- getMaxGap = runInWebReader getMaxGap- getInitialGap = runInWebReader getInitialGap+ StoreReadBase (ReaderT WebConfig m) where getNetwork = runInWebReader getNetwork getBestBlock = runInWebReader getBestBlock getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) getBlock bh = runInWebReader (getBlock bh) getTxData th = runInWebReader (getTxData th) getSpender op = runInWebReader (getSpender op)- getSpenders th = runInWebReader (getSpenders th) getUnspent op = runInWebReader (getUnspent op) getBalance a = runInWebReader (getBalance a)- getBalances as = runInWebReader (getBalances as) getMempool = runInWebReader getMempool++instance (MonadUnliftIO m, MonadLoggerIO m) =>+ StoreReadExtra (ReaderT WebConfig m) where+ getMaxGap = runInWebReader getMaxGap+ getInitialGap = runInWebReader getInitialGap+ getBalances as = runInWebReader (getBalances as) getAddressesTxs as = runInWebReader . getAddressesTxs as getAddressesUnspents as = runInWebReader . getAddressesUnspents as xPubBals = runInWebReader . xPubBals@@ -148,18 +147,19 @@ xPubUnspents xpub = runInWebReader . xPubUnspents xpub xPubTxs xpub = runInWebReader . xPubTxs xpub -instance (MonadUnliftIO m, MonadLoggerIO m) => StoreRead (WebT m) where+instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where getNetwork = lift getNetwork getBestBlock = lift getBestBlock getBlocksAtHeight = lift . getBlocksAtHeight getBlock = lift . getBlock getTxData = lift . getTxData getSpender = lift . getSpender- getSpenders = lift . getSpenders getUnspent = lift . getUnspent getBalance = lift . getBalance- getBalances = lift . getBalances getMempool = lift getMempool++instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where+ getBalances = lift . getBalances getAddressesTxs as = lift . getAddressesTxs as getAddressesUnspents as = lift . getAddressesUnspents as xPubBals = lift . xPubBals@@ -494,7 +494,7 @@ refuseLargeBlock b toRawBlock b -toRawBlock :: (Monad m, StoreRead m) => BlockData -> m H.Block+toRawBlock :: (Monad m, StoreReadBase m) => BlockData -> m H.Block toRawBlock b = do let ths = blockDataTxs b txs <- map transactionData . catMaybes <$> mapM getTransaction ths@@ -626,7 +626,7 @@ -- specified height. Returns'Nothing' if answer cannot be computed before -- hitting limits. cbAfterHeight ::- (MonadIO m, StoreRead m)+ (MonadIO m, StoreReadBase m) => H.BlockHeight -> TxHash -> m (Maybe Bool)@@ -671,7 +671,7 @@ -- | Publish a new transaction to the network. publishTx ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => Network -> Publisher StoreEvent -> PeerManager@@ -766,15 +766,15 @@ txs <- getAddressTxs addr =<< paramToLimits True pLimits catMaybes <$> mapM (getTransaction . txRefHash) txs -scottyAddrsTxsFull ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxsFull -> WebT m [Transaction]+scottyAddrsTxsFull :: (MonadUnliftIO m, MonadLoggerIO m)+ => GetAddrsTxsFull -> WebT m [Transaction] scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do txs <- getAddressesTxs addrs =<< paramToLimits True pLimits catMaybes <$> mapM (getTransaction . txRefHash) txs -scottyAddrBalance ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrBalance -> WebT m Balance-scottyAddrBalance (GetAddrBalance addr) = getBalance addr+scottyAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m)+ => GetAddrBalance -> WebT m Balance+scottyAddrBalance (GetAddrBalance addr) = getDefaultBalance addr scottyAddrsBalance :: (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance]@@ -878,7 +878,7 @@ return h healthCheck ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => Network -> PeerManager -> Chain