haskoin-store 0.6.9 → 0.7.0
raw patch · 11 files changed
+463/−213 lines, 11 files
Files
- CHANGELOG.md +20/−0
- README.md +7/−0
- app/Main.hs +73/−14
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +51/−57
- src/Network/Haskoin/Store/Data.hs +60/−16
- src/Network/Haskoin/Store/Data/HashMap.hs +57/−39
- src/Network/Haskoin/Store/Data/ImportDB.hs +13/−16
- src/Network/Haskoin/Store/Data/KeyValue.hs +44/−10
- src/Network/Haskoin/Store/Data/RocksDB.hs +33/−16
- src/Network/Haskoin/Store/Logic.hs +103/−43
CHANGELOG.md view
@@ -4,6 +4,26 @@ 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.8.0+### Added+- Limits and skips.+- Add timestamps to transactions.+- Add transaction count to address balance object.+- Add Merkle root to block data.++### Changed+- Data model update.+- Performance improvement for xpub calls.++## 0.7.0+### Added+- Total funds received by an address now shows up in balance.+- Balances for any address that ever had funds show up in xpub endpoints.++### Changed+- Transactions are returned in reverse mempool/block order (highest or most recent first).+- Balance objects do not get deleted from database ever.+ ## 0.6.9 ### Changed - Reduce number of coinbase checks to 10,000 ancestors.
README.md view
@@ -25,3 +25,10 @@ ## API Documentation * [Swagger API Documentation](https://btc.haskoin.com/).++## Notes++### Transaction Ordering+Transactions are returned in reverse blockchain or mempool order, meaning that the latest transactions are shown first, starting from the mempool and then from the highest block in the blockchain. If many transactions are returned from the same block, they are in reverse order as they appear in the block, meaning the latest transaction in the block comes first.++After the November 2018 hard fork Bitcoin Cash transactions are not stored in a block in topological order. If multiple transactions in one block depend on each other, they may appear in the "wrong" order. This is intentional and does not need to be fixed.
app/Main.hs view
@@ -257,11 +257,22 @@ S.json res S.get "/mempool" $ do setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits+ mpu <-+ case mbr of+ Just BlockRef {} ->+ raise $+ UserError "mempool transactions do not have height"+ Just (MemRef t) -> return $ Just t+ Nothing -> return Nothing stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $- getMempool (db, defaultReadOptions {useSnapshot = Just s}) .|+ getMempool+ (db, defaultReadOptions {useSnapshot = Just s})+ mpu .| mapC snd .|+ apply_limit mlimit .| jsonListConduit toEncoding .| streamConduit io >> liftIO flush'@@ -288,8 +299,8 @@ height <- param "height" res <- withSnapshot db $ \s -> do- let d = (db, defaultReadOptions {useSnapshot = Just s})- cbAfterHeight d 10000 height txid+ let d = (db, defaultReadOptions {useSnapshot = Just s})+ cbAfterHeight d 10000 height txid S.json $ object ["result" .= res] S.get "/transactions" $ do txids <- param "txids"@@ -308,54 +319,73 @@ S.get "/address/:address/transactions" $ do address <- parse_address setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits+ liftIO $ print (mlimit, mbr) stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $ getAddressTxs (db, defaultReadOptions {useSnapshot = Just s})- address .|+ address+ mbr .|+ apply_limit mlimit .| jsonListConduit (addressTxToEncoding net) .| streamConduit io >> liftIO flush' S.get "/address/transactions" $ do addresses <- parse_addresses setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $ mergeSourcesBy (compare `on` addressTxBlock)- (map (getAddressTxs- ( db- , defaultReadOptions {useSnapshot = Just s}))+ (map (\a ->+ getAddressTxs+ ( db+ , defaultReadOptions+ {useSnapshot = Just s})+ a+ mbr) addresses) .|+ apply_limit mlimit .| jsonListConduit (addressTxToEncoding net) .| streamConduit io >> liftIO flush' S.get "/address/:address/unspent" $ do address <- parse_address setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $ getAddressUnspents (db, defaultReadOptions {useSnapshot = Just s})- address .|+ address+ mbr .|+ apply_limit mlimit .| jsonListConduit (unspentToEncoding net) .| streamConduit io >> liftIO flush' S.get "/address/unspent" $ do addresses <- parse_addresses setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $ mergeSourcesBy (compare `on` unspentBlock)- (map (getAddressUnspents- ( db- , defaultReadOptions {useSnapshot = Just s}))+ (map (\a ->+ getAddressUnspents+ ( db+ , defaultReadOptions+ {useSnapshot = Just s})+ a+ mbr) addresses) .|+ apply_limit mlimit .| jsonListConduit (unspentToEncoding net) .| streamConduit io >> liftIO flush'@@ -371,8 +401,10 @@ Balance { balanceAddress = address , balanceAmount = 0- , balanceCount = 0+ , balanceUnspentCount = 0 , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0 } S.json $ balanceToJSON net res S.get "/address/balances" $ do@@ -384,8 +416,10 @@ Balance { balanceAddress = a , balanceAmount = 0- , balanceCount = 0+ , balanceUnspentCount = 0 , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0 } f _ (Just b) = b mapM (\a -> f a <$> getBalance d a) addresses@@ -400,22 +434,30 @@ S.get "/xpub/:xpub/transactions" $ do xpub <- parse_xpub setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $- xpubTxs (db, defaultReadOptions {useSnapshot = Just s}) xpub .|+ xpubTxs+ (db, defaultReadOptions {useSnapshot = Just s})+ mbr+ xpub .|+ apply_limit mlimit .| jsonListConduit (xPubTxToEncoding net) .| streamConduit io >> liftIO flush' S.get "/xpub/:xpub/unspent" $ do xpub <- parse_xpub setHeader "Content-Type" "application/json"+ (mlimit, mbr) <- parse_limits stream $ \io flush' -> withSnapshot db $ \s -> runResourceT . runConduit $ xpubUnspent (db, defaultReadOptions {useSnapshot = Just s})+ mbr xpub .|+ apply_limit mlimit .| jsonListConduit (xPubUnspentToEncoding net) .| streamConduit io >> liftIO flush'@@ -456,6 +498,23 @@ S.get "/peers" $ getPeersInformation (storeManager st) >>= S.json notFound $ raise ThingNotFound where+ parse_limits = do+ let b = do+ height <- param "height"+ pos <- param "pos" `rescue` const (return maxBound)+ return $ BlockRef height pos+ m = do+ time <- param "time"+ return $ MemRef (PreciseUnixTime time)+ mlimit <- fmap Just (param "limit") `rescue` const (return Nothing)+ case mlimit of+ Just l+ | l < 0 -> raise $ UserError "limit cannot be negative"+ _ -> return ()+ mbr <- Just <$> b <|> Just <$> m <|> return Nothing+ return (mlimit, mbr)+ apply_limit Nothing = mapC id+ apply_limit (Just l) = takeC l parse_address = do address <- param "address" case stringToAddr net address of
haskoin-store.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3b2c66acf9e4bbe87c2b291dc99c916edc43bac8bd65fe11da48a82bc56b727e+-- hash: e10497cea596a6a9304272b26538e801e27583b99503f75d7fdde1185d3bd2ea name: haskoin-store-version: 0.6.9+version: 0.7.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
@@ -22,6 +22,7 @@ , XPubUnspent(..) , Balance(..) , PeerInformation(..)+ , PreciseUnixTime(..) , withStore , store , getBestBlock@@ -207,64 +208,53 @@ , peerRelay = rl } -xpubAddrs ::- (Monad m, StoreStream i m)- => i- -> XPubKey- -> m [(Address, SoftPath)]-xpubAddrs i k = (<>) <$> go 0 0 <*> go 1 0+xpubBals :: (Monad m, BalanceRead i m) => i -> XPubKey -> m [XPubBal]+xpubBals i xpub = (<>) <$> go 0 0 <*> go 1 0 where+ g = getBalance i go m n = do- let g a = not <$> runConduit (getAddressTxs i a .| nullC)- t <- or <$> mapM (g . fst) (as m n)- if t- then (as m n <>) <$> go m (n + 100)- else return []+ xs <- catMaybes <$> mapM (uncurry b) (as m n)+ case xs of+ [] -> return []+ _ -> (xs <>) <$> go m (n + 100)+ b a p =+ g a >>= \case+ Nothing -> return Nothing+ Just b' -> return $ Just XPubBal {xPubBalPath = p, xPubBal = b'} as m n = map- (\(a, _, n') -> (a, Deriv :/ m :/ n'))- (take 100 (deriveAddrs (pubSubKey k m) n))+ (\(a, _, n') -> (a, [m, n']))+ (take 100 (deriveAddrs (pubSubKey xpub m) n)) xpubTxs ::- (Monad m, StoreStream i m)+ (Monad m, BalanceRead i m, StoreStream i m) => i+ -> Maybe BlockRef -> XPubKey -> ConduitT () XPubTx m ()-xpubTxs i xpub = do- as <- lift $ xpubAddrs i xpub- let cds = map (uncurry cnd) as- mergeSourcesBy (compare `on` (addressTxBlock . xPubTx)) cds+xpubTxs i mbr xpub = do+ bals <- lift $ xpubBals i xpub+ xs <-+ forM bals $ \XPubBal {xPubBalPath = p, xPubBal = b} ->+ return $ getAddressTxs i (balanceAddress b) mbr .| mapC (f p)+ mergeSourcesBy (flip compare `on` (addressTxBlock . xPubTx)) xs where- cnd a p = getAddressTxs i a .| mapC (f p)- f p t = XPubTx {xPubTxPath = pathToList p, xPubTx = t}--xpubBals ::- (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 >>= \case- Nothing -> return Nothing- Just b ->- return $ Just XPubBal {xPubBalPath = pathToList p, xPubBal = b}+ f p t = XPubTx {xPubTxPath = p, xPubTx = t} xpubUnspent ::- (Monad m, StoreStream i m, StoreRead i m)+ (Monad m, StoreStream i m, BalanceRead i m, StoreRead i m) => i+ -> Maybe BlockRef -> XPubKey -> ConduitT () XPubUnspent m ()-xpubUnspent i xpub = do- as <- lift $ xpubAddrs i xpub- let cds = map (uncurry cnd) as- mergeSourcesBy (compare `on` (unspentBlock . xPubUnspent)) cds+xpubUnspent i mbr xpub = do+ bals <- lift $ xpubBals i xpub+ xs <-+ forM bals $ \XPubBal {xPubBalPath = p, xPubBal = b} ->+ return $ getAddressUnspents i (balanceAddress b) mbr .| mapC (f p)+ mergeSourcesBy (flip compare `on` (unspentBlock . xPubUnspent)) xs where- cnd a p = getAddressUnspents i a .| mapC (f p)- f p t =- XPubUnspent- {xPubUnspentPath = pathToList p, xPubUnspent = t}+ f p t = XPubUnspent {xPubUnspentPath = p, xPubUnspent = t} -- | Check if any of the ancestors of this transaction is a coinbase after the -- specified height. Returns 'Nothing' if answer cannot be computed before@@ -272,25 +262,29 @@ cbAfterHeight :: (Monad m, StoreRead i m) => i- -> Int+ -> Int -- ^ how many ancestors to test before giving up -> BlockHeight -> TxHash -> m (Maybe Bool)-cbAfterHeight _ 0 _ _ = return Nothing-cbAfterHeight i d h t = runMaybeT $ snd <$> tst d t+cbAfterHeight i d h t+ | d <= 0 = return Nothing+ | otherwise = runMaybeT $ snd <$> tst d t where- tst 0 _ = MaybeT $ return Nothing- tst e x = do- let e' = e - 1- tx <- MaybeT $ getTransaction i x- if any isCoinbase (transactionInputs tx)- then return (e', blockRefHeight (transactionBlock tx) > h)- else case transactionBlock tx of- BlockRef {blockRefHeight = b}- | b <= h -> return (e', False)- _ ->- r e' . nub $- map (outPointHash . inputPoint) (transactionInputs tx)+ tst e x+ | e <= 0 = MaybeT $ return Nothing+ | otherwise = do+ let e' = e - 1+ tx <- MaybeT $ getTransaction i x+ if any isCoinbase (transactionInputs tx)+ then return (e', blockRefHeight (transactionBlock tx) > h)+ else case transactionBlock tx of+ BlockRef {blockRefHeight = b}+ | b <= h -> return (e', False)+ _ ->+ r e' . nub $+ map+ (outPointHash . inputPoint)+ (transactionInputs tx) r e [] = return (e, False) r e (n:ns) = do (e', s) <- tst e n
src/Network/Haskoin/Store/Data.hs view
@@ -5,6 +5,8 @@ module Network.Haskoin.Store.Data where import Conduit+import Control.Applicative+import Control.Monad import Control.Monad.Trans.Maybe import Data.Aeson as A import Data.ByteString (ByteString)@@ -64,9 +66,14 @@ return $ toTransaction d sm class StoreStream r m where- getMempool :: r -> ConduitT () (PreciseUnixTime, TxHash) m ()- getAddressUnspents :: r -> Address -> ConduitT () Unspent m ()- getAddressTxs :: r -> Address -> ConduitT () AddressTx m ()+ getMempool ::+ r+ -> Maybe PreciseUnixTime+ -> ConduitT () (PreciseUnixTime, TxHash) m ()+ getAddressUnspents ::+ r -> Address -> Maybe BlockRef -> ConduitT () Unspent m ()+ getAddressTxs ::+ r -> Address -> Maybe BlockRef -> ConduitT () AddressTx m () class StoreWrite w m where setInit :: w -> m ()@@ -83,10 +90,15 @@ insertMempoolTx :: w -> TxHash -> PreciseUnixTime -> m () deleteMempoolTx :: w -> TxHash -> PreciseUnixTime -> m () --- | Unix time with nanosecond precision for mempool transactions+-- | Unix time with nanosecond precision for mempool transactions. newtype PreciseUnixTime = PreciseUnixTime Word64- deriving (Show, Eq, Read, Generic, Ord, Hashable, Serialize)+ deriving (Show, Eq, Read, Generic, Ord, Hashable) +-- | Serialize such that ordering is inverted.+instance Serialize PreciseUnixTime where+ put (PreciseUnixTime w) = putWord64be $ maxBound - w+ get = PreciseUnixTime . (maxBound -) <$> getWord64be+ preciseUnixTime :: SystemTime -> PreciseUnixTime preciseUnixTime s = PreciseUnixTime . fromIntegral $@@ -105,8 +117,29 @@ -- ^ position of transaction within the block } | MemRef { memRefTime :: !PreciseUnixTime }- deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)+ deriving (Show, Read, Eq, Ord, Generic, Hashable) +-- | Serialized entities will sort in reverse order.+instance Serialize BlockRef where+ put MemRef {memRefTime = t} = do+ putWord8 0x00+ put t+ put BlockRef {blockRefHeight = h, blockRefPos = p} = do+ putWord8 0x01+ putWord32be (maxBound - h)+ putWord32be (maxBound - p)+ get = getmemref <|> getblockref+ where+ getmemref = do+ guard . (== 0x00) =<< getWord8+ w <- (maxBound -) <$> getWord64be+ return MemRef {memRefTime = PreciseUnixTime w}+ getblockref = do+ guard . (== 0x01) =<< getWord8+ h <- (maxBound -) <$> getWord32be+ p <- (maxBound -) <$> getWord32be+ return BlockRef {blockRefHeight = h, blockRefPos = p}+ -- | JSON serialization for 'BlockRef'. blockRefPairs :: A.KeyValue kv => BlockRef -> [kv] blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} =@@ -147,14 +180,18 @@ -- | Address balance information. data Balance = Balance- { balanceAddress :: !Address+ { balanceAddress :: !Address -- ^ address balance- , balanceAmount :: !Word64+ , balanceAmount :: !Word64 -- ^ confirmed balance- , balanceZero :: !Word64+ , balanceZero :: !Word64 -- ^ unconfirmed balance- , balanceCount :: !Word64+ , balanceUnspentCount :: !Word64 -- ^ number of unspent outputs+ , balanceTxCount :: !Word64+ -- ^ number of transactions+ , balanceTotalReceived :: !Word64+ -- ^ total amount from all outputs in this address } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) -- | JSON serialization for 'Balance'.@@ -163,7 +200,9 @@ [ "address" .= addrToJSON net (balanceAddress ab) , "confirmed" .= balanceAmount ab , "unconfirmed" .= balanceZero ab- , "utxo" .= balanceCount ab+ , "utxo" .= balanceUnspentCount ab+ , "txs" .= balanceTxCount ab+ , "received" .= balanceTotalReceived ab ] balanceToJSON :: Network -> Balance -> Value@@ -242,6 +281,7 @@ , "nonce" .= bhNonce (blockDataHeader bv) , "size" .= blockDataSize bv , "tx" .= blockDataTxs bv+ , "merkle" .= TxHash (buildMerkleRoot (blockDataTxs bv)) ] instance ToJSON BlockData where@@ -403,7 +443,8 @@ , txData :: !Tx , txDataPrevs :: !(IntMap Prev) , txDataDeleted :: !Bool- , txDataRBF :: Bool+ , txDataRBF :: !Bool+ , txDataTime :: !Word64 } deriving (Show, Eq, Ord, Generic, Serialize) toTransaction :: TxData -> IntMap Spender -> Transaction@@ -416,6 +457,7 @@ , transactionOutputs = outs , transactionDeleted = txDataDeleted t , transactionRBF = txDataRBF t+ , transactionTime = txDataTime t } where ws =@@ -436,6 +478,7 @@ , txDataPrevs = ps , txDataDeleted = transactionDeleted t , txDataRBF = transactionRBF t+ , txDataTime = transactionTime t } f _ Coinbase {} = Nothing f n Input {inputPkScript = s, inputAmount = v} =@@ -461,6 +504,8 @@ -- ^ this transaction has been deleted and is no longer valid , transactionRBF :: !Bool -- ^ this transaction can be replaced in the mempool+ , transactionTime :: !Word64+ -- ^ time the transaction was first seen or time of block } deriving (Show, Eq, Ord, Generic, Hashable, Serialize) transactionData :: Transaction -> Tx@@ -492,12 +537,11 @@ 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)+ , "inputs" .= map (object . inputPairs net) (transactionInputs dtx)+ , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx) , "block" .= transactionBlock dtx , "deleted" .= transactionDeleted dtx+ , "time" .= transactionTime dtx ] ++ ["rbf" .= transactionRBF dtx | getReplaceByFee net]
src/Network/Haskoin/Store/Data/HashMap.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.HashMap where @@ -30,7 +31,7 @@ , hTx :: !(HashMap TxHash TxData) , hSpender :: !(HashMap TxHash (IntMap (Maybe Spender))) , hUnspent :: !(HashMap TxHash (IntMap (Maybe Unspent)))- , hBalance :: !(HashMap Address (Maybe BalVal))+ , hBalance :: !(HashMap Address BalVal) , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))) , hMempool :: !(HashMap PreciseUnixTime (HashMap TxHash Bool))@@ -77,35 +78,58 @@ 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)+getBalanceH :: HashMapDB -> Address -> Maybe Balance+getBalanceH db a = f <$> M.lookup a (hBalance db) where f b = Balance { balanceAddress = a , balanceAmount = balValAmount b , balanceZero = balValZero b- , balanceCount = balValCount b+ , balanceUnspentCount = balValUnspentCount b+ , balanceTxCount = balValTxCount b+ , balanceTotalReceived = balValTotalReceived b } -getMempoolH :: HashMapDB -> HashMap PreciseUnixTime (HashMap TxHash Bool)-getMempoolH = hMempool+getMempoolH ::+ Monad m+ => HashMapDB+ -> Maybe PreciseUnixTime+ -> ConduitT () (PreciseUnixTime, TxHash) m ()+getMempoolH db mpu =+ let f ts =+ case mpu of+ Nothing -> False+ Just pu -> ts > pu+ ls =+ dropWhile (f . fst) .+ sortBy (flip compare) . M.toList . M.map (M.keys . M.filter id) $+ hMempool db+ in yieldMany [(u, h) | (u, hs) <- ls, h <- hs] -getAddressTxsH :: HashMapDB -> Address -> [Maybe AddressTx]-getAddressTxsH db a =- concatMap (uncurry f) . M.toList $ M.lookupDefault M.empty a (hAddrTx db)+getAddressTxsH :: HashMapDB -> Address -> Maybe BlockRef -> [AddressTx]+getAddressTxsH db a mbr =+ dropWhile h .+ sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $+ M.lookupDefault M.empty a (hAddrTx db) where f b hm = map (uncurry (g b)) $ M.toList hm- g b h True =+ g b h' True = Just AddressTx- {addressTxAddress = a, addressTxBlock = b, addressTxHash = h}+ {addressTxAddress = a, addressTxBlock = b, addressTxHash = h'} g _ _ False = Nothing+ h AddressTx {addressTxBlock = b} =+ case mbr of+ Nothing -> False+ Just br -> b > br getAddressUnspentsH ::- HashMapDB -> Address -> [Maybe Unspent]-getAddressUnspentsH db a =- concatMap (uncurry f) . M.toList $ M.lookupDefault M.empty a (hAddrOut db)+ HashMapDB -> Address -> Maybe BlockRef -> [Unspent]+getAddressUnspentsH db a mbr =+ dropWhile h .+ sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $+ M.lookupDefault M.empty a (hAddrOut db) where f b hm = map (uncurry (g b)) $ M.toList hm g b p (Just u) =@@ -117,6 +141,10 @@ , unspentPoint = p } g _ _ Nothing = Nothing+ h Unspent {unspentBlock = b} =+ case mbr of+ Nothing -> False+ Just br -> b > br setInitH :: HashMapDB -> HashMapDB setInitH db = db {hInit = True}@@ -161,14 +189,13 @@ setBalanceH :: Balance -> HashMapDB -> HashMapDB setBalanceH b db = db {hBalance = M.insert (balanceAddress b) x (hBalance db)} where- x- | balanceCount b == 0 = Nothing- | otherwise =- Just+ x = BalVal { balValAmount = balanceAmount b , balValZero = balanceZero b- , balValCount = balanceCount b+ , balValUnspentCount = balanceUnspentCount b+ , balValTxCount = balanceTxCount b+ , balValTotalReceived = balanceTotalReceived b } insertAddrTxH :: AddressTx -> HashMapDB -> HashMapDB@@ -265,18 +292,15 @@ getSpender db = pure . join . getSpenderH db instance Applicative m => BalanceRead HashMapDB m where- getBalance db = pure . join . getBalanceH db+ getBalance db = pure . 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- in yieldMany [(u, h) | (u, hs) <- ls, h <- hs]- getAddressTxs db = yieldMany . sort . catMaybes . getAddressTxsH db- getAddressUnspents db =- yieldMany . sort . catMaybes . getAddressUnspentsH db+ getMempool = getMempoolH+ getAddressUnspents db a = yieldMany . getAddressUnspentsH db a+ getAddressTxs db a = yieldMany . getAddressTxsH db a instance MonadIO m => StoreRead (TVar HashMapDB) m where isInitialized v = readTVarIO v >>= isInitialized@@ -298,9 +322,9 @@ 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- getAddressUnspents v a = readTVarIO v >>= \db -> getAddressUnspents db a+ getMempool v m = readTVarIO v >>= \db -> getMempool db m+ getAddressTxs v a m = readTVarIO v >>= \db -> getAddressTxs db a m+ getAddressUnspents v a m = readTVarIO v >>= \db -> getAddressUnspents db a m instance StoreWrite ((HashMapDB -> HashMapDB) -> m ()) m where setInit f = f setInitH@@ -386,12 +410,9 @@ 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')+ 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@@ -400,10 +421,7 @@ in (m', s') else (m, s) where- g m a =- case M.lookup a m of- Nothing -> Nothing- Just b -> Just (a, b)+ g m a = (a, ) <$> M.lookup a m instance MonadIO m => BalanceWrite (TVar BalanceMap) m where setBalance v = atomically . setBalance (modifyTVar v)
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -72,19 +72,19 @@ bestBlockOp (Just b) = [insertOp BestKey b] blockHashOps :: HashMap BlockHash BlockData -> [BatchOp]-blockHashOps = map f . M.toList+blockHashOps = map (uncurry f) . M.toList where- f (h, d) = insertOp (BlockKey h) d+ f = insertOp . BlockKey blockHeightOps :: HashMap BlockHeight [BlockHash] -> [BatchOp]-blockHeightOps = map f . M.toList+blockHeightOps = map (uncurry f) . M.toList where- f (g, ls) = insertOp (HeightKey g) ls+ f = insertOp . HeightKey txOps :: HashMap TxHash TxData -> [BatchOp]-txOps = map f . M.toList+txOps = map (uncurry f) . M.toList where- f (h, t) = insertOp (TxKey h) t+ f = insertOp . TxKey spenderOps :: HashMap TxHash (IntMap (Maybe Spender)) -> [BatchOp] spenderOps = concatMap (uncurry f) . M.toList@@ -93,11 +93,10 @@ 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 :: HashMap Address BalVal -> [BatchOp] balOps = map (uncurry f) . M.toList where- f a Nothing = deleteOp (BalKey a)- f a (Just b) = insertOp (BalKey a) b+ f = insertOp . BalKey addrTxOps :: HashMap Address (HashMap BlockRef (HashMap TxHash Bool)) -> [BatchOp]@@ -201,13 +200,11 @@ 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+ } a = runMaybeT $ cachemap <|> hashmap <|> database+ where+ cachemap = MaybeT $ getBalance bm a+ hashmap = MaybeT $ getBalance hm a+ database = MaybeT $ getBalance db a getUnspentI :: MonadIO m => ImportDB -> OutPoint -> m (Maybe Unspent) getUnspentI ImportDB { importRocksDB = db
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -24,10 +24,13 @@ -- ^ key for a transaction affecting an address | AddrTxKeyA { addrTxKeyA :: !Address } -- ^ short key that matches all entries+ | AddrTxKeyB { addrTxKeyA :: !Address+ , addrTxKeyB :: !BlockRef+ } deriving (Show, Eq, Ord, Generic, Hashable) instance Serialize AddrTxKey- -- 0x05 · Address · Maybe (BlockHeight, BlockPos) · TxHash+ -- 0x05 · Address · BlockRef · TxHash where put AddrTxKey {addrTxKey = AddressTx { addressTxAddress = a , addressTxBlock = b@@ -41,6 +44,11 @@ put AddrTxKeyA {addrTxKeyA = a} = do putWord8 0x05 put a+ -- 0x05 · Address · BlockRef+ put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do+ putWord8 0x05+ put a+ put b get = do guard . (== 0x05) =<< getWord8 a <- get@@ -68,10 +76,14 @@ -- ^ full key | AddrOutKeyA { addrOutKeyA :: !Address } -- ^ short key for all spent or unspent outputs+ | AddrOutKeyB { addrOutKeyA :: !Address+ , addrOutKeyB :: !BlockRef+ } deriving (Show, Read, Eq, Ord, Generic, Hashable) -instance Serialize AddrOutKey where- -- 0x06 · StoreAddr · BlockHeight · MainChain · BlockPos · BlockHash · OutPoint+instance Serialize AddrOutKey+ -- 0x06 · StoreAddr · BlockRef · OutPoint+ where put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do putWord8 0x06 put a@@ -81,6 +93,11 @@ put AddrOutKeyA {addrOutKeyA = a} = do putWord8 0x06 put a+ -- 0x06 · StoreAddr · BlockRef+ put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do+ putWord8 0x06+ put a+ put b get = do guard . (== 0x06) =<< getWord8 AddrOutKey <$> get <*> get <*> get@@ -168,7 +185,9 @@ -- | Mempool transaction database key. data MemKey- = MemKey { memTime :: !PreciseUnixTime, memKey :: !TxHash }+ = MemKey { memTime :: !PreciseUnixTime+ , memKey :: !TxHash }+ | MemKeyT { memTime :: !PreciseUnixTime } | MemKeyS deriving (Show, Read, Eq, Ord, Generic, Hashable) @@ -178,6 +197,9 @@ putWord8 0x07 put t put h+ put (MemKeyT t) = do+ putWord8 0x07+ put t -- 0x07 put MemKeyS = putWord8 0x07 get = do@@ -193,6 +215,7 @@ } deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BlockKey where+ -- 0x01 · BlockHash put (BlockKey h) = do putWord8 0x01 put h@@ -226,7 +249,7 @@ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BalKey where- -- 0x04 · StoreAddr+ -- 0x04 · Address put BalKey {balanceKey = a} = do putWord8 0x04 put a@@ -238,17 +261,28 @@ -- | Address balance database value. data BalVal = BalVal- { balValAmount :: !Word64+ { balValAmount :: !Word64 -- ^ balance in satoshi- , balValZero :: !Word64+ , balValZero :: !Word64 -- ^ unconfirmed balance in satoshi- , balValCount :: !Word64+ , balValUnspentCount :: !Word64 -- ^ number of unspent outputs+ , balValTxCount :: !Word64+ -- ^ number of transactions+ , balValTotalReceived :: !Word64+ -- ^ total amount received by this address } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) -- | Default balance for an address. instance Default BalVal where- def = BalVal {balValAmount = 0, balValZero = 0, balValCount = 0}+ def =+ BalVal+ { balValAmount = 0+ , balValZero = 0+ , balValUnspentCount = 0+ , balValTxCount = 0+ , balValTotalReceived = 0+ } instance KeyValue BalKey BalVal @@ -258,7 +292,7 @@ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BestKey where- -- 0x00 (x32)+ -- 0x00 × 32 put BestKey = put (B.replicate 32 0x00) get = do guard . (== B.replicate 32 0x00) =<< getBytes 32
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -19,7 +19,7 @@ import UnliftIO dataVersion :: Word32-dataVersion = 8+dataVersion = 12 data ExceptRocksDB = MempoolTxNotFound@@ -64,51 +64,68 @@ getBalanceDB :: MonadIO m => DB -> ReadOptions -> Address -> m (Maybe Balance) getBalanceDB db opts a = fmap f <$> retrieve db opts (BalKey a) where- f BalVal {balValAmount = v, balValZero = z, balValCount = c} =+ f BalVal { balValAmount = v+ , balValZero = z+ , balValUnspentCount = c+ , balValTxCount = t+ , balValTotalReceived = r+ } = Balance { balanceAddress = a , balanceAmount = v , balanceZero = z- , balanceCount = c+ , balanceUnspentCount = c+ , balanceTxCount = t+ , balanceTotalReceived = r } getMempoolDB :: (MonadIO m, MonadResource m) => DB -> ReadOptions+ -> Maybe PreciseUnixTime -> ConduitT () (PreciseUnixTime, TxHash) m ()-getMempoolDB db opts = matching db opts MemKeyS .| mapC (uncurry f)+getMempoolDB db opts mpu = x .| mapC (uncurry f) where+ x =+ case mpu of+ Nothing -> matching db opts MemKeyS+ Just pu -> matchingSkip db opts MemKeyS (MemKeyT pu) f (MemKey u t) () = (u, t)- f _ _ = undefined+ f _ _ = undefined getAddressTxsDB :: (MonadIO m, MonadResource m) => DB -> ReadOptions -> Address+ -> Maybe BlockRef -> ConduitT () AddressTx m ()-getAddressTxsDB db opts a =- matching db opts (AddrTxKeyA a) .| mapC (uncurry f)+getAddressTxsDB db opts a mbr = x .| mapC (uncurry f) where+ x =+ case mbr of+ Nothing -> matching db opts (AddrTxKeyA a)+ Just br -> matchingSkip db opts (AddrTxKeyA a) (AddrTxKeyB a br) f AddrTxKey {addrTxKey = t} () = t- f _ _ = undefined+ f _ _ = undefined getAddressUnspentsDB :: (MonadIO m, MonadResource m) => DB -> ReadOptions -> Address+ -> Maybe BlockRef -> ConduitT () Unspent m ()-getAddressUnspentsDB db opts a =- matching db opts (AddrOutKeyA a) .| mapC (uncurry f)+getAddressUnspentsDB db opts a mbr = x .| mapC (uncurry f) where- f AddrOutKey { addrOutKeyB = b- , addrOutKeyP = p- }- OutVal { outValAmount = v- , outValScript = s- } =+ x =+ case mbr of+ Nothing -> matching db opts (AddrOutKeyA a)+ Just br -> matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a br)+ f AddrOutKey {addrOutKeyB = b, addrOutKeyP = p} OutVal { outValAmount = v+ , outValScript = s+ } = Unspent { unspentBlock = b , unspentAmount = v
src/Network/Haskoin/Store/Logic.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiWayIf #-} module Network.Haskoin.Store.Logic where import Conduit@@ -12,6 +12,7 @@ import Control.Monad.Logger import qualified Data.ByteString as B import qualified Data.ByteString.Short as B.Short+import Data.Either import qualified Data.IntMap.Strict as I import Data.List import Data.Maybe@@ -88,7 +89,7 @@ -> Tx -> PreciseUnixTime -> m ()-newMempoolTx net i tx now = do+newMempoolTx net i tx now@(PreciseUnixTime w) = do $(logInfoS) "BlockLogic" $ "Adding transaction to mempool: " <> txHashToHex (txHash tx) getTxData i (txHash tx) >>= \case@@ -115,7 +116,7 @@ getTxOutput (outPointIndex op) t let ds = map spenderHash (mapMaybe outputSpender us) if null ds- then importTx net i (MemRef now) tx+ then importTx net i (MemRef now) (w `div` 1000) tx else g ds g ds = do $(logWarnS) "BlockLogic" $@@ -131,7 +132,7 @@ $(logWarnS) "BlockLogic" $ "Replacting RBF transaction with: " <> txHashToHex (txHash tx) forM_ ds (deleteTx net i True)- importTx net i (MemRef now) tx+ importTx net i (MemRef now) (w `div` 1000) tx n = do $(logWarnS) "BlockLogic" $ "Inserting transaction with deleted flag: " <>@@ -235,7 +236,16 @@ } insertAtHeight i (headerHash (nodeHeader n)) (nodeHeight n) setBest i (headerHash (nodeHeader n))- zipWithM_ (\x t -> importTx net i (br x) t) [0 ..] (sortTxs (blockTxns b))+ zipWithM_+ (\x t ->+ importTx+ net+ i+ (br x)+ (fromIntegral (blockTimestamp (nodeHeader n)))+ t)+ [0 ..]+ (sortTxs (blockTxns b)) where br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos} @@ -261,9 +271,10 @@ => Network -> i -> BlockRef+ -> Word64 -- ^ unix time -> Tx -> m ()-importTx net i br tx = do+importTx net i br tt tx = do when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do $(logErrorS) "BlockLogic" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx)@@ -288,25 +299,27 @@ zipWithM_ (spendOutput net i br (txHash tx)) [0 ..] us if | iscb || not (null us) -> do zipWithM_- (newOutput net i br . OutPoint (txHash tx))+ (newOutput i br . OutPoint (txHash tx)) [0 ..] (txOut tx) rbf <- getrbf- 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- }+ let t =+ 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+ , transactionTime = tt+ }+ let (d, _) = fromTransaction t insertTx i d+ updateAddressCounts i (txAddresses t) (+1) unless (confirmed br) $ insertMempoolTx i (txHash tx) (memRefTime br) | null us && confirmed br -> confirmTx net i br tx@@ -484,8 +497,8 @@ , unspentScript = B.Short.toShort (scriptOutput o) }- reduceBalance net i False a (outValue o)- increaseBalance net i True a (outValue o)+ reduceBalance net i False False a (outValue o)+ increaseBalance i True False a (outValue o) insertTx i t {txDataBlock = br} deleteMempoolTx i (txHash tx) (memRefTime (txDataBlock t)) @@ -540,10 +553,11 @@ forM_ (take (length (txOut (txData t))) [0 ..]) $ \n -> delOutput net i (OutPoint h n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ (unspendOutput net i) ps+ mapM_ (unspendOutput i) ps unless (confirmed (txDataBlock t)) $ deleteMempoolTx i h (memRefTime (txDataBlock t)) insertTx i t {txDataDeleted = True}+ updateAddressCounts i (txDataAddresses t) (subtract 1) insertDeletedMempoolTx :: ( MonadError ImportException m@@ -555,7 +569,7 @@ -> Tx -> PreciseUnixTime -> m ()-insertDeletedMempoolTx i tx now = do+insertDeletedMempoolTx i tx now@(PreciseUnixTime w) = do us <- forM (txIn tx) $ \TxIn {prevOutput = op} -> getImportTx i (outPointHash op) >>= getTxOutput (outPointIndex op)@@ -570,6 +584,7 @@ , transactionOutputs = map mkout (txOut tx) , transactionDeleted = True , transactionRBF = rbf+ , transactionTime = w `div` 1000 } $(logWarnS) "BlockLogic" $ "Inserting deleted mempool transaction: " <> txHashToHex (txHash tx)@@ -590,14 +605,14 @@ | confirmed (txDataBlock t) -> return False | txDataRBF t -> return True | otherwise -> return False- mkin u ip w =+ mkin u ip wit = Input { inputPoint = prevOutput ip , inputSequence = txInSequence ip , inputSigScript = scriptInput ip , inputPkScript = outputScript u , inputAmount = outputAmount u- , inputWitness = w+ , inputWitness = wit } mkout o = Output@@ -616,13 +631,12 @@ , BalanceWrite i m , MonadLogger m )- => Network- -> i+ => i -> BlockRef -> OutPoint -> TxOut -> m ()-newOutput net i br op to = do+newOutput i br op to = do addUnspent i u case scriptToAddressBS (scriptOutput to) of Left _ -> return ()@@ -635,7 +649,7 @@ , addressTxHash = outPointHash op , addressTxBlock = br }- increaseBalance net i (confirmed br) a (outValue to)+ increaseBalance i (confirmed br) True a (outValue to) where u = Unspent@@ -686,6 +700,7 @@ net i (confirmed (transactionBlock t))+ True a (outputAmount u) @@ -753,7 +768,13 @@ case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of Left _ -> return () Right a -> do- reduceBalance net i (confirmed (unspentBlock u)) a (unspentAmount u)+ reduceBalance+ net+ i+ (confirmed (unspentBlock u))+ False+ a+ (unspentAmount u) removeAddrUnspent i a u insertAddrTx i@@ -774,11 +795,10 @@ , BalanceWrite i m , MonadLogger m )- => Network- -> i+ => i -> OutPoint -> m ()-unspendOutput net i op = do+unspendOutput i op = do t <- getImportTx i (outPointHash op) o <- getTxOutput (outPointIndex op) t s <-@@ -812,9 +832,9 @@ , addressTxBlock = transactionBlock x } increaseBalance- net i (confirmed (unspentBlock u))+ False a (outputAmount o) @@ -829,10 +849,11 @@ => Network -> i -> Bool -- ^ spend or delete confirmed output+ -> Bool -- ^ reduce total received -> Address -> Word64 -> m ()-reduceBalance net i c a v =+reduceBalance net i c t a v = getBalance i a >>= \case Nothing -> do $(logErrorS) "BlockLogic" $@@ -867,7 +888,12 @@ if c then 0 else v- , balanceCount = balanceCount b - 1+ , balanceUnspentCount = balanceUnspentCount b - 1+ , balanceTotalReceived =+ balanceTotalReceived b -+ if t+ then v+ else 0 } increaseBalance ::@@ -878,13 +904,13 @@ , BalanceWrite i m , MonadLogger m )- => Network- -> i+ => i -> Bool -- ^ add confirmed output+ -> Bool -- ^ increase total received -> Address -> Word64 -> m ()-increaseBalance _net i c a v = do+increaseBalance i c t a v = do b <- getBalance i a >>= \case Nothing ->@@ -893,7 +919,9 @@ { balanceAddress = a , balanceAmount = 0 , balanceZero = 0- , balanceCount = 0+ , balanceUnspentCount = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0 } Just b -> return b setBalance i $@@ -908,5 +936,37 @@ if c then 0 else v- , balanceCount = balanceCount b + 1+ , balanceUnspentCount = balanceUnspentCount b + 1+ , balanceTotalReceived =+ balanceTotalReceived b ++ if t+ then v+ else 0 }++updateAddressCounts ::+ (MonadError ImportException m, BalanceWrite i m, BalanceRead i m)+ => i+ -> [Address]+ -> (Word64 -> Word64)+ -> m ()+updateAddressCounts i as f =+ forM_ as $ \a -> do+ b <-+ getBalance i a >>= \case+ Nothing -> throwError (BalanceNotFound a)+ Just b -> return b+ setBalance i b {balanceTxCount = f (balanceTxCount b)}++txAddresses :: Transaction -> [Address]+txAddresses t =+ nub . rights $+ map (scriptToAddressBS . inputPkScript)+ (filter (not . isCoinbase) (transactionInputs t)) <>+ map (scriptToAddressBS . outputScript) (transactionOutputs t)++txDataAddresses :: TxData -> [Address]+txDataAddresses t =+ nub . rights $+ map (scriptToAddressBS . prevScript) (I.elems (txDataPrevs t)) <>+ map (scriptToAddressBS . scriptOutput) (txOut (txData t))