haskoin-store 0.4.2 → 0.5.0
raw patch · 10 files changed
+485/−173 lines, 10 files
Files
- CHANGELOG.md +7/−0
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +3/−3
- src/Network/Haskoin/Store/Block.hs +42/−13
- src/Network/Haskoin/Store/Data.hs +33/−12
- src/Network/Haskoin/Store/Data/HashMap.hs +103/−9
- src/Network/Haskoin/Store/Data/ImportDB.hs +59/−9
- src/Network/Haskoin/Store/Data/KeyValue.hs +43/−7
- src/Network/Haskoin/Store/Data/RocksDB.hs +28/−4
- src/Network/Haskoin/Store/Logic.hs +165/−114
CHANGELOG.md view
@@ -4,6 +4,13 @@ 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.5.0+### 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 ### Removed - Remove extended public key itself from output of relevant endpoints to save bandwidth.
haskoin-store.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: df955314f48f1a258269639f5f16eb7cf357def339f0545cc3b42abfd014743e+-- hash: 9f282c83b5c6c54c4781dbfbe252a55fa6ae68ba6164c9f42f954775560e2b20 name: haskoin-store-version: 0.4.2+version: 0.5.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
@@ -228,7 +228,7 @@ mergeSourcesBy (compare `on` (addressTxBlock . xPubTx)) cds where cnd a p = getAddressTxs i a .| mapC (f p)- f p t = XPubTx {xPubTxPath = p, xPubTx = t}+ f p t = XPubTx {xPubTxPath = pathToList p, xPubTx = t} xpubBals :: (Monad m, StoreStream i m, StoreRead i m) => i -> XPubKey -> m [XPubBal]@@ -242,7 +242,7 @@ then Nothing else Just XPubBal- { xPubBalPath = p+ { xPubBalPath = pathToList p , xPubBal = b } @@ -259,7 +259,7 @@ cnd a p = getAddressUnspents i a .| mapC (f p) f p t = XPubUnspent- {xPubUnspentPath = p, xPubUnspent = t}+ {xPubUnspentPath = pathToList p, xPubUnspent = t} -- Snatched from: -- https://github.com/cblp/conduit-merge/blob/master/src/Data/Conduit/Merge.hs
src/Network/Haskoin/Store/Block.hs view
@@ -13,6 +13,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Maybe+import qualified Data.HashMap.Strict as M import Data.Maybe import Data.String import Data.Time.Clock.System@@ -20,6 +21,7 @@ import Haskoin import Haskoin.Node import Network.Haskoin.Store.Data+import Network.Haskoin.Store.Data.HashMap import Network.Haskoin.Store.Data.ImportDB import Network.Haskoin.Store.Logic import Network.Haskoin.Store.Messages@@ -45,9 +47,10 @@ -- | Block store process state. data BlockRead = BlockRead- { mySelf :: !BlockStore- , myConfig :: !BlockConfig- , myPeer :: !(TVar (Maybe Syncing))+ { mySelf :: !BlockStore+ , myConfig :: !BlockConfig+ , myPeer :: !(TVar (Maybe Syncing))+ , myUnspent :: !(TVar UnspentMap) } -- | Run block store process.@@ -59,14 +62,16 @@ blockStore cfg inbox = do $(logInfoS) "Block" "Initializing block store..." pb <- newTVarIO Nothing+ um <- newTVarIO M.empty runReaderT (ini >> run)- BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb}+ BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb, myUnspent = um} where ini = do db <- blockConfDB <$> asks myConfig net <- blockConfNet <$> asks myConfig- runExceptT (initDB net db) >>= \case+ um <- asks myUnspent+ runExceptT (initDB net db um) >>= \case Left e -> do $(logErrorS) "Block" $ "Could not initialize block store: " <> fromString (show e)@@ -89,6 +94,19 @@ (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+ um <- asks myUnspent+ u <- readTVarIO um+ $(logDebugS) "Block" $+ "Unspent output cache pre-prune tx count: " <>+ fromString (show (M.size u))+ atomically $ modifyTVar um pruneUnspentMap+ v <- readTVarIO um+ $(logDebugS) "Block" $+ "Unspent output cache post-prune tx count: " <>+ fromString (show (M.size v))+ processBlock :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => Peer@@ -107,11 +125,13 @@ n <- cbn upr net <- blockConfNet <$> asks myConfig- runExceptT (newBlock net db b n) >>= \case+ um <- asks myUnspent+ runExceptT (newBlock net db um 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) Left e -> do $(logErrorS) "Block" $ "Error importing block " <>@@ -169,7 +189,8 @@ now <- preciseUnixTime <$> liftIO getSystemTime net <- blockConfNet <$> asks myConfig db <- blockConfDB <$> asks myConfig- runExceptT (runImportDB db $ \i -> newMempoolTx net i tx now) >>= \case+ um <- asks myUnspent+ runExceptT (runImportDB db um $ \i -> newMempoolTx net i tx now) >>= \case Left e -> $(logErrorS) "Block" $ "Error importing tx: " <> txHashToHex (txHash tx) <> ": " <>@@ -199,7 +220,9 @@ $(logDebugS) "Block" $ "Requesting " <> fromString (show (length xs)) <> " new transactions"- MGetData (GetData (map (InvVector InvTx) xs)) `sendMessage` p+ net <- blockConfNet <$> asks myConfig+ let inv = if getSegWit net then InvWitnessTx else InvTx+ MGetData (GetData (map (InvVector inv) xs)) `sendMessage` p checkTime :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m () checkTime =@@ -247,7 +270,12 @@ when (end b d c) mzero ns <- bls c b setPeer p (last ns)- vs <- mapM f ns+ net <- blockConfNet <$> asks myConfig+ let inv =+ if getSegWit net+ then InvWitnessBlock+ else InvBlock+ vs <- mapM (f inv) ns $(logInfoS) "Block" $ "Requesting " <> fromString (show (length vs)) <> " blocks" MGetData (GetData vs) `sendMessage` p@@ -283,9 +311,9 @@ end b d c | nodeHeader b == nodeHeader c = True | otherwise = nodeHeight b > nodeHeight d + 500- f GenesisNode {} = throwIO UnexpectedGenesisNode- f BlockNode {nodeHeader = bh} =- return $ InvVector InvBlock (getBlockHash (headerHash bh))+ f _ GenesisNode {} = throwIO UnexpectedGenesisNode+ f inv BlockNode {nodeHeader = bh} =+ return $ InvVector inv (getBlockHash (headerHash bh)) bls c b = do t <- top c (tts (nodeHeight c) (nodeHeight b)) ch <- blockConfChain <$> asks myConfig@@ -321,7 +349,8 @@ " as it is not in main chain..." resetPeer db <- blockConfDB <$> asks myConfig- runExceptT (runImportDB db $ \i -> revertBlock i d) >>= \case+ um <- asks myUnspent+ runExceptT (runImportDB db um $ \i -> revertBlock i d) >>= \case Left e -> do $(logErrorS) "Block" $ "Could not revert best block: " <>
src/Network/Haskoin/Store/Data.hs view
@@ -8,6 +8,8 @@ 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 Data.Maybe@@ -25,12 +27,18 @@ newtype InitException = IncorrectVersion Word32 deriving (Show, Read, Eq, Ord, Exception) +class UnspentStore u m where+ addUnspent :: u -> Unspent -> m ()+ delUnspent :: u -> OutPoint -> m ()+ getUnspent :: u -> OutPoint -> m (Maybe Unspent)+ 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 class StoreStream r m where@@ -44,6 +52,7 @@ insertBlock :: w -> BlockData -> m () insertAtHeight :: w -> BlockHash -> BlockHeight -> m () insertTx :: w -> Transaction -> m ()+ insertOutput :: w -> OutPoint -> Output -> m () setBalance :: w -> Balance -> m () insertAddrTx :: w -> AddressTx -> m () removeAddrTx :: w -> AddressTx -> m ()@@ -145,22 +154,34 @@ data Unspent = Unspent { unspentBlock :: !BlockRef -- ^ block information for output+ , unspentPoint :: !OutPoint+ -- ^ txid and index where output located , unspentAmount :: !Word64 -- ^ value of output in satoshi- , unspentScript :: !ByteString+ , unspentScript :: !ShortByteString -- ^ pubkey (output) script- , unspentPoint :: !OutPoint- -- ^ txid and index where output located- } deriving (Show, Eq, Ord, Generic, Serialize, Hashable)+ } deriving (Show, Eq, Ord, Generic, Hashable) +instance Serialize Unspent where+ put u = do+ put $ unspentBlock u+ put $ unspentPoint u+ put $ unspentAmount u+ put $ B.Short.length (unspentScript u)+ putShortByteString $ unspentScript u+ get =+ Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get)+ unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv] unspentPairs net u = [ "address" .=- eitherToMaybe (addrToJSON net <$> scriptToAddressBS (unspentScript u))+ eitherToMaybe+ (addrToJSON net <$>+ scriptToAddressBS (B.Short.fromShort (unspentScript u))) , "block" .= unspentBlock u , "txid" .= outPointHash (unspentPoint u) , "index" .= outPointIndex (unspentPoint u)- , "pkscript" .= String (encodeHex (unspentScript u))+ , "pkscript" .= String (encodeHex (B.Short.fromShort (unspentScript u))) , "value" .= unspentAmount u ] @@ -412,14 +433,14 @@ -- | Address transaction from an extended public key. data XPubTx = XPubTx- { xPubTxPath :: !SoftPath+ { xPubTxPath :: ![KeyIndex] , xPubTx :: !AddressTx } deriving (Show, Eq, Generic) -- | JSON serialization for 'XPubTx'. xPubTxPairs :: A.KeyValue kv => Network -> XPubTx -> [kv] xPubTxPairs net XPubTx {xPubTxPath = p, xPubTx = tx} =- [ "path" .= pathToStr p+ [ "path" .= p , "tx" .= addressTxToJSON net tx ] @@ -431,14 +452,14 @@ -- | Address balances for an extended public key. data XPubBal = XPubBal- { xPubBalPath :: !SoftPath+ { xPubBalPath :: ![KeyIndex] , xPubBal :: !Balance } deriving (Show, Eq, Generic) -- | JSON serialization for 'XPubBal'. xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv] xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} =- [ "path" .= pathToStr p+ [ "path" .= p , "balance" .= balanceToJSON net b ] @@ -450,7 +471,7 @@ -- | Unspent transaction for extended public key. data XPubUnspent = XPubUnspent- { xPubUnspentPath :: !SoftPath+ { xPubUnspentPath :: ![KeyIndex] , xPubUnspent :: !Unspent } deriving (Show, Eq, Generic) @@ -459,7 +480,7 @@ xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p , xPubUnspent = u } =- [ "path" .= pathToStr p+ [ "path" .= p , "unspent" .= unspentToJSON net u ]
src/Network/Haskoin/Store/Data/HashMap.hs view
@@ -6,8 +6,12 @@ module Network.Haskoin.Store.Data.HashMap where import Conduit+import Control.Monad+import qualified Data.ByteString.Short as B.Short import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I import Data.List import Data.Maybe import Haskoin@@ -15,11 +19,15 @@ import Network.Haskoin.Store.Data.KeyValue import UnliftIO +type UnspentMap = HashMap TxHash (IntMap Unspent)+ data HashMapDB = HashMapDB { hBest :: !(Maybe BlockHash) , hBlock :: !(HashMap BlockHash BlockData) , hHeight :: !(HashMap BlockHeight [BlockHash]) , hTx :: !(HashMap TxHash Transaction)+ , hOut :: !(HashMap TxHash (IntMap Output))+ , hUnspent :: !(HashMap TxHash (IntMap (Maybe Unspent))) , hBalance :: !(HashMap Address (Maybe BalVal)) , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))))@@ -34,6 +42,8 @@ , hBlock = M.empty , hHeight = M.empty , hTx = M.empty+ , hOut = M.empty+ , hUnspent = M.empty , hBalance = M.empty , hAddrTx = M.empty , hAddrOut = M.empty@@ -55,8 +65,16 @@ getBlockH db h = M.lookup h (hBlock db) getTransactionH :: HashMapDB -> TxHash -> Maybe Transaction-getTransactionH db t = M.lookup t (hTx db)+getTransactionH db t = do+ tx <- M.lookup t (hTx db)+ m <- M.lookup t (hOut db)+ return tx {transactionOutputs = I.elems m} +getOutputH :: HashMapDB -> OutPoint -> Maybe Output+getOutputH db op = do+ m <- M.lookup (outPointHash op) (hOut db)+ I.lookup (fromIntegral (outPointIndex op)) m+ getBalanceH :: HashMapDB -> Address -> Maybe Balance getBalanceH db a = case M.lookup a (hBalance db) of@@ -103,7 +121,7 @@ Unspent { unspentBlock = b , unspentAmount = outValAmount u- , unspentScript = outValScript u+ , unspentScript = B.Short.toShort (outValScript u) , unspentPoint = p } g _ _ Nothing = Nothing@@ -124,8 +142,31 @@ f xs ys = nub $ xs <> ys insertTxH :: Transaction -> HashMapDB -> HashMapDB-insertTxH tx db = db {hTx = M.insert (txHash (transactionData tx)) tx (hTx db)}+insertTxH tx 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)+ } +insertOutputH :: OutPoint -> Output -> HashMapDB -> HashMapDB+insertOutputH op out db =+ db+ { hOut =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton (fromIntegral (outPointIndex op)) out)+ (hOut db)+ }+ setBalanceH :: Balance -> HashMapDB -> HashMapDB setBalanceH b db = db {hBalance = M.insert (balanceAddress b) x (hBalance db)} where@@ -161,7 +202,7 @@ let uns = OutVal { outValAmount = unspentAmount u- , outValScript = unspentScript u+ , outValScript = B.Short.fromShort (unspentScript u) } s = M.singleton@@ -197,13 +238,16 @@ 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- }+ b =+ Balance+ { balanceAddress = a+ , balanceAmount = 0+ , balanceZero = 0+ , balanceCount = 0+ } instance Monad m => StoreStream HashMapDB m where getMempool db =@@ -220,6 +264,7 @@ 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 instance MonadIO m => StoreStream (TVar HashMapDB) m where@@ -233,6 +278,7 @@ insertBlock f = f . insertBlockH insertAtHeight f h = f . insertAtHeightH h insertTx f = f . insertTxH+ insertOutput f p = f . insertOutputH p setBalance f = f . setBalanceH insertAddrTx f = f . insertAddrTxH removeAddrTx f = f . removeAddrTxH@@ -247,6 +293,7 @@ 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) insertAddrTx v = atomically . insertAddrTx (modifyTVar v) removeAddrTx v = atomically . removeAddrTx (modifyTVar v)@@ -254,3 +301,50 @@ removeAddrUnspent v a = atomically . removeAddrUnspent (modifyTVar v) a 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 => UnspentStore (TVar UnspentMap) m where+ addUnspent v u =+ atomically . modifyTVar v $+ M.insertWith+ (<>)+ (outPointHash (unspentPoint u))+ (I.singleton (fromIntegral (outPointIndex (unspentPoint u))) u)+ delUnspent v p = atomically . modifyTVar v $ M.update f (outPointHash p)+ where+ f m =+ let n = I.delete (fromIntegral (outPointIndex p)) 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
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -8,9 +8,13 @@ import Control.Applicative import Control.Monad.Except import Control.Monad.Trans.Maybe+import qualified Data.ByteString.Short as B.Short import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I import Data.List+import Data.Maybe import Database.RocksDB as R import Database.RocksDB.Query as R import Haskoin@@ -23,16 +27,18 @@ data ImportDB = ImportDB { importRocksDB :: !(DB, ReadOptions) , importHashMap :: !(TVar HashMapDB)+ , importUnspentMap :: !(TVar UnspentMap) } runImportDB :: (MonadError e m, MonadIO m) => DB+ -> TVar UnspentMap -> (ImportDB -> m a) -> m a-runImportDB db f = do+runImportDB db um f = do hm <- newTVarIO emptyHashMapDB- x <- f ImportDB {importRocksDB = d, importHashMap = hm}+ x <- f ImportDB {importRocksDB = d, importHashMap = hm, importUnspentMap = um} ops <- hashMapOps <$> readTVarIO hm writeBatch db ops return x@@ -45,10 +51,12 @@ blockHashOps (hBlock db) <> blockHeightOps (hHeight db) <> txOps (hTx db) <>+ outOps (hOut db) <> balOps (hBalance db) <> addrTxOps (hAddrTx db) <> addrOutOps (hAddrOut db) <>- mempoolOps (hMempool db)+ mempoolOps (hMempool db) <>+ unspentOps (hUnspent db) bestBlockOp :: Maybe BlockHash -> [BatchOp] bestBlockOp Nothing = []@@ -69,6 +77,12 @@ where f (h, t) = insertOp (TxKey h) t +outOps :: HashMap TxHash (IntMap Output) -> [BatchOp]+outOps = concatMap (uncurry f) . M.toList+ where+ f h = map (uncurry (g h)) . I.toList+ g h i = insertOp (OutputKey (OutPoint h (fromIntegral i)))+ balOps :: HashMap Address (Maybe BalVal) -> [BatchOp] balOps = map (uncurry f) . M.toList where@@ -122,14 +136,22 @@ mempoolOps = concatMap (uncurry f) . M.toList where f u = map (uncurry (g u)) . M.toList- g u t True = insertOp (MemKey u t) ()+ g u t True = insertOp (MemKey u t) () g u t False = deleteOp (MemKey u t) -unspentOps :: HashMap OutPoint (Maybe OutVal) -> [BatchOp]-unspentOps = map (uncurry f) . M.toList+unspentOps :: HashMap TxHash (IntMap (Maybe Unspent)) -> [BatchOp]+unspentOps = concatMap (uncurry f) . M.toList where- f p (Just o) = insertOp (UnspentKey p) o- f p Nothing = deleteOp (UnspentKey p)+ f h = map (uncurry (g h)) . I.toList+ g h i (Just u) =+ insertOp+ (UnspentKey (OutPoint h (fromIntegral i)))+ UnspentVal+ { unspentValAmount = unspentAmount u+ , unspentValBlock = unspentBlock u+ , unspentValScript = B.Short.fromShort (unspentScript u)+ }+ g h i Nothing = deleteOp (UnspentKey (OutPoint h (fromIntegral i))) isInitializedI :: MonadIO m => ImportDB -> m (Either InitException Bool) isInitializedI ImportDB {importRocksDB = db}= isInitialized db@@ -151,20 +173,41 @@ getTransactionI :: MonadIO m => ImportDB -> TxHash -> m (Maybe Transaction) getTransactionI ImportDB {importRocksDB = db, importHashMap = hm} th =- runMaybeT $ MaybeT (getTransaction hm th) <|> MaybeT (getTransaction db 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} +getOutputI :: MonadIO m => ImportDB -> OutPoint -> m (Maybe Output)+getOutputI ImportDB {importRocksDB = db, importHashMap = hm} op =+ runMaybeT $ MaybeT (getOutput hm op) <|> MaybeT (getOutput 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 +getUnspentI :: MonadIO m => ImportDB -> OutPoint -> m (Maybe Unspent)+getUnspentI ImportDB { importRocksDB = (db, opts)+ , importHashMap = hm+ , importUnspentMap = um+ } p =+ runMaybeT $+ MaybeT (getUnspent hm p) <|>+ MaybeT (getUnspent um p) <|>+ MaybeT (getUnspentDB db opts p)+ instance MonadIO m => StoreRead ImportDB m where isInitialized = isInitializedI getBestBlock = getBestBlockI getBlocksAtHeight = getBlocksAtHeightI getBlock = getBlockI getTransaction = getTransactionI+ getOutput = getOutputI getBalance = getBalanceI instance MonadIO m => StoreWrite ImportDB m where@@ -174,6 +217,7 @@ 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 insertAddrTx ImportDB {importHashMap = hm} = insertAddrTx hm removeAddrTx ImportDB {importHashMap = hm} = removeAddrTx hm@@ -181,3 +225,9 @@ removeAddrUnspent ImportDB {importHashMap = hm} = removeAddrUnspent hm insertMempoolTx ImportDB {importHashMap = hm} = insertMempoolTx hm deleteMempoolTx ImportDB {importHashMap = hm} = deleteMempoolTx hm++instance MonadIO m => UnspentStore ImportDB m where+ addUnspent ImportDB {importHashMap = hm, importUnspentMap = um} u =+ addUnspent hm u >> addUnspent um u+ delUnspent ImportDB {importHashMap = hm} = delUnspent hm+ getUnspent = getUnspentI
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -113,23 +113,59 @@ instance KeyValue TxKey Transaction +data OutputKey+ = OutputKey { outputPoint :: !OutPoint }+ | OutputKeyS { outputKeyS :: !TxHash }+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize OutputKey where+ -- 0x10 · TxHash · Index+ put (OutputKey OutPoint {outPointHash = h, outPointIndex = i}) = do+ putWord8 0x10+ put h+ put i+ put (OutputKeyS h) = do+ putWord8 0x10+ put h+ get = do+ guard . (== 0x10) =<< getWord8+ op <- OutPoint <$> get <*> get+ return $ OutputKey op++instance Key OutputKey++instance KeyValue OutputKey Output+ -- | Unspent output database key.-newtype UnspentKey- = UnspentKey { unspentKey :: OutPoint }+data UnspentKey+ = UnspentKey { unspentKey :: !OutPoint }+ | UnspentKeyS { unspentKeyS :: !TxHash } deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize UnspentKey where- -- 0x09 · OutPoint- put UnspentKey {unspentKey = k} = do+ -- 0x09 · TxHash · Index+ put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do putWord8 0x09- put k+ put h+ put i+ put UnspentKeyS {unspentKeyS = t} = do+ putWord8 0x09+ put t get = do guard . (== 0x09) =<< getWord8- UnspentKey <$> get+ h <- get+ i <- get+ return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i} +data UnspentVal = UnspentVal+ { unspentValBlock :: !BlockRef+ , unspentValAmount :: !Word64+ , unspentValScript :: !ByteString+ } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)+ instance Key UnspentKey -instance KeyValue UnspentKey OutVal+instance KeyValue UnspentKey UnspentVal -- | Mempool transaction database key. data MemKey
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -7,6 +7,8 @@ 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.Word import Database.RocksDB (DB, ReadOptions)@@ -17,7 +19,7 @@ import UnliftIO dataVersion :: Word32-dataVersion = 5+dataVersion = 6 data ExceptRocksDB = MempoolTxNotFound@@ -46,8 +48,18 @@ getTransactionDB :: MonadIO m => DB -> ReadOptions -> TxHash -> m (Maybe Transaction)-getTransactionDB db opts th = retrieve db opts (TxKey th)+getTransactionDB db opts th = runMaybeT $ do+ tx <- MaybeT $ retrieve db opts (TxKey th)+ outs <- lift $ getOutputsDB db opts th+ return tx {transactionOutputs = outs} +getOutputDB :: MonadIO m => DB -> ReadOptions -> OutPoint -> m (Maybe Output)+getOutputDB db opts = retrieve db opts . OutputKey++getOutputsDB :: MonadIO m => DB -> ReadOptions -> TxHash -> m [Output]+getOutputsDB db opts th =+ map snd <$> liftIO (matchingAsList db opts (OutputKeyS th))+ getBalanceDB :: MonadIO m => DB -> ReadOptions -> Address -> m (Maybe Balance) getBalanceDB db opts a = fmap f <$> retrieve db opts (BalKey a) where@@ -67,7 +79,7 @@ getMempoolDB db opts = matching db opts MemKeyS .| mapC (uncurry f) where f (MemKey u t) () = (u, t)- f _ _ = undefined+ f _ _ = undefined getAddressTxsDB :: (MonadIO m, MonadResource m)@@ -99,17 +111,29 @@ Unspent { unspentBlock = b , unspentAmount = v- , unspentScript = s+ , unspentScript = B.Short.toShort s , unspentPoint = p } f _ _ = undefined +getUnspentDB :: MonadIO m => DB -> ReadOptions -> OutPoint -> m (Maybe Unspent)+getUnspentDB db opts op = fmap f <$> retrieve db opts (UnspentKey op)+ where+ f u =+ Unspent+ { unspentBlock = unspentValBlock u+ , unspentPoint = op+ , unspentAmount = unspentValAmount u+ , unspentScript = B.Short.toShort (unspentValScript u)+ }+ instance MonadIO m => StoreRead (DB, ReadOptions) m where isInitialized (db, opts) = isInitializedDB db opts 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 =
src/Network/Haskoin/Store/Logic.hs view
@@ -7,6 +7,10 @@ import Control.Monad import Control.Monad.Except 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@@ -14,25 +18,23 @@ import Database.RocksDB import Haskoin import Network.Haskoin.Store.Data+import Network.Haskoin.Store.Data.HashMap import Network.Haskoin.Store.Data.ImportDB import UnliftIO data ImportException = PrevBlockNotBest !BlockHash+ | UnconfirmedCoinbase !TxHash | BestBlockUnknown | BestBlockNotFound !BlockHash | BlockNotBest !BlockHash+ | OrphanTx !TxHash | TxNotFound !TxHash- | DuplicateTx !TxHash+ | NoUnspent !OutPoint | TxDeleted !TxHash | TxDoubleSpend !TxHash- | TxOutputsSpent !TxHash | TxConfirmed !TxHash | OutputOutOfRange !OutPoint- | OutputAlreadyUnspent !OutPoint- | OutputAlreadySpent !OutPoint- | OutputDoesNotExist !OutPoint- | BalanceNotFound !Address | InsufficientBalance !Address | InsufficientOutputs !Address | InsufficientFunds !TxHash@@ -40,9 +42,14 @@ | DuplicatePrevOutput !TxHash deriving (Show, Read, Eq, Ord, Exception) -initDB :: (MonadIO m, MonadError ImportException m) => Network -> DB -> m ()-initDB net db =- runImportDB db $ \i ->+initDB ::+ (MonadIO m, MonadError ImportException m)+ => Network+ -> DB+ -> TVar UnspentMap+ -> m ()+initDB net db um =+ runImportDB db um $ \i -> isInitialized i >>= \case Left e -> throwError (InitException e) Right True -> return ()@@ -51,7 +58,11 @@ setInit i newMempoolTx ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => Network -> i -> Tx@@ -59,7 +70,7 @@ -> m () newMempoolTx net i tx now = getTransaction i (txHash tx) >>= \case- Just x | not (transactionDeleted x) -> throwError (DuplicateTx (txHash tx))+ Just x | not (transactionDeleted x) -> return () _ -> go where go = do@@ -94,13 +105,18 @@ (MonadError ImportException m, MonadIO m) => Network -> DB+ -> TVar UnspentMap -> Block -> BlockNode -> m ()-newBlock net db b n = runImportDB db $ \i -> importBlock net i b n+newBlock net db um b n = runImportDB db um $ \i -> importBlock net i b n revertBlock ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => i -> BlockHash -> m ()@@ -119,7 +135,7 @@ insertBlock i bd {blockDataMainChain = False} importBlock ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ (MonadError ImportException m, StoreRead i m, StoreWrite i m, UnspentStore i m) => Network -> i -> Block@@ -151,78 +167,88 @@ zipWithM_ (\x t -> importTx i (br x) t) [0 ..] (blockTxns b) forM_ txs $ \tr -> do let tx = transactionData tr- when (tx `notElem` blockTxns b) $+ th = txHash tx+ when (th `notElem` hs) $ case transactionBlock tr of- MemRef t -> newMempoolTx net i tx t+ MemRef t -> newMempoolTx net i tx t BlockRef {} -> throwError (TxConfirmed (txHash tx)) where+ hs = map txHash (blockTxns b) br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos} importTx :: ( MonadError ImportException m , StoreRead i m , StoreWrite i m+ , UnspentStore i m ) => i -> BlockRef -> Tx -> m ()-importTx i br tx =- getTransaction i th >>= \case- Just t- | not (transactionDeleted t) -> return ()- | otherwise -> go- Nothing -> go+importTx i br tx = do+ when (length (nub (map prevOutput (txIn tx))) < length (txIn 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)) $+ throwError (UnconfirmedCoinbase (txHash tx))+ unless iscb $ do+ when (sum (map unspentAmount us) < sum (map outValue (txOut tx))) $+ throwError (InsufficientFunds th)+ zipWithM_+ (spendOutput i br (txHash tx))+ [0 ..]+ us+ zipWithM_ (newOutput i br (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) where th = txHash tx- go = do- when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $- throwError (DuplicatePrevOutput (txHash tx))- us <-- if iscb- then return []- else forM (txIn tx) $ \TxIn {prevOutput = op} ->- getImportTx i (outPointHash op) >>=- getTxOutput (outPointIndex op)- unless iscb $ do- when (sum (map outputAmount us) < sum (map outValue (txOut tx))) $- throwError (InsufficientFunds th)- when (confirmed br && any (isJust . outputSpender) us) $ do- let ds = map spenderHash (mapMaybe outputSpender us)- mapM_ (deleteTx i False) ds- when (not (confirmed br) && any (isJust . outputSpender) us) $- throwError (TxDoubleSpend th)- zipWithM_- (spendOutput i br (txHash tx))- [0 ..]- (map prevOutput (txIn tx))- zipWithM_ (insertOutput i br (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) iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) fee us = if iscb then 0- else sum (map outputAmount us) - sum (map outValue (txOut tx))+ else sum (map unspentAmount us) - sum (map outValue (txOut tx)) ws = map Just (txWitness tx) <> repeat Nothing getrbf | iscb = return False | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True+ | confirmed br = return False | otherwise = let hs = nub $ map (outPointHash . prevOutput) (txIn tx) in fmap or . forM hs $ \h ->@@ -244,8 +270,8 @@ { inputPoint = prevOutput ip , inputSequence = txInSequence ip , inputSigScript = scriptInput ip- , inputPkScript = outputScript u- , inputAmount = outputAmount u+ , inputPkScript = B.Short.fromShort (unspentScript u)+ , inputAmount = unspentAmount u , inputWitness = w } mkout o =@@ -268,7 +294,11 @@ concat <$> mapM (getRecursiveTx i) ss deleteTx ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => i -> Bool -- ^ only delete transaction if unconfirmed -> TxHash@@ -287,7 +317,7 @@ forM_ (mapMaybe outputSpender (transactionOutputs t)) $ \s -> deleteTx i False (spenderHash s) forM_ (take (length (transactionOutputs t)) [0 ..]) $ \n ->- deleteOutput i (OutPoint h 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)) $@@ -347,15 +377,20 @@ , outputSpender = Nothing } -insertOutput ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+newOutput ::+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => i -> BlockRef -> TxHash -> Word32 -> TxOut -> m ()-insertOutput i tb th ix to =+newOutput i tb th ix to = do+ addUnspent i u case scriptToAddressBS (scriptOutput to) of Left _ -> return () Right a -> do@@ -373,18 +408,23 @@ Unspent { unspentBlock = tb , unspentAmount = outValue to- , unspentScript = scriptOutput to+ , unspentScript = B.Short.toShort (scriptOutput to) , unspentPoint = OutPoint th ix } -deleteOutput ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+delOutput ::+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => i -> OutPoint -> m ()-deleteOutput i op = do+delOutput i op = do t <- getImportTx i (outPointHash op) u <- getTxOutput (outPointIndex op) t+ delUnspent i op case scriptToAddressBS (outputScript u) of Left _ -> return () Right a -> do@@ -392,7 +432,7 @@ i a Unspent- { unspentScript = outputScript u+ { unspentScript = B.Short.toShort (outputScript u) , unspentBlock = transactionBlock t , unspentPoint = op , unspentAmount = outputAmount u@@ -433,33 +473,32 @@ return $ transactionOutputs tx !! fromIntegral i spendOutput ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => i -> BlockRef -> TxHash -> Word32- -> OutPoint+ -> Unspent -> m ()-spendOutput i tb th ix op = do- tx <- getImportTx i (outPointHash op)- out <- getTxOutput (outPointIndex op) tx- when (isJust (outputSpender out)) $ throwError (OutputAlreadySpent op)- insertTx+spendOutput i tb th ix u = do+ insertOutput i- tx {transactionOutputs = zipWith f [0 ..] (transactionOutputs tx)}- case scriptToAddressBS (outputScript out) of+ (unspentPoint u)+ Output+ { outputAmount = unspentAmount u+ , outputScript = B.Short.fromShort (unspentScript u)+ , outputSpender = Just Spender {spenderHash = th, spenderIndex = ix}+ }+ delUnspent i (unspentPoint u)+ case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of Left _ -> return () Right a -> do- removeAddrUnspent- i- a- Unspent- { unspentScript = outputScript out- , unspentAmount = outputAmount out- , unspentBlock = transactionBlock tx- , unspentPoint = op- }- reduceBalance i (confirmed tb) a (outputAmount out)+ removeAddrUnspent i a u+ reduceBalance i (confirmed tb) a (unspentAmount u) insertAddrTx i AddressTx@@ -467,13 +506,13 @@ , addressTxHash = th , addressTxBlock = tb }- where- f n o- | n == outPointIndex op = o {outputSpender = Just (Spender th ix)}- | otherwise = o unspendOutput ::- (MonadError ImportException m, StoreRead i m, StoreWrite i m)+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , UnspentStore i m+ ) => i -> OutPoint -> BlockRef@@ -481,22 +520,23 @@ unspendOutput i op br = do tx <- getImportTx i (outPointHash op) out <- getTxOutput (outPointIndex op) tx- when (isNothing (outputSpender out)) $ throwError (OutputAlreadyUnspent op)- insertTx- i- tx {transactionOutputs = zipWith f [0 ..] (transactionOutputs tx)}- let u =- Unspent- { unspentAmount = outputAmount out- , unspentBlock = transactionBlock tx- , unspentScript = outputScript out- , unspentPoint = op- }- case scriptToAddressBS (outputScript out) of- Left _ -> return ()- Right a -> do- insertAddrUnspent i a u- increaseBalance i (confirmed br) a (outputAmount out)+ 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+ }+ 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}@@ -553,3 +593,14 @@ { 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