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: 2f2f97b31d4301490cc2d4dfa702f98c3482eed7ead5b3193ca2d2f549124bb0 +-- hash: 59919146383deeb855254d8d6c939cf31929f9ff325d838ae674219063a2e363 name: haskoin-store -version: 0.35.2 +version: 0.36.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.35.2 + , haskoin-store-data ==0.36.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.35.2 + , haskoin-store-data ==0.36.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.35.2 - , haskoin-store-data ==0.35.2 + , haskoin-store ==0.36.0 + , haskoin-store-data ==0.36.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 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 @@ -194,7 +194,8 @@ deleteAddrTx :: Address -> TxRef -> m () insertAddrUnspent :: Address -> Unspent -> m () deleteAddrUnspent :: Address -> Unspent -> m () - setMempool :: [TxRef] -> m () + addToMempool :: TxHash -> UnixTime -> m () + deleteFromMempool :: TxHash -> m () setBalance :: Balance -> m () insertUnspent :: Unspent -> m () deleteUnspent :: OutPoint -> m () 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 @@ -4,12 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Haskoin.Store.Database.Writer - ( WriterT - , MemoryTx - , runWriter - , runTx - ) where +module Haskoin.Store.Database.Writer (WriterT , runWriter) where import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) @@ -20,7 +15,7 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M -import Data.Maybe (maybeToList) +import Data.List (sort) import Database.RocksDB (BatchOp) import Database.RocksDB.Query (deleteOp, insertOp, writeBatch) import GHC.Generics (Generic) @@ -28,14 +23,11 @@ Network, OutPoint (..), TxHash, headerHash, txHash) import Haskoin.Store.Common -import Haskoin.Store.Data (Balance (..), BlockData (..), - BlockRef (..), Spender, - TxData (..), TxRef (..), - Unspent (..)) +import Haskoin.Store.Data import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Types -import UnliftIO (MonadIO, STM, TVar, atomically, - modifyTVar, newTVarIO, readTVar, +import UnliftIO (MonadIO, TVar, atomically, + liftIO, modifyTVar, newTVarIO, readTVarIO) data Dirty a = Modified a | Deleted @@ -48,7 +40,6 @@ data Writer = Writer { getReader :: !DatabaseReader , getState :: !(TVar Memory) } -type MemoryTx = ReaderT (TVar Memory) STM type WriterT = ReaderT Writer instance MonadIO m => StoreReadBase (WriterT m) where @@ -93,102 +84,80 @@ , hAddrOut :: !(HashMap (Address, BlockRef, OutPoint) (Dirty OutVal)) , hMempool - :: !(Maybe [TxRef]) + :: !(HashMap TxHash UnixTime) } deriving (Eq, Show) -instance StoreWrite MemoryTx where +instance MonadIO m => StoreWrite (WriterT m) where setBest h = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ setBestH h insertBlock b = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ insertBlockH b setBlocksAtHeight h g = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ setBlocksAtHeightH h g insertTx t = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ insertTxH t - insertSpender p s = - ReaderT $ \v -> modifyTVar v $ - insertSpenderH p s + insertSpender p s' = + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ + insertSpenderH p s' deleteSpender p = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ deleteSpenderH p insertAddrTx a t = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ insertAddrTxH a t deleteAddrTx a t = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ deleteAddrTxH a t insertAddrUnspent a u = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ insertAddrUnspentH a u deleteAddrUnspent a u = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ deleteAddrUnspentH a u - setMempool xs = - ReaderT $ \v -> modifyTVar v $ - setMempoolH xs + addToMempool x t = + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ + addToMempoolH x t + deleteFromMempool x = + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ + deleteFromMempoolH x setBalance b = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ setBalanceH b insertUnspent h = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ insertUnspentH h deleteUnspent p = - ReaderT $ \v -> modifyTVar v $ + ReaderT $ \Writer { getState = s } -> + liftIO . atomically . modifyTVar s $ deleteUnspentH p -instance StoreReadBase MemoryTx where - getNetwork = - ReaderT $ fmap hNet . readTVar - getBestBlock = - 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 $ \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 - case m of - Just (Modified s) -> return (Just s) - Just Deleted -> return Nothing - Nothing -> return Nothing - getUnspent op = - ReaderT $ \v -> do - m <- getUnspentH op <$> readTVar v - case m of - Just (Modified u) -> return (Just (valToUnspent op u)) - Just Deleted -> return Nothing - Nothing -> return Nothing - getBalance a = - ReaderT $ \v -> getBalanceH a <$> readTVar v >>= \case - Just b -> return $ Just (valToBalance a b) - Nothing -> error "Balance not set in STM" - getMempool = - ReaderT $ \v -> getMempoolH <$> readTVar v >>= \case - Just mp -> return mp - Nothing -> error "Mempool not set in STM" - runWriter :: MonadIO m => DatabaseReader -> WriterT m a -> m a -runWriter bdb@DatabaseReader{databaseHandle = db, databaseNetwork = net} f = do - hm <- newTVarIO (emptyMemory net) +runWriter bdb@DatabaseReader{ databaseHandle = db + , databaseNetwork = net } f = do + (mem, best) <- runReaderT ((,) <$> getMempool <*> getBestBlock) bdb + hm <- newTVarIO (emptyMemory net best mem) x <- R.runReaderT f Writer {getReader = bdb, getState = hm} ops <- hashMapOps <$> readTVarIO hm writeBatch db ops @@ -204,11 +173,11 @@ balOps (hBalance db) <> addrTxOps (hAddrTx db) <> addrOutOps (hAddrOut db) <> - maybeToList (mempoolOp <$> hMempool db) <> + mempoolOp (hMempool db) <> unspentOps (hUnspent db) bestBlockOp :: Maybe BlockHash -> [BatchOp] -bestBlockOp Nothing = [] +bestBlockOp Nothing = [deleteOp BestKey] bestBlockOp (Just b) = [insertOp BestKey b] blockHashOps :: HashMap BlockHash BlockData -> [BatchOp] @@ -261,11 +230,8 @@ , addrOutKeyB = b , addrOutKeyP = p } -mempoolOp :: [TxRef] -> BatchOp -mempoolOp = - insertOp MemKey . - map (\TxRef { txRefBlock = MemRef t - , txRefHash = h } -> (t, h)) +mempoolOp :: HashMap TxHash UnixTime -> [BatchOp] +mempoolOp = (: []) . insertOp MemKey . map (\(h, t) -> (t, h)) . M.toList unspentOps :: HashMap OutPoint (Dirty UnspentVal) -> [BatchOp] @@ -281,11 +247,8 @@ hNet <$> readTVarIO hm getBestBlockI :: MonadIO m => Writer -> m (Maybe BlockHash) -getBestBlockI Writer {getState = hm, getReader = db} = - runMaybeT $ MaybeT f <|> MaybeT g - where - f = getBestBlockH <$> readTVarIO hm - g = runReaderT getBestBlock db +getBestBlockI Writer {getState = hm} = + getBestBlockH <$> readTVarIO hm getBlocksAtHeightI :: MonadIO m => BlockHeight @@ -340,18 +303,13 @@ Nothing -> runReaderT (getUnspent op) db getMempoolI :: MonadIO m => Writer -> m [TxRef] -getMempoolI Writer {getState = hm, getReader = db} = - getMempoolH <$> readTVarIO hm >>= \case - Just xs -> return xs - Nothing -> runReaderT getMempool db - -runTx :: MonadIO m => MemoryTx a -> WriterT m a -runTx f = ReaderT $ atomically . runReaderT f . getState +getMempoolI Writer {getState = hm} = + getMempoolH <$> readTVarIO hm -emptyMemory :: Network -> Memory -emptyMemory net = +emptyMemory :: Network -> Maybe BlockHash -> [TxRef] -> Memory +emptyMemory net best mem = Memory { hNet = net - , hBest = Nothing + , hBest = best , hBlock = M.empty , hHeight = M.empty , hTx = M.empty @@ -360,7 +318,7 @@ , hBalance = M.empty , hAddrTx = M.empty , hAddrOut = M.empty - , hMempool = Nothing + , hMempool = M.fromList $ map (\(TxRef (MemRef t) h) -> (h, t)) mem } getBestBlockH :: Memory -> Maybe BlockHash @@ -381,29 +339,27 @@ getBalanceH :: Address -> Memory -> Maybe BalVal getBalanceH a = M.lookup a . hBalance -getMempoolH :: Memory -> Maybe [TxRef] -getMempoolH = hMempool - -getBestH :: Memory -> Maybe BlockHash -getBestH = hBest +getMempoolH :: Memory -> [TxRef] +getMempoolH = sort . map (\(h, t) -> TxRef (MemRef t) h) . M.toList . hMempool setBestH :: BlockHash -> Memory -> Memory setBestH h db = db {hBest = Just h} insertBlockH :: BlockData -> Memory -> Memory insertBlockH bd db = - db { hBlock = - M.insert + db { hBlock = M.insert (headerHash (blockDataHeader bd)) bd (hBlock db) } setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> Memory -> Memory -setBlocksAtHeightH hs g db = db {hHeight = M.insert g hs (hHeight db)} +setBlocksAtHeightH hs g db = + db {hHeight = M.insert g hs (hHeight db)} insertTxH :: TxData -> Memory -> Memory -insertTxH tx db = db {hTx = M.insert (txHash (txData tx)) tx (hTx db)} +insertTxH tx db = + db {hTx = M.insert (txHash (txData tx)) tx (hTx db)} insertSpenderH :: OutPoint -> Spender -> Memory -> Memory insertSpenderH op s db = @@ -439,8 +395,13 @@ 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 } +addToMempoolH :: TxHash -> UnixTime -> Memory -> Memory +addToMempoolH h t db = + db { hMempool = M.insert h t (hMempool db) } + +deleteFromMempoolH :: TxHash -> Memory -> Memory +deleteFromMempoolH h db = + db { hMempool = M.delete h (hMempool db) } getUnspentH :: OutPoint -> Memory -> Maybe (Dirty UnspentVal) getUnspentH op db = M.lookup op (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,55 +16,43 @@ , deleteUnconfirmedTx ) where -import Control.Monad (forM_, guard, unless, void, - when, zipWithM_, (<=<)) -import Control.Monad.Except (ExceptT (..), MonadError, - runExceptT, throwError) -import Control.Monad.Logger (LoggingT (..), - MonadLoggerIO (..), logDebugS, - logErrorS) -import Control.Monad.Reader (ReaderT (ReaderT), runReaderT) -import Control.Monad.Trans (lift) -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 (delete, nub, sortOn) -import Data.Maybe (catMaybes, fromMaybe, isJust, - isNothing, mapMaybe) -import Data.Ord (Down (Down)) -import Data.Serialize (encode) -import Data.Word (Word32, Word64) -import Haskoin (Address, Block (..), BlockHash, - BlockHeader (..), - BlockNode (..), Network (..), - OutPoint (..), Tx (..), TxHash, - TxIn (..), TxOut (..), - blockHashToHex, computeSubsidy, - eitherToMaybe, genesisBlock, - genesisNode, headerHash, - isGenesis, nullOutPoint, - scriptToAddressBS, txHash, - txHashToHex) +import Control.Monad (forM_, guard, unless, void, when, + zipWithM_) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Logger (MonadLoggerIO (..), logDebugS, + logErrorS) +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) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import Data.Serialize (encode) +import Data.Word (Word32, Word64) +import Haskoin (Address, Block (..), BlockHash, + BlockHeader (..), BlockNode (..), + Network (..), OutPoint (..), Tx (..), + TxHash, TxIn (..), TxOut (..), + blockHashToHex, computeSubsidy, + eitherToMaybe, genesisBlock, + genesisNode, headerHash, isGenesis, + nullOutPoint, scriptToAddressBS, txHash, + txHashToHex) import Haskoin.Store.Common -import Haskoin.Store.Data (Balance (..), BlockData (..), - BlockRef (..), Prev (..), - Spender (..), TxData (..), - TxRef (..), UnixTime, - Unspent (..), confirmed) -import Haskoin.Store.Database.Writer (MemoryTx, WriterT, runTx) -import UnliftIO (Exception, MonadIO, - MonadUnliftIO, async, liftIO, - waitAny) +import Haskoin.Store.Data (Balance (..), BlockData (..), + BlockRef (..), Prev (..), Spender (..), + TxData (..), TxRef (..), UnixTime, + Unspent (..), confirmed) +import UnliftIO (Exception) type MonadImport m = ( MonadError ImportException m , MonadLoggerIO m + , StoreReadBase m + , StoreWrite m ) -type MonadMemory = ExceptT ImportException MemoryTx - data ImportException = PrevBlockNotBest | Orphan @@ -94,13 +82,7 @@ show TxSpent = "Transaction is spent" show OrphanLoop = "Orphan loop" -runMonadMemory :: MonadImport m => MonadMemory a -> WriterT m a -runMonadMemory f = - runTx (runExceptT f) >>= \case - Left e -> throwError e - Right x -> return x - -initBest :: MonadImport m => WriterT m () +initBest :: MonadImport m => m () initBest = do $(logDebugS) "BlockStore" "Initializing best block" net <- getNetwork @@ -115,48 +97,19 @@ where f = (< now - 3600 * 72) . memRefTime . txRefBlock -newMempoolTx :: MonadImport m => Tx -> UnixTime -> WriterT m Bool +newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool newMempoolTx tx w = getActiveTxData (txHash tx) >>= \case - Just _ -> return False + Just _ -> + return False Nothing -> do - preLoadMemory [tx] freeOutputs True True [tx] rbf <- isRBF (MemRef w) tx checkNewTx tx - runMonadMemory $ importTx (MemRef w) w rbf tx + importTx (MemRef w) w rbf tx return True -multiAsync :: MonadUnliftIO m => Int -> [m a] -> m [a] -multiAsync n = go [] - where - go [] [] = return [] - go acc xs - | length acc >= n || null xs = do - (a, x) <- waitAny acc - (x :) <$> go (delete a acc) xs - | otherwise = - case xs of - [] -> undefined - (x : xs') -> do - a <- async x - go (a : acc) xs' - -preLoadMemory :: MonadLoggerIO m => [Tx] -> WriterT m () -preLoadMemory txs = do - $(logDebugS) "BlockStore" "Pre-loading memory" - ReaderT $ \r -> do - l <- askLoggerIO - liftIO (runLoggingT (runReaderT go r) l) - where - go = do - -- _ <- multiAsync 32 $ map loadPrevOut (concatMap prevOuts txs) - -- _ <- multiAsync 32 $ map loadOutputBalances txs - mapM_ loadPrevOut (concatMap prevOuts txs) - mapM_ loadOutputBalances txs - runTx . setMempool =<< getMempool - -bestBlockData :: MonadImport m => WriterT m BlockData +bestBlockData :: MonadImport m => m BlockData bestBlockData = do h <- getBestBlock >>= \case Nothing -> do @@ -169,7 +122,7 @@ throwError BestBlockNotFound Just b -> return b -revertBlock :: MonadImport m => BlockHash -> WriterT m () +revertBlock :: MonadImport m => BlockHash -> m () revertBlock bh = do bd <- bestBlockData >>= \b -> if headerHash (blockDataHeader b) == bh @@ -179,14 +132,12 @@ "Cannot revert non-head block: " <> blockHashToHex bh throwError BlockNotBest tds <- mapM getImportTxData (blockDataTxs bd) - preLoadMemory $ map txData tds - runTx $ do - setBest (prevBlock (blockDataHeader bd)) - insertBlock bd {blockDataMainChain = False} - forM_ (tail tds) unConfirmTx + setBest (prevBlock (blockDataHeader bd)) + insertBlock bd {blockDataMainChain = False} + forM_ (tail tds) unConfirmTx deleteConfirmedTx (txHash (txData (head tds))) -checkNewBlock :: MonadImport m => Block -> BlockNode -> WriterT m () +checkNewBlock :: MonadImport m => Block -> BlockNode -> m () checkNewBlock b n = getBestBlock >>= \case Nothing @@ -204,9 +155,8 @@ <> blockHashToHex (headerHash (blockHeader b)) throwError PrevBlockNotBest -importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> WriterT m () +importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m () importOrConfirm bn txs = do - preLoadMemory txs freeOutputs True False txs mapM_ (uncurry action) (sortTxs txs) where @@ -222,7 +172,7 @@ $(logDebugS) "BlockStore" $ "Confirming tx: " <> txHashToHex (txHash tx) - runTx $ confTx t (Just (br i)) + confirmTx t (br i) return Nothing Nothing -> do $(logErrorS) "BlockStore" $ @@ -232,10 +182,10 @@ import_it i tx = do $(logDebugS) "BlockStore" $ "Importing tx: " <> txHashToHex (txHash tx) - runMonadMemory $ importTx (br i) bn_time False tx + importTx (br i) bn_time False tx return Nothing -importBlock :: MonadImport m => Block -> BlockNode -> WriterT m () +importBlock :: MonadImport m => Block -> BlockNode -> m () importBlock b n = do $(logDebugS) "BlockStore" $ "Checking new block: " @@ -248,24 +198,23 @@ $(logDebugS) "BlockStore" $ "Inserting block entries for: " <> blockHashToHex (headerHash (nodeHeader n)) - runTx $ do - insertBlock - BlockData - { blockDataHeight = nodeHeight n - , blockDataMainChain = True - , blockDataWork = nodeWork n - , blockDataHeader = nodeHeader n - , blockDataSize = fromIntegral (B.length (encode b)) - , blockDataTxs = map txHash (blockTxns b) - , blockDataWeight = if getSegWit net then w else 0 - , blockDataSubsidy = subsidy - , blockDataFees = cb_out_val - subsidy - , blockDataOutputs = ts_out_val - } - setBlocksAtHeight - (nub (headerHash (nodeHeader n) : bs)) - (nodeHeight n) - setBest (headerHash (nodeHeader n)) + insertBlock + BlockData + { blockDataHeight = nodeHeight n + , blockDataMainChain = True + , blockDataWork = nodeWork n + , blockDataHeader = nodeHeader n + , blockDataSize = fromIntegral (B.length (encode b)) + , blockDataTxs = map txHash (blockTxns b) + , blockDataWeight = if getSegWit net then w else 0 + , blockDataSubsidy = subsidy + , blockDataFees = cb_out_val - subsidy + , blockDataOutputs = ts_out_val + } + setBlocksAtHeight + (nub (headerHash (nodeHeader n) : bs)) + (nodeHeight n) + setBest (headerHash (nodeHeader n)) importOrConfirm n (blockTxns b) $(logDebugS) "BlockStore" $ "Finished importing transactions for: " @@ -282,14 +231,18 @@ s = B.length (encode b') in fromIntegral $ s * 3 + x -checkNewTx :: MonadImport m => Tx -> WriterT m () +checkNewTx :: MonadImport m => Tx -> m () checkNewTx tx = do - us <- runTx $ getUnspentOutputs tx when (unique_inputs < length (txIn tx)) $ do $(logErrorS) "BlockStore" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx) throwError DuplicatePrevOutput + us <- getUnspentOutputs tx + when (any isNothing us) $ do + $(logErrorS) "BlockStore" $ + "Orphan: " <> txHashToHex (txHash tx) + throwError Orphan when (isCoinbase tx) $ do $(logErrorS) "BlockStore" $ "Coinbase cannot be imported into mempool: " @@ -304,47 +257,12 @@ "Insufficient funds for tx: " <> txHashToHex (txHash tx) throwError InsufficientFunds where - unspents = sum . map unspentAmount + unspents = sum . map unspentAmount . catMaybes outputs = sum (map outValue (txOut tx)) unique_inputs = length (nub' (map prevOutput (txIn tx))) -getUnspentOutputs :: StoreReadBase m => Tx -> m [Unspent] -getUnspentOutputs tx = catMaybes <$> mapM getUnspent (prevOuts tx) - -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 - 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 <=< getDefaultBalance +getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent] +getUnspentOutputs tx = mapM getUnspent (prevOuts tx) prepareTxData :: Bool -> BlockRef -> Word64 -> [Unspent] -> Tx -> TxData prepareTxData rbf br tt us tx = @@ -360,20 +278,30 @@ ps = I.fromList $ zip [0 ..] $ if isCoinbase tx then [] else map mkprv us importTx - :: BlockRef + :: MonadImport m + => BlockRef -> Word64 -- ^ unix time -> Bool -- ^ RBF -> Tx - -> MonadMemory () + -> m () importTx br tt rbf tx = do - us <- lift $ getUnspentOutputs tx - let td = prepareTxData rbf br tt us tx - lift $ commitAddTx us td + us <- getUnspentOutputs tx + when (any isNothing us && not (isCoinbase tx)) $ do + $(logErrorS) "BlockStore" $ + "Attempted to import a tx missing UTXO: " + <> txHashToHex (txHash tx) + throwError Orphan + let us' = catMaybes us + td = prepareTxData rbf br tt us' tx + commitAddTx us' td -unConfirmTx :: TxData -> MemoryTx () +unConfirmTx :: MonadImport m => TxData -> m () unConfirmTx t = confTx t Nothing -replaceAddressTx :: TxData -> BlockRef -> MemoryTx () +confirmTx :: MonadImport m => TxData -> BlockRef -> m () +confirmTx t br = confTx t (Just br) + +replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m () replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do deleteAddrTx a @@ -384,7 +312,8 @@ TxRef { txRefBlock = new , txRefHash = txHash (txData t) } -adjustAddressOutput :: OutPoint -> TxOut -> BlockRef -> BlockRef -> MemoryTx () +adjustAddressOutput :: MonadImport m + => OutPoint -> TxOut -> BlockRef -> BlockRef -> m () adjustAddressOutput op o old new = do let pk = scriptOutput o u <- getUnspent op @@ -424,32 +353,32 @@ decreaseBalance (confirmed old) a (outValue o) increaseBalance (confirmed new) a (outValue o) -confTx :: TxData -> Maybe BlockRef -> MemoryTx () +confTx :: MonadImport m => TxData -> Maybe BlockRef -> m () confTx t mbr = do replaceAddressTx t new forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do let op = OutPoint (txHash (txData t)) n adjustAddressOutput op o old new - insertTx td - updateMempool td + rbf <- isRBF new (txData t) + insertTx (td rbf) + updateMempool (td rbf) where new = fromMaybe (MemRef (txDataTime t)) mbr old = txDataBlock t - td = t {txDataBlock = new} + td rbf = t { txDataBlock = new, txDataRBF = rbf} freeOutputs :: MonadImport m => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF -> [Tx] - -> WriterT m () + -> m () freeOutputs memonly rbfcheck txs = forM_ txs $ \tx -> forM_ (prevOuts tx) $ \op -> unless (outPointHash op `S.member` ths) $ - getUnspent op >>= \case - Just _ -> return () - Nothing -> getSpender op >>= \case + getUnspent op >>= \u -> when (isNothing u) $ + getSpender op >>= \case Just Spender { spenderHash = h } | h == txHash tx -> return () | otherwise -> deleteTx memonly rbfcheck h @@ -461,10 +390,10 @@ where ths = S.fromList (map txHash txs) -deleteConfirmedTx :: MonadImport m => TxHash -> WriterT m () +deleteConfirmedTx :: MonadImport m => TxHash -> m () deleteConfirmedTx = deleteTx False False -deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> WriterT m () +deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m () deleteUnconfirmedTx rbfcheck th = getActiveTxData th >>= \case Just _ -> @@ -478,7 +407,7 @@ => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF -> TxHash - -> WriterT m () + -> m () deleteTx memonly rbfcheck th = getChain memonly rbfcheck th >>= mapM_ (deleteSingleTx . txHash) @@ -488,7 +417,7 @@ => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF -> TxHash - -> WriterT m [Tx] + -> m [Tx] getChain memonly rbfcheck th = fmap sort_clean $ getActiveTxData th >>= \case @@ -520,7 +449,7 @@ xs <- concat <$> mapM (getChain memonly rbfcheck) ss return $ tx : xs -deleteSingleTx :: MonadImport m => TxHash -> WriterT m () +deleteSingleTx :: MonadImport m => TxHash -> m () deleteSingleTx th = getActiveTxData th >>= \case Nothing -> do @@ -531,22 +460,21 @@ $(logDebugS) "BlockStore" $ "Deleting tx: " <> txHashToHex th getSpenders th >>= \case - m | I.null m -> do - preLoadMemory [txData td] - runTx $ commitDelTx td + m | I.null m -> + commitDelTx td | otherwise -> do $(logErrorS) "BlockStore" $ "Tried to delete spent tx: " <> txHashToHex th throwError TxSpent -commitDelTx :: TxData -> MemoryTx () +commitDelTx :: MonadImport m => TxData -> m () commitDelTx = commitModTx False [] -commitAddTx :: [Unspent] -> TxData -> MemoryTx () +commitAddTx :: MonadImport m => [Unspent] -> TxData -> m () commitAddTx = commitModTx True -commitModTx :: Bool -> [Unspent] -> TxData -> MemoryTx () +commitModTx :: MonadImport m => Bool -> [Unspent] -> TxData -> m () commitModTx add us td = do mapM_ mod_addr_tx (txDataAddresses td) mod_outputs @@ -567,21 +495,19 @@ mod_outputs | add = addOutputs td | otherwise = delOutputs td -updateMempool :: TxData -> MemoryTx () -updateMempool td = do - mp <- getMempool - setMempool (f mp) - where - f mp | txDataDeleted td || confirmed (txDataBlock td) = - filter ((/= txHash (txData td)) . txRefHash) mp - | otherwise = - sortOn Down $ TxRef (txDataBlock td) (txHash (txData td)) : mp +updateMempool :: MonadImport m => TxData -> m () +updateMempool td@TxData{txDataDeleted = True} = + deleteFromMempool (txHash (txData td)) +updateMempool td@TxData{txDataDeleted = False, txDataBlock = MemRef t} = + addToMempool (txHash (txData td)) t +updateMempool td@TxData{txDataBlock = BlockRef{}} = + deleteFromMempool (txHash (txData td)) -spendOutputs :: [Unspent] -> TxData -> MemoryTx () +spendOutputs :: MonadImport m => [Unspent] -> TxData -> m () spendOutputs us td = zipWithM_ (spendOutput (txHash (txData td))) [0 ..] us -addOutputs :: TxData -> MemoryTx () +addOutputs :: MonadImport m => TxData -> m () addOutputs td = zipWithM_ (addOutput (txDataBlock td) . OutPoint (txHash (txData td))) @@ -617,13 +543,13 @@ | otherwise -> ck hs' in ck hs -addOutput :: BlockRef -> OutPoint -> TxOut -> MemoryTx () +addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () addOutput = modOutput True -delOutput :: BlockRef -> OutPoint -> TxOut -> MemoryTx () +delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () delOutput = modOutput False -modOutput :: Bool -> BlockRef -> OutPoint -> TxOut -> MemoryTx () +modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m () modOutput add br op o = do mod_unspent forM_ ma $ \a -> do @@ -645,7 +571,7 @@ mod_addr_unspent | add = insertAddrUnspent | otherwise = deleteAddrUnspent -delOutputs :: TxData -> MemoryTx () +delOutputs :: MonadImport m => TxData -> m () delOutputs td = forM_ (zip [0..] outs) $ \(i, o) -> do let op = OutPoint (txHash (txData td)) i @@ -653,7 +579,7 @@ where outs = txOut (txData td) -getImportTxData :: MonadImport m => TxHash -> WriterT m TxData +getImportTxData :: MonadImport m => TxHash -> m TxData getImportTxData th = getActiveTxData th >>= \case Nothing -> do @@ -666,7 +592,7 @@ guard (fromIntegral i < length (txOut tx)) return $ txOut tx !! fromIntegral i -spendOutput :: TxHash -> Word32 -> Unspent -> MemoryTx () +spendOutput :: MonadImport m => TxHash -> Word32 -> Unspent -> m () spendOutput th ix u = do insertSpender (unspentPoint u) (Spender th ix) let pk = B.Short.fromShort (unspentScript u) @@ -680,10 +606,10 @@ deleteAddrUnspent a u deleteUnspent (unspentPoint u) -unspendOutputs :: TxData -> MemoryTx () +unspendOutputs :: MonadImport m => TxData -> m () unspendOutputs td = mapM_ unspendOutput (prevOuts (txData td)) -unspendOutput :: OutPoint -> MemoryTx () +unspendOutput :: MonadImport m => OutPoint -> m () unspendOutput op = do t <- getActiveTxData (outPointHash op) >>= \case Nothing -> @@ -706,23 +632,24 @@ insertAddrUnspent a u increaseBalance (confirmed (unspentBlock u)) a (outValue o) -modifyReceived :: Address -> (Word64 -> Word64) -> MemoryTx () +modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m () modifyReceived a f = do b <- getDefaultBalance a setBalance b { balanceTotalReceived = f (balanceTotalReceived b) } -decreaseBalance :: Bool -> Address -> Word64 -> MemoryTx () +decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () decreaseBalance conf = modBalance conf False -increaseBalance :: Bool -> Address -> Word64 -> MemoryTx () +increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () increaseBalance conf = modBalance conf True modBalance - :: Bool -- ^ confirmed + :: MonadImport m + => Bool -- ^ confirmed -> Bool -- ^ add -> Address -> Word64 - -> MemoryTx () + -> m () modBalance conf add a val = do b <- getDefaultBalance a setBalance $ (g . f) b @@ -733,7 +660,7 @@ m | add = (+) | otherwise = subtract -modAddressCount :: Bool -> Address -> MemoryTx () +modAddressCount :: MonadImport m => Bool -> Address -> m () modAddressCount add a = do b <- getDefaultBalance a setBalance b {balanceTxCount = f (balanceTxCount b)}