haskoin-store 0.35.2 → 0.36.0
raw patch · 4 files changed
+213/−324 lines, 4 filesdep ~haskoin-storedep ~haskoin-store-data
Dependency ranges changed: haskoin-store, haskoin-store-data
Files
- haskoin-store.cabal +6/−6
- src/Haskoin/Store/Common.hs +2/−1
- src/Haskoin/Store/Database/Writer.hs +73/−112
- src/Haskoin/Store/Logic.hs +132/−205
haskoin-store.cabal view
@@ -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 <https://github.com/haskoin/haskoin-store#readme> category: Bitcoin, Finance, Network@@ -53,7 +53,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1- , haskoin-store-data ==0.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
src/Haskoin/Store/Common.hs view
@@ -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 ()
src/Haskoin/Store/Database/Writer.hs view
@@ -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)
src/Haskoin/Store/Logic.hs view
@@ -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)}