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: 513e05388b9aeae3b17af94550d0da07c8f48cd45bc7dd191c39ac4ba296fbaa +-- hash: 5311cf67a21f834e0890ad311ec5a86ad5678aacdf47bd4e63e0c36ed240332c name: haskoin-store -version: 0.26.0 +version: 0.26.1 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.26.0 + , haskoin-store-data ==0.26.1 , 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.26.0 + , haskoin-store-data ==0.26.1 , 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.26.0 + , haskoin-store-data ==0.26.1 , 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 @@ -45,13 +45,18 @@ mapMaybe) import Data.String (fromString) import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Clock.System (getSystemTime, systemSeconds) +import Data.Time.Format (defaultTimeLocale, formatTime, + iso8601DateFormat) import Haskoin (Block (..), BlockHash (..), - BlockHeight, BlockNode (..), - GetData (..), InvType (..), - InvVector (..), Message (..), - Network (..), OutPoint (..), - Tx (..), TxHash (..), TxIn (..), + BlockHeader (..), BlockHeight, + BlockNode (..), GetData (..), + InvType (..), InvVector (..), + Message (..), Network (..), + OutPoint (..), Tx (..), + TxHash (..), TxIn (..), blockHashToHex, headerHash, txHash, txHashToHex) import Haskoin.Node (OnlinePeer (..), Peer, @@ -272,11 +277,14 @@ checkpeer blocknode <- getblocknode p' <- managerPeerText peer =<< asks (blockConfManager . myConfig) + $(logDebugS) "BlockStore" $ + "Processing block from peer " <> p' <> ": " <> + blockText blocknode (blockTxns block) lift (runImport (importBlock block blocknode)) >>= \case Right deletedtxids -> do listener <- asks (blockConfListener . myConfig) $(logInfoS) "BlockStore" $ - "Best block indexed: " <> hexhash <> " from peer " <> p' + "Best block: " <> blockText blocknode (blockTxns block) atomically $ do mapM_ (listener . StoreTxDeleted) deletedtxids listener (StoreBestBlock blockhash) @@ -620,10 +628,10 @@ $(logDebugS) "BlockStore" $ "Requesting block " <> cs (show i) <> "/" <> cs (show (length vectors)) <> - ": " <> - blockHashToHex (headerHash (nodeHeader bn)) <> " from peer " <> - p' + p' <> + ": " <> + blockText bn [] MGetData (GetData vectors) `sendMessage` peer where checksyncingpeer = @@ -800,3 +808,18 @@ blockStoreTxHashSTM :: Peer -> [TxHash] -> BlockStore -> STM () blockStoreTxHashSTM peer txhashes store = BlockTxAvailable peer txhashes `sendSTM` store + +blockText :: BlockNode -> [Tx] -> Text +blockText bn txs + | null txs = height <> sep <> time <> sep <> hash + | otherwise = height <> sep <> time <> sep <> txcount <> sep <> hash + where + height = cs $ show (nodeHeight bn) + systime = + posixSecondsToUTCTime (fromIntegral (blockTimestamp (nodeHeader bn))) + time = + cs $ + formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M")) systime + hash = blockHashToHex (headerHash (nodeHeader bn)) + txcount = cs (show (length txs)) <> " txs" + sep = " | " diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -960,14 +960,17 @@ MonadLoggerIO m => [Address] -> CacheT m [Maybe AddressXPub] cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as) -redisAddToMempool :: RedisCtx m f => [BlockTx] -> m (f Integer) +redisAddToMempool :: (Applicative f, RedisCtx m f) => [BlockTx] -> m (f Integer) +redisAddToMempool [] = return (pure 0) redisAddToMempool btxs = zadd mempoolSetKey $ map (\btx -> (blockRefScore (blockTxBlock btx), encode (blockTxHash btx))) btxs -redisRemFromMempool :: RedisCtx m f => [TxHash] -> m (f Integer) -redisRemFromMempool = zrem mempoolSetKey . map encode +redisRemFromMempool :: + (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer) +redisRemFromMempool [] = return (pure 0) +redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs redisSetAddrInfo :: (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ()) @@ -1016,7 +1019,9 @@ zadd (txSetPfx <> encode xpub) $ map (\t -> (blockRefScore (blockTxBlock t), encode (blockTxHash t))) btxs -redisRemXPubTxs :: RedisCtx m f => XPubSpec -> [TxHash] -> m (f Integer) +redisRemXPubTxs :: + (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer) +redisRemXPubTxs _ [] = return (pure 0) redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs) redisAddXPubUnspents :: diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -32,8 +32,9 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.ByteString (ByteString) import Data.Function (on) +import qualified Data.HashSet as H import Data.IntMap.Strict (IntMap) -import Data.List (nub, partition, sortBy) +import Data.List (nub, sortBy) import Data.Maybe (listToMaybe) import Data.Serialize (Serialize (..)) import Data.Word (Word32, Word64) @@ -322,14 +323,14 @@ applyLimitC (Just l) = takeC (fromIntegral l) sortTxs :: [Tx] -> [(Word32, Tx)] -sortTxs txs = go $ zip [0 ..] txs +sortTxs txs = go [] thset $ zip [0 ..] txs where - go [] = [] - go ts = - let (is, ds) = - partition - (all ((`notElem` map (txHash . snd) ts) . - outPointHash . prevOutput) . - txIn . snd) - ts - in is <> go ds + thset = H.fromList (map txHash txs) + go [] _ [] = [] + go orphans ths [] = go [] ths orphans + go orphans ths ((i, tx):xs) = + let ops = map (outPointHash . prevOutput) (txIn tx) + orp = any (`H.member` ths) ops + in if orp + then go ((i, tx) : orphans) ths xs + else (i, tx) : go orphans (txHash tx `H.delete` ths) xs 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 @@ -43,11 +43,9 @@ sortTxs) import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), BlockTx (..), - Prev (..), Spender (..), - StoreOutput (..), Transaction (..), - TxData (..), UnixTime, Unspent (..), - confirmed, nullBalance, toTransaction, - transactionData) + Prev (..), Spender (..), TxData (..), + UnixTime, Unspent (..), confirmed, + nullBalance) import UnliftIO (Exception) data ImportException @@ -575,23 +573,6 @@ throwError $ TxDeleted (txHashToHex th) | otherwise -> return d -getImportTx :: - (StoreRead m, MonadLogger m, MonadError ImportException m) - => TxHash - -> m Transaction -getImportTx 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 -> do - sm <- getSpenders th - return $ toTransaction d sm - getTxOut :: Word32 -> Tx @@ -600,25 +581,6 @@ guard (fromIntegral i < length (txOut tx)) return $ txOut tx !! fromIntegral i -getTxOutput :: - (MonadLogger m, MonadError ImportException m) - => Word32 - -> Transaction - -> m StoreOutput -getTxOutput i tx = do - unless (fromIntegral i < length (transactionOutputs tx)) $ do - $(logErrorS) "BlockStore" $ - "Output out of range: " <> txHashToHex (txHash (transactionData tx)) <> - " " <> - fromString (show i) - throwError . OutputOutOfRange . cs $ - show - OutPoint - { outPointHash = txHash (transactionData tx) - , outPointIndex = i - } - return $ transactionOutputs tx !! fromIntegral i - spendOutput :: ( StoreRead m , StoreWrite m @@ -653,10 +615,16 @@ => OutPoint -> m () unspendOutput op = do - t <- getImportTx (outPointHash op) - o <- getTxOutput (outPointIndex op) t + t <- getImportTxData (outPointHash op) + o <- + case getTxOut (outPointIndex op) (txData t) of + Nothing -> do + $(logErrorS) "BlockStore" $ + "Output out of range: " <> cs (show op) + throwError (OutputOutOfRange (cs (show op))) + Just o -> return o s <- - case outputSpender o of + getSpender op >>= \case Nothing -> do $(logErrorS) "BlockStore" $ "Output already unspent: " <> txHashToHex (outPointHash op) <> @@ -666,31 +634,29 @@ Just s -> return s x <- getImportTxData (spenderHash s) deleteSpender op + let m = eitherToMaybe (scriptToAddressBS (scriptOutput o)) let u = Unspent - { unspentAmount = outputAmount o - , unspentBlock = transactionBlock t - , unspentScript = B.Short.toShort (outputScript o) + { unspentAmount = outValue o + , unspentBlock = txDataBlock t + , unspentScript = B.Short.toShort (scriptOutput o) , unspentPoint = op - , unspentAddress = - eitherToMaybe (scriptToAddressBS (outputScript o)) + , unspentAddress = m } insertUnspent u - case scriptToAddressBS (outputScript o) of - Left _ -> return () - Right a -> do + case m of + Nothing -> return () + Just a -> do insertAddrUnspent a u deleteAddrTx a BlockTx - { blockTxHash = spenderHash s - , blockTxBlock = txDataBlock x - } + {blockTxHash = spenderHash s, blockTxBlock = txDataBlock x} increaseBalance (confirmed (unspentBlock u)) False a - (outputAmount o) + (outValue o) reduceBalance :: ( StoreRead m