haskoin-store 0.24.0 → 0.25.1
raw patch · 16 files changed
+545/−2821 lines, 16 filesdep +haskoin-store-datadep ~haskoin-coredep ~haskoin-node
Dependencies added: haskoin-store-data
Dependency ranges changed: haskoin-core, haskoin-node
Files
- CHANGELOG.md +0/−757
- README.md +0/−35
- haskoin-store.cabal +11/−12
- src/Haskoin/Store.hs +22/−65
- src/Haskoin/Store/BlockStore.hs +99/−13
- src/Haskoin/Store/Cache.hs +10/−11
- src/Haskoin/Store/Common.hs +328/−1470
- src/Haskoin/Store/Database/Memory.hs +5/−5
- src/Haskoin/Store/Database/Reader.hs +7/−5
- src/Haskoin/Store/Database/Types.hs +1/−1
- src/Haskoin/Store/Database/Writer.hs +4/−5
- src/Haskoin/Store/Logic.hs +4/−3
- src/Haskoin/Store/Manager.hs +30/−25
- src/Haskoin/Store/Web.hs +23/−56
- test/Haskoin/Store/CacheSpec.hs +1/−1
- test/Haskoin/Store/CommonSpec.hs +0/−357
− CHANGELOG.md
@@ -1,757 +0,0 @@-# Changelog-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.24.0-### Changed-- Use mocking to simulate peers instead of connecting to the network while testing.-- Depend on latest version of Haskoin Core for faster JSON serialisation.-- Clean up confusing JSON encoding/decoding codebase.--## 0.23.24-### Changed-- Implement faster JSON encoding using toEncoding from the Aeson library.--## 0.23.23-### Changed-- Do not read full mempool so often from cache code.--## 0.23.22-### Changed-- Depend on latest Haskoin Node that fixes debugging regression.--## 0.23.21-### Changed-- Reduce non-debug log verbosity.--## 0.23.20-### Changed-- Better Haskoin Node logging.--## 0.23.19-### Changed-- Use set peer timeout instead of constant in block store. --## 0.23.18-### Changed-- Allow setting peer timeouts in command line.--### Fixed-- Bump Haskoin Node dependency to fix another premature timeout condition.--## 0.23.17-### Fixed-- Touch syncing peer whenever we process one of its blocks to avoid premature timeout.--## 0.23.16-### Changed-- Better algorithm to avoid importing transaction multiple times in cache.-- Depend on latest Haskoin Node.--## 0.23.15-### Changed-- Do not storm the cache with mempool transactions.--## 0.23.13-### Fixed-- Do not ignore deleted incoming transactions.--## 0.23.12-### Fixed-- Do not do RBF checks when replacing a mempool transaction with a confirmed one.--## 0.23.11-### Fixed-- Streamline mempool transaction importing.--## 0.23.10-### Fixed-- Fix transactions not recorded in cache mempool set.-- Fix transactions being downloaded multiple times.--### Removed-- Do not store orphan transactions in database.--### Changed-- Use sets for incoming transactions instead of lists.-- Do not do anything to the cache if there are no xpubs in it.--## 0.23.9-### Fixed-- Wiping mempool fixed.--## 0.23.8-### Added-- Chunk transactions to be deleted from mempool.--## 0.23.7-### Added-- Mempool improvements.--## 0.23.6-### Added-- Ability to wipe mempool at start.-- Improvements to mempool processing code.--## 0.23.5-### Changed-- Tighten the locking loop to avoid slow cache building.--## 0.23.5-### Fixed-- Wrong error in cache when acquiring lock.--## 0.23.4-### Added-- Add extra debug logging for cache code.--### Fixed-- Fix a bug with xpub growing algorithm.--### Changed-- Use locks instead of transactions to update cache.--## 0.23.3-### Fixed-- Reduce contention when many instances of Haskoin Store share a cache.--## 0.23.2-### Added-- Allow retrieving xpub data without using cache.--## 0.23.1-### Added-- Allow xpub eviction from cache via API.-- Clarify cache address addition code.--### Fixed-- Balances were incorrectly computed in cache when new transactions arrived.--## 0.23.0-### Added-- Support for Redis transactions.-- Use a smaller initial gap for empty xpubs.--### Changed-- Remove custom JSON encoding class.-- Refactor and code simplification.--## 0.22.5-### Fixed-- Cache was being completely pruned.--## 0.22.4-### Fixed-- Cache now prunes correctly.--## 0.22.3-### Fixed-- Bug was making cache get stuck when pruning.--## 0.22.2-### Changed-- More efficient algorithms for caching and cache misses.-- Better debug logging of cache hits and misses.--## 0.22.1-### Added-- More debug logging for cache hits.--### Fixed-- Bug using maximum against empty list.--## 0.22.0-### Changed-- Extreme code refactoring.-- Move all code to Haskoin and drop Network from modules.--### Added-- Use Redis pipelining when importing multiple transactions into cache.-- Implement configurable LRU for Redis cache.-- Import xpubs directly into cache from web worker thread when a key is requested.--### Removed-- Only expose a few modules to external API.--## 0.21.7-### Changed-- Improve build configuration.--### Fixed-- Use minimum used addresses instead of minimum index for xpub cache decision.--## 0.21.6-### Fixed-- Fix missing xpub unspent outputs when using cache.--## 0.21.5-### Added-- Only store xpubs in cache if they have more than a threshold addresses used.--## 0.21.4-### Fixed-- Fix shared cache case where head is set beyond header chain by another node.--## 0.21.3-### Fixed-- Fix bug where best head was not being registered in cache.-- Fix best head in cache being decoded incorrectly.--## 0.21.2-### Added-- Complete support for Redis xpub cache.--## 0.21.1-### Fixed-- Latest version of secp256k1-haskell works with Debian 9.--## 0.21.0-### Fixed-- Fix output of web API calls when issuing limits with offsets.--### Changed-- Massive refactoring of entire codebase.--### Added-- Work in progress Redis caching for extended public keys.--## 0.20.2-### Changed-- Filter xpub address balances on web API to show only addresses that have been used.--### Removed-- Remove paths and addresses from xpub summary.--## 0.20.1-### Changed-- Refactor code greatly.-- Depend on new Haskoin Store package to avoid missing tx broadcasts.-- Merge StoreStream class into StoreRead.-- Move former streaming functions to use lists instead of conduits.-- Remove excessively verbose debugging.--## 0.20.0-### Added-- Set minimum version bounds for some dependencies.-- Now compatible with GHC 8.8.-- Extended key caching system using Redis.--### Changed-- Massively refactored codebase.-- Less verbose debug logging.--### Removed-- Removed conduits for faster queries.--## 0.19.6-### Added-- Use a parallel strategy to compute key derivations.--### Fixed-- Do not fail health check upon transaction timeout while syncing.--### Changed-- Do not use conduits for xpub balance streams.-- Multiple minor refactorings.--## 0.19.5-### Changed-- Minor refactor to block import code.--### Fixed-- Minor fix to transaction timeout check.--## 0.19.4-### Fixed-- Clarify and correct health check algorithm.--## 0.19.3-### Changed-- Add address transactions to cache.-- Improve multi-address transaction retrieval algorithms.--## 0.19.2-### Removed-- Cache-Control header turned out to be unnecessary.--### Fixed-- Fix some minor errors in web module.--## 0.19.1-### Added-- Set Cache-Control header to no-cache.--## 0.19.0-### Changed-- Store mempool in single key/value pair.--## 0.18.11-### Changed-- Do not stream mempool.--## 0.18.10-### Removed-- Disable timeout checks for testnets.--## 0.18.9-### Added-- Endpoint to locate a block by unix timestamp.--### Removed-- No more persistence for peers due to dependency on newest haskoin-node.--## 0.18.8-### Added-- Transaction and block timeouts for health check.-- Raw blocks.--## 0.18.7-### Fixed-- Missing tranasctions on xpub listings.--## 0.18.6-### Removed-- Follow Stack advise removing `-O2` GHC option.--## 0.18.5-### Added-- Compatibility with SegWit on extended public key endpoints.--### Changed-- Fix syncing peer not reset after timeout.-- Use simpler monad for streaming data.--## 0.18.4-### Changed-- Bump Haskoin Node to fix peers not stored and excessively verbose logging.--## 0.18.3-### Changed-- Configurable HTTP request logging. Disabled by default.--## 0.18.2-### Changed-- Fix for memory leak.--## 0.18.1-### Removed-- Remove transaction count from xpub summary object.--## 0.18.0-### Changed-- Simplified limits and start point handling on web API.-- Made transaction streaming algorithm faster for xpub transactions.-- Extended public key summary output contains all addresses that have received transactions.--### Added-- Fine-grained control for maximum limits via command line options.-- Transaction hash as starting point.-- Block hash as starting point.-- Timestamp as starting point.-- Configurable xpub gap limit.-- Transaction count added to xpub summary.-- UTXO count added to xpub summary.--### Removed-- Mempool endpoint now has no limits or offsets and always returns full list.-- Extended public key summary output no longer includes any transactions.-- Offsets not allowed for transaction lists involving multiple addresses or xpubs.-- Confusing block position parameter no longer part of web API.--## 0.17.2-### Changed-- Stream address balances and unspent outputs.-- Add configurable max value for limit and offset which defaults at 10000.--## 0.17.1-### Changed-- When posting a transaction to the network, timeout is now five seconds.-- Improve error message when transaction post timeout reached.-- Remove obsolete `not found` error for transaction post.-- Endpoints for retrieving blocks now do streaming for better performance.-- Improve Swagger API documentation.--## 0.17.0-### Added-- Endpoints for retrieving block transactions.-- Endpoint for retrieving set of latest blocks.--### Changed-- Use standardized JSON and binary serialization schemes for raw transaction endpoints.--## 0.16.6-### Changed-- Now logging info messages too by default.-- Consolidated web logging in middleware.--### Removed-- UUIDs for web requests.--## 0.16.5-### Removed-- Remove concurrency from xpub balance requests to prevent RocksDB segfaults.--## 0.16.4-### Removed-- Remove concurrency from requests using iterators to prevent RocksDB from segfaulting.--## 0.16.3-### Added-- Debugging information for web API.--## 0.16.2-### Changed-- Debugging disabled by default (use `--debug` to enable).--## 0.16.1-### Added-- Cache mempool transactions.-- Improve initial syncing performance.--## 0.16.0-### Added-- Orphan transaction support.-- Full address balance cache in RocksDB.-- Full unspent output cache in RocksDB.--### Changed-- Significantly refactor code.-- Move web stuff to its own module.-- Change types related to databases.-- Make xpub balance, transaction and unspent queries fetch data in parallel.--## 0.15.2-### Added-- Internal data types to support orphan transactions.--### Changed-- Do not spam block actor with pings.-- Fix balance/unspent cache not reverting when importing fails.-- Fix transaction sorting algorithm not including transaction position information.-- Fix conflicting mempool transaction preventing block from importing.--## 0.15.1-### Changed-- Fix duplicate coinbase transaction id bug.--## 0.15.0-### Removed-- Removed `PreciseUnixTime` data type.--### Changed-- Use 64 bits for Unix time representation.-- Data model now uses simplified Unix time representation.--## 0.14.9-### Added-- Last external/change index information to xpub summary object.--## 0.14.8-### Added-- Endpoint for xpub summaries.-- Endpoints for full transactions.-- Ability to query by offset/limit.-- More API documentation.--## 0.14.7-### Added-- Debug information for `publishTx`.--### Changed-- Transaction publishing no longer requests mempool.-- Fixed serialization for `TxId` freezing the entire program by infinitely recursing.--## 0.14.6-### Changed-- Enable full threading again as it was deemed not responsible for the freezing behaviour.--## 0.14.5-### Changed-- Enable threading but leave it at a single thread to be able to open more than 1024 files.--## 0.14.4-### Changed-- Target LTS Haskell 13.20 and disable threading in new attempt to fix freezing bug.--## 0.14.3-### Changed-- Remove `-O2`.--## 0.14.2-### Changed-- Target LTS Haskell 12.26 to attempt to fix freezing bug.--## 0.14.1-### Added-- Extra debugging around code that freezes.--### Changed-- Bump dependency on `haskoin-node`.--## 0.14.0-### Removed-- Dump slow protobuf serialization.--### Added-- Add custom serialization.-- Extra debug logging.--### Changed-- Bump `haskoin-core` and `haskoin-node`.--## 0.13.1-### Changed-- Bump `haskoin-node` in `stack.yaml`.-- Do not send empty `getdata` messages.--## 0.13.0-### Added-- Primitive content negotiation for web exceptions.-- Protobuf support for errors.-- Protobuf support for tranasction ids.--### Changed-- Protobuf format changed in non-backwards-compatible manner for transaction ids.--## 0.12.0-### Added-- Support for binary serialization using Protocol Buffers.-- New endpoints for binary raw transactions (not hex-encoded).--### Changed-- Services field now a hex string instead of a number to avoid overflowing signed 64-bit integer.-- Flatten list of block data objects when responding to request for multiple block heights.-- Errors now reported in plain text without container JSON object.-- Transaction broadcasts are responded to with transaction id in plaintext hex (no JSON).-- Remove database snapshots to improve performance.--## 0.11.2-### Changed-- Fix duplicate mempool transaction announcements in event stream.--## 0.11.1-### Removed-- Removed latest block time check.--## 0.11.0-### Changed-- Improve post transactions endpoint.--## 0.10.1-### Changed-- Fix bug where transaction lists from multiple addresses would sort incorrectly.-- Address gap reduced to 20.--## 0.10.0-### Removed-- Remove addresses from transaction lists.-- No longer use container objects for xpub transactions.--## 0.9.3-### Added-- Permissive CORS headers to allow queries from any domain.-- Improved documentation using real-world examples from the BCH testnet.--## 0.9.2-### Added-- HTTP JSON API switch to turn off transaction list when retrieving blocks.--## 0.9.1-### Added-- Total block fees.-- Total block outputs.-- Block subsidy.--### Changed-- Do not consider the blocks less one block away from headers as out of sync in health check.-- Health check now returns HTTP 503 when not OK or out of sync.--## 0.9.0-### Added-- Version to health check output.-- Block weight for segwit.-- Transaction weight for segwit.--## 0.8.1-### Added-- Health check endpoint.--## 0.8.0-### Added-- Limits and skips.-- Add timestamps to transactions.-- Add transaction count to address balance object.-- Add Merkle root to block data.-- Total funds received by an address now shows up in balance.-- Balances for any address that ever had funds show up in xpub endpoints.--### Changed-- Data model update.-- Performance improvement for xpub calls.-- Transactions are returned in reverse mempool/block order (highest or most recent first).-- Balance objects do not get deleted from database ever.--## 0.6.9-### Changed-- Reduce number of coinbase checks to 10,000 ancestors.--## 0.6.8-### Changed-- Further optimize coinbase after height checks.--## 0.6.7-### Changed-- Impose restrictions on recursion for coinbase after height checks.--## 0.6.6-### Added-- Check whether a transaction can be traced back to a coinbase after certain height.--## 0.6.5-### Changed-- Delete transactions in reverse topological order when reverting a block.--## 0.6.4-### Changed-- Do not fail silently when importing orphan transactions into the mempool.--## 0.6.3-### Changed-- Dummy release to bump haskoin-node in stack.yaml.--## 0.6.2-### Changed-- Correct bug where coinbase transactions weren't properly flagged.--## 0.6.1-### Changed-- Compatibility with Bitcoin Cash hard fork.-- Various bug fixes.--## 0.6.0-### Added-- Address balance cache in memory.--### Changed-- Simplify data model further.-- Fix bug importing outputs with UTXO cache.-- Unspent balances cannot be negative.--## 0.5.0-### Added-- Add UTXO cache in memory.-- Get transactions with witness data in segwit networks.--### Changed-- Paths for derivations in xpubs is a list and no longer a string.-- Various bug fixes.--## 0.4.2-### Removed-- Remove extended public key itself from output of relevant endpoints to save bandwidth.--## 0.4.1-### Changed-- Fix bug when deleting coinbase transactions.-- Extended public key API support.--## 0.4.0-### Changed-- Generate events for mempool transactions.-- Respond with entire block data when querying blocks by height.--## 0.3.1-### Changed-- Do not import transactions to mempool while not synced.-- Only sync mempool against a single peer.-- Allow duplicate transactions to fix re-introduced sync bug.--## 0.3.0-### Added-- Update dependencies.-- Keep orphan blocks and deleted transactions in database.-- Add a `mainchain` field for block data and a `deleted` field for transactions.-- Stream records for performance.-- Show witness data for transaction inputs in SegWit network.-- Support RBF in SegWit network.--### Changed-- Refactor all data access code away from actor.-- Refactor import logic away from actor.-- Abstract data access using typeclasses.-- Implement data access using clean layered architecture.-- Make most of import logic code pure.-- Database now in `db` as opposed to `blocks` directory.-- Use latest `haskoin-node`.--### Removed-- Remove some data from peer information output.-- Remove full transaction from address transaction data.-- Remove limits from address transaction data.-- Remove block data from previous output.-- Remove spender from JSON response when output not spent.-- Remove block hash from block reference.--## 0.2.3-### Removed-- Do not send transaction notifications if a block is being imported.--## 0.2.2-### Added-- Peer information endpoint.--### Changed-- Update `haskoin-node`.--## 0.2.1-### Changed-- Fix tests--## 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.-- Improve handling orphan transactions.--## 0.1.2-### Changed-- Specify dependencies better.--## 0.1.1-### Changed-- Dependency `secp256k1` is now `secp256k1-haskell`.--## 0.1.0-### Added-- New `CHANGELOG.md` file.-- Bitcoin (BTC) and Bitcoin Cash (BCH) compatibility.-- RocksDB database.-- Mempool support.-- HTTP streaming for events.-- CashAddr support.-- Bech32 support.-- Rate limits.--### Changed-- Split out of former `haskoin` repository.-- Use hpack and `package.yaml`.--### Removed-- Removed Stylish Haskell configuration file.-- Remvoed `haskoin-core` and `haskoin-wallet` packages from this repository.
− README.md
@@ -1,35 +0,0 @@-# Haskoin Store--Full blockchain index & store featuring:--- Bitcoin Cash (BCH) & Bitcoin SegWit (BTC) support.-- Address balance, transaction, and UTXO index.-- Mempool support (SPV).-- XPub balance, transaction, and UTXO support.-- Persistent storage using RocksDB.-- RESTful endpoints for blockchain data.-- Concurrent non-blocking transactional design.-- JSON and Protocol Buffers serialization support.---## Install--* Get [Stack](https://haskell-lang.org/get-started).-* Get [Nix](https://nixos.org/nix/).-* Clone this repository `git clone https://github.com/haskoin/haskoin-store`.-* From the root of this repository run `stack --nix build --copy-bins`.-* File will usually be installed in `~/.local/bin/haskoin-store`.--## Cache--A memory-based RocksDB database can be used as a cache to store:--* Address balances.-* Unspent outputs.--Give `haskoin-store` the path to a directory mapped to RAM, and it will populate a RockDB database for caching. Needs around 25 GB at the moment (May 2019).---## API Documentation--* [Swagger API Documentation](https://api.haskoin.com/).
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f95fe3732d305938e74dde6fd2add6ccccc8f8ab25b96dce638ed21700a7e86d+-- hash: 2b2f22bc5fd135babc82dcfdd807a87cfe18a820002b08da61fbe8ec69e68d0b name: haskoin-store-version: 0.24.0+version: 0.25.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.@@ -21,9 +21,6 @@ license: PublicDomain license-file: UNLICENSE build-type: Simple-extra-source-files:- README.md- CHANGELOG.md source-repository head type: git@@ -58,8 +55,9 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0- , haskoin-core >=0.13.0- , haskoin-node >=0.12.0+ , haskoin-core >=0.13.3+ , haskoin-node >=0.13.0+ , haskoin-store-data ==0.25.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32@@ -98,9 +96,10 @@ , deepseq >=1.4.4.0 , filepath , hashable >=1.3.0.0- , haskoin-core >=0.13.0- , haskoin-node >=0.12.0+ , haskoin-core >=0.13.3+ , haskoin-node >=0.13.0 , haskoin-store+ , haskoin-store-data ==0.25.0 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1@@ -119,7 +118,6 @@ main-is: Spec.hs other-modules: Haskoin.Store.CacheSpec- Haskoin.Store.CommonSpec Haskoin.StoreSpec Haskoin.Store Haskoin.Store.BlockStore@@ -149,8 +147,9 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0- , haskoin-core >=0.13.0- , haskoin-node >=0.12.0+ , haskoin-core >=0.13.3+ , haskoin-node >=0.13.0+ , haskoin-store-data ==0.25.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store.hs view
@@ -1,81 +1,38 @@ module Haskoin.Store- ( StoreRead (..)- , BlockData (..)- , TxData (..)- , Spender (..)- , Balance (..)- , balanceToJSON- , balanceToEncoding- , balanceParseJSON- , Unspent (..)- , unspentToJSON- , unspentToEncoding- , BlockTx (..)- , BlockRef (..)- , XPubSpec (..)- , XPubBal (..)- , XPubSummary (..)- , XPubUnspent (..)- , xPubUnspentToJSON- , xPubUnspentToEncoding- , DeriveType (..)- , UnixTime- , Limit- , Offset- , BlockPos-- , Transaction (..)- , transactionToJSON- , transactionToEncoding- , StoreInput (..)- , storeInputToJSON- , storeInputToEncoding- , StoreOutput (..)- , storeOutputToJSON- , storeOutputToEncoding- , getTransaction- , transactionData- , fromTransaction- , toTransaction-- , blockAtOrBefore- , confirmed- , nullBalance- , isCoinbase-- , PeerInformation (..)- , HealthCheck (..)- , StoreEvent (..)- , PubExcept (..)- , TxId (..)- , GenericResult (..)-- , StoreWrite (..)-- , StoreConfig (..)- , Store (..)+ ( Store(..)+ , StoreConfig(..)+ , StoreEvent(..) , withStore - , DatabaseReader (..)- , DatabaseReaderT- , connectRocksDB- , withDatabaseReader-- , WebConfig (..)- , WebLimits (..)- , WebTimeouts (..)- , Except (..)- , runWeb+ , module Haskoin.Store.BlockStore+ , module Haskoin.Store.Web+ , module Haskoin.Store.Database.Reader+ , module Haskoin.Store.Data + -- * Cache , CacheConfig (..) , CacheT , CacheError (..) , withCache , connectRedis++ -- * Store Reader+ , StoreRead (..)+ , Limit+ , Offset++ -- * Useful Fuctions+ , getTransaction+ , blockAtOrBefore++ -- * Other Data+ , PubExcept (..) ) where +import Haskoin.Store.BlockStore import Haskoin.Store.Cache import Haskoin.Store.Common+import Haskoin.Store.Data import Haskoin.Store.Database.Reader import Haskoin.Store.Manager import Haskoin.Store.Web
src/Haskoin/Store/BlockStore.hs view
@@ -6,8 +6,25 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Haskoin.Store.BlockStore- ( BlockStoreConfig(..)+ ( -- * Block Store+ BlockStore+ , BlockStoreMessage+ , BlockStoreConfig(..) , blockStore+ , blockStorePeerConnect+ , blockStorePeerConnectSTM+ , blockStorePeerDisconnect+ , blockStorePeerDisconnectSTM+ , blockStoreHead+ , blockStoreHeadSTM+ , blockStoreBlock+ , blockStoreBlockSTM+ , blockStoreNotFound+ , blockStoreNotFoundSTM+ , blockStoreTx+ , blockStoreTxSTM+ , blockStoreTxHash+ , blockStoreTxHashSTM ) where import Control.Applicative ((<|>))@@ -46,11 +63,10 @@ managerGetPeers, sendMessage) import Haskoin.Node (Chain, PeerManager, managerPeerText)-import Haskoin.Store.Common (BlockStore,- BlockStoreMessage (..),- BlockTx (..), StoreEvent (..),- StoreRead (..), TxData (..),- UnixTime, Unspent (..), sortTxs)+import Haskoin.Store.Common (StoreEvent (..), StoreRead (..),+ sortTxs)+import Haskoin.Store.Data (BlockTx (..), TxData (..),+ UnixTime, Unspent (..)) import Haskoin.Store.Database.Reader (DatabaseReader) import Haskoin.Store.Database.Writer (DatabaseWriter, runDatabaseWriter)@@ -58,16 +74,40 @@ deleteTx, getOldMempool, importBlock, initBest, newMempoolTx, revertBlock)-import NQE (Inbox, Listen, inboxToMailbox,- query, receive)+import Network.Socket (SockAddr)+import NQE (Inbox, Listen, Mailbox,+ inboxToMailbox, query, receive,+ send, sendSTM) import System.Random (randomRIO) import UnliftIO (Exception, MonadIO,- MonadUnliftIO, TVar, atomically,- liftIO, modifyTVar, newTVarIO,- readTVar, readTVarIO, throwIO,- withAsync, writeTVar)+ MonadUnliftIO, STM, TVar,+ atomically, liftIO, modifyTVar,+ newTVarIO, readTVar, readTVarIO,+ throwIO, withAsync, writeTVar) import UnliftIO.Concurrent (threadDelay) +-- | Messages for block store actor.+data BlockStoreMessage+ = BlockNewBest !BlockNode+ -- ^ new block header in chain+ | BlockPeerConnect !Peer !SockAddr+ -- ^ new peer connected+ | BlockPeerDisconnect !Peer !SockAddr+ -- ^ peer disconnected+ | BlockReceived !Peer !Block+ -- ^ new block received from a peer+ | BlockNotFound !Peer ![BlockHash]+ -- ^ block not found+ | BlockTxReceived !Peer !Tx+ -- ^ transaction received from peer+ | BlockTxAvailable !Peer ![TxHash]+ -- ^ peer has transactions available+ | BlockPing !(Listen ())+ -- ^ internal housekeeping ping++-- | Mailbox for block store.+type BlockStore = Mailbox BlockStoreMessage+ data BlockException = BlockNotInChain !BlockHash | Uninitialized@@ -412,7 +452,7 @@ t = pendingTxTime p th = txHash tx h x TxOrphan {} = return (Left (Just x))- h _ _ = return (Left Nothing)+ h _ _ = return (Left Nothing) let f = do x <- newMempoolTx tx t $(logInfoS) "BlockStore" $@@ -710,3 +750,49 @@ forever $ do threadDelay =<< liftIO (randomRIO (100 * 1000, 1000 * 1000)) BlockPing `query` mbox++blockStorePeerConnect :: MonadIO m => Peer -> SockAddr -> BlockStore -> m ()+blockStorePeerConnect peer addr store = BlockPeerConnect peer addr `send` store++blockStorePeerDisconnect :: MonadIO m => Peer -> SockAddr -> BlockStore -> m ()+blockStorePeerDisconnect peer addr store =+ BlockPeerDisconnect peer addr `send` store++blockStoreHead :: MonadIO m => BlockNode -> BlockStore -> m ()+blockStoreHead node store = BlockNewBest node `send` store++blockStoreBlock :: MonadIO m => Peer -> Block -> BlockStore -> m ()+blockStoreBlock peer block store = BlockReceived peer block `send` store++blockStoreNotFound :: MonadIO m => Peer -> [BlockHash] -> BlockStore -> m ()+blockStoreNotFound peer blocks store = BlockNotFound peer blocks `send` store++blockStoreTx :: MonadIO m => Peer -> Tx -> BlockStore -> m ()+blockStoreTx peer tx store = BlockTxReceived peer tx `send` store++blockStoreTxHash :: MonadIO m => Peer -> [TxHash] -> BlockStore -> m ()+blockStoreTxHash peer txhashes store =+ BlockTxAvailable peer txhashes `send` store++blockStorePeerConnectSTM :: Peer -> SockAddr -> BlockStore -> STM ()+blockStorePeerConnectSTM peer addr store = BlockPeerConnect peer addr `sendSTM` store++blockStorePeerDisconnectSTM :: Peer -> SockAddr -> BlockStore -> STM ()+blockStorePeerDisconnectSTM peer addr store =+ BlockPeerDisconnect peer addr `sendSTM` store++blockStoreHeadSTM :: BlockNode -> BlockStore -> STM ()+blockStoreHeadSTM node store = BlockNewBest node `sendSTM` store++blockStoreBlockSTM :: Peer -> Block -> BlockStore -> STM ()+blockStoreBlockSTM peer block store = BlockReceived peer block `sendSTM` store++blockStoreNotFoundSTM :: Peer -> [BlockHash] -> BlockStore -> STM ()+blockStoreNotFoundSTM peer blocks store = BlockNotFound peer blocks `sendSTM` store++blockStoreTxSTM :: Peer -> Tx -> BlockStore -> STM ()+blockStoreTxSTM peer tx store = BlockTxReceived peer tx `sendSTM` store++blockStoreTxHashSTM :: Peer -> [TxHash] -> BlockStore -> STM ()+blockStoreTxHashSTM peer txhashes store =+ BlockTxAvailable peer txhashes `sendSTM` store
src/Haskoin/Store/Cache.hs view
@@ -38,7 +38,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet-import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntMap.Strict as I import Data.List (nub, sort) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe)@@ -68,16 +68,15 @@ xPubWitnessAddr) import Haskoin.Node (Chain, chainGetAncestor, chainGetBlock, chainGetSplitBlock)-import Haskoin.Store.Common (Balance (..), BlockData (..),+import Haskoin.Store.Common (Limit, Offset, StoreRead (..),+ sortTxs, xPubBals, xPubBalsTxs,+ xPubBalsUnspents, xPubTxs)+import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), BlockTx (..),- DeriveType (..), Limit, Offset,- Prev (..), StoreRead (..),- StoreRead (..), TxData (..),- Unspent (..), XPubBal (..),- XPubSpec (..), XPubUnspent (..),- nullBalance, sortTxs, xPubBals,- xPubBalsTxs, xPubBalsUnspents,- xPubTxs)+ DeriveType (..), Prev (..),+ TxData (..), Unspent (..),+ XPubBal (..), XPubSpec (..),+ XPubUnspent (..), nullBalance) import NQE (Inbox, Mailbox, receive, send) import System.Random (randomRIO) import UnliftIO (Exception, MonadIO, MonadUnliftIO,@@ -1092,7 +1091,7 @@ txInputs :: TxData -> [(Address, OutPoint)] txInputs td = let is = txIn (txData td)- ps = IntMap.toAscList (txDataPrevs td)+ ps = I.toAscList (txDataPrevs td) as = map (scriptToAddressBS . prevScript . snd) ps f (Right a) i = Just (a, prevOutput i) f (Left _) _ = Nothing
src/Haskoin/Store/Common.hs view
@@ -5,1473 +5,331 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.Store.Common- ( BlockStoreMessage(..)- , DeriveType(..)- , Limit- , Offset- , BlockStore- , UnixTime- , getUnixTime- , putUnixTime- , BlockPos- , XPubSpec(..)- , StoreRead(..)- , StoreWrite(..)- , BlockRef(..)- , BlockTx(..)- , confirmed- , Balance(..)- , balanceToJSON- , balanceToEncoding- , balanceParseJSON- , BlockData(..)- , StoreInput(..)- , storeInputToJSON- , storeInputToEncoding- , isCoinbase- , Spender(..)- , StoreOutput(..)- , storeOutputToJSON- , storeOutputToEncoding- , Prev(..)- , TxData(..)- , Unspent(..)- , unspentToJSON- , unspentToEncoding- , Transaction(..)- , transactionToJSON- , transactionToEncoding- , transactionData- , fromTransaction- , toTransaction- , GenericResult(..)- , TxId(..)- , PeerInformation(..)- , XPubBal(..)- , xPubBalToJSON- , xPubBalToEncoding- , xPubBalParseJSON- , xPubBalsTxs- , XPubUnspent(..)- , xPubUnspentToJSON- , xPubUnspentToEncoding- , xPubBalsUnspents- , XPubSummary(..)- , HealthCheck(..)- , Event(..)- , StoreEvent(..)- , PubExcept(..)- , zeroBalance- , nullBalance- , getTransaction- , blockAtOrBefore- , applyOffset- , applyLimit- , applyOffsetLimit- , applyOffsetC- , applyLimitC- , applyOffsetLimitC- , sortTxs- ) where--import Conduit (ConduitT, dropC, mapC, takeC)-import Control.Applicative ((<|>))-import Control.DeepSeq (NFData)-import Control.Exception (Exception)-import Control.Monad (guard, join, mzero)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (Encoding, FromJSON (..),- ToJSON (..), Value (..), object,- pairs, (.!=), (.:), (.:?), (.=))-import qualified Data.Aeson as A-import Data.Aeson.Encoding (list, null_, pair, text)-import Data.Aeson.Types (Parser)-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Short (ShortByteString)-import qualified Data.ByteString.Short as BSS-import Data.Function (on)-import Data.Hashable (Hashable (..))-import qualified Data.IntMap as I-import Data.IntMap.Strict (IntMap)-import Data.List (nub, partition, sortBy)-import Data.Maybe (catMaybes, isJust, listToMaybe,- mapMaybe)-import Data.Serialize (Get, Put, Serialize (..),- getWord32be, getWord64be, getWord8,- putWord32be, putWord64be, putWord8)-import qualified Data.Serialize as S-import Data.String.Conversions (cs)-import Data.Text (Text)-import Data.Word (Word32, Word64)-import GHC.Generics (Generic)-import Haskoin (Address, Block, BlockHash,- BlockHeader (..), BlockHeight,- BlockNode, BlockWork, KeyIndex,- Network (..), OutPoint (..),- PubKeyI (..), RejectCode (..),- Tx (..), TxHash (..), TxIn (..),- TxOut (..), WitnessStack,- XPubKey (..), addrFromJSON,- addrToEncoding, addrToJSON,- blockHashToHex, decodeHex,- deriveAddr, deriveCompatWitnessAddr,- deriveWitnessAddr, encodeHex,- headerHash, pubSubKey,- scriptToAddressBS, txHash,- txHashToHex, wrapPubKey)-import Haskoin.Node (Peer)-import Network.Socket (SockAddr)-import NQE (Listen, Mailbox)-import qualified Paths_haskoin_store as P--data DeriveType- = DeriveNormal- | DeriveP2SH- | DeriveP2WPKH- deriving (Show, Eq, Generic, NFData, Serialize)---- | Messages for block store actor.-data BlockStoreMessage- = BlockNewBest !BlockNode- -- ^ new block header in chain- | BlockPeerConnect !Peer !SockAddr- -- ^ new peer connected- | BlockPeerDisconnect !Peer !SockAddr- -- ^ peer disconnected- | BlockReceived !Peer !Block- -- ^ new block received from a peer- | BlockNotFound !Peer ![BlockHash]- -- ^ block not found- | BlockTxReceived !Peer !Tx- -- ^ transaction received from peer- | BlockTxAvailable !Peer ![TxHash]- -- ^ peer has transactions available- | BlockPing !(Listen ())- -- ^ internal housekeeping ping---- | Mailbox for block store.-type BlockStore = Mailbox BlockStoreMessage--data XPubSpec =- XPubSpec- { xPubSpecKey :: !XPubKey- , xPubDeriveType :: !DeriveType- } deriving (Show, Eq, Generic, NFData)--instance Hashable XPubSpec where- hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} =- hashWithSalt i pubkey--instance Serialize XPubSpec where- put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do- put (xPubDepth k)- put (xPubParent k)- put (xPubIndex k)- put (xPubChain k)- put (wrapPubKey True (xPubKey k))- put t- get = do- d <- get- p <- get- i <- get- c <- get- k <- get- t <- get- let x =- XPubKey- { xPubDepth = d- , xPubParent = p- , xPubIndex = i- , xPubChain = c- , xPubKey = pubKeyPoint k- }- return XPubSpec {xPubSpecKey = x, xPubDeriveType = t}--type DeriveAddr = XPubKey -> KeyIndex -> Address--type UnixTime = Word64-type BlockPos = Word32--type Offset = Word32-type Limit = Word32--class Monad m =>- StoreRead m- where- getNetwork :: m Network- getBestBlock :: m (Maybe BlockHash)- getBlocksAtHeight :: BlockHeight -> m [BlockHash]- getBlock :: BlockHash -> m (Maybe BlockData)- getTxData :: TxHash -> m (Maybe TxData)- getSpenders :: TxHash -> m (IntMap Spender)- getSpender :: OutPoint -> m (Maybe Spender)- getBalance :: Address -> m Balance- getBalance a = head <$> getBalances [a]- getBalances :: [Address] -> m [Balance]- getBalances as = mapM getBalance as- getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getAddressTxs a = getAddressesTxs [a]- getUnspent :: OutPoint -> m (Maybe Unspent)- getAddressUnspents ::- Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getAddressUnspents a = getAddressesUnspents [a]- getAddressesUnspents ::- [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getMempool :: m [BlockTx]- xPubBals :: XPubSpec -> m [XPubBal]- xPubBals xpub = do- igap <- getInitialGap- gap <- getMaxGap- ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0))- if all (nullBalance . xPubBal) ext1- then return []- else do- ext2 <- derive_until_gap gap 0 (aderiv 0 igap)- chg <- derive_until_gap gap 1 (aderiv 1 0)- return (ext1 <> ext2 <> chg)- where- aderiv m n =- deriveAddresses- (deriveFunction (xPubDeriveType xpub))- (pubSubKey (xPubSpecKey xpub) m)- n- xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}- derive_until_gap _ _ [] = return []- derive_until_gap gap m as = do- let (as1, as2) = splitAt (fromIntegral gap) as- bs <- getBalances (map snd as1)- let xbs = zipWith (xbalance m) bs (map fst as1)- if all nullBalance bs- then return xbs- else (xbs <>) <$> derive_until_gap gap m as2- xPubSummary :: XPubSpec -> m XPubSummary- xPubSummary xpub = do- bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub- let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]- ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]- uc =- sum- [ c- | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-- bs- ]- xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]- rx =- sum- [ r- | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-- xt- ]- return- XPubSummary- { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)- , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)- , xPubSummaryReceived = rx- , xPubUnspentCount = uc- , xPubChangeIndex = ch- , xPubExternalIndex = ex- }- xPubUnspents ::- XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [XPubUnspent]- xPubUnspents xpub start offset limit = do- xs <- filter positive <$> xPubBals xpub- applyOffsetLimit offset limit <$> go xs- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go [] = return []- go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do- uns <- getAddressUnspents a start limit- let xuns =- map- (\t ->- XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs- xPubTxs ::- XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]- xPubTxs xpub start offset limit = do- bs <- xPubBals xpub- let as = map (balanceAddress . xPubBal) bs- ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $ applyOffsetLimit offset limit ts'- getMaxGap :: m Word32- getInitialGap :: m Word32--class StoreWrite m where- setBest :: BlockHash -> m ()- insertBlock :: BlockData -> m ()- setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m ()- insertTx :: TxData -> m ()- insertSpender :: OutPoint -> Spender -> m ()- deleteSpender :: OutPoint -> m ()- insertAddrTx :: Address -> BlockTx -> m ()- deleteAddrTx :: Address -> BlockTx -> m ()- insertAddrUnspent :: Address -> Unspent -> m ()- deleteAddrUnspent :: Address -> Unspent -> m ()- setMempool :: [BlockTx] -> m ()- setBalance :: Balance -> m ()- insertUnspent :: Unspent -> m ()- deleteUnspent :: OutPoint -> m ()--deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]-deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]--deriveFunction :: DeriveType -> DeriveAddr-deriveFunction DeriveNormal i = fst . deriveAddr i-deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i-deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i--xPubBalsUnspents ::- StoreRead m- => [XPubBal]- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [XPubUnspent]-xPubBalsUnspents bals start offset limit = do- let xs = filter positive bals- applyOffsetLimit offset limit <$> go xs- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go [] = return []- go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do- uns <- getAddressUnspents a start limit- let xuns =- map- (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs--xPubBalsTxs ::- StoreRead m- => [XPubBal]- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [BlockTx]-xPubBalsTxs bals start offset limit = do- let as = map balanceAddress . filter (not . nullBalance) $ map xPubBal bals- ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $ applyOffsetLimit offset limit ts'--getTransaction ::- (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)-getTransaction h = runMaybeT $ do- d <- MaybeT $ getTxData h- sm <- lift $ getSpenders h- return $ toTransaction d sm--blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)-blockAtOrBefore q = runMaybeT $ do- a <- g 0- b <- MaybeT getBestBlock >>= MaybeT . getBlock- f a b- where- f a b- | t b <= q = return b- | t a > q = mzero- | h b - h a == 1 = return a- | otherwise = do- let x = h a + (h b - h a) `div` 2- m <- g x- if t m > q then f a m else f m b- g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock- h = blockDataHeight- t = fromIntegral . blockTimestamp . blockDataHeader---- | Serialize such that ordering is inverted.-putUnixTime :: Word64 -> Put-putUnixTime w = putWord64be $ maxBound - w--getUnixTime :: Get Word64-getUnixTime = (maxBound -) <$> getWord64be---- | Reference to a block where a transaction is stored.-data BlockRef- = BlockRef- { blockRefHeight :: !BlockHeight- -- ^ block height in the chain- , blockRefPos :: !Word32- -- ^ position of transaction within the block- }- | MemRef- { memRefTime :: !UnixTime- }- deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)---- | Serialized entities will sort in reverse order.-instance Serialize BlockRef where- put MemRef {memRefTime = t} = do- putWord8 0x00- putUnixTime t- put BlockRef {blockRefHeight = h, blockRefPos = p} = do- putWord8 0x01- putWord32be (maxBound - h)- putWord32be (maxBound - p)- get = getmemref <|> getblockref- where- getmemref = do- guard . (== 0x00) =<< getWord8- MemRef <$> getUnixTime- getblockref = do- guard . (== 0x01) =<< getWord8- h <- (maxBound -) <$> getWord32be- p <- (maxBound -) <$> getWord32be- return BlockRef {blockRefHeight = h, blockRefPos = p}--confirmed :: BlockRef -> Bool-confirmed BlockRef {} = True-confirmed MemRef {} = False--instance ToJSON BlockRef where- toJSON BlockRef {blockRefHeight = h, blockRefPos = p} =- object ["height" .= h, "position" .= p]- toJSON MemRef {memRefTime = t} = object ["mempool" .= t]- toEncoding BlockRef {blockRefHeight = h, blockRefPos = p} =- pairs ("height" .= h <> "position" .= p)- toEncoding MemRef {memRefTime = t} = pairs ("mempool" .= t)--instance FromJSON BlockRef where- parseJSON = A.withObject "blockref" $ \o -> b o <|> m o- where- b o = do- height <- o .: "height"- position <- o .: "position"- return BlockRef {blockRefHeight = height, blockRefPos = position}- m o = do- mempool <- o .: "mempool"- return MemRef {memRefTime = mempool}---- | Transaction in relation to an address.-data BlockTx = BlockTx- { blockTxBlock :: !BlockRef- -- ^ block information- , blockTxHash :: !TxHash- -- ^ transaction hash- } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData)--instance ToJSON BlockTx where- toJSON btx = object ["txid" .= blockTxHash btx, "block" .= blockTxBlock btx]- toEncoding btx =- pairs- ( "txid" .= blockTxHash btx- <> "block" .= blockTxBlock btx- )--instance FromJSON BlockTx where- parseJSON =- A.withObject "blocktx" $ \o -> do- txid <- o .: "txid"- block <- o .: "block"- return BlockTx {blockTxBlock = block, blockTxHash = txid}---- | Address balance information.-data Balance =- Balance- { balanceAddress :: !Address- -- ^ address balance- , balanceAmount :: !Word64- -- ^ confirmed balance- , balanceZero :: !Word64- -- ^ unconfirmed balance- , balanceUnspentCount :: !Word64- -- ^ number of unspent outputs- , balanceTxCount :: !Word64- -- ^ number of transactions- , balanceTotalReceived :: !Word64- -- ^ total amount from all outputs in this address- }- deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--zeroBalance :: Address -> Balance-zeroBalance a =- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceUnspentCount = 0- , balanceZero = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- }--nullBalance :: Balance -> Bool-nullBalance Balance { balanceAmount = 0- , balanceUnspentCount = 0- , balanceZero = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- } = True-nullBalance _ = False--balanceToJSON :: Network -> Balance -> Value-balanceToJSON net b =- object $- [ "address" .= addrToJSON net (balanceAddress b)- , "confirmed" .= balanceAmount b- , "unconfirmed" .= balanceZero b- , "utxo" .= balanceUnspentCount b- , "txs" .= balanceTxCount b- , "received" .= balanceTotalReceived b- ]--balanceToEncoding :: Network -> Balance -> Encoding-balanceToEncoding net b =- pairs- ( "address" `pair` addrToEncoding net (balanceAddress b)- <> "confirmed" .= balanceAmount b- <> "unconfirmed" .= balanceZero b- <> "utxo" .= balanceUnspentCount b- <> "txs" .= balanceTxCount b- <> "received" .= balanceTotalReceived b- )--balanceParseJSON :: Network -> Value -> Parser Balance-balanceParseJSON net =- A.withObject "balance" $ \o -> do- amount <- o .: "confirmed"- unconfirmed <- o .: "unconfirmed"- utxo <- o .: "utxo"- txs <- o .: "txs"- received <- o .: "received"- address <- addrFromJSON net =<< o .: "address"- return- Balance- { balanceAddress = address- , balanceAmount = amount- , balanceUnspentCount = utxo- , balanceZero = unconfirmed- , balanceTxCount = txs- , balanceTotalReceived = received- }---- | Unspent output.-data Unspent = Unspent- { unspentBlock :: !BlockRef- , unspentPoint :: !OutPoint- , unspentAmount :: !Word64- , unspentScript :: !ShortByteString- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--unspentToJSON :: Network -> Unspent -> Value-unspentToJSON net u =- object- [ "address" .= scriptToAddrJSON net bsscript- , "block" .= unspentBlock u- , "txid" .= outPointHash (unspentPoint u)- , "index" .= outPointIndex (unspentPoint u)- , "pkscript" .= script- , "value" .= unspentAmount u- ]- where- bsscript = BSS.fromShort (unspentScript u)- script = encodeHex bsscript--unspentToEncoding :: Network -> Unspent -> Encoding-unspentToEncoding net u =- pairs- ( "address" `pair` scriptToAddrEncoding net bsscript- <> "block" .= unspentBlock u- <> "txid" .= outPointHash (unspentPoint u)- <> "index" .= outPointIndex (unspentPoint u)- <> "pkscript" `pair` text script- <> "value" .= unspentAmount u- )- where- bsscript = BSS.fromShort (unspentScript u)- script = encodeHex bsscript--instance FromJSON Unspent where- parseJSON =- A.withObject "unspent" $ \o -> do- block <- o .: "block"- txid <- o .: "txid"- index <- o .: "index"- value <- o .: "value"- script <- BSS.toShort <$> (o .: "pkscript" >>= jsonHex)- return- Unspent- { unspentBlock = block- , unspentPoint = OutPoint txid index- , unspentAmount = value- , unspentScript = script- }---- | Database value for a block entry.-data BlockData = BlockData- { blockDataHeight :: !BlockHeight- -- ^ height of the block in the chain- , blockDataMainChain :: !Bool- -- ^ is this block in the main chain?- , blockDataWork :: !BlockWork- -- ^ accumulated work in that block- , blockDataHeader :: !BlockHeader- -- ^ block header- , blockDataSize :: !Word32- -- ^ size of the block including witnesses- , blockDataWeight :: !Word32- -- ^ weight of this block (for segwit networks)- , blockDataTxs :: ![TxHash]- -- ^ block transactions- , blockDataOutputs :: !Word64- -- ^ sum of all transaction outputs- , blockDataFees :: !Word64- -- ^ sum of all transaction fees- , blockDataSubsidy :: !Word64- -- ^ block subsidy- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--instance ToJSON BlockData where- toJSON bv =- object- [ "hash" .= headerHash (blockDataHeader bv)- , "height" .= blockDataHeight bv- , "mainchain" .= blockDataMainChain bv- , "previous" .= prevBlock (blockDataHeader bv)- , "time" .= blockTimestamp (blockDataHeader bv)- , "version" .= blockVersion (blockDataHeader bv)- , "bits" .= blockBits (blockDataHeader bv)- , "nonce" .= bhNonce (blockDataHeader bv)- , "size" .= blockDataSize bv- , "tx" .= blockDataTxs bv- , "merkle" .= TxHash (merkleRoot (blockDataHeader bv))- , "subsidy" .= blockDataSubsidy bv- , "fees" .= blockDataFees bv- , "outputs" .= blockDataOutputs bv- , "work" .= show (blockDataWork bv)- , "weight" .= blockDataWeight bv- ]- toEncoding bv =- pairs- ( "hash" `pair` text (blockHashToHex (headerHash (blockDataHeader bv)))- <> "height" .= blockDataHeight bv- <> "mainchain" .= blockDataMainChain bv- <> "previous" .= prevBlock (blockDataHeader bv)- <> "time" .= blockTimestamp (blockDataHeader bv)- <> "version" .= blockVersion (blockDataHeader bv)- <> "bits" .= blockBits (blockDataHeader bv)- <> "nonce" .= bhNonce (blockDataHeader bv)- <> "size" .= blockDataSize bv- <> "tx" .= blockDataTxs bv- <> "merkle" `pair` text (txHashToHex (TxHash (merkleRoot (blockDataHeader bv))))- <> "subsidy" .= blockDataSubsidy bv- <> "fees" .= blockDataFees bv- <> "outputs" .= blockDataOutputs bv- <> "work" .= blockDataWork bv- <> "weight" .= blockDataWeight bv)--instance FromJSON BlockData where- parseJSON =- A.withObject "blockdata" $ \o -> do- height <- o .: "height"- mainchain <- o .: "mainchain"- previous <- o .: "previous"- time <- o .: "time"- version <- o .: "version"- bits <- o .: "bits"- nonce <- o .: "nonce"- size <- o .: "size"- tx <- o .: "tx"- TxHash merkle <- o .: "merkle"- subsidy <- o .: "subsidy"- fees <- o .: "fees"- outputs <- o .: "outputs"- work <- o .: "work"- weight <- o .: "weight"- return- BlockData- { blockDataHeader =- BlockHeader- { prevBlock = previous- , blockTimestamp = time- , blockVersion = version- , blockBits = bits- , bhNonce = nonce- , merkleRoot = merkle- }- , blockDataMainChain = mainchain- , blockDataWork = work- , blockDataSize = size- , blockDataWeight = weight- , blockDataTxs = tx- , blockDataOutputs = outputs- , blockDataFees = fees- , blockDataHeight = height- , blockDataSubsidy = subsidy- }--data StoreInput- = StoreCoinbase { inputPoint :: !OutPoint- , inputSequence :: !Word32- , inputSigScript :: !ByteString- , inputWitness :: !(Maybe WitnessStack)- }- | StoreInput { inputPoint :: !OutPoint- , inputSequence :: !Word32- , inputSigScript :: !ByteString- , inputPkScript :: !ByteString- , inputAmount :: !Word64- , inputWitness :: !(Maybe WitnessStack)- }- deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--isCoinbase :: StoreInput -> Bool-isCoinbase StoreCoinbase {} = True-isCoinbase StoreInput {} = False--storeInputToJSON :: Network -> StoreInput -> Value-storeInputToJSON net StoreInput { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputPkScript = ps- , inputAmount = val- , inputWitness = wit- } =- object- [ "coinbase" .= False- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= String (encodeHex ps)- , "value" .= val- , "address" .= scriptToAddrJSON net ps- , "witness" .= fmap (map encodeHex) wit- ]-storeInputToJSON _ StoreCoinbase { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputWitness = wit- } =- object- [ "coinbase" .= True- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= Null- , "value" .= Null- , "address" .= Null- , "witness" .= fmap (map encodeHex) wit- ]--storeInputToEncoding :: Network -> StoreInput -> Encoding-storeInputToEncoding net StoreInput { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputPkScript = ps- , inputAmount = val- , inputWitness = wit- } =- pairs- ( "coinbase" .= False- <> "txid" .= oph- <> "output" .= opi- <> "sigscript" `pair` text (encodeHex ss)- <> "sequence" .= sq- <> "pkscript" `pair` text (encodeHex ps)- <> "value" .= val- <> "address" `pair` scriptToAddrEncoding net ps- <> "witness" .= fmap (map encodeHex) wit- )--storeInputToEncoding _ StoreCoinbase { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputWitness = wit- } =- pairs- ( "coinbase" .= True- <> "txid" `pair` text (txHashToHex oph)- <> "output" .= opi- <> "sigscript" `pair` text (encodeHex ss)- <> "sequence" .= sq- <> "pkscript" `pair` null_- <> "value" `pair` null_- <> "address" `pair` null_- <> "witness" .= fmap (map encodeHex) wit- )--instance FromJSON StoreInput where- parseJSON =- A.withObject "storeinput" $ \o -> do- coinbase <- o .: "coinbase"- outpoint <- OutPoint <$> o .: "txid" <*> o .: "output"- sequ <- o .: "sequence"- witness <-- o .:? "witness" >>= \mmxs ->- case join mmxs of- Nothing -> return Nothing- Just xs -> Just <$> mapM jsonHex xs- sigscript <- o .: "sigscript" >>= jsonHex- if coinbase- then return- StoreCoinbase- { inputPoint = outpoint- , inputSequence = sequ- , inputSigScript = sigscript- , inputWitness = witness- }- else do- pkscript <- o .: "pkscript" >>= jsonHex- value <- o .: "value"- return- StoreInput- { inputPoint = outpoint- , inputSequence = sequ- , inputSigScript = sigscript- , inputPkScript = pkscript- , inputAmount = value- , inputWitness = witness- }--jsonHex :: Text -> Parser ByteString-jsonHex s =- case decodeHex s of- Nothing -> fail "Could not decode hex"- Just b -> return b---- | Information about input spending output.-data Spender = Spender- { spenderHash :: !TxHash- -- ^ input transaction hash- , spenderIndex :: !Word32- -- ^ input position in transaction- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--instance ToJSON Spender where- toJSON n = object ["txid" .= txHashToHex (spenderHash n), "input" .= spenderIndex n]- toEncoding n = pairs ("txid" .= txHashToHex (spenderHash n) <> "input" .= spenderIndex n)--instance FromJSON Spender where- parseJSON =- A.withObject "spender" $ \o -> Spender <$> o .: "txid" <*> o .: "input"---- | Output information.-data StoreOutput = StoreOutput- { outputAmount :: !Word64- , outputScript :: !ByteString- , outputSpender :: !(Maybe Spender)- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--storeOutputToJSON :: Network -> StoreOutput -> Value-storeOutputToJSON net d =- object- [ "address" .= scriptToAddrJSON net (outputScript d)- , "pkscript" .= encodeHex (outputScript d)- , "value" .= outputAmount d- , "spent" .= isJust (outputSpender d)- , "spender" .= outputSpender d- ]--storeOutputToEncoding :: Network -> StoreOutput -> Encoding-storeOutputToEncoding net d =- pairs- ( "address" `pair` scriptToAddrEncoding net (outputScript d)- <> "pkscript" `pair` text (encodeHex (outputScript d))- <> "value" .= outputAmount d- <> "spent" .= isJust (outputSpender d)- <> "spender" .= outputSpender d- )--instance FromJSON StoreOutput where- parseJSON =- A.withObject "storeoutput" $ \o -> do- value <- o .: "value"- pkscript <- o .: "pkscript" >>= jsonHex- spender <- o .: "spender"- return- StoreOutput- { outputAmount = value- , outputScript = pkscript- , outputSpender = spender- }--data Prev = Prev- { prevScript :: !ByteString- , prevAmount :: !Word64- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput-toInput i Nothing w =- StoreCoinbase- { inputPoint = prevOutput i- , inputSequence = txInSequence i- , inputSigScript = scriptInput i- , inputWitness = w- }-toInput i (Just p) w =- StoreInput- { inputPoint = prevOutput i- , inputSequence = txInSequence i- , inputSigScript = scriptInput i- , inputPkScript = prevScript p- , inputAmount = prevAmount p- , inputWitness = w- }--toOutput :: TxOut -> Maybe Spender -> StoreOutput-toOutput o s =- StoreOutput- { outputAmount = outValue o- , outputScript = scriptOutput o- , outputSpender = s- }--data TxData = TxData- { txDataBlock :: !BlockRef- , txData :: !Tx- , txDataPrevs :: !(IntMap Prev)- , txDataDeleted :: !Bool- , txDataRBF :: !Bool- , txDataTime :: !Word64- } deriving (Show, Eq, Ord, Generic, Serialize, NFData)--toTransaction :: TxData -> IntMap Spender -> Transaction-toTransaction t sm =- Transaction- { transactionBlock = txDataBlock t- , transactionVersion = txVersion (txData t)- , transactionLockTime = txLockTime (txData t)- , transactionInputs = ins- , transactionOutputs = outs- , transactionDeleted = txDataDeleted t- , transactionRBF = txDataRBF t- , transactionTime = txDataTime t- }- where- ws =- take (length (txIn (txData t))) $- map Just (txWitness (txData t)) <> repeat Nothing- f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)- ins = zipWith f [0 ..] (txIn (txData t))- g n o = toOutput o (I.lookup n sm)- outs = zipWith g [0 ..] (txOut (txData t))--fromTransaction :: Transaction -> (TxData, IntMap Spender)-fromTransaction t = (d, sm)- where- d =- TxData- { txDataBlock = transactionBlock t- , txData = transactionData t- , txDataPrevs = ps- , txDataDeleted = transactionDeleted t- , txDataRBF = transactionRBF t- , txDataTime = transactionTime t- }- f _ StoreCoinbase {} = Nothing- f n StoreInput {inputPkScript = s, inputAmount = v} =- Just (n, Prev {prevScript = s, prevAmount = v})- ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)- g _ StoreOutput {outputSpender = Nothing} = Nothing- g n StoreOutput {outputSpender = Just s} = Just (n, s)- sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)---- | Detailed transaction information.-data Transaction = Transaction- { transactionBlock :: !BlockRef- -- ^ block information for this transaction- , transactionVersion :: !Word32- -- ^ transaction version- , transactionLockTime :: !Word32- -- ^ lock time- , transactionInputs :: ![StoreInput]- -- ^ transaction inputs- , transactionOutputs :: ![StoreOutput]- -- ^ transaction outputs- , transactionDeleted :: !Bool- -- ^ this transaction has been deleted and is no longer valid- , transactionRBF :: !Bool- -- ^ this transaction can be replaced in the mempool- , transactionTime :: !Word64- -- ^ time the transaction was first seen or time of block- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--transactionData :: Transaction -> Tx-transactionData t =- Tx- { txVersion = transactionVersion t- , txIn = map i (transactionInputs t)- , txOut = map o (transactionOutputs t)- , txWitness = mapMaybe inputWitness (transactionInputs t)- , txLockTime = transactionLockTime t- }- where- i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} =- TxIn {prevOutput = p, scriptInput = s, txInSequence = q}- i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} =- TxIn {prevOutput = p, scriptInput = s, txInSequence = q}- o StoreOutput {outputAmount = v, outputScript = s} =- TxOut {outValue = v, scriptOutput = s}--transactionToJSON :: Network -> Transaction -> Value-transactionToJSON net dtx =- object- [ "txid" .= txHash (transactionData dtx)- , "size" .= B.length (S.encode (transactionData dtx))- , "version" .= transactionVersion dtx- , "locktime" .= transactionLockTime dtx- , "fee" .=- if any isCoinbase (transactionInputs dtx)- then 0- else inv - outv- , "inputs" .= map (storeInputToJSON net) (transactionInputs dtx)- , "outputs" .= map (storeOutputToJSON net) (transactionOutputs dtx)- , "block" .= transactionBlock dtx- , "deleted" .= transactionDeleted dtx- , "time" .= transactionTime dtx- , "rbf" .= transactionRBF dtx- , "weight" .= w- ]- where- inv = sum (map inputAmount (transactionInputs dtx))- outv = sum (map outputAmount (transactionOutputs dtx))- w =- let b = B.length $ S.encode (transactionData dtx) {txWitness = []}- x = B.length $ S.encode (transactionData dtx)- in b * 3 + x--transactionToEncoding :: Network -> Transaction -> Encoding-transactionToEncoding net dtx =- pairs- ( "txid" `pair` text (txHashToHex (txHash (transactionData dtx)))- <> "size" .= B.length (S.encode (transactionData dtx))- <> "version" .= transactionVersion dtx- <> "locktime" .= transactionLockTime dtx- <> "fee" .= (if any isCoinbase (transactionInputs dtx) then 0 else inv - outv)- <> "inputs" `pair` list (storeInputToEncoding net) (transactionInputs dtx)- <> "outputs" `pair` list (storeOutputToEncoding net) (transactionOutputs dtx)- <> "block" .= transactionBlock dtx- <> "deleted" .= transactionDeleted dtx- <> "time" .= transactionTime dtx- <> "rbf" .= transactionRBF dtx- <> "weight" .= w- )- where- inv = sum (map inputAmount (transactionInputs dtx))- outv = sum (map outputAmount (transactionOutputs dtx))- w =- let b = B.length $ S.encode (transactionData dtx) {txWitness = []}- x = B.length $ S.encode (transactionData dtx)- in b * 3 + x--instance FromJSON Transaction where- parseJSON =- A.withObject "transaction" $ \o -> do- version <- o .: "version"- locktime <- o .: "locktime"- inputs <- o .: "inputs"- outputs <- o .: "outputs"- block <- o .: "block"- deleted <- o .: "deleted"- time <- o .: "time"- rbf <- o .:? "rbf" .!= False- return- Transaction- { transactionBlock = block- , transactionVersion = version- , transactionLockTime = locktime- , transactionInputs = inputs- , transactionOutputs = outputs- , transactionDeleted = deleted- , transactionTime = time- , transactionRBF = rbf- }---- | Information about a connected peer.-data PeerInformation- = PeerInformation { peerUserAgent :: !ByteString- -- ^ user agent string- , peerAddress :: !String- -- ^ network address- , peerVersion :: !Word32- -- ^ version number- , peerServices :: !Word64- -- ^ services field- , peerRelay :: !Bool- -- ^ will relay transactions- }- deriving (Show, Eq, Ord, Generic, NFData, Serialize)--instance ToJSON PeerInformation where- toJSON p = object- [ "useragent" .= String (cs (peerUserAgent p))- , "address" .= peerAddress p- , "version" .= peerVersion p- , "services" .= String (encodeHex (S.encode (peerServices p)))- , "relay" .= peerRelay p- ]- toEncoding p = pairs- ( "useragent" `pair` text (cs (peerUserAgent p))- <> "address" .= peerAddress p- <> "version" .= peerVersion p- <> "services" `pair` text (encodeHex (S.encode (peerServices p)))- <> "relay" .= peerRelay p- )--instance FromJSON PeerInformation where- parseJSON =- A.withObject "peerinformation" $ \o -> do- String useragent <- o .: "useragent"- address <- o .: "address"- version <- o .: "version"- services <-- o .: "services" >>= jsonHex >>= \b ->- case S.decode b of- Left e -> fail $ "Could not decode services: " <> e- Right s -> return s- relay <- o .: "relay"- return- PeerInformation- { peerUserAgent = cs useragent- , peerAddress = address- , peerVersion = version- , peerServices = services- , peerRelay = relay- }---- | Address balances for an extended public key.-data XPubBal = XPubBal- { xPubBalPath :: ![KeyIndex]- , xPubBal :: !Balance- } deriving (Show, Ord, Eq, Generic, Serialize, NFData)--xPubBalToJSON :: Network -> XPubBal -> Value-xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} =- object ["path" .= p, "balance" .= balanceToJSON net b]--xPubBalToEncoding :: Network -> XPubBal -> Encoding-xPubBalToEncoding net XPubBal {xPubBalPath = p, xPubBal = b} =- pairs ("path" .= p <> "balance" `pair` balanceToEncoding net b)--xPubBalParseJSON :: Network -> Value -> Parser XPubBal-xPubBalParseJSON net =- A.withObject "xpubbal" $ \o -> do- path <- o .: "path"- balance <- balanceParseJSON net =<< o .: "balance"- return XPubBal {xPubBalPath = path, xPubBal = balance}---- | Unspent transaction for extended public key.-data XPubUnspent = XPubUnspent- { xPubUnspentPath :: ![KeyIndex]- , xPubUnspent :: !Unspent- } deriving (Show, Eq, Generic, Serialize, NFData)--xPubUnspentToJSON :: Network -> XPubUnspent -> Value-xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} =- object ["path" .= p, "unspent" .= unspentToJSON net u]--xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding-xPubUnspentToEncoding net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} =- pairs ("path" .= p <> "unspent" `pair` unspentToEncoding net u)--instance FromJSON XPubUnspent where- parseJSON =- A.withObject "xpubunspent" $ \o -> do- p <- o .: "path"- u <- o .: "unspent"- return XPubUnspent {xPubUnspentPath = p, xPubUnspent = u}--data XPubSummary =- XPubSummary- { xPubSummaryConfirmed :: !Word64- , xPubSummaryZero :: !Word64- , xPubSummaryReceived :: !Word64- , xPubUnspentCount :: !Word64- , xPubExternalIndex :: !Word32- , xPubChangeIndex :: !Word32- }- deriving (Eq, Show, Generic, Serialize, NFData)--instance ToJSON XPubSummary where- toJSON XPubSummary { xPubSummaryConfirmed = c- , xPubSummaryZero = z- , xPubSummaryReceived = r- , xPubUnspentCount = u- , xPubExternalIndex = ext- , xPubChangeIndex = ch- } =- object- [ "balance" .=- object- [ "confirmed" .= c- , "unconfirmed" .= z- , "received" .= r- , "utxo" .= u- ]- , "indices" .= object ["change" .= ch, "external" .= ext]- ]- toEncoding XPubSummary { xPubSummaryConfirmed = c- , xPubSummaryZero = z- , xPubSummaryReceived = r- , xPubUnspentCount = u- , xPubExternalIndex = ext- , xPubChangeIndex = ch- } =- pairs- ( "balance" `pair` pairs- ( "confirmed" .= c- <> "unconfirmed" .= z- <> "received" .= r- <> "utxo" .= u- )- <> "indices" `pair` pairs- ( "change" .= ch- <> "external" .= ext- )- )--instance FromJSON XPubSummary where- parseJSON =- A.withObject "xpubsummary" $ \o -> do- b <- o .: "balance"- i <- o .: "indices"- conf <- b .: "confirmed"- unconfirmed <- b .: "unconfirmed"- received <- b .: "received"- utxo <- b .: "utxo"- change <- i .: "change"- external <- i .: "external"- return- XPubSummary- { xPubSummaryConfirmed = conf- , xPubSummaryZero = unconfirmed- , xPubSummaryReceived = received- , xPubUnspentCount = utxo- , xPubExternalIndex = external- , xPubChangeIndex = change- }--data HealthCheck =- HealthCheck- { healthHeaderBest :: !(Maybe BlockHash)- , healthHeaderHeight :: !(Maybe BlockHeight)- , healthBlockBest :: !(Maybe BlockHash)- , healthBlockHeight :: !(Maybe BlockHeight)- , healthPeers :: !(Maybe Int)- , healthNetwork :: !String- , healthOK :: !Bool- , healthSynced :: !Bool- , healthLastBlock :: !(Maybe Word64)- , healthLastTx :: !(Maybe Word64)- }- deriving (Show, Eq, Generic, Serialize, NFData)--instance ToJSON HealthCheck where- toJSON h =- object- [ "headers" .=- object- [ "hash" .= healthHeaderBest h- , "height" .= healthHeaderHeight h- ]- , "blocks" .=- object- ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h]- , "peers" .= healthPeers h- , "net" .= healthNetwork h- , "ok" .= healthOK h- , "synced" .= healthSynced h- , "version" .= P.version- , "lastblock" .= healthLastBlock h- , "lasttx" .= healthLastTx h- ]- toEncoding h =- pairs- ( "headers" `pair`- pairs- ( "hash" .= healthHeaderBest h- <> "height" .= healthHeaderHeight h- )- <> "blocks" `pair`- pairs- ( "hash" .= healthBlockBest h- <> "height" .= healthBlockHeight h- )- <> "peers" .= healthPeers h- <> "net" .= healthNetwork h- <> "ok" .= healthOK h- <> "synced" .= healthSynced h- <> "version" .= P.version- <> "lastblock" .= healthLastBlock h- <> "lasttx" .= healthLastTx h- )--instance FromJSON HealthCheck where- parseJSON =- A.withObject "healthcheck" $ \o -> do- headers <- o .: "headers"- headers_hash <- headers .: "hash"- headers_height <- headers .: "height"- blocks <- o .: "blocks"- blocks_hash <- blocks .: "hash"- blocks_height <- blocks .: "height"- peers <- o .: "peers"- net <- o .: "net"- ok <- o .: "ok"- synced <- o .: "synced"- lastblock <- o .: "lastblock"- lasttx <- o .: "lasttx"- return- HealthCheck- { healthHeaderBest = headers_hash- , healthHeaderHeight = headers_height- , healthBlockBest = blocks_hash- , healthBlockHeight = blocks_height- , healthPeers = peers- , healthNetwork = net- , healthOK = ok- , healthSynced = synced- , healthLastBlock = lastblock- , healthLastTx = lasttx- }--data Event- = EventBlock BlockHash- | EventTx TxHash- deriving (Show, Eq, Generic, Serialize, NFData)--instance ToJSON Event where- toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h]- toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h]- toEncoding (EventTx h) =- pairs ("type" `pair` text "tx" <> "id" `pair` text (txHashToHex h))- toEncoding (EventBlock h) =- pairs- ("type" `pair` text "block" <> "id" `pair` text (blockHashToHex h))--instance FromJSON Event where- parseJSON =- A.withObject "event" $ \o -> do- t <- o .: "type"- case t of- "tx" -> do- i <- o .: "id"- return $ EventTx i- "block" -> do- i <- o .: "id"- return $ EventBlock i- _ -> fail $ "Could not recognize event type: " <> t--newtype GenericResult a = GenericResult- { getResult :: a- } deriving (Show, Eq, Generic, Serialize, NFData)--instance ToJSON a => ToJSON (GenericResult a) where- toJSON (GenericResult b) = object ["result" .= b]- toEncoding (GenericResult b) = pairs ("result" .= b)--instance FromJSON a => FromJSON (GenericResult a) where- parseJSON =- A.withObject "result" $ \o -> GenericResult <$> o .: "result"--newtype TxId =- TxId TxHash- deriving (Show, Eq, Generic, Serialize, NFData)--instance ToJSON TxId where- toJSON (TxId h) = object ["txid" .= h]- toEncoding (TxId h) = pairs ("txid" `pair` text (txHashToHex h))--instance FromJSON TxId where- parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid"---- | Events that the store can generate.-data StoreEvent- = StoreBestBlock !BlockHash- -- ^ new best block- | StoreMempoolNew !TxHash- -- ^ new mempool transaction- | StorePeerConnected !Peer !SockAddr- -- ^ new peer connected- | StorePeerDisconnected !Peer !SockAddr- -- ^ peer has disconnected- | StorePeerPong !Peer !Word64- -- ^ peer responded 'Ping'- | StoreTxAvailable !Peer ![TxHash]- -- ^ peer inv transactions- | StoreTxReject !Peer !TxHash !RejectCode !ByteString- -- ^ peer rejected transaction- | StoreTxDeleted !TxHash- -- ^ transaction deleted from store- | StoreBlockReverted !BlockHash- -- ^ block no longer head of main chain--data PubExcept- = PubNoPeers- | PubReject RejectCode- | PubTimeout- | PubPeerDisconnected- deriving (Eq, NFData, Generic, Serialize)--instance Show PubExcept where- show PubNoPeers = "no peers"- show (PubReject c) =- "rejected: " <>- case c of- RejectMalformed -> "malformed"- RejectInvalid -> "invalid"- RejectObsolete -> "obsolete"- RejectDuplicate -> "duplicate"- RejectNonStandard -> "not standard"- RejectDust -> "dust"- RejectInsufficientFee -> "insufficient fee"- RejectCheckpoint -> "checkpoint"- show PubTimeout = "peer timeout or silent rejection"- show PubPeerDisconnected = "peer disconnected"--instance Exception PubExcept--applyOffsetLimit :: Offset -> Maybe Limit -> [a] -> [a]-applyOffsetLimit offset limit = applyLimit limit . applyOffset offset--applyOffset :: Offset -> [a] -> [a]-applyOffset = drop . fromIntegral--applyLimit :: Maybe Limit -> [a] -> [a]-applyLimit Nothing = id-applyLimit (Just l) = take (fromIntegral l)--applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()-applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit--applyOffsetC :: Monad m => Offset -> ConduitT i i m ()-applyOffsetC = dropC . fromIntegral--applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()-applyLimitC Nothing = mapC id-applyLimitC (Just l) = takeC (fromIntegral l)--sortTxs :: [Tx] -> [(Word32, Tx)]-sortTxs txs = go $ 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--scriptToAddrJSON :: Network -> ByteString -> Value-scriptToAddrJSON net bs =- case scriptToAddressBS bs of- Left _ -> Null- Right a -> addrToJSON net a--scriptToAddrEncoding :: Network -> ByteString -> Encoding-scriptToAddrEncoding net bs =- case scriptToAddressBS bs of- Left _ -> null_- Right a -> addrToEncoding net a+ ( Limit+ , Offset+ , StoreRead(..)+ , StoreWrite(..)+ , StoreEvent(..)+ , PubExcept(..)+ , xPubBalsTxs+ , xPubBalsUnspents+ , getTransaction+ , blockAtOrBefore+ , applyOffset+ , applyLimit+ , applyOffsetLimit+ , applyOffsetC+ , applyLimitC+ , applyOffsetLimitC+ , sortTxs+ ) where++import Conduit (ConduitT, dropC, mapC, takeC)+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad (mzero)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.ByteString (ByteString)+import Data.Function (on)+import Data.IntMap.Strict (IntMap)+import Data.List (nub, partition, sortBy)+import Data.Maybe (listToMaybe)+import Data.Serialize (Serialize (..))+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)+import Haskoin (Address, BlockHash,+ BlockHeader (..), BlockHeight,+ KeyIndex, Network (..),+ OutPoint (..), RejectCode (..),+ Tx (..), TxHash (..), TxIn (..),+ XPubKey (..), deriveAddr,+ deriveCompatWitnessAddr,+ deriveWitnessAddr, pubSubKey,+ txHash)+import Haskoin.Node (Peer)+import Haskoin.Store.Data (Balance (..), BlockData (..),+ BlockRef, BlockTx (..),+ DeriveType (..), Spender,+ Transaction, TxData, UnixTime,+ Unspent, XPubBal (..),+ XPubSpec (..), XPubSummary (..),+ XPubUnspent (..), nullBalance,+ toTransaction)+import Network.Socket (SockAddr)++type DeriveAddr = XPubKey -> KeyIndex -> Address++type Offset = Word32+type Limit = Word32++class Monad m =>+ StoreRead m+ where+ getNetwork :: m Network+ getBestBlock :: m (Maybe BlockHash)+ getBlocksAtHeight :: BlockHeight -> m [BlockHash]+ getBlock :: BlockHash -> m (Maybe BlockData)+ getTxData :: TxHash -> m (Maybe TxData)+ getSpenders :: TxHash -> m (IntMap Spender)+ getSpender :: OutPoint -> m (Maybe Spender)+ getBalance :: Address -> m Balance+ getBalance a = head <$> getBalances [a]+ getBalances :: [Address] -> m [Balance]+ getBalances as = mapM getBalance as+ getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs a = getAddressesTxs [a]+ getUnspent :: OutPoint -> m (Maybe Unspent)+ getAddressUnspents ::+ Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getAddressUnspents a = getAddressesUnspents [a]+ getAddressesUnspents ::+ [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getMempool :: m [BlockTx]+ xPubBals :: XPubSpec -> m [XPubBal]+ xPubBals xpub = do+ igap <- getInitialGap+ gap <- getMaxGap+ ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0))+ if all (nullBalance . xPubBal) ext1+ then return []+ else do+ ext2 <- derive_until_gap gap 0 (aderiv 0 igap)+ chg <- derive_until_gap gap 1 (aderiv 1 0)+ return (ext1 <> ext2 <> chg)+ where+ aderiv m n =+ deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) m)+ n+ xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ derive_until_gap _ _ [] = return []+ derive_until_gap gap m as = do+ let (as1, as2) = splitAt (fromIntegral gap) as+ bs <- getBalances (map snd as1)+ let xbs = zipWith (xbalance m) bs (map fst as1)+ if all nullBalance bs+ then return xbs+ else (xbs <>) <$> derive_until_gap gap m as2+ xPubSummary :: XPubSpec -> m XPubSummary+ xPubSummary xpub = do+ bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub+ let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]+ ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]+ uc =+ sum+ [ c+ | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-+ bs+ ]+ xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]+ rx =+ sum+ [ r+ | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-+ xt+ ]+ return+ XPubSummary+ { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)+ , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)+ , xPubSummaryReceived = rx+ , xPubUnspentCount = uc+ , xPubChangeIndex = ch+ , xPubExternalIndex = ex+ }+ xPubUnspents ::+ XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [XPubUnspent]+ xPubUnspents xpub start offset limit = do+ xs <- filter positive <$> xPubBals xpub+ applyOffsetLimit offset limit <$> go xs+ where+ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0+ go [] = return []+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a start limit+ let xuns =+ map+ (\t ->+ XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})+ uns+ (xuns <>) <$> go xs+ xPubTxs ::+ XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]+ xPubTxs xpub start offset limit = do+ bs <- xPubBals xpub+ let as = map (balanceAddress . xPubBal) bs+ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyOffsetLimit offset limit ts'+ getMaxGap :: m Word32+ getInitialGap :: m Word32++class StoreWrite m where+ setBest :: BlockHash -> m ()+ insertBlock :: BlockData -> m ()+ setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m ()+ insertTx :: TxData -> m ()+ insertSpender :: OutPoint -> Spender -> m ()+ deleteSpender :: OutPoint -> m ()+ insertAddrTx :: Address -> BlockTx -> m ()+ deleteAddrTx :: Address -> BlockTx -> m ()+ insertAddrUnspent :: Address -> Unspent -> m ()+ deleteAddrUnspent :: Address -> Unspent -> m ()+ setMempool :: [BlockTx] -> m ()+ setBalance :: Balance -> m ()+ insertUnspent :: Unspent -> m ()+ deleteUnspent :: OutPoint -> m ()++deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]+deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]++deriveFunction :: DeriveType -> DeriveAddr+deriveFunction DeriveNormal i = fst . deriveAddr i+deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i+deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i++xPubBalsUnspents ::+ StoreRead m+ => [XPubBal]+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [XPubUnspent]+xPubBalsUnspents bals start offset limit = do+ let xs = filter positive bals+ applyOffsetLimit offset limit <$> go xs+ where+ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0+ go [] = return []+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a start limit+ let xuns =+ map+ (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})+ uns+ (xuns <>) <$> go xs++xPubBalsTxs ::+ StoreRead m+ => [XPubBal]+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [BlockTx]+xPubBalsTxs bals start offset limit = do+ let as = map balanceAddress . filter (not . nullBalance) $ map xPubBal bals+ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyOffsetLimit offset limit ts'++getTransaction ::+ (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)+getTransaction h = runMaybeT $ do+ d <- MaybeT $ getTxData h+ sm <- lift $ getSpenders h+ return $ toTransaction d sm++blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)+blockAtOrBefore q = runMaybeT $ do+ a <- g 0+ b <- MaybeT getBestBlock >>= MaybeT . getBlock+ f a b+ where+ f a b+ | t b <= q = return b+ | t a > q = mzero+ | h b - h a == 1 = return a+ | otherwise = do+ let x = h a + (h b - h a) `div` 2+ m <- g x+ if t m > q then f a m else f m b+ g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock+ h = blockDataHeight+ t = fromIntegral . blockTimestamp . blockDataHeader+++-- | Events that the store can generate.+data StoreEvent+ = StoreBestBlock !BlockHash+ -- ^ new best block+ | StoreMempoolNew !TxHash+ -- ^ new mempool transaction+ | StorePeerConnected !Peer !SockAddr+ -- ^ new peer connected+ | StorePeerDisconnected !Peer !SockAddr+ -- ^ peer has disconnected+ | StorePeerPong !Peer !Word64+ -- ^ peer responded 'Ping'+ | StoreTxAvailable !Peer ![TxHash]+ -- ^ peer inv transactions+ | StoreTxReject !Peer !TxHash !RejectCode !ByteString+ -- ^ peer rejected transaction+ | StoreTxDeleted !TxHash+ -- ^ transaction deleted from store+ | StoreBlockReverted !BlockHash+ -- ^ block no longer head of main chain++data PubExcept+ = PubNoPeers+ | PubReject RejectCode+ | PubTimeout+ | PubPeerDisconnected+ deriving (Eq, NFData, Generic, Serialize)++instance Show PubExcept where+ show PubNoPeers = "no peers"+ show (PubReject c) =+ "rejected: " <>+ case c of+ RejectMalformed -> "malformed"+ RejectInvalid -> "invalid"+ RejectObsolete -> "obsolete"+ RejectDuplicate -> "duplicate"+ RejectNonStandard -> "not standard"+ RejectDust -> "dust"+ RejectInsufficientFee -> "insufficient fee"+ RejectCheckpoint -> "checkpoint"+ show PubTimeout = "peer timeout or silent rejection"+ show PubPeerDisconnected = "peer disconnected"++instance Exception PubExcept++applyOffsetLimit :: Offset -> Maybe Limit -> [a] -> [a]+applyOffsetLimit offset limit = applyLimit limit . applyOffset offset++applyOffset :: Offset -> [a] -> [a]+applyOffset = drop . fromIntegral++applyLimit :: Maybe Limit -> [a] -> [a]+applyLimit Nothing = id+applyLimit (Just l) = take (fromIntegral l)++applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()+applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit++applyOffsetC :: Monad m => Offset -> ConduitT i i m ()+applyOffsetC = dropC . fromIntegral++applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()+applyLimitC Nothing = mapC id+applyLimitC (Just l) = takeC (fromIntegral l)++sortTxs :: [Tx] -> [(Word32, Tx)]+sortTxs txs = go $ 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
src/Haskoin/Store/Database/Memory.hs view
@@ -26,11 +26,11 @@ import Haskoin (Address, BlockHash, BlockHeight, Network, OutPoint (..), TxHash, headerHash, txHash)-import Haskoin.Store.Common (Balance (..), BlockData (..),- BlockRef, BlockTx (..), Limit,- Spender, StoreRead (..),- StoreWrite (..), TxData (..),- Unspent (..), applyLimit,+import Haskoin.Store.Common (Limit, StoreRead (..),+ StoreWrite (..), applyLimit)+import Haskoin.Store.Data (Balance (..), BlockData (..),+ BlockRef, BlockTx (..), Spender,+ TxData (..), Unspent (..), zeroBalance) import Haskoin.Store.Database.Types (BalVal, OutVal (..), UnspentVal, balanceToVal, unspentToVal,
src/Haskoin/Store/Database/Reader.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} module Haskoin.Store.Database.Reader- ( DatabaseReader (..)+ ( -- * RocksDB Database Access+ DatabaseReader (..) , DatabaseReaderT , connectRocksDB , withDatabaseReader@@ -25,11 +26,12 @@ matchingSkip, retrieve) import Haskoin (Address, BlockHash, BlockHeight, Network, OutPoint (..), TxHash)-import Haskoin.Store.Common (Balance, BlockData,+import Haskoin.Store.Common (Limit, StoreRead (..),+ applyLimit, applyLimitC)+import Haskoin.Store.Data (Balance, BlockData, BlockRef (..), BlockTx (..),- Limit, Spender, StoreRead (..),- TxData, Unspent (..), applyLimit,- applyLimitC, zeroBalance)+ Spender, TxData, Unspent (..),+ zeroBalance) import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..), BalKey (..), BestKey (..), BlockKey (..), HeightKey (..),
src/Haskoin/Store/Database/Types.hs view
@@ -40,7 +40,7 @@ import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight, OutPoint (..), TxHash)-import Haskoin.Store.Common (Balance (..), BlockData, BlockRef,+import Haskoin.Store.Data (Balance (..), BlockData, BlockRef, BlockTx (..), Spender, TxData, UnixTime, Unspent (..), getUnixTime, putUnixTime)
src/Haskoin/Store/Database/Writer.hs view
@@ -24,12 +24,11 @@ import Database.RocksDB.Query (deleteOp, insertOp, writeBatch) import Haskoin (Address, BlockHash, BlockHeight, OutPoint (..), TxHash)-import Haskoin.Store.Common (Balance, BlockData,+import Haskoin.Store.Common (StoreRead (..), StoreWrite (..))+import Haskoin.Store.Data (Balance, BlockData, BlockRef (..), BlockTx (..),- Spender, StoreRead (..),- StoreWrite (..), TxData,- Unspent, nullBalance,- zeroBalance)+ Spender, TxData, Unspent,+ nullBalance, zeroBalance) import Haskoin.Store.Database.Memory (MemoryDatabase (..), MemoryState (..), emptyMemoryDatabase,
src/Haskoin/Store/Logic.hs view
@@ -38,15 +38,16 @@ genesisNode, headerHash, isGenesis, nullOutPoint, scriptToAddressBS, txHash, txHashToHex)-import Haskoin.Store.Common (Balance (..), BlockData (..),+import Haskoin.Store.Common (StoreRead (..), StoreWrite (..),+ sortTxs)+import Haskoin.Store.Data (Balance (..), BlockData (..), BlockRef (..), BlockTx (..), Prev (..), Spender (..), StoreInput (..), StoreOutput (..),- StoreRead (..), StoreWrite (..), Transaction (..), TxData (..), UnixTime, Unspent (..), confirmed, fromTransaction, isCoinbase,- nullBalance, sortTxs, toTransaction,+ nullBalance, toTransaction, transactionData) import UnliftIO (Exception)
src/Haskoin/Store/Manager.hs view
@@ -22,14 +22,19 @@ NodeEvent (..), PeerEvent (..), PeerManager, WithConnection, node)-import Haskoin.Store.BlockStore (BlockStoreConfig (..),- blockStore)+import Haskoin.Store.BlockStore (BlockStore,+ BlockStoreConfig (..),+ blockStore, blockStoreBlockSTM,+ blockStoreHeadSTM,+ blockStoreNotFoundSTM,+ blockStorePeerConnectSTM,+ blockStorePeerDisconnectSTM,+ blockStoreTxHashSTM,+ blockStoreTxSTM) import Haskoin.Store.Cache (CacheConfig (..), CacheWriter, cacheNewBlock, cacheNewTx, cacheWriter, connectRedis)-import Haskoin.Store.Common (BlockStore,- BlockStoreMessage (..),- StoreEvent (..))+import Haskoin.Store.Common (StoreEvent (..)) import Haskoin.Store.Database.Reader (DatabaseReader (..), connectRocksDB, withDatabaseReader)@@ -40,8 +45,8 @@ inboxToMailbox, newInbox, receive, sendSTM, withProcess, withPublisher, withSubscription)-import UnliftIO (MonadIO, MonadUnliftIO, link,- withAsync)+import UnliftIO (MonadIO, MonadUnliftIO, STM,+ link, withAsync) -- | Store mailboxes. data Store =@@ -191,29 +196,29 @@ cacheWriterDispatch _ = const (return ()) -- | Dispatcher of node events.-storeDispatch :: BlockStore -> Listen StoreEvent -> Listen NodeEvent+storeDispatch :: BlockStore -> Listen StoreEvent -> NodeEvent -> STM () -storeDispatch b pub (PeerEvent (PeerConnected p a)) = do- pub (StorePeerConnected p a)- BlockPeerConnect p a `sendSTM` b+storeDispatch b l (PeerEvent (PeerConnected p a)) = do+ l (StorePeerConnected p a)+ blockStorePeerConnectSTM p a b -storeDispatch b pub (PeerEvent (PeerDisconnected p a)) = do- pub (StorePeerDisconnected p a)- BlockPeerDisconnect p a `sendSTM` b+storeDispatch b l (PeerEvent (PeerDisconnected p a)) = do+ l (StorePeerDisconnected p a)+ blockStorePeerDisconnectSTM p a b storeDispatch b _ (ChainEvent (ChainBestBlock bn)) =- BlockNewBest bn `sendSTM` b+ blockStoreHeadSTM bn b storeDispatch _ _ (ChainEvent _) = return () -storeDispatch _ pub (PeerEvent (PeerMessage p (MPong (Pong n)))) =- pub (StorePeerPong p n)+storeDispatch _ l (PeerEvent (PeerMessage p (MPong (Pong n)))) =+ l (StorePeerPong p n) storeDispatch b _ (PeerEvent (PeerMessage p (MBlock block))) =- BlockReceived p block `sendSTM` b+ blockStoreBlockSTM p block b storeDispatch b _ (PeerEvent (PeerMessage p (MTx tx))) =- BlockTxReceived p tx `sendSTM` b+ blockStoreTxSTM p tx b storeDispatch b _ (PeerEvent (PeerMessage p (MNotFound (NotFound is)))) = do let blocks =@@ -221,19 +226,19 @@ | InvVector t h <- is , t == InvBlock || t == InvWitnessBlock ]- unless (null blocks) $ BlockNotFound p blocks `sendSTM` b+ unless (null blocks) $ blockStoreNotFoundSTM p blocks b -storeDispatch b pub (PeerEvent (PeerMessage p (MInv (Inv is)))) = do+storeDispatch b l (PeerEvent (PeerMessage p (MInv (Inv is)))) = do let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx]- pub (StoreTxAvailable p txs)- unless (null txs) $ BlockTxAvailable p txs `sendSTM` b+ l (StoreTxAvailable p txs)+ unless (null txs) $ blockStoreTxHashSTM p txs b -storeDispatch _ pub (PeerEvent (PeerMessage p (MReject r))) =+storeDispatch _ l (PeerEvent (PeerMessage p (MReject r))) = when (rejectMessage r == MCTx) $ case decode (rejectData r) of Left _ -> return () Right th ->- pub $+ l $ StoreTxReject p th (rejectCode r) (getVarString (rejectReason r)) storeDispatch _ _ (PeerEvent _) = return ()
src/Haskoin/Store/Web.hs view
@@ -1,15 +1,11 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Haskoin.Store.Web- ( Except (..)- , WebConfig (..)+ ( -- * Web+ WebConfig (..)+ , Except (..) , WebLimits (..) , WebTimeouts (..) , runWeb@@ -17,7 +13,6 @@ import Conduit () import Control.Applicative ((<|>))-import Control.DeepSeq (NFData) import Control.Monad (forever, guard, unless, when, (<=<)) import Control.Monad.Logger (MonadLogger, MonadLoggerIO,@@ -26,8 +21,7 @@ import Control.Monad.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (Encoding, ToJSON (..), object,- (.=))+import Data.Aeson (Encoding, ToJSON (..)) import Data.Aeson.Encoding (encodingToLazyByteString, list) import qualified Data.ByteString as B import Data.ByteString.Builder (lazyByteString)@@ -41,15 +35,12 @@ import Data.Serialize as Serialize import Data.String.Conversions (cs) import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as T.Lazy import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime, systemSeconds) import Data.Word (Word32, Word64) import Database.RocksDB (Property (..), getProperty)-import GHC.Generics (Generic) import Haskoin (Address, Block (..), BlockHash (..), BlockHeader (..), BlockHeight,@@ -67,21 +58,22 @@ PeerManager, chainGetBest, managerGetPeers, sendMessage) import Haskoin.Store.Cache (CacheT, delXPubKeys, withCache)-import Haskoin.Store.Common (BlockData (..), BlockRef (..),+import Haskoin.Store.Common (Limit, Offset, PubExcept (..),+ StoreEvent (..), StoreRead (..),+ applyOffset, blockAtOrBefore,+ getTransaction)+import Haskoin.Store.Data (BlockData (..), BlockRef (..), BlockTx (..), DeriveType (..),- Event (..), GenericResult (..),- HealthCheck (..), Limit,- Offset,+ Event (..), Except (..),+ GenericResult (..),+ HealthCheck (..), PeerInformation (..),- PubExcept (..), StoreEvent (..),- StoreInput (..), StoreRead (..),+ StoreInput (..), Transaction (..), TxData (..), TxId (..), UnixTime, Unspent, XPubBal (..), XPubSpec (..),- applyOffset, balanceToEncoding,- blockAtOrBefore, getTransaction,- isCoinbase, nullBalance,- transactionData,+ balanceToEncoding, isCoinbase,+ nullBalance, transactionData, transactionToEncoding, unspentToEncoding, xPubBalToEncoding,@@ -97,43 +89,17 @@ responseStatus) import NQE (Publisher, receive, withSubscription)+import qualified Paths_haskoin_store as P (version) import Text.Printf (printf) import Text.Read (readMaybe)-import UnliftIO (Exception, MonadIO,- MonadUnliftIO, askRunInIO,- liftIO, timeout)+import UnliftIO (MonadIO, MonadUnliftIO,+ askRunInIO, liftIO, timeout) import Web.Scotty.Internal.Types (ActionT) import Web.Scotty.Trans (Parsable, ScottyError) import qualified Web.Scotty.Trans as S type WebT m = ActionT Except (ReaderT WebConfig m) -data Except- = ThingNotFound- | ServerError- | BadRequest- | UserError String- | StringError String- | BlockTooLarge- deriving (Eq, Ord, Serialize, Generic, NFData)--instance Show Except where- show ThingNotFound = "not found"- show ServerError = "you made me kill a unicorn"- show BadRequest = "bad request"- show (UserError s) = s- show (StringError _) = "you killed the dragon with your bare hands"- show BlockTooLarge = "block too large"--instance Exception Except--instance ScottyError Except where- stringError = StringError- showError = T.Lazy.pack . show--instance ToJSON Except where- toJSON e = object ["error" .= T.pack (show e)]- data WebConfig = WebConfig { webPort :: !Int@@ -998,6 +964,7 @@ , healthSynced = sy , healthLastBlock = bd , healthLastTx = td+ , healthVersion = show P.version } where block_hash = headerHash . blockDataHeader
test/Haskoin/Store/CacheSpec.hs view
@@ -2,7 +2,7 @@ import Data.List (sort) import Haskoin.Store.Cache (blockRefScore, scoreBlockRef)-import Haskoin.Store.Common (BlockRef (..))+import Haskoin.Store.Data (BlockRef (..)) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, choose, forAll, listOf, oneof)
− test/Haskoin/Store/CommonSpec.hs
@@ -1,357 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Haskoin.Store.CommonSpec- ( spec- ) where--import Data.Aeson (Encoding, FromJSON (..), ToJSON (..),- Value)-import qualified Data.Aeson as A-import Data.Aeson.Encoding (encodingToLazyByteString)-import Data.Aeson.Parser (decodeWith, json)-import Data.Aeson.Types (Parser, parse)-import Data.ByteString (pack)-import qualified Data.ByteString.Short as BSS-import Data.Serialize (Serialize (..), decode, encode)-import Data.String.Conversions (cs)-import Haskoin (Address (..), BlockHash (..),- BlockHeader (..), Hash160 (..),- Hash256 (..), Network (..),- OutPoint (..), RejectCode (..),- Tx (..), TxHash (..), TxIn (..),- TxOut (..), XPubKey (..), bch,- bchRegTest, bchTest, btc, btcRegTest,- btcTest, ripemd160, sha256)-import Haskoin.Store.Common (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),- DeriveType (..), Event (..),- HealthCheck (..),- PeerInformation (..), Prev (..),- PubExcept (..), Spender (..),- StoreInput (..), StoreOutput (..),- Transaction (..), TxData (..),- TxId (..), Unspent (..), XPubBal (..),- XPubSpec (..), XPubSummary (..),- XPubUnspent (..), balanceParseJSON,- balanceToEncoding, balanceToJSON,- transactionToEncoding,- transactionToJSON, unspentToEncoding,- unspentToJSON, xPubUnspentToEncoding,- xPubUnspentToJSON)-import NQE ()-import Test.Hspec (Expectation, Spec, describe, shouldBe)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Arbitrary (..), Gen,- arbitraryPrintableChar,- arbitraryUnicodeChar, elements,- forAll, listOf, listOf1, oneof)--spec :: Spec-spec = do- describe "Binary serialization" $ do- prop "identity for derivation type" $ \x -> testSerial (x :: DeriveType)- prop "identity for xpub spec" $ \x -> testSerial (x :: XPubSpec)- prop "identity for block ref" $ \x -> testSerial (x :: BlockRef)- prop "identity for block tx" $ \x -> testSerial (x :: BlockTx)- prop "identity for balance" $ \x -> testSerial (x :: Balance)- prop "identity for unspent" $ \x -> testSerial (x :: Unspent)- prop "identity for block data" $ \x -> testSerial (x :: BlockData)- prop "identity for input" $ \x -> testSerial (x :: StoreInput)- prop "identity for spender" $ \x -> testSerial (x :: Spender)- prop "identity for output" $ \x -> testSerial (x :: StoreOutput)- prop "identity for previous output" $ \x -> testSerial (x :: Prev)- prop "identity for tx data" $ \x -> testSerial (x :: TxData)- prop "identity for transaction" $ \x -> testSerial (x :: Transaction)- prop "identity for xpub balance" $ \x -> testSerial (x :: XPubBal)- prop "identity for xpub unspent" $ \x -> testSerial (x :: XPubUnspent)- prop "identity for xpub summary" $ \x -> testSerial (x :: XPubSummary)- prop "identity for health check" $ \x -> testSerial (x :: HealthCheck)- prop "identity for event" $ \x -> testSerial (x :: Event)- prop "identity for txid" $ \x -> testSerial (x :: TxId)- prop "identity for publish exception" $ \x ->- testSerial (x :: PubExcept)- prop "identity for peer info" $ \x -> testSerial (x :: PeerInformation)- describe "JSON serialization" $ do- prop "identity for balance" . forAll arbitraryNetData $ \(net, x) ->- testNetJSON- (balanceParseJSON net)- (balanceToJSON net)- (balanceToEncoding net)- x- prop "identity for block tx" $ \x -> testJSON (x :: BlockTx)- prop "identity for block ref" $ \x -> testJSON (x :: BlockRef)- prop "identity for unspent" . forAll arbitraryNetData $ \(net, x) ->- testNetJSON parseJSON (unspentToJSON net) (unspentToEncoding net) x- prop "identity for block data" $ \x -> testJSON (x :: BlockData)- prop "identity for spender" $ \x -> testJSON (x :: Spender)- prop "identity for transaction" . forAll arbitraryNetData $ \(net, x) ->- testNetJSON- parseJSON- (transactionToJSON net)- (transactionToEncoding net)- x- prop "identity for xpub summary" $ \x -> testJSON (x :: XPubSummary)- prop "identity for xpub unspent" . forAll arbitraryNetData $ \(net, x) ->- testNetJSON- parseJSON- (xPubUnspentToJSON net)- (xPubUnspentToEncoding net)- x- prop "identity for health check" $ \x -> testJSON (x :: HealthCheck)- prop "identity for event" $ \x -> testJSON (x :: Event)- prop "identity for txid" $ \x -> testJSON (x :: TxId)- prop "identity for peer information" $ \x ->- testJSON (x :: PeerInformation)--testJSON :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation-testJSON input = (A.decode . A.encode) input `shouldBe` Just input--testNetJSON ::- (Eq a, Show a)- => (Value -> Parser a)- -> (a -> Value)- -> (a -> Encoding)- -> a- -> Expectation-testNetJSON parsejson tojson toenc x =- let encval = A.encode (tojson x)- encenc = encodingToLazyByteString (toenc x)- decval = decodeWith json (parse parsejson) encval- decenc = decodeWith json (parse parsejson) encenc- in do- decval `shouldBe` Just x- decenc `shouldBe` Just x--testSerial :: (Eq a, Show a, Serialize a) => a -> Expectation-testSerial input = (decode . encode) input `shouldBe` Right input--arbitraryNetwork :: Gen Network-arbitraryNetwork = elements [bch, btc, bchTest, btcTest, bchRegTest, btcRegTest]--arbitraryNetData :: Arbitrary a => Gen (Network, a)-arbitraryNetData = do- net <- arbitraryNetwork- x <- arbitrary- return (net, x)--instance Arbitrary BlockRef where- arbitrary =- oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary]--instance Arbitrary Hash256 where- arbitrary = sha256 . pack <$> listOf1 arbitrary--instance Arbitrary TxHash where- arbitrary = TxHash <$> arbitrary--instance Arbitrary OutPoint where- arbitrary = OutPoint <$> arbitrary <*> arbitrary--instance Arbitrary TxIn where- arbitrary =- TxIn <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*>- arbitrary--instance Arbitrary TxOut where- arbitrary = TxOut <$> arbitrary <*> (pack <$> listOf1 arbitrary)--instance Arbitrary Tx where- arbitrary = do- ver <- arbitrary- txin <- listOf1 arbitrary- txout <- listOf1 arbitrary- txlock <- arbitrary- return- Tx- { txVersion = ver- , txIn = txin- , txOut = txout- , txWitness = []- , txLockTime = txlock- }--instance Arbitrary Prev where- arbitrary = Prev <$> (pack <$> listOf1 arbitrary) <*> arbitrary--instance Arbitrary TxData where- arbitrary =- TxData- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary StoreInput where- arbitrary =- oneof- [ StoreCoinbase <$> arbitrary <*> arbitrary <*>- (pack <$> listOf1 arbitrary) <*>- (oneof- [ Just <$> (listOf $ pack <$> listOf1 arbitrary)- , return Nothing- ])- , StoreInput <$> arbitrary <*> arbitrary <*>- (pack <$> listOf1 arbitrary) <*>- (pack <$> listOf1 arbitrary) <*>- arbitrary <*>- (oneof- [ Just <$> (listOf $ pack <$> listOf1 arbitrary)- , return Nothing- ])- ]--instance Arbitrary Spender where- arbitrary = Spender <$> arbitrary <*> arbitrary--instance Arbitrary StoreOutput where- arbitrary =- StoreOutput <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*> arbitrary--instance Arbitrary Transaction where- arbitrary =- Transaction- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary PeerInformation where- arbitrary = do- PeerInformation- <$> (cs <$> listOf arbitraryUnicodeChar)- <*> listOf arbitraryPrintableChar- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary BlockHash where- arbitrary = BlockHash <$> arbitrary--instance Arbitrary HealthCheck where- arbitrary = do- bh <- arbitrary- hh <- arbitrary- let mb = elements [Nothing, Just bh]- mh = elements [Nothing, Just hh]- HealthCheck- <$> mb- <*> arbitrary- <*> mh- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary RejectCode where- arbitrary =- elements- [ RejectMalformed- , RejectInvalid- , RejectObsolete- , RejectDuplicate- , RejectNonStandard- , RejectDust- , RejectInsufficientFee- , RejectCheckpoint- ]--instance Arbitrary PubExcept where- arbitrary =- oneof- [ pure PubNoPeers- , PubReject <$> arbitrary- , pure PubTimeout- , pure PubPeerDisconnected- ]--instance Arbitrary XPubKey where- arbitrary =- XPubKey <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>- arbitrary--instance Arbitrary XPubSpec where- arbitrary = XPubSpec <$> arbitrary <*> arbitrary--instance Arbitrary DeriveType where- arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]--instance Arbitrary TxId where- arbitrary = TxId <$> arbitrary--instance Arbitrary BlockTx where- arbitrary = BlockTx <$> arbitrary <*> arbitrary--instance Arbitrary Hash160 where- arbitrary = ripemd160 . pack <$> listOf1 arbitrary--instance Arbitrary Address where- arbitrary =- oneof- [ PubKeyAddress <$> arbitrary- , ScriptAddress <$> arbitrary- ]--instance Arbitrary Balance where- arbitrary =- Balance- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary Unspent where- arbitrary =- Unspent <$> arbitrary <*> arbitrary <*> arbitrary <*>- (BSS.toShort . pack <$> listOf1 arbitrary)--instance Arbitrary BlockHeader where- arbitrary =- BlockHeader <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>- arbitrary <*>- arbitrary--instance Arbitrary BlockData where- arbitrary =- BlockData- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> listOf1 arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary XPubBal where- arbitrary = XPubBal <$> arbitrary <*> arbitrary--instance Arbitrary XPubUnspent where- arbitrary = XPubUnspent <$> arbitrary <*> arbitrary--instance Arbitrary XPubSummary where- arbitrary =- XPubSummary- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary Event where- arbitrary =- oneof [EventBlock <$> arbitrary, EventTx <$> arbitrary]