haskoin-store 0.28.0 → 0.29.0
raw patch · 11 files changed
+351/−282 lines, 11 filesdep ~haskoin-store-data
Dependency ranges changed: haskoin-store-data
Files
- haskoin-store.cabal +5/−5
- src/Haskoin/Store/BlockStore.hs +24/−24
- src/Haskoin/Store/Cache.hs +19/−19
- src/Haskoin/Store/Common.hs +11/−11
- src/Haskoin/Store/Database/Memory.hs +10/−10
- src/Haskoin/Store/Database/Reader.hs +12/−21
- src/Haskoin/Store/Database/Types.hs +6/−46
- src/Haskoin/Store/Database/Writer.hs +14/−15
- src/Haskoin/Store/Logic.hs +239/−118
- src/Haskoin/Store/Web.hs +8/−8
- test/Haskoin/StoreSpec.hs +3/−5
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 697b02b2afcb3a3cf353fa248771abc9f0fb2e0d6fb0825e3fa37bced3622695+-- hash: 32be1f4a3da179a635d98745d8b60cd57647439c7d934b319b38e5e3d370e336 name: haskoin-store-version: 0.28.0+version: 0.29.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format.@@ -57,7 +57,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.3 , haskoin-node >=0.13.0- , haskoin-store-data ==0.28.0+ , haskoin-store-data ==0.29.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32@@ -99,7 +99,7 @@ , haskoin-core >=0.13.3 , haskoin-node >=0.13.0 , haskoin-store- , haskoin-store-data ==0.28.0+ , haskoin-store-data ==0.29.0 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1@@ -149,7 +149,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.3 , haskoin-node >=0.13.0- , haskoin-store-data ==0.28.0+ , haskoin-store-data ==0.29.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store/BlockStore.hs view
@@ -30,8 +30,6 @@ import Control.Applicative ((<|>)) import Control.Monad (forM, forM_, forever, mzero, unless, void, when)-import Control.Monad.Except (ExceptT, MonadError (..),- runExceptT) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS, logWarnS) import Control.Monad.Reader (MonadReader, ReaderT (..), asks)@@ -70,13 +68,13 @@ managerPeerText) import Haskoin.Store.Common (StoreEvent (..), StoreRead (..), sortTxs)-import Haskoin.Store.Data (BlockTx (..), TxData (..),+import Haskoin.Store.Data (TxData (..), TxRef (..), UnixTime, Unspent (..)) import Haskoin.Store.Database.Reader (DatabaseReader) import Haskoin.Store.Database.Writer (DatabaseWriter, runDatabaseWriter) import Haskoin.Store.Logic (ImportException (TxOrphan),- deleteTx, getOldMempool,+ delTx, getOldMempool, importBlock, initBest, newMempoolTx, revertBlock) import Network.Socket (SockAddr)@@ -86,9 +84,10 @@ import System.Random (randomRIO) import UnliftIO (Exception, MonadIO, MonadUnliftIO, STM, TVar,- atomically, liftIO, modifyTVar,- newTVarIO, readTVar, readTVarIO,- throwIO, withAsync, writeTVar)+ atomically, catch, liftIO,+ modifyTVar, newTVarIO, readTVar,+ readTVarIO, throwIO, try,+ withAsync, writeTVar) import UnliftIO.Concurrent (threadDelay) -- | Messages for block store actor.@@ -103,9 +102,9 @@ -- ^ new block received from a peer | BlockNotFound !Peer ![BlockHash] -- ^ block not found- | BlockTxReceived !Peer !Tx+ | TxRefReceived !Peer !Tx -- ^ transaction received from peer- | BlockTxAvailable !Peer ![TxHash]+ | TxRefAvailable !Peer ![TxHash] -- ^ peer has transactions available | BlockPing !(Listen ()) -- ^ internal housekeeping ping@@ -166,11 +165,11 @@ type BlockT m = ReaderT BlockRead m runImport ::- MonadLoggerIO m- => ReaderT DatabaseWriter (ExceptT ImportException m) a+ (MonadLoggerIO m, MonadUnliftIO m)+ => ReaderT DatabaseWriter m a -> ReaderT BlockRead m (Either ImportException a) runImport f =- ReaderT $ \r -> runExceptT (runDatabaseWriter (blockConfDB (myConfig r)) f)+ ReaderT $ \r -> try (runDatabaseWriter (blockConfDB (myConfig r)) f) runRocksDB :: ReaderT DatabaseReader m a -> ReaderT BlockRead m a runRocksDB f =@@ -218,8 +217,8 @@ $(logDebugS) "BlockStore" $ "Wiping mempool tx " <> cs (show i) <> "/" <> cs (show n) <> ": " <>- txHashToHex (blockTxHash tx)- deleteTx True False (blockTxHash tx)+ txHashToHex (txRefHash tx)+ delTx (txRefHash tx) wipeit x n txs = do let (txs1, txs2) = splitAt 1000 txs case txs1 of@@ -463,7 +462,7 @@ case x of Just ls -> Right (th, ls) Nothing -> Left Nothing- catchError f (h p)+ catch f (h p) case output of Left e -> do $(logErrorS) "BlockStore" $@@ -588,10 +587,11 @@ deletetxs old = do forM_ (zip [(1 :: Int) ..] old) $ \(i, txid) -> do $(logInfoS) "BlockStore" $- "Removing " <> cs (show i) <> "/" <> cs (show (length old)) <>- " old mempool tx " <>+ "Removing old mempool tx " <> cs (show i) <> "/" <>+ cs (show (length old)) <>+ ": " <> txHashToHex txid- runImport (deleteTx True False txid) >>= \case+ runImport (delTx txid) >>= \case Left _ -> return () Right txids -> do listener <- asks (blockConfListener . myConfig)@@ -746,8 +746,8 @@ processBlockStoreMessage (BlockPeerDisconnect p _sa) = processDisconnect p processBlockStoreMessage (BlockReceived p b) = processBlock p b processBlockStoreMessage (BlockNotFound p bs) = processNoBlocks p bs-processBlockStoreMessage (BlockTxReceived p tx) = processTx p tx-processBlockStoreMessage (BlockTxAvailable p ts) = processTxs p ts+processBlockStoreMessage (TxRefReceived p tx) = processTx p tx+processBlockStoreMessage (TxRefAvailable p ts) = processTxs p ts processBlockStoreMessage (BlockPing r) = do processMempool pruneOrphans@@ -778,11 +778,11 @@ blockStoreNotFound peer blocks store = BlockNotFound peer blocks `send` store blockStoreTx :: MonadIO m => Peer -> Tx -> BlockStore -> m ()-blockStoreTx peer tx store = BlockTxReceived peer tx `send` store+blockStoreTx peer tx store = TxRefReceived peer tx `send` store blockStoreTxHash :: MonadIO m => Peer -> [TxHash] -> BlockStore -> m () blockStoreTxHash peer txhashes store =- BlockTxAvailable peer txhashes `send` store+ TxRefAvailable peer txhashes `send` store blockStorePeerConnectSTM :: Peer -> SockAddr -> BlockStore -> STM () blockStorePeerConnectSTM peer addr store = BlockPeerConnect peer addr `sendSTM` store@@ -801,11 +801,11 @@ blockStoreNotFoundSTM peer blocks store = BlockNotFound peer blocks `sendSTM` store blockStoreTxSTM :: Peer -> Tx -> BlockStore -> STM ()-blockStoreTxSTM peer tx store = BlockTxReceived peer tx `sendSTM` store+blockStoreTxSTM peer tx store = TxRefReceived peer tx `sendSTM` store blockStoreTxHashSTM :: Peer -> [TxHash] -> BlockStore -> STM () blockStoreTxHashSTM peer txhashes store =- BlockTxAvailable peer txhashes `sendSTM` store+ TxRefAvailable peer txhashes `sendSTM` store blockText :: BlockNode -> [Tx] -> Text blockText bn txs
src/Haskoin/Store/Cache.hs view
@@ -75,7 +75,7 @@ xPubBalsTxs, xPubBalsUnspents, xPubTxs) import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),+ BlockRef (..), TxRef (..), DeriveType (..), Prev (..), TxData (..), Unspent (..), XPubBal (..), XPubSpec (..),@@ -170,7 +170,7 @@ (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => XPubSpec -> Limits- -> CacheX m [BlockTx]+ -> CacheX m [TxRef] getXPubTxs xpub limits = do xpubtxt <- xpubText xpub $(logDebugS) "Cache" $ "Getting xpub txs for " <> xpubtxt@@ -285,7 +285,7 @@ (StoreRead m, MonadLoggerIO m) => XPubSpec -> Limits- -> CacheX m [BlockTx]+ -> CacheX m [TxRef] cacheGetXPubTxs xpub limits = do score <- case start limits of@@ -307,7 +307,7 @@ touchKeys [xpub] return $ map (uncurry f) xs where- f t s = BlockTx {blockTxHash = t, blockTxBlock = scoreBlockRef s}+ f t s = TxRef {txRefHash = t, txRefBlock = scoreBlockRef s} cacheGetXPubUnspents :: (StoreRead m, MonadLoggerIO m)@@ -849,9 +849,9 @@ x <- redisAddXPubTxs (addressXPubSpec i)- [ BlockTx- { blockTxHash = txHash (txData tx)- , blockTxBlock = txDataBlock tx+ [ TxRef+ { txRefHash = txHash (txData tx)+ , txRefBlock = txDataBlock tx } ] y <- uns p i@@ -877,9 +877,9 @@ b@MemRef {} -> redisAddToMempool $ (: [])- BlockTx- { blockTxHash = txHash (txData tx)- , blockTxBlock = b+ TxRef+ { txRefHash = txHash (txData tx)+ , txRefBlock = b } _ -> redisRemFromMempool [txHash (txData tx)] return $ a >> b >> return ()@@ -977,8 +977,8 @@ syncMempoolC :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m () syncMempoolC = do- nodepool <- (HashSet.fromList . map blockTxHash) <$> lift getMempool- cachepool <- (HashSet.fromList . map blockTxHash) <$> cacheGetMempool+ nodepool <- (HashSet.fromList . map txRefHash) <$> lift getMempool+ cachepool <- (HashSet.fromList . map txRefHash) <$> cacheGetMempool txs <- mapM getit . HashSet.toList $ mappend@@ -1000,7 +1000,7 @@ Nothing -> return (Left th) Just tx -> return (Right tx) -cacheGetMempool :: MonadLoggerIO m => CacheX m [BlockTx]+cacheGetMempool :: MonadLoggerIO m => CacheX m [TxRef] cacheGetMempool = runRedis redisGetMempool cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash)@@ -1038,11 +1038,11 @@ MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub] cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as) -redisAddToMempool :: (Applicative f, RedisCtx m f) => [BlockTx] -> m (f Integer)+redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer) redisAddToMempool [] = return (pure 0) redisAddToMempool btxs = zadd mempoolSetKey $- map (\btx -> (blockRefScore (blockTxBlock btx), encode (blockTxHash btx)))+ map (\btx -> (blockRefScore (txRefBlock btx), encode (txRefHash btx))) btxs redisRemFromMempool ::@@ -1099,11 +1099,11 @@ return $ addrs' + txset' + utxo' + bal' redisAddXPubTxs ::- (Applicative f, RedisCtx m f) => XPubSpec -> [BlockTx] -> m (f Integer)+ (Applicative f, RedisCtx m f) => XPubSpec -> [TxRef] -> m (f Integer) redisAddXPubTxs _ [] = return (pure 0) redisAddXPubTxs xpub btxs = zadd (txSetPfx <> encode xpub) $- map (\t -> (blockRefScore (blockTxBlock t), encode (blockTxHash t))) btxs+ map (\t -> (blockRefScore (txRefBlock t), encode (txRefHash t))) btxs redisRemXPubTxs :: (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer)@@ -1207,14 +1207,14 @@ x <- Redis.get bestBlockKey return $ (eitherToMaybe . decode =<<) <$> x -redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [BlockTx])+redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [TxRef]) redisGetMempool = do xs <- getFromSortedSet mempoolSetKey Nothing 0 0 return $ do ys <- xs return $ map (uncurry f) ys where- f t s = BlockTx {blockTxBlock = scoreBlockRef s, blockTxHash = t}+ f t s = TxRef {txRefBlock = scoreBlockRef s, txRefHash = t} xpubText :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => XPubSpec -> CacheX m Text xpubText xpub = do
src/Haskoin/Store/Common.hs view
@@ -51,7 +51,7 @@ txHash) import Haskoin.Node (Peer) import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockTx (..), DeriveType (..),+ TxRef (..), DeriveType (..), Spender, Transaction, TxData, UnixTime, Unspent (..), XPubBal (..), XPubSpec (..),@@ -99,14 +99,14 @@ getBalance a = head <$> getBalances [a] getBalances :: [Address] -> m [Balance] getBalances as = mapM getBalance as- getAddressesTxs :: [Address] -> Limits -> m [BlockTx]- getAddressTxs :: Address -> Limits -> m [BlockTx]+ 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 [BlockTx]+ getMempool :: m [TxRef] xPubBals :: XPubSpec -> m [XPubBal] xPubBals xpub = do igap <- getInitialGap@@ -176,12 +176,12 @@ XPubUnspent {xPubUnspentPath = p, xPubUnspent = t}) uns (xuns <>) <$> go xs- xPubTxs :: XPubSpec -> Limits -> m [BlockTx]+ xPubTxs :: XPubSpec -> Limits -> m [TxRef] xPubTxs xpub limits = do bs <- xPubBals xpub let as = map (balanceAddress . xPubBal) bs ts <- concat <$> mapM (\a -> getAddressTxs a (deOffset limits)) as- let ts' = sortBy (flip compare `on` blockTxBlock) (nub' ts)+ let ts' = sortBy (flip compare `on` txRefBlock) (nub' ts) return $ applyLimits limits ts' getMaxGap :: m Word32 getInitialGap :: m Word32@@ -193,11 +193,11 @@ insertTx :: TxData -> m () insertSpender :: OutPoint -> Spender -> m () deleteSpender :: OutPoint -> m ()- insertAddrTx :: Address -> BlockTx -> m ()- deleteAddrTx :: Address -> BlockTx -> m ()+ insertAddrTx :: Address -> TxRef -> m ()+ deleteAddrTx :: Address -> TxRef -> m () insertAddrUnspent :: Address -> Unspent -> m () deleteAddrUnspent :: Address -> Unspent -> m ()- setMempool :: [BlockTx] -> m ()+ setMempool :: [TxRef] -> m () setBalance :: Balance -> m () insertUnspent :: Unspent -> m () deleteUnspent :: OutPoint -> m ()@@ -233,11 +233,11 @@ StoreRead m => [XPubBal] -> Limits- -> m [BlockTx]+ -> m [TxRef] xPubBalsTxs bals limits = do let as = map balanceAddress . filter (not . nullBalance) $ map xPubBal bals ts <- concat <$> mapM (\a -> getAddressTxs a (deOffset limits)) as- let ts' = sortBy (flip compare `on` blockTxBlock) (nub' ts)+ let ts' = sortBy (flip compare `on` txRefBlock) (nub' ts) return $ applyLimits limits ts' getTransaction ::
src/Haskoin/Store/Database/Memory.hs view
@@ -25,7 +25,7 @@ headerHash, txHash) import Haskoin.Store.Common (StoreRead (..), StoreWrite (..)) import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),+ BlockRef (..), TxRef (..), Spender, TxData (..), Unspent (..), zeroBalance) import Haskoin.Store.Database.Types (BalVal, OutVal (..), UnspentVal,@@ -58,7 +58,7 @@ , hBalance :: !(HashMap Address BalVal) , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))))- , hMempool :: !(Maybe [BlockTx])+ , hMempool :: !(Maybe [TxRef]) } deriving (Eq, Show) emptyMemoryDatabase :: MemoryDatabase@@ -101,7 +101,7 @@ fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a $ hBalance mem -getMempoolH :: MemoryDatabase -> Maybe [BlockTx]+getMempoolH :: MemoryDatabase -> Maybe [TxRef] getMempoolH = hMempool setBestH :: BlockHash -> MemoryDatabase -> MemoryDatabase@@ -145,24 +145,24 @@ where b = balanceToVal bal -insertAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase+insertAddrTxH :: Address -> TxRef -> MemoryDatabase -> MemoryDatabase insertAddrTxH a btx db = let s = M.singleton a (M.singleton- (blockTxBlock btx)- (M.singleton (blockTxHash btx) True))+ (txRefBlock btx)+ (M.singleton (txRefHash btx) True)) in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)} -deleteAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase+deleteAddrTxH :: Address -> TxRef -> MemoryDatabase -> MemoryDatabase deleteAddrTxH a btx db = let s = M.singleton a (M.singleton- (blockTxBlock btx)- (M.singleton (blockTxHash btx) False))+ (txRefBlock btx)+ (M.singleton (txRefHash btx) False)) in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)} insertAddrUnspentH :: Address -> Unspent -> MemoryDatabase -> MemoryDatabase@@ -190,7 +190,7 @@ (M.singleton (unspentPoint u) Nothing)) in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)} -setMempoolH :: [BlockTx] -> MemoryDatabase -> MemoryDatabase+setMempoolH :: [TxRef] -> MemoryDatabase -> MemoryDatabase setMempoolH xs db = db {hMempool = Just xs} getUnspentH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)
src/Haskoin/Store/Database/Reader.hs view
@@ -30,17 +30,16 @@ StoreRead (..), applyLimits, applyLimitsC, deOffset, nub') import Haskoin.Store.Data (Balance, BlockData,- BlockRef (..), BlockTx (..),- Spender, TxData (..),+ BlockRef (..), Spender,+ TxData (..), TxRef (..), Unspent (..), zeroBalance) import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..), BalKey (..), BestKey (..), BlockKey (..), HeightKey (..),- MemKey (..), OldMemKey (..),- SpenderKey (..), TxKey (..),- UnspentKey (..), VersionKey (..),- toUnspent, valToBalance,- valToUnspent)+ MemKey (..), SpenderKey (..),+ TxKey (..), UnspentKey (..),+ VersionKey (..), toUnspent,+ valToBalance, valToUnspent) import UnliftIO (MonadIO, liftIO) type DatabaseReaderT = ReaderT DatabaseReader@@ -84,26 +83,18 @@ withDatabaseReader = flip runReaderT initRocksDB :: MonadIO m => DatabaseReader -> m ()-initRocksDB bdb@DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = do+initRocksDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = do e <- runExceptT $ retrieve db opts VersionKey >>= \case Just v | v == dataVersion -> return ()- | v == 15 -> migrate15to16 bdb >> initRocksDB bdb | otherwise -> throwError "Incorrect RocksDB database version" Nothing -> setInitRocksDB db case e of Left s -> error s Right () -> return () -migrate15to16 :: MonadIO m => DatabaseReader -> m ()-migrate15to16 DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = do- xs <- liftIO $ matchingAsList db opts OldMemKeyS- let ys = map (\(OldMemKey t h, ()) -> (t, h)) xs- insert db MemKey ys- insert db VersionKey (16 :: Word32)- setInitRocksDB :: MonadIO m => DB -> m () setInitRocksDB db = insert db VersionKey dataVersion @@ -145,21 +136,21 @@ fromMaybe (zeroBalance a) . fmap (valToBalance a) <$> retrieve db opts (BalKey a) -getMempoolDB :: MonadIO m => DatabaseReader -> m [BlockTx]+getMempoolDB :: MonadIO m => DatabaseReader -> m [TxRef] getMempoolDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = fmap f . fromMaybe [] <$> retrieve db opts MemKey where- f (t, h) = BlockTx {blockTxBlock = MemRef t, blockTxHash = h}+ f (t, h) = TxRef {txRefBlock = MemRef t, txRefHash = h} getAddressesTxsDB :: MonadIO m => [Address] -> Limits -> DatabaseReader- -> m [BlockTx]+ -> m [TxRef] getAddressesTxsDB addrs limits db = do ts <- concat <$> mapM (\a -> getAddressTxsDB a (deOffset limits) db) addrs- let ts' = sortBy (flip compare `on` blockTxBlock) (nub' ts)+ let ts' = sortBy (flip compare `on` txRefBlock) (nub' ts) return $ applyLimits limits ts' getAddressTxsDB ::@@ -167,7 +158,7 @@ => Address -> Limits -> DatabaseReader- -> m [BlockTx]+ -> m [TxRef] getAddressTxsDB a limits bdb@DatabaseReader { databaseReadOptions = opts , databaseHandle = db } =
src/Haskoin/Store/Database/Types.hs view
@@ -10,7 +10,6 @@ , BalKey(..) , HeightKey(..) , MemKey(..)- , OldMemKey(..) , SpenderKey(..) , TxKey(..) , UnspentKey(..)@@ -42,14 +41,13 @@ OutPoint (..), TxHash, eitherToMaybe, scriptToAddressBS) import Haskoin.Store.Data (Balance (..), BlockData, BlockRef,- BlockTx (..), Spender, TxData,- UnixTime, Unspent (..), getUnixTime,- putUnixTime)+ Spender, TxData, TxRef (..), UnixTime,+ Unspent (..)) -- | Database key for an address transaction. data AddrTxKey = AddrTxKey { addrTxKeyA :: !Address- , addrTxKeyT :: !BlockTx+ , addrTxKeyT :: !TxRef } -- ^ key for a transaction affecting an address | AddrTxKeyA { addrTxKeyA :: !Address }@@ -62,11 +60,9 @@ instance Serialize AddrTxKey -- 0x05 · Address · BlockRef · TxHash- where+ where put AddrTxKey { addrTxKeyA = a- , addrTxKeyT = BlockTx { blockTxBlock = b- , blockTxHash = t- }+ , addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t} } = do putWord8 0x05 put a@@ -91,11 +87,7 @@ return AddrTxKey { addrTxKeyA = a- , addrTxKeyT =- BlockTx- { blockTxBlock = b- , blockTxHash = t- }+ , addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t} } instance Key AddrTxKey@@ -324,38 +316,6 @@ instance Key VersionKey instance KeyValue VersionKey Word32----- | Old mempool transaction database key.-data OldMemKey- = OldMemKey- { memTime :: !UnixTime- , memKey :: !TxHash- }- | OldMemKeyT- { memTime :: !UnixTime- }- | OldMemKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize OldMemKey where- -- 0x07 · UnixTime · TxHash- put (OldMemKey t h) = do- putWord8 0x07- putUnixTime t- put h- -- 0x07 · UnixTime- put (OldMemKeyT t) = do- putWord8 0x07- putUnixTime t- -- 0x07- put OldMemKeyS = putWord8 0x07- get = do- guard . (== 0x07) =<< getWord8- OldMemKey <$> getUnixTime <*> get--instance Key OldMemKey-instance KeyValue OldMemKey () data BalVal = BalVal { balValAmount :: !Word64
src/Haskoin/Store/Database/Writer.hs view
@@ -9,7 +9,6 @@ import Control.Applicative ((<|>)) import Control.Monad (join)-import Control.Monad.Except (MonadError) import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)@@ -26,7 +25,7 @@ OutPoint (..), TxHash) import Haskoin.Store.Common (StoreRead (..), StoreWrite (..)) import Haskoin.Store.Data (Balance, BlockData,- BlockRef (..), BlockTx (..),+ BlockRef (..), TxRef (..), Spender, TxData, Unspent, nullBalance, zeroBalance) import Haskoin.Store.Database.Memory (MemoryDatabase (..),@@ -52,7 +51,7 @@ } runDatabaseWriter ::- (MonadIO m, MonadError e m)+ MonadIO m => DatabaseReader -> ReaderT DatabaseWriter m a -> m a@@ -133,9 +132,9 @@ (AddrTxKey { addrTxKeyA = a , addrTxKeyT =- BlockTx- { blockTxBlock = b- , blockTxHash = t+ TxRef+ { txRefBlock = b+ , txRefHash = t } }) ()@@ -144,9 +143,9 @@ AddrTxKey { addrTxKeyA = a , addrTxKeyT =- BlockTx- { blockTxBlock = b- , blockTxHash = t+ TxRef+ { txRefBlock = b+ , txRefHash = t } } @@ -164,10 +163,10 @@ h a b p Nothing = deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} -mempoolOp :: [BlockTx] -> BatchOp+mempoolOp :: [TxRef] -> BatchOp mempoolOp = insertOp MemKey .- map (\BlockTx {blockTxBlock = MemRef t, blockTxHash = h} -> (t, h))+ map (\TxRef {txRefBlock = MemRef t, txRefHash = h} -> (t, h)) unspentOps :: HashMap TxHash (IntMap (Maybe UnspentVal)) -> [BatchOp] unspentOps = concatMap (uncurry f) . M.toList@@ -200,11 +199,11 @@ deleteSpenderI p DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ deleteSpender p -insertAddrTxI :: MonadIO m => Address -> BlockTx -> DatabaseWriter -> m ()+insertAddrTxI :: MonadIO m => Address -> TxRef -> DatabaseWriter -> m () insertAddrTxI a t DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ insertAddrTx a t -deleteAddrTxI :: MonadIO m => Address -> BlockTx -> DatabaseWriter -> m ()+deleteAddrTxI :: MonadIO m => Address -> TxRef -> DatabaseWriter -> m () deleteAddrTxI a t DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ deleteAddrTx a t @@ -216,7 +215,7 @@ deleteAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ deleteAddrUnspent a u -setMempoolI :: MonadIO m => [BlockTx] -> DatabaseWriter -> m ()+setMempoolI :: MonadIO m => [TxRef] -> DatabaseWriter -> m () setMempoolI xs DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ setMempool xs getBestBlockI :: MonadIO m => DatabaseWriter -> m (Maybe BlockHash)@@ -304,7 +303,7 @@ getMempoolI :: MonadIO m => DatabaseWriter- -> m [BlockTx]+ -> m [TxRef] getMempoolI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} = getMempoolH <$> readTVarIO (memoryDatabase hm) >>= \case Just xs -> return xs
src/Haskoin/Store/Logic.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Haskoin.Store.Logic ( ImportException (..)@@ -10,20 +11,22 @@ , revertBlock , importBlock , newMempoolTx- , deleteTx+ , delTx ) where import Control.Monad (forM, forM_, guard, unless, void, when, zipWithM_)-import Control.Monad.Except (MonadError (..))-import Control.Monad.Logger (MonadLogger, logDebugS, logErrorS,+import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logWarnS) import qualified Data.ByteString as B import qualified Data.ByteString.Short as B.Short import Data.Either (rights)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet import qualified Data.IntMap.Strict as I-import Data.List (sort, nub)-import Data.Maybe (fromMaybe, isNothing)+import Data.List (nub, sort)+import Data.Maybe (catMaybes, fromMaybe, isNothing) import Data.Serialize (encode) import Data.String (fromString) import Data.String.Conversions (cs)@@ -42,11 +45,13 @@ import Haskoin.Store.Common (StoreRead (..), StoreWrite (..), nub', sortTxs) import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),- Prev (..), Spender (..), TxData (..),+ BlockRef (..), Prev (..),+ Spender (..), TxData (..), TxRef (..), UnixTime, Unspent (..), confirmed, nullBalance)-import UnliftIO (Exception)+import UnliftIO (Async, Exception, MonadUnliftIO, TVar,+ async, atomically, modifyTVar,+ newTVarIO, readTVarIO, throwIO, wait) data ImportException = PrevBlockNotBest !Text@@ -72,11 +77,72 @@ | DuplicatePrevOutput !Text deriving (Show, Read, Eq, Ord, Exception) +data BlockAccel =+ BlockAccel+ { utxas :: !(TVar (HashMap OutPoint (Async (Maybe Unspent))))+ , balas :: !(TVar (HashMap Address (Async Balance)))+ }++accelTxs :: (MonadUnliftIO m, StoreRead m) => [Tx] -> m BlockAccel+accelTxs txs = do+ utxas' <-+ fmap HashMap.fromList $+ forM inops $ \op -> do+ a <- async (getUnspent op)+ return (op, a)+ let f tx = map g (txOut tx)+ g to =+ case scriptToAddressBS (scriptOutput to) of+ Left _ -> Nothing+ Right a -> Just a+ oaddrs = catMaybes (concatMap f txs)+ balas' <-+ fmap HashMap.fromList $+ forM oaddrs $ \a -> do+ a' <- async (getBalance a)+ return (a, a')+ utxas <- newTVarIO utxas'+ balas <- newTVarIO balas'+ return BlockAccel {..}+ where+ newops = HashSet.fromList (map txHash txs)+ inops =+ filter+ (not . (`HashSet.member` newops) . outPointHash)+ (concatMap (map prevOutput . txIn) txs)++getAccelBalance ::+ (MonadUnliftIO m, StoreRead m) => BlockAccel -> Address -> m Balance+getAccelBalance BlockAccel {..} a = do+ balas' <- readTVarIO balas+ case HashMap.lookup a balas' of+ Nothing -> getBalance a+ Just a' -> wait a'++delAccelBalance :: (MonadUnliftIO m) => BlockAccel -> Address -> m ()+delAccelBalance BlockAccel {..} a =+ atomically $ modifyTVar balas (HashMap.delete a)++getAccelUnspent ::+ (MonadUnliftIO m, StoreRead m)+ => BlockAccel+ -> OutPoint+ -> m (Maybe Unspent)+getAccelUnspent BlockAccel {..} op = do+ utxas' <- readTVarIO utxas+ case HashMap.lookup op utxas' of+ Nothing -> getUnspent op+ Just a -> wait a++delAccelUnspent :: (MonadUnliftIO m) => BlockAccel -> OutPoint -> m ()+delAccelUnspent BlockAccel {..} op =+ atomically $ modifyTVar utxas (HashMap.delete op)+ initBest :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m ) => m () initBest = do@@ -88,11 +154,15 @@ getOldMempool :: StoreRead m => UnixTime -> m [TxHash] getOldMempool now =- map blockTxHash . filter ((< now - 3600 * 72) . memRefTime . blockTxBlock) <$>+ map txRefHash . filter ((< now - 3600 * 72) . memRefTime . txRefBlock) <$> getMempool newMempoolTx ::- (StoreRead m, StoreWrite m, MonadLogger m, MonadError ImportException m)+ ( StoreRead m+ , StoreWrite m+ , MonadLoggerIO m+ , MonadUnliftIO m+ ) => Tx -> UnixTime -> m (Maybe [TxHash])@@ -104,13 +174,15 @@ $(logDebugS) "BlockStore" $ "Transaction already in store: " <> txHashToHex (txHash tx) return Nothing- _ -> Just <$> importTx (MemRef w) w tx+ _ -> do+ accel <- accelTxs [tx]+ Just <$> importTx accel (MemRef w) w tx revertBlock :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m ) => BlockHash -> m [TxHash]@@ -119,23 +191,24 @@ getBestBlock >>= \case Nothing -> do $(logErrorS) "BlockStore" "Best block unknown"- throwError BestBlockUnknown+ throwIO BestBlockUnknown Just h -> getBlock h >>= \case Nothing -> do $(logErrorS) "BlockStore" "Best block not found"- throwError (BestBlockNotFound (blockHashToHex h))+ throwIO (BestBlockNotFound (blockHashToHex h)) Just b | h == bh -> return b | otherwise -> do $(logErrorS) "BlockStore" $ "Cannot delete block that is not head: " <> blockHashToHex h- throwError (BlockNotBest (blockHashToHex bh))+ throwIO (BlockNotBest (blockHashToHex bh)) txs <- mapM (fmap txData . getImportTxData) (blockDataTxs bd)+ accel <- accelTxs txs ths <- nub' . concat <$>- mapM (deleteTx False False . txHash . snd) (reverse (sortTxs txs))+ mapM (deleteTx accel False False . txHash . snd) (reverse (sortTxs txs)) setBest (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} return ths@@ -143,14 +216,14 @@ importBlock :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m ) => Block -> BlockNode -> m [TxHash] -- ^ deleted transactions importBlock b n = do- mp <- filter (`elem` bths) . map blockTxHash <$> getMempool+ mp <- filter (`elem` bths) . map txRefHash <$> getMempool getBestBlock >>= \case Nothing | isGenesis n -> return ()@@ -158,16 +231,17 @@ $(logErrorS) "BlockStore" $ "Cannot import non-genesis block at this point: " <> blockHashToHex (headerHash (blockHeader b))- throwError BestBlockUnknown+ throwIO BestBlockUnknown Just h | prevBlock (blockHeader b) == h -> return () | otherwise -> do $(logErrorS) "BlockStore" $ "Block does not build on head: " <> blockHashToHex (headerHash (blockHeader b))- throwError $+ throwIO $ PrevBlockNotBest (blockHashToHex (prevBlock (nodeHeader n))) net <- getNetwork+ accel <- accelTxs (blockTxns b) let subsidy = computeSubsidy net (nodeHeight n) insertBlock BlockData@@ -186,26 +260,25 @@ , blockDataOutputs = ts_out_val } bs <- getBlocksAtHeight (nodeHeight n)- setBlocksAtHeight- (nub (headerHash (nodeHeader n) : bs))- (nodeHeight n)+ setBlocksAtHeight (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n) setBest (headerHash (nodeHeader n)) ths <- nub' . concat <$>- mapM (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b))+ mapM (uncurry (import_or_confirm accel mp)) (sortTxs (blockTxns b)) return ths where bths = map txHash (blockTxns b)- import_or_confirm mp x tx =+ import_or_confirm accel mp x tx = if txHash tx `elem` mp then getTxData (txHash tx) >>= \case- Just td -> confirmTx td (br x) tx >> return []+ Just td -> confirmTx accel td (br x) tx >> return [] Nothing -> do $(logErrorS) "BlockStore" $ "Cannot get data for mempool tx: " <> txHashToHex (txHash tx)- throwError $ TxNotFound (txHashToHex (txHash tx))+ throwIO $ TxNotFound (txHashToHex (txHash tx)) else importTx+ accel (br x) (fromIntegral (blockTimestamp (nodeHeader n))) tx@@ -223,14 +296,15 @@ importTx :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => BlockRef+ => BlockAccel+ -> BlockRef -> Word64 -- ^ unix time -> Tx -> m [TxHash] -- ^ deleted transactions-importTx br tt tx = do+importTx accel br tt tx = do unless (confirmed br) $ do $(logDebugS) "BlockStore" $ "Importing transaction " <> txHashToHex (txHash tx)@@ -238,12 +312,12 @@ $(logErrorS) "BlockStore" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx)- throwError (DuplicatePrevOutput (txHashToHex (txHash tx)))+ throwIO (DuplicatePrevOutput (txHashToHex (txHash tx))) when iscb $ do $(logErrorS) "BlockStore" $ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx)- throwError (UnconfirmedCoinbase (txHashToHex (txHash tx)))+ throwIO (UnconfirmedCoinbase (txHashToHex (txHash tx))) us' <- if iscb then return []@@ -255,15 +329,15 @@ sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do $(logErrorS) "BlockStore" $ "Insufficient funds for tx: " <> txHashToHex (txHash tx)- throwError (InsufficientFunds (txHashToHex th))+ throwIO (InsufficientFunds (txHashToHex th)) rbf <- isRBF br tx commit rbf us return ths where commit rbf us = do- zipWithM_ (spendOutput br (txHash tx)) [0 ..] us+ zipWithM_ (spendOutput accel br (txHash tx)) [0 ..] us zipWithM_- (\i o -> newOutput br (OutPoint (txHash tx) i) o)+ (\i o -> newOutput accel br (OutPoint (txHash tx) i) o) [0 ..] (txOut tx) let ps =@@ -281,10 +355,10 @@ , txDataTime = tt } insertTx d- updateAddressCounts (txDataAddresses d) (+ 1)+ updateAddressCounts accel (txDataAddresses d) (+ 1) unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br) uns op =- getUnspent op >>= \case+ getAccelUnspent accel op >>= \case Just u -> return (u, []) Nothing -> do $(logWarnS) "BlockStore" $@@ -301,13 +375,13 @@ fromString (show (outPointIndex op)) $(logErrorS) "BlockStore" $ "Orphan tx: " <> txHashToHex (txHash tx)- throwError (TxOrphan (txHashToHex (txHash tx)))+ throwIO (TxOrphan (txHashToHex (txHash tx))) Just Spender {spenderHash = s} -> do $(logWarnS) "BlockStore" $ "Deleting transaction " <> txHashToHex s <> " because it conflicts with " <> txHashToHex (txHash tx)- ths <- deleteTx True (not (confirmed br)) s+ ths <- deleteTx accel True (not (confirmed br)) s getUnspent op >>= \case Nothing -> do $(logErrorS) "BlockStore" $@@ -315,7 +389,7 @@ txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))- throwError (OutputSpent (cs (show op)))+ throwIO (OutputSpent (cs (show op))) Just u -> return (u, ths) th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx))@@ -324,30 +398,32 @@ confirmTx :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => TxData+ => BlockAccel+ -> TxData -> BlockRef -> Tx -> m ()-confirmTx t br tx = do+confirmTx accel t br tx = do forM_ (txDataPrevs t) $ \p -> case scriptToAddressBS (prevScript p) of Left _ -> return () Right a -> do deleteAddrTx a- BlockTx- {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}+ TxRef+ {txRefBlock = txDataBlock t, txRefHash = txHash tx} insertAddrTx a- BlockTx {blockTxBlock = br, blockTxHash = txHash tx}+ TxRef {txRefBlock = br, txRefHash = txHash tx} forM_ (zip [0 ..] (txOut tx)) $ \(n, o) -> do let op = OutPoint (txHash tx) n s <- getSpender (OutPoint (txHash tx) n) when (isNothing s) $ do deleteUnspent op+ delAccelUnspent accel op insertUnspent Unspent { unspentBlock = br@@ -362,11 +438,11 @@ Right a -> do deleteAddrTx a- BlockTx- {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}+ TxRef+ {txRefBlock = txDataBlock t, txRefHash = txHash tx} insertAddrTx a- BlockTx {blockTxBlock = br, blockTxHash = txHash tx}+ TxRef {txRefBlock = br, txRefHash = txHash tx} when (isNothing s) $ do deleteAddrUnspent a@@ -390,38 +466,62 @@ eitherToMaybe (scriptToAddressBS (scriptOutput o)) }- reduceBalance False False a (outValue o)- increaseBalance True False a (outValue o)+ reduceBalance accel False False a (outValue o)+ increaseBalance accel True False a (outValue o) insertTx t {txDataBlock = br} deleteFromMempool (txHash tx) deleteFromMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> m () deleteFromMempool th = do mp <- getMempool- setMempool $ filter ((/= th) . blockTxHash) mp+ setMempool $ filter ((/= th) . txRefHash) mp insertIntoMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> UnixTime -> m () insertIntoMempool th unixtime = do mp <- getMempool setMempool . reverse . sort $- BlockTx {blockTxBlock = MemRef unixtime, blockTxHash = th} : mp+ TxRef {txRefBlock = MemRef unixtime, txRefHash = th} : mp +delTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLoggerIO m+ , MonadUnliftIO m+ )+ => TxHash+ -> m [TxHash] -- ^ deleted transactions+delTx th =+ getTxData th >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Cannot find tx to delete: " <> txHashToHex th+ throwIO (TxNotFound (txHashToHex th))+ Just t+ | txDataDeleted t -> do+ $(logWarnS) "BlockStore" $+ "Already deleted tx: " <> txHashToHex th+ return []+ | otherwise -> do+ accel <- accelTxs [txData t]+ deleteTx accel True False th+ deleteTx :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => Bool -- ^ only delete transaction if unconfirmed+ => BlockAccel+ -> Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ do RBF check before deleting transaction -> TxHash -> m [TxHash] -- ^ deleted transactions-deleteTx memonly rbfcheck txhash = do+deleteTx accel memonly rbfcheck txhash = do getTxData txhash >>= \case Nothing -> do $(logErrorS) "BlockStore" $ "Cannot find tx to delete: " <> txHashToHex txhash- throwError (TxNotFound (txHashToHex txhash))+ throwIO (TxNotFound (txHashToHex txhash)) Just t | txDataDeleted t -> do $(logWarnS) "BlockStore" $@@ -430,7 +530,7 @@ | memonly && confirmed (txDataBlock t) -> do $(logErrorS) "BlockStore" $ "Will not delete confirmed tx: " <> txHashToHex txhash- throwError (TxConfirmed (txHashToHex txhash))+ throwIO (TxConfirmed (txHashToHex txhash)) | rbfcheck -> isRBF (txDataBlock t) (txData t) >>= \case True -> go t@@ -438,7 +538,7 @@ $(logErrorS) "BlockStore" $ "Delete non-RBF transaction attempted: " <> txHashToHex txhash- throwError $ CannotDeleteNonRBF (txHashToHex txhash)+ throwIO $ CannotDeleteNonRBF (txHashToHex txhash) | otherwise -> go t where go t = do@@ -452,19 +552,19 @@ "Deleting descendant " <> txHashToHex s <> " to delete parent " <> txHashToHex txhash- deleteTx True rbfcheck s+ deleteTx accel True rbfcheck s forM_ (take (length (txOut (txData t))) [0 ..]) $ \n ->- delOutput (OutPoint txhash n)+ delOutput accel (OutPoint txhash n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ unspendOutput ps+ mapM_ (unspendOutput accel) ps unless (confirmed (txDataBlock t)) $ deleteFromMempool txhash insertTx t {txDataDeleted = True}- updateAddressCounts (txDataAddresses t) (subtract 1)+ updateAddressCounts accel (txDataAddresses t) (subtract 1) return $ nub' (txhash : ths) isRBF ::- (StoreRead m, MonadLogger m, MonadError ImportException m)+ (StoreRead m, MonadLoggerIO m) => BlockRef -> Tx -> m Bool@@ -487,7 +587,7 @@ Nothing -> do $(logErrorS) "BlockStore" $ "Transaction not found: " <> txHashToHex h- throwError (TxNotFound (txHashToHex h))+ throwIO (TxNotFound (txHashToHex h)) Just t | confirmed (txDataBlock t) -> ck hs' | txDataRBF t -> return True@@ -497,13 +597,16 @@ newOutput :: ( StoreRead m , StoreWrite m- , MonadLogger m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => BlockRef+ => BlockAccel+ -> BlockRef -> OutPoint -> TxOut -> m ()-newOutput br op to = do+newOutput accel br op to = do+ delAccelUnspent accel op insertUnspent u case scriptToAddressBS (scriptOutput to) of Left _ -> return ()@@ -511,8 +614,8 @@ insertAddrUnspent a u insertAddrTx a- BlockTx {blockTxHash = outPointHash op, blockTxBlock = br}- increaseBalance (confirmed br) True a (outValue to)+ TxRef {txRefHash = outPointHash op, txRefBlock = br}+ increaseBalance accel (confirmed br) True a (outValue to) where u = Unspent@@ -527,12 +630,13 @@ delOutput :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => OutPoint+ => BlockAccel+ -> OutPoint -> m ()-delOutput op = do+delOutput accel op = do t <- getImportTxData (outPointHash op) u <- case getTxOut (outPointIndex op) (txData t) of@@ -542,7 +646,8 @@ "Output out of range: " <> txHashToHex (txHash (txData t)) <> " " <> fromString (show (outPointIndex op))- throwError . OutputOutOfRange . cs $ show op+ throwIO . OutputOutOfRange . cs $ show op+ delAccelUnspent accel op deleteUnspent op case scriptToAddressBS (scriptOutput u) of Left _ -> return ()@@ -559,25 +664,25 @@ } deleteAddrTx a- BlockTx- { blockTxHash = outPointHash op- , blockTxBlock = txDataBlock t+ TxRef+ { txRefHash = outPointHash op+ , txRefBlock = txDataBlock t }- reduceBalance (confirmed (txDataBlock t)) True a (outValue u)+ reduceBalance accel (confirmed (txDataBlock t)) True a (outValue u) getImportTxData ::- (StoreRead m, MonadLogger m, MonadError ImportException m)+ (StoreRead m, MonadLoggerIO m) => TxHash -> m TxData getImportTxData th = getTxData th >>= \case Nothing -> do $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex th- throwError $ TxNotFound (txHashToHex th)+ throwIO $ TxNotFound (txHashToHex th) Just d | txDataDeleted d -> do $(logErrorS) "BlockStore" $ "Tx deleted: " <> txHashToHex th- throwError $ TxDeleted (txHashToHex th)+ throwIO $ TxDeleted (txHashToHex th) | otherwise -> return d getTxOut@@ -591,44 +696,48 @@ spendOutput :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => BlockRef+ => BlockAccel+ -> BlockRef -> TxHash -> Word32 -> Unspent -> m ()-spendOutput br th ix u = do+spendOutput accel br th ix u = do insertSpender (unspentPoint u) Spender {spenderHash = th, spenderIndex = ix} case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of Left _ -> return () Right a -> do reduceBalance+ accel (confirmed (unspentBlock u)) False a (unspentAmount u) deleteAddrUnspent a u- insertAddrTx a BlockTx {blockTxHash = th, blockTxBlock = br}+ insertAddrTx a TxRef {txRefHash = th, txRefBlock = br}+ delAccelUnspent accel (unspentPoint u) deleteUnspent (unspentPoint u) unspendOutput :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => OutPoint+ => BlockAccel+ -> OutPoint -> m ()-unspendOutput op = do+unspendOutput accel op = do t <- getImportTxData (outPointHash op) o <- case getTxOut (outPointIndex op) (txData t) of Nothing -> do $(logErrorS) "BlockStore" $ "Output out of range: " <> cs (show op)- throwError (OutputOutOfRange (cs (show op)))+ throwIO (OutputOutOfRange (cs (show op))) Just o -> return o s <- getSpender op >>= \case@@ -637,7 +746,7 @@ "Output already unspent: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))- throwError (AlreadyUnspent (cs (show op)))+ throwIO (AlreadyUnspent (cs (show op))) Just s -> return s x <- getImportTxData (spenderHash s) deleteSpender op@@ -650,6 +759,7 @@ , unspentPoint = op , unspentAddress = m }+ delAccelUnspent accel op insertUnspent u case m of Nothing -> return ()@@ -657,9 +767,10 @@ insertAddrUnspent a u deleteAddrTx a- BlockTx- {blockTxHash = spenderHash s, blockTxBlock = txDataBlock x}+ TxRef+ {txRefHash = spenderHash s, txRefBlock = txDataBlock x} increaseBalance+ accel (confirmed (unspentBlock u)) False a@@ -668,22 +779,23 @@ reduceBalance :: ( StoreRead m , StoreWrite m- , MonadLogger m- , MonadError ImportException m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => Bool -- ^ spend or delete confirmed output+ => BlockAccel+ -> Bool -- ^ spend or delete confirmed output -> Bool -- ^ reduce total received -> Address -> Word64 -> m ()-reduceBalance c t a v = do+reduceBalance accel c t a v = do net <- getNetwork- b <- getBalance a+ b <- getAccelBalance accel a if nullBalance b then do $(logErrorS) "BlockStore" $ "Address balance not found: " <> addrText net a- throwError (BalanceNotFound (addrText net a))+ throwIO (BalanceNotFound (addrText net a)) else do when (v > amnt b) $ do $(logErrorS) "BlockStore" $@@ -693,10 +805,11 @@ ", has: " <> cs (show (amnt b)) <> ")"- throwError $+ throwIO $ if c then InsufficientBalance (addrText net a) else InsufficientZeroBalance (addrText net a)+ delAccelBalance accel a setBalance b { balanceAmount =@@ -729,15 +842,18 @@ increaseBalance :: ( StoreRead m , StoreWrite m- , MonadLogger m+ , MonadLoggerIO m+ , MonadUnliftIO m )- => Bool -- ^ add confirmed output+ => BlockAccel+ -> Bool -- ^ add confirmed output -> Bool -- ^ increase total received -> Address -> Word64 -> m ()-increaseBalance c t a v = do- b <- getBalance a+increaseBalance accel c t a v = do+ b <- getAccelBalance accel a+ delAccelBalance accel a setBalance b { balanceAmount =@@ -759,18 +875,23 @@ } updateAddressCounts ::- (StoreWrite m, StoreRead m, Monad m, MonadError ImportException m)- => [Address]+ ( StoreWrite m+ , StoreRead m+ , MonadUnliftIO m+ )+ => BlockAccel+ -> [Address] -> (Word64 -> Word64) -> m ()-updateAddressCounts as f =+updateAddressCounts accel as f = forM_ as $ \a -> do b <- do net <- getNetwork- b <- getBalance a+ b <- getAccelBalance accel a if nullBalance b- then throwError (BalanceNotFound (addrText net a))+ then throwIO (BalanceNotFound (addrText net a)) else return b+ delAccelBalance accel a setBalance b {balanceTxCount = f (balanceTxCount b)} txDataAddresses :: TxData -> [Address]
src/Haskoin/Store/Web.hs view
@@ -66,7 +66,7 @@ StoreRead (..), blockAtOrBefore, getTransaction, nub') import Haskoin.Store.Data (BlockData (..), BlockRef (..),- BlockTx (..), DeriveType (..),+ TxRef (..), DeriveType (..), Event (..), Except (..), GenericResult (..), HealthCheck (..),@@ -410,7 +410,7 @@ scottyMempool = do setHeaders proto <- setupBin- txs <- map blockTxHash <$> getMempool+ txs <- map txRefHash <$> getMempool protoSerial proto txs scottyTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -573,7 +573,7 @@ then do txs' <- fmap catMaybes . lift . runNoCache nocache $- mapM (getTransaction . blockTxHash) txs+ mapM (getTransaction . txRefHash) txs protoSerialNet proto (list . transactionToEncoding) txs' else protoSerial proto txs @@ -958,7 +958,7 @@ return $ compute_delta bt tm tx_time_delta tm bd ml = do bd' <- bd- tt <- memRefTime . blockTxBlock <$> ml <|> bd+ tt <- memRefTime . txRefBlock <$> ml <|> bd return $ min (compute_delta tt tm) bd' timeout_ok to td = fromMaybe False $ do td' <- td@@ -1039,7 +1039,7 @@ (Monad m, StoreRead m) => Limits -> Address- -> m [BlockTx]+ -> m [TxRef] getAddressTxsLimit limits addr = getAddressTxs addr limits getAddressTxsFull ::@@ -1049,13 +1049,13 @@ -> m [Transaction] getAddressTxsFull limits addr = do txs <- getAddressTxsLimit limits addr- catMaybes <$> mapM (getTransaction . blockTxHash) txs+ catMaybes <$> mapM (getTransaction . txRefHash) txs getAddressesTxsLimit :: (Monad m, StoreRead m) => Limits -> [Address]- -> m [BlockTx]+ -> m [TxRef] getAddressesTxsLimit limits addrs = getAddressesTxs addrs limits getAddressesTxsFull ::@@ -1066,7 +1066,7 @@ getAddressesTxsFull limits addrs = fmap catMaybes $ getAddressesTxsLimit limits addrs >>=- mapM (getTransaction . blockTxHash)+ mapM (getTransaction . txRefHash) getAddressUnspentsLimit :: (Monad m, StoreRead m)
test/Haskoin/StoreSpec.hs view
@@ -7,7 +7,6 @@ import Conduit import Control.Monad import Control.Monad.Logger-import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Base64@@ -19,7 +18,6 @@ import Haskoin import Haskoin.Node import Haskoin.Store-import Haskoin.Store.Common import Network.Socket import NQE import System.Random@@ -117,7 +115,7 @@ fromRight (error "Could not decode blocks") $ runGet f (decodeBase64Lenient allBlocksBase64) where- f = mapM (const get) [1..15]+ f = mapM (const get) [(1 :: Int) .. 15] allBlocksBase64 :: ByteString allBlocksBase64 =@@ -193,7 +191,7 @@ forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact .| outc .| awaitForever (`send` s)- outc = mapMC $ \msg -> return $ runPut (putMessage net msg)+ outc = mapMC $ \msg' -> return $ runPut (putMessage net msg') inc = forever $ do x <- takeCE 24 .| foldC@@ -205,7 +203,7 @@ Left e -> error $ "Dummy peer could not decode payload: " <> show e- Right msg -> yield msg+ Right msg' -> yield msg' mockPeerReact :: Message -> [Message] mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]