haskoin-store 0.16.0 → 0.16.1
raw patch · 5 files changed
+104/−61 lines, 5 files
Files
- CHANGELOG.md +5/−0
- haskoin-store.cabal +2/−2
- src/Network/Haskoin/Store/Data/Cached.hs +3/−1
- src/Network/Haskoin/Store/Data/ImportDB.hs +32/−2
- src/Network/Haskoin/Store/Logic.hs +62/−56
CHANGELOG.md view
@@ -4,6 +4,11 @@ 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.16.1+### Added+- Cache mempool transactions.+- Improve initial syncing performance.+ ## 0.16.0 ### Added - Orphan transaction support.
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a806db1bfb6b706e998c48d71994d5fe905b80350b267bcdfcb11398f97bee3e+-- hash: 7bbe7347a0126be9bd8aec84b19b635f8acc5701fa8600737ea7d974fa5db2ea name: haskoin-store-version: 0.16.0+version: 0.16.1 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/Network/Haskoin/Store/Data/Cached.hs view
@@ -32,6 +32,7 @@ newLayeredDB blocks (Just cache) = do bulkCopy opts db cdb BalKeyS bulkCopy opts db cdb UnspentKeyB+ bulkCopy opts db cdb MemKeyS return LayeredDB {layeredDB = blocks, layeredCache = Just cache} where BlockDB {blockDBopts = opts, blockDB = db} = blocks@@ -81,7 +82,8 @@ => Maybe UnixTime -> LayeredDB -> ConduitT () (UnixTime, TxHash) m ()-getMempoolC mpu LayeredDB {layeredDB = db} = getMempoolDB mpu db+getMempoolC mpu LayeredDB {layeredCache = Just db} = getMempoolDB mpu db+getMempoolC mpu LayeredDB {layeredDB = db} = getMempoolDB mpu db getOrphansC :: (MonadUnliftIO m, MonadResource m)
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -77,8 +77,7 @@ cacheMapOps :: BlockMem -> [BatchOp] cacheMapOps db =- balOps (hBalance db) <>- unspentOps (hUnspent db)+ balOps (hBalance db) <> mempoolOps (hMempool db) <> unspentOps (hUnspent db) bestBlockOp :: Maybe BlockHash -> [BatchOp] bestBlockOp Nothing = []@@ -315,6 +314,29 @@ deleteUnspentI p ImportDB {importHashMap = hm} = withBlockMem hm $ deleteUnspent p +getMempoolI ::+ MonadIO m+ => Maybe UnixTime+ -> ImportDB+ -> ConduitT () (UnixTime, TxHash) m ()+getMempoolI mpu ImportDB {importHashMap = hm, importLayeredDB = db} = do+ h <- hMempool <$> readTVarIO hm+ let hmap =+ M.fromList . filter tfilter $+ concatMap+ (\(u, l) -> map (\(t, b) -> ((u, t), b)) (M.toList l))+ (M.toList h)+ dmap <-+ fmap M.fromList . liftIO . runResourceT . withLayeredDB db . runConduit $+ getMempool mpu .| mapC (, True) .| sinkList+ let rmap = M.filter id (M.union hmap dmap)+ yieldMany $ sortBy (flip compare) (M.keys rmap)+ where+ tfilter =+ case mpu of+ Just x -> (<= x) . fst . fst+ Nothing -> const True+ instance MonadIO m => StoreRead (ReaderT ImportDB m) where isInitialized = R.ask >>= isInitializedI getBestBlock = R.ask >>= getBestBlockI@@ -346,3 +368,11 @@ insertUnspent u = R.ask >>= insertUnspentI u deleteUnspent p = R.ask >>= deleteUnspentI p setBalance b = R.ask >>= setBalanceI b++instance MonadIO m => StoreStream (ReaderT ImportDB m) where+ getMempool m = R.ask >>= getMempoolI m+ getOrphans = undefined+ getAddressUnspents a m = undefined+ getAddressTxs a m = undefined+ getAddressBalances = undefined+ getUnspents = undefined
src/Network/Haskoin/Store/Logic.hs view
@@ -54,6 +54,7 @@ initDB :: ( StoreRead m , StoreWrite m+ , StoreStream m , MonadLogger m , MonadError ImportException m )@@ -75,10 +76,7 @@ importBlock net (genesisBlock net) (genesisNode net) setInit -getOldOrphans ::- (StoreStream m, MonadResource m)- => UnixTime- -> ConduitT () TxHash m ()+getOldOrphans :: (Monad m, StoreStream m) => UnixTime -> ConduitT () TxHash m () getOldOrphans now = getOrphans .| filterC ((< now - 600) . fst) .| mapC (txHash . snd) @@ -222,6 +220,7 @@ importBlock :: ( StoreRead m+ , StoreStream m , StoreWrite m , MonadLogger m , MonadError ImportException m@@ -231,59 +230,66 @@ -> BlockNode -> m () importBlock net b n = do- getBestBlock >>= \case- Nothing- | 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 -> do- $(logErrorS) "BlockLogic" $- "Block " <> blockHashToHex (headerHash (blockHeader b)) <>- " does not build on current best " <>- blockHashToHex h- throwError- (PrevBlockNotBest- (blockHashToHex (prevBlock (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 = fromIntegral w- , blockDataSubsidy = subsidy (nodeHeight n)- , blockDataFees = cb_out_val - subsidy (nodeHeight n)- , blockDataOutputs = ts_out_val- }- insertAtHeight (headerHash (nodeHeader n)) (nodeHeight n)- setBest (headerHash (nodeHeader n))- $(logDebugS) "Block" $ "Importing or confirming block transactions..."- mapM_ (uncurry import_or_confirm) (sortTxs (blockTxns b))- $(logDebugS) "Block" $- "Done importing transactions for block " <>- blockHashToHex (headerHash (nodeHeader n))+ mp <-+ runConduit $+ getMempool Nothing .| mapC snd .| filterC (`elem` bths) .| sinkList+ getBestBlock >>= \case+ Nothing+ | 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 -> do+ $(logErrorS) "BlockLogic" $+ "Block " <> blockHashToHex (headerHash (blockHeader b)) <>+ " does not build on current best " <>+ blockHashToHex h+ throwError+ (PrevBlockNotBest+ (blockHashToHex (prevBlock (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 = fromIntegral w+ , blockDataSubsidy = subsidy (nodeHeight n)+ , blockDataFees = cb_out_val - subsidy (nodeHeight n)+ , blockDataOutputs = ts_out_val+ }+ insertAtHeight (headerHash (nodeHeader n)) (nodeHeight n)+ setBest (headerHash (nodeHeader n))+ $(logDebugS) "Block" $ "Importing or confirming block transactions..."+ mapM_ (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b))+ $(logDebugS) "Block" $+ "Done importing transactions for block " <>+ blockHashToHex (headerHash (nodeHeader n)) where- import_or_confirm x tx =- getTxData (txHash tx) >>= \case- Just t- | x > 0 && not (txDataDeleted t) -> do confirmTx net t (br x) tx- _ -> do- importTx- net- (br x)- (fromIntegral (blockTimestamp (nodeHeader n)))- tx+ bths = map txHash (blockTxns b)+ import_or_confirm mp x tx =+ if txHash tx `elem` mp+ then getTxData (txHash tx) >>= \case+ Just td -> confirmTx net td (br x) tx+ Nothing -> do+ $(logErrorS) "Block" $+ "Cannot get data for transaction in mempool"+ throwError $ TxNotFound (txHashToHex (txHash tx))+ else importTx+ net+ (br x)+ (fromIntegral (blockTimestamp (nodeHeader n)))+ tx subsidy = computeSubsidy net cb_out_val = sum (map outValue (txOut (head (blockTxns b)))) ts_out_val = sum (map (sum . map outValue . txOut) (tail (blockTxns b)))