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: 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 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 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -16,11 +16,15 @@ , isInCache , evictFromCache -- * Store Reader - , StoreRead(..) + , StoreReadBase(..) + , StoreReadExtra(..) , Limits(..) , Start(..) -- * Useful Fuctions , getTransaction + , getDefaultBalance + , getSpenders + , getActiveTxData , blockAtOrBefore -- * Other Data , PubExcept(..) diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -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 ) diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -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) diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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) } diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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) diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -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