diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 454857d6641206426edf1b345b6c3325c11aa449009fe4abc4e2cf89dfcaefee +-- hash: 513e05388b9aeae3b17af94550d0da07c8f48cd45bc7dd191c39ac4ba296fbaa name: haskoin-store -version: 0.25.4 +version: 0.26.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format. @@ -57,7 +57,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.3 , haskoin-node >=0.13.0 - , haskoin-store-data ==0.25.4 + , haskoin-store-data ==0.26.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32 @@ -99,7 +99,7 @@ , haskoin-core >=0.13.3 , haskoin-node >=0.13.0 , haskoin-store - , haskoin-store-data ==0.25.4 + , haskoin-store-data ==0.26.0 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1 @@ -149,7 +149,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.3 , haskoin-node >=0.13.0 - , haskoin-store-data ==0.25.4 + , haskoin-store-data ==0.26.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -280,7 +280,7 @@ atomically $ do mapM_ (listener . StoreTxDeleted) deletedtxids listener (StoreBestBlock blockhash) - lift (syncMe peer) + lift (touchPeer peer >> syncMe peer) Left e -> do $(logErrorS) "BlockStore" $ "Error importing block: " <> hexhash <> ": " <> @@ -300,16 +300,9 @@ "Ignoring block " <> hexhash <> " from disconnected peer" mzero Just _ -> - getSyncingState >>= \case - Just Syncing {syncingPeer = syncingpeer} - | peer == syncingpeer -> do - box <- asks myPeer - now <- - fromIntegral . systemSeconds <$> - liftIO getSystemTime - atomically . modifyTVar box . fmap $ \s -> - s {syncingTime = now} - _ -> do + lift (touchPeer peer) >>= \case + True -> return () + False -> do p' <- managerPeerText peer =<< asks (blockConfManager . myConfig) @@ -530,6 +523,17 @@ then InvWitnessTx else InvTx MGetData (GetData (map (InvVector inv . getTxHash) xs)) `sendMessage` p + +touchPeer :: MonadIO m => Peer -> ReaderT BlockRead m Bool +touchPeer p = + getSyncingState >>= \case + Just Syncing {syncingPeer = s} + | p == s -> do + box <- asks myPeer + now <- fromIntegral . systemSeconds <$> liftIO getSystemTime + atomically . modifyTVar box . fmap $ \x -> x {syncingTime = now} + return True + _ -> return False checkTime :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m () checkTime = diff --git a/src/Haskoin/Store/Database/Memory.hs b/src/Haskoin/Store/Database/Memory.hs --- a/src/Haskoin/Store/Database/Memory.hs +++ b/src/Haskoin/Store/Database/Memory.hs @@ -25,7 +25,8 @@ import Data.Word (Word32) import Haskoin (Address, BlockHash, BlockHeight, Network, OutPoint (..), TxHash, - headerHash, txHash) + eitherToMaybe, headerHash, + scriptToAddressBS, txHash) import Haskoin.Store.Common (Limit, StoreRead (..), StoreWrite (..), applyLimit) import Haskoin.Store.Data (Balance (..), BlockData (..), @@ -156,6 +157,8 @@ , unspentAmount = outValAmount u , unspentScript = B.Short.toShort (outValScript u) , unspentPoint = p + , unspentAddress = + eitherToMaybe (scriptToAddressBS (outValScript u)) } g _ _ Nothing = Nothing h Unspent {unspentBlock = b} = diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -39,7 +39,8 @@ import Database.RocksDB.Query (Key, KeyValue) import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight, - OutPoint (..), TxHash) + OutPoint (..), TxHash, eitherToMaybe, + scriptToAddressBS) import Haskoin.Store.Data (Balance (..), BlockData, BlockRef, BlockTx (..), Spender, TxData, UnixTime, Unspent (..), getUnixTime, @@ -220,6 +221,7 @@ , unspentAmount = outValAmount v , unspentScript = BSS.toShort (outValScript v) , unspentPoint = addrOutKeyP b + , unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v)) } -- | Mempool transaction database key. @@ -431,4 +433,5 @@ , unspentPoint = p , unspentAmount = v , unspentScript = s + , unspentAddress = eitherToMaybe (scriptToAddressBS (BSS.fromShort s)) } diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -13,8 +13,8 @@ , deleteTx ) where -import Control.Monad (forM, forM_, unless, void, when, - zipWithM_) +import Control.Monad (forM, forM_, guard, unless, void, + when, zipWithM_) import Control.Monad.Except (MonadError (..)) import Control.Monad.Logger (MonadLogger, logDebugS, logErrorS, logWarnS) @@ -34,20 +34,19 @@ Network (..), OutPoint (..), Tx (..), TxHash, TxIn (..), TxOut (..), addrToString, blockHashToHex, - computeSubsidy, genesisBlock, - genesisNode, headerHash, isGenesis, - nullOutPoint, scriptToAddressBS, - txHash, txHashToHex) + computeSubsidy, eitherToMaybe, + genesisBlock, genesisNode, headerHash, + isGenesis, nullOutPoint, + scriptToAddressBS, txHash, + txHashToHex) import Haskoin.Store.Common (StoreRead (..), StoreWrite (..), sortTxs) import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), BlockTx (..), Prev (..), Spender (..), - StoreInput (..), StoreOutput (..), - Transaction (..), TxData (..), - UnixTime, Unspent (..), confirmed, - fromTransaction, isCoinbase, - nullBalance, toTransaction, + StoreOutput (..), Transaction (..), + TxData (..), UnixTime, Unspent (..), + confirmed, nullBalance, toTransaction, transactionData) import UnliftIO (Exception) @@ -135,7 +134,7 @@ "Cannot delete block that is not head: " <> blockHashToHex h throwError (BlockNotBest (blockHashToHex bh)) - txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd) + txs <- mapM (fmap txData . getImportTxData) (blockDataTxs bd) ths <- nub . concat <$> mapM (deleteTx False False . txHash . snd) (reverse (sortTxs txs)) @@ -263,23 +262,22 @@ (\i o -> newOutput br (OutPoint (txHash tx) i) o) [0 ..] (txOut tx) - 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 ps = + I.fromList . zip [0 ..] $ + if iscb + then [] + else map mkprv us + d = + TxData + { txDataBlock = br + , txData = tx + , txDataPrevs = ps + , txDataDeleted = False + , txDataRBF = rbf + , txDataTime = tt } - let (d, _) = fromTransaction t insertTx d - updateAddressCounts (txAddresses t) (+ 1) + updateAddressCounts (txDataAddresses d) (+ 1) unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br) uns op = getUnspent op >>= \case @@ -317,30 +315,7 @@ Just u -> return (u, ths) th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) - ws = map Just (txWitness tx) <> repeat Nothing - mkcb ip w = - StoreCoinbase - { inputPoint = prevOutput ip - , inputSequence = txInSequence ip - , inputSigScript = scriptInput ip - , inputWitness = w - } - mkin u ip w = - let script = B.Short.fromShort (unspentScript u) - in StoreInput - { inputPoint = prevOutput ip - , inputSequence = txInSequence ip - , inputSigScript = scriptInput ip - , inputPkScript = script - , inputAmount = unspentAmount u - , inputWitness = w - } - mkout o = - StoreOutput - { outputAmount = outValue o - , outputScript = scriptOutput o - , outputSpender = Nothing - } + mkprv u = Prev (B.Short.fromShort (unspentScript u)) (unspentAmount u) confirmTx :: ( StoreRead m @@ -375,6 +350,8 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o) + , unspentAddress = + eitherToMaybe (scriptToAddressBS (scriptOutput o)) } case scriptToAddressBS (scriptOutput o) of Left _ -> return () @@ -394,6 +371,9 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o) + , unspentAddress = + eitherToMaybe + (scriptToAddressBS (scriptOutput o)) } insertAddrUnspent a @@ -402,6 +382,9 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o) + , unspentAddress = + eitherToMaybe + (scriptToAddressBS (scriptOutput o)) } reduceBalance False False a (outValue o) increaseBalance True False a (outValue o) @@ -532,6 +515,8 @@ , unspentAmount = outValue to , unspentScript = B.Short.toShort (scriptOutput to) , unspentPoint = op + , unspentAddress = + eitherToMaybe (scriptToAddressBS (scriptOutput to)) } delOutput :: @@ -543,32 +528,53 @@ => OutPoint -> m () delOutput op = do - t <- getImportTx (outPointHash op) - u <- getTxOutput (outPointIndex op) t + t <- getImportTxData (outPointHash op) + u <- + case getTxOut (outPointIndex op) (txData t) of + Just u -> return u + Nothing -> do + $(logErrorS) "BlockStore" $ + "Output out of range: " <> txHashToHex (txHash (txData t)) <> + " " <> + fromString (show (outPointIndex op)) + throwError . OutputOutOfRange . cs $ show op deleteUnspent op - case scriptToAddressBS (outputScript u) of + case scriptToAddressBS (scriptOutput u) of Left _ -> return () Right a -> do deleteAddrUnspent a Unspent - { unspentScript = B.Short.toShort (outputScript u) - , unspentBlock = transactionBlock t + { unspentScript = B.Short.toShort (scriptOutput u) + , unspentBlock = txDataBlock t , unspentPoint = op - , unspentAmount = outputAmount u + , unspentAmount = outValue u + , unspentAddress = + eitherToMaybe (scriptToAddressBS (scriptOutput u)) } deleteAddrTx a BlockTx { blockTxHash = outPointHash op - , blockTxBlock = transactionBlock t + , blockTxBlock = txDataBlock t } - reduceBalance - (confirmed (transactionBlock t)) - True - a - (outputAmount u) + reduceBalance (confirmed (txDataBlock t)) True a (outValue u) +getImportTxData :: + (StoreRead m, MonadLogger m, MonadError ImportException m) + => TxHash + -> m TxData +getImportTxData th = + getTxData th >>= \case + Nothing -> do + $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex th + throwError $ TxNotFound (txHashToHex th) + Just d + | txDataDeleted d -> do + $(logErrorS) "BlockStore" $ "Tx deleted: " <> txHashToHex th + throwError $ TxDeleted (txHashToHex th) + | otherwise -> return d + getImportTx :: (StoreRead m, MonadLogger m, MonadError ImportException m) => TxHash @@ -586,6 +592,14 @@ sm <- getSpenders th return $ toTransaction d sm +getTxOut + :: Word32 + -> Tx + -> Maybe TxOut +getTxOut i tx = do + guard (fromIntegral i < length (txOut tx)) + return $ txOut tx !! fromIntegral i + getTxOutput :: (MonadLogger m, MonadError ImportException m) => Word32 @@ -650,7 +664,7 @@ fromString (show (outPointIndex op)) throwError (AlreadyUnspent (cs (show op))) Just s -> return s - x <- getImportTx (spenderHash s) + x <- getImportTxData (spenderHash s) deleteSpender op let u = Unspent @@ -658,6 +672,8 @@ , unspentBlock = transactionBlock t , unspentScript = B.Short.toShort (outputScript o) , unspentPoint = op + , unspentAddress = + eitherToMaybe (scriptToAddressBS (outputScript o)) } insertUnspent u case scriptToAddressBS (outputScript o) of @@ -668,7 +684,7 @@ a BlockTx { blockTxHash = spenderHash s - , blockTxBlock = transactionBlock x + , blockTxBlock = txDataBlock x } increaseBalance (confirmed (unspentBlock u)) @@ -783,13 +799,6 @@ then throwError (BalanceNotFound (addrText net a)) else return b setBalance 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 =