summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorxenog <>2018-09-14 12:58:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-14 12:58:00 (GMT)
commit346fcc378fbaeb146b025dca884ca87bf7182961 (patch)
treec754ec60d8cd9988543113c8f43eaa1cfa44ee50
parentd02735c4c4202cc47ff57bfabcc62f864171a953 (diff)
version 0.2.00.2.0
-rw-r--r--CHANGELOG.md15
-rw-r--r--README.md30
-rw-r--r--app/Main.hs176
-rw-r--r--haskoin-store.cabal7
-rw-r--r--src/Haskoin/Store.hs (renamed from src/Network/Haskoin/Store.hs)165
-rw-r--r--src/Network/Haskoin/Store/Block.hs533
-rw-r--r--src/Network/Haskoin/Store/Types.hs419
-rw-r--r--test/Spec.hs117
8 files changed, 813 insertions, 649 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 385e0e6..8f97157 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -4,6 +4,21 @@ All notable changes to this project will be documented in this file.
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.2.0
+### Added
+- Documentation everywhere.
+- Ability to retrieve address transactions.
+
+### Changed
+- New versions of NQE and Haskoin Node upstream.
+- Improve and simplify API.
+- Multi-element endpoints return arrays of arrays.
+- Database snapshots for all queries are now mandatory.
+
+### Removed
+- Retrieving unspent and spent outputs for an address.
+- Redundant API endpoints for multiple elements.
+
## 0.1.3
### Changed
- Fix a bug with transaction notifications.
diff --git a/README.md b/README.md
index c756d4a..40dd903 100644
--- a/README.md
+++ b/README.md
@@ -34,33 +34,3 @@ For every address Haskoin Store has a balance object that contains basic statist
* `unconfirmed` balance represent aggregate changes done by mempool transactions. Can be negative if the transactions currently in the mempool are expected to reduce the balance when all of them make it into the blockchain.
* `outputs` is the count of outputs that send funds to this address. It is just a count and not a monetary value.
* `utxo` is the count of outputs that send funds to this address that remain unspent, taking the mempool into account: if spent in the mempool it will *not* count as unspent.
-
-## Limits
-
-Various endpoints in the API will have both server and per-query limits to avoid overloading the server. Depending on the type of query being done the limits have varying effects.
-
-### Multiple Objects in URI
-
-If specifying multiple objects in the URI, for example when obtaining the balances for multiple addresses, no more than 500 elements may be requested.
-
-If each object specified in the URI might lead to multiple results, these will be concatenated in the response, such that the first set of elements will correspond to the first requested item that yields any results, and the last set of elements will correspond to the last requested item that yields results, assuming that the number of returned items has not exceeded the count limit.
-
-### Count Limit
-
-The count limit is set by default at 10,000 server-wide. It may be changed via the server command line or for an individual request. The individual request limit may not be value larger than the server’s.
-
-If the number of available results exceeds the count limit, and if stopping at exactly the limit would lead to a result set that would be partial for a block in the blockchain, any extra items that belong to the same block as the last element that fits within the limit will be appended to the results, exceeding the count limit.
-
-When multiple objects are present in the URI and the result set exceeds the count limit, and stopping at the limit would lead to a partial result set for a requested item and block in the blockchain, any extra elements that pertain to the same item and block as the last element that fits within the limit will be appended.
-
-The mempool is considered as a single block for count limit calculation purposes.
-
-In short, a block worth of relevant data—or the mempool—will always be delivered in its entirety, regardless of the count limit.
-
-### Height Limit
-
-When delivering multiple results, Haskoin Store will start with data from the mempool, and then data from the highest block in the chain, followed by its parent, and so on until reaching the genesis block, or the count limit. Results are returned in reversed order from highest (latest) to lowest (earliest).
-
-If the result set count matches or exceeds the count limit, it is possible that there are more entries available below the block height of the last result returned. By specifying a height limit in the query, the result set will start at the specified height, skipping any blocks above it.
-
-Since block data is never delivered incomplete, it suffices to subtract one to the block height of the last returned element when performing the next request. If the last returned element is not in a block, then the height of the best block should be used for the next request.
diff --git a/app/Main.hs b/app/Main.hs
index 7fa31e2..9c83739 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -7,7 +7,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Conduit
import Control.Arrow
-import Control.Concurrent.NQE
import Control.Exception
import Control.Monad
import Control.Monad.Logger
@@ -15,7 +14,6 @@ import Data.Aeson (ToJSON (..), Value (..), encode,
object, (.=))
import Data.Bits
import Data.ByteString.Builder (lazyByteString)
-import Data.Function
import Data.List
import Data.Maybe
import Data.String.Conversions
@@ -23,9 +21,10 @@ import qualified Data.Text as T
import Data.Version
import Database.RocksDB hiding (get)
import Haskoin
-import Network.Haskoin.Node
-import Network.Haskoin.Store
+import Haskoin.Node
+import Haskoin.Store
import Network.HTTP.Types
+import NQE
import Options.Applicative
import Paths_haskoin_store as P
import System.Directory
@@ -216,8 +215,6 @@ main =
when (null (configPeers conf) && not (configDiscover conf)) . liftIO $
die "Specify: --discover | --peers PEER,..."
let net = configNetwork conf
- b <- Inbox <$> newTQueueIO
- s <- Inbox <$> newTQueueIO
let wdir = configDir conf </> getNetworkName net
liftIO $ createDirectoryIfMissing True wdir
db <-
@@ -229,18 +226,13 @@ main =
, maxOpenFiles = -1
, writeBufferSize = 2 `shift` 30
}
- mgr <- Inbox <$> newTQueueIO
- pub <- Inbox <$> newTQueueIO
- ch <- Inbox <$> newTQueueIO
- supervisor
- KillAll
- s
- [runWeb conf pub mgr ch b db, runStore conf pub mgr ch b db]
+ runStore conf db $ \st -> runWeb conf st db
where
opts =
info (helper <*> config) $
fullDesc <> progDesc "Blockchain store and API" <>
- Options.Applicative.header ("haskoin-store version " <> showVersion P.version)
+ Options.Applicative.header
+ ("haskoin-store version " <> showVersion P.version)
testLength :: Monad m => Int -> ActionT Except m ()
testLength l = when (l <= 0 || l > maxUriArgs) (raise OutOfBounds)
@@ -248,68 +240,86 @@ testLength l = when (l <= 0 || l > maxUriArgs) (raise OutOfBounds)
runWeb ::
(MonadUnliftIO m, MonadLoggerIO m)
=> Config
- -> Publisher Inbox TBQueue StoreEvent
- -> Manager
- -> Chain
- -> BlockStore
+ -> Store
-> DB
-> m ()
-runWeb conf pub mgr ch bl db = do
+runWeb conf st db = do
l <- askLoggerIO
scottyT (configPort conf) (runner l) $ do
defaultHandler defHandler
- get "/block/best" $ getBestBlock db Nothing >>= json
+ get "/block/best" $ do
+ res <- withSnapshot db $ getBestBlock db
+ json res
get "/block/:block" $ do
block <- param "block"
- getBlock block db Nothing >>= maybeJSON
+ res <- withSnapshot db $ getBlock block db
+ maybeJSON res
get "/block/height/:height" $ do
height <- param "height"
- getBlockAtHeight height db Nothing >>= maybeJSON
+ res <- withSnapshot db $ getBlockAtHeight height db
+ maybeJSON res
get "/block/heights" $ do
heights <- param "heights"
- testLength (length heights)
- getBlocksAtHeights heights db Nothing >>= json
+ testLength (length (heights :: [BlockHeight]))
+ res <-
+ withSnapshot db $ \s ->
+ mapM (\h -> getBlockAtHeight h db s) heights
+ json res
get "/blocks" $ do
blocks <- param "blocks"
testLength (length blocks)
- getBlocks blocks db Nothing >>= json
- get "/mempool" $ lift (getMempool db Nothing) >>= json
+ res <- withSnapshot db $ getBlocks blocks db
+ json res
+ get "/mempool" $ do
+ res <- withSnapshot db $ getMempool db
+ json res
get "/transaction/:txid" $ do
txid <- param "txid"
- lift (getTx net txid db Nothing) >>= maybeJSON
+ res <- withSnapshot db $ getTx net txid db
+ maybeJSON res
get "/transactions" $ do
txids <- param "txids"
- testLength (length txids)
- lift (getTxs net txids db Nothing) >>= json
- get "/address/:address/outputs" $ do
+ testLength (length (txids :: [TxHash]))
+ res <- withSnapshot db $ \s -> mapM (\t -> getTx net t db s) txids
+ json res
+ get "/address/:address/transactions" $ do
address <- parse_address
height <- parse_height
x <- parse_max
- lift (addrTxsMax db x height address) >>= json
- get "/address/outputs" $ do
+ res <- withSnapshot db $ \s -> addrTxsMax net db s x height address
+ json res
+ get "/address/transactions" $ do
addresses <- parse_addresses
height <- parse_height
x <- parse_max
- lift (addrsTxsMax db x height addresses) >>= json
+ res <-
+ withSnapshot db $ \s -> addrsTxsMax net db s x height addresses
+ json res
get "/address/:address/unspent" $ do
address <- parse_address
height <- parse_height
x <- parse_max
- lift (addrUnspentMax db x height address) >>= json
+ res <- withSnapshot db $ \s -> addrUnspentMax db s x height address
+ json res
get "/address/unspent" $ do
addresses <- parse_addresses
height <- parse_height
x <- parse_max
- lift (addrsUnspentMax db x height addresses) >>= json
+ res <-
+ withSnapshot db $ \s -> addrsUnspentMax db s x height addresses
+ json res
get "/address/:address/balance" $ do
address <- parse_address
- getBalance address db Nothing >>= json
+ res <- withSnapshot db $ getBalance address db
+ json res
get "/address/balances" $ do
addresses <- parse_addresses
- getBalances addresses db Nothing >>= json
+ res <-
+ withSnapshot db $ \s -> mapM (\a -> getBalance a db s) addresses
+ json res
post "/transactions" $ do
NewTx tx <- jsonData
- lift (publishTx net pub mgr ch db bl tx) >>= \case
+ lift (publishTx net st db tx) >>= \case
Left PublishTimeout -> do
status status500
json (UserError (show PublishTimeout))
@@ -321,7 +331,7 @@ runWeb conf pub mgr ch bl db = do
get "/events" $ do
setHeader "Content-Type" "application/x-json-stream"
stream $ \io flush ->
- withBoundedPubSub maxPubSubQueue pub $ \sub ->
+ withPubSub (storePublisher st) (newTBQueueIO maxPubSubQueue) $ \sub ->
forever $
flush >> receive sub >>= \case
BestBlock block_hash -> do
@@ -337,7 +347,7 @@ runWeb conf pub mgr ch bl db = do
address <- param "address"
case stringToAddr net address of
Nothing -> next
- Just a -> return a
+ Just a -> return a
parse_addresses = do
addresses <- param "addresses"
let as = mapMaybe (stringToAddr net) addresses
@@ -357,23 +367,14 @@ runWeb conf pub mgr ch bl db = do
runStore ::
(MonadLoggerIO m, MonadUnliftIO m)
=> Config
- -> Publisher Inbox TBQueue StoreEvent
- -> Manager
- -> Chain
- -> BlockStore
-> DB
- -> m ()
-runStore conf pub mgr ch b db = do
- s <- Inbox <$> newTQueueIO
+ -> (Store -> m a)
+ -> m a
+runStore conf db f = do
let net = configNetwork conf
cfg =
StoreConfig
- { storeConfBlocks = b
- , storeConfSupervisor = s
- , storeConfChain = ch
- , storeConfManager = mgr
- , storeConfPublisher = pub
- , storeConfMaxPeers = 20
+ { storeConfMaxPeers = 20
, storeConfInitPeers =
map
(second (fromMaybe (getDefaultPort net)))
@@ -382,65 +383,64 @@ runStore conf pub mgr ch b db = do
, storeConfDB = db
, storeConfNetwork = net
}
- store cfg
+ withStore cfg f
addrTxsMax ::
MonadUnliftIO m
- => DB
+ => Network
+ -> DB
+ -> Snapshot
-> Int
-> Maybe BlockHeight
-> Address
- -> m [AddrOutput]
-addrTxsMax db c h = addrsTxsMax db c h . (: [])
+ -> m [DetailedTx]
+addrTxsMax net db s c h a = concat <$> addrsTxsMax net db s c h [a]
addrsTxsMax ::
MonadUnliftIO m
- => DB
+ => Network
+ -> DB
+ -> Snapshot
-> Int
-> Maybe BlockHeight
-> [Address]
- -> m [AddrOutput]
-addrsTxsMax db c h as =
- runResourceT $
- runConduit $ getAddrsOutputs as h db Nothing .| capRecords f c .| sinkList
- where
- f = (==) `on` g
- g AddrOutput {..} =
- (addrOutputAddress addrOutputKey, blockRefHash <$> outBlock addrOutput)
+ -> m [[DetailedTx]]
+addrsTxsMax net db s c h addrs
+ | c <= 0 = return []
+ | otherwise =
+ case addrs of
+ [] -> return []
+ (a:as) -> do
+ ts <-
+ runResourceT . runConduit $
+ getAddrTxs net a h db s .| takeC c .| sinkList
+ mappend [ts] <$> addrsTxsMax net db s (c - length ts) h as
addrUnspentMax ::
MonadUnliftIO m
=> DB
+ -> Snapshot
-> Int
-> Maybe BlockHeight
-> Address
-> m [AddrOutput]
-addrUnspentMax db c h = addrsUnspentMax db c h . (: [])
+addrUnspentMax db s c h a = concat <$> addrsUnspentMax db s c h [a]
addrsUnspentMax ::
MonadUnliftIO m
=> DB
+ -> Snapshot
-> Int
-> Maybe BlockHeight
-> [Address]
- -> m [AddrOutput]
-addrsUnspentMax db c h as =
- runResourceT $
- runConduit $ getUnspents as h db Nothing .| capRecords f c .| sinkList
- where
- f = (==) `on` g
- g AddrOutput {..} =
- (addrOutputAddress addrOutputKey, blockRefHash <$> outBlock addrOutput)
-
-capRecords :: Monad m => (a -> a -> Bool) -> Int -> ConduitT a a m ()
-capRecords f c = void $ mapAccumWhileC go (Nothing, c)
- where
- go x (acc, n)
- | n > 0 = Right ((Just x, n - 1), x)
- | otherwise =
- case acc of
- Nothing -> Left (Just x, n - 1)
- Just y ->
- if f x y
- then Right ((Just x, n - 1), x)
- else Left (Just x, n - 1)
+ -> m [[AddrOutput]]
+addrsUnspentMax db s c h addrs
+ | c <= 0 = return []
+ | otherwise =
+ case addrs of
+ [] -> return []
+ (a:as) -> do
+ os <-
+ runResourceT . runConduit $
+ getUnspent a h db s .| takeC c .| sinkList
+ mappend [os] <$> addrsUnspentMax db s (c - length os) h as
diff --git a/haskoin-store.cabal b/haskoin-store.cabal
index 6d28fb9..2b32136 100644
--- a/haskoin-store.cabal
+++ b/haskoin-store.cabal
@@ -2,10 +2,10 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 31ec5e381f6c17e7be976119ac20f85b6f6598508e24a47b1c22c09e4fe59ec6
+-- hash: df37cb39caa6d4694913200ee8ccf5e190db23ea20a046529710b3b0f72252e8
name: haskoin-store
-version: 0.1.3
+version: 0.2.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
@@ -27,7 +27,7 @@ source-repository head
library
exposed-modules:
- Network.Haskoin.Store
+ Haskoin.Store
other-modules:
Network.Haskoin.Store.Block
Network.Haskoin.Store.Types
@@ -100,6 +100,7 @@ test-suite haskoin-store-test
, haskoin-store
, hspec
, monad-logger
+ , mtl
, nqe
, rocksdb-haskell
, unliftio
diff --git a/src/Network/Haskoin/Store.hs b/src/Haskoin/Store.hs
index 651a281..cea3dba 100644
--- a/src/Network/Haskoin/Store.hs
+++ b/src/Haskoin/Store.hs
@@ -6,38 +6,35 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-module Network.Haskoin.Store
- ( BlockStore
+module Haskoin.Store
+ ( Store(..)
+ , BlockStore
, Output(..)
+ , Spender(..)
, BlockRef(..)
, StoreConfig(..)
, StoreEvent(..)
, BlockValue(..)
, DetailedTx(..)
+ , DetailedInput(..)
+ , DetailedOutput(..)
, NewTx(..)
- , AddrOutputKey(..)
, AddrOutput(..)
, AddressBalance(..)
, TxException(..)
- , store
+ , withStore
, getBestBlock
, getBlockAtHeight
- , getBlocksAtHeights
, getBlock
, getBlocks
, getTx
- , getTxs
- , getAddrOutputs
- , getAddrsOutputs
+ , getAddrTxs
, getUnspent
- , getUnspents
, getBalance
- , getBalances
, getMempool
, publishTx
) where
-import Control.Concurrent.NQE
import Control.Monad.Except
import Control.Monad.Logger
import Control.Monad.Reader
@@ -46,83 +43,91 @@ import Data.Serialize
import Data.String
import Data.String.Conversions
import Database.RocksDB
+import Haskoin.Node
import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Network
-import Network.Haskoin.Node
import Network.Haskoin.Store.Block
import Network.Haskoin.Store.Types
import Network.Haskoin.Transaction
import Network.Socket (SockAddr (..))
+import NQE
import System.Random
import UnliftIO
+-- | Context for the store.
type MonadStore m = (MonadLoggerIO m, MonadReader StoreRead m)
+-- | Running store state.
data StoreRead = StoreRead
{ myMailbox :: !(Inbox NodeEvent)
, myBlockStore :: !BlockStore
, myChain :: !Chain
, myManager :: !Manager
, myListener :: !(Listen StoreEvent)
- , myPublisher :: !(Publisher Inbox TBQueue StoreEvent)
+ , myPublisher :: !(Publisher StoreEvent)
, myBlockDB :: !DB
, myNetwork :: !Network
}
-store :: (MonadLoggerIO m, MonadUnliftIO m) => StoreConfig m -> m ()
-store StoreConfig {..} = do
- $(logInfoS) "Store" "Launching..."
- ns <- Inbox <$> newTQueueIO
- sm <- Inbox <$> newTQueueIO
- ls <- Inbox <$> newTQueueIO
- let node_cfg =
- NodeConfig
+-- | Run a Haskoin Store instance. It will launch a network node, a
+-- 'BlockStore', connect to the network and start synchronizing blocks and
+-- transactions.
+withStore ::
+ (MonadLoggerIO m, MonadUnliftIO m)
+ => StoreConfig
+ -> (Store -> m a)
+ -> m a
+withStore StoreConfig {..} f = do
+ sm <- newInbox =<< newTQueueIO
+ withNode (node_cfg sm) $ \(mg, ch) -> do
+ ls <- newInbox =<< newTQueueIO
+ bs <- newInbox =<< newTQueueIO
+ pb <- newInbox =<< newTQueueIO
+ let store_read =
+ StoreRead
+ { myMailbox = sm
+ , myBlockStore = bs
+ , myChain = ch
+ , myManager = mg
+ , myPublisher = pb
+ , myListener = (`sendSTM` ls)
+ , myBlockDB = storeConfDB
+ , myNetwork = storeConfNetwork
+ }
+ let block_cfg =
+ BlockConfig
+ { blockConfMailbox = bs
+ , blockConfChain = ch
+ , blockConfManager = mg
+ , blockConfListener = (`sendSTM` ls)
+ , blockConfDB = storeConfDB
+ , blockConfNet = storeConfNetwork
+ }
+ withAsync (runReaderT run store_read) $ \st ->
+ withAsync (blockStore block_cfg) $ \bt ->
+ withAsync (publisher pb (receiveSTM ls)) $ \pu -> do
+ link st
+ link bt
+ link pu
+ f (Store mg ch bs pb)
+ where
+ run =
+ forever $ do
+ sm <- asks myMailbox
+ storeDispatch =<< receive sm
+ node_cfg sm =
+ NodeConfig
{ maxPeers = storeConfMaxPeers
, database = storeConfDB
, initPeers = storeConfInitPeers
, discover = storeConfDiscover
, nodeEvents = (`sendSTM` sm)
, netAddress = NetworkAddress 0 (SockAddrInet 0 0)
- , nodeSupervisor = ns
- , nodeChain = storeConfChain
- , nodeManager = storeConfManager
, nodeNet = storeConfNetwork
}
- let store_read =
- StoreRead
- { myMailbox = sm
- , myBlockStore = storeConfBlocks
- , myChain = storeConfChain
- , myManager = storeConfManager
- , myPublisher = storeConfPublisher
- , myListener = (`sendSTM` ls)
- , myBlockDB = storeConfDB
- , myNetwork = storeConfNetwork
- }
- let block_cfg =
- BlockConfig
- { blockConfMailbox = storeConfBlocks
- , blockConfChain = storeConfChain
- , blockConfManager = storeConfManager
- , blockConfListener = (`sendSTM` ls)
- , blockConfDB = storeConfDB
- , blockConfNet = storeConfNetwork
- }
- supervisor
- KillAll
- storeConfSupervisor
- [ runReaderT run store_read
- , node node_cfg
- , blockStore block_cfg
- , boundedPublisher storeConfPublisher ls
- ]
- where
- run =
- forever $ do
- sm <- asks myMailbox
- storeDispatch =<< receive sm
+-- | Dispatcher of node events.
storeDispatch :: MonadStore m => NodeEvent -> m ()
storeDispatch (ManagerEvent (ManagerConnect p)) = do
@@ -212,33 +217,32 @@ storeDispatch (PeerEvent (_, TxNotFound tx_hash)) = do
storeDispatch (PeerEvent _) = return ()
+-- | Publish a new transaction to the network.
publishTx ::
(MonadUnliftIO m, MonadLoggerIO m)
=> Network
- -> Publisher Inbox TBQueue StoreEvent
- -> Manager
- -> Chain
+ -> Store
-> DB
- -> BlockStore
-> Tx
-> m (Either TxException DetailedTx)
-publishTx net pub mgr ch db bl tx =
- getTx net (txHash tx) db Nothing >>= \case
- Just d -> return (Right d)
- Nothing ->
- timeout 10000000 (runExceptT go) >>= \case
- Nothing -> return (Left PublishTimeout)
- Just e -> return e
+publishTx net Store {..} db tx =
+ withSnapshot db $ \s ->
+ getTx net (txHash tx) db s >>= \case
+ Just d -> return (Right d)
+ Nothing ->
+ timeout 10000000 (runExceptT (go s)) >>= \case
+ Nothing -> return (Left PublishTimeout)
+ Just e -> return e
where
- go = do
+ go s = do
p <-
- managerGetPeers mgr >>= \case
+ managerGetPeers storeManager >>= \case
[] -> throwError NoPeers
p:_ -> return (onlinePeerMailbox p)
- ExceptT . withBoundedPubSub 1000 pub $ \sub ->
- runExceptT (send_it sub p)
- send_it sub p = do
- h <- is_at_height
+ ExceptT . withPubSub storePublisher (newTBQueueIO 1000) $ \sub ->
+ runExceptT (send_it s sub p)
+ send_it s sub p = do
+ h <- is_at_height s
unless h $ throwError NotAtHeight
r <- liftIO randomIO
MTx tx `sendMessage` p
@@ -246,13 +250,13 @@ publishTx net pub mgr ch db bl tx =
recv_loop sub p r
maybeToExceptT
CouldNotImport
- (MaybeT (getTx net (txHash tx) db Nothing))
+ (MaybeT (withSnapshot db $ getTx net (txHash tx) db))
recv_loop sub p r =
receive sub >>= \case
PeerPong p' n
| p == p' && n == r -> do
- TxPublished tx `send` bl
- recv_loop sub p r
+ TxPublished tx `send` storeBlock
+ recv_loop sub p r
MempoolNew h
| h == txHash tx -> return ()
PeerDisconnected p'
@@ -262,11 +266,12 @@ publishTx net pub mgr ch db bl tx =
TxException h x
| h == txHash tx -> throwError x
_ -> recv_loop sub p r
- is_at_height = do
- bb <- getBestBlockHash db Nothing
- cb <- chainGetBest ch
+ is_at_height s = do
+ bb <- getBestBlockHash db s
+ cb <- chainGetBest storeChain
return (headerHash (nodeHeader cb) == bb)
+-- | Peer information to show on logs.
peerString :: (MonadStore m, IsString a) => Peer -> m a
peerString p = do
mgr <- asks myManager
diff --git a/src/Network/Haskoin/Store/Block.hs b/src/Network/Haskoin/Store/Block.hs
index 00bb2b6..2d42c49 100644
--- a/src/Network/Haskoin/Store/Block.hs
+++ b/src/Network/Haskoin/Store/Block.hs
@@ -12,32 +12,24 @@ module Network.Haskoin.Store.Block
( blockStore
, getBestBlock
, getBestBlockHash
- , getBlocksAtHeights
, getBlockAtHeight
, getBlock
, getBlocks
+ , getAddrTxs
, getUnspent
- , getAddrOutputs
- , getAddrsOutputs
, getBalance
- , getBalances
, getTx
- , getTxs
- , getUnspents
, getMempool
) where
import Conduit
import Control.Applicative
-import Control.Concurrent.NQE
import Control.Monad.Except
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import qualified Data.ByteString as B
-import Data.Foldable
-import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map.Strict as M
@@ -50,13 +42,15 @@ import Data.String.Conversions
import Data.Text (Text)
import Data.Time.Clock.POSIX
import Database.RocksDB (BatchOp, DB, Snapshot)
-import qualified Database.RocksDB as R
+import Database.RocksDB as R
import Database.RocksDB.Query as R
import Haskoin
-import Network.Haskoin.Node
+import Haskoin.Node
import Network.Haskoin.Store.Types
+import NQE
import UnliftIO
+-- | Block store process state.
data BlockRead = BlockRead
{ myBlockDB :: !DB
, mySelf :: !BlockStore
@@ -68,13 +62,20 @@ data BlockRead = BlockRead
, myNetwork :: !Network
}
+-- | Block store context.
type MonadBlock m
= (MonadLoggerIO m, MonadReader BlockRead m)
+-- | Map of outputs for importing transactions.
type OutputMap = Map OutPoint Output
+
+-- | Map of address balances for importing transactions.
type AddressMap = Map Address Balance
+
+-- | Map of transactions for importing.
type TxMap = Map TxHash ImportTx
+-- | Status of a transaction being verified for importing.
data TxStatus
= TxValid
| TxOrphan
@@ -82,11 +83,13 @@ data TxStatus
| TxInputSpent
deriving (Eq, Show, Ord)
+-- | Transaction to import.
data ImportTx = ImportTx
{ importTx :: !Tx
, importTxBlock :: !(Maybe BlockRef)
}
+-- | State for importing or removing blocks and transactions.
data ImportState = ImportState
{ outputMap :: !OutputMap
, addressMap :: !AddressMap
@@ -95,11 +98,16 @@ data ImportState = ImportState
, blockAction :: !(Maybe BlockAction)
}
+-- | Context for importing or removing blocks and transactions.
type MonadImport m = MonadState ImportState m
+-- | Whether to import or remove a block.
data BlockAction = RevertBlock | ImportBlock !Block
-runMonadImport :: MonadBlock m => StateT ImportState m a -> m a
+-- | Run within 'MonadImport' context. Execute updates to database and
+-- notification to subscribers when finished.
+runMonadImport ::
+ MonadBlock m => StateT ImportState m a -> m a
runMonadImport f =
evalStateT
(f >>= \a -> update_database >> return a)
@@ -112,12 +120,13 @@ runMonadImport f =
}
where
update_database = do
+ net <- asks myNetwork
ops <-
concat <$>
sequence
[ getBlockOps
, getBalanceOps
- , getDeleteTxOps
+ , getDeleteTxOps net
, getInsertTxOps
, purgeOrphanOps
]
@@ -132,6 +141,7 @@ runMonadImport f =
gets newTxs >>= \ths ->
forM_ (M.keys ths) $ \tx -> atomically (l (MempoolNew tx))
+-- | Run block store process.
blockStore :: (MonadUnliftIO m, MonadLoggerIO m) => BlockConfig -> m ()
blockStore BlockConfig {..} = do
base_height_box <- newTVarIO 0
@@ -156,120 +166,78 @@ blockStore BlockConfig {..} = do
init_db =
runResourceT $ do
runConduit $
- matching blockConfDB Nothing OrphanKey .|
+ matching blockConfDB Nothing ShortOrphanKey .|
mapM_C (\(k, Tx {}) -> remove blockConfDB k)
retrieve blockConfDB Nothing BestBlockKey >>= \case
Nothing -> addNewBlock (genesisBlock blockConfNet)
- Just (_ :: BlockHash) ->
- getBestBlock blockConfDB Nothing >>= \BlockValue {..} -> do
- base_height_box <- asks myBaseHeight
- atomically $ writeTVar base_height_box blockValueHeight
-
-getBestBlockHash :: MonadIO m => DB -> Maybe Snapshot -> m BlockHash
-getBestBlockHash db snapshot =
- retrieve db snapshot BestBlockKey >>= \case
+ Just (_ :: BlockHash) -> do
+ BlockValue {..} <-
+ withSnapshot blockConfDB $ getBestBlock blockConfDB
+ base_height_box <- asks myBaseHeight
+ atomically $ writeTVar base_height_box blockValueHeight
+
+-- | Get best block hash.
+getBestBlockHash :: MonadIO m => DB -> Snapshot -> m BlockHash
+getBestBlockHash db s =
+ retrieve db (Just s) BestBlockKey >>= \case
Nothing -> throwString "Best block hash not available"
Just bh -> return bh
-getBestBlock :: MonadIO m => DB -> Maybe Snapshot -> m BlockValue
+-- | Get best block.
+getBestBlock :: MonadIO m => DB -> Snapshot -> m BlockValue
getBestBlock db s =
- case s of
- Nothing -> R.withSnapshot db $ f . Just
- Just _ -> f s
- where
- f s' =
- getBestBlockHash db s' >>= \bh ->
- getBlock bh db s' >>= \case
- Nothing ->
- throwString $
- "Best block not available at hash: " <>
- cs (blockHashToHex bh)
- Just b -> return b
-
-getBlocksAtHeights ::
- MonadIO m => [BlockHeight] -> DB -> Maybe Snapshot -> m [BlockValue]
-getBlocksAtHeights bhs db s =
- case s of
- Nothing -> R.withSnapshot db $ f . Just
- Just _ -> f s
- where
- f s' =
- fmap catMaybes . forM (nub bhs) $ \bh ->
- getBlockAtHeight bh db s'
+ getBestBlockHash db s >>= \bh ->
+ getBlock bh db s >>= \case
+ Nothing ->
+ throwString $
+ "Best block not available at hash: " <> cs (blockHashToHex bh)
+ Just b -> return b
+-- | Get one block at specified height.
getBlockAtHeight ::
- MonadIO m => BlockHeight -> DB -> Maybe Snapshot -> m (Maybe BlockValue)
+ MonadIO m => BlockHeight -> DB -> Snapshot -> m (Maybe BlockValue)
getBlockAtHeight height db s =
- case s of
- Nothing -> R.withSnapshot db $ f . Just
- Just _ -> f s
- where
- f s' = retrieve db s' (HeightKey height) >>= \case
+ retrieve db (Just s) (HeightKey height) >>= \case
Nothing -> return Nothing
- Just h -> retrieve db s' (BlockKey h)
+ Just h -> retrieve db (Just s) (BlockKey h)
-getBlocks :: MonadIO m => [BlockHash] -> DB -> Maybe Snapshot -> m [BlockValue]
+-- | Get blocks for specific hashes.
+getBlocks :: MonadIO m => [BlockHash] -> DB -> Snapshot -> m [BlockValue]
getBlocks bids db s =
- case s of
- Nothing -> R.withSnapshot db $ f . Just
- Just _ -> f s
- where
- f s' =
- fmap catMaybes . forM (nub bids) $ \bid -> getBlock bid db s'
+ fmap catMaybes . forM (nub bids) $ \bid -> getBlock bid db s
+-- | Get a block.
getBlock ::
- MonadIO m => BlockHash -> DB -> Maybe Snapshot -> m (Maybe BlockValue)
-getBlock bh db snapshot = retrieve db snapshot (BlockKey bh)
-
-getAddrSpent ::
- (MonadResource m, MonadUnliftIO m)
- => Address
- -> Maybe BlockHeight
- -> DB
- -> Maybe Snapshot
- -> ConduitT () (AddrOutputKey, Output) m ()
-getAddrSpent addr h db snapshot =
- matchingSkip
- db
- snapshot
- (MultiAddrOutputKey True addr)
- (MultiAddrHeightKey True addr h)
+ MonadIO m => BlockHash -> DB -> Snapshot -> m (Maybe BlockValue)
+getBlock bh db s = retrieve db (Just s) (BlockKey bh)
+-- | Get unspent outputs for an address.
getAddrUnspent ::
(MonadUnliftIO m, MonadResource m)
=> Address
-> Maybe BlockHeight
-> DB
- -> Maybe Snapshot
- -> ConduitT () (AddrOutputKey, Output) m ()
-getAddrUnspent addr h db snapshot =
+ -> Snapshot
+ -> ConduitT () (AddrOutKey, Output) m ()
+getAddrUnspent addr h db s =
matchingSkip
db
- snapshot
- (MultiAddrOutputKey False addr)
- (MultiAddrHeightKey False addr h)
-
-getBalances ::
- MonadIO m => [Address] -> DB -> Maybe Snapshot -> m [AddressBalance]
-getBalances addrs db s =
- case s of
- Nothing -> R.withSnapshot db $ f . Just
- Just _ -> f s
- where
- f s' = forM (nub addrs) $ \a -> getBalance a db s'
+ (Just s)
+ (ShortAddrOutKey addr)
+ (ShortAddrOutKeyHeight addr h)
+-- | Get balance for an address.
getBalance ::
- MonadIO m => Address -> DB -> Maybe Snapshot -> m AddressBalance
+ MonadIO m => Address -> DB -> Snapshot -> m AddressBalance
getBalance addr db s =
- retrieve db s (BalanceKey addr) >>= \case
+ retrieve db (Just s) (BalanceKey addr) >>= \case
Just Balance {..} ->
return
AddressBalance
{ addressBalAddress = addr
, addressBalConfirmed = balanceValue
, addressBalUnconfirmed = balanceUnconfirmed
- , addressOutputCount = balanceOutputCount
- , addressSpentCount = balanceSpentCount
+ , addressUtxoCount = balanceUtxoCount
}
Nothing ->
return
@@ -277,40 +245,38 @@ getBalance addr db s =
{ addressBalAddress = addr
, addressBalConfirmed = 0
, addressBalUnconfirmed = 0
- , addressOutputCount = 0
- , addressSpentCount = 0
+ , addressUtxoCount = 0
}
-getMempool :: MonadUnliftIO m => DB -> Maybe Snapshot -> m [TxHash]
-getMempool db snapshot = get_hashes <$> matchingAsList db snapshot MempoolKey
+-- | Get list of transactions in mempool.
+getMempool :: MonadUnliftIO m => DB -> Snapshot -> m [TxHash]
+getMempool db s = get_hashes <$> matchingAsList db (Just s) ShortMempoolKey
where
- get_hashes mempool_txs = [tx_hash | (MempoolTx tx_hash, ()) <- mempool_txs]
-
-getTxs :: MonadUnliftIO m => Network -> [TxHash] -> DB -> Maybe Snapshot -> m [DetailedTx]
-getTxs net ths db s =
- case s of
- Nothing -> R.withSnapshot db $ f . Just
- Just _ -> f s
- where
- f s' = fmap catMaybes . forM (nub ths) $ \th -> getTx net th db s'
+ get_hashes mempool_txs = [tx_hash | (MempoolKey tx_hash, ()) <- mempool_txs]
+-- | Get single transaction.
getTx ::
- MonadUnliftIO m => Network -> TxHash -> DB -> Maybe Snapshot -> m (Maybe DetailedTx)
+ MonadUnliftIO m
+ => Network
+ -> TxHash
+ -> DB
+ -> Snapshot
+ -> m (Maybe DetailedTx)
getTx net th db s = do
- xs <- matchingAsList db s (BaseTxKey th)
+ xs <- matchingAsList db (Just s) (ShortMultiTxKey th)
case find_tx xs of
Just TxRecord {..} ->
let os = map (uncurry output) (filter_outputs xs)
is = map (input txValuePrevOuts) (txIn txValue)
- in return $
- Just
- DetailedTx
- { detailedTxData = txValue
- , detailedTxFee = fee is os
- , detailedTxBlock = txValueBlock
- , detailedTxInputs = is
- , detailedTxOutputs = os
- }
+ in return $
+ Just
+ DetailedTx
+ { detailedTxData = txValue
+ , detailedTxFee = fee is os
+ , detailedTxBlock = txValueBlock
+ , detailedTxInputs = is
+ , detailedTxOutputs = os
+ }
Nothing -> return Nothing
where
fee is os =
@@ -320,33 +286,33 @@ getTx net th db s = do
input prevs TxIn {..} =
if outPointHash prevOutput == zero
then DetailedCoinbase
- { detInOutPoint = prevOutput
- , detInSequence = txInSequence
- , detInSigScript = scriptInput
- , detInNetwork = net
- }
+ { detInOutPoint = prevOutput
+ , detInSequence = txInSequence
+ , detInSigScript = scriptInput
+ , detInNetwork = net
+ }
else let PrevOut {..} =
fromMaybe
(error
("Could not locate outpoint: " <>
showOutPoint prevOutput))
(lookup prevOutput prevs)
- in DetailedInput
- { detInOutPoint = prevOutput
- , detInSequence = txInSequence
- , detInSigScript = scriptInput
- , detInPkScript = prevOutScript
- , detInValue = prevOutValue
- , detInBlock = prevOutBlock
- , detInNetwork = net
- }
+ in DetailedInput
+ { detInOutPoint = prevOutput
+ , detInSequence = txInSequence
+ , detInSigScript = scriptInput
+ , detInPkScript = prevOutScript
+ , detInValue = prevOutValue
+ , detInBlock = prevOutBlock
+ , detInNetwork = net
+ }
output OutPoint {..} Output {..} =
DetailedOutput
- { detOutValue = outputValue
- , detOutScript = outScript
- , detOutSpender = outSpender
- , detOutNetwork = net
- }
+ { detOutValue = outputValue
+ , detOutScript = outScript
+ , detOutSpender = outSpender
+ , detOutNetwork = net
+ }
find_tx xs =
listToMaybe
[ t
@@ -360,12 +326,13 @@ getTx net th db s = do
[ (p, o)
| (k, v) <- xs
, case (k, v) of
- (MultiTxKeyOutput {}, MultiTxOutput {}) -> True
- _ -> False
- , let MultiTxKeyOutput (OutputKey p) = k
+ (MultiTxOutKey {}, MultiTxOutput {}) -> True
+ _ -> False
+ , let MultiTxOutKey (OutputKey p) = k
, let MultiTxOutput o = v
]
+-- | Get transaction output for importing transaction.
getOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m (Maybe Output)
getOutput out_point = runMaybeT $ MaybeT map_lookup <|> MaybeT db_lookup
where
@@ -373,6 +340,7 @@ getOutput out_point = runMaybeT $ MaybeT map_lookup <|> MaybeT db_lookup
db_key = OutputKey out_point
db_lookup = asks myBlockDB >>= \db -> retrieve db Nothing db_key
+-- | Get address balance for importing transaction.
getAddress :: (MonadBlock m, MonadImport m) => Address -> m Balance
getAddress address =
fromMaybe emptyBalance <$>
@@ -382,36 +350,45 @@ getAddress address =
db_key = BalanceKey address
db_lookup = asks myBlockDB >>= \db -> retrieve db Nothing db_key
+-- | Get transactions to delete.
getDeleteTxs :: MonadImport m => m (Set TxHash)
getDeleteTxs = gets deleteTxs
+-- | Should this transaction be deleted already?
shouldDelete :: MonadImport m => TxHash -> m Bool
shouldDelete tx_hash = S.member tx_hash <$> getDeleteTxs
+-- | Add a new block.
addBlock :: MonadImport m => Block -> m ()
addBlock block = modify $ \s -> s {blockAction = Just (ImportBlock block)}
+-- | Revert best block.
revertBlock :: MonadImport m => m ()
revertBlock = modify $ \s -> s {blockAction = Just RevertBlock}
+-- | Delete a transaction.
deleteTx :: MonadImport m => TxHash -> m ()
deleteTx tx_hash =
modify $ \s -> s {deleteTxs = S.insert tx_hash (deleteTxs s)}
+-- | Insert a transaction.
insertTx :: MonadImport m => Tx -> Maybe BlockRef -> m ()
insertTx tx maybe_block_ref =
modify $ \s -> s {newTxs = M.insert (txHash tx) import_tx (newTxs s)}
where
import_tx = ImportTx {importTx = tx, importTxBlock = maybe_block_ref}
+-- | Insert or update a transaction output.
updateOutput :: MonadImport m => OutPoint -> Output -> m ()
updateOutput out_point output =
modify $ \s -> s {outputMap = M.insert out_point output (outputMap s)}
+-- | Insert or update an address balance.
updateAddress :: MonadImport m => Address -> Balance -> m ()
updateAddress address balance =
modify $ \s -> s {addressMap = M.insert address balance (addressMap s)}
+-- | Spend an output.
spendOutput :: (MonadBlock m, MonadImport m) => OutPoint -> Spender -> m ()
spendOutput out_point spender@Spender {..} =
void . runMaybeT $ do
@@ -433,14 +410,15 @@ spendOutput out_point spender@Spender {..} =
if isJust spenderBlock
then balance
{ balanceValue = balanceValue - outputValue
- , balanceSpentCount = balanceSpentCount + 1
+ , balanceUtxoCount = balanceUtxoCount - 1
}
else balance
{ balanceUnconfirmed =
balanceUnconfirmed - fromIntegral outputValue
- , balanceSpentCount = balanceSpentCount + 1
+ , balanceUtxoCount = balanceUtxoCount - 1
}
+-- | Make an output unspent.
unspendOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m ()
unspendOutput out_point =
void . runMaybeT $ do
@@ -461,14 +439,15 @@ unspendOutput out_point =
if isJust spenderBlock
then balance
{ balanceValue = balanceValue + outputValue
- , balanceSpentCount = balanceSpentCount - 1
+ , balanceUtxoCount = balanceUtxoCount + 1
}
else balance
{ balanceUnconfirmed =
balanceUnconfirmed + fromIntegral outputValue
- , balanceSpentCount = balanceSpentCount - 1
+ , balanceUtxoCount = balanceUtxoCount + 1
}
+-- | Remove unspent output.
removeOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m ()
removeOutput out_point@OutPoint {..} = do
net <- asks myNetwork
@@ -488,14 +467,15 @@ removeOutput out_point@OutPoint {..} = do
if isJust outBlock
then balance
{ balanceValue = balanceValue - outputValue
- , balanceOutputCount = balanceOutputCount - 1
+ , balanceUtxoCount = balanceUtxoCount - 1
}
else balance
{ balanceUnconfirmed =
balanceUnconfirmed - fromIntegral outputValue
- , balanceOutputCount = balanceOutputCount - 1
+ , balanceUtxoCount = balanceUtxoCount - 1
}
+-- | Add a new unspent output.
addOutput :: (MonadBlock m, MonadImport m) => OutPoint -> Output -> m ()
addOutput out_point@OutPoint {..} output@Output {..} = do
net <- asks myNetwork
@@ -508,18 +488,20 @@ addOutput out_point@OutPoint {..} output@Output {..} = do
if isJust outBlock
then balance
{ balanceValue = balanceValue + outputValue
- , balanceOutputCount = balanceOutputCount + 1
+ , balanceUtxoCount = balanceUtxoCount + 1
}
else balance
{ balanceUnconfirmed =
balanceUnconfirmed + fromIntegral outputValue
- , balanceOutputCount = balanceOutputCount + 1
+ , balanceUtxoCount = balanceUtxoCount + 1
}
+-- | Get transaction.
getTxRecord :: MonadBlock m => TxHash -> m (Maybe TxRecord)
getTxRecord tx_hash =
asks myBlockDB >>= \db -> retrieve db Nothing (TxKey tx_hash)
+-- | Delete a transaction.
deleteTransaction ::
(MonadBlock m, MonadImport m)
=> TxHash
@@ -554,12 +536,12 @@ deleteTransaction tx_hash = shouldDelete tx_hash >>= \d -> unless d delete_it
mapM_ (removeOutput . OutPoint tx_hash) (take n_out [0 ..])
unspend_inputs = mapM_ unspendOutput
+-- | Add new block.
addNewBlock :: MonadBlock m => Block -> m ()
addNewBlock block@Block {..} =
runMonadImport $ do
new_height <- get_new_height
- $(logInfoS) "Block" $
- "Importing block height: " <> cs (show new_height)
+ $(logInfoS) "Block" $ "Importing block height: " <> cs (show new_height)
import_txs new_height
addBlock block
where
@@ -575,12 +557,14 @@ addNewBlock block@Block {..} =
if blockHeader == getGenesisHeader net
then return 0
else do
- best <- asks myBlockDB >>= \db -> getBestBlock db Nothing
+ best <-
+ asks myBlockDB >>= \db -> withSnapshot db $ getBestBlock db
when (prev_block /= headerHash (blockValueHeader best)) .
throwString $
"Block does not build on best at hash: " <> show new_hash
return $ blockValueHeight best + 1
+-- | Get write ops for importing or removing a block.
getBlockOps :: (MonadBlock m, MonadImport m) => m [BatchOp]
getBlockOps =
gets blockAction >>= \case
@@ -600,12 +584,12 @@ getBlockOps =
cs (blockHashToHex block_hash)
let block_value =
BlockValue
- { blockValueHeight = nodeHeight bn
- , blockValueWork = nodeWork bn
- , blockValueHeader = nodeHeader bn
- , blockValueSize = fromIntegral (B.length (encode block))
- , blockValueTxs = map txHash blockTxns
- }
+ { blockValueHeight = nodeHeight bn
+ , blockValueWork = nodeWork bn
+ , blockValueHeader = nodeHeader bn
+ , blockValueSize = fromIntegral (B.length (encode block))
+ , blockValueTxs = map txHash blockTxns
+ }
return
[ insertOp (BlockKey block_hash) block_value
, insertOp (HeightKey (nodeHeight bn)) block_hash
@@ -613,7 +597,7 @@ getBlockOps =
]
get_block_remove_ops = do
db <- asks myBlockDB
- BlockValue {..} <- getBestBlock db Nothing
+ BlockValue {..} <- withSnapshot db $ getBestBlock db
let block_hash = headerHash blockValueHeader
block_key = BlockKey block_hash
height_key = HeightKey blockValueHeight
@@ -624,6 +608,7 @@ getBlockOps =
, insertOp BestBlockKey prev_block
]
+-- | Get output ops for importing or removing transactions.
outputOps :: (MonadBlock m, MonadImport m) => OutPoint -> m [BatchOp]
outputOps out_point@OutPoint {..}
| out_point == nullOutPoint = return []
@@ -640,34 +625,51 @@ outputOps out_point@OutPoint {..}
addr_ops = addressOutOps net out_point output False
return $ output_op : addr_ops
+-- | Get address output ops when importing or removing transactions.
addressOutOps :: Network -> OutPoint -> Output -> Bool -> [BatchOp]
addressOutOps net out_point output@Output {..} del =
case scriptToAddressBS net outScript of
Nothing -> []
- Just address ->
- let key =
- AddrOutputKey
- { addrOutputSpent = isJust outSpender
- , addrOutputAddress = address
+ Just a
+ | del -> out_ops a
+ | otherwise -> tx_op a : spender_ops a <> out_ops a
+ where
+ out_ops a =
+ let key =
+ AddrOutKey
+ { addrOutputAddress = a
, addrOutputHeight = blockRefHeight <$> outBlock
, addrOutputPos = blockRefPos <$> outBlock
, addrOutPoint = out_point
}
- key_mempool = key {addrOutputHeight = Nothing}
- key_delete = key {addrOutputSpent = isNothing outSpender}
- key_delete_mempool = key_delete {addrOutputHeight = Nothing}
- op =
- if del
- then deleteOp key
- else insertOp key output
- in if isJust outBlock
- then [ op
- , deleteOp key_delete
- , deleteOp key_mempool
- , deleteOp key_delete_mempool
- ]
- else [op, deleteOp key_delete]
-
+ mem = key {addrOutputHeight = Nothing, addrOutputPos = Nothing}
+ in if isJust outSpender || del
+ then [deleteOp mem, deleteOp key]
+ else [deleteOp mem, insertOp key output]
+ tx_op a =
+ let tx_key =
+ AddrTxKey
+ { addrTxKey = a
+ , addrTxHeight = blockRefHeight <$> outBlock
+ , addrTxPos = blockRefPos <$> outBlock
+ , addrTxHash = outPointHash out_point
+ }
+ in insertOp tx_key ()
+ spender_ops a =
+ case outSpender of
+ Nothing -> []
+ Just Spender {..} ->
+ let spender_key =
+ AddrTxKey
+ { addrTxKey = a
+ , addrTxHeight = blockRefHeight <$> spenderBlock
+ , addrTxPos = blockRefPos <$> spenderBlock
+ , addrTxHash = spenderHash
+ }
+ in [insertOp spender_key ()]
+
+
+-- | Get ops for outputs to delete.
deleteOutOps :: (MonadBlock m, MonadImport m) => OutPoint -> m [BatchOp]
deleteOutOps out_point@OutPoint {..} = do
net <- asks myNetwork
@@ -681,53 +683,81 @@ deleteOutOps out_point@OutPoint {..} = do
addr_ops = addressOutOps net out_point output True
return $ output_op : addr_ops
+-- | Get ops for transactions to delete.
deleteTxOps :: TxHash -> [BatchOp]
deleteTxOps tx_hash =
[ deleteOp (TxKey tx_hash)
- , deleteOp (MempoolTx tx_hash)
- , deleteOp (OrphanTxKey tx_hash)
+ , deleteOp (MempoolKey tx_hash)
+ , deleteOp (OrphanKey tx_hash)
]
+-- | Purge all orphan transactions.
purgeOrphanOps :: (MonadBlock m, MonadImport m) => m [BatchOp]
purgeOrphanOps =
fmap (fromMaybe []) . runMaybeT $ do
db <- asks myBlockDB
guard . isJust =<< gets blockAction
liftIO . runResourceT . runConduit $
- matching db Nothing OrphanKey .| mapC (\(k, Tx {}) -> deleteOp k) .|
+ matching db Nothing ShortOrphanKey .|
+ mapC (\(k, Tx {}) -> deleteOp k) .|
sinkList
-getSimpleTx :: MonadBlock m => TxHash -> m Tx
+-- | Get a transaction record from database.
+getSimpleTx :: MonadBlock m => TxHash -> m TxRecord
getSimpleTx tx_hash =
getTxRecord tx_hash >>= \case
Nothing -> throwString $ "Cannot find tx hash: " <> show tx_hash
- Just TxRecord {..} -> return txValue
+ Just r -> return r
+-- | Get outpoints for a transaction.
getTxOutPoints :: Tx -> [OutPoint]
getTxOutPoints tx@Tx {..} =
let tx_hash = txHash tx
in [OutPoint tx_hash i | i <- take (length txOut) [0 ..]]
+-- | Get previous outpoints from a transaction.
getPrevOutPoints :: Tx -> [OutPoint]
getPrevOutPoints Tx {..} = map prevOutput txIn
-getDeleteTxOps :: (MonadBlock m, MonadImport m) => m [BatchOp]
-getDeleteTxOps = do
+deleteAddrTxOps :: Network -> TxRecord -> [BatchOp]
+deleteAddrTxOps net TxRecord {..} =
+ let ias =
+ mapMaybe
+ (scriptToAddressBS net . prevOutScript . snd)
+ txValuePrevOuts
+ oas = mapMaybe (scriptToAddressBS net . scriptOutput) (txOut txValue)
+ in map del_addr_tx (ias <> oas)
+ where
+ del_addr_tx a =
+ deleteOp $
+ AddrTxKey
+ { addrTxKey = a
+ , addrTxHeight = blockRefHeight <$> txValueBlock
+ , addrTxPos = blockRefPos <$> txValueBlock
+ , addrTxHash = txHash txValue
+ }
+
+-- | Get ops do delete transactions.
+getDeleteTxOps :: (MonadBlock m, MonadImport m) => Network -> m [BatchOp]
+getDeleteTxOps net = do
del_txs <- S.toList <$> getDeleteTxs
- txs <- mapM getSimpleTx del_txs
+ trs <- mapM getSimpleTx del_txs
+ let txs = map txValue trs
let prev_outs = concatMap getPrevOutPoints txs
tx_outs = concatMap getTxOutPoints txs
tx_ops = concatMap deleteTxOps del_txs
+ addr_tx_ops = concatMap (deleteAddrTxOps net) trs
prev_out_ops <- concat <$> mapM outputOps prev_outs
tx_out_ops <- concat <$> mapM deleteOutOps tx_outs
- return $ prev_out_ops <> tx_out_ops <> tx_ops
+ return $ prev_out_ops <> tx_out_ops <> tx_ops <> addr_tx_ops
+-- | Get ops to insert transactions.
insertTxOps :: (MonadBlock m, MonadImport m) => ImportTx -> m [BatchOp]
insertTxOps ImportTx {..} = do
prev_outputs <- get_prev_outputs
let key = TxKey (txHash importTx)
- mempool_key = MempoolTx (txHash importTx)
- orphan_key = OrphanTxKey (txHash importTx)
+ mempool_key = MempoolKey (txHash importTx)
+ orphan_key = OrphanKey (txHash importTx)
value =
TxRecord
{ txValueBlock = importTxBlock
@@ -766,6 +796,7 @@ insertTxOps ImportTx {..} = do
, prevOutScript = outScript
})
+-- | Aggregate all transaction insert ops.
getInsertTxOps :: (MonadBlock m, MonadImport m) => m [BatchOp]
getInsertTxOps = do
new_txs <- M.elems <$> gets newTxs
@@ -777,19 +808,21 @@ getInsertTxOps = do
tx_ops <- concat <$> mapM insertTxOps new_txs
return $ prev_out_ops <> tx_out_ops <> tx_ops
+-- | Aggregate all balance update ops.
getBalanceOps :: MonadImport m => m [BatchOp]
getBalanceOps = do
address_map <- gets addressMap
return $ map (uncurry (insertOp . BalanceKey)) (M.toList address_map)
+-- | Revert best block.
revertBestBlock :: MonadBlock m => m ()
revertBestBlock = do
net <- asks myNetwork
db <- asks myBlockDB
- BlockValue {..} <- getBestBlock db Nothing
+ BlockValue {..} <- withSnapshot db $ getBestBlock db
when (blockValueHeader == getGenesisHeader net) . throwString $
"Attempted to revert genesis block"
- import_txs <- mapM getSimpleTx (tail blockValueTxs)
+ import_txs <- map txValue <$> mapM getSimpleTx (tail blockValueTxs)
runMonadImport $ do
mapM_ deleteTransaction blockValueTxs
revertBlock
@@ -803,6 +836,7 @@ revertBestBlock = do
writeTVar base_height_box height
writeTVar peer_box Nothing
+-- | Validate a transaction without script evaluation.
validateTx :: Monad m => OutputMap -> Tx -> ExceptT TxException m ()
validateTx outputs tx = do
prev_outs <-
@@ -815,6 +849,7 @@ validateTx outputs tx = do
sum_outputs = sum (map outValue (txOut tx))
when (sum_outputs > sum_inputs) (throwError OverSpend)
+-- | Import a transaction.
importTransaction ::
(MonadBlock m, MonadImport m) => Tx -> Maybe BlockRef -> m Bool
importTransaction tx maybe_block_ref =
@@ -847,7 +882,7 @@ importTransaction tx maybe_block_ref =
$(logInfoS) "BlockStore " $
"Got orphan tx hash: " <> cs (txHashToHex (txHash tx))
db <- asks myBlockDB
- R.insert db (OrphanTxKey (txHash tx)) tx
+ R.insert db (OrphanKey (txHash tx)) tx
validate_tx
| isJust maybe_block_ref = return () -- only validate unconfirmed
| otherwise = do
@@ -889,6 +924,7 @@ importTransaction tx maybe_block_ref =
, outSpender = Nothing
}
+-- | Attempt to synchronize blocks.
syncBlocks :: MonadBlock m => m ()
syncBlocks =
void . runMaybeT $ do
@@ -898,7 +934,7 @@ syncBlocks =
let chain_height = nodeHeight chain_best
base_height_box <- asks myBaseHeight
db <- asks myBlockDB
- best_block <- getBestBlock db Nothing
+ best_block <- withSnapshot db $ getBestBlock db
let best_height = blockValueHeight best_block
when (best_height == chain_height) $ do
reset_peer best_height
@@ -943,7 +979,7 @@ syncBlocks =
revert_if_needed chain_best = do
db <- asks myBlockDB
ch <- asks myChain
- best <- getBestBlock db Nothing
+ best <- withSnapshot db $ getBestBlock db
let best_hash = headerHash (blockValueHeader best)
chain_hash = headerHash (nodeHeader chain_best)
when (best_hash /= chain_hash) $
@@ -959,24 +995,28 @@ syncBlocks =
revert_until split = do
best_hash <-
asks myBlockDB >>= \db ->
- headerHash . blockValueHeader <$> getBestBlock db Nothing
+ headerHash . blockValueHeader <$>
+ withSnapshot db (getBestBlock db)
when (best_hash /= split) $ do
revertBestBlock
revert_until split
-importBlock :: (MonadError String m, MonadBlock m) => Block -> m ()
+-- | Import a block.
+importBlock ::
+ (MonadError String m, MonadBlock m) => Block -> m ()
importBlock block@Block {..} = do
bn <- asks myChain >>= chainGetBlock (headerHash blockHeader)
when (isNothing bn) $
throwString $
"Not in chain: block hash" <>
cs (blockHashToHex (headerHash blockHeader))
- best <- asks myBlockDB >>= \db -> getBestBlock db Nothing
+ best <- asks myBlockDB >>= \db -> withSnapshot db $ getBestBlock db
let best_hash = headerHash (blockValueHeader best)
prev_hash = prevBlock blockHeader
when (prev_hash /= best_hash) (throwError "does not build on best")
addNewBlock block
+-- | Process incoming messages to the 'BlockStore' mailbox.
processBlockMessage :: (MonadUnliftIO m, MonadBlock m) => BlockMessage -> m ()
processBlockMessage (BlockChainNew _) = syncBlocks
@@ -1008,7 +1048,7 @@ processBlockMessage (BlockPeerDisconnect p) = do
peer_box <- asks myPeer
base_height_box <- asks myBaseHeight
db <- asks myBlockDB
- best <- getBestBlock db Nothing
+ best <- withSnapshot db $ getBestBlock db
is_my_peer <-
atomically $
readTVar peer_box >>= \x ->
@@ -1040,11 +1080,11 @@ processBlockMessage (TxAvailable p ts) =
has <-
fmap catMaybes . forM ts $ \t ->
let mem =
- retrieve db Nothing (MempoolTx t) >>= \case
+ retrieve db Nothing (MempoolKey t) >>= \case
Nothing -> return Nothing
Just () -> return (Just t)
orp =
- retrieve db Nothing (OrphanTxKey t) >>= \case
+ retrieve db Nothing (OrphanKey t) >>= \case
Nothing -> return Nothing
Just Tx {} -> return (Just t)
in runMaybeT $ MaybeT mem <|> MaybeT orp
@@ -1062,82 +1102,56 @@ processBlockMessage (PongReceived p n) = do
"Pong received with nonce " <> cs (show n) <> " from peer " <> pstr
asks myListener >>= atomically . ($ PeerPong p n)
+-- | Import orphan transactions that can be imported.
importOrphans :: (MonadUnliftIO m, MonadBlock m) => m ()
importOrphans = do
db <- asks myBlockDB
ret <-
runResourceT . runConduit $
- matching db Nothing OrphanKey .| mapMC (import_tx . snd) .| anyC id
+ matching db Nothing ShortOrphanKey .| mapMC (import_tx . snd) .| anyC id
when ret importOrphans
where
import_tx tx' = runMonadImport $ importTransaction tx' Nothing
-getAddrOutputs ::
+getAddrTxs ::
(MonadResource m, MonadUnliftIO m)
- => Address
+ => Network
+ -> Address
-> Maybe BlockHeight
-> DB
- -> Maybe Snapshot
- -> ConduitT () AddrOutput m ()
-getAddrOutputs a h db s =
- case s of
- Nothing -> R.withSnapshotBracket db $ f . Just
- Just _ -> f s
+ -> Snapshot
+ -> ConduitT () DetailedTx m ()
+getAddrTxs net a h db s =
+ matchingSkip db (Just s) (ShortAddrTxKey a) (ShortAddrTxKeyHeight a h) .|
+ concatMapMC f
where
- f s' = mergeSourcesBy (flip compare) [p s', u s']
- u s' = getAddrUnspent a h db s' .| mapC (uncurry AddrOutput)
- p s' = getAddrSpent a h db s' .| mapC (uncurry AddrOutput)
-
-
-getAddrsOutputs ::
- (MonadResource m, MonadUnliftIO m)
- => [Address]
- -> Maybe BlockHeight
- -> DB
- -> Maybe Snapshot
- -> ConduitT () AddrOutput m ()
-getAddrsOutputs as h db s =
- if isJust s
- then f s
- else R.withSnapshotBracket db $ \s' -> f (Just s')
- where
- f s' = forM_ as $ \a -> getAddrOutputs a h db s'
-
-getUnspents ::
- (MonadResource m, MonadUnliftIO m)
- => [Address]
- -> Maybe BlockHeight
- -> DB
- -> Maybe Snapshot
- -> ConduitT () AddrOutput m ()
-getUnspents as h db s =
- case s of
- Nothing -> R.withSnapshotBracket db $ f . Just
- Just _ -> f s
- where
- f s' = forM_ as $ \a -> getUnspent a h db s'
+ f (AddrTxKey {..}, ()) = getTx net addrTxHash db s
+ f _ = throwString "Nonsense! This ship in unsinkable!"
+-- | Get unspent outputs for an address.
getUnspent ::
(MonadResource m, MonadUnliftIO m)
=> Address
-> Maybe BlockHeight
-> DB
- -> Maybe Snapshot
+ -> Snapshot
-> ConduitT () AddrOutput m ()
-getUnspent addr h db s =
- getAddrUnspent addr h db s .| mapC (uncurry AddrOutput)
+getUnspent a h db s =
+ getAddrUnspent a h db s .| mapC (uncurry AddrOutput)
+-- | Synchronize mempool against a peer.
syncMempool :: MonadBlock m => Peer -> m ()
syncMempool p =
void . runMaybeT $ do
- guard =<< isAtHeight
+ guard =<< lift isAtHeight
$(logInfoS) "Block" "Syncing mempool..."
MMempool `sendMessage` p
+-- | Is the block store synchronized?
isAtHeight :: MonadBlock m => m Bool
isAtHeight = do
db <- asks myBlockDB
- bb <- getBestBlockHash db Nothing
+ bb <- withSnapshot db $ getBestBlockHash db
ch <- asks myChain
cb <- chainGetBest ch
time <- liftIO getPOSIXTime
@@ -1147,36 +1161,15 @@ isAtHeight = do
zero :: TxHash
zero = "0000000000000000000000000000000000000000000000000000000000000000"
+-- | Show outpoint in log.
showOutPoint :: (IsString a, ConvertibleStrings Text a) => OutPoint -> a
showOutPoint OutPoint {..} =
cs $ txHashToHex outPointHash <> ":" <> cs (show outPointIndex)
+-- | Show peer data in log.
peerString :: (MonadBlock m, IsString a) => Peer -> m a
peerString p = do
mgr <- asks myManager
managerGetPeer mgr p >>= \case
Nothing -> return "[unknown]"
Just o -> return $ fromString $ show $ onlinePeerAddress o
-
--- | Merge multiple sorted sources into one sorted producer using specified
--- sorting function. Adapted from: <https://github.com/cblp/conduit-merge>
-mergeSourcesBy ::
- (Foldable f, Monad m)
- => (a -> a -> Ordering)
- -> f (ConduitT () a m ())
- -> ConduitT i a m ()
-mergeSourcesBy f = mergeSealed . fmap sealConduitT . toList
- where
- mergeSealed sources = do
- prefetchedSources <- lift $ traverse ($$++ await) sources
- go [(a, s) | (s, Just a) <- prefetchedSources]
- go [] = pure ()
- go sources = do
- let (a, src1):sources1 = sortBy (f `on` fst) sources
- yield a
- (src2, mb) <- lift $ src1 $$++ await
- let sources2 =
- case mb of
- Nothing -> sources1
- Just b -> (b, src2) : sources1
- go sources2
diff --git a/src/Network/Haskoin/Store/Types.hs b/src/Network/Haskoin/Store/Types.hs
index 97afbdb..2f74819 100644
--- a/src/Network/Haskoin/Store/Types.hs
+++ b/src/Network/Haskoin/Store/Types.hs
@@ -7,12 +7,11 @@
module Network.Haskoin.Store.Types where
import Control.Applicative
-import Control.Concurrent.NQE
import Control.Exception
import Control.Monad.Reader
import Data.Aeson as A
import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as B
import Data.Function
import Data.Int
import Data.Maybe
@@ -22,24 +21,39 @@ import Data.Word
import Database.RocksDB (DB)
import Database.RocksDB.Query as R
import Haskoin
-import Network.Haskoin.Node
-import UnliftIO
+import Haskoin.Node
+import NQE
+-- | Reasons why a transaction may not get imported.
data TxException
= DoubleSpend
+ -- ^ outputs already spent by another transaction
| OverSpend
+ -- ^ outputs larger than inputs
| OrphanTx
+ -- ^ inputs unknown
| NonStandard
+ -- ^ non-standard transaction rejected by peer
| LowFee
+ -- ^ pony up
| Dust
+ -- ^ an output is too small
| NoPeers
+ -- ^ no peers to send the transaction to
| InvalidTx
+ -- ^ transaction is invalid in some other way
| CouldNotImport
+ -- ^ could not import for an unknown reason
| PeerIsGone
+ -- ^ the peer that got the transaction disconnected
| AlreadyImported
+ -- ^ the transaction is already in the database
| PublishTimeout
+ -- ^ some timeout was reached while publishing
| PeerRejectOther
+ -- ^ peer rejected transaction for unknown reason
| NotAtHeight
+ -- ^ this node is not yet synchronized
deriving (Eq)
instance Show TxException where
@@ -60,81 +74,131 @@ instance Show TxException where
instance Exception TxException
+-- | Wrapper for an transaction that can be deserialized from a JSON object.
newtype NewTx = NewTx
{ newTx :: Tx
} deriving (Show, Eq, Ord)
+-- | Configuration for a block store.
data BlockConfig = BlockConfig
{ blockConfMailbox :: !BlockStore
+ -- ^ block store mailbox
, blockConfManager :: !Manager
+ -- ^ peer manager from running node
, blockConfChain :: !Chain
+ -- ^ chain from a running node
, blockConfListener :: !(Listen StoreEvent)
+ -- ^ listener for store events
, blockConfDB :: !DB
+ -- ^ RocksDB database handle
, blockConfNet :: !Network
+ -- ^ network constants
}
+-- | Event that the store can generate.
data StoreEvent
= BestBlock !BlockHash
+ -- ^ new best block
| MempoolNew !TxHash
+ -- ^ new mempool transaction
| TxException !TxHash
!TxException
+ -- ^ published tx could not be imported
| PeerConnected !Peer
+ -- ^ new peer connected
| PeerDisconnected !Peer
+ -- ^ peer has disconnected
| PeerPong !Peer
!Word64
+ -- ^ peer responded 'Ping'
+-- | Messages that a 'BlockStore' can accept.
data BlockMessage
= BlockChainNew !BlockNode
+ -- ^ new block header in chain
| BlockPeerConnect !Peer
+ -- ^ new peer connected
| BlockPeerDisconnect !Peer
+ -- ^ peer disconnected
| BlockReceived !Peer
!Block
+ -- ^ new block received from a peer
| BlockNotReceived !Peer
!BlockHash
+ -- ^ peer could not deliver a block
| TxReceived !Peer
!Tx
+ -- ^ transaction received from a peer
| TxAvailable !Peer
![TxHash]
+ -- ^ peer has transactions available
| TxPublished !Tx
+ -- ^ transaction has been published successfully
| PongReceived !Peer
!Word64
+ -- ^ peer responded to a 'Ping'
+-- | Mailbox for block store.
type BlockStore = Inbox BlockMessage
-data AddrOutputKey
- = AddrOutputKey { addrOutputSpent :: !Bool
- , addrOutputAddress :: !Address
- , addrOutputHeight :: !(Maybe BlockHeight)
- , addrOutputPos :: !(Maybe Word32)
- , addrOutPoint :: !OutPoint }
- | MultiAddrOutputKey { addrOutputSpent :: !Bool
- , addrOutputAddress :: !Address }
- | MultiAddrHeightKey { addrOutputSpent :: !Bool
- , addrOutputAddress :: !Address
- , addrOutputHeight :: !(Maybe BlockHeight) }
+-- | Database key for an address transaction.
+data AddrTxKey
+ = AddrTxKey { addrTxKey :: !Address
+ , addrTxHeight :: !(Maybe BlockHeight)
+ , addrTxPos :: !(Maybe Word32)
+ , addrTxHash :: !TxHash }
+ -- ^ key for a transaction affecting an address
+ | ShortAddrTxKey { addrTxKey :: !Address }
+ | ShortAddrTxKeyHeight { addrTxKey :: !Address
+ , addrTxHeight :: !(Maybe BlockHeight)}
+ -- ^ short key that matches all entries
deriving (Show, Eq)
-instance Ord AddrOutputKey where
+-- | Database key for an address output.
+data AddrOutKey
+ = AddrOutKey { addrOutputAddress :: !Address
+ , addrOutputHeight :: !(Maybe BlockHeight)
+ , addrOutputPos :: !(Maybe Word32)
+ , addrOutPoint :: !OutPoint }
+ -- ^ full key
+ | ShortAddrOutKey { addrOutputAddress :: !Address }
+ -- ^ short key for all spent or unspent outputs
+ | ShortAddrOutKeyHeight { addrOutputAddress :: !Address
+ , addrOutputHeight :: !(Maybe BlockHeight) }
+ -- ^ short key for all outputs at a given height
+ deriving (Show, Eq)
+
+instance Ord AddrOutKey where
compare = compare `on` f
where
- f AddrOutputKey {..} =
+ f AddrOutKey {..} =
( fromMaybe maxBound addrOutputHeight
, fromMaybe maxBound addrOutputPos
, outPointIndex addrOutPoint)
f _ = undefined
+-- | Database value for a block entry.
data BlockValue = BlockValue
{ blockValueHeight :: !BlockHeight
+ -- ^ height of the block in the chain
, blockValueWork :: !BlockWork
+ -- ^ accumulated work in that block
, blockValueHeader :: !BlockHeader
+ -- ^ block header
, blockValueSize :: !Word32
+ -- ^ size of the block including witnesses
, blockValueTxs :: ![TxHash]
+ -- ^ block transactions
} deriving (Show, Eq, Ord)
+-- | Reference to a block where a transaction is stored.
data BlockRef = BlockRef
{ blockRefHash :: !BlockHash
+ -- ^ block header hash
, blockRefHeight :: !BlockHeight
+ -- ^ block height in the chain
, blockRefPos :: !Word32
+ -- ^ position of transaction within the block
} deriving (Show, Eq)
instance Ord BlockRef where
@@ -142,70 +206,116 @@ instance Ord BlockRef where
where
f BlockRef {..} = (blockRefHeight, blockRefPos)
+-- | Detailed transaction information.
data DetailedTx = DetailedTx
{ detailedTxData :: !Tx
+ -- ^ 'Tx' object
, detailedTxFee :: !Word64
+ -- ^ transaction fees paid to miners in satoshi
, detailedTxInputs :: ![DetailedInput]
+ -- ^ transaction inputs
, detailedTxOutputs :: ![DetailedOutput]
+ -- ^ transaction outputs
, detailedTxBlock :: !(Maybe BlockRef)
+ -- ^ block information for this transaction
} deriving (Show, Eq)
+-- | Input information.
data DetailedInput
= DetailedCoinbase { detInOutPoint :: !OutPoint
+ -- ^ output being spent (should be zeroes)
, detInSequence :: !Word32
+ -- ^ sequence
, detInSigScript :: !ByteString
- , detInNetwork :: !Network }
+ -- ^ input script data (not valid script)
+ , detInNetwork :: !Network
+ -- ^ network constants
+ }
+ -- ^ coinbase input details
| DetailedInput { detInOutPoint :: !OutPoint
+ -- ^ output being spent
, detInSequence :: !Word32
+ -- ^ sequence
, detInSigScript :: !ByteString
+ -- ^ signature (input) script
, detInPkScript :: !ByteString
+ -- ^ pubkey (output) script from previous tx
, detInValue :: !Word64
+ -- ^ amount in satoshi being spent spent
, detInBlock :: !(Maybe BlockRef)
- , detInNetwork :: !Network }
+ -- ^ block where this input is found
+ , detInNetwork :: !Network
+ -- ^ network constants
+ }
+ -- ^ regular input details
deriving (Show, Eq)
isCoinbase :: DetailedInput -> Bool
isCoinbase DetailedCoinbase {} = True
isCoinbase _ = False
+-- | Output information.
data DetailedOutput = DetailedOutput
{ detOutValue :: !Word64
+ -- ^ amount in satoshi
, detOutScript :: !ByteString
+ -- ^ pubkey (output) script
, detOutSpender :: !(Maybe Spender)
+ -- ^ input spending this transaction
, detOutNetwork :: !Network
+ -- ^ network constants
} deriving (Show, Eq)
+-- | Address balance information.
data AddressBalance = AddressBalance
{ addressBalAddress :: !Address
+ -- ^ address balance
, addressBalConfirmed :: !Word64
+ -- ^ confirmed balance
, addressBalUnconfirmed :: !Int64
- , addressOutputCount :: !Word64
- , addressSpentCount :: !Word64
+ -- ^ unconfirmed balance (can be negative)
+ , addressUtxoCount :: !Word64
+ -- ^ number of unspent outputs
} deriving (Show, Eq)
+-- | Transaction record in database.
data TxRecord = TxRecord
{ txValueBlock :: !(Maybe BlockRef)
+ -- ^ block information
, txValue :: !Tx
+ -- ^ transaction data
, txValuePrevOuts :: [(OutPoint, PrevOut)]
+ -- ^ previous output information
} deriving (Show, Eq, Ord)
+-- | Output key in database.
newtype OutputKey = OutputKey
{ outPoint :: OutPoint
} deriving (Show, Eq, Ord)
+-- | Previous output data.
data PrevOut = PrevOut
{ prevOutValue :: !Word64
+ -- ^ value of output in satoshi
, prevOutBlock :: !(Maybe BlockRef)
+ -- ^ block information for spent output
, prevOutScript :: !ByteString
+ -- ^ pubkey (output) script
} deriving (Show, Eq, Ord)
+-- | Output data.
data Output = Output
{ outputValue :: !Word64
+ -- ^ value of output in satoshi
, outBlock :: !(Maybe BlockRef)
+ -- ^ block infromation for output
, outScript :: !ByteString
+ -- ^ pubkey (output) script
, outSpender :: !(Maybe Spender)
+ -- ^ input spending this output
} deriving (Show, Eq, Ord)
+-- | Prepare previous output.
outputToPrevOut :: Output -> PrevOut
outputToPrevOut Output {..} =
PrevOut
@@ -214,6 +324,7 @@ outputToPrevOut Output {..} =
, prevOutScript = outScript
}
+-- | Convert previous output to unspent output.
prevOutToOutput :: PrevOut -> Output
prevOutToOutput PrevOut {..} =
Output
@@ -223,117 +334,165 @@ prevOutToOutput PrevOut {..} =
, outSpender = Nothing
}
+-- | Information about input spending output.
data Spender = Spender
{ spenderHash :: !TxHash
+ -- ^ input transaction hash
, spenderIndex :: !Word32
+ -- ^ input position in transaction
, spenderBlock :: !(Maybe BlockRef)
+ -- ^ block information
} deriving (Show, Eq, Ord)
+-- | Aggregate key for transactions and outputs.
data MultiTxKey
= MultiTxKey !TxKey
- | MultiTxKeyOutput !OutputKey
- | BaseTxKey !TxHash
+ -- ^ key for transaction
+ | MultiTxOutKey !OutputKey
+ -- ^ key for output
+ | ShortMultiTxKey !TxHash
+ -- ^ short key that matches all
deriving (Show, Eq, Ord)
+-- | Aggregate database key for transactions and outputs.
data MultiTxValue
= MultiTx !TxRecord
+ -- ^ transaction record
| MultiTxOutput !Output
+ -- ^ records for all outputs
deriving (Show, Eq, Ord)
+-- | Transaction database key.
newtype TxKey =
TxKey TxHash
deriving (Show, Eq, Ord)
-data MempoolTx
- = MempoolTx TxHash
- | MempoolKey
+-- | Mempool transaction database key.
+data MempoolKey
+ = MempoolKey TxHash
+ -- ^ key for a mempool transaction
+ | ShortMempoolKey
+ -- ^ short key that matches all
deriving (Show, Eq, Ord)
-data OrphanTx
- = OrphanTxKey TxHash
- | OrphanKey
+-- | Orphan transaction database key.
+data OrphanKey
+ = OrphanKey TxHash
+ -- ^ key for an orphan transaction
+ | ShortOrphanKey
+ -- ^ short key that matches all
deriving (Show, Eq, Ord)
+-- | Block entry database key.
newtype BlockKey =
BlockKey BlockHash
deriving (Show, Eq, Ord)
+-- | Block height database key.
newtype HeightKey =
HeightKey BlockHeight
deriving (Show, Eq, Ord)
+-- | Address balance database key.
newtype BalanceKey = BalanceKey
{ balanceAddress :: Address
} deriving (Show, Eq)
+-- | Address balance database value.
data Balance = Balance
{ balanceValue :: !Word64
+ -- ^ balance in satoshi
, balanceUnconfirmed :: !Int64
- , balanceOutputCount :: !Word64
- , balanceSpentCount :: !Word64
+ -- ^ unconfirmed balance in satoshi (can be negative)
+ , balanceUtxoCount :: !Word64
+ -- ^ number of unspent outputs
} deriving (Show, Eq, Ord)
+-- | Default balance for an address.
emptyBalance :: Balance
emptyBalance =
Balance
{ balanceValue = 0
, balanceUnconfirmed = 0
- , balanceOutputCount = 0
- , balanceSpentCount = 0
+ , balanceUtxoCount = 0
}
+-- | Key for best block in database.
data BestBlockKey = BestBlockKey deriving (Show, Eq, Ord)
+-- | Address output.
data AddrOutput = AddrOutput
- { addrOutputKey :: !AddrOutputKey
+ { addrOutputKey :: !AddrOutKey
, addrOutput :: !Output
} deriving (Eq, Show)
instance Ord AddrOutput where
compare = compare `on` addrOutputKey
+-- | Serialization format for addresses in database.
newtype StoreAddress = StoreAddress Address
deriving (Show, Eq)
+instance Key BestBlockKey
+ -- 0x00
instance Key BlockKey
-instance Key HeightKey
-instance Key OutputKey
+ -- 0x01 · BlockHash
instance Key TxKey
-instance Key MempoolTx
-instance Key OrphanTx
-instance Key AddrOutputKey
+ -- 0x02 · TxHash · 0x00
+instance Key OutputKey
+ -- 0x02 · TxHash · 0x01 · OutputIndex
+instance Key MultiTxKey
+ -- 0x02 · TxHash
+ -- 0x02 · TxHash · 0x00
+ -- 0x02 · TxHash · 0x01 · OutputIndex
+instance Key HeightKey
+ -- 0x03 · InvBlockHeight
+instance Key BalanceKey
+ -- 0x04 · Storeaddress
+instance Key AddrTxKey
+ -- 0x05 · StoreAddress · InvBlockHeight · InvBlockPos · TxHash
+ -- 0x05 · StoreAddress · InvBlockHeight
+ -- 0x05 · StoreAddress
+instance Key AddrOutKey
+ -- 0x06 · StoreAddress · InvBlockHeight · InvBlockPos
+ -- 0x06 · StoreAddress · InvBlockHeight
+ -- 0x06 · StoreAddress
+instance Key MempoolKey
+ -- 0x07 · TxHash
+ -- 0x07
+instance Key OrphanKey
+ -- 0x08 · TxHash
+ -- 0x08
+
+instance R.KeyValue BestBlockKey BlockHash
instance R.KeyValue BlockKey BlockValue
instance R.KeyValue TxKey TxRecord
-instance R.KeyValue HeightKey BlockHash
-instance R.KeyValue BestBlockKey BlockHash
-instance R.KeyValue OutputKey Output
+instance R.KeyValue AddrOutKey Output
instance R.KeyValue MultiTxKey MultiTxValue
-instance R.KeyValue AddrOutputKey Output
+instance R.KeyValue HeightKey BlockHash
instance R.KeyValue BalanceKey Balance
-instance R.KeyValue MempoolTx ()
-instance R.KeyValue OrphanTx Tx
+instance R.KeyValue AddrTxKey ()
+instance R.KeyValue OutputKey Output
+instance R.KeyValue MempoolKey ()
+instance R.KeyValue OrphanKey Tx
-instance Serialize MempoolTx where
- put (MempoolTx h) = do
+instance Serialize MempoolKey where
+ put (MempoolKey h) = do
putWord8 0x07
put h
- put MempoolKey = putWord8 0x07
+ put ShortMempoolKey = putWord8 0x07
get = do
guard . (== 0x07) =<< getWord8
- record <|> return MempoolKey
- where
- record = MempoolTx <$> get
+ MempoolKey <$> get
-instance Serialize OrphanTx where
- put (OrphanTxKey h) = do
+instance Serialize OrphanKey where
+ put (OrphanKey h) = do
putWord8 0x08
put h
- put OrphanKey = putWord8 0x08
+ put ShortOrphanKey = putWord8 0x08
get = do
guard . (== 0x08) =<< getWord8
- record <|> return OrphanKey
- where
- record = OrphanTxKey <$> get
+ OrphanKey <$> get
instance Serialize BalanceKey where
put BalanceKey {..} = do
@@ -348,40 +507,65 @@ instance Serialize Balance where
put Balance {..} = do
put balanceValue
put balanceUnconfirmed
- put balanceOutputCount
- put balanceSpentCount
+ put balanceUtxoCount
get = do
balanceValue <- get
balanceUnconfirmed <- get
- balanceOutputCount <- get
- balanceSpentCount <- get
+ balanceUtxoCount <- get
return Balance {..}
-addrKeyStart :: Bool -> Address -> Put
-addrKeyStart b a = do
- putWord8 $ if b then 0x03 else 0x05
- put (StoreAddress a)
-
-instance Serialize AddrOutputKey where
- put AddrOutputKey {..} = do
- addrKeyStart addrOutputSpent addrOutputAddress
+instance Serialize AddrTxKey where
+ put AddrTxKey {..} = do
+ putWord8 0x05
+ put $ StoreAddress addrTxKey
+ put (maybe 0 (maxBound -) addrTxHeight)
+ put (maybe 0 (maxBound -) addrTxPos)
+ put addrTxHash
+ put ShortAddrTxKey {..} = do
+ putWord8 0x05
+ put $ StoreAddress addrTxKey
+ put ShortAddrTxKeyHeight {..} = do
+ putWord8 0x05
+ put $ StoreAddress addrTxKey
+ put (maybe 0 (maxBound -) addrTxHeight)
+ get = do
+ guard . (== 0x05) =<< getWord8
+ StoreAddress addrTxKey <- get
+ h <- (maxBound -) <$> get
+ let addrTxHeight
+ | h == 0 = Nothing
+ | otherwise = Just h
+ p <- (maxBound -) <$> get
+ let addrTxPos
+ | p == 0 = Nothing
+ | otherwise = Just p
+ addrTxHash <- get
+ return AddrTxKey {..}
+
+-- | Beginning of address output database key.
+addrKeyStart :: Address -> Put
+addrKeyStart a = put (StoreAddress a)
+
+instance Serialize AddrOutKey where
+ put AddrOutKey {..} = do
+ putWord8 0x06
+ put $ StoreAddress addrOutputAddress
put (maybe 0 (maxBound -) addrOutputHeight)
put (maybe 0 (maxBound -) addrOutputPos)
put addrOutPoint
- put MultiAddrOutputKey {..} = addrKeyStart addrOutputSpent addrOutputAddress
- put MultiAddrHeightKey {..} = do
- addrKeyStart addrOutputSpent addrOutputAddress
+ put ShortAddrOutKey {..} = do
+ putWord8 0x06
+ put $ StoreAddress addrOutputAddress
+ put ShortAddrOutKeyHeight {..} = do
+ putWord8 0x06
+ put $ StoreAddress addrOutputAddress
put (maybe 0 (maxBound -) addrOutputHeight)
get = do
- addrOutputSpent <-
- getWord8 >>= \case
- 0x03 -> return True
- 0x05 -> return False
- _ -> mzero
+ guard . (== 0x06) =<< getWord8
StoreAddress addrOutputAddress <- get
- record addrOutputSpent addrOutputAddress
+ record addrOutputAddress
where
- record addrOutputSpent addrOutputAddress = do
+ record addrOutputAddress = do
h <- (maxBound -) <$> get
let addrOutputHeight | h == 0 = Nothing
| otherwise = Just h
@@ -389,22 +573,18 @@ instance Serialize AddrOutputKey where
let addrOutputPos | p == 0 = Nothing
| otherwise = Just p
addrOutPoint <- get
- return AddrOutputKey {..}
+ return AddrOutKey {..}
instance Serialize MultiTxKey where
- put (MultiTxKey k) = put k
- put (MultiTxKeyOutput k) = put k
- put (BaseTxKey k) = putWord8 0x02 >> put k
- get = MultiTxKey <$> get <|> MultiTxKeyOutput <$> get <|> base
- where
- base = do
- guard . (== 0x02) =<< getWord8
- BaseTxKey <$> get
+ put (MultiTxKey k) = put k
+ put (MultiTxOutKey k) = put k
+ put (ShortMultiTxKey k) = putWord8 0x02 >> put k
+ get = MultiTxKey <$> get <|> MultiTxOutKey <$> get
instance Serialize MultiTxValue where
put (MultiTx v) = put v
put (MultiTxOutput v) = put v
- get = (MultiTx <$> get) <|> (MultiTxOutput <$> get)
+ get = MultiTx <$> get <|> MultiTxOutput <$> get
instance Serialize Spender where
put Spender {..} = do
@@ -435,7 +615,7 @@ instance Serialize PrevOut where
put PrevOut {..} = do
put prevOutValue
put prevOutBlock
- put (BS.length prevOutScript)
+ put (B.length prevOutScript)
putByteString prevOutScript
get = do
prevOutValue <- get
@@ -483,9 +663,9 @@ instance Serialize TxRecord where
return TxRecord {..}
instance Serialize BestBlockKey where
- put BestBlockKey = put (BS.replicate 32 0x00)
+ put BestBlockKey = put (B.replicate 32 0x00)
get = do
- guard . (== BS.replicate 32 0x00) =<< getBytes 32
+ guard . (== B.replicate 32 0x00) =<< getBytes 32
return BestBlockKey
instance Serialize BlockValue where
@@ -503,6 +683,7 @@ instance Serialize BlockValue where
blockValueTxs <- get
return BlockValue {..}
+-- | Byte identifying network for an address.
netByte :: Network -> Word8
netByte net | net == btc = 0x00
| net == btcTest = 0x01
@@ -512,6 +693,7 @@ netByte net | net == btc = 0x00
| net == bchRegTest = 0x06
| otherwise = 0xff
+-- | Network from its corresponding byte.
byteNet :: Word8 -> Maybe Network
byteNet 0x00 = Just btc
byteNet 0x01 = Just btcTest
@@ -521,6 +703,7 @@ byteNet 0x05 = Just bchTest
byteNet 0x06 = Just bchRegTest
byteNet _ = Nothing
+-- | Deserializer for network byte.
getByteNet :: Get Network
getByteNet =
byteNet <$> getWord8 >>= \case
@@ -569,6 +752,7 @@ instance Serialize StoreAddress where
h <- get
return (WitnessScriptAddress h net)
+-- | JSON serialization for 'BlockValue'.
blockValuePairs :: A.KeyValue kv => BlockValue -> [kv]
blockValuePairs BlockValue {..} =
[ "hash" .= headerHash blockValueHeader
@@ -590,6 +774,7 @@ instance ToJSON Spender where
toJSON = object . spenderPairs
toEncoding = pairs . mconcat . spenderPairs
+-- | JSON serialization for 'BlockRef'.
blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]
blockRefPairs BlockRef {..} =
[ "hash" .= blockRefHash
@@ -597,10 +782,12 @@ blockRefPairs BlockRef {..} =
, "position" .= blockRefPos
]
+-- | JSON serialization for 'Spender'.
spenderPairs :: A.KeyValue kv => Spender -> [kv]
spenderPairs Spender {..} =
["txid" .= spenderHash, "input" .= spenderIndex, "block" .= spenderBlock]
+-- | JSON serialization for a 'DetailedOutput'.
detailedOutputPairs :: A.KeyValue kv => DetailedOutput -> [kv]
detailedOutputPairs DetailedOutput {..} =
[ "address" .= scriptToAddressBS detOutNetwork detOutScript
@@ -614,6 +801,7 @@ instance ToJSON DetailedOutput where
toJSON = object . detailedOutputPairs
toEncoding = pairs . mconcat . detailedOutputPairs
+-- | JSON serialization for 'DetailedInput'.
detailedInputPairs :: A.KeyValue kv => DetailedInput -> [kv]
detailedInputPairs DetailedInput {..} =
[ "txid" .= outPointHash detInOutPoint
@@ -642,10 +830,11 @@ instance ToJSON DetailedInput where
toJSON = object . detailedInputPairs
toEncoding = pairs . mconcat . detailedInputPairs
+-- | JSON serialization for 'DetailedTx'.
detailedTxPairs :: A.KeyValue kv => DetailedTx -> [kv]
detailedTxPairs DetailedTx {..} =
[ "txid" .= txHash detailedTxData
- , "size" .= BS.length (S.encode detailedTxData)
+ , "size" .= B.length (S.encode detailedTxData)
, "version" .= txVersion detailedTxData
, "locktime" .= txLockTime detailedTxData
, "fee" .= detailedTxFee
@@ -663,6 +852,7 @@ instance ToJSON BlockRef where
toJSON = object . blockRefPairs
toEncoding = pairs . mconcat . blockRefPairs
+-- | JSON serialization for 'AddrOutput'.
addrOutputPairs :: A.KeyValue kv => AddrOutput -> [kv]
addrOutputPairs AddrOutput {..} =
[ "address" .= addrOutputAddress
@@ -673,7 +863,7 @@ addrOutputPairs AddrOutput {..} =
]
where
Output {..} = addrOutput
- AddrOutputKey {..} = addrOutputKey
+ AddrOutKey {..} = addrOutputKey
dout =
DetailedOutput
{ detOutValue = outputValue
@@ -686,13 +876,13 @@ instance ToJSON AddrOutput where
toJSON = object . addrOutputPairs
toEncoding = pairs . mconcat . addrOutputPairs
+-- | JSON serialization for 'AddressBalance'.
addressBalancePairs :: A.KeyValue kv => AddressBalance -> [kv]
addressBalancePairs AddressBalance {..} =
[ "address" .= addressBalAddress
, "confirmed" .= addressBalConfirmed
, "unconfirmed" .= addressBalUnconfirmed
- , "outputs" .= addressOutputCount
- , "utxo" .= (addressOutputCount - addressSpentCount)
+ , "utxo" .= addressUtxoCount
]
instance FromJSON NewTx where
@@ -731,17 +921,28 @@ instance Serialize TxKey where
guard . (== 0x00) =<< getWord8
return (TxKey hash)
-type StoreSupervisor n = Inbox (SupervisorMessage n)
-
-data StoreConfig n = StoreConfig
- { storeConfBlocks :: !BlockStore
- , storeConfSupervisor :: !(StoreSupervisor n)
- , storeConfManager :: !Manager
- , storeConfChain :: !Chain
- , storeConfPublisher :: !(Publisher Inbox TBQueue StoreEvent)
- , storeConfMaxPeers :: !Int
- , storeConfInitPeers :: ![HostPort]
- , storeConfDiscover :: !Bool
- , storeConfDB :: !DB
- , storeConfNetwork :: !Network
+-- | Configuration for a 'Store'.
+data StoreConfig = StoreConfig
+ { storeConfMaxPeers :: !Int
+ -- ^ max peers to connect to
+ , storeConfInitPeers :: ![HostPort]
+ -- ^ static set of peers to connect to
+ , storeConfDiscover :: !Bool
+ -- ^ discover new peers?
+ , storeConfDB :: !DB
+ -- ^ RocksDB database handler
+ , storeConfNetwork :: !Network
+ -- ^ network constants
+ }
+
+-- | Store mailboxes.
+data Store = Store
+ { storeManager :: !Manager
+ -- ^ peer manager mailbox
+ , storeChain :: !Chain
+ -- ^ chain header process mailbox
+ , storeBlock :: !BlockStore
+ -- ^ block storage mailbox
+ , storePublisher :: !(Publisher StoreEvent)
+ -- ^ store event publisher mailbox
}
diff --git a/test/Spec.hs b/test/Spec.hs
index 61e41bc..cb509ca 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,17 +1,16 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-import Control.Concurrent.NQE
import Control.Monad
import Control.Monad.Logger
+import Control.Monad.Trans
import Data.Maybe
-import Database.RocksDB (DB)
-import qualified Database.RocksDB as RocksDB
-import Network.Haskoin.Block
-import Network.Haskoin.Constants
-import Network.Haskoin.Node
-import Network.Haskoin.Store
-import Network.Haskoin.Transaction
+import Database.RocksDB (DB)
+import qualified Database.RocksDB as RocksDB
+import Haskoin
+import Haskoin.Node
+import Haskoin.Store
+import NQE
import Test.Hspec
import UnliftIO
@@ -32,13 +31,12 @@ main = do
replicateM 9 . receiveMatch testStoreEvents $ \case
BestBlock b -> Just b
_ -> Nothing
- withAsync (dummyEventHandler testStoreEvents) $ \_ -> do
- let bestHash = last bs
- bestNodeM <- chainGetBlock bestHash testStoreChain
- bestNodeM `shouldSatisfy` isJust
- let bestNode = fromJust bestNodeM
- bestHeight = nodeHeight bestNode
- bestHeight `shouldBe` 8
+ let bestHash = last bs
+ bestNodeM <- chainGetBlock bestHash testStoreChain
+ bestNodeM `shouldSatisfy` isJust
+ let bestNode = fromJust bestNodeM
+ bestHeight = nodeHeight bestNode
+ bestHeight `shouldBe` 8
it "get a block and its transactions" $
withTestStore net "get-block-txs" $ \TestStore {..} -> do
let get_the_block h =
@@ -47,70 +45,51 @@ main = do
| otherwise -> get_the_block ((h :: Int) - 1)
_ -> get_the_block h
bh <- get_the_block 381
- withAsync (dummyEventHandler testStoreEvents) $ \_ -> do
- m <- getBlock bh testStoreDB Nothing
- let BlockValue {..} =
- fromMaybe (error "Could not get block") m
- blockValueHeight `shouldBe` 381
- length blockValueTxs `shouldBe` 2
- let h1 =
- "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22"
- h2 =
- "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c"
- head blockValueTxs `shouldBe` h1
- last blockValueTxs `shouldBe` h2
- t1 <- getTx net h1 testStoreDB Nothing
- t1 `shouldSatisfy` isJust
- txHash (detailedTxData (fromJust t1)) `shouldBe` h1
- t2 <- getTx net h2 testStoreDB Nothing
- t2 `shouldSatisfy` isJust
- txHash (detailedTxData (fromJust t2)) `shouldBe` h2
-
-dummyEventHandler :: (MonadIO m, Mailbox b) => b a -> m ()
-dummyEventHandler = forever . void . receive
+ m <- getBlock bh testStoreDB Nothing
+ let BlockValue {..} =
+ fromMaybe (error "Could not get block") m
+ blockValueHeight `shouldBe` 381
+ length blockValueTxs `shouldBe` 2
+ let h1 =
+ "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22"
+ h2 =
+ "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c"
+ head blockValueTxs `shouldBe` h1
+ last blockValueTxs `shouldBe` h2
+ t1 <- getTx net h1 testStoreDB Nothing
+ t1 `shouldSatisfy` isJust
+ txHash (detailedTxData (fromJust t1)) `shouldBe` h1
+ t2 <- getTx net h2 testStoreDB Nothing
+ t2 `shouldSatisfy` isJust
+ txHash (detailedTxData (fromJust t2)) `shouldBe` h2
withTestStore ::
- Network -> String -> (TestStore -> IO ()) -> IO ()
+ MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a
withTestStore net t f =
withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w ->
runNoLoggingT $ do
- s <- Inbox <$> liftIO newTQueueIO
- c <- Inbox <$> liftIO newTQueueIO
- b <- Inbox <$> liftIO newTQueueIO
- m <- Inbox <$> liftIO newTQueueIO
- p <- Inbox <$> liftIO newTQueueIO
db <-
RocksDB.open
w
RocksDB.defaultOptions
- { RocksDB.createIfMissing = True
- , RocksDB.compression = RocksDB.SnappyCompression
- }
+ { RocksDB.createIfMissing = True
+ , RocksDB.compression = RocksDB.SnappyCompression
+ }
let cfg =
StoreConfig
- { storeConfBlocks = b
- , storeConfSupervisor = s
- , storeConfChain = c
- , storeConfPublisher = p
- , storeConfMaxPeers = 20
- , storeConfInitPeers = []
- , storeConfDiscover = True
- , storeConfDB = db
- , storeConfManager = m
- , storeConfNetwork = net
- }
- withAsync (store cfg) $ \a ->
- withBoundedPubSub 100 p $ \sub -> do
- link a
- x <-
- liftIO $
- f
- TestStore
+ { storeConfMaxPeers = 20
+ , storeConfInitPeers = []
+ , storeConfDiscover = True
+ , storeConfDB = db
+ , storeConfNetwork = net
+ }
+ withStore cfg $ \Store {..} ->
+ withPubSub storePublisher newTQueueIO $ \sub ->
+ lift $
+ f
+ TestStore
{ testStoreDB = db
- , testStoreBlockStore = b
- , testStoreChain = c
- , testStoreEvents = Inbox sub
+ , testStoreBlockStore = storeBlock
+ , testStoreChain = storeChain
+ , testStoreEvents = sub
}
- stopSupervisor s
- wait a
- return x