haskoin-store 0.5.0 → 0.6.0
raw patch · 12 files changed
+930/−494 lines, 12 files
Files
- CHANGELOG.md +13/−2
- app/Main.hs +19/−2
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +14/−12
- src/Network/Haskoin/Store/Block.hs +38/−16
- src/Network/Haskoin/Store/Data.hs +126/−21
- src/Network/Haskoin/Store/Data/HashMap.hs +177/−114
- src/Network/Haskoin/Store/Data/ImportDB.hs +72/−42
- src/Network/Haskoin/Store/Data/KeyValue.hs +12/−13
- src/Network/Haskoin/Store/Data/RocksDB.hs +24/−25
- src/Network/Haskoin/Store/Logic.hs +432/−245
- test/Spec.hs +1/−0
CHANGELOG.md view
@@ -4,11 +4,22 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.6.0+### Added+- Address balance cache in memory.++### Changed+- Simplify data model further.+- Fix bug importing outputs with UTXO cache.+- Unspent balances cannot be negative.+ ## 0.5.0+### Added+- Add UTXO cache in memory.+- Get transactions with witness data in segwit networks.+ ### Changed - Paths for derivations in xpubs is a list and no longer a string.-- Get transactions with witness data in segwit networks.-- Add UTXO cache in memory. - Various bug fixes. ## 0.4.2
app/Main.hs view
@@ -356,14 +356,31 @@ res <- withSnapshot db $ \s -> do let d = (db, defaultReadOptions {useSnapshot = Just s})- getBalance d address+ getBalance d address >>= \case+ Just b -> return b+ Nothing ->+ return+ Balance+ { balanceAddress = address+ , balanceAmount = 0+ , balanceCount = 0+ , balanceZero = 0+ } S.json $ balanceToJSON net res S.get "/address/balances" $ do addresses <- parse_addresses res <- withSnapshot db $ \s -> do let d = (db, defaultReadOptions {useSnapshot = Just s})- mapM (getBalance d) addresses+ f a Nothing =+ Balance+ { balanceAddress = a+ , balanceAmount = 0+ , balanceCount = 0+ , balanceZero = 0+ }+ f _ (Just b) = b+ mapM (\a -> f a <$> getBalance d a) addresses S.json $ map (balanceToJSON net) res S.get "/xpub/:xpub/balances" $ do xpub <- parse_xpub
haskoin-store.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9f282c83b5c6c54c4781dbfbe252a55fa6ae68ba6164c9f42f954775560e2b20+-- hash: 922627e06c3369774ef7b05e763944bc0e2305abe21a0ff6628093fcfe5a2ccb name: haskoin-store-version: 0.5.0+version: 0.6.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network
src/Haskoin/Store.hs view
@@ -27,6 +27,11 @@ , getBlocksAtHeight , getBlock , getTransaction+ , getTxData+ , getSpenders+ , getSpender+ , fromTransaction+ , toTransaction , getBalance , getMempool , getAddressUnspents@@ -231,20 +236,17 @@ f p t = XPubTx {xPubTxPath = pathToList p, xPubTx = t} xpubBals ::- (Monad m, StoreStream i m, StoreRead i m) => i -> XPubKey -> m [XPubBal]+ (Monad m, StoreStream i m, BalanceRead i m)+ => i+ -> XPubKey+ -> m [XPubBal] xpubBals i xpub = do as <- xpubAddrs i xpub- fmap catMaybes $- forM as $ \(a, p) ->- getBalance i a >>= \b ->- return $- if balanceCount b == 0- then Nothing- else Just- XPubBal- { xPubBalPath = pathToList p- , xPubBal = b- }+ fmap catMaybes . forM as $ \(a, p) ->+ getBalance i a >>= \case+ Nothing -> return Nothing+ Just b ->+ return $ Just XPubBal {xPubBalPath = pathToList p, xPubBal = b} xpubUnspent :: (Monad m, StoreStream i m, StoreRead i m)
src/Network/Haskoin/Store/Block.hs view
@@ -47,10 +47,11 @@ -- | Block store process state. data BlockRead = BlockRead- { mySelf :: !BlockStore- , myConfig :: !BlockConfig- , myPeer :: !(TVar (Maybe Syncing))- , myUnspent :: !(TVar UnspentMap)+ { mySelf :: !BlockStore+ , myConfig :: !BlockConfig+ , myPeer :: !(TVar (Maybe Syncing))+ , myUnspent :: !(TVar UnspentMap)+ , myBalances :: !(TVar BalanceMap) } -- | Run block store process.@@ -63,15 +64,23 @@ $(logInfoS) "Block" "Initializing block store..." pb <- newTVarIO Nothing um <- newTVarIO M.empty+ bm <- newTVarIO (M.empty, []) runReaderT (ini >> run)- BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb, myUnspent = um}+ BlockRead+ { mySelf = inboxToMailbox inbox+ , myConfig = cfg+ , myPeer = pb+ , myUnspent = um+ , myBalances = bm+ } where ini = do db <- blockConfDB <$> asks myConfig net <- blockConfNet <$> asks myConfig um <- asks myUnspent- runExceptT (initDB net db um) >>= \case+ bm <- asks myBalances+ runExceptT (initDB net db um bm) >>= \case Left e -> do $(logErrorS) "Block" $ "Could not initialize block store: " <> fromString (show e)@@ -94,18 +103,27 @@ (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => Peer -> m () mempool p = MMempool `sendMessage` p -pruneUnspent :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m ()-pruneUnspent = do+pruneCache :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m ()+pruneCache = do um <- asks myUnspent+ bm <- asks myBalances u <- readTVarIO um+ b <- readTVarIO bm $(logDebugS) "Block" $ "Unspent output cache pre-prune tx count: " <> fromString (show (M.size u))- atomically $ modifyTVar um pruneUnspentMap- v <- readTVarIO um $(logDebugS) "Block" $+ "Address cache pre-prune count: " <> fromString (show (M.size (fst b)))+ pruneUnspent um+ pruneBalance bm+ u' <- readTVarIO um+ b' <- readTVarIO bm+ $(logDebugS) "Block" $ "Unspent output cache post-prune tx count: " <>- fromString (show (M.size v))+ fromString (show (M.size u'))+ $(logDebugS) "Block" $+ "Address cache post-prune count: " <>+ fromString (show (M.size (fst b'))) processBlock :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m)@@ -126,12 +144,13 @@ upr net <- blockConfNet <$> asks myConfig um <- asks myUnspent- runExceptT (newBlock net db um b n) >>= \case+ bm <- asks myBalances+ runExceptT (newBlock net db um bm b n) >>= \case Right () -> do l <- blockConfListener <$> asks myConfig atomically $ l (StoreBestBlock (headerHash (blockHeader b))) lift $ isSynced >>= \x -> when x (mempool p)- when (nodeHeight n `mod` 1000 == 0) (lift pruneUnspent)+ when (nodeHeight n `mod` 1000 == 0) (lift pruneCache) Left e -> do $(logErrorS) "Block" $ "Error importing block " <>@@ -190,7 +209,8 @@ net <- blockConfNet <$> asks myConfig db <- blockConfDB <$> asks myConfig um <- asks myUnspent- runExceptT (runImportDB db um $ \i -> newMempoolTx net i tx now) >>= \case+ bm <- asks myBalances+ runExceptT (runImportDB db um bm $ \i -> newMempoolTx net i tx now) >>= \case Left e -> $(logErrorS) "Block" $ "Error importing tx: " <> txHashToHex (txHash tx) <> ": " <>@@ -214,7 +234,7 @@ xs <- fmap catMaybes . forM hs $ \h -> runMaybeT $ do- t <- getTransaction (db, defaultReadOptions) h+ t <- getTxData (db, defaultReadOptions) h guard (isNothing t) return (getTxHash h) $(logDebugS) "Block" $@@ -350,7 +370,9 @@ resetPeer db <- blockConfDB <$> asks myConfig um <- asks myUnspent- runExceptT (runImportDB db um $ \i -> revertBlock i d) >>= \case+ bm <- asks myBalances+ net <- blockConfNet <$> asks myConfig+ runExceptT (runImportDB db um bm $ \i -> revertBlock net i d) >>= \case Left e -> do $(logErrorS) "Block" $ "Could not revert best block: " <>
src/Network/Haskoin/Store/Data.hs view
@@ -5,21 +5,24 @@ module Network.Haskoin.Store.Data where import Conduit-import Data.Aeson as A-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Short (ShortByteString)-import qualified Data.ByteString.Short as B.Short+import Control.Monad.Trans.Maybe+import Data.Aeson as A+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString.Short as B.Short import Data.Hashable import Data.Int+import qualified Data.IntMap as I+import Data.IntMap.Strict (IntMap) import Data.Maybe-import Data.Serialize as S+import Data.Serialize as S import Data.String.Conversions import Data.Time.Clock.System import Data.Word import GHC.Generics import Haskoin-import Network.Socket (SockAddr)+import Network.Socket (SockAddr) import UnliftIO.Exception type UnixTime = Int64@@ -27,20 +30,39 @@ newtype InitException = IncorrectVersion Word32 deriving (Show, Read, Eq, Ord, Exception) -class UnspentStore u m where+class Applicative m => UnspentWrite u m where addUnspent :: u -> Unspent -> m () delUnspent :: u -> OutPoint -> m ()+ pruneUnspent :: u -> m ()+ pruneUnspent _ = pure ()++class UnspentRead u m where getUnspent :: u -> OutPoint -> m (Maybe Unspent) +class Applicative m => BalanceWrite b m where+ setBalance :: b -> Balance -> m ()+ pruneBalance :: b -> m ()+ pruneBalance _ = pure ()++class BalanceRead b m where+ getBalance :: b -> Address -> m (Maybe Balance)+ class StoreRead r m where isInitialized :: r -> m (Either InitException Bool) getBestBlock :: r -> m (Maybe BlockHash) getBlocksAtHeight :: r -> BlockHeight -> m [BlockHash] getBlock :: r -> BlockHash -> m (Maybe BlockData)- getTransaction :: r -> TxHash -> m (Maybe Transaction)- getOutput :: r -> OutPoint -> m (Maybe Output)- getBalance :: r -> Address -> m Balance+ getTxData :: r -> TxHash -> m (Maybe TxData)+ getSpenders :: r -> TxHash -> m (IntMap Spender)+ getSpender :: r -> OutPoint -> m (Maybe Spender) +getTransaction ::+ (Monad m, StoreRead r m) => r -> TxHash -> m (Maybe Transaction)+getTransaction r h = runMaybeT $ do+ d <- MaybeT $ getTxData r h+ sm <- lift $ getSpenders r h+ return $ toTransaction d sm+ class StoreStream r m where getMempool :: r -> ConduitT () (PreciseUnixTime, TxHash) m () getAddressUnspents :: r -> Address -> ConduitT () Unspent m ()@@ -51,9 +73,9 @@ setBest :: w -> BlockHash -> m () insertBlock :: w -> BlockData -> m () insertAtHeight :: w -> BlockHash -> BlockHeight -> m ()- insertTx :: w -> Transaction -> m ()- insertOutput :: w -> OutPoint -> Output -> m ()- setBalance :: w -> Balance -> m ()+ insertTx :: w -> TxData -> m ()+ insertSpender :: w -> OutPoint -> Spender -> m ()+ deleteSpender :: w -> OutPoint -> m () insertAddrTx :: w -> AddressTx -> m () removeAddrTx :: w -> AddressTx -> m () insertAddrUnspent :: w -> Address -> Unspent -> m ()@@ -129,8 +151,8 @@ -- ^ address balance , balanceAmount :: !Word64 -- ^ confirmed balance- , balanceZero :: !Int64- -- ^ unconfirmed balance (can be negative)+ , balanceZero :: !Word64+ -- ^ unconfirmed balance , balanceCount :: !Word64 -- ^ number of unspent outputs } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)@@ -278,6 +300,7 @@ , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps) ] ++ ["witness" .= fmap (map encodeHex) wit | getSegWit net]+ inputPairs net Coinbase { inputPoint = OutPoint oph opi , inputSequence = sq , inputSigScript = ss@@ -344,6 +367,84 @@ outputToEncoding :: Network -> Output -> Encoding outputToEncoding net = pairs . mconcat . outputPairs net +data Prev = Prev+ { prevScript :: !ByteString+ , prevAmount :: !Word64+ } deriving (Show, Eq, Ord, Generic, Hashable, Serialize)++toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> Input+toInput i Nothing w =+ Coinbase+ { inputPoint = prevOutput i+ , inputSequence = txInSequence i+ , inputSigScript = scriptInput i+ , inputWitness = w+ }+toInput i (Just p) w =+ Input+ { inputPoint = prevOutput i+ , inputSequence = txInSequence i+ , inputSigScript = scriptInput i+ , inputPkScript = prevScript p+ , inputAmount = prevAmount p+ , inputWitness = w+ }++toOutput :: TxOut -> Maybe Spender -> Output+toOutput o s =+ Output+ { outputAmount = outValue o+ , outputScript = scriptOutput o+ , outputSpender = s+ }++data TxData = TxData+ { txDataBlock :: !BlockRef+ , txData :: !Tx+ , txDataPrevs :: !(IntMap Prev)+ , txDataDeleted :: !Bool+ , txDataRBF :: Bool+ } deriving (Show, Eq, Ord, Generic, Serialize)++toTransaction :: TxData -> IntMap Spender -> Transaction+toTransaction t sm =+ Transaction+ { transactionBlock = txDataBlock t+ , transactionVersion = txVersion (txData t)+ , transactionLockTime = txLockTime (txData t)+ , transactionInputs = ins+ , transactionOutputs = outs+ , transactionDeleted = txDataDeleted t+ , transactionRBF = txDataRBF t+ }+ where+ ws =+ take (length (txIn (txData t))) $+ map Just (txWitness (txData t)) <> repeat Nothing+ f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)+ ins = zipWith f [0 ..] (txIn (txData t))+ g n o = toOutput o (I.lookup n sm)+ outs = zipWith g [0 ..] (txOut (txData t))++fromTransaction :: Transaction -> (TxData, IntMap Spender)+fromTransaction t = (d, sm)+ where+ d =+ TxData+ { txDataBlock = transactionBlock t+ , txData = transactionData t+ , txDataPrevs = ps+ , txDataDeleted = transactionDeleted t+ , txDataRBF = transactionRBF t+ }+ f _ Coinbase {} = Nothing+ f n Input {inputPkScript = s, inputAmount = v} =+ Just (n, Prev {prevScript = s, prevAmount = v})+ ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)+ g _ Output {outputSpender = Nothing} = Nothing+ g n Output {outputSpender = Just s} = Just (n, s)+ sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)+ -- | Detailed transaction information. data Transaction = Transaction { transactionBlock :: !BlockRef@@ -352,8 +453,6 @@ -- ^ transaction version , transactionLockTime :: !Word32 -- ^ lock time- , transactionFee :: !Word64- -- ^ transaction fees paid to miners in satoshi , transactionInputs :: ![Input] -- ^ transaction inputs , transactionOutputs :: ![Output]@@ -388,9 +487,15 @@ , "size" .= B.length (S.encode (transactionData dtx)) , "version" .= transactionVersion dtx , "locktime" .= transactionLockTime dtx- , "fee" .= transactionFee dtx- , "inputs" .= map (object . inputPairs net) (transactionInputs dtx)- , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx)+ , "fee" .=+ if all isCoinbase (transactionInputs dtx)+ then 0+ else sum (map inputAmount (transactionInputs dtx)) -+ sum (map outputAmount (transactionOutputs dtx))+ , "inputs" .=+ map (object . inputPairs net) (transactionInputs dtx)+ , "outputs" .=+ map (object . outputPairs net) (transactionOutputs dtx) , "block" .= transactionBlock dtx , "deleted" .= transactionDeleted dtx ] ++
src/Network/Haskoin/Store/Data/HashMap.hs view
@@ -8,6 +8,7 @@ import Conduit import Control.Monad import qualified Data.ByteString.Short as B.Short+import Data.Function import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.IntMap.Strict (IntMap)@@ -20,13 +21,14 @@ import UnliftIO type UnspentMap = HashMap TxHash (IntMap Unspent)+type BalanceMap = (HashMap Address Balance, [Address]) data HashMapDB = HashMapDB { hBest :: !(Maybe BlockHash) , hBlock :: !(HashMap BlockHash BlockData) , hHeight :: !(HashMap BlockHeight [BlockHash])- , hTx :: !(HashMap TxHash Transaction)- , hOut :: !(HashMap TxHash (IntMap Output))+ , hTx :: !(HashMap TxHash TxData)+ , hSpender :: !(HashMap TxHash (IntMap (Maybe Spender))) , hUnspent :: !(HashMap TxHash (IntMap (Maybe Unspent))) , hBalance :: !(HashMap Address (Maybe BalVal)) , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool)))@@ -42,7 +44,7 @@ , hBlock = M.empty , hHeight = M.empty , hTx = M.empty- , hOut = M.empty+ , hSpender = M.empty , hUnspent = M.empty , hBalance = M.empty , hAddrTx = M.empty@@ -64,38 +66,28 @@ getBlockH :: HashMapDB -> BlockHash -> Maybe BlockData getBlockH db h = M.lookup h (hBlock db) -getTransactionH :: HashMapDB -> TxHash -> Maybe Transaction-getTransactionH db t = do- tx <- M.lookup t (hTx db)- m <- M.lookup t (hOut db)- return tx {transactionOutputs = I.elems m}+getTxDataH :: HashMapDB -> TxHash -> Maybe TxData+getTxDataH db t = M.lookup t (hTx db) -getOutputH :: HashMapDB -> OutPoint -> Maybe Output-getOutputH db op = do- m <- M.lookup (outPointHash op) (hOut db)+getSpenderH :: HashMapDB -> OutPoint -> Maybe (Maybe Spender)+getSpenderH db op = do+ m <- M.lookup (outPointHash op) (hSpender db) I.lookup (fromIntegral (outPointIndex op)) m -getBalanceH :: HashMapDB -> Address -> Maybe Balance-getBalanceH db a =- case M.lookup a (hBalance db) of- Nothing -> Nothing- Just Nothing ->- Just- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceZero = 0- , balanceCount = 0- }- Just (Just b) ->- Just- Balance- { balanceAddress = a- , balanceAmount = balValAmount b- , balanceZero = balValZero b- , balanceCount = balValCount b- }+getSpendersH :: HashMapDB -> TxHash -> IntMap (Maybe Spender)+getSpendersH db t = M.lookupDefault I.empty t (hSpender db) +getBalanceH :: HashMapDB -> Address -> Maybe (Maybe Balance)+getBalanceH db a = fmap f <$> M.lookup a (hBalance db)+ where+ f b =+ Balance+ { balanceAddress = a+ , balanceAmount = balValAmount b+ , balanceZero = balValZero b+ , balanceCount = balValCount b+ }+ getMempoolH :: HashMapDB -> HashMap PreciseUnixTime (HashMap TxHash Bool) getMempoolH = hMempool @@ -141,41 +133,43 @@ where f xs ys = nub $ xs <> ys -insertTxH :: Transaction -> HashMapDB -> HashMapDB-insertTxH tx db =+insertTxH :: TxData -> HashMapDB -> HashMapDB+insertTxH tx db = db {hTx = M.insert (txHash (txData tx)) tx (hTx db)}++insertSpenderH :: OutPoint -> Spender -> HashMapDB -> HashMapDB+insertSpenderH op s db = db- { hTx =- M.insert- (txHash (transactionData tx))- tx {transactionOutputs = []}- (hTx db)- , hOut =- M.insert- (txHash (transactionData tx))- (I.fromList (zip [0 ..] (transactionOutputs tx)))- (hOut db)+ { hSpender =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton (fromIntegral (outPointIndex op)) (Just s))+ (hSpender db) } -insertOutputH :: OutPoint -> Output -> HashMapDB -> HashMapDB-insertOutputH op out db =+deleteSpenderH :: OutPoint -> HashMapDB -> HashMapDB+deleteSpenderH op db = db- { hOut =+ { hSpender = M.insertWith (<>) (outPointHash op)- (I.singleton (fromIntegral (outPointIndex op)) out)- (hOut db)+ (I.singleton (fromIntegral (outPointIndex op)) Nothing)+ (hSpender db) } setBalanceH :: Balance -> HashMapDB -> HashMapDB setBalanceH b db = db {hBalance = M.insert (balanceAddress b) x (hBalance db)} where- x =- case b of- Balance {balanceAmount = 0, balanceZero = 0, balanceCount = 0} ->- Nothing- Balance {balanceAmount = v, balanceZero = z, balanceCount = c} ->- Just BalVal {balValAmount = v, balValZero = z, balValCount = c}+ x+ | balanceCount b == 0 = Nothing+ | otherwise =+ Just+ BalVal+ { balValAmount = balanceAmount b+ , balValZero = balanceZero b+ , balValCount = balanceCount b+ } insertAddrTxH :: AddressTx -> HashMapDB -> HashMapDB insertAddrTxH a db =@@ -232,23 +226,50 @@ let s = M.singleton u (M.singleton h False) in db {hMempool = M.unionWith M.union s (hMempool db)} +getUnspentH :: HashMapDB -> OutPoint -> Maybe (Maybe Unspent)+getUnspentH db op = do+ m <- M.lookup (outPointHash op) (hUnspent db)+ I.lookup (fromIntegral (outPointIndex op)) m++addUnspentH :: Unspent -> HashMapDB -> HashMapDB+addUnspentH u db =+ db+ { hUnspent =+ M.insertWith+ (<>)+ (outPointHash (unspentPoint u))+ (I.singleton+ (fromIntegral (outPointIndex (unspentPoint u)))+ (Just u))+ (hUnspent db)+ }++delUnspentH :: OutPoint -> HashMapDB -> HashMapDB+delUnspentH op db =+ db+ { hUnspent =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton (fromIntegral (outPointIndex op)) Nothing)+ (hUnspent db)+ }+ instance Applicative m => StoreRead HashMapDB m where isInitialized = pure . isInitializedH getBestBlock = pure . getBestBlockH getBlocksAtHeight db = pure . getBlocksAtHeightH db getBlock db = pure . getBlockH db- getTransaction db = pure . getTransactionH db- getOutput db = pure . getOutputH db- getBalance db a = pure . fromMaybe b $ getBalanceH db a- where- b =- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceZero = 0- , balanceCount = 0- }+ getTxData db = pure . getTxDataH db+ getSpenders db = pure . I.map fromJust . I.filter isJust . getSpendersH db+ getSpender db = pure . join . getSpenderH db +instance Applicative m => BalanceRead HashMapDB m where+ getBalance db = pure . join . getBalanceH db++instance Applicative m => UnspentRead HashMapDB m where+ getUnspent db = pure . join . getUnspentH db+ instance Monad m => StoreStream HashMapDB m where getMempool db = let ls = M.toList . M.map (M.keys . M.filter id) $ getMempoolH db@@ -258,15 +279,24 @@ yieldMany . sort . catMaybes . getAddressUnspentsH db instance MonadIO m => StoreRead (TVar HashMapDB) m where- isInitialized v = atomically $ readTVar v >>= isInitialized- getBestBlock v = atomically $ readTVar v >>= getBestBlock- getBlocksAtHeight v h =- atomically $ readTVar v >>= \db -> getBlocksAtHeight db h- getBlock v b = atomically $ readTVar v >>= \db -> getBlock db b- getTransaction v t = atomically $ readTVar v >>= \db -> getTransaction db t- getOutput v t = atomically $ readTVar v >>= \db -> getOutput db t- getBalance v t = atomically $ readTVar v >>= \db -> getBalance db t+ isInitialized v = readTVarIO v >>= isInitialized+ getBestBlock v = readTVarIO v >>= getBestBlock+ getBlocksAtHeight v h = readTVarIO v >>= \db -> getBlocksAtHeight db h+ getBlock v b = readTVarIO v >>= \db -> getBlock db b+ getTxData v t = readTVarIO v >>= \db -> getTxData db t+ getSpender v t = readTVarIO v >>= \db -> getSpender db t+ getSpenders v t = readTVarIO v >>= \db -> getSpenders db t +instance MonadIO m => BalanceRead (TVar HashMapDB) m where+ getBalance v a =+ readTVarIO v >>= \db -> getBalance db a++instance MonadIO m => UnspentRead (TVar HashMapDB) m where+ getUnspent v op = readTVarIO v >>= \db -> getUnspent db op++instance MonadIO m => BalanceWrite (TVar HashMapDB) m where+ setBalance v b = atomically $ modifyTVar v (setBalanceH b)+ instance MonadIO m => StoreStream (TVar HashMapDB) m where getMempool v = readTVarIO v >>= getMempool getAddressTxs v a = readTVarIO v >>= \db -> getAddressTxs db a@@ -278,8 +308,8 @@ insertBlock f = f . insertBlockH insertAtHeight f h = f . insertAtHeightH h insertTx f = f . insertTxH- insertOutput f p = f . insertOutputH p- setBalance f = f . setBalanceH+ insertSpender f p = f . insertSpenderH p+ deleteSpender f = f . deleteSpenderH insertAddrTx f = f . insertAddrTxH removeAddrTx f = f . removeAddrTxH insertAddrUnspent f a = f . insertAddrUnspentH a@@ -287,14 +317,18 @@ insertMempoolTx f h = f . insertMempoolTxH h deleteMempoolTx f h = f . deleteMempoolTxH h +instance Applicative m => UnspentWrite ((HashMapDB -> HashMapDB) -> m ()) m where+ addUnspent f = f . addUnspentH+ delUnspent f = f . delUnspentH+ instance MonadIO m => StoreWrite (TVar HashMapDB) m where setInit v = atomically $ setInit (modifyTVar v) setBest v = atomically . setBest (modifyTVar v) insertBlock v = atomically . insertBlock (modifyTVar v) insertAtHeight v h = atomically . insertAtHeight (modifyTVar v) h insertTx v = atomically . insertTx (modifyTVar v)- insertOutput v p = atomically . insertOutput (modifyTVar v) p- setBalance v = atomically . setBalance (modifyTVar v)+ insertSpender v p = atomically . insertSpender (modifyTVar v) p+ deleteSpender v = atomically . deleteSpender (modifyTVar v) insertAddrTx v = atomically . insertAddrTx (modifyTVar v) removeAddrTx v = atomically . removeAddrTx (modifyTVar v) insertAddrUnspent v a = atomically . insertAddrUnspent (modifyTVar v) a@@ -302,49 +336,78 @@ insertMempoolTx v h = atomically . insertMempoolTx (modifyTVar v) h deleteMempoolTx v h = atomically . deleteMempoolTx (modifyTVar v) h -instance MonadIO m => UnspentStore (TVar HashMapDB) m where- addUnspent v u =- atomically . modifyTVar v $ \x ->- x- { hUnspent =- M.insertWith- (<>)- (outPointHash (unspentPoint u))- (I.singleton- (fromIntegral (outPointIndex (unspentPoint u)))- (Just u))- (hUnspent x)- }- delUnspent v p =- atomically . modifyTVar v $ \x ->- x- { hUnspent =- M.insertWith- (<>)- (outPointHash p)- (I.singleton (fromIntegral (outPointIndex p)) Nothing)- (hUnspent x)- }- getUnspent v p =- (join . I.lookup (fromIntegral (outPointIndex p)) <=<- M.lookup (outPointHash p)) .- hUnspent <$>- readTVarIO v+instance MonadIO m => UnspentWrite (TVar HashMapDB) m where+ addUnspent v = atomically . addUnspent (modifyTVar v)+ delUnspent v = atomically . delUnspent (modifyTVar v) -instance MonadIO m => UnspentStore (TVar UnspentMap) m where- addUnspent v u =- atomically . modifyTVar v $+instance Applicative m => UnspentRead UnspentMap m where+ getUnspent um op = pure $ do+ m <- M.lookup (outPointHash op) um+ I.lookup (fromIntegral (outPointIndex op)) m++instance MonadIO m => UnspentRead (TVar UnspentMap) m where+ getUnspent v op = readTVarIO v >>= \um -> getUnspent um op++instance Applicative m =>+ UnspentWrite ((UnspentMap -> UnspentMap) -> m ()) m where+ addUnspent f u =+ f $ M.insertWith (<>) (outPointHash (unspentPoint u)) (I.singleton (fromIntegral (outPointIndex (unspentPoint u))) u)- delUnspent v p = atomically . modifyTVar v $ M.update f (outPointHash p)+ delUnspent f op = f $ M.update g (outPointHash op) where- f m =- let n = I.delete (fromIntegral (outPointIndex p)) m+ g m =+ let n = I.delete (fromIntegral (outPointIndex op)) m in if I.null n then Nothing else Just n- getUnspent v p =- (I.lookup (fromIntegral (outPointIndex p)) <=< M.lookup (outPointHash p)) <$>- readTVarIO v+ pruneUnspent f =+ f $ \um ->+ if M.size um > 2000 * 1000+ then let g is = unspentBlock (head (I.elems is))+ ls =+ sortBy+ (compare `on` (g . snd))+ (filter (not . I.null . snd) (M.toList um))+ in M.fromList (drop (1000 * 1000) ls)+ else um++instance MonadIO m => UnspentWrite (TVar UnspentMap) m where+ addUnspent v = atomically . addUnspent (modifyTVar v)+ delUnspent v = atomically . delUnspent (modifyTVar v)+ pruneUnspent = atomically . pruneUnspent . modifyTVar++instance Applicative m => BalanceRead BalanceMap m where+ getBalance m a = pure $ M.lookup a (fst m)++instance Applicative m =>+ BalanceWrite ((BalanceMap -> BalanceMap) -> m ()) m where+ setBalance f b =+ f $ \(m, s) ->+ if balanceCount b == 0+ then let m' = M.delete (balanceAddress b) m+ in (m', s)+ else let m' = M.insert (balanceAddress b) b m+ s' = balanceAddress b : s+ in (m', s')+ pruneBalance f =+ f $ \(m, s) ->+ if length s > 2000 * 1000+ then let s' = take (1000 * 1000) s+ m' = M.fromList (mapMaybe (g m) s')+ in (m', s')+ else (m, s)+ where+ g m a =+ case M.lookup a m of+ Nothing -> Nothing+ Just b -> Just (a, b)++instance MonadIO m => BalanceWrite (TVar BalanceMap) m where+ setBalance v = atomically . setBalance (modifyTVar v)+ pruneBalance = atomically . pruneBalance . modifyTVar++instance MonadIO m => BalanceRead (TVar BalanceMap) m where+ getBalance v a = readTVarIO v >>= \m -> getBalance m a
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -25,20 +25,29 @@ import UnliftIO data ImportDB = ImportDB- { importRocksDB :: !(DB, ReadOptions)- , importHashMap :: !(TVar HashMapDB)+ { importRocksDB :: !(DB, ReadOptions)+ , importHashMap :: !(TVar HashMapDB) , importUnspentMap :: !(TVar UnspentMap)+ , importBalanceMap :: !(TVar BalanceMap) } runImportDB :: (MonadError e m, MonadIO m) => DB -> TVar UnspentMap+ -> TVar BalanceMap -> (ImportDB -> m a) -> m a-runImportDB db um f = do+runImportDB db um bm f = do hm <- newTVarIO emptyHashMapDB- x <- f ImportDB {importRocksDB = d, importHashMap = hm, importUnspentMap = um}+ x <-+ f+ ImportDB+ { importRocksDB = d+ , importHashMap = hm+ , importUnspentMap = um+ , importBalanceMap = bm+ } ops <- hashMapOps <$> readTVarIO hm writeBatch db ops return x@@ -51,7 +60,7 @@ blockHashOps (hBlock db) <> blockHeightOps (hHeight db) <> txOps (hTx db) <>- outOps (hOut db) <>+ spenderOps (hSpender db) <> balOps (hBalance db) <> addrTxOps (hAddrTx db) <> addrOutOps (hAddrOut db) <>@@ -72,22 +81,23 @@ where f (g, ls) = insertOp (HeightKey g) ls -txOps :: HashMap TxHash Transaction -> [BatchOp]+txOps :: HashMap TxHash TxData -> [BatchOp] txOps = map f . M.toList where f (h, t) = insertOp (TxKey h) t -outOps :: HashMap TxHash (IntMap Output) -> [BatchOp]-outOps = concatMap (uncurry f) . M.toList+spenderOps :: HashMap TxHash (IntMap (Maybe Spender)) -> [BatchOp]+spenderOps = concatMap (uncurry f) . M.toList where f h = map (uncurry (g h)) . I.toList- g h i = insertOp (OutputKey (OutPoint h (fromIntegral i)))+ g h i (Just s) = insertOp (SpenderKey (OutPoint h (fromIntegral i))) s+ g h i Nothing = deleteOp (SpenderKey (OutPoint h (fromIntegral i))) balOps :: HashMap Address (Maybe BalVal) -> [BatchOp] balOps = map (uncurry f) . M.toList where- f a (Just b) = insertOp (BalKey a) b f a Nothing = deleteOp (BalKey a)+ f a (Just b) = insertOp (BalKey a) b addrTxOps :: HashMap Address (HashMap BlockRef (HashMap TxHash Bool)) -> [BatchOp]@@ -170,45 +180,55 @@ getBlockI ImportDB {importRocksDB = db, importHashMap = hm} bh = runMaybeT $ MaybeT (getBlock hm bh) <|> MaybeT (getBlock db bh) -getTransactionI ::- MonadIO m => ImportDB -> TxHash -> m (Maybe Transaction)-getTransactionI ImportDB {importRocksDB = db, importHashMap = hm} th =- runMaybeT $ do- tx <- MaybeT (getTransaction hm th) <|> MaybeT (getTransaction db th)- outs <-- forM (take (length (transactionOutputs tx)) [0 ..]) $ \i ->- fromMaybe (transactionOutputs tx !! fromIntegral i) <$>- getOutput hm (OutPoint th i)- return tx {transactionOutputs = outs}+getTxDataI ::+ MonadIO m => ImportDB -> TxHash -> m (Maybe TxData)+getTxDataI ImportDB {importRocksDB = db, importHashMap = hm} th =+ runMaybeT $ MaybeT (getTxData hm th) <|> MaybeT (getTxData db th) -getOutputI :: MonadIO m => ImportDB -> OutPoint -> m (Maybe Output)-getOutputI ImportDB {importRocksDB = db, importHashMap = hm} op =- runMaybeT $ MaybeT (getOutput hm op) <|> MaybeT (getOutput db op)+getSpenderI :: MonadIO m => ImportDB -> OutPoint -> m (Maybe Spender)+getSpenderI ImportDB {importRocksDB = db, importHashMap = hm} op =+ getSpenderH <$> readTVarIO hm <*> pure op >>= \case+ Just s -> return s+ Nothing -> getSpender db op -getBalanceI :: MonadIO m => ImportDB -> Address -> m Balance-getBalanceI ImportDB {importRocksDB = db, importHashMap = hm} a =- getBalanceH <$> readTVarIO hm <*> pure a >>= \case- Just b -> return b- Nothing -> getBalance db a+getSpendersI :: MonadIO m => ImportDB -> TxHash -> m (IntMap Spender)+getSpendersI ImportDB {importRocksDB = db, importHashMap = hm} t = do+ hsm <- getSpendersH <$> readTVarIO hm <*> pure t+ dsm <- I.map Just <$> getSpenders db t+ return . I.map fromJust . I.filter isJust $ hsm <> dsm +getBalanceI :: MonadIO m => ImportDB -> Address -> m (Maybe Balance)+getBalanceI ImportDB { importRocksDB = db+ , importHashMap = hm+ , importBalanceMap = bm+ } a =+ getBalance bm a >>= \case+ Just b -> return (Just b)+ Nothing ->+ getBalanceH <$> readTVarIO hm <*> pure a >>= \case+ Just x -> return x+ Nothing -> getBalance db a+ getUnspentI :: MonadIO m => ImportDB -> OutPoint -> m (Maybe Unspent)-getUnspentI ImportDB { importRocksDB = (db, opts)+getUnspentI ImportDB { importRocksDB = db , importHashMap = hm , importUnspentMap = um- } p =- runMaybeT $- MaybeT (getUnspent hm p) <|>- MaybeT (getUnspent um p) <|>- MaybeT (getUnspentDB db opts p)+ } op =+ getUnspent um op >>= \case+ Just b -> return (Just b)+ Nothing ->+ getUnspentH <$> readTVarIO hm <*> pure op >>= \case+ Just x -> return x+ Nothing -> getUnspent db op instance MonadIO m => StoreRead ImportDB m where isInitialized = isInitializedI getBestBlock = getBestBlockI getBlocksAtHeight = getBlocksAtHeightI getBlock = getBlockI- getTransaction = getTransactionI- getOutput = getOutputI- getBalance = getBalanceI+ getTxData = getTxDataI+ getSpender = getSpenderI+ getSpenders = getSpendersI instance MonadIO m => StoreWrite ImportDB m where setInit ImportDB {importHashMap = hm, importRocksDB = (db, _)} =@@ -217,8 +237,8 @@ insertBlock ImportDB {importHashMap = hm} = insertBlock hm insertAtHeight ImportDB {importHashMap = hm} = insertAtHeight hm insertTx ImportDB {importHashMap = hm} = insertTx hm- insertOutput ImportDB {importHashMap = hm} = insertOutput hm- setBalance ImportDB {importHashMap = hm} = setBalance hm+ insertSpender ImportDB {importHashMap = hm} = insertSpender hm+ deleteSpender ImportDB {importHashMap = hm} = deleteSpender hm insertAddrTx ImportDB {importHashMap = hm} = insertAddrTx hm removeAddrTx ImportDB {importHashMap = hm} = removeAddrTx hm insertAddrUnspent ImportDB {importHashMap = hm} = insertAddrUnspent hm@@ -226,8 +246,18 @@ insertMempoolTx ImportDB {importHashMap = hm} = insertMempoolTx hm deleteMempoolTx ImportDB {importHashMap = hm} = deleteMempoolTx hm -instance MonadIO m => UnspentStore ImportDB m where+instance MonadIO m => UnspentRead ImportDB m where+ getUnspent = getUnspentI++instance MonadIO m => UnspentWrite ImportDB m where addUnspent ImportDB {importHashMap = hm, importUnspentMap = um} u = addUnspent hm u >> addUnspent um u- delUnspent ImportDB {importHashMap = hm} = delUnspent hm- getUnspent = getUnspentI+ delUnspent ImportDB {importHashMap = hm, importUnspentMap = um} op =+ delUnspent um op >> delUnspent hm op++instance MonadIO m => BalanceRead ImportDB m where+ getBalance = getBalanceI++instance MonadIO m => BalanceWrite ImportDB m where+ setBalance ImportDB {importHashMap = hm, importBalanceMap = bm} b =+ setBalance hm b >> setBalance bm b
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -11,7 +11,6 @@ import qualified Data.ByteString as B import Data.Default import Data.Hashable-import Data.Int import Data.Serialize as S import Data.Word import Database.RocksDB.Query@@ -111,30 +110,30 @@ instance Key TxKey -instance KeyValue TxKey Transaction+instance KeyValue TxKey TxData -data OutputKey- = OutputKey { outputPoint :: !OutPoint }- | OutputKeyS { outputKeyS :: !TxHash }+data SpenderKey+ = SpenderKey { outputPoint :: !OutPoint }+ | SpenderKeyS { outputKeyS :: !TxHash } deriving (Show, Read, Eq, Ord, Generic, Hashable) -instance Serialize OutputKey where+instance Serialize SpenderKey where -- 0x10 · TxHash · Index- put (OutputKey OutPoint {outPointHash = h, outPointIndex = i}) = do+ put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do putWord8 0x10 put h put i- put (OutputKeyS h) = do+ put (SpenderKeyS h) = do putWord8 0x10 put h get = do guard . (== 0x10) =<< getWord8 op <- OutPoint <$> get <*> get- return $ OutputKey op+ return $ SpenderKey op -instance Key OutputKey+instance Key SpenderKey -instance KeyValue OutputKey Output+instance KeyValue SpenderKey Spender -- | Unspent output database key. data UnspentKey@@ -241,8 +240,8 @@ data BalVal = BalVal { balValAmount :: !Word64 -- ^ balance in satoshi- , balValZero :: !Int64- -- ^ unconfirmed balance in satoshi (can be negative)+ , balValZero :: !Word64+ -- ^ unconfirmed balance in satoshi , balValCount :: !Word64 -- ^ number of unspent outputs } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -7,9 +7,9 @@ module Network.Haskoin.Store.Data.RocksDB where import Conduit-import Control.Monad.Trans.Maybe import qualified Data.ByteString.Short as B.Short-import Data.Maybe+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as I import Data.Word import Database.RocksDB (DB, ReadOptions) import Database.RocksDB.Query@@ -19,7 +19,7 @@ import UnliftIO dataVersion :: Word32-dataVersion = 6+dataVersion = 8 data ExceptRocksDB = MempoolTxNotFound@@ -46,19 +46,20 @@ getBlockDB :: MonadIO m => DB -> ReadOptions -> BlockHash -> m (Maybe BlockData) getBlockDB db opts h = retrieve db opts (BlockKey h) -getTransactionDB ::- MonadIO m => DB -> ReadOptions -> TxHash -> m (Maybe Transaction)-getTransactionDB db opts th = runMaybeT $ do- tx <- MaybeT $ retrieve db opts (TxKey th)- outs <- lift $ getOutputsDB db opts th- return tx {transactionOutputs = outs}+getTxDataDB ::+ MonadIO m => DB -> ReadOptions -> TxHash -> m (Maybe TxData)+getTxDataDB db opts th = retrieve db opts (TxKey th) -getOutputDB :: MonadIO m => DB -> ReadOptions -> OutPoint -> m (Maybe Output)-getOutputDB db opts = retrieve db opts . OutputKey+getSpenderDB :: MonadIO m => DB -> ReadOptions -> OutPoint -> m (Maybe Spender)+getSpenderDB db opts = retrieve db opts . SpenderKey -getOutputsDB :: MonadIO m => DB -> ReadOptions -> TxHash -> m [Output]-getOutputsDB db opts th =- map snd <$> liftIO (matchingAsList db opts (OutputKeyS th))+getSpendersDB :: MonadIO m => DB -> ReadOptions -> TxHash -> m (IntMap Spender)+getSpendersDB db opts th =+ I.fromList . map (uncurry f) <$>+ liftIO (matchingAsList db opts (SpenderKeyS th))+ where+ f (SpenderKey op) s = (fromIntegral (outPointIndex op), s)+ f _ _ = undefined getBalanceDB :: MonadIO m => DB -> ReadOptions -> Address -> m (Maybe Balance) getBalanceDB db opts a = fmap f <$> retrieve db opts (BalKey a)@@ -132,22 +133,20 @@ getBestBlock (db, opts) = getBestBlockDB db opts getBlocksAtHeight (db, opts) = getBlocksAtHeightDB db opts getBlock (db, opts) = getBlockDB db opts- getTransaction (db, opts) = getTransactionDB db opts- getOutput (db, opts) = getOutputDB db opts- getBalance (db, opts) a = fromMaybe b <$> getBalanceDB db opts a- where- b =- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceZero = 0- , balanceCount = 0- }+ getTxData (db, opts) = getTxDataDB db opts+ getSpenders (db, opts) = getSpendersDB db opts+ getSpender (db, opts) = getSpenderDB db opts instance (MonadIO m, MonadResource m) => StoreStream (DB, ReadOptions) m where getMempool (db, opts) = getMempoolDB db opts getAddressTxs (db, opts) = getAddressTxsDB db opts getAddressUnspents (db, opts) = getAddressUnspentsDB db opts++instance MonadIO m => BalanceRead (DB, ReadOptions) m where+ getBalance (db, opts) = getBalanceDB db opts++instance MonadIO m => UnspentRead (DB, ReadOptions) m where+ getUnspent (db, opts) = getUnspentDB db opts setInitDB :: MonadIO m => DB -> m () setInitDB db = insert db VersionKey dataVersion
src/Network/Haskoin/Store/Logic.hs view
@@ -1,19 +1,21 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Store.Logic where import Conduit import Control.Monad import Control.Monad.Except+import Control.Monad.Logger import qualified Data.ByteString as B import qualified Data.ByteString.Short as B.Short-import Data.Function-import qualified Data.HashMap.Strict as M import qualified Data.IntMap.Strict as I import Data.List import Data.Maybe import Data.Serialize+import Data.String import Data.Word import Database.RocksDB import Haskoin@@ -33,9 +35,12 @@ | NoUnspent !OutPoint | TxDeleted !TxHash | TxDoubleSpend !TxHash+ | AlreadyUnspent !OutPoint | TxConfirmed !TxHash | OutputOutOfRange !OutPoint+ | BalanceNotFound !Address | InsufficientBalance !Address+ | InsufficientZeroBalance !Address | InsufficientOutputs !Address | InsufficientFunds !TxHash | InitException !InitException@@ -43,17 +48,26 @@ deriving (Show, Read, Eq, Ord, Exception) initDB ::- (MonadIO m, MonadError ImportException m)+ (MonadIO m, MonadError ImportException m, MonadLoggerIO m) => Network -> DB -> TVar UnspentMap+ -> TVar BalanceMap -> m ()-initDB net db um =- runImportDB db um $ \i ->+initDB net db um bm =+ runImportDB db um bm $ \i -> isInitialized i >>= \case- Left e -> throwError (InitException e)- Right True -> return ()+ Left e -> do+ $(logErrorS) "BlockLogic" $+ "Initialization exception: " <> fromString (show e)+ throwError (InitException e)+ Right True -> do+ $(logDebugS) "BlockLogic" "Database is already initialized"+ return () Right False -> do+ $(logDebugS)+ "BlockLogic"+ "Initializing database by importing genesis block" importBlock net i (genesisBlock net) (genesisNode net) setInit i @@ -61,22 +75,35 @@ ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m ) => Network -> i -> Tx -> PreciseUnixTime -> m ()-newMempoolTx net i tx now =- getTransaction i (txHash tx) >>= \case- Just x | not (transactionDeleted x) -> return ()+newMempoolTx net i tx now = do+ $(logInfoS) "BlockLogic" $+ "Adding transaction to mempool: " <> txHashToHex (txHash tx)+ getTxData i (txHash tx) >>= \case+ Just x+ | not (txDataDeleted x) -> do+ $(logWarnS) "BlockLogic" $+ "Transaction already exists: " <> txHashToHex (txHash tx)+ return () _ -> go where go = do orp <- any isNothing <$>- mapM (getTransaction i . outPointHash . prevOutput) (txIn tx)+ mapM (getTxData i . outPointHash . prevOutput) (txIn tx)+ when orp $+ $(logErrorS) "BlockLogic" $+ "Transaction is orphan: " <> txHashToHex (txHash tx) unless orp f f = do us <-@@ -85,9 +112,11 @@ getTxOutput (outPointIndex op) t let ds = map spenderHash (mapMaybe outputSpender us) if null ds- then importTx i (MemRef now) tx+ then importTx net i (MemRef now) tx else g ds g ds = do+ $(logWarnS) "BlockLogic" $+ "Transaction inputs already spent: " <> txHashToHex (txHash tx) rbf <- if getReplaceByFee net then and <$> mapM isrbf ds@@ -96,46 +125,74 @@ then r ds else n r ds = do- forM_ ds (deleteTx i False)- importTx i (MemRef now) tx- n = insertDeletedMempoolTx i tx now+ $(logWarnS) "BlockLogic" $+ "Replacting RBF transaction with: " <> txHashToHex (txHash tx)+ forM_ ds (deleteTx net i True)+ importTx net i (MemRef now) tx+ n = do+ $(logWarnS) "BlockLogic" $+ "Inserting transaction with deleted flag: " <>+ txHashToHex (txHash tx)+ insertDeletedMempoolTx i tx now isrbf th = transactionRBF <$> getImportTx i th newBlock ::- (MonadError ImportException m, MonadIO m)+ (MonadError ImportException m, MonadIO m, MonadLogger m) => Network -> DB -> TVar UnspentMap+ -> TVar BalanceMap -> Block -> BlockNode -> m ()-newBlock net db um b n = runImportDB db um $ \i -> importBlock net i b n+newBlock net db um bm b n = runImportDB db um bm $ \i -> importBlock net i b n revertBlock :: ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> BlockHash -> m ()-revertBlock i bh = do+revertBlock net i bh = do bd <- getBestBlock i >>= \case- Nothing -> throwError BestBlockUnknown+ Nothing -> do+ $(logErrorS) "BlockLogic" "Best block unknown"+ throwError BestBlockUnknown Just h -> getBlock i h >>= \case- Nothing -> throwError (BestBlockNotFound h)+ Nothing -> do+ $(logErrorS) "BlockLogic" "Best block not found"+ throwError (BestBlockNotFound h) Just b | h == bh -> return b- | otherwise -> throwError (BlockNotBest bh)- forM_ (blockDataTxs bd) $ deleteTx i False+ | otherwise -> do+ $(logErrorS) "BlockLogic" $+ "Attempted to delete block that isn't best: " <>+ blockHashToHex h+ throwError (BlockNotBest bh)+ mapM_ (deleteTx net i False) (reverse (blockDataTxs bd)) setBest i (prevBlock (blockDataHeader bd)) insertBlock i bd {blockDataMainChain = False} importBlock ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m, UnspentStore i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m+ ) => Network -> i -> Block@@ -144,11 +201,23 @@ importBlock net i b n = do getBestBlock i >>= \case Nothing- | isGenesis n -> return ()- | otherwise -> throwError BestBlockUnknown+ | isGenesis n -> do+ $(logInfoS) "BlockLogic" $+ "Importing genesis block: " <>+ blockHashToHex (headerHash (nodeHeader n))+ return ()+ | otherwise -> do+ $(logErrorS) "BlockLogic" $+ "Importing non-genesis block when best block unknown: " <>+ blockHashToHex (headerHash (blockHeader b))+ throwError BestBlockUnknown Just h | prevBlock (blockHeader b) == h -> return ()- | otherwise ->+ | otherwise -> do+ $(logErrorS) "BlockLogic" $+ "Block " <> blockHashToHex (headerHash (blockHeader b)) <>+ " does not build on current best " <>+ blockHashToHex h throwError (PrevBlockNotBest (prevBlock (nodeHeader n))) insertBlock i@@ -163,15 +232,19 @@ insertAtHeight i (headerHash (nodeHeader n)) (nodeHeight n) setBest i (headerHash (nodeHeader n)) txs <- concat <$> mapM (getRecursiveTx i . txHash) (tail (blockTxns b))- mapM_ (deleteTx i False . txHash . transactionData) (reverse txs)- zipWithM_ (\x t -> importTx i (br x) t) [0 ..] (blockTxns b)+ mapM_ (deleteTx net i False . txHash . transactionData) (reverse txs)+ zipWithM_ (\x t -> importTx net i (br x) t) [0 ..] (blockTxns b) forM_ txs $ \tr -> do let tx = transactionData tr th = txHash tx when (th `notElem` hs) $ case transactionBlock tr of MemRef t -> newMempoolTx net i tx t- BlockRef {} -> throwError (TxConfirmed (txHash tx))+ BlockRef {} -> do+ $(logErrorS) "BlockLogic" $+ "Expected mempool transaction but found confirmed: " <>+ txHashToHex (txHash tx)+ throwError (TxConfirmed (txHash tx)) where hs = map txHash (blockTxns b) br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos}@@ -180,70 +253,95 @@ ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> BlockRef -> Tx -> m ()-importTx i br tx = do- when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $+importTx net i br tx = do+ when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do+ $(logErrorS) "BlockLogic" $+ "Transaction spends same output twice: " <> txHashToHex (txHash tx) throwError (DuplicatePrevOutput (txHash tx)) us <- if iscb then return []- else forM (txIn tx) $ \TxIn {prevOutput = op} ->- getUnspent i op >>= \case- Nothing- | confirmed br ->- getOutput i op >>= \case- Nothing ->- throwError (OrphanTx (txHash tx))- Just Output {outputSpender = Just s} -> do- deleteTx i False (spenderHash s)- getUnspent i op >>= \case- Nothing ->- throwError- (TxDoubleSpend (txHash tx))- Just u -> return u- Just Output {outputSpender = Nothing} ->- throwError (TxDoubleSpend (txHash tx))- | otherwise -> throwError (NoUnspent op)- Just u -> return u- when (iscb && not (confirmed br)) $+ else forM (txIn tx) $ \TxIn {prevOutput = op} -> uns op+ when (iscb && not (confirmed br)) $ do+ $(logErrorS) "BlockLogic" $+ "Attempting to import coinbase to the mempool: " <>+ txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHash tx)) unless iscb $ do- when (sum (map unspentAmount us) < sum (map outValue (txOut tx))) $+ when (sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do+ $(logErrorS) "BlockLogic" $+ "Insufficient funds: " <> txHashToHex (txHash tx) throwError (InsufficientFunds th)- zipWithM_- (spendOutput i br (txHash tx))- [0 ..]- us- zipWithM_ (newOutput i br (txHash tx)) [0 ..] (txOut tx)+ zipWithM_ (spendOutput net i br (txHash tx)) [0 ..] us+ zipWithM_ (newOutput net i br . OutPoint (txHash tx)) [0 ..] (txOut tx) rbf <- getrbf- insertTx- i- Transaction- { transactionBlock = br- , transactionVersion = txVersion tx- , transactionLockTime = txLockTime tx- , transactionFee = fee us- , transactionInputs =- if iscb- then zipWith mkcb (txIn tx) ws- else zipWith3 mkin us (txIn tx) ws- , transactionOutputs = map mkout (txOut tx)- , transactionDeleted = False- , transactionRBF = rbf- }- unless (confirmed br) $ insertMempoolTx i (txHash tx) (memRefTime br)+ let (d, _) =+ fromTransaction+ Transaction+ { transactionBlock = br+ , transactionVersion = txVersion tx+ , transactionLockTime = txLockTime tx+ , transactionInputs =+ if iscb+ then zipWith mkcb (txIn tx) ws+ else zipWith3 mkin us (txIn tx) ws+ , transactionOutputs = map mkout (txOut tx)+ , transactionDeleted = False+ , transactionRBF = rbf+ }+ insertTx i d+ unless (confirmed br) $+ insertMempoolTx i (txHash tx) (memRefTime br) where+ uns op =+ getUnspent i op >>= \case+ Nothing+ | confirmed br -> do+ $(logWarnS) "BlockLogic" $+ "Could not find unspent output: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ getSpender i op >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Could not find output: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (OrphanTx (txHash tx))+ Just s -> do+ $(logWarnS) "BlockLogic" $+ "Deleting conflicting transaction: " <>+ txHashToHex (spenderHash s)+ deleteTx net i True (spenderHash s)+ getUnspent i op >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Transaction double-spend detected: " <>+ txHashToHex (txHash tx)+ throwError (TxDoubleSpend (txHash tx))+ Just u -> return u+ | otherwise -> do+ $(logErrorS) "BlockLogic" $+ "No unspent output: " <> txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (NoUnspent op)+ Just u -> return u th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx))- fee us =- if iscb- then 0- else sum (map unspentAmount us) - sum (map outValue (txOut tx)) ws = map Just (txWitness tx) <> repeat Nothing getrbf | iscb = return False@@ -252,11 +350,11 @@ | otherwise = let hs = nub $ map (outPointHash . prevOutput) (txIn tx) in fmap or . forM hs $ \h ->- getTransaction i h >>= \case+ getTxData i h >>= \case Nothing -> throwError (TxNotFound h) Just t- | confirmed (transactionBlock t) -> return False- | transactionRBF t -> return True+ | confirmed (txDataBlock t) -> return False+ | txDataRBF t -> return True | otherwise -> return False mkcb ip w = Coinbase@@ -281,51 +379,68 @@ , outputSpender = Nothing } -getRecursiveTx :: (Monad m, StoreRead i m) => i -> TxHash -> m [Transaction]+getRecursiveTx ::+ (Monad m, StoreRead i m, MonadLogger m) => i -> TxHash -> m [Transaction] getRecursiveTx i th =- getTransaction i th >>= \case+ getTxData i th >>= \case Nothing -> return []- Just t ->+ Just d -> do+ sm <- getSpenders i th+ let t = toTransaction d sm fmap (t :) $ do- let ss =- nub- (map spenderHash- (mapMaybe outputSpender (transactionOutputs t)))+ let ss = nub . map spenderHash $ I.elems sm concat <$> mapM (getRecursiveTx i) ss deleteTx :: ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> Bool -- ^ only delete transaction if unconfirmed -> TxHash -> m ()-deleteTx i mo h =- getTransaction i h >>= \case- Nothing -> throwError (TxNotFound h)+deleteTx net i mo h = do+ $(logDebugS) "BlockLogic" $ "Deleting transaction: " <> txHashToHex h+ getTxData i h >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Transaciton not found: " <> txHashToHex h+ throwError (TxNotFound h) Just t- | not (transactionDeleted t) ->- if mo && confirmed (transactionBlock t)- then throwError (TxConfirmed h)- else go t- | otherwise -> return ()+ | txDataDeleted t -> do+ $(logErrorS) "BlockLogic" $+ "Transaction already deleted: " <> txHashToHex h+ return ()+ | mo && confirmed (txDataBlock t) -> do+ $(logErrorS) "BlockLogic" $+ "Will not delete confirmed transaction: " <> txHashToHex h+ throwError (TxConfirmed h)+ | otherwise -> go t where go t = do- forM_ (mapMaybe outputSpender (transactionOutputs t)) $ \s ->- deleteTx i False (spenderHash s)- forM_ (take (length (transactionOutputs t)) [0 ..]) $ \n ->- delOutput i (OutPoint h n)- let ps = filter (/= nullOutPoint) (map inputPoint (transactionInputs t))- forM_ ps $ \op -> unspendOutput i op (transactionBlock t)- unless (confirmed (transactionBlock t)) $- deleteMempoolTx i h (memRefTime (transactionBlock t))- insertTx i t {transactionDeleted = True}+ ss <- nub . map spenderHash . I.elems <$> getSpenders i h+ mapM_ (deleteTx net i True) ss+ let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))+ mapM_ (unspendOutput net i) ps+ forM_ (take (length (txOut (txData t))) [0 ..]) $ \n ->+ delOutput net i (OutPoint h n)+ unless (confirmed (txDataBlock t)) $+ deleteMempoolTx i h (memRefTime (txDataBlock t))+ insertTx i t {txDataDeleted = True} insertDeletedMempoolTx ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , MonadLogger m+ ) => i -> Tx -> PreciseUnixTime@@ -335,18 +450,20 @@ forM (txIn tx) $ \TxIn {prevOutput = op} -> getImportTx i (outPointHash op) >>= getTxOutput (outPointIndex op) rbf <- getrbf- insertTx- i- Transaction- { transactionBlock = MemRef now- , transactionVersion = txVersion tx- , transactionLockTime = txLockTime tx- , transactionFee = fee us- , transactionInputs = zipWith3 mkin us (txIn tx) ws- , transactionOutputs = map mkout (txOut tx)- , transactionDeleted = True- , transactionRBF = rbf- }+ let (d, _) =+ fromTransaction+ Transaction+ { transactionBlock = MemRef now+ , transactionVersion = txVersion tx+ , transactionLockTime = txLockTime tx+ , transactionInputs = zipWith3 mkin us (txIn tx) ws+ , transactionOutputs = map mkout (txOut tx)+ , transactionDeleted = True+ , transactionRBF = rbf+ }+ $(logWarnS) "BlockLogic" $+ "Inserting deleted mempool transaction: " <> txHashToHex (txHash tx)+ insertTx i d where ws = map Just (txWitness tx) <> repeat Nothing getrbf@@ -354,13 +471,15 @@ | otherwise = let hs = nub $ map (outPointHash . prevOutput) (txIn tx) in fmap or . forM hs $ \h ->- getTransaction i h >>= \case- Nothing -> throwError (TxNotFound h)+ getTxData i h >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Transaction not found: " <> txHashToHex h+ throwError (TxNotFound h) Just t- | confirmed (transactionBlock t) -> return False- | transactionRBF t -> return True+ | confirmed (txDataBlock t) -> return False+ | txDataRBF t -> return True | otherwise -> return False- fee us = sum (map outputAmount us) - sum (map outValue (txOut tx)) mkin u ip w = Input { inputPoint = prevOutput ip@@ -381,15 +500,19 @@ ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> BlockRef- -> TxHash- -> Word32+ -> OutPoint -> TxOut -> m ()-newOutput i tb th ix to = do+newOutput net i br op to = do addUnspent i u case scriptToAddressBS (scriptOutput to) of Left _ -> return ()@@ -399,29 +522,34 @@ i AddressTx { addressTxAddress = a- , addressTxHash = th- , addressTxBlock = tb+ , addressTxHash = outPointHash op+ , addressTxBlock = br }- increaseBalance i (confirmed tb) a (outValue to)+ increaseBalance net i (confirmed br) a (outValue to) where u = Unspent- { unspentBlock = tb+ { unspentBlock = br , unspentAmount = outValue to , unspentScript = B.Short.toShort (scriptOutput to)- , unspentPoint = OutPoint th ix+ , unspentPoint = op } delOutput :: ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> OutPoint -> m ()-delOutput i op = do+delOutput net i op = do t <- getImportTx i (outPointHash op) u <- getTxOutput (outPointIndex op) t delUnspent i op@@ -445,162 +573,221 @@ , addressTxBlock = transactionBlock t } reduceBalance+ net i (confirmed (transactionBlock t)) a (outputAmount u) getImportTx ::- (MonadError ImportException m, StoreRead i m)+ (MonadError ImportException m, StoreRead i m, MonadLogger m) => i -> TxHash -> m Transaction getImportTx i th =- getTransaction i th >>= \case- Nothing -> throwError $ TxNotFound th- Just t- | transactionDeleted t -> throwError $ TxDeleted th- | otherwise -> return t+ getTxData i th >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Tranasction not found: " <> txHashToHex th+ throwError $ TxNotFound th+ Just d+ | txDataDeleted d -> do+ $(logErrorS) "BlockLogic" $+ "Transaction deleted: " <> txHashToHex th+ throwError $ TxDeleted th+ | otherwise -> do+ sm <- getSpenders i th+ return $ toTransaction d sm getTxOutput ::- (MonadError ImportException m) => Word32 -> Transaction -> m Output+ (MonadError ImportException m, MonadLogger m)+ => Word32+ -> Transaction+ -> m Output getTxOutput i tx = do- unless (fromIntegral i < length (transactionOutputs tx)) $+ unless (fromIntegral i < length (transactionOutputs tx)) $ do+ $(logErrorS) "BlockLogic" $+ "Output out of range " <> txHashToHex (txHash (transactionData tx)) <>+ " " <>+ fromString (show i) throwError $- OutputOutOfRange- OutPoint- {outPointHash = txHash (transactionData tx), outPointIndex = i}+ OutputOutOfRange+ OutPoint+ { outPointHash = txHash (transactionData tx)+ , outPointIndex = i+ } return $ transactionOutputs tx !! fromIntegral i spendOutput :: ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> BlockRef -> TxHash -> Word32 -> Unspent -> m ()-spendOutput i tb th ix u = do- insertOutput+spendOutput net i br th ix u = do+ insertSpender i (unspentPoint u)- Output- { outputAmount = unspentAmount u- , outputScript = B.Short.fromShort (unspentScript u)- , outputSpender = Just Spender {spenderHash = th, spenderIndex = ix}- }- delUnspent i (unspentPoint u)+ Spender {spenderHash = th, spenderIndex = ix} case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of Left _ -> return () Right a -> do+ reduceBalance net i (confirmed (unspentBlock u)) a (unspentAmount u) removeAddrUnspent i a u- reduceBalance i (confirmed tb) a (unspentAmount u) insertAddrTx i AddressTx { addressTxAddress = a , addressTxHash = th- , addressTxBlock = tb+ , addressTxBlock = br }+ delUnspent i (unspentPoint u) unspendOutput :: ( MonadError ImportException m , StoreRead i m , StoreWrite i m- , UnspentStore i m+ , UnspentRead i m+ , UnspentWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m )- => i+ => Network+ -> i -> OutPoint- -> BlockRef -> m ()-unspendOutput i op br = do- tx <- getImportTx i (outPointHash op)- out <- getTxOutput (outPointIndex op) tx- when (isJust (outputSpender out)) $ do- insertTx- i- tx {transactionOutputs = zipWith f [0 ..] (transactionOutputs tx)}- let u =- Unspent- { unspentAmount = outputAmount out- , unspentBlock = transactionBlock tx- , unspentScript = B.Short.toShort (outputScript out)- , unspentPoint = op+unspendOutput net i op = do+ t <- getImportTx i (outPointHash op)+ o <- getTxOutput (outPointIndex op) t+ s <-+ case outputSpender o of+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Output already unspent: " <> txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (AlreadyUnspent op)+ Just s -> return s+ x <- getImportTx i (spenderHash s)+ deleteSpender i op+ let u =+ Unspent+ { unspentAmount = outputAmount o+ , unspentBlock = transactionBlock t+ , unspentScript = B.Short.toShort (outputScript o)+ , unspentPoint = op+ }+ addUnspent i u+ case scriptToAddressBS (outputScript o) of+ Left _ -> return ()+ Right a -> do+ insertAddrUnspent i a u+ removeAddrTx+ i+ AddressTx+ { addressTxAddress = a+ , addressTxHash = spenderHash s+ , addressTxBlock = transactionBlock x }- addUnspent i u- case scriptToAddressBS (outputScript out) of- Left _ -> return ()- Right a -> do- insertAddrUnspent i a u- increaseBalance i (confirmed br) a (outputAmount out)- where- f n o- | n == outPointIndex op = o {outputSpender = Nothing}- | otherwise = o+ increaseBalance+ net+ i+ (confirmed (unspentBlock u))+ a+ (outputAmount o) reduceBalance ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)- => i- -> Bool -- ^ confirmed+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m+ )+ => Network+ -> i+ -> Bool -- ^ spend or delete confirmed output -> Address -> Word64 -> m ()-reduceBalance i c a v = do- b <- getBalance i a- setBalance i =<<- if c- then do- unless (v <= balanceAmount b) $- throwError (InsufficientBalance a)- unless (balanceCount b > 0) $ throwError (InsufficientOutputs a)- return- b- { balanceAmount = balanceAmount b - v- , balanceCount = balanceCount b - 1- }- else do- unless- (fromIntegral v <=- fromIntegral (balanceAmount b) + balanceZero b) $- throwError (InsufficientBalance a)- unless (balanceCount b > 0) $ throwError (InsufficientOutputs a)- return- b- { balanceZero = balanceZero b - fromIntegral v- , balanceCount = balanceCount b - 1- }+reduceBalance net i c a v =+ getBalance i a >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Balance not found: " <> addrToString net a+ throwError (BalanceNotFound a)+ Just b -> do+ when+ (v >+ if c+ then balanceAmount b+ else balanceZero b) $+ $(logErrorS) "BlockLogic" $+ "Insufficient balance: " <> addrToString net a+ setBalance i $+ b+ { balanceAmount =+ balanceAmount b -+ if c+ then v+ else 0+ , balanceZero =+ balanceZero b -+ if c+ then 0+ else v+ , balanceCount = balanceCount b - 1+ } increaseBalance ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)- => i- -> Bool -- ^ confirmed+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , MonadLogger m+ )+ => Network+ -> i+ -> Bool -- ^ add confirmed output -> Address -> Word64 -> m ()-increaseBalance i c a v = do- b <- getBalance i a+increaseBalance _net i c a v = do+ b <-+ getBalance i a >>= \case+ Nothing ->+ return+ Balance+ { balanceAddress = a+ , balanceAmount = 0+ , balanceZero = 0+ , balanceCount = 0+ }+ Just b -> return b setBalance i $- if c- then b- { balanceAmount = balanceAmount b + v- , balanceCount = balanceCount b + 1- }- else b- { balanceZero = balanceZero b + fromIntegral v- , balanceCount = balanceCount b + 1- }--pruneUnspentMap :: UnspentMap -> UnspentMap-pruneUnspentMap um- | M.size um > 2000 * 1000 =- let f is = unspentBlock (head (I.elems is))- ls =- sortBy- (compare `on` (f . snd))- (filter (not . I.null . snd) (M.toList um))- in M.fromList (drop (1000 * 1000) ls)- | otherwise = um+ b+ { balanceAmount =+ balanceAmount b ++ if c+ then v+ else 0+ , balanceZero =+ balanceZero b ++ if c+ then 0+ else v+ , balanceCount = balanceCount b + 1+ }
test/Spec.hs view
@@ -74,6 +74,7 @@ w defaultOptions { createIfMissing = True+ , errorIfExists = True , compression = SnappyCompression } let cfg =