haskoin-store 0.65.12 → 1.0.0

raw patch · 16 files changed

+7178/−5481 lines, 16 filesdep ~base16dep ~haskoin-coredep ~haskoin-nodePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base16, haskoin-core, haskoin-node, haskoin-store-data

API changes (from Hackage documentation)

Files

• CHANGELOG.md +1758/−0
• README.md +57/−0
• app/Main.hs +643/−813
• haskoin-store.cabal +18/−15
• src/Haskoin/Store/BlockStore.hs +301/−256
• src/Haskoin/Store/Cache.hs +339/−326
• src/Haskoin/Store/Common.hs +64/−84
• src/Haskoin/Store/Database/Reader.hs +104/−93
• src/Haskoin/Store/Database/Types.hs +79/−121
• src/Haskoin/Store/Database/Writer.hs +131/−115
• src/Haskoin/Store/Logic.hs +254/−248
• src/Haskoin/Store/Manager.hs +161/−130
• src/Haskoin/Store/Stats.hs +56/−52
• src/Haskoin/Store/Web.hs +3162/−3190
• test/Haskoin/Store/CacheSpec.hs +2/−2
• test/Haskoin/StoreSpec.hs +49/−36

@@ -0,0 +1,1758 @@+# 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)++## [1.0.0] - 2023-07-28++### Changed++- Compatibility with latest haskoin-core and haskoin-node packages.+- Use DuplicateRecordFields and OverloadedRecordDot language extensions.+- Modernize package in a backwards-incompatible manner.+- Refactor package extensively.++## [0.65.10] - 2023-05-12++### Changed++- Revert to older LTS Haskell to attempt to resolve memory leak.++### Removed++- Remove unnecessary lock release.++## [0.65.9] - 2023-05-09++### Changed++- Be more aggressive caching individual transactions.+- Introduce a periodic cache mempool sync task.++## [0.65.8] - 2023-05-08++### Changed++- Perform health check in separate thread.++## [0.65.7] - 2023-05-05++### Changed++- Do not sync mempool to Redis if node is not up-to-date.++## [0.65.6] - 2023-05-04++### Changed++- Improve caching ingestion performance.++## [0.65.5] - 2022-09-19++### Added++- Fee field added to Blockchain.info-style export-history endpoint.++### Changed++- Bump version due to Git mistake.++## [0.65.3] - 2022-04-13++### Added++- IPv6 peer support.++## [0.65.2] - 2022-04-13++### Fixed++- Correct lazy bytestring deserialization algorithm for web client.++## [0.65.1] - 2022-04-13++### Changed++- Simplify function in Cache module.+- Bump depenedencies.++## [0.65.0] - 2022-02-03++### Changed++- Spenders now embedded into tx objects in database for performance.+- Use faster IORef instead of slow TVar when ingesting.+- Use mutable hash tables when ingesting.+- Allow to disable unscalable API endpoints.++## [0.64.19] - 2022-02-01++### Added++- Allow to set query timeouts.++## [0.64.18] - 2022-01-21++### Fixed++- Off-by-one error when importing change addresses to cache.++## [0.64.17] - 2022-01-21++### Fixed++- Add change addresses to cache when necessary.++## [0.64.16] - 2022-01-10++### Fixed++- Correct fee calculation for blocks that do not claim all rewards.++## [0.64.15] - 2022-01-07++### Fixed++- Correct scale of cache pruning code.++## [0.64.14] - 2022-01-07++### Fixed++- Always prune to 80% of max cache size.++## [0.64.13] - 2022-01-07++### Fixed++- Avoid doing a hissy fit on transient cache issue.++## [0.64.12] - 2022-01-07++### Fixed++- Prune a little more cache to allow for new keys.++## [0.64.11] - 2022-01-06++### Fixed++- Prune cache more often.++## [0.64.10] - 2021-12-30++### Changed++- Return empty addresses in xpub balances call.++## [0.64.9] - 2021-12-29++### Fixed++- Avoid notifying same transactions in mempool.++## [0.64.8] - 2021-12-26++### Changed++- Use better Fourmolu format.+- Be more precise when counting retrieved items.++### Fixed++- Avoid transactions duplicated in xpub data.+- Refactor some functions to make them more robust.++## [0.64.7] - 2021-12-26++### Fixed++- Optimisations for various Blockchain endpoints.+- More accurate item counts for various web endpoints.++## [0.64.6] - 2021-12-25++### Fixed++- Record cache index time just once per xpub.++## [0.64.5] - 2021-12-25++### Changed++- Add suffix cached to cache entries to avoid conflicts with data entries.++## [0.64.4] - 2021-12-25++### Fixed+- Bring dots back and avoid stats hacks.++## [0.64.3] - 2021-12-25++### Fixed++- Fix typo.++## [0.64.2] - 2021-12-25++### Changed++- Replace dots for underscores in metrics.++## [0.64.1] - 2021-12-25++### Changed++- Automatic formatting.+- Improve cache debug logging.++### Fixed++- Add item count to 'all' query metrics.++## [0.64.0] - 2021-12-25++### Changed++- Improve metrics.++### Fixed++- Get lock before importing transactions to cache.++## 0.63.0+### Fixed+- Make cache updates lightweight.++## 0.62.1+### Fixed+- Fix idempotent transaction elimination bug.++## 0.62.0+### Added+- Configurable Blockchain price URLs.+- Reuse HTTP connections with wreq sessions.++## 0.61.1+### Changed+- Upstream improvements on Base58 performance.++## 0.61.0+### Fixed+- Fixed recursion bug in Blockchain format conversion function.++## 0.60.0+### Fixed+- Correct notifications subsystem.++## 0.59.0+### Fixed+- Correct internal dependency.++## 0.58.0+### Fixed+- Correct output freeing algorithm.++## 0.57.0+### Changed+- Report errors freeing outputs.++## 0.56.0+### Changed+- Report all deleted mempool transactions.+- Crash on certain data corruption.++## 0.55.0+### Changed+- Always have a previous output object in Blockchain inputs.++## 0.54.0+### Added+- WebSocket support.+- Testnet4 support.++## 0.53.11+### Changed+- Dummy version increase to signal upstream update of Haskoin Core.++## 0.53.10+### Fixed+- Correct test that was reversed in previous version.++## 0.53.9+### Removed+- Mempool is no longer synced by default to fix public Bitcoin Core regression.++## 0.53.8+### Changed+- Put derivations stat inside database.++## 0.53.7+### Added+- Added counters for database retrievals.+- Added counter for xpub derivations.++### Changed+- Removed some buggy or unnecessary stats.++## 0.53.6+### Changed+- Improve web server statistics.++## 0.53.5+### Addded+- Endpoint to delete an xpub from cache.++## 0.53.4+### Added+- Debugging when reverting block.++### Fixed+- Negative (headers - blocks) diff shown incorrectly.+- Infinite loop when removing a block's coinbase transaction.++## 0.53.3+### Added+- Blockchain.info endpoint: `q/pubkeyhash/:addr`.+- Blockchain.info endpoint: `q/getsentbyaddress/:addr`.+- Blockchain.info endpoint: `q/pubkeyaddr/:addr`.+- Configurable request body limit size.++## 0.53.2+### Fixed+- Return output in satoshi for some endpoints.++## 0.53.1+### Fixed+- Return 404 in case of bad address.++## 0.53.0+### Added+- Blockchain.info endpoint: `q/addresstohash/:addr`.+- Blockchain.info endpoint: `q/addrpubkey/:pubkey`.+- Blockchain.info endpoint: `q/hashpubkey/:pubkey`.+- Blockchain.info endpoint: `q/getblockcount`.+- Blockchain.info endpoint: `q/latesthash`.+- Blockchain.info endpoint: `q/bcperblock`.+- Blockchain.info endpoint: `q/txtotalbtcoutput/:txid`.+- Blockchain.info endpoint: `q/txtotalbtcinput/:txid`.+- Blockchain.info endpoint: `q/txfee/:txid`.+- Blockchain.info endpoint: `q/txresult/:txhash/:addr`.+- Blockchain.info endpoint: `q/getreceivedbyaddress/:addr`.+- Blockchain.info endpoint: `q/addressbalance/:addr`.+- Blockchain.info endpoint: `q/addressfirstseen/:addr`.+- Support xpubs in `blockchain/rawaddr` endpoint.++### Fixed+- Various latest blocks endpoint fixes.+- Allow empty parameters in Blockchain.info POST requests.++## 0.52.13+### Fixed+- Upstream fixes for unknown inv types.++## 0.52.12+### Fixed+- Fix limits for legacy endpoints.++## 0.52.11+### Added+- Alias for Blockchain.info raw address endpoint.++### Fixed+- Fix unknown message types without payload upstream.+- Randomise peer timeouts upstream.++## 0.52.10+### Fixed+- Fix binary search algorithm for blocks upstream.++## 0.52.9+### Added+- Add Blockchain.info latest block endpoint.+- Add Blockchain.info unconfirmed-transactions endpoint.+- Add Blockchain.info blocks for one day endpoint.++## 0.52.8+### Fixed+- Fix special case for zero limit.++## 0.52.7+### Fixed+- Fix cache bug when too many transactions in mempool.++## 0.52.6+### Changed+- Use rationals for Blockchain.info export-history endpoint arithmetics.++## 0.52.5+### Added+- Support for Blockchain.info export-history endpoint.++### Fixed+- Use strict bytestring decoder for HTTP API client.++## 0.52.4+### Fixed+- Use Base58 addresses by default in Blockchain.info balance querios.++## 0.52.3+### Fixed+- Errors should also contain CORS headers.++## 0.52.2+### Fixed+- Blockchain.info raw address limit should use `limit` parametre and not `n`.++## 0.52.1+### Changed+- Stream multiple transactions when requested.++### Fixed+- Fix missing unspent outputs.++## 0.52.0+### Changed+- Remove unnecessary performance optimisations.++### Fixed+- Reduce balance retrievals for xpubs.+- Hack UTXO ordering to avoid unwanted behaviours.+- Do not merge conduits when there are too many.++## 0.51.0+### Fixed+- Data type for RequestTooLarge was missing.++## 0.50.3+### Added+- Log HTTP request bodies.++### Removed+- Remove web request timeout.++### Fixed+- Do not ignore unknown start tx anchors in conduits.+- Use fast transaction counting in cache.++### Changed+- Use WAI middlewares to manage stats.++## 0.50.2+### Fixed+- Do not use lazy parsers for incoming data that may throw exceptions.++## 0.50.1+### Fixed+- Do not allow incoming POST requests of unlimited body size.++## 0.50.0+### Added+- Limit number of simultaneous xpubs being cached.++## 0.49.0+### Changed+- Improve conduit merging algorithm.++## 0.48.0+### Added+- Timeouts and token bucket for web requests.+- Configurable price fetch interval.++## 0.47.6+### Fixed+- Fix web.all stat.++## 0.47.5+### Changed+- Simplify stats.++## 0.47.4+### Added+- Implement Blockchain.info block height.+- Implement Blockchain.info raw address.+- Implement Blockchain.info balances.++### Fixed+- Make Blockchain.info unspent endpoint more efficient.+- Make Blockchain.info xpubs endpoint more efficient.++### Changed+- Use compact JSON serialization by default everywhere.++## 0.47.3+### Fixed+- Fix serialization bug with unspents.++## 0.47.2+### Fixed+- Fix serialization bug for health check.++## 0.47.1+### Fixed+- Fix serialization bugs for web data types.++## 0.47.0+### Added+- Support for legacy block endpoints.++### Changed+- Serialization now uses bytes library and does interleaved IO.++## 0.46.6+### Added+- Allow comma-separated values in multiaddr.++## 0.46.5+### Changed+- Throw error when offset exceeded instead of truncating it.++## 0.46.4+### Fixed+- Do not compute balances separately for loose addresses when part of an xpub.++### Changed+- Do not fetch entire transaction list for loose addresses.+- Transaction count in wallet object is just a synonym for filtered tx count.+- Use conduits to prevent over-fetching transactions from database.++## 0.46.3+### Fixed+- Make hex value encoding compatible with Java BigInteger decoder.++## 0.46.2+### Changed+- Allow negative confirmations for compatibility with old API.++## 0.46.1+### Added+- Filters for transactions in multiaddr endpoint.++## 0.46.0+### Fixed+- Release to fix unintentional upload.++## 0.45.0+### Added+- Using a tx_index that results in a txid conflict returns a 409 - Conflict.++## 0.44.0+### Changed+- Numeric txid now 53 bits long and doesn't return transactions when hashes collide.++## 0.43.1+### Fixed+- Do not overcount statistics.++## 0.43.0+### Changed+- Transaction index now simply encodes txid as a long number (sorry JS users).++## 0.42.4+### Changed+- Optimise encoding of JSON data for Blockchain.info API.++## 0.42.3+### Changed+- Narrow down the balance for transactions to onlyShow set.++## 0.42.2+### Changed+- Make unspent algorithm more efficient.++## 0.42.1+### Added+- Support for Blockchain.info API unspent endpoint.++### Fixed+- Fix RBF transactions on Blockchain.info API.++## 0.42.0+### Removed+- No more pruning of old mempool transactions.++## 0.41.4+### Fixed+- Correct error computing wallet balances.++## 0.41.3+### Changed+- Use whole active set when computing results for multiaddr.+- Compute correct count of transactions for wallet.++## 0.41.2+### Changed+- Caching mempool is not much slower when pruning, so reversing that change.++## 0.41.1+### Changed+- Only prune mempool every ten minutes or so.++## 0.41.0+### Removed+- No more cache eviction endpoint.++## 0.40.22+### Added+- More metrics for cache.++## 0.40.21+### Added+- Support HTTP GET for multiaddr endpoint.++## 0.40.20+### Added+- Prefix 'app.' in statsd when using Nomad variables.++## 0.40.19+### Added+- Statsd support and pleny of statistics.++### Removed+- Removed use of sync lock for importing xpubs in cache due to volume.++## 0.40.18+### Added+- New options to control cache lock retry count and delay.++### Changed+- Cache xpubs asyncrhonously.+- Mempool syncs fully every refresh cycle.++## 0.40.17+### Changed+- Delete more than 1000 xpubs from Redis if needed.+- Attempt to get lock ten times in order to index a new xpub.++## 0.40.16+### Fixed+- Fix best block not set.++## 0.40.15+### Fixed+- Do not update cache best block if it is higher.++## 0.40.14+### Fixed+- Always respond to cache pings to avoid getting stuck.++## 0.40.13+### Added+- Be more careful about importing blocks to the cache.++### Removed+- Reduce excessive cache logging.++## 0.40.12+### Fixed+- Correct bad arithmetics in cache cooldown.++## 0.40.11+### Added+- Debug log cache cooldown.++### Fixed+- Unlimited retry lock acquisition now works.+- Make locking tighter++## 0.40.10+### Changed+- Reduce the number of things that cache do when pinged.++## 0.40.9+### Fixed+- Avoid filling the cache actor mailbox with pings.++## 0.40.8+### Fixed+- Correct a typo in cache code.++## 0.40.7+### Changed+- Improve cache mempool sync algorithm.++## 0.40.6+### Changed+- Make cache cooldown a number.++## 0.40.5+### Added+- Log every non-successful query.++## 0.40.4+### Fixed+- Use Redis TTL for cache cooldown.++## 0.40.3+### Fixed+- Mempool no longer gets saved in cache when node is not in sync.++## 0.40.2+### Changed+- Change source of price data to https://blockchain.info/ticker.++## 0.40.1+### Removed+- Do not expose Paths_haskoin_store module explicitly.++## 0.40.0+### Added+- Blockchain.info API compatibility for multiaddr and rawtx endpoints.++### Changed+- Segwit fields are no longer omitted on incompatible networks.++## 0.39.0+### Changed+- Upgrade Haskoin Core to support higher version on witness addresses.++## 0.38.4+### Fixed+- Fix block search by timestamp.++## 0.38.3+### Changed+- Disable low latency garbage collector by default.++## 0.38.2+### Changed+- Use GHC 8.10 and its low latency garbage collector.++## 0.38.1+### Changed+- Optimise algorithm for fork safety check.++## 0.38.0+### Added+- Support for Bitcoin Cash hard fork.++## 0.37.5+### Added+- Configurable cache refresh time.++## 0.37.4+### Fixed+- Now request mempool when connecting even if already in sync.++### Changed+- Add a delay to mempool sync to allow for block headers to catch up.+- Attempt to sync mempool whenever syncing is done or a new peer connects.++## 0.37.3+### Changed+- Correct logic error when deleting superseded transactions.++## 0.37.2+### Changed+- Simplify multiple algorithms to hopefully solve corruption bug.+- Allow to disable mempool transaction indexing via command line.++## 0.37.1+### Changed+- Better locking around caching operations.+- Have a global cooldown on cache mempool updates.++### Fixed+- Fix address unspent retrieval using correct column family.++## 0.37.0+### Added+- Add support for column families and prefixes breaking database backwards compatibility.++## 0.36.2+### Fixed+- Fix another place where mempool sorting was wrong.++## 0.36.1+### Fixed+- Fix wrong sorting of mempool transactions in database.++## 0.36.0+### Changed+- Do not use STM transactions because it is impossible to reason about preloading.+- Make importing blocks after mempool is populated faster.++## 0.35.2+### Changed+- Reduce frequency of cache mempool updates.++## 0.35.1+### Changed+- Remove cache lock retries.+- Do not use lock when caching a new xpub.++## 0.35.0+### Changed+- Use new RocksDB Haskell bindings.+- Make headers - blocks diff configurable in health check.+- Simplify locking in cache.++## 0.34.8+### Changed+- Minor refactoring.+- Only send one mempool message ever.++## 0.34.7+### Changed+- Fix block heights endpoint URL.++## 0.34.6+### Removed+- Remove asynchronous database retrieval permanently due to instability.++## 0.34.5+### Added+- Preload memory before freeing outputs.++## 0.34.4+### Added+- Asynchronous preloading only for blocks.++## 0.34.3+### Removed+- Disable asynchronous preloading to prevent segmentation fault error.++## 0.34.2+### Removed+- No more upper limit for mempool call.++### Fixed+- Health check uses minimum between last block and mempool tx.++## 0.34.1+### Added+- Pending mempool transactions health check.++### Removed+- No more upper limit for mempool call.++## 0.34.0+### Changed+- New format for health check.++## 0.33.1+### Changed+- Upload with updated Cabal files.++## 0.33.0+### Fixed+- Fix outputs showing up as both spent and unspent.++### Changed+- Simplify data structures used to hold uncommitted changes.+- Split StoreRead class in two.+- Improve pre-loading algorithms.++## 0.32.3+### Fixed+- Fix command line argument mappings to env vars.++## 0.32.2+### Fixed+- Do not complain when deleting non-existent unconfirmed txs.++## 0.32.1+### Fixed+- Fix corruption bug when deleting transactions during some reorgs.+- Fix tests on data package.+- Rename upstream address string functions.++## 0.32.0+### Changed+- Concurrently load dependencies when importing transaction data.+- Import each transaction using STM.+- Rework logging.+- Refactor all block chain importing algorithms.+- Use peer locking when importing data.+- Change license to MIT.++### Added+- Make max peer count configurable.++### Fixed+- Prevent premature peer timeouts when importing blocks.++## 0.31.0+### Added+- Add Haskell web client code to data library.+- Use type-safe definitions for web paths and parameters.+- Support JSON pretty encoding and enable by default for some endpoints.+- Allow environment variables for configuration.++### Changed+- Change command-line arguments to better fit GNU style.+- Refactor code to manipulate address balances.+- Improve logging.+- Rate-limit mempool importing.+- Do not add xpubs to cache if node not in sync.+- Do not import transactions to cache if no xpubs in cache.+- Refactor transaction importing logic extremely.+- Refactor memory database and writer.++### Fixed+- Fix BTC double-count transaction bug.+- Add missing xpub derive parameter to xpub evict documentation.++## 0.30.1+### Changed+- Limit mempool API endpoint list.++## 0.30.0+### Changed+- Raw JSON values are now wrapped in an object with a result property.+- Better logging when importing transactions into mempool.++### Fixed+- Transaction limit by block height works now.++## 0.29.3+### Changed+- Revert concurrent retrieval changes from 0.29.1 and 0.29.0 to solve stability+  issues.+- Bitcoin Cash (BCH) replaces BTC as default network in CLI.+- Peer discovery enabled automatically if no peers specified in CLI.+- Use separate Stack configuration file for data package.++## 0.29.2+### Changed+- Increase timeouts for manager and chain health checks.++## 0.29.1+### Added+- Perform xpub operations concurrently.++## 0.29.0+### Changed+- BlockTx renamed to TxRef.+- Remove unnecessary monad transformers to simplify import code.++### Added+- Retrieve balances and unspent outputs concurrently when importing.+- Coin instance for Unspent in data package.++## 0.28.0+### Changed+- Change the way that limits, start, and offset values are handled.++### Fixed+- Fix incorrect limit responses.++## 0.27.0+### Added+- Complete support for offset.++### Changed+- Improve monad stack for cache.++## 0.26.6+### Added+- Support for offset in all endpoints where it makes sense.++## 0.26.5+### Fixed+- Sort after using the nub function or use Data.List.nub in exceptional cases.++## 0.26.4+### Changed+- Don't do certain validity checks on confirmed transactions.++### Fixed+- Do not crash when syncing the blockchain from scratch on a populated cache.++## 0.26.3+### Changed+- Replace nub function everywhere with faster version written using hash sets.++### Fixed+- Fix shared cache locking.++## 0.26.2+### Changed+- Simplify cache block import code.+- Improve cache import performance.++## 0.26.1+### Fixed+- Do not call zadd or zrem in Redis with incorrect argument count.++### Changed+- Do not use slow Transaction type in Logic.+- Improve logging while importing blocks.+- Better transaction import algorithm.++## 0.26.0+### Changed+- Add information to some binary types for feature parity with JSON.++## 0.25.4+### Changed+- Hide segwit data on non-segwit networks.++### Fixed+- Fix work which now always serialises as a number literal.++## 0.25.3+### Changed+- Fix version display on health check.++## 0.25.2+### Changed+- Fix wrong version of Haskoin Store Data dependency.++## 0.25.1+### Changed+- Improve code organisation.+- Split data definitions and serialisation into its own package.++## 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.

@@ -0,0 +1,57 @@+# Haskoin Store++Block chain store and index featuring:++- Persistent storage using [RocksDB](https://rocksdb.org/).+- [Bitcoin Cash (BCH)](https://www.bitcoincash.org/) support.+- [Bitcoin Core (BTC)](https://bitcoin.org/) support.+- Indices for address balances, transactions, and unspent outputs (UTXO).+- Persistent mempool.+- Replace Bitcoin Core (BTC) RBF transactions by default.+- Query transactions, balances and UTXO on extended keys (xpub).+- Optional accelerated xpub cache using Redis.+- RESTful API with JSON and binary serialization.+- High performance concurrent architecture.+- Compatibility with Blockchain.info-style endpoints.++## Install with Nix on any distribution++* Get [Nix](https://nixos.org/nix/)++```sh+nix-env --install stack+git clone https://github.com/haskoin/haskoin-store.git+cd haskoin-store+stack --nix build --copy-bins+~/.local/bin/haskoin-store --help+```++## Install on Ubuntu or Debian++```sh+apt install git zlib1g-dev libsecp256k1-dev librocksdb-dev pkg-config haskell-stack+git clone https://github.com/haskoin/haskoin-store.git+cd haskoin-store+stack build --copy-bins+~/.local/bin/haskoin-store --help+```++## Install on Fedora++```sh+dnf install git zlib-devel libsecp256k1-devel rocksdb-devel stack+git clone https://github.com/haskoin/haskoin-store.git+cd haskoin-store+stack build --copy-bins+~/.local/bin/haskoin-store --help+```++## Non-Haskell Dependencies++* [zlib](https://zlib.net/)+* [libsecp256k1](https://github.com/Bitcoin-ABC/secp256k1)+* [RocksDB](https://github.com/facebook/rocksdb)++## API Documentation++* [Swagger API Documentation](https://api.haskoin.com/)

@@ -1,815 +1,645 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}--module Main where--import Control.Applicative ((<|>))-import Control.Arrow (second)-import Control.Monad (when)-import Control.Monad.Logger-  ( LogLevel (..),-    filterLogger,-    logInfoS,-    runStderrLoggingT,-  )-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Char (toLower)-import Data.Default (Default (..))-import Data.List (intercalate)-import Data.Maybe (fromMaybe)-import Data.String.Conversions (cs)-import qualified Data.Text as T-import Data.Word (Word32)-import Haskoin-  ( Network (..),-    allNets,-    bch,-    bchRegTest,-    bchTest,-    bchTest4,-    btc,-    btcRegTest,-    btcTest,-    eitherToMaybe,-  )-import Haskoin.Node (withConnection)-import Haskoin.Store-  ( StoreConfig (..),-    WebConfig (..),-    WebLimits (..),-    WebTimeouts (..),-    runWeb,-    withStore,-  )-import Haskoin.Store.Stats (withStats)-import Options.Applicative-  ( Parser,-    auto,-    eitherReader,-    execParser,-    flag,-    fullDesc,-    header,-    help,-    helper,-    info,-    long,-    many,-    metavar,-    option,-    progDesc,-    short,-    showDefault,-    strOption,-    switch,-    value,-  )-import System.Exit (exitSuccess)-import System.FilePath ((</>))-import System.IO.Unsafe (unsafePerformIO)-import Text.Read (readMaybe)-import UnliftIO (MonadIO)-import UnliftIO.Directory-  ( createDirectoryIfMissing,-    getAppUserDataDirectory,-  )-import UnliftIO.Environment (lookupEnv)--version :: String--#ifdef CURRENT_PACKAGE_VERSION-version = CURRENT_PACKAGE_VERSION-#else-version = "Unavailable"-#endif--data Config = Config-  { configDir :: !FilePath,-    configHost :: !String,-    configPort :: !Int,-    configNetwork :: !String,-    configDiscover :: !Bool,-    configPeers :: ![String],-    configVersion :: !Bool,-    configDebug :: !Bool,-    configMaxPending :: !Int,-    configWebLimits :: !WebLimits,-    configWebTimeouts :: !WebTimeouts,-    configRedis :: !Bool,-    configRedisURL :: !String,-    configRedisMin :: !Int,-    configRedisMax :: !Integer,-    configWipeMempool :: !Bool,-    configNoMempool :: !Bool,-    configSyncMempool :: !Bool,-    configPeerTimeout :: !Int,-    configPeerMaxLife :: !Int,-    configMaxPeers :: !Int,-    configMaxDiff :: !Int,-    configStatsd :: !Bool,-    configStatsdHost :: !String,-    configStatsdPort :: !Int,-    configStatsdPrefix :: !String,-    configWebPriceGet :: !Int,-    configWebTickerURL :: !String,-    configWebHistoryURL :: !String,-    configWebNoBlockchain :: !Bool,-    configWebNoSlow :: !Bool,-    configHealthCheckInterval :: !Int,-    configCacheMempoolSync :: !Int-  }--instance Default Config where-  def =-    Config-      { configDir = defDirectory,-        configHost = defHost,-        configPort = defPort,-        configNetwork = defNetwork,-        configDiscover = defDiscover,-        configPeers = defPeers,-        configVersion = False,-        configDebug = defDebug,-        configMaxPending = defMaxPending,-        configWebLimits = defWebLimits,-        configWebTimeouts = defWebTimeouts,-        configRedis = defRedis,-        configRedisURL = defRedisURL,-        configRedisMin = defRedisMin,-        configRedisMax = defRedisMax,-        configWipeMempool = defWipeMempool,-        configNoMempool = defNoMempool,-        configSyncMempool = defSyncMempool,-        configPeerTimeout = defPeerTimeout,-        configPeerMaxLife = defPeerMaxLife,-        configMaxPeers = defMaxPeers,-        configMaxDiff = defMaxDiff,-        configStatsd = defStatsd,-        configStatsdHost = defStatsdHost,-        configStatsdPort = defStatsdPort,-        configStatsdPrefix = defStatsdPrefix,-        configWebPriceGet = defWebPriceGet,-        configWebTickerURL = defWebTickerURL,-        configWebHistoryURL = defWebHistoryURL,-        configWebNoBlockchain = defWebNoBlockchain,-        configWebNoSlow = defWebNoSlow,-        configHealthCheckInterval = defHealthCheckInterval,-        configCacheMempoolSync = defCacheMempoolSync-      }--defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a-defEnv e d p = do-  ms <- lookupEnv e-  return $ fromMaybe d $ p =<< ms--defMaxPending :: Int-defMaxPending =-  unsafePerformIO $-    defEnv "MAX_PENDING_TXS" 100 readMaybe-{-# NOINLINE defMaxPending #-}--defMaxPeers :: Int-defMaxPeers =-  unsafePerformIO $-    defEnv "MAX_PEERS" 20 readMaybe-{-# NOINLINE defMaxPeers #-}--defDirectory :: FilePath-defDirectory = unsafePerformIO $ do-  d <- getAppUserDataDirectory "haskoin-store"-  defEnv "DIR" d pure-{-# NOINLINE defDirectory #-}--defHost :: String-defHost =-  unsafePerformIO $-    defEnv "HOST" "*" pure-{-# NOINLINE defHost #-}--defPort :: Int-defPort =-  unsafePerformIO $-    defEnv "PORT" 3000 readMaybe-{-# NOINLINE defPort #-}--defNetwork :: String-defNetwork =-  unsafePerformIO $-    defEnv "NET" "bch" pure-{-# NOINLINE defNetwork #-}--defRedisMin :: Int-defRedisMin =-  unsafePerformIO $-    defEnv "CACHE_MIN" 100 readMaybe-{-# NOINLINE defRedisMin #-}--defRedis :: Bool-defRedis =-  unsafePerformIO $-    defEnv "CACHE" False parseBool-{-# NOINLINE defRedis #-}--defSyncMempool :: Bool-defSyncMempool =-  unsafePerformIO $-    defEnv "SYNC_MEMPOOL" False parseBool-{-# NOINLINE defSyncMempool #-}--defDiscover :: Bool-defDiscover =-  unsafePerformIO $-    defEnv "DISCOVER" False parseBool-{-# NOINLINE defDiscover #-}--defPeers :: [String]-defPeers =-  unsafePerformIO $-    defEnv "PEER" [] (pure . words)-{-# NOINLINE defPeers #-}--defDebug :: Bool-defDebug =-  unsafePerformIO $-    defEnv "DEBUG" False parseBool-{-# NOINLINE defDebug #-}--defWebLimits :: WebLimits-defWebLimits = unsafePerformIO $ do-  max_limit <- defEnv "MAX_LIMIT" (maxLimitCount def) readMaybe-  max_full <- defEnv "MAX_FULL" (maxLimitFull def) readMaybe-  max_offset <- defEnv "MAX_OFFSET" (maxLimitOffset def) readMaybe-  def_limit <- defEnv "DEF_LIMIT" (maxLimitDefault def) readMaybe-  max_gap <- defEnv "MAX_GAP" (maxLimitGap def) readMaybe-  init_gap <- defEnv "INIT_GAP" (maxLimitInitialGap def) readMaybe-  max_body <- defEnv "MAX_BODY" (maxLimitBody def) readMaybe-  max_timeout <- defEnv "MAX_TIMEOUT" (maxLimitTimeout def) readMaybe-  return-    WebLimits-      { maxLimitCount = max_limit,-        maxLimitFull = max_full,-        maxLimitOffset = max_offset,-        maxLimitDefault = def_limit,-        maxLimitGap = max_gap,-        maxLimitInitialGap = init_gap,-        maxLimitBody = max_body,-        maxLimitTimeout = max_timeout-      }-{-# NOINLINE defWebLimits #-}--defWebNoBlockchain :: Bool-defWebNoBlockchain =-  unsafePerformIO $-    defEnv "NO_BLOCKCHAIN" False parseBool-{-# NOINLINE defWebNoBlockchain #-}--defWebNoSlow :: Bool-defWebNoSlow =-  unsafePerformIO $-    defEnv "NO_SLOW" False parseBool-{-# NOINLINE defWebNoSlow #-}--defWebTimeouts :: WebTimeouts-defWebTimeouts = unsafePerformIO $ do-  block_timeout <- defEnv "BLOCK_TIMEOUT" (blockTimeout def) readMaybe-  tx_timeout <- defEnv "TX_TIMEOUT" (txTimeout def) readMaybe-  return-    WebTimeouts-      { txTimeout = tx_timeout,-        blockTimeout = block_timeout-      }-{-# NOINLINE defWebTimeouts #-}--defWipeMempool :: Bool-defWipeMempool =-  unsafePerformIO $-    defEnv "WIPE_MEMPOOL" False parseBool-{-# NOINLINE defWipeMempool #-}--defNoMempool :: Bool-defNoMempool =-  unsafePerformIO $-    defEnv "NO_MEMPOOL" False parseBool-{-# NOINLINE defNoMempool #-}--defRedisURL :: String-defRedisURL =-  unsafePerformIO $-    defEnv "REDIS" "" pure-{-# NOINLINE defRedisURL #-}--defRedisMax :: Integer-defRedisMax =-  unsafePerformIO $-    defEnv "CACHE_KEYS" 100000000 readMaybe-{-# NOINLINE defRedisMax #-}--defPeerTimeout :: Int-defPeerTimeout =-  unsafePerformIO $-    defEnv "PEER_TIMEOUT" 120 readMaybe-{-# NOINLINE defPeerTimeout #-}--defPeerMaxLife :: Int-defPeerMaxLife =-  unsafePerformIO $-    defEnv "PEER_MAX_LIFE" (48 * 3600) readMaybe-{-# NOINLINE defPeerMaxLife #-}--defMaxDiff :: Int-defMaxDiff =-  unsafePerformIO $-    defEnv "MAX_DIFF" 2 readMaybe-{-# NOINLINE defMaxDiff #-}--defStatsd :: Bool-defStatsd =-  unsafePerformIO $-    defEnv "STATSD" False parseBool-{-# NOINLINE defStatsd #-}--defStatsdHost :: String-defStatsdHost =-  unsafePerformIO $-    defEnv "STATSD_HOST" "localhost" pure-{-# NOINLINE defStatsdHost #-}--defStatsdPort :: Int-defStatsdPort =-  unsafePerformIO $-    defEnv "STATSD_PORT" 8125 readMaybe-{-# NOINLINE defStatsdPort #-}--defWebPriceGet :: Int-defWebPriceGet =-  unsafePerformIO $-    defEnv "WEB_PRICE_GET" (90 * 1000 * 1000) readMaybe-{-# NOINLINE defWebPriceGet #-}--defWebTickerURL :: String-defWebTickerURL =-  unsafePerformIO $-    defEnv "PRICE_TICKER_URL" "https://api.blockchain.info/ticker" pure-{-# NOINLINE defWebTickerURL #-}--defWebHistoryURL :: String-defWebHistoryURL =-  unsafePerformIO $-    defEnv "PRICE_HISTORY_URL" "https://api.blockchain.info/price/index-series" pure-{-# NOINLINE defWebHistoryURL #-}--defStatsdPrefix :: String-defStatsdPrefix =-  unsafePerformIO $-    runMaybeT go >>= \case-      Nothing -> return "haskoin_store"-      Just x -> return x-  where-    go = prefix <|> nomad-    prefix = MaybeT $ lookupEnv "STATSD_PREFIX"-    nomad = do-      task <- MaybeT $ lookupEnv "NOMAD_TASK_NAME"-      service <- MaybeT $ lookupEnv "NOMAD_ALLOC_INDEX"-      return $ "app." <> task <> "." <> service-{-# NOINLINE defStatsdPrefix #-}--defHealthCheckInterval :: Int-defHealthCheckInterval =-  unsafePerformIO $-    defEnv "HEALTH_CHECK_INTERVAL" 30 readMaybe-{-# NOINLINE defHealthCheckInterval #-}--defCacheMempoolSync :: Int-defCacheMempoolSync =-  unsafePerformIO $-    defEnv "CACHE_MEMPOOL_SYNC" 30 readMaybe-{-# NOINLINE defCacheMempoolSync #-}--netNames :: String-netNames = intercalate "|" (map getNetworkName allNets)--parseBool :: String -> Maybe Bool-parseBool str = case map toLower str of-  "yes" -> Just True-  "true" -> Just True-  "on" -> Just True-  "1" -> Just True-  "no" -> Just False-  "false" -> Just False-  "off" -> Just False-  "0" -> Just False-  _ -> Nothing--config :: Parser Config-config = do-  configDir <--    strOption $-      metavar "PATH"-        <> long "dir"-        <> short 'd'-        <> help "Data directory"-        <> showDefault-        <> value (configDir def)-  configHost <--    strOption $-      metavar "HOST"-        <> long "host"-        <> help "Host to bind"-        <> showDefault-        <> value (configHost def)-  configPort <--    option auto $-      metavar "INT"-        <> long "port"-        <> help "REST API listening port"-        <> showDefault-        <> value (configPort def)-  configNetwork <--    strOption $-      metavar netNames-        <> long "net"-        <> short 'n'-        <> help "Network to connect to"-        <> showDefault-        <> value (configNetwork def)-  configDiscover <--    flag (configDiscover def) True $-      long "discover"-        <> help "Peer discovery"-  configPeers <--    fmap (mappend defPeers) $-      many $-        option auto $-          metavar "HOST"-            <> long "peer"-            <> short 'p'-            <> help "Network peer (as many as required)"-  configMaxPeers <--    option auto $-      metavar "INT"-        <> long "max-peers"-        <> help "Do not connect to more than this many peers"-        <> showDefault-        <> value (configMaxPeers def)-  configVersion <--    switch $-      long "version"-        <> short 'v'-        <> help "Show version"-  configDebug <--    flag (configDebug def) True $-      long "debug"-        <> help "Show debug messages"-  maxLimitCount <--    option auto $-      metavar "INT"-        <> long "max-limit"-        <> help "Hard limit for simple listings (0 = inf)"-        <> showDefault-        <> value (maxLimitCount (configWebLimits def))-  maxLimitFull <--    option auto $-      metavar "INT"-        <> long "max-full"-        <> help "Hard limit for full listings (0 = inf)"-        <> showDefault-        <> value (maxLimitFull (configWebLimits def))-  maxLimitOffset <--    option auto $-      metavar "INT"-        <> long "max-offset"-        <> help "Hard limit for offsets (0 = inf)"-        <> showDefault-        <> value (maxLimitOffset (configWebLimits def))-  maxLimitDefault <--    option auto $-      metavar "INT"-        <> long "def-limit"-        <> help "Soft default limit (0 = inf)"-        <> showDefault-        <> value (maxLimitDefault (configWebLimits def))-  maxLimitGap <--    option auto $-      metavar "INT"-        <> long "max-gap"-        <> help "Max gap for xpub queries"-        <> showDefault-        <> value (maxLimitGap (configWebLimits def))-  maxLimitInitialGap <--    option auto $-      metavar "INT"-        <> long "init-gap"-        <> help "Max gap for empty xpub"-        <> showDefault-        <> value (maxLimitInitialGap (configWebLimits def))-  maxLimitBody <--    option auto $-      metavar "BYTES"-        <> long "max-body"-        <> help "Maximum request body size"-        <> showDefault-        <> value (maxLimitBody (configWebLimits def))-  maxLimitTimeout <--    option auto $-      metavar "SECONDS"-        <> long "max-timeout"-        <> help "Web request timeout"-        <> showDefault-        <> value (maxLimitTimeout (configWebLimits def))-  blockTimeout <--    option auto $-      metavar "SECONDS"-        <> long "block-timeout"-        <> help "Last block mined health timeout"-        <> showDefault-        <> value (blockTimeout (configWebTimeouts def))-  txTimeout <--    option auto $-      metavar "SECONDS"-        <> long "tx-timeout"-        <> help "Last tx recived health timeout"-        <> showDefault-        <> value (txTimeout (configWebTimeouts def))-  configPeerTimeout <--    option auto $-      metavar "SECONDS"-        <> long "peer-timeout"-        <> help "Unresponsive peer timeout"-        <> showDefault-        <> value (configPeerTimeout def)-  configPeerMaxLife <--    option auto $-      metavar "SECONDS"-        <> long "peer-max-life"-        <> help "Disconnect peers older than this"-        <> showDefault-        <> value (configPeerMaxLife def)-  configMaxPending <--    option auto $-      metavar "INT"-        <> long "max-pending-txs"-        <> help "Maximum pending txs to fail health check"-        <> showDefault-        <> value (configMaxPending def)-  configRedis <--    flag (configRedis def) True $-      long "cache"-        <> help "Redis cache for extended public keys"-  configRedisURL <--    strOption $-      metavar "URL"-        <> long "redis"-        <> help "URL for Redis cache"-        <> value (configRedisURL def)-  configRedisMin <--    option auto $-      metavar "INT"-        <> long "cache-min"-        <> help "Minimum used xpub addresses to cache"-        <> showDefault-        <> value (configRedisMin def)-  configRedisMax <--    option auto $-      metavar "INT"-        <> long "cache-keys"-        <> help "Maximum number of keys in Redis xpub cache"-        <> showDefault-        <> value (configRedisMax def)-  configNoMempool <--    flag (configNoMempool def) True $-      long "no-mempool"-        <> help "Do not index new mempool transactions"-  configWipeMempool <--    flag (configWipeMempool def) True $-      long "wipe-mempool"-        <> help "Wipe mempool at start"-  configSyncMempool <--    flag (configSyncMempool def) True $-      long "sync-mempool"-        <> help "Sync mempool from peers"-  configMaxDiff <--    option auto $-      metavar "INT"-        <> long "max-diff"-        <> help "Maximum difference between headers and blocks"-        <> showDefault-        <> value (configMaxDiff def)-  configStatsd <--    flag (configStatsd def) True $-      long "statsd"-        <> help "Enable statsd metrics"-  configStatsdHost <--    strOption $-      metavar "HOST"-        <> long "statsd-host"-        <> help "Host to send statsd metrics"-        <> showDefault-        <> value (configStatsdHost def)-  configStatsdPort <--    option auto $-      metavar "PORT"-        <> long "statsd-port"-        <> help "Port to send statsd metrics"-        <> showDefault-        <> value (configStatsdPort def)-  configStatsdPrefix <--    strOption $-      metavar "PREFIX"-        <> long "statsd-prefix"-        <> help "Prefix for statsd metrics"-        <> showDefault-        <> value (configStatsdPrefix def)-  configWebPriceGet <--    option auto $-      metavar "MICROSECONDS"-        <> long "web-price-get"-        <> help "How often to retrieve price information"-        <> showDefault-        <> value (configWebPriceGet def)-  configWebNoBlockchain <--    flag (configWebNoBlockchain def) False $-      long "no-blockchain"-        <> help "Disable Blockchain.info compatibility layer"-  configWebTickerURL <--    strOption $-      metavar "URL"-        <> long "price-ticker-url"-        <> help "Blockchain.info price ticker URL"-        <> showDefault-        <> value (configWebTickerURL def)-  configWebHistoryURL <--    strOption $-      metavar "URL"-        <> long "price-history-url"-        <> help "Blockchain.info price history URL"-        <> showDefault-        <> value (configWebHistoryURL def)-  configWebNoSlow <--    flag (configWebNoSlow def) False $-      long "no-slow"-        <> help "Disable non-scalable API calls (recommend also --no-blockchain)"-  configHealthCheckInterval <--    option auto $-      metavar "SECONDS"-        <> long "health-check-interval"-        <> help "Background check update interval"-        <> showDefault-        <> value (configHealthCheckInterval def)-  configCacheMempoolSync <--    option auto $-      metavar "SECONDS"-        <> long "cache-mempool-sync"-        <> help "Sync mempool to cache interval"-        <> showDefault-        <> value (configCacheMempoolSync def)-  pure-    Config-      { configWebLimits = WebLimits {..},-        configWebTimeouts = WebTimeouts {..},-        ..-      }--networkReader :: String -> Either String Network-networkReader s-  | s == getNetworkName btc = Right btc-  | s == getNetworkName btcTest = Right btcTest-  | s == getNetworkName btcRegTest = Right btcRegTest-  | s == getNetworkName bch = Right bch-  | s == getNetworkName bchTest = Right bchTest-  | s == getNetworkName bchTest4 = Right bchTest4-  | s == getNetworkName bchRegTest = Right bchRegTest-  | otherwise = Left "Network name invalid"--peerReader :: String -> Either String String-peerReader "" = Left "Peer cannot be blank"-peerReader s = Right s--main :: IO ()-main = do-  conf <- execParser opts-  when (configVersion conf) $ do-    putStrLn version-    exitSuccess-  if null (configPeers conf) && not (configDiscover conf)-    then run conf {configDiscover = True}-    else run conf-  where-    opts =-      info (helper <*> config) $-        fullDesc-          <> progDesc "Bitcoin (BCH & BTC) block chain index with HTTP API"-          <> Options.Applicative.header-            ("haskoin-store version " <> version)--run :: Config -> IO ()-run-  Config-    { configHost = host,-      configPort = port,-      configNetwork = net_str,-      configDiscover = disc,-      configPeers = peers,-      configDir = db_dir,-      configDebug = deb,-      configMaxPending = pend,-      configWebLimits = limits,-      configWebTimeouts = tos,-      configRedis = redis,-      configRedisURL = redisurl,-      configRedisMin = cachemin,-      configRedisMax = redismax,-      configWipeMempool = wipemempool,-      configPeerTimeout = peertimeout,-      configPeerMaxLife = peerlife,-      configMaxPeers = maxpeers,-      configMaxDiff = maxdiff,-      configNoMempool = nomem,-      configSyncMempool = syncmem,-      configStatsd = statsd,-      configStatsdHost = statsdhost,-      configStatsdPort = statsdport,-      configStatsdPrefix = statsdpfx,-      configWebPriceGet = wpget,-      configWebTickerURL = wturl,-      configWebHistoryURL = whurl,-      configWebNoSlow = no_slow,-      configWebNoBlockchain = no_blockchain,-      configHealthCheckInterval = health_check_interval,-      configCacheMempoolSync = cachesync-    } =-    runStderrLoggingT . filterLogger l . with_stats $ \stats -> do-      net <- case networkReader net_str of-        Right n -> return n-        Left e -> error e-      $(logInfoS) "Main" $-        "Creating working directory if not found: " <> cs (wd net)-      createDirectoryIfMissing True (wd net)-      let scfg =-            StoreConfig-              { storeConfMaxPeers = maxpeers,-                storeConfInitPeers = peers,-                storeConfDiscover = disc,-                storeConfDB = wd net </> "db",-                storeConfNetwork = net,-                storeConfCache =-                  if redis-                    then Just redisurl-                    else Nothing,-                storeConfGap = maxLimitGap limits,-                storeConfInitialGap = maxLimitInitialGap limits,-                storeConfCacheMin = cachemin,-                storeConfMaxKeys = redismax,-                storeConfWipeMempool = wipemempool,-                storeConfNoMempool = nomem,-                storeConfSyncMempool = syncmem,-                storeConfPeerTimeout = fromIntegral peertimeout,-                storeConfPeerMaxLife = fromIntegral peerlife,-                storeConfConnect = withConnection,-                storeConfStats = stats,-                storeConfCacheMempoolSync = cachesync-              }-      withStore scfg $ \st ->-        runWeb-          WebConfig-            { webHost = host,-              webPort = port,-              webStore = st,-              webMaxLimits = limits,-              webTimeouts = tos,-              webMaxPending = pend,-              webVersion = version,-              webMaxDiff = maxdiff,-              webNoMempool = nomem,-              webStats = stats,-              webPriceGet = wpget,-              webTickerURL = wturl,-              webHistoryURL = whurl,-              webSlow = not no_slow,-              webBlockchain = not no_blockchain,-              webHealthCheckInterval = health_check_interval-            }-    where-      with_stats go-        | statsd = do-            $(logInfoS) "Main" $-              "Sending stats to "-                <> T.pack statsdhost-                <> ":"-                <> cs (show statsdport)-                <> " with prefix: "-                <> T.pack statsdpfx-            withStats-              (T.pack statsdhost)-              statsdport-              (T.pack statsdpfx)-              (go . Just)-        | otherwise = go Nothing-      l _ lvl-        | deb = True-        | otherwise = LevelInfo <= lvl-      wd net = db_dir </> getNetworkName net+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoFieldSelectors #-}++module Main where++import Control.Applicative ((<|>))+import Control.Arrow (second)+import Control.Monad (when)+import Control.Monad.Cont (ContT (ContT), lift, runContT)+import Control.Monad.Logger+  ( LogLevel (..),+    filterLogger,+    logInfoS,+    runStderrLoggingT,+  )+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Char (toLower)+import Data.Default (Default (..))+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.String.Conversions (cs)+import Data.Text qualified as T+import Data.Word (Word32)+import Haskoin+  ( Network (..),+    allNets,+    bch,+    bchRegTest,+    bchTest,+    bchTest4,+    btc,+    btcRegTest,+    btcTest,+    eitherToMaybe,+    netByName,+    withContext,+  )+import Haskoin.Node (withConnection)+import Haskoin.Store+  ( StoreConfig (..),+    WebConfig (..),+    WebLimits (..),+    WebTimeouts (..),+    runWeb,+    withStore,+  )+import Haskoin.Store.Stats (withStats)+import Options.Applicative+  ( Parser,+    auto,+    eitherReader,+    execParser,+    flag,+    fullDesc,+    header,+    help,+    helper,+    info,+    long,+    many,+    metavar,+    option,+    progDesc,+    short,+    showDefault,+    strOption,+    switch,+    value,+  )+import System.Exit (exitSuccess)+import System.FilePath ((</>))+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (readMaybe)+import UnliftIO (MonadIO)+import UnliftIO.Directory+  ( createDirectoryIfMissing,+    getAppUserDataDirectory,+  )+import UnliftIO.Environment (lookupEnv)++version :: String++#ifdef CURRENT_PACKAGE_VERSION+version = CURRENT_PACKAGE_VERSION+#else+version = "Unavailable"+#endif++data Config = Config+  { dir :: !FilePath,+    host :: !String,+    port :: !Int,+    net :: !String,+    discover :: !Bool,+    peers :: ![String],+    version :: !Bool,+    debug :: !Bool,+    maxPendingTxs :: !Int,+    maxLaggingBlocks :: !Int,+    minPeers :: !Int,+    webLimits :: !WebLimits,+    webTimeouts :: !WebTimeouts,+    redis :: !Bool,+    redisURL :: !String,+    redisMinAddrs :: !Int,+    redisMaxKeys :: !Integer,+    redisSyncInterval :: !Int,+    noMempool :: !Bool,+    wipeMempool :: !Bool,+    syncMempool :: !Bool,+    peerTimeout :: !Int,+    maxPeerLife :: !Int,+    maxPeers :: !Int,+    statsd :: !Bool,+    statsdHost :: !String,+    statsdPort :: !Int,+    statsdPrefix :: !String,+    tickerRefresh :: !Int,+    tickerURL :: !String,+    priceHistoryURL :: !String,+    noBlockchainInfo :: !Bool,+    noSlow :: !Bool,+    healthCheckInterval :: !Int+  }++env :: (MonadIO m) => String -> a -> (String -> Maybe a) -> m a+env e d p = do+  ms <- lookupEnv e+  return $ fromMaybe d $ p =<< ms++defConfig :: (MonadIO m) => m Config+defConfig = do+  dir <-+    getDir+  host <-+    env "HOST" "*" pure+  port <-+    env "PORT" 3000 readMaybe+  net <-+    env "NET" "bch" pure+  discover <-+    env "DISCOVER" False parseBool+  peers <-+    env "PEER" [] (pure . words)+  debug <-+    env "DEBUG" False parseBool+  maxPendingTxs <-+    env "MAX_PENDING_TXS" 10000 readMaybe+  maxLaggingBlocks <-+    env "MAX_LAGGING_BLOCKS" 3 readMaybe+  minPeers <-+    env "MIN_PEERS" 1 readMaybe+  webLimits <-+    getWebLimits+  webTimeouts <-+    getWebTimeouts+  redis <-+    env "REDIS" False parseBool+  redisURL <-+    env "REDIS_URL" "" pure+  redisMinAddrs <-+    env "REDIS_MIN_ADDRS" 100 readMaybe+  redisMaxKeys <-+    env "REDIS_MAX_KEYS" 100000000 readMaybe+  redisSyncInterval <-+    env "REDIS_SYNC_INTERVAL" 30 readMaybe+  noMempool <-+    env "NO_MEMPOOL" False parseBool+  wipeMempool <-+    env "WIPE_MEMPOOL" False parseBool+  syncMempool <-+    env "SYNC_MEMPOOL" False parseBool+  peerTimeout <-+    env "PEER_TIMEOUT" 120 readMaybe+  maxPeerLife <-+    env "MAX_PEER_LIFE" (48 * 3600) readMaybe+  maxPeers <-+    env "MAX_PEERS" 20 readMaybe+  statsd <-+    env "STATSD" False parseBool+  statsdHost <-+    env "STATSD_HOST" "localhost" pure+  statsdPort <-+    env "STATSD_PORT" 8125 readMaybe+  statsdPrefix <-+    getStatsdPrefix+  tickerRefresh <-+    env "TICKER_REFRESH" (90 * 1000 * 1000) readMaybe+  tickerURL <-+    env "TICKER_URL" tickerString pure+  priceHistoryURL <-+    env "PRICE_HISTORY_URL" priceHistoryString pure+  noBlockchainInfo <-+    env "NO_BLOCKCHAIN_INFO" False parseBool+  noSlow <-+    env "NO_SLOW" False parseBool+  healthCheckInterval <-+    env "HEALTH_CHECK_INTERVAL" 30 readMaybe+  return Config {version = False, ..}+  where+    tickerString =+      "https://api.blockchain.info/ticker"+    priceHistoryString =+      "https://api.blockchain.info/price/index-series"+    getDir =+      getAppUserDataDirectory "haskoin-store" >>= \d ->+        env "DIR" d pure+    getWebLimits = do+      let WebLimits {..} = def+      maxItemCount <-+        env "MAX_ITEM_COUNT" maxItemCount readMaybe+      maxFullItemCount <-+        env "MAX_FULL_ITEM_COUNT" maxFullItemCount readMaybe+      maxOffset <-+        env "MAX_OFFSET" maxOffset readMaybe+      defItemCount <-+        env "DEF_ITEM_COUNT" defItemCount readMaybe+      xpubGap <-+        env "XPUB_GAP" xpubGap readMaybe+      xpubGapInit <-+        env "XPUB_GAP_INIT" xpubGapInit readMaybe+      maxBodySize <-+        env "MAX_BODY_SIZE" maxBodySize readMaybe+      requestTimeout <-+        env "REQUEST_TIMEOUT" requestTimeout readMaybe+      return WebLimits {..}+    getWebTimeouts = do+      let WebTimeouts {..} = def+      block <-+        env "BLOCK_TIMEOUT" block readMaybe+      tx <-+        env "TX_TIMEOUT" tx readMaybe+      return WebTimeouts {..}+    getStatsdPrefix = do+      let go = prefix <|> nomad+          prefix =+            MaybeT $ lookupEnv "STATSD_PREFIX"+          nomad = do+            task <-+              MaybeT $ lookupEnv "NOMAD_TASK_NAME"+            service <-+              MaybeT $ lookupEnv "NOMAD_ALLOC_INDEX"+            return $ "app." <> task <> "." <> service+      fromMaybe "haskoin_store" <$> runMaybeT go++netNames :: String+netNames = intercalate "|" $ map (.name) allNets++parseBool :: String -> Maybe Bool+parseBool str = case map toLower str of+  "yes" -> Just True+  "true" -> Just True+  "on" -> Just True+  "1" -> Just True+  "no" -> Just False+  "false" -> Just False+  "off" -> Just False+  "0" -> Just False+  _ -> Nothing++config :: Config -> Parser Config+config c = do+  dir <-+    strOption $+      metavar "DIRECTORY"+        <> long "dir"+        <> short 'd'+        <> help "Data directory"+        <> showDefault+        <> value c.dir+  host <-+    strOption $+      metavar "ADDRESS"+        <> long "host"+        <> help "Network address to bind"+        <> showDefault+        <> value c.host+  port <-+    option auto $+      metavar "PORT"+        <> long "port"+        <> help "REST API listening port"+        <> showDefault+        <> value c.port+  net <-+    strOption $+      metavar netNames+        <> long "net"+        <> short 'n'+        <> help "Network to connect to"+        <> showDefault+        <> value c.net+  discover <-+    flag c.discover True $+      long "discover"+        <> help "Peer discovery"+  peers <-+    fmap (mappend c.peers) $+      many $+        option auto $+          metavar "HOSTNAME[:PORT]"+            <> long "peer"+            <> short 'p'+            <> help "Network peer (as many as required)"+  version <-+    switch $+      long "version"+        <> short 'v'+        <> help "Show version"+  debug <-+    flag c.debug True $+      long "debug"+        <> help "Show debug messages"+  maxPendingTxs <-+    option auto $+      metavar "COUNT"+        <> long "max-pending-txs"+        <> help "Maximum pending txs to fail health check"+        <> showDefault+        <> value c.maxPendingTxs+  maxLaggingBlocks <-+    option auto $+      metavar "COUNT"+        <> long "max-lagging-blocks"+        <> help "Maximum number of unindexed blocks"+        <> showDefault+        <> value c.maxLaggingBlocks+  minPeers <-+    option auto $+      metavar "COUNT"+        <> long "min-peers"+        <> help "Minimum number of connected peers for health check"+        <> showDefault+        <> value c.minPeers+  webLimits <- do+    maxItemCount <-+      option auto $+        metavar "COUNT"+          <> long "max-item-count"+          <> help "Hard limit for simple listings (0 = inf)"+          <> showDefault+          <> value c.webLimits.maxItemCount+    maxFullItemCount <-+      option auto $+        metavar "COUNT"+          <> long "max-full-item-count"+          <> help "Hard limit for full listings (0 = inf)"+          <> showDefault+          <> value c.webLimits.maxFullItemCount+    maxOffset <-+      option auto $+        metavar "OFFSET"+          <> long "max-offset"+          <> help "Hard limit for offsets (0 = inf)"+          <> showDefault+          <> value c.webLimits.maxOffset+    defItemCount <-+      option auto $+        metavar "COUNT"+          <> long "def-item-count"+          <> help "Soft default limit (0 = inf)"+          <> showDefault+          <> value c.webLimits.defItemCount+    xpubGap <-+      option auto $+        metavar "GAP"+          <> long "xpub-gap"+          <> help "Max gap for xpub queries"+          <> showDefault+          <> value c.webLimits.xpubGap+    xpubGapInit <-+      option auto $+        metavar "GAP"+          <> long "xpub-gap-init"+          <> help "Max gap for empty xpubs"+          <> showDefault+          <> value c.webLimits.xpubGapInit+    maxBodySize <-+      option auto $+        metavar "BYTES"+          <> long "max-body-size"+          <> help "Maximum request body size"+          <> showDefault+          <> value c.webLimits.maxBodySize+    requestTimeout <-+      option auto $+        metavar "SECONDS"+          <> long "request-timeout"+          <> help "Web request timeout"+          <> showDefault+          <> value c.webLimits.requestTimeout+    return WebLimits {..}+  webTimeouts <- do+    block <-+      option auto $+        metavar "SECONDS"+          <> long "block-timeout"+          <> help "Block lag health timeout"+          <> showDefault+          <> value c.webTimeouts.block+    tx <-+      option auto $+        metavar "SECONDS"+          <> long "tx-timeout"+          <> help "Last tx received health timeout"+          <> showDefault+          <> value c.webTimeouts.tx+    return WebTimeouts {..}+  redis <-+    flag c.redis True $+      long "redis"+        <> help "Redis cache for xpub data"+  redisURL <-+    strOption $+      metavar "URL"+        <> long "redis-url"+        <> help "URL for Redis cache"+        <> value c.redisURL+  redisMinAddrs <-+    option auto $+      metavar "GAP"+        <> long "redis-min-gap"+        <> help "Minimum xpub address count to cache in Redis"+        <> showDefault+        <> value c.redisMinAddrs+  redisMaxKeys <-+    option auto $+      metavar "COUNT"+        <> long "redis-max-keys"+        <> help "Maximum number of keys in Redis"+        <> showDefault+        <> value c.redisMaxKeys+  redisSyncInterval <-+    option auto $+      metavar "SECONDS"+        <> long "redis-sync-interval"+        <> help "Sync mempool to Redis interval"+        <> showDefault+        <> value c.redisSyncInterval+  noMempool <-+    flag c.noMempool True $+      long "no-mempool"+        <> help "Do not index mempool transactions"+  wipeMempool <-+    flag c.wipeMempool True $+      long "wipe-mempool"+        <> help "Wipe indexed mempool at start"+  syncMempool <-+    flag c.syncMempool True $+      long "sync-mempool"+        <> help "Attempt to download peer mempools"+  peerTimeout <-+    option auto $+      metavar "SECONDS"+        <> long "peer-timeout"+        <> help "Unresponsive peer timeout"+        <> showDefault+        <> value c.peerTimeout+  maxPeerLife <-+    option auto $+      metavar "SECONDS"+        <> long "max-peer-life"+        <> help "Maximum peer connection time"+        <> showDefault+        <> value c.maxPeerLife+  maxPeers <-+    option auto $+      metavar "COUNT"+        <> long "max-peers"+        <> help "Do not connect to more than this many peers"+        <> showDefault+        <> value c.maxPeers+  statsd <-+    flag c.statsd True $+      long "statsd"+        <> help "Enable statsd metrics"+  statsdHost <-+    strOption $+      metavar "HOSTNAME"+        <> long "statsd-host"+        <> help "Host to send statsd metrics"+        <> showDefault+        <> value c.statsdHost+  statsdPort <-+    option auto $+      metavar "PORT"+        <> long "statsd-port"+        <> help "Port to send statsd metrics"+        <> showDefault+        <> value c.statsdPort+  statsdPrefix <-+    strOption $+      metavar "PREFIX"+        <> long "statsd-prefix"+        <> help "Prefix for statsd metrics"+        <> showDefault+        <> value c.statsdPrefix+  tickerRefresh <-+    option auto $+      metavar "MICROSECONDS"+        <> long "ticker-refresh"+        <> help "How often to retrieve price information"+        <> showDefault+        <> value c.tickerRefresh+  tickerURL <-+    strOption $+      metavar "URL"+        <> long "ticker-url"+        <> help "Blockchain.info price ticker URL"+        <> showDefault+        <> value c.tickerURL+  priceHistoryURL <-+    strOption $+      metavar "URL"+        <> long "price-history-url"+        <> help "Blockchain.info price history URL"+        <> showDefault+        <> value c.priceHistoryURL+  noBlockchainInfo <-+    flag c.noBlockchainInfo False $+      long "no-blockchain-info"+        <> help "Disable Blockchain.info-style API endpoints"+  noSlow <-+    flag c.noSlow False $+      long "no-slow"+        <> help "Disable potentially slow API endpoints"+  healthCheckInterval <-+    option auto $+      metavar "SECONDS"+        <> long "health-check-interval"+        <> help "Background check update interval"+        <> showDefault+        <> value c.healthCheckInterval+  pure Config {..}++networkReader :: String -> Either String Network+networkReader s =+  case netByName s of+    Just net -> Right net+    Nothing -> Left "Network name invalid"++peerReader :: String -> Either String String+peerReader "" = Left "Peer cannot be blank"+peerReader s = Right s++main :: IO ()+main = do+  c <- execParser . opts =<< defConfig+  when c.version $ do+    putStrLn version+    exitSuccess+  if null c.peers && not c.discover+    then run $ let Config {..} = c in Config {discover = True, ..}+    else run c+  where+    opts c =+      info (helper <*> config c) $+        fullDesc+          <> progDesc "Bitcoin (BCH & BTC) block chain index with HTTP API"+          <> Options.Applicative.header+            ("haskoin-store version " <> version)++run :: Config -> IO ()+run cfg =+  withContext $ \ctx ->+    runStderrLoggingT $ filterLogger l $ flip runContT return $ do+      stats <- ContT $ with_stats+      net <- either error return $ networkReader cfg.net+      let dir = cfg.dir </> net.name+      $(logInfoS) "haskoin-store" $+        "Creating working directory (if not found): " <> cs dir+      createDirectoryIfMissing True dir+      store <-+        ContT $+          withStore+            StoreConfig+              { maxPeers = cfg.maxPeers,+                initPeers = cfg.peers,+                discover = cfg.discover,+                db = dir </> "db",+                net = net,+                ctx = ctx,+                redis = if cfg.redis then Just cfg.redisURL else Nothing,+                gap = cfg.webLimits.xpubGap,+                initGap = cfg.webLimits.xpubGapInit,+                redisMinAddrs = cfg.redisMinAddrs,+                redisMaxKeys = cfg.redisMaxKeys,+                wipeMempool = cfg.wipeMempool,+                noMempool = cfg.noMempool,+                syncMempool = cfg.syncMempool,+                peerTimeout = fromIntegral cfg.peerTimeout,+                maxPeerLife = fromIntegral cfg.maxPeerLife,+                connect = withConnection,+                statsStore = stats,+                redisSyncInterval = cfg.redisSyncInterval+              }+      lift $+        runWeb+          WebConfig+            { host = cfg.host,+              port = cfg.port,+              store = store,+              limits = cfg.webLimits,+              timeouts = cfg.webTimeouts,+              maxPendingTxs = cfg.maxPendingTxs,+              maxLaggingBlocks = cfg.maxLaggingBlocks,+              minPeers = cfg.minPeers,+              version = version,+              noMempool = cfg.noMempool,+              statsStore = stats,+              tickerRefresh = cfg.tickerRefresh,+              tickerURL = cfg.tickerURL,+              priceHistoryURL = cfg.priceHistoryURL,+              noSlow = cfg.noSlow,+              noBlockchainInfo = cfg.noBlockchainInfo,+              healthCheckInterval = cfg.healthCheckInterval+            }+  where+    with_stats go+      | cfg.statsd = do+          $(logInfoS) "Main" $+            "Sending stats to "+              <> T.pack cfg.statsdHost+              <> ":"+              <> cs (show cfg.statsdPort)+              <> " with prefix: "+              <> T.pack cfg.statsdPrefix+          withStats+            (T.pack cfg.statsdHost)+            cfg.statsdPort+            (T.pack cfg.statsdPrefix)+            (go . Just)+      | otherwise = go Nothing+    l _ lvl+      | cfg.debug = True+      | otherwise = LevelInfo <= lvl

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           haskoin-store-version:        0.65.12+version:        1.0.0 synopsis:       Storage and index for Bitcoin and Bitcoin Cash description:    Please see the README on GitHub at <https://github.com/haskoin/haskoin-store#readme> category:       Bitcoin, Finance, Network@@ -17,6 +17,9 @@ license:        MIT license-file:   LICENSE build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md  source-repository head   type: git@@ -43,7 +46,7 @@       aeson >=1.4.7.1     , aeson-pretty >=0.8.8     , base >=4.9 && <5-    , base16 >=0.3.0+    , base16 >=1.0     , bytes >=0.17     , bytestring >=0.10.10.0     , cereal >=0.5.8.1@@ -56,9 +59,9 @@     , foldl >=1.4.10     , hashable >=1.3.0.0     , hashtables >=1.2.4.2-    , haskoin-core >=0.21.1-    , haskoin-node >=0.18.0-    , haskoin-store-data ==0.65.12+    , haskoin-core >=1.0.0+    , haskoin-node >=1.0.0+    , haskoin-store-data ==1.0.0     , hedis >=0.12.13     , http-types >=0.12.3     , lens >=4.18.1@@ -98,7 +101,7 @@       aeson >=1.4.7.1     , aeson-pretty >=0.8.8     , base >=4.9 && <5-    , base16 >=0.3.0+    , base16 >=1.0     , bytes >=0.17     , bytestring >=0.10.10.0     , cereal >=0.5.8.1@@ -112,10 +115,10 @@     , foldl >=1.4.10     , hashable >=1.3.0.0     , hashtables >=1.2.4.2-    , haskoin-core >=0.21.1-    , haskoin-node >=0.18.0+    , haskoin-core >=1.0.0+    , haskoin-node >=1.0.0     , haskoin-store-    , haskoin-store-data ==0.65.12+    , haskoin-store-data ==1.0.0     , hedis >=0.12.13     , http-types >=0.12.3     , lens >=4.18.1@@ -145,7 +148,7 @@     , wreq >=0.5.3.2   default-language: Haskell2010 -test-suite haskoin-store-test+test-suite spec   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:@@ -160,7 +163,7 @@     , aeson >=1.4.7.1     , aeson-pretty >=0.8.8     , base >=4.9 && <5-    , base16 >=0.3.0+    , base16 >=1.0     , base64 >=0.4.1     , bytes >=0.17     , bytestring >=0.10.10.0@@ -174,10 +177,10 @@     , foldl >=1.4.10     , hashable >=1.3.0.0     , hashtables >=1.2.4.2-    , haskoin-core >=0.21.1-    , haskoin-node >=0.18.0+    , haskoin-core >=1.0.0+    , haskoin-node >=1.0.0     , haskoin-store-    , haskoin-store-data ==0.65.12+    , haskoin-store-data ==1.0.0     , hedis >=0.12.13     , hspec >=2.7.1     , http-types >=0.12.3

@@ -1,12 +1,17 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}  module Haskoin.Store.BlockStore   ( -- * Block Store@@ -61,7 +66,8 @@     asks,   ) import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (runMaybeT)+import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+import Data.Bool (bool) import Data.ByteString qualified as B import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap@@ -71,6 +77,7 @@ import Data.Maybe   ( catMaybes,     fromJust,+    fromMaybe,     isJust,     mapMaybe,   )@@ -78,6 +85,7 @@ import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text)+import Data.Text qualified as T import Data.Time.Clock   ( NominalDiffTime,     UTCTime,@@ -98,6 +106,7 @@     BlockHeader (..),     BlockHeight,     BlockNode (..),+    Ctx,     GetData (..),     InvType (..),     InvVector (..),@@ -115,9 +124,9 @@ import Haskoin.Node   ( Chain,     OnlinePeer (..),-    Peer,+    Peer (..),     PeerException (..),-    PeerManager,+    PeerMgr,     chainBlockMain,     chainGetAncestor,     chainGetBest,@@ -125,7 +134,6 @@     chainGetParents,     getPeers,     killPeer,-    peerText,     sendMessage,     setBusy,     setFree,@@ -198,50 +206,50 @@   deriving (Show, Eq, Ord, Exception)  data Syncing = Syncing-  { syncingPeer :: !Peer,-    syncingTime :: !UTCTime,-    syncingBlocks :: ![BlockHash]+  { peer :: !Peer,+    time :: !UTCTime,+    blocks :: ![BlockHash]   }  data PendingTx = PendingTx-  { pendingTxTime :: !UTCTime,-    pendingTx :: !Tx,-    pendingDeps :: !(HashSet TxHash)+  { time :: !UTCTime,+    tx :: !Tx,+    deps :: !(HashSet TxHash)   }   deriving (Show, Eq, Ord)  -- | Block store process state. data BlockStore = BlockStore-  { myMailbox :: !(Mailbox BlockStoreMessage),-    myConfig :: !BlockStoreConfig,-    myPeer :: !(TVar (Maybe Syncing)),-    myTxs :: !(TVar (HashMap TxHash PendingTx)),+  { mailbox :: !(Mailbox BlockStoreMessage),+    config :: !BlockStoreConfig,+    peer :: !(TVar (Maybe Syncing)),+    txs :: !(TVar (HashMap TxHash PendingTx)),     requested :: !(TVar (HashSet TxHash)),-    myMetrics :: !(Maybe StoreMetrics)+    metrics :: !(Maybe StoreMetrics)   }  data StoreMetrics = StoreMetrics   { storeHeight :: !Metrics.Gauge,     headersHeight :: !Metrics.Gauge,-    storePendingTxs :: !Metrics.Gauge,-    storePeersConnected :: !Metrics.Gauge,-    storeMempoolSize :: !Metrics.Gauge+    pendingTxs :: !Metrics.Gauge,+    connectedPeers :: !Metrics.Gauge,+    mempoolSize :: !Metrics.Gauge   } -newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics+newStoreMetrics :: (MonadIO m) => Metrics.Store -> m StoreMetrics newStoreMetrics s = liftIO $ do   storeHeight <- g "blockchain.height"   headersHeight <- g "blockchain.headers"-  storePendingTxs <- g "mempool.pending_txs"-  storePeersConnected <- g "network.peers_connected"-  storeMempoolSize <- g "mempool.size"+  pendingTxs <- g "mempool.pending_txs"+  connectedPeers <- g "network.peers_connected"+  mempoolSize <- g "mempool.size"   return StoreMetrics {..}   where     g x = Metrics.createGauge ("store." <> x) s -setStoreHeight :: MonadIO m => BlockT m ()+setStoreHeight :: (MonadIO m) => BlockT m () setStoreHeight =-  asks myMetrics >>= \case+  asks (.metrics) >>= \case     Nothing -> return ()     Just m ->       getBestBlock >>= \case@@ -249,79 +257,84 @@         Just bb ->           getBlock bb >>= \case             Nothing -> setit m 0-            Just b -> setit m (blockDataHeight b)+            Just b -> setit m b.height   where-    setit m i = liftIO $ storeHeight m `Metrics.Gauge.set` fromIntegral i+    setit m i = liftIO $ m.storeHeight `Metrics.Gauge.set` fromIntegral i -setHeadersHeight :: MonadIO m => BlockT m ()+setHeadersHeight :: (MonadIO m) => BlockT m () setHeadersHeight =-  asks myMetrics >>= \case+  asks (.metrics) >>= \case     Nothing -> return ()     Just m -> do-      h <- fmap nodeHeight $ chainGetBest =<< asks (blockConfChain . myConfig)-      liftIO $ headersHeight m `Metrics.Gauge.set` fromIntegral h+      h <- fmap (.height) $ chainGetBest =<< asks (.config.chain)+      liftIO $ m.headersHeight `Metrics.Gauge.set` fromIntegral h -setPendingTxs :: MonadIO m => BlockT m ()+setPendingTxs :: (MonadIO m) => BlockT m () setPendingTxs =-  asks myMetrics >>= \case+  asks (.metrics) >>= \case     Nothing -> return ()     Just m -> do-      s <- asks myTxs >>= \t -> atomically (HashMap.size <$> readTVar t)-      liftIO $ storePendingTxs m `Metrics.Gauge.set` fromIntegral s+      s <- asks (.txs) >>= \t -> atomically (HashMap.size <$> readTVar t)+      liftIO $ m.pendingTxs `Metrics.Gauge.set` fromIntegral s -setPeersConnected :: MonadIO m => BlockT m ()+setPeersConnected :: (MonadIO m) => BlockT m () setPeersConnected =-  asks myMetrics >>= \case+  asks (.metrics) >>= \case     Nothing -> return ()     Just m -> do-      ps <- fmap length $ getPeers =<< asks (blockConfManager . myConfig)-      liftIO $ storePeersConnected m `Metrics.Gauge.set` fromIntegral ps+      ps <- fmap length $ getPeers =<< asks (.config.peerMgr)+      liftIO $ m.connectedPeers `Metrics.Gauge.set` fromIntegral ps -setMempoolSize :: MonadIO m => BlockT m ()+setMempoolSize :: (MonadIO m) => BlockT m () setMempoolSize =-  asks myMetrics >>= \case+  asks (.metrics) >>= \case     Nothing -> return ()     Just m -> do       s <- length <$> getMempool-      liftIO $ storeMempoolSize m `Metrics.Gauge.set` fromIntegral s+      liftIO $ m.mempoolSize `Metrics.Gauge.set` fromIntegral s  -- | Configuration for a block store. data BlockStoreConfig = BlockStoreConfig-  { -- | peer manager from running node-    blockConfManager :: !PeerManager,+  { ctx :: !Ctx,+    -- | peer manager from running node+    peerMgr :: !PeerMgr,     -- | chain from a running node-    blockConfChain :: !Chain,+    chain :: !Chain,     -- | listener for store events-    blockConfListener :: !(Publisher StoreEvent),+    pub :: !(Publisher StoreEvent),     -- | RocksDB database handle-    blockConfDB :: !DatabaseReader,+    db :: !DatabaseReader,     -- | network constants-    blockConfNet :: !Network,+    net :: !Network,     -- | do not index new mempool transactions-    blockConfNoMempool :: !Bool,+    noMempool :: !Bool,     -- | wipe mempool at start-    blockConfWipeMempool :: !Bool,+    wipeMempool :: !Bool,     -- | sync mempool from peers-    blockConfSyncMempool :: !Bool,+    syncMempool :: !Bool,     -- | disconnect syncing peer if inactive for this long-    blockConfPeerTimeout :: !NominalDiffTime,-    blockConfStats :: !(Maybe Metrics.Store)+    peerTimeout :: !NominalDiffTime,+    statsStore :: !(Maybe Metrics.Store)   }  type BlockT m = ReaderT BlockStore m  runImport ::-  MonadLoggerIO m =>+  (MonadLoggerIO m) =>+  Network ->+  Ctx ->   WriterT (ExceptT ImportException m) a ->   BlockT m (Either ImportException a)-runImport f =-  ReaderT $ \r -> runExceptT $ runWriter (blockConfDB (myConfig r)) f+runImport net ctx f =+  ReaderT $ \r -> runExceptT $ runWriter net ctx r.config.db f  runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a runRocksDB f =-  ReaderT $ runReaderT f . blockConfDB . myConfig+  ReaderT $ runReaderT f . (.config.db) -instance MonadIO m => StoreReadBase (BlockT m) where+instance (MonadIO m) => StoreReadBase (BlockT m) where+  getCtx =+    asks (.config.ctx)   getNetwork =     runRocksDB getNetwork   getBestBlock =@@ -341,7 +354,7 @@   getMempool =     runRocksDB getMempool -instance MonadUnliftIO m => StoreReadExtra (BlockT m) where+instance (MonadUnliftIO m) => StoreReadExtra (BlockT m) where   getMaxGap =     runRocksDB getMaxGap   getInitialGap =@@ -378,15 +391,15 @@   ts <- newTVarIO HashMap.empty   rq <- newTVarIO HashSet.empty   inbox <- newInbox-  metrics <- mapM newStoreMetrics (blockConfStats cfg)+  metrics <- mapM newStoreMetrics cfg.statsStore   let r =         BlockStore-          { myMailbox = inboxToMailbox inbox,-            myConfig = cfg,-            myPeer = pb,-            myTxs = ts,+          { mailbox = inboxToMailbox inbox,+            config = cfg,+            peer = pb,+            txs = ts,             requested = rq,-            myMetrics = metrics+            metrics = metrics           }   withAsync (runReaderT (go inbox) r) $ \a -> do     link a@@ -401,53 +414,60 @@         "Deleting " <> cs (show (length txs)) <> " transactions"       forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th     wipe_it txs = do+      net <- getNetwork+      ctx <- getCtx       let (txs1, txs2) = splitAt 1000 txs       unless (null txs1) $-        runImport (del txs1) >>= \case+        runImport net ctx (del txs1) >>= \case           Left e -> do             $(logErrorS) "BlockStore" $               "Could not wipe mempool: " <> cs (show e)             throwIO e           Right () -> wipe_it txs2     wipe-      | blockConfWipeMempool cfg =+      | cfg.wipeMempool =           getMempool >>= wipe_it       | otherwise =           return ()-    ini =-      runImport initBest >>= \case+    ini = do+      net <- getNetwork+      ctx <- getCtx+      runImport net ctx initBest >>= \case         Left e -> do           $(logErrorS) "BlockStore" $             "Could not initialize: " <> cs (show e)           throwIO e         Right () -> return ()     run inbox =-      withAsync (pingMe (inboxToMailbox inbox)) $-        const $-          forever $-            receive inbox-              >>= ReaderT . runReaderT . processBlockStoreMessage+      withAsync (pingMe (inboxToMailbox inbox)) $ \a ->+        link a >> runBlockStoreLoop inbox -isInSync :: MonadLoggerIO m => BlockT m Bool+runBlockStoreLoop inbox =+  forever $ do+    $(logDebugS) "BlockStore" "Waiting for new event..."+    msg <- receive inbox+    ReaderT $ runReaderT $ processBlockStoreMessage msg++isInSync :: (MonadLoggerIO m) => BlockT m Bool isInSync =   getBestBlock >>= \case     Nothing -> do       $(logErrorS) "BlockStore" "Block database uninitialized"       throwIO Uninitialized     Just bb -> do-      cb <- asks (blockConfChain . myConfig) >>= chainGetBest-      if headerHash (nodeHeader cb) == bb+      cb <- asks (.config.chain) >>= chainGetBest+      if headerHash cb.header == bb         then clearSyncingState >> return True         else return False -guardMempool :: Monad m => BlockT m () -> BlockT m ()+guardMempool :: (Monad m) => BlockT m () -> BlockT m () guardMempool f = do-  n <- asks (blockConfNoMempool . myConfig)+  n <- asks (.config.noMempool)   unless n f -syncMempool :: Monad m => BlockT m () -> BlockT m ()+syncMempool :: (Monad m) => BlockT m () -> BlockT m () syncMempool f = do-  s <- asks (blockConfSyncMempool . myConfig)+  s <- asks (.config.syncMempool)   when s f  mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()@@ -455,7 +475,7 @@   guardMempool . syncMempool $     isInSync >>= \s -> when s $ do       $(logDebugS) "BlockStore" $-        "Requesting mempool from peer: " <> peerText p+        "Requesting mempool from peer: " <> p.label       MMempool `sendMessage` p  processBlock ::@@ -469,7 +489,7 @@     False -> do       $(logErrorS) "BlockStore" $         "Non-syncing peer "-          <> peerText peer+          <> peer.label           <> " sent me a block: "           <> blockHashToHex blockhash       PeerMisbehaving "Sent unexpected block" `killPeer` peer@@ -480,7 +500,7 @@       Nothing -> do         $(logErrorS) "BlockStore" $           "Peer "-            <> peerText peer+            <> peer.label             <> " sent unknown block: "             <> blockHashToHex blockhash         PeerMisbehaving "Sent unknown block" `killPeer` peer@@ -489,19 +509,21 @@     "Processing block: "       <> blockText node Nothing       <> " from peer: "-      <> peerText peer+      <> peer.label+  net <- lift getNetwork+  ctx <- lift getCtx   lift . notify (Just block) $-    runImport (importBlock block node) >>= \case+    runImport net ctx (importBlock block node) >>= \case       Left e -> failure e       Right _ -> success node   where-    header = blockHeader block+    header = block.header     blockhash = headerHash header     hexhash = blockHashToHex blockhash     success node = do       $(logInfoS) "BlockStore" $         "Best block: " <> blockText node (Just block)-      removeSyncingBlock $ headerHash $ nodeHeader node+      removeSyncingBlock $ headerHash node.header       touchPeer       isInSync >>= \case         False -> syncMe@@ -513,7 +535,7 @@         "Error importing block "           <> hexhash           <> " from peer: "-          <> peerText peer+          <> peer.label           <> ": "           <> cs (show e)       killPeer (PeerMisbehaving (show e)) peer@@ -523,55 +545,54 @@   [BlockHash] ->   m () setSyncingBlocks hs =-  asks myPeer >>= \box ->+  asks (.peer) >>= \box ->     atomically $       modifyTVar box $ \case         Nothing -> Nothing-        Just x -> Just x {syncingBlocks = hs}+        Just x -> Just (x :: Syncing) {blocks = hs}  getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash] getSyncingBlocks =-  asks myPeer >>= readTVarIO >>= \case+  asks (.peer) >>= readTVarIO >>= \case     Nothing -> return []-    Just x -> return $ syncingBlocks x+    Just x -> return x.blocks  addSyncingBlocks ::   (MonadReader BlockStore m, MonadIO m) =>   [BlockHash] ->   m () addSyncingBlocks hs =-  asks myPeer >>= \box ->+  asks (.peer) >>= \box ->     atomically $       modifyTVar box $ \case         Nothing -> Nothing-        Just x -> Just x {syncingBlocks = syncingBlocks x <> hs}+        Just x -> Just (x :: Syncing) {blocks = x.blocks <> hs}  removeSyncingBlock ::   (MonadReader BlockStore m, MonadIO m) =>   BlockHash ->   m () removeSyncingBlock h = do-  box <- asks myPeer+  box <- asks (.peer)   atomically $     modifyTVar box $ \case       Nothing -> Nothing-      Just x -> Just x {syncingBlocks = delete h (syncingBlocks x)}+      Just x -> Just (x :: Syncing) {blocks = delete h x.blocks}  checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool-checkPeer p =-  fmap syncingPeer <$> getSyncingState >>= \case-    Nothing -> return False-    Just p' -> return $ p == p'+checkPeer p = fmap (fromMaybe False) <$> runMaybeT $ do+  Syncing {peer} <- MaybeT getSyncingState+  return $ peer == p  getBlockNode ::   (MonadLoggerIO m, MonadReader BlockStore m) =>   BlockHash ->   m (Maybe BlockNode) getBlockNode blockhash =-  chainGetBlock blockhash =<< asks (blockConfChain . myConfig)+  chainGetBlock blockhash =<< asks (.config.chain)  processNoBlocks ::-  MonadLoggerIO m =>+  (MonadLoggerIO m) =>   Peer ->   [BlockHash] ->   BlockT m ()@@ -585,50 +606,50 @@         <> " "         <> blockHashToHex h         <> " not found by peer: "-        <> peerText p+        <> p.label   killPeer (PeerMisbehaving "Did not find requested block(s)") p -processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m ()+processTx :: (MonadLoggerIO m) => Peer -> Tx -> BlockT m () processTx p tx = guardMempool $ do   t <- liftIO getCurrentTime   $(logDebugS) "BlockManager" $     "Received tx "       <> txHashToHex (txHash tx)       <> " by peer: "-      <> peerText p+      <> p.label   addPendingTx $ PendingTx t tx HashSet.empty -pruneOrphans :: MonadIO m => BlockT m ()+pruneOrphans :: (MonadIO m) => BlockT m () pruneOrphans = guardMempool $ do-  ts <- asks myTxs+  ts <- asks (.txs)   now <- liftIO getCurrentTime   atomically . modifyTVar ts . HashMap.filter $ \p ->-    now `diffUTCTime` pendingTxTime p > 600+    now `diffUTCTime` p.time > 600 -addPendingTx :: MonadIO m => PendingTx -> BlockT m ()+addPendingTx :: (MonadIO m) => PendingTx -> BlockT m () addPendingTx p = do-  ts <- asks myTxs-  rq <- asks requested+  ts <- asks (.txs)+  rq <- asks (.requested)   atomically $ do     modifyTVar ts $ HashMap.insert th p     modifyTVar rq $ HashSet.delete th     HashMap.size <$> readTVar ts   setPendingTxs   where-    th = txHash (pendingTx p)+    th = txHash p.tx -addRequestedTx :: MonadIO m => TxHash -> BlockT m ()+addRequestedTx :: (MonadIO m) => TxHash -> BlockT m () addRequestedTx th = do-  qbox <- asks requested+  qbox <- asks (.requested)   atomically $ modifyTVar qbox $ HashSet.insert th   liftIO . void . async $ do     threadDelay 20000000     atomically $ modifyTVar qbox $ HashSet.delete th -isPending :: MonadIO m => TxHash -> BlockT m Bool+isPending :: (MonadIO m) => TxHash -> BlockT m Bool isPending th = do-  tbox <- asks myTxs-  qbox <- asks requested+  tbox <- asks (.txs)+  qbox <- asks (.requested)   atomically $ do     ts <- readTVar tbox     rs <- readTVar qbox@@ -636,34 +657,34 @@       th `HashMap.member` ts         || th `HashSet.member` rs -pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx]+pendingTxs :: (MonadIO m) => Int -> BlockT m [PendingTx] pendingTxs i = do   selected <--    asks myTxs >>= \box -> atomically $ do+    asks (.txs) >>= \box -> atomically $ do       pending <- readTVar box       let (selected, rest) = select pending       writeTVar box rest-      return (selected)+      return selected   setPendingTxs   return selected   where     select pend =-      let eligible = HashMap.filter (null . pendingDeps) pend+      let eligible = HashMap.filter (null . (.deps)) pend           orphans = HashMap.difference pend eligible           selected = take i $ sortit eligible           remaining = HashMap.filter (`notElem` selected) eligible        in (selected, remaining <> orphans)     sortit m =-      let sorted = sortTxs $ map pendingTx $ HashMap.elems m+      let sorted = sortTxs $ map (.tx) $ HashMap.elems m           txids = map (txHash . snd) sorted        in mapMaybe (`HashMap.lookup` m) txids -fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m ()+fulfillOrphans :: (MonadIO m) => BlockStore -> TxHash -> m () fulfillOrphans block_read th =   atomically $ modifyTVar box (HashMap.map fulfill)   where-    box = myTxs block_read-    fulfill p = p {pendingDeps = HashSet.delete th (pendingDeps p)}+    box = block_read.txs+    fulfill p = p {deps = HashSet.delete th p.deps}  updateOrphans ::   ( StoreReadBase m,@@ -672,11 +693,11 @@   ) =>   m () updateOrphans = do-  box <- asks myTxs+  box <- asks (.txs)   pending <- readTVarIO box-  let orphans = HashMap.filter (not . null . pendingDeps) pending+  let orphans = HashMap.filter (not . null . (.deps)) pending   updated <- forM orphans $ \p -> do-    let tx = pendingTx p+    let tx = p.tx     exists (txHash tx) >>= \case       True -> return Nothing       False -> Just <$> fill_deps p@@ -686,20 +707,20 @@     exists th =       getTxData th >>= \case         Nothing -> return False-        Just TxData {txDataDeleted = True} -> return False-        Just TxData {txDataDeleted = False} -> return True-    prev_utxos tx = catMaybes <$> mapM (getUnspent . prevOutput) (txIn tx)+        Just TxData {deleted = True} -> return False+        Just TxData {deleted = False} -> return True+    prev_utxos tx = catMaybes <$> mapM (getUnspent . (.outpoint)) tx.inputs     fulfill p unspent =-      let unspent_hash = outPointHash (unspentPoint unspent)-          new_deps = HashSet.delete unspent_hash (pendingDeps p)-       in p {pendingDeps = new_deps}+      let unspent_hash = unspent.outpoint.hash+          new_deps = HashSet.delete unspent_hash p.deps+       in p {deps = new_deps}     fill_deps p = do-      let tx = pendingTx p+      let tx = p.tx       unspents <- prev_utxos tx       return $ foldl fulfill p unspents  newOrphanTx ::-  MonadLoggerIO m =>+  (MonadLoggerIO m) =>   BlockStore ->   UTCTime ->   Tx ->@@ -709,22 +730,22 @@     "Import tx "       <> txHashToHex (txHash tx)       <> ": Orphan"-  let box = myTxs block_read+  let box = block_read.txs   unspents <- catMaybes <$> mapM getUnspent prevs-  let unspent_set = HashSet.fromList (map unspentPoint unspents)+  let unspent_set = HashSet.fromList (map (.outpoint) unspents)       missing_set = HashSet.difference prev_set unspent_set-      missing_txs = HashSet.map outPointHash missing_set+      missing_txs = HashSet.map (.hash) missing_set   atomically . modifyTVar box $     HashMap.insert       (txHash tx)       PendingTx-        { pendingTxTime = time,-          pendingTx = tx,-          pendingDeps = missing_txs+        { time = time,+          tx = tx,+          deps = missing_txs         }   where     prev_set = HashSet.fromList prevs-    prevs = map prevOutput (txIn tx)+    prevs = map (.outpoint) tx.inputs  importMempoolTx ::   (MonadLoggerIO m, MonadError ImportException m) =>@@ -741,63 +762,59 @@       return False     handle_error _ = return False     seconds = floor (utcTimeToPOSIXSeconds time)-    new_mempool_tx =-      newMempoolTx tx seconds >>= \case-        True -> do-          $(logInfoS) "BlockStore" $-            "Import tx "-              <> txHashToHex (txHash tx)-              <> ": OK"-          fulfillOrphans block_read tx_hash-          return True-        False -> do-          $(logDebugS) "BlockStore" $-            "Import tx "-              <> txHashToHex (txHash tx)-              <> ": Already imported"-          return False+    new_mempool_tx = do+      t <- newMempoolTx tx seconds+      $(logInfoS) "BlockStore" $+        "Tx "+          <> txHashToHex (txHash tx)+          <> bool " was already imported" " imported" t+      when t $ fulfillOrphans block_read tx_hash+      return t -notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a+notify :: (MonadIO m) => Maybe Block -> BlockT m a -> BlockT m a notify block go = do   old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool   x <- go   new <- HashSet.union e . HashSet.fromList . map snd <$> getMempool-  l <- asks (blockConfListener . myConfig)+  l <- asks (.config.pub)   forM_ (old `HashSet.difference` new) $ \h ->     publish (StoreMempoolDelete h) l   forM_ (new `HashSet.difference` old) $ \h ->     publish (StoreMempoolNew h) l   case block of-    Just b -> publish (StoreBestBlock (headerHash (blockHeader b))) l+    Just b -> publish (StoreBestBlock (headerHash b.header)) l     Nothing -> return ()   return x   where     e = case block of-      Just b -> HashSet.fromList (map txHash (blockTxns b))+      Just b -> HashSet.fromList (map txHash b.txs)       Nothing -> HashSet.empty -processMempool :: MonadLoggerIO m => BlockT m ()+processMempool :: (MonadLoggerIO m) => BlockT m () processMempool = guardMempool . notify Nothing $ do   txs <- pendingTxs 2000   block_read <- ask   unless (null txs) (import_txs block_read txs)   where     run_import block_read p =-      let t = pendingTx p+      let t = p.tx           h = txHash t-       in importMempoolTx block_read (pendingTxTime p) (pendingTx p)+       in importMempoolTx block_read p.time p.tx     import_txs block_read txs =       let r = mapM (run_import block_read) txs-       in runImport r >>= \case-            Left e -> report_error e-            Right _ -> return ()+       in do+            net <- getNetwork+            ctx <- getCtx+            runImport net ctx r >>= \case+              Left e -> report_error e+              Right _ -> return ()     report_error e = do       $(logErrorS) "BlockImport" $         "Error processing mempool: " <> cs (show e)       throwIO e  processTxs ::-  MonadLoggerIO m =>+  (MonadLoggerIO m) =>   Peer ->   [TxHash] ->   BlockT m ()@@ -808,7 +825,7 @@       "Received inventory with "         <> cs (show (length hs))         <> " transactions from peer: "-        <> peerText p+        <> p.label     xs <- catMaybes <$> zip_counter process_tx     unless (null xs) $ go xs   where@@ -853,9 +870,9 @@               return (Just h)     go xs = do       mapM_ addRequestedTx xs-      net <- asks (blockConfNet . myConfig)-      let inv = if getSegWit net then InvWitnessTx else InvTx-          vec = map (InvVector inv . getTxHash) xs+      net <- asks (.config.net)+      let inv = if net.segWit then InvWitnessTx else InvTx+          vec = map (InvVector inv . (.get)) xs           msg = MGetData (GetData vec)       msg `sendMessage` p @@ -868,38 +885,40 @@   getSyncingState >>= \case     Nothing -> return ()     Just _ -> do-      box <- asks myPeer+      box <- asks (.peer)       now <- liftIO getCurrentTime       atomically $         modifyTVar box $           fmap $-            \x -> x {syncingTime = now}+            \x -> (x :: Syncing) {time = now} -checkTime :: MonadLoggerIO m => BlockT m ()+checkTime :: (MonadLoggerIO m) => BlockT m () checkTime =-  asks myPeer >>= readTVarIO >>= \case+  asks (.peer) >>= readTVarIO >>= \case     Nothing -> return ()     Just       Syncing-        { syncingTime = t,-          syncingPeer = p+        { time = t,+          peer = p         } -> do         now <- liftIO getCurrentTime-        peer_time_out <- asks (blockConfPeerTimeout . myConfig)+        peer_time_out <- asks (.config.peerTimeout)         when (now `diffUTCTime` t > peer_time_out) $ do           $(logErrorS) "BlockStore" $-            "Syncing peer timeout: " <> peerText p+            "Syncing peer timeout: " <> p.label           killPeer PeerTimeout p -revertToMainChain :: MonadLoggerIO m => BlockT m ()+revertToMainChain :: (MonadLoggerIO m) => BlockT m () revertToMainChain = do-  h <- headerHash . nodeHeader <$> getBest-  ch <- asks (blockConfChain . myConfig)+  h <- headerHash . (.header) <$> getBest+  ch <- asks (.config.chain)+  net <- getNetwork+  ctx <- getCtx   chainBlockMain h ch >>= \x -> unless x $ do     $(logWarnS) "BlockStore" $       "Reverting best block: "         <> blockHashToHex h-    runImport (revertBlock h) >>= \case+    runImport net ctx (revertBlock h) >>= \case       Left e -> do         $(logErrorS) "BlockStore" $           "Could not revert block "@@ -910,7 +929,7 @@       Right () -> setSyncingBlocks []     revertToMainChain -getBest :: MonadLoggerIO m => BlockT m BlockNode+getBest :: (MonadLoggerIO m) => BlockT m BlockNode getBest = do   bb <-     getBestBlock >>= \case@@ -918,7 +937,7 @@       Nothing -> do         $(logErrorS) "BlockStore" "No best block set"         throwIO Uninitialized-  ch <- asks (blockConfChain . myConfig)+  ch <- asks (.config.chain)   chainGetBlock bb ch >>= \case     Just x -> return x     Nothing -> do@@ -927,7 +946,7 @@           <> blockHashToHex bb       throwIO (BlockNotInChain bb) -getSyncBest :: MonadLoggerIO m => BlockT m BlockNode+getSyncBest :: (MonadLoggerIO m) => BlockT m BlockNode getSyncBest = do   bb <-     getSyncingBlocks >>= \case@@ -938,7 +957,7 @@             $(logErrorS) "BlockStore" "No best block set"             throwIO Uninitialized       hs -> return $ last hs-  ch <- asks (blockConfChain . myConfig)+  ch <- asks (.config.chain)   chainGetBlock bb ch >>= \case     Just x -> return x     Nothing -> do@@ -947,18 +966,18 @@           <> blockHashToHex bb       throwIO (BlockNotInChain bb) -shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer)+shouldSync :: (MonadLoggerIO m) => BlockT m (Maybe Peer) shouldSync =   isInSync >>= \case     True -> return Nothing     False ->       getSyncingState >>= \case         Nothing -> return Nothing-        Just Syncing {syncingPeer = p, syncingBlocks = bs}+        Just Syncing {peer = p, blocks = bs}           | 100 > length bs -> return (Just p)           | otherwise -> return Nothing -syncMe :: MonadLoggerIO m => BlockT m ()+syncMe :: (MonadLoggerIO m) => BlockT m () syncMe = do   revertToMainChain   shouldSync >>= \case@@ -973,32 +992,30 @@           "Requesting "             <> fromString (show (length iv))             <> " blocks from peer: "-            <> peerText p-        addSyncingBlocks $ map (headerHash . nodeHeader) bns+            <> p.label+        addSyncingBlocks $ map (headerHash . (.header)) bns         MGetData (GetData iv) `sendMessage` p   where     getiv bns = do-      w <- getSegWit <$> asks (blockConfNet . myConfig)+      w <- asks (.config.net.segWit)       let i = if w then InvWitnessBlock else InvBlock-          f = InvVector i . getBlockHash . headerHash . nodeHeader+          f = InvVector i . (.get) . headerHash . (.header)       return $ map f bns     getbh =-      chainGetBest =<< asks (blockConfChain . myConfig)+      chainGetBest =<< asks (.config.chain)     sel bb bh = do       let sh = geth bb bh       t <- top sh bh-      ch <- asks (blockConfChain . myConfig)-      ps <- chainGetParents (nodeHeight bb + 1) t ch+      ch <- asks (.config.chain)+      ps <- chainGetParents (bb.height + 1) t ch       return $         if 500 > length ps           then ps <> [bh]           else ps     geth bb bh =-      min-        (nodeHeight bb + 501)-        (nodeHeight bh)+      min (bb.height + 501) bh.height     top sh bh =-      if sh == nodeHeight bh+      if sh == bh.height         then return bh         else findAncestor sh bh @@ -1008,16 +1025,16 @@   BlockNode ->   m BlockNode findAncestor height target = do-  ch <- asks (blockConfChain . myConfig)+  ch <- asks (.config.chain)   chainGetAncestor height target ch >>= \case     Just ancestor -> return ancestor     Nothing -> do-      let h = headerHash $ nodeHeader target+      let h = headerHash target.header       $(logErrorS) "BlockStore" $         "Could not find header for ancestor of block "           <> blockHashToHex h           <> " at height "-          <> cs (show (nodeHeight target))+          <> cs (show target.height)       throwIO $ AncestorNotInChain height h  finishPeer ::@@ -1025,17 +1042,17 @@   Peer ->   m () finishPeer p = do-  box <- asks myPeer+  box <- asks (.peer)   readTVarIO box >>= \case-    Just Syncing {syncingPeer = p'} | p == p' -> reset_it box+    Just Syncing {peer = p'} | p == p' -> reset_it box     _ -> return ()   where     reset_it box = do       atomically $ writeTVar box Nothing-      $(logDebugS) "BlockStore" $ "Releasing peer: " <> peerText p+      $(logDebugS) "BlockStore" $ "Releasing peer: " <> p.label       setFree p -trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool+trySetPeer :: (MonadLoggerIO m) => Peer -> BlockT m Bool trySetPeer p =   getSyncingState >>= \case     Just _ -> return False@@ -1046,19 +1063,19 @@         False -> return False         True -> do           $(logDebugS) "BlockStore" $-            "Locked peer: " <> peerText p-          box <- asks myPeer+            "Locked peer: " <> p.label+          box <- asks (.peer)           now <- liftIO getCurrentTime           atomically . writeTVar box $             Just               Syncing-                { syncingPeer = p,-                  syncingTime = now,-                  syncingBlocks = []+                { peer = p,+                  time = now,+                  blocks = []                 }           return True -trySyncing :: MonadLoggerIO m => BlockT m ()+trySyncing :: (MonadLoggerIO m) => BlockT m () trySyncing =   isInSync >>= \case     True -> return ()@@ -1073,8 +1090,8 @@         False -> recurse ps         True -> syncMe     online_peer = do-      ops <- getPeers =<< asks (blockConfManager . myConfig)-      let ps = map onlinePeerMailbox ops+      ops <- getPeers =<< asks (.config.peerMgr)+      let ps = map (.mailbox) ops       recurse ps  trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()@@ -1089,34 +1106,62 @@ getSyncingState ::   (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing) getSyncingState =-  readTVarIO =<< asks myPeer+  readTVarIO =<< asks (.peer)  clearSyncingState ::   (MonadLoggerIO m, MonadReader BlockStore m) => m () clearSyncingState =-  asks myPeer >>= readTVarIO >>= \case+  asks (.peer) >>= readTVarIO >>= \case     Nothing -> return ()-    Just Syncing {syncingPeer = p} -> finishPeer p+    Just Syncing {peer = p} -> finishPeer p  processBlockStoreMessage ::   (MonadUnliftIO m, MonadLoggerIO m) =>   BlockStoreMessage ->   BlockT m ()-processBlockStoreMessage (BlockNewBest _) =+processBlockStoreMessage (BlockNewBest node) = do+  $(logDebugS) "BlockStore" $+    "New best block mined at height "+      <> cs (show node.height)+      <> ": "+      <> blockHashToHex (headerHash node.header)   trySyncing-processBlockStoreMessage (BlockPeerConnect p) =+processBlockStoreMessage (BlockPeerConnect p) = do+  $(logDebugS) "BlockStore" $+    "New peer connected: " <> p.label   trySyncingPeer p-processBlockStoreMessage (BlockPeerDisconnect p) =+processBlockStoreMessage (BlockPeerDisconnect p) = do+  $(logDebugS) "BlockStore" $+    "Peer disconnected: " <> p.label   finishPeer p-processBlockStoreMessage (BlockReceived p b) =+processBlockStoreMessage (BlockReceived p b) = do+  $(logDebugS) "BlockStore" $+    "Received block: "+      <> blockHashToHex (headerHash b.header)   processBlock p b-processBlockStoreMessage (BlockNotFound p bs) =+processBlockStoreMessage (BlockNotFound p bs) = do+  $(logDebugS) "BlockStore" $+    "Blocks not found by peer "+      <> p.label+      <> ": "+      <> T.unwords (map blockHashToHex bs)   processNoBlocks p bs-processBlockStoreMessage (TxRefReceived p tx) =+processBlockStoreMessage (TxRefReceived p tx) = do+  $(logDebugS) "BlockStore" $+    "Transaction received from peer "+      <> p.label+      <> ": "+      <> txHashToHex (txHash tx)   processTx p tx-processBlockStoreMessage (TxRefAvailable p ts) =+processBlockStoreMessage (TxRefAvailable p ts) = do+  $(logDebugS) "BlockStore" $+    "Transactions available from peer "+      <> p.label+      <> ": "+      <> T.unwords (map txHashToHex ts)   processTxs p ts processBlockStoreMessage (BlockPing r) = do+  $(logDebugS) "BlockStore" "Internal clock event"   setStoreHeight   setHeadersHeight   setPendingTxs@@ -1128,7 +1173,7 @@   checkTime   atomically (r ()) -pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m ()+pingMe :: (MonadLoggerIO m) => Mailbox BlockStoreMessage -> m () pingMe mbox =   forever $ do     BlockPing `query` mbox@@ -1140,84 +1185,84 @@           )     threadDelay delay -blockStorePeerConnect :: MonadIO m => Peer -> BlockStore -> m ()+blockStorePeerConnect :: (MonadIO m) => Peer -> BlockStore -> m () blockStorePeerConnect peer store =-  BlockPeerConnect peer `send` myMailbox store+  BlockPeerConnect peer `send` store.mailbox  blockStorePeerDisconnect ::-  MonadIO m => Peer -> BlockStore -> m ()+  (MonadIO m) => Peer -> BlockStore -> m () blockStorePeerDisconnect peer store =-  BlockPeerDisconnect peer `send` myMailbox store+  BlockPeerDisconnect peer `send` store.mailbox  blockStoreHead ::-  MonadIO m => BlockNode -> BlockStore -> m ()+  (MonadIO m) => BlockNode -> BlockStore -> m () blockStoreHead node store =-  BlockNewBest node `send` myMailbox store+  BlockNewBest node `send` store.mailbox  blockStoreBlock ::-  MonadIO m => Peer -> Block -> BlockStore -> m ()+  (MonadIO m) => Peer -> Block -> BlockStore -> m () blockStoreBlock peer block store =-  BlockReceived peer block `send` myMailbox store+  BlockReceived peer block `send` store.mailbox  blockStoreNotFound ::-  MonadIO m => Peer -> [BlockHash] -> BlockStore -> m ()+  (MonadIO m) => Peer -> [BlockHash] -> BlockStore -> m () blockStoreNotFound peer blocks store =-  BlockNotFound peer blocks `send` myMailbox store+  BlockNotFound peer blocks `send` store.mailbox  blockStoreTx ::-  MonadIO m => Peer -> Tx -> BlockStore -> m ()+  (MonadIO m) => Peer -> Tx -> BlockStore -> m () blockStoreTx peer tx store =-  TxRefReceived peer tx `send` myMailbox store+  TxRefReceived peer tx `send` store.mailbox  blockStoreTxHash ::-  MonadIO m => Peer -> [TxHash] -> BlockStore -> m ()+  (MonadIO m) => Peer -> [TxHash] -> BlockStore -> m () blockStoreTxHash peer txhashes store =-  TxRefAvailable peer txhashes `send` myMailbox store+  TxRefAvailable peer txhashes `send` store.mailbox  blockStorePeerConnectSTM ::   Peer -> BlockStore -> STM () blockStorePeerConnectSTM peer store =-  BlockPeerConnect peer `sendSTM` myMailbox store+  BlockPeerConnect peer `sendSTM` store.mailbox  blockStorePeerDisconnectSTM ::   Peer -> BlockStore -> STM () blockStorePeerDisconnectSTM peer store =-  BlockPeerDisconnect peer `sendSTM` myMailbox store+  BlockPeerDisconnect peer `sendSTM` store.mailbox  blockStoreHeadSTM ::   BlockNode -> BlockStore -> STM () blockStoreHeadSTM node store =-  BlockNewBest node `sendSTM` myMailbox store+  BlockNewBest node `sendSTM` store.mailbox  blockStoreBlockSTM ::   Peer -> Block -> BlockStore -> STM () blockStoreBlockSTM peer block store =-  BlockReceived peer block `sendSTM` myMailbox store+  BlockReceived peer block `sendSTM` store.mailbox  blockStoreNotFoundSTM ::   Peer -> [BlockHash] -> BlockStore -> STM () blockStoreNotFoundSTM peer blocks store =-  BlockNotFound peer blocks `sendSTM` myMailbox store+  BlockNotFound peer blocks `sendSTM` store.mailbox  blockStoreTxSTM ::   Peer -> Tx -> BlockStore -> STM () blockStoreTxSTM peer tx store =-  TxRefReceived peer tx `sendSTM` myMailbox store+  TxRefReceived peer tx `sendSTM` store.mailbox  blockStoreTxHashSTM ::   Peer -> [TxHash] -> BlockStore -> STM () blockStoreTxHashSTM peer txhashes store =-  TxRefAvailable peer txhashes `sendSTM` myMailbox store+  TxRefAvailable peer txhashes `sendSTM` store.mailbox  blockStorePendingTxs ::-  MonadIO m => BlockStore -> m Int+  (MonadIO m) => BlockStore -> m Int blockStorePendingTxs =   atomically . blockStorePendingTxsSTM  blockStorePendingTxsSTM ::   BlockStore -> STM Int blockStorePendingTxsSTM BlockStore {..} = do-  x <- HashMap.keysSet <$> readTVar myTxs+  x <- HashMap.keysSet <$> readTVar txs   y <- readTVar requested   return $ HashSet.size $ x `HashSet.union` y @@ -1228,9 +1273,9 @@   Just block ->     height <> sep <> t <> sep <> hash <> sep <> size block   where-    height = cs $ show (nodeHeight bn)-    b = posixSecondsToUTCTime . fromIntegral . blockTimestamp $ nodeHeader bn+    height = cs $ show bn.height+    b = posixSecondsToUTCTime $ fromIntegral bn.header.timestamp     t = cs $ formatTime defaultTimeLocale "%FT%T" b-    hash = blockHashToHex (headerHash (nodeHeader bn))+    hash = blockHashToHex (headerHash bn.header)     sep = " | "     size = (<> " bytes") . cs . show . B.length . encode

@@ -2,15 +2,18 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoFieldSelectors #-}  module Haskoin.Store.Cache   ( CacheConfig (..),@@ -97,6 +100,7 @@     BlockHash,     BlockHeader (..),     BlockNode (..),+    Ctx,     DerivPathI (..),     KeyIndex,     OutPoint (..),@@ -124,6 +128,8 @@     chainGetAncestor,     chainGetBest,     chainGetBlock,+    chainGetParents,+    chainGetSplitBlock,   ) import Haskoin.Store.Common import Haskoin.Store.Data@@ -167,60 +173,60 @@   ) import UnliftIO.Concurrent (threadDelay) -runRedis :: MonadLoggerIO m => Redis (Either Reply a) -> CacheX m a-runRedis action =-  asks cacheConn >>= \conn ->-    liftIO (Redis.runRedis conn action) >>= \case-      Right x -> return x-      Left e -> do-        $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e)-        throwIO (RedisError e)+runRedis :: (MonadLoggerIO m) => Redis (Either Reply a) -> CacheX m a+runRedis action = do+  conn <- asks (.redis)+  liftIO (Redis.runRedis conn action) >>= \case+    Right x -> return x+    Left e -> do+      $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e)+      throwIO (RedisError e)  data CacheConfig = CacheConfig-  { cacheConn :: !Connection,-    cacheMin :: !Int,-    cacheMax :: !Integer,-    cacheChain :: !Chain,-    cacheMetrics :: !(Maybe CacheMetrics)+  { redis :: !Connection,+    minAddrs :: !Int,+    maxKeys :: !Integer,+    chain :: !Chain,+    metrics :: !(Maybe CacheMetrics)   }  data CacheMetrics = CacheMetrics   { cacheHits :: !Metrics.Counter,     cacheMisses :: !Metrics.Counter,-    cacheLockAcquired :: !Metrics.Counter,-    cacheLockReleased :: !Metrics.Counter,-    cacheLockFailed :: !Metrics.Counter,-    cacheXPubBals :: !Metrics.Counter,-    cacheXPubUnspents :: !Metrics.Counter,-    cacheXPubTxs :: !Metrics.Counter,-    cacheXPubTxCount :: !Metrics.Counter,-    cacheIndexTime :: !StatDist+    lockAcquired :: !Metrics.Counter,+    lockReleased :: !Metrics.Counter,+    lockFailed :: !Metrics.Counter,+    xPubBals :: !Metrics.Counter,+    xPubUnspents :: !Metrics.Counter,+    xPubTx :: !Metrics.Counter,+    xPubTxCount :: !Metrics.Counter,+    indexTime :: !StatDist   } -newCacheMetrics :: MonadIO m => Metrics.Store -> m CacheMetrics+newCacheMetrics :: (MonadIO m) => Metrics.Store -> m CacheMetrics newCacheMetrics s = liftIO $ do   cacheHits <- c "cache.hits"   cacheMisses <- c "cache.misses"-  cacheLockAcquired <- c "cache.lock_acquired"-  cacheLockReleased <- c "cache.lock_released"-  cacheLockFailed <- c "cache.lock_failed"-  cacheIndexTime <- d "cache.index"-  cacheXPubBals <- c "cache.xpub_balances_cached"-  cacheXPubUnspents <- c "cache.xpub_unspents_cached"-  cacheXPubTxs <- c "cache.xpub_txs_cached"-  cacheXPubTxCount <- c "cache.xpub_tx_count_cached"+  lockAcquired <- c "cache.lock_acquired"+  lockReleased <- c "cache.lock_released"+  lockFailed <- c "cache.lock_failed"+  indexTime <- d "cache.index"+  xPubBals <- c "cache.xpub_balances_cached"+  xPubUnspents <- c "cache.xpub_unspents_cached"+  xPubTx <- c "cache.xpub_txs_cached"+  xPubTxCount <- c "cache.xpub_tx_count_cached"   return CacheMetrics {..}   where     c x = Metrics.createCounter x s     d x = createStatDist x s  withMetrics ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   (CacheMetrics -> StatDist) ->   CacheX m a ->   CacheX m a withMetrics df go =-  asks cacheMetrics >>= \case+  asks (.metrics) >>= \case     Nothing -> go     Just m ->       bracket@@ -235,12 +241,12 @@       addStatQuery (df metrics)  incrementCounter ::-  MonadIO m =>+  (MonadIO m) =>   (CacheMetrics -> Metrics.Counter) ->   Int ->   CacheX m () incrementCounter f i =-  asks cacheMetrics >>= \case+  asks (.metrics) >>= \case     Just s -> liftIO $ Metrics.Counter.add (f s) (fromIntegral i)     Nothing -> return () @@ -254,7 +260,7 @@   | LogicError !String   deriving (Show, Eq, Generic, NFData, Exception) -connectRedis :: MonadIO m => String -> m Connection+connectRedis :: (MonadIO m) => String -> m Connection connectRedis redisurl = do   conninfo <-     if null redisurl@@ -268,6 +274,7 @@   (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>   StoreReadBase (CacheT m)   where+  getCtx = lift getCtx   getNetwork = lift getNetwork   getBestBlock = lift getBestBlock   getBlocksAtHeight = lift . getBlocksAtHeight@@ -323,7 +330,7 @@         lift $           runReaderT (getXPubTxCount xpub xbals) cfg -withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a+withCache :: (StoreReadBase m) => Maybe CacheConfig -> CacheT m a -> m a withCache s f = runReaderT f s  balancesPfx :: ByteString@@ -347,17 +354,18 @@ getXPubTxs xpub xbals limits = go False   where     go m =-      isXPubCached xpub >>= \case-        True -> do-          txs <- cacheGetXPubTxs xpub limits-          incrementCounter cacheXPubTxs (length txs)-          return txs-        False ->-          if m-            then lift $ xPubTxs xpub xbals limits-            else do-              newXPubC xpub xbals-              go True+      isXPubCached xpub >>= \c ->+        if c+          then do+            txs <- cacheGetXPubTxs xpub limits+            incrementCounter (.xPubTx) (length txs)+            return txs+          else do+            if m+              then lift $ xPubTxs xpub xbals limits+              else do+                newXPubC xpub xbals+                go True  getXPubTxCount ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>@@ -368,16 +376,17 @@   go False   where     go t =-      isXPubCached xpub >>= \case-        True -> do-          incrementCounter cacheXPubTxCount 1-          cacheGetXPubTxCount xpub-        False ->-          if t-            then lift $ xPubTxCount xpub xbals-            else do-              newXPubC xpub xbals-              go True+      isXPubCached xpub >>= \c ->+        if c+          then do+            incrementCounter (.xPubTxCount) 1+            cacheGetXPubTxCount xpub+          else do+            if t+              then lift $ xPubTxCount xpub xbals+              else do+                newXPubC xpub xbals+                go True  getXPubUnspents ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>@@ -389,36 +398,38 @@   go False   where     xm =-      let f x = (balanceAddress (xPubBal x), x)-          g = (> 0) . balanceUnspentCount . xPubBal+      let f x = (x.balance.address, x)+          g = (> 0) . (.balance.utxo)        in HashMap.fromList $ map f $ filter g xbals     go m =-      isXPubCached xpub >>= \case-        True -> do-          process-        False ->-          if m-            then lift $ xPubUnspents xpub xbals limits-            else do-              newXPubC xpub xbals-              go True+      isXPubCached xpub >>= \c ->+        if c+          then do+            process+          else do+            if m+              then lift $ xPubUnspents xpub xbals limits+              else do+                newXPubC xpub xbals+                go True     process = do       ops <- map snd <$> cacheGetXPubUnspents xpub limits       uns <- catMaybes <$> lift (mapM getUnspent ops)+      ctx <- lift getCtx       let f u =             either               (const Nothing)               (\a -> Just (a, u))-              (scriptToAddressBS (unspentScript u))+              (scriptToAddressBS ctx u.script)           g a = HashMap.lookup a xm           h u x =             XPubUnspent-              { xPubUnspent = u,-                xPubUnspentPath = xPubBalPath x+              { unspent = u,+                path = x.path               }           us = mapMaybe f uns           i a u = h u <$> g a-      incrementCounter cacheXPubUnspents (length us)+      incrementCounter (.xPubUnspents) (length us)       return $ mapMaybe (uncurry i) us  getXPubBalances ::@@ -426,34 +437,35 @@   XPubSpec ->   CacheX m [XPubBal] getXPubBalances xpub =-  isXPubCached xpub >>= \case-    True -> do-      xbals <- cacheGetXPubBalances xpub-      incrementCounter cacheXPubBals (length xbals)-      return xbals-    False -> do-      bals <- lift $ xPubBals xpub-      newXPubC xpub bals-      return bals+  isXPubCached xpub >>= \c ->+    if c+      then do+        xbals <- cacheGetXPubBalances xpub+        incrementCounter (.xPubBals) (length xbals)+        return xbals+      else do+        bals <- lift $ xPubBals xpub+        newXPubC xpub bals+        return bals -isInCache :: MonadLoggerIO m => XPubSpec -> CacheT m Bool+isInCache :: (MonadLoggerIO m) => XPubSpec -> CacheT m Bool isInCache xpub =   ask >>= \case     Nothing -> return False     Just cfg -> runReaderT (isXPubCached xpub) cfg -isXPubCached :: MonadLoggerIO m => XPubSpec -> CacheX m Bool-isXPubCached xpub = do-  cached <- runRedis (redisIsXPubCached xpub)-  if cached-    then incrementCounter cacheHits 1-    else incrementCounter cacheMisses 1-  return cached+isXPubCached :: (MonadLoggerIO m) => XPubSpec -> CacheX m Bool+isXPubCached xpub =+  runRedis (redisIsXPubCached xpub) >>= \c -> do+    if c+      then incrementCounter (.cacheHits) 1+      else incrementCounter (.cacheMisses) 1+    return c -redisIsXPubCached :: RedisCtx m f => XPubSpec -> m (f Bool)+redisIsXPubCached :: (RedisCtx m f) => XPubSpec -> m (f Bool) redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub) -cacheGetXPubBalances :: MonadLoggerIO m => XPubSpec -> CacheX m [XPubBal]+cacheGetXPubBalances :: (MonadLoggerIO m) => XPubSpec -> CacheX m [XPubBal] cacheGetXPubBalances xpub = do   bals <- runRedis $ redisGetXPubBalances xpub   touchKeys [xpub]@@ -468,7 +480,7 @@   touchKeys [xpub]   return count -redisGetXPubTxCount :: RedisCtx m f => XPubSpec -> m (f Integer)+redisGetXPubTxCount :: (RedisCtx m f) => XPubSpec -> m (f Integer) redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub)  cacheGetXPubTxs ::@@ -477,12 +489,12 @@   Limits ->   CacheX m [TxRef] cacheGetXPubTxs xpub limits =-  case start limits of+  case limits.start of     Nothing ->       go1 Nothing     Just (AtTx th) ->       lift (getTxData th) >>= \case-        Just TxData {txDataBlock = b@BlockRef {}} ->+        Just TxData {block = b@BlockRef {}} ->           go1 $ Just (blockRefScore b)         _ ->           go2 th@@ -495,8 +507,8 @@           getFromSortedSet             (txSetPfx <> encode xpub)             score-            (offset limits)-            (limit limits)+            limits.offset+            limits.limit       touchKeys [xpub]       return $ map (uncurry f) xs     go2 hash = do@@ -515,12 +527,12 @@       return $         map (uncurry f) $           l $-            drop (fromIntegral (offset limits)) xs'+            drop (fromIntegral limits.offset) xs'     l =-      if limit limits > 0-        then take (fromIntegral (limit limits))+      if limits.limit > 0+        then take (fromIntegral limits.limit)         else id-    f t s = TxRef {txRefHash = t, txRefBlock = scoreBlockRef s}+    f t s = TxRef {txid = t, block = scoreBlockRef s}  cacheGetXPubUnspents ::   (StoreReadBase m, MonadLoggerIO m) =>@@ -528,12 +540,12 @@   Limits ->   CacheX m [(BlockRef, OutPoint)] cacheGetXPubUnspents xpub limits =-  case start limits of+  case limits.start of     Nothing ->       go1 Nothing     Just (AtTx th) ->       lift (getTxData th) >>= \case-        Just TxData {txDataBlock = b@BlockRef {}} ->+        Just TxData {block = b@BlockRef {}} ->           go1 (Just (blockRefScore b))         _ ->           go2 th@@ -546,8 +558,8 @@           getFromSortedSet             (utxoPfx <> encode xpub)             score-            (offset limits)-            (limit limits)+            limits.offset+            limits.limit       touchKeys [xpub]       return $ map (uncurry f) xs     go2 hash = do@@ -560,16 +572,16 @@             0       touchKeys [xpub]       let xs' =-            if any ((== hash) . outPointHash . fst) xs-              then dropWhile ((/= hash) . outPointHash . fst) xs+            if any ((== hash) . (.hash) . fst) xs+              then dropWhile ((/= hash) . (.hash) . fst) xs               else []       return $         map (uncurry f) $           l $-            drop (fromIntegral (offset limits)) xs'+            drop (fromIntegral limits.offset) xs'     l =-      if limit limits > 0-        then take (fromIntegral (limit limits))+      if limits.limit > 0+        then take (fromIntegral limits.limit)         else id     f o s = (scoreBlockRef s, o) @@ -577,22 +589,22 @@ redisGetXPubBalances xpub =   fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub)   where-    f p b = XPubBal {xPubBalPath = p, xPubBal = b}+    f p b = XPubBal {path = p, balance = b}  blockRefScore :: BlockRef -> Double-blockRefScore BlockRef {blockRefHeight = h, blockRefPos = p} =+blockRefScore BlockRef {height = h, position = p} =   fromIntegral (0x001fffffffffffff - (h' .|. p'))   where     h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64     p' = (fromIntegral p .&. 0x03ffffff) :: Word64-blockRefScore MemRef {memRefTime = t} = negate t'+blockRefScore MemRef {timestamp = t} = negate t'   where     t' = fromIntegral (t .&. 0x001fffffffffffff)  scoreBlockRef :: Double -> BlockRef scoreBlockRef s-  | s < 0 = MemRef {memRefTime = n}-  | otherwise = BlockRef {blockRefHeight = h, blockRefPos = p}+  | s < 0 = MemRef {timestamp = n}+  | otherwise = BlockRef {height = h, position = p}   where     n = truncate (abs s) :: Word64     m = 0x001fffffffffffff - n@@ -668,8 +680,8 @@ type CacheWriter = Mailbox CacheWriterMessage  data AddressXPub = AddressXPub-  { addressXPubSpec :: !XPubSpec,-    addressXPubPath :: ![KeyIndex]+  { spec :: !XPubSpec,+    path :: ![KeyIndex]   }   deriving (Show, Eq, Generic, NFData, Serialize) @@ -685,10 +697,10 @@ maxKey :: ByteString maxKey = "max" -xPubAddrFunction :: DeriveType -> XPubKey -> Address-xPubAddrFunction DeriveNormal = xPubAddr-xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr-xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr+xPubAddrFunction :: Ctx -> DeriveType -> XPubKey -> Address+xPubAddrFunction ctx DeriveNormal = xPubAddr ctx+xPubAddrFunction ctx DeriveP2SH = xPubCompatWitnessAddr ctx+xPubAddrFunction ctx DeriveP2WPKH = xPubWitnessAddr ctx  cacheWriter ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>@@ -702,40 +714,41 @@       newBlockC       syncMempoolC       forever $ do+        $(logDebugS) "Cache" "Awaiting event..."         x <- receive inbox         cacheWriterReact x -lockIt :: MonadLoggerIO m => CacheX m Bool+lockIt :: (MonadLoggerIO m) => CacheX m Bool lockIt = do   go >>= \case     Right Redis.Ok -> do       $(logDebugS) "Cache" "Acquired lock"-      incrementCounter cacheLockAcquired 1+      incrementCounter (.lockAcquired) 1       return True     Right Redis.Pong -> do       $(logErrorS)         "Cache"         "Unexpected pong when acquiring lock"-      incrementCounter cacheLockFailed 1+      incrementCounter (.lockFailed) 1       return False     Right (Redis.Status s) -> do       $(logErrorS) "Cache" $         "Unexpected status acquiring lock: " <> cs s-      incrementCounter cacheLockFailed 1+      incrementCounter (.lockFailed) 1       return False     Left (Redis.Bulk Nothing) -> do       $(logDebugS) "Cache" "Lock already taken"-      incrementCounter cacheLockFailed 1+      incrementCounter (.lockFailed) 1       return False     Left e -> do       $(logErrorS)         "Cache"         "Error when trying to acquire lock"-      incrementCounter cacheLockFailed 1+      incrementCounter (.lockFailed) 1       throwIO (RedisError e)   where     go = do-      conn <- asks cacheConn+      conn <- asks (.redis)       liftIO . Redis.runRedis conn $ do         let opts =               Redis.SetOpts@@ -745,7 +758,7 @@                 }         Redis.setOpts "lock" "locked" opts -refreshLock :: MonadLoggerIO m => CacheX m ()+refreshLock :: (MonadLoggerIO m) => CacheX m () refreshLock = void . runRedis $ do   let opts =         Redis.SetOpts@@ -755,7 +768,7 @@           }   Redis.setOpts "lock" "locked" opts -unlockIt :: MonadLoggerIO m => Bool -> CacheX m ()+unlockIt :: (MonadLoggerIO m) => Bool -> CacheX m () unlockIt False = return () unlockIt True = void $ runRedis (Redis.del ["lock"]) @@ -777,7 +790,7 @@   (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>   CacheX m Bool isFull = do-  x <- asks cacheMax+  x <- asks (.maxKeys)   s <- runRedis Redis.dbsize   return $ s > x @@ -785,7 +798,8 @@   (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>   CacheX m Integer pruneDB = do-  x <- asks (((`div` 10) . (* 8)) . cacheMax) -- Prune to 80% of max+  x <- asks (((`div` 10) . (* 8)) . (.maxKeys))+  -- Prune to 80% of max   s <- runRedis Redis.dbsize   if s > x then flush (s - x) else return 0   where@@ -800,7 +814,7 @@             "Pruning " <> cs (show (length ks)) <> " old xpubs"           delXPubKeys ks -touchKeys :: MonadLoggerIO m => [XPubSpec] -> CacheX m ()+touchKeys :: (MonadLoggerIO m) => [XPubSpec] -> CacheX m () touchKeys xpubs = do   now <- systemSeconds <$> liftIO getSystemTime   runRedis $ redisTouchKeys now xpubs@@ -815,16 +829,21 @@   CacheWriterMessage ->   CacheX m () cacheWriterReact CacheNewBlock = do+  $(logDebugS) "Cache" "Received new block event"   newBlockC   syncMempoolC-cacheWriterReact (CacheNewTx txid) =+cacheWriterReact (CacheNewTx txid) = do+  $(logDebugS) "Cache" $+    "Received new transaction event: " <> txHashToHex txid   syncNewTxC [txid] cacheWriterReact (CacheSyncMempool l) = do+  $(logDebugS) "Cache" "Received sync mempool event"+  newBlockC   syncMempoolC   atomically $ l ()  lenNotNull :: [XPubBal] -> Int-lenNotNull = length . filter (not . nullBalance . xPubBal)+lenNotNull = length . filter (not . nullBalance . (.balance))  newXPubC ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>@@ -834,7 +853,7 @@ newXPubC xpub xbals =   should_index >>= \i -> when i $     bracket set_index unset_index $ \j -> when j $-      withMetrics cacheIndexTime $ do+      withMetrics (.indexTime) $ do         xpubtxt <- xpubText xpub         $(logDebugS) "Cache" $           "Caching "@@ -867,9 +886,9 @@           return $ b >> c >> d >> e >> return ()         $(logDebugS) "Cache" $ "Cached " <> xpubtxt   where-    op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u)+    op XPubUnspent {unspent = u} = (u.outpoint, u.block)     should_index =-      asks cacheMin >>= \x ->+      asks (.minAddrs) >>= \x ->         if x <= lenNotNull xbals           then             inSync >>= \s ->@@ -886,9 +905,9 @@         }     red = Redis.setOpts key "1" opts     unset_index y = when y . void . runRedis $ Redis.del [key]-    set_index =-      asks cacheConn >>= \conn ->-        liftIO (Redis.runRedis conn red) <&> isRight+    set_index = do+      conn <- asks (.redis)+      liftIO (Redis.runRedis conn red) <&> isRight  inSync ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>@@ -897,72 +916,52 @@   lift getBestBlock >>= \case     Nothing -> return False     Just bb -> do-      ch <- asks cacheChain+      ch <- asks (.chain)       cb <- chainGetBest ch-      return $ nodeHeight cb > 0 && headerHash (nodeHeader cb) == bb+      return $ cb.height > 0 && headerHash cb.header == bb  newBlockC ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>   CacheX m () newBlockC =   inSync >>= \s -> when s . void . withLock $ do-    ch <- asks cacheChain-    bn <- chainGetBest ch-    cn <- cacheGetHead-    case cn of-      Nothing -> do-        $(logInfoS) "Cache" "Initializing best cache block"-        do_import bn-      Just hb ->-        if hb == headerHash (nodeHeader bn)-          then $(logDebugS) "Cache" "Cache in sync"-          else do-            sync ch hb bn-            void pruneDB+    get_best_block_node >>= \case+      Nothing -> $(logErrorS) "Cache" "No best block available"+      Just best_block_node ->+        cacheGetHead >>= \case+          Nothing -> do+            $(logInfoS) "Cache" "Initializing best cache block"+            importBlockC $ headerHash best_block_node.header+          Just cache_head_hash ->+            get_block_node cache_head_hash >>= \case+              Nothing -> do+                $(logErrorS) "Cache" $+                  "Could not get best cache block: "+                    <> blockHashToHex cache_head_hash+              Just cache_head_node -> do+                blocks <- get_blocks cache_head_node best_block_node+                mapM_ importBlockC blocks   where-    sync ch hb bn =-      chainGetBlock hb ch >>= \case-        Nothing -> do-          $(logErrorS) "Cache" $-            "Cache head block node not found: "-              <> blockHashToHex hb-        Just hn ->-          chainBlockMain hb ch >>= \m ->-            if m-              then next ch bn hn-              else do-                $(logDebugS) "Cache" $-                  "Reverting cache head not in main chain: "-                    <> blockHashToHex hb-                removeHeadC hb-                cacheGetHead >>= \case-                  Nothing -> do_import bn-                  Just hb' -> sync ch hb' bn-    next ch bn hn =-      if-          | prevBlock (nodeHeader bn) == headerHash (nodeHeader hn) ->-              do_import bn-          | nodeHeight bn > nodeHeight hn ->-              chainGetAncestor (nodeHeight hn + 1) bn ch >>= \case-                Nothing -> do-                  $(logErrorS) "Cache" $-                    "Ancestor not found at height "-                      <> cs (show (nodeHeight hn + 1))-                      <> " for block: "-                      <> blockHashToHex (headerHash (nodeHeader bn))-                  throwIO $-                    LogicError $-                      "Ancestor not found at height "-                        <> show (nodeHeight hn + 1)-                        <> " for block: "-                        <> cs (blockHashToHex (headerHash (nodeHeader bn)))-                Just hn' -> do-                  do_import hn'-                  next ch bn hn'-          | otherwise ->-              $(logInfoS) "Cache" "Cache best block higher than this node's"-    do_import bn = do-      importBlockC . headerHash $ nodeHeader bn+    get_best_block_node =+      lift getBestBlock >>= \case+        Nothing -> return Nothing+        Just best_block_hash -> get_block_node best_block_hash+    get_block_node block_hash = do+      ch <- asks (.chain)+      chainGetBlock block_hash ch+    get_blocks left_node right_node = do+      ch <- asks (.chain)+      split_node <- chainGetSplitBlock left_node right_node ch+      let split_node_hash = headerHash split_node.header+          right_node_hash = headerHash right_node.header+      if split_node_hash == right_node_hash+        then return []+        else do+          let fork_height = split_node.height + 1+          left_parents <- chainGetParents fork_height left_node ch+          right_parents <- chainGetParents fork_height right_node ch+          let blocks = reverse left_parents <> right_parents <> pure right_node+          return $ map (headerHash . (.header)) blocks  importBlockC ::   (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) =>@@ -971,7 +970,7 @@ importBlockC bh =   lift (getBlock bh) >>= \case     Just bd -> do-      let ths = blockDataTxs bd+      let ths = bd.txs       tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths       $(logDebugS) "Cache" $         "Importing "@@ -993,39 +992,18 @@         "Could not get block: "           <> blockHashToHex bh -removeHeadC ::-  (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) =>-  BlockHash ->-  CacheX m ()-removeHeadC cb =-  void . runMaybeT $ do-    bh <- MaybeT cacheGetHead-    guard (cb == bh)-    bd <- MaybeT (lift (getBlock bh))-    lift $ do-      tds <--        sortTxData . catMaybes-          <$> mapM (lift . getTxData) (blockDataTxs bd)-      $(logDebugS) "Cache" $ "Reverting head: " <> blockHashToHex bh-      importMultiTxC tds-      $(logWarnS) "Cache" $-        "Reverted block head "-          <> blockHashToHex bh-          <> " to parent "-          <> blockHashToHex (prevBlock (blockDataHeader bd))-      cacheSetHead (prevBlock (blockDataHeader bd))- importMultiTxC ::   (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) =>   [TxData] ->   CacheX m () importMultiTxC txs = do+  ctx <- lift getCtx   $(logDebugS) "Cache" $ "Processing " <> cs (show (length txs)) <> " txs"   $(logDebugS) "Cache" $     "Getting address information for "-      <> cs (show (length alladdrs))+      <> cs (show (length (alladdrs ctx)))       <> " addresses"-  addrmap <- getaddrmap+  addrmap <- getaddrmap ctx   let addrs = HashMap.keys addrmap   $(logDebugS) "Cache" $     "Getting balances for "@@ -1034,9 +1012,9 @@   balmap <- getbalances addrs   $(logDebugS) "Cache" $     "Getting unspent data for "-      <> cs (show (length allops))+      <> cs (show (length (allops ctx)))       <> " outputs"-  unspentmap <- getunspents+  unspentmap <- getunspents ctx   gap <- lift getMaxGap   now <- systemSeconds <$> liftIO getSystemTime   let xpubs = allxpubsls addrmap@@ -1058,22 +1036,26 @@     let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap     $(logDebugS) "Cache" "Starting Redis import pipeline"     runRedis $ do-      x <- redisImportMultiTx addrmap' unspentmap txs+      x <- redisImportMultiTx ctx addrmap' unspentmap txs       y <- redisUpdateBalances addrmap' balmap       z <- redisTouchKeys now (HashMap.keys xmap)       return $ x >> y >> z >> return ()     $(logDebugS) "Cache" "Completed Redis pipeline"-    return $ getNewAddrs gap xmap (HashMap.elems addrmap')+    return $ getNewAddrs ctx gap xmap (HashMap.elems addrmap')   cacheAddAddresses addrs'   where-    alladdrsls = HashSet.toList alladdrs-    faddrmap xmap = HashMap.filter (\a -> addressXPubSpec a `elem` xmap)-    getaddrmap =-      HashMap.fromList . catMaybes . zipWith (\a -> fmap (a,)) alladdrsls-        <$> cacheGetAddrsInfo alladdrsls-    getunspents =-      HashMap.fromList . catMaybes . zipWith (\p -> fmap (p,)) allops-        <$> lift (mapM getUnspent allops)+    alladdrsls ctx = HashSet.toList (alladdrs ctx)+    faddrmap xmap = HashMap.filter (\a -> a.spec `elem` xmap)+    getaddrmap ctx =+      HashMap.fromList+        . catMaybes+        . zipWith (\a -> fmap (a,)) (alladdrsls ctx)+        <$> cacheGetAddrsInfo (alladdrsls ctx)+    getunspents ctx =+      HashMap.fromList+        . catMaybes+        . zipWith (\p -> fmap (p,)) (allops ctx)+        <$> lift (mapM getUnspent (allops ctx))     getbalances addrs =       HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs     getxbals xpubs = do@@ -1081,68 +1063,81 @@         bs <- redisGetXPubBalances xpub         return $ (,) xpub <$> bs       return $ HashMap.filter (not . null) (HashMap.fromList bals)-    allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs-    alladdrs =-      HashSet.fromList . map fst $-        concatMap txInputs txs <> concatMap txOutputs txs-    allxpubsls addrmap = HashSet.toList (allxpubs addrmap)-    allxpubs addrmap =-      HashSet.fromList . map addressXPubSpec $ HashMap.elems addrmap+    allops ctx =+      map snd $+        concatMap (txInputs ctx) txs+          <> concatMap (txOutputs ctx) txs+    alladdrs ctx =+      HashSet.fromList $+        map fst $+          concatMap (txInputs ctx) txs+            <> concatMap (txOutputs ctx) txs+    allxpubsls = HashSet.toList . allxpubs+    allxpubs =+      HashSet.fromList . map (.spec) . HashMap.elems  redisImportMultiTx ::   (Monad f, RedisCtx m f) =>+  Ctx ->   HashMap Address AddressXPub ->   HashMap OutPoint Unspent ->   [TxData] ->   m (f ())-redisImportMultiTx addrmap unspentmap txs = do-  xs <- mapM importtxentries txs+redisImportMultiTx ctx addrmap unspentmap tds = do+  xs <- mapM importtxentries tds   return $ sequence_ xs   where     uns p i =       case HashMap.lookup p unspentmap of         Just u ->-          redisAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)]-        Nothing -> redisRemXPubUnspents (addressXPubSpec i) [p]+          redisAddXPubUnspents i.spec [(p, u.block)]+        Nothing -> redisRemXPubUnspents i.spec [p]     addtx tx a p =       case HashMap.lookup a addrmap of         Just i -> do           let tr =                 TxRef-                  { txRefHash = txHash (txData tx),-                    txRefBlock = txDataBlock tx+                  { txid = txHash tx.tx,+                    block = tx.block                   }-          x <- redisAddXPubTxs (addressXPubSpec i) [tr]+          x <- redisAddXPubTxs i.spec [tr]           y <- uns p i           return $ x >> y >> return ()         Nothing -> return (pure ())     remtx tx a p =       case HashMap.lookup a addrmap of         Just i -> do-          x <- redisRemXPubTxs (addressXPubSpec i) [txHash (txData tx)]+          x <- redisRemXPubTxs i.spec [txHash tx.tx]           y <- uns p i           return $ x >> y >> return ()         Nothing -> return (pure ())-    importtxentries tx =-      if txDataDeleted tx+    importtxentries td =+      if td.deleted         then do-          x <- mapM (uncurry (remtx tx)) (txaddrops tx)-          y <- redisRemFromMempool [txHash (txData tx)]+          x <-+            mapM+              (uncurry (remtx td))+              (txaddrops td)+          y <- redisRemFromMempool [txHash td.tx]           return $ sequence_ x >> void y         else do-          a <- sequence <$> mapM (uncurry (addtx tx)) (txaddrops tx)+          a <-+            sequence+              <$> mapM+                (uncurry (addtx td))+                (txaddrops td)           b <--            case txDataBlock tx of+            case td.block of               b@MemRef {} ->                 let tr =                       TxRef-                        { txRefHash = txHash (txData tx),-                          txRefBlock = b+                        { txid = txHash td.tx,+                          block = b                         }                  in redisAddToMempool [tr]-              _ -> redisRemFromMempool [txHash (txData tx)]+              _ -> redisRemFromMempool [txHash td.tx]           return $ a >> b >> return ()-    txaddrops td = txInputs td <> txOutputs td+    txaddrops td = txInputs ctx td <> txOutputs ctx td  redisUpdateBalances ::   (Monad f, RedisCtx m f) =>@@ -1153,11 +1148,11 @@   fmap (fmap mconcat . sequence) . forM (HashMap.keys addrmap) $ \a ->     case (HashMap.lookup a addrmap, HashMap.lookup a balmap) of       (Just ainfo, Just bal) ->-        redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal]+        redisAddXPubBalances ainfo.spec [xpubbal ainfo bal]       _ -> return (pure ())   where     xpubbal ainfo bal =-      XPubBal {xPubBalPath = addressXPubPath ainfo, xPubBal = bal}+      XPubBal {path = ainfo.path, balance = bal}  cacheAddAddresses ::   (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) =>@@ -1165,6 +1160,7 @@   CacheX m () cacheAddAddresses [] = $(logDebugS) "Cache" "No further addresses to add" cacheAddAddresses addrs = do+  ctx <- lift getCtx   $(logDebugS) "Cache" $     "Adding " <> cs (show (length addrs)) <> " new generated addresses"   $(logDebugS) "Cache" "Getting balances"@@ -1183,55 +1179,59 @@   let xpubs =         HashSet.toList           . HashSet.fromList-          . map addressXPubSpec+          . map (.spec)           $ Map.elems amap   $(logDebugS) "Cache" "Getting xpub balances"   xmap <- getbals xpubs   gap <- lift getMaxGap   let notnulls = getnotnull balmap-      addrs' = getNewAddrs gap xmap notnulls+      addrs' = getNewAddrs ctx gap xmap notnulls   cacheAddAddresses addrs'   where     getbals xpubs = runRedis $ do       bs <- sequence <$> forM xpubs redisGetXPubBalances       return $-        HashMap.filter (not . null) . HashMap.fromList . zip xpubs <$> bs+        HashMap.filter (not . null)+          . HashMap.fromList+          . zip xpubs+          <$> bs     amap = Map.fromList addrs     getnotnull =       let f xpub =             map $ \bal ->               AddressXPub-                { addressXPubSpec = xpub,-                  addressXPubPath = xPubBalPath bal+                { spec = xpub,+                  path = bal.path                 }-          g = filter (not . nullBalance . xPubBal)+          g = filter (not . nullBalance . (.balance))        in concatMap (uncurry f) . HashMap.toList . HashMap.map g     getbal a i =       let f b =-            ( addressXPubSpec i,-              [XPubBal {xPubBal = b, xPubBalPath = addressXPubPath i}]+            ( i.spec,+              [XPubBal {balance = b, path = i.path}]             )        in f <$> lift (getDefaultBalance a)     getutxo a i =       let f us =-            ( addressXPubSpec i,-              map (\u -> (unspentPoint u, unspentBlock u)) us+            ( i.spec,+              map (\u -> (u.outpoint, u.block)) us             )        in f <$> lift (getAddressUnspents a def)     gettxmap a i =-      let f ts = (addressXPubSpec i, ts)+      let f ts = (i.spec, ts)        in f <$> lift (getAddressTxs a def)  getNewAddrs ::+  Ctx ->   KeyIndex ->   HashMap XPubSpec [XPubBal] ->   [AddressXPub] ->   [(Address, AddressXPub)]-getNewAddrs gap xpubs =+getNewAddrs ctx gap xpubs =   concatMap $ \a ->-    case HashMap.lookup (addressXPubSpec a) xpubs of+    case HashMap.lookup a.spec xpubs of       Nothing -> []-      Just bals -> addrsToAdd gap bals a+      Just bals -> addrsToAdd ctx gap bals a  syncNewTxC ::   (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>@@ -1243,7 +1243,7 @@     unless (null txs) $ do       forM_ txs $ \tx ->         $(logDebugS) "Cache" $-          "Synchronizing transaction: " <> txHashToHex (txHash (txData tx))+          "Synchronizing transaction: " <> txHashToHex (txHash tx.tx)       importMultiTxC txs  syncMempoolC ::@@ -1263,13 +1263,13 @@         "Synchronizing " <> cs (show (length txs)) <> " mempool transactions"       importMultiTxC txs -cacheGetMempool :: MonadLoggerIO m => CacheX m [(UnixTime, TxHash)]+cacheGetMempool :: (MonadLoggerIO m) => CacheX m [(UnixTime, TxHash)] cacheGetMempool = runRedis redisGetMempool -cacheIsInMempool :: MonadLoggerIO m => TxHash -> CacheX m Bool+cacheIsInMempool :: (MonadLoggerIO m) => TxHash -> CacheX m Bool cacheIsInMempool = runRedis . redisIsInMempool -cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash)+cacheGetHead :: (MonadLoggerIO m) => CacheX m (Maybe BlockHash) cacheGetHead = runRedis redisGetHead  cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m ()@@ -1278,7 +1278,7 @@   void $ runRedis (redisSetHead bh)  cacheGetAddrsInfo ::-  MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub]+  (MonadLoggerIO m) => [Address] -> CacheX m [Maybe AddressXPub] cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as)  redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer)@@ -1286,7 +1286,7 @@ redisAddToMempool btxs =   zadd mempoolSetKey $     map-      (\btx -> (blockRefScore (txRefBlock btx), encode (txRefHash btx)))+      (\btx -> (blockRefScore btx.block, encode btx.txid))       btxs  redisIsInMempool :: (Applicative f, RedisCtx m f) => TxHash -> m (f Bool)@@ -1327,7 +1327,7 @@  redisDelXPubKeys ::   (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer)-redisDelXPubKeys xpub bals = go (map (balanceAddress . xPubBal) bals)+redisDelXPubKeys xpub bals = go $ map (.balance.address) bals   where     go addrs = do       addrcount <-@@ -1351,7 +1351,7 @@ redisAddXPubTxs _ [] = return (pure 0) redisAddXPubTxs xpub btxs =   zadd (txSetPfx <> encode xpub) $-    map (\t -> (blockRefScore (txRefBlock t), encode (txRefHash t))) btxs+    map (\t -> (blockRefScore t.block, encode t.txid)) btxs  redisRemXPubTxs ::   (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer)@@ -1383,16 +1383,16 @@   xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries   ys <- forM bals $ \b ->     redisSetAddrInfo-      (balanceAddress (xPubBal b))+      b.balance.address       AddressXPub-        { addressXPubSpec = xpub,-          addressXPubPath = xPubBalPath b+        { spec = xpub,+          path = b.path         }   return $ sequence_ xs >> sequence_ ys   where-    entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals+    entries = map (\b -> (encode b.path, encode b.balance)) bals -redisSetHead :: RedisCtx m f => BlockHash -> m (f Redis.Status)+redisSetHead :: (RedisCtx m f) => BlockHash -> m (f Redis.Status) redisSetHead bh = Redis.set bestBlockKey (encode bh)  redisGetAddrsInfo ::@@ -1404,60 +1404,69 @@     is' <- sequence is     return $ map (eitherToMaybe . decode =<<) is' -addrsToAdd :: KeyIndex -> [XPubBal] -> AddressXPub -> [(Address, AddressXPub)]-addrsToAdd gap xbals addrinfo-  | null fbals = []-  | not haschange = zipWith f addrs list <> zipWith f changeaddrs changelist-  | otherwise = zipWith f addrs list+addrsToAdd ::+  Ctx ->+  KeyIndex ->+  [XPubBal] ->+  AddressXPub ->+  [(Address, AddressXPub)]+addrsToAdd ctx gap xbals addrinfo+  | null fbals =+      []+  | not haschange =+      zipWith f (addrs ctx) list+        <> zipWith f (changeaddrs ctx) changelist+  | otherwise =+      zipWith f (addrs ctx) list   where-    haschange = any ((== 1) . head . xPubBalPath) xbals-    f a p = (a, AddressXPub {addressXPubSpec = xpub, addressXPubPath = p})-    dchain = head (addressXPubPath addrinfo)-    fbals = filter ((== dchain) . head . xPubBalPath) xbals-    maxidx = maximum (map (head . tail . xPubBalPath) fbals)-    xpub = addressXPubSpec addrinfo-    aidx = (head . tail) (addressXPubPath addrinfo)+    haschange = any ((== 1) . head . (.path)) xbals+    f a p = (a, AddressXPub {spec = xpub, path = p})+    dchain = head addrinfo.path+    fbals = filter ((== dchain) . head . (.path)) xbals+    maxidx = maximum (map (head . tail . (.path)) fbals)+    xpub = addrinfo.spec+    aidx = (head . tail) addrinfo.path     ixs =       if gap > maxidx - aidx         then [maxidx + 1 .. aidx + gap]         else []     paths = map (Deriv :/ dchain :/) ixs-    keys = map (\p -> derivePubPath p (xPubSpecKey xpub))+    keys ctx = map (\p -> derivePubPath ctx p xpub.key)     list = map pathToList paths-    xpubf = xPubAddrFunction (xPubDeriveType xpub)-    addrs = map xpubf (keys paths)+    xpubf ctx = xPubAddrFunction ctx xpub.deriv+    addrs ctx = map (xpubf ctx) (keys ctx paths)     changepaths = map (Deriv :/ 1 :/) [0 .. gap - 1]-    changeaddrs = map xpubf (keys changepaths)+    changeaddrs ctx = map (xpubf ctx) (keys ctx changepaths)     changelist = map pathToList changepaths  sortTxData :: [TxData] -> [TxData] sortTxData tds =-  let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds)-      ths = map (txHash . snd) (sortTxs (map txData tds))+  let txm = Map.fromList (map (\d -> (txHash d.tx, d)) tds)+      ths = map (txHash . snd) (sortTxs (map (.tx) tds))    in mapMaybe (`Map.lookup` txm) ths -txInputs :: TxData -> [(Address, OutPoint)]-txInputs td =-  let is = txIn (txData td)-      ps = I.toAscList (txDataPrevs td)-      as = map (scriptToAddressBS . prevScript . snd) ps-      f (Right a) i = Just (a, prevOutput i)+txInputs :: Ctx -> TxData -> [(Address, OutPoint)]+txInputs ctx td =+  let is = td.tx.inputs+      ps = I.toAscList td.prevs+      as = map (scriptToAddressBS ctx . (.script) . snd) ps+      f (Right a) i = Just (a, i.outpoint)       f (Left _) _ = Nothing    in catMaybes (zipWith f as is) -txOutputs :: TxData -> [(Address, OutPoint)]-txOutputs td =+txOutputs :: Ctx -> TxData -> [(Address, OutPoint)]+txOutputs ctx td =   let ps =         zipWith           ( \i _ ->               OutPoint-                { outPointHash = txHash (txData td),-                  outPointIndex = i+                { hash = txHash td.tx,+                  index = i                 }           )           [0 ..]-          (txOut (txData td))-      as = map (scriptToAddressBS . scriptOutput) (txOut (txData td))+          td.tx.outputs+      as = map (scriptToAddressBS ctx . (.script)) td.tx.outputs       f (Right a) p = Just (a, p)       f (Left _) _ = Nothing    in catMaybes (zipWith f as ps)@@ -1472,25 +1481,29 @@   xs <- getFromSortedSet mempoolSetKey Nothing 0 0   return $ map (uncurry f) <$> xs   where-    f t s = (memRefTime (scoreBlockRef s), t)+    f t s = ((scoreBlockRef s).timestamp, t)  xpubText ::-  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+  ( MonadUnliftIO m,+    MonadLoggerIO m,+    StoreReadBase m+  ) =>   XPubSpec ->   CacheX m Text xpubText xpub = do   net <- lift getNetwork-  let suffix = case xPubDeriveType xpub of+  let suffix = case xpub.deriv of         DeriveNormal -> ""         DeriveP2SH -> "/p2sh"         DeriveP2WPKH -> "/p2wpkh"-  return . cs $ suffix <> xPubExport net (xPubSpecKey xpub)+  ctx <- lift getCtx+  return . cs $ suffix <> xPubExport net ctx xpub.key -cacheNewBlock :: MonadIO m => CacheWriter -> m ()+cacheNewBlock :: (MonadIO m) => CacheWriter -> m () cacheNewBlock = send CacheNewBlock -cacheNewTx :: MonadIO m => TxHash -> CacheWriter -> m ()+cacheNewTx :: (MonadIO m) => TxHash -> CacheWriter -> m () cacheNewTx = send . CacheNewTx -cacheSyncMempool :: MonadIO m => CacheWriter -> m ()+cacheSyncMempool :: (MonadIO m) => CacheWriter -> m () cacheSyncMempool = query CacheSyncMempool

@@ -1,11 +1,15 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoFieldSelectors #-}  module Haskoin.Store.Common   ( Limits (..),@@ -59,14 +63,12 @@ import Control.Monad.Trans.Reader (runReaderT) import Data.ByteString (ByteString) import Data.Default (Default (..))-import qualified Data.Graph as G-import qualified Data.HashSet as H-import qualified Data.HashMap.Strict as M+import Data.HashSet qualified as H import Data.Hashable (Hashable) import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as I+import Data.IntMap.Strict qualified as I import Data.List (sortOn)-import qualified Data.Map.Strict as Map+import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Serialize (Serialize (..))@@ -78,29 +80,6 @@ import Data.Word (Word32, Word64) import GHC.Generics (Generic) import Haskoin-  ( Address,-    BlockHash,-    BlockHeader (..),-    BlockHeight,-    BlockNode (..),-    KeyIndex,-    Network (..),-    OutPoint (..),-    RejectCode (..),-    Tx (..),-    TxHash (..),-    TxIn (..),-    XPubKey (..),-    deriveAddr,-    deriveCompatWitnessAddr,-    deriveWitnessAddr,-    firstGreaterOrEqual,-    headerHash,-    lastSmallerOrEqual,-    mtp,-    pubSubKey,-    txHash,-  ) import Haskoin.Node (Chain, Peer) import Haskoin.Store.Data   ( Balance (..),@@ -120,9 +99,9 @@     toTransaction,     zeroBalance,   )-import qualified System.Metrics as Metrics+import System.Metrics qualified as Metrics import System.Metrics.Counter (Counter)-import qualified System.Metrics.Counter as Counter+import System.Metrics.Counter qualified as Counter import UnliftIO (MonadIO, liftIO)  type DeriveAddr = XPubKey -> KeyIndex -> Address@@ -149,8 +128,9 @@ instance Default Limits where   def = defaultLimits -class Monad m => StoreReadBase m where+class (Monad m) => StoreReadBase m where   getNetwork :: m Network+  getCtx :: m Ctx   getBestBlock :: m (Maybe BlockHash)   getBlocksAtHeight :: BlockHeight -> m [BlockHash]   getBlock :: BlockHash -> m (Maybe BlockData)@@ -160,7 +140,7 @@   getUnspent :: OutPoint -> m (Maybe Unspent)   getMempool :: m [(UnixTime, TxHash)] -class StoreReadBase m => StoreReadExtra m where+class (StoreReadBase m) => StoreReadExtra m where   getAddressesTxs :: [Address] -> Limits -> m [TxRef]   getAddressesUnspents :: [Address] -> Limits -> m [Unspent]   getInitialGap :: m Word32@@ -189,19 +169,19 @@   insertUnspent :: Unspent -> m ()   deleteUnspent :: OutPoint -> m () -getActiveBlock :: StoreReadExtra m => BlockHash -> m (Maybe BlockData)+getActiveBlock :: (StoreReadExtra m) => BlockHash -> m (Maybe BlockData) getActiveBlock bh =   getBlock bh >>= \case-    Just b | blockDataMainChain b -> return (Just b)+    Just b | b.main -> return (Just b)     _ -> return Nothing -getActiveTxData :: StoreReadBase m => TxHash -> m (Maybe TxData)+getActiveTxData :: (StoreReadBase m) => TxHash -> m (Maybe TxData) getActiveTxData th =   getTxData th >>= \case-    Just td | not (txDataDeleted td) -> return (Just td)+    Just td | not (td.deleted) -> return (Just td)     _ -> return Nothing -getDefaultBalance :: StoreReadBase m => Address -> m Balance+getDefaultBalance :: (StoreReadBase m) => Address -> m Balance getDefaultBalance a =   getBalance a >>= \case     Nothing -> return $ zeroBalance a@@ -210,36 +190,40 @@ 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+deriveFunction :: Ctx -> DeriveType -> DeriveAddr+deriveFunction ctx DeriveNormal i = fst . deriveAddr ctx i+deriveFunction ctx DeriveP2SH i = fst . deriveCompatWitnessAddr ctx i+deriveFunction ctx DeriveP2WPKH i = fst . deriveWitnessAddr ctx i  xPubSummary :: XPubSpec -> [XPubBal] -> XPubSummary xPubSummary _xspec xbals =   XPubSummary-    { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs),-      xPubSummaryZero = sum (map (balanceZero . xPubBal) bs),-      xPubSummaryReceived = rx,-      xPubUnspentCount = uc,-      xPubChangeIndex = ch,-      xPubExternalIndex = ex+    { confirmed = sum (map (.balance.confirmed) bs),+      unconfirmed = sum (map (.balance.unconfirmed) bs),+      received = rx,+      utxo = uc,+      change = ch,+      external = ex     }   where-    bs = filter (not . nullBalance . xPubBal) xbals-    ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]-    ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]-    uc = sum [balanceUnspentCount (xPubBal b) | b <- bs]-    xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]-    rx = sum [balanceTotalReceived (xPubBal b) | b <- xt]+    bs = filter (not . nullBalance . (.balance)) xbals+    ex = foldl max 0 [i | XPubBal {path = [0, i]} <- bs]+    ch = foldl max 0 [i | XPubBal {path = [1, i]} <- bs]+    uc = sum [b.balance.utxo | b <- bs]+    xt = [b | b@XPubBal {path = [0, _]} <- bs]+    rx = sum [b.balance.received | b <- xt]  getTransaction ::   (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction)-getTransaction h = fmap toTransaction <$> getTxData h+getTransaction h = do+  ctx <- getCtx+  fmap (toTransaction ctx) <$> getTxData h  getNumTransaction ::   (Monad m, StoreReadExtra m) => Word64 -> m [Transaction]-getNumTransaction i = map toTransaction <$> getNumTxData i+getNumTransaction i =+  getCtx >>= \ctx ->+    map (toTransaction ctx) <$> getNumTxData i  blockAtOrAfter ::   (MonadIO m, StoreReadExtra m) =>@@ -249,10 +233,10 @@ blockAtOrAfter ch q = runMaybeT $ do   net <- lift getNetwork   x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch-  MaybeT $ getBlock (headerHash (nodeHeader x))+  MaybeT $ getBlock $ headerHash x.header   where     f x =-      let t = fromIntegral (blockTimestamp (nodeHeader x))+      let t = fromIntegral x.header.timestamp        in return $ t `compare` q  blockAtOrBefore ::@@ -263,10 +247,10 @@ blockAtOrBefore ch q = runMaybeT $ do   net <- lift getNetwork   x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch-  MaybeT $ getBlock (headerHash (nodeHeader x))+  MaybeT $ getBlock $ headerHash x.header   where     f x =-      let t = fromIntegral (blockTimestamp (nodeHeader x))+      let t = fromIntegral x.header.timestamp        in return $ t `compare` q  blockAtOrAfterMTP ::@@ -277,7 +261,7 @@ blockAtOrAfterMTP ch q = runMaybeT $ do   net <- lift getNetwork   x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch-  MaybeT $ getBlock (headerHash (nodeHeader x))+  MaybeT $ getBlock $ headerHash x.header   where     f x = do       t <- fromIntegral <$> mtp x@@ -330,41 +314,37 @@ applyLimit l = take (fromIntegral l)  deOffset :: Limits -> Limits-deOffset l = case limit l of+deOffset l = case l.limit of   0 -> l {offset = 0}-  _ -> l {limit = limit l + offset l, offset = 0}+  _ -> l {limit = l.limit + l.offset, offset = 0} -applyLimitsC :: Monad m => Limits -> ConduitT i i m ()+applyLimitsC :: (Monad m) => Limits -> ConduitT i i m () applyLimitsC Limits {..} = applyOffsetC offset >> applyLimitC limit -applyOffsetC :: Monad m => Offset -> ConduitT i i m ()+applyOffsetC :: (Monad m) => Offset -> ConduitT i i m () applyOffsetC = dropC . fromIntegral -applyLimitC :: Monad m => Limit -> ConduitT i i m ()+applyLimitC :: (Monad m) => Limit -> ConduitT i i m () applyLimitC 0 = mapC id applyLimitC l = takeC (fromIntegral l)  sortTxs :: [Tx] -> [(Word32, Tx)]-sortTxs txs = ts+sortTxs txs = go [] thset $ zip [0 ..] txs   where-    hm :: M.HashMap TxHash Int-    hm = M.fromList $ zip (map txHash txs) [0 ..]-    ns :: [(Tx, Int, [Int])]-    ns =-      let is tx = nub' $ map (outPointHash . prevOutput) (txIn tx)-          hs tx = mapMaybe (`M.lookup` hm) (is tx)-          tp i tx = (tx, i, hs tx)-       in zipWith tp [0 ..] txs-    (g, n, _) = G.graphFromEdges ns-    vs = G.reverseTopSort g-    ts =-      let f (tx, i, _) = (fromIntegral i, tx)-       in map (f . n) vs+    thset = H.fromList (map txHash txs)+    go [] _ [] = []+    go orphans ths [] = go [] ths orphans+    go orphans ths ((i, tx) : xs) =+      let ops = map (.outpoint.hash) tx.inputs+          orp = any (`H.member` ths) ops+       in if orp+            then go ((i, tx) : orphans) ths xs+            else (i, tx) : go orphans (txHash tx `H.delete` ths) xs  nub' :: (Eq a, Hashable a) => [a] -> [a] nub' = H.toList . H.fromList -microseconds :: MonadIO m => m Integer+microseconds :: (MonadIO m) => m Integer microseconds =   let f t =         toInteger (systemSeconds t) * 1000000@@ -372,7 +352,7 @@    in liftIO $ f <$> getSystemTime  streamThings ::-  Monad m =>+  (Monad m) =>   (Limits -> m [a]) ->   Maybe (a -> TxHash) ->   Limits ->@@ -384,9 +364,9 @@   where     h l x = case gettx of       Just g -> Just l {offset = 1, start = Just (AtTx (g x))}-      Nothing -> case limit l of+      Nothing -> case l.limit of         0 -> Nothing-        _ -> Just l {offset = offset l + limit l}+        _ -> Just l {offset = l.offset + l.limit}     go l x = case h l x of       Nothing -> return ()       Just l' ->@@ -433,7 +413,7 @@     dataXPubTxCount :: !Counter   } -createDataMetrics :: MonadIO m => Metrics.Store -> m DataMetrics+createDataMetrics :: (MonadIO m) => Metrics.Store -> m DataMetrics createDataMetrics s = liftIO $ do   dataBestCount <- Metrics.createCounter "data.best_block" s   dataBlockCount <- Metrics.createCounter "data.blocks" s

@@ -1,8 +1,11 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Haskoin.Store.Database.Reader   ( -- * RocksDB Database Access@@ -34,10 +37,10 @@ import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits ((.&.))-import qualified Data.ByteString as BS+import Data.ByteString qualified as BS import Data.Default (def) import Data.Function (on)-import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Strict qualified as IntMap import Data.List (sortOn) import Data.Maybe (fromMaybe) import Data.Ord (Down (..))@@ -63,6 +66,7 @@   ( Address,     BlockHash,     BlockHeight,+    Ctx,     Network,     OutPoint (..),     TxHash,@@ -72,28 +76,29 @@ import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types-import qualified System.Metrics as Metrics+import System.Metrics qualified as Metrics import System.Metrics.Counter (Counter)-import qualified System.Metrics.Counter as Counter+import System.Metrics.Counter qualified as Counter import UnliftIO (MonadIO, MonadUnliftIO, liftIO)  type DatabaseReaderT = ReaderT DatabaseReader  data DatabaseReader = DatabaseReader-  { databaseHandle :: !DB,-    databaseMaxGap :: !Word32,-    databaseInitialGap :: !Word32,-    databaseNetwork :: !Network,-    databaseMetrics :: !(Maybe DataMetrics)+  { db :: !DB,+    maxGap :: !Word32,+    initGap :: !Word32,+    net :: !Network,+    metrics :: !(Maybe DataMetrics),+    ctx :: !Ctx   }  incrementCounter ::-  MonadIO m =>+  (MonadIO m) =>   (DataMetrics -> Counter) ->   Int ->   ReaderT DatabaseReader m () incrementCounter f i =-  asks databaseMetrics >>= \case+  asks (.metrics) >>= \case     Just s -> liftIO $ Counter.add (f s) (fromIntegral i)     Nothing -> return () @@ -101,23 +106,25 @@ dataVersion = 18  withDatabaseReader ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   Network ->+  Ctx ->   Word32 ->   Word32 ->   FilePath ->   Maybe DataMetrics ->   DatabaseReaderT m a ->   m a-withDatabaseReader net igap gap dir stats f =+withDatabaseReader net ctx igap gap dir stats f =   withDBCF dir cfg columnFamilyConfig $ \db -> do     let bdb =           DatabaseReader-            { databaseHandle = db,-              databaseMaxGap = gap,-              databaseNetwork = net,-              databaseInitialGap = igap,-              databaseMetrics = stats+            { db = db,+              maxGap = gap,+              net = net,+              initGap = igap,+              metrics = stats,+              ctx = ctx             }     initRocksDB bdb     runReaderT f bdb@@ -157,8 +164,8 @@ balanceCF :: DB -> ColumnFamily balanceCF db = columnFamilies db !! 7 -initRocksDB :: MonadIO m => DatabaseReader -> m ()-initRocksDB DatabaseReader {databaseHandle = db} = do+initRocksDB :: (MonadIO m) => DatabaseReader -> m ()+initRocksDB DatabaseReader {db = db} = do   e <-     runExceptT $       retrieve db VersionKey >>= \case@@ -170,11 +177,11 @@     Left s -> error s     Right () -> return () -setInitRocksDB :: MonadIO m => DB -> m ()+setInitRocksDB :: (MonadIO m) => DB -> m () setInitRocksDB db = insert db VersionKey dataVersion  addressConduit ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   Address ->   Maybe Start ->   Iterator ->@@ -194,9 +201,9 @@           (AddrTxKeyB a (BlockRef bh maxBound))       Just (AtTx txh) ->         lift (getTxData txh) >>= \case-          Just TxData {txDataBlock = b@BlockRef {}} ->+          Just TxData {block = b@BlockRef {}} ->             matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)-          Just TxData {txDataBlock = MemRef {}} ->+          Just TxData {block = MemRef {}} ->             let cond (AddrTxKey _a (TxRef MemRef {} th)) =                   th /= txh                 cond (AddrTxKey _a (TxRef BlockRef {} _th)) =@@ -206,13 +213,14 @@           Nothing -> return ()  unspentConduit ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>+  Ctx ->   Address ->   Maybe Start ->   Iterator ->   ConduitT i Unspent (DatabaseReaderT m) ()-unspentConduit a s it =-  x .| mapC (uncurry toUnspent)+unspentConduit ctx a s it =+  x .| mapC (uncurry (toUnspent ctx))   where     x = case s of       Nothing ->@@ -224,11 +232,11 @@           (AddrOutKeyB a (BlockRef h maxBound))       Just (AtTx txh) ->         lift (getTxData txh) >>= \case-          Just TxData {txDataBlock = b@BlockRef {}} ->+          Just TxData {block = b@BlockRef {}} ->             matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)-          Just TxData {txDataBlock = MemRef {}} ->+          Just TxData {block = MemRef {}} ->             let cond (AddrOutKey _a MemRef {} p) =-                  outPointHash p /= txh+                  p.hash /= txh                 cond (AddrOutKey _a BlockRef {} _p) =                   False              in matching it (AddrOutKeyA a)@@ -236,7 +244,7 @@           Nothing -> return ()  withManyIters ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   DB ->   ColumnFamily ->   Int ->@@ -255,117 +263,121 @@ joinConduits cs l =   runConduit $ joinDescStreams cs .| applyLimitsC l .| sinkList -instance MonadIO m => StoreReadBase (DatabaseReaderT m) where-  getNetwork = asks databaseNetwork+instance (MonadIO m) => StoreReadBase (DatabaseReaderT m) where+  getCtx = asks (.ctx)+  getNetwork = asks (.net)    getTxData th = do-    db <- asks databaseHandle+    db <- asks (.db)     retrieveCF db (txCF db) (TxKey th) >>= \case       Nothing -> return Nothing       Just t -> do-        incrementCounter dataTxCount 1+        incrementCounter (.dataTxCount) 1         return (Just t)    getSpender op = runMaybeT $ do-    td <- MaybeT $ getTxData (outPointHash op)-    let i = fromIntegral (outPointIndex op)-    MaybeT . return $ i `IntMap.lookup` txDataSpenders td+    td <- MaybeT $ getTxData op.hash+    let i = fromIntegral op.index+    MaybeT . return $ i `IntMap.lookup` td.spenders    getUnspent p = do-    db <- asks databaseHandle+    db <- asks (.db)+    ctx <- asks (.ctx)     val <- retrieveCF db (unspentCF db) (UnspentKey p)-    case fmap (valToUnspent p) val of+    case fmap (valToUnspent ctx p) val of       Nothing -> return Nothing       Just u -> do-        incrementCounter dataUnspentCount 1+        incrementCounter (.dataUnspentCount) 1         return (Just u)    getBalance a = do-    db <- asks databaseHandle-    incrementCounter dataBalanceCount 1+    db <- asks (.db)+    incrementCounter (.dataBalanceCount) 1     fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a)    getMempool = do-    db <- asks databaseHandle-    incrementCounter dataMempoolCount 1+    db <- asks (.db)+    incrementCounter (.dataMempoolCount) 1     fromMaybe [] <$> retrieve db MemKey    getBestBlock = do-    incrementCounter dataBestCount 1-    asks databaseHandle >>= (`retrieve` BestKey)+    incrementCounter (.dataBestCount) 1+    asks (.db) >>= (`retrieve` BestKey)    getBlocksAtHeight h = do-    db <- asks databaseHandle+    db <- asks (.db)     retrieveCF db (heightCF db) (HeightKey h) >>= \case       Nothing -> return []       Just ls -> do-        incrementCounter dataBlockCount (length ls)+        incrementCounter (.dataBlockCount) (length ls)         return ls    getBlock h = do-    db <- asks databaseHandle+    db <- asks (.db)     retrieveCF db (blockCF db) (BlockKey h) >>= \case       Nothing -> return Nothing       Just b -> do-        incrementCounter dataBlockCount 1+        incrementCounter (.dataBlockCount) 1         return (Just b) -instance MonadUnliftIO m => StoreReadExtra (DatabaseReaderT m) where+instance (MonadUnliftIO m) => StoreReadExtra (DatabaseReaderT m) where   getAddressesTxs addrs limits = do-    db <- asks databaseHandle+    db <- asks (.db)     withManyIters db (addrTxCF db) (length addrs) $ \its -> do       txs <- joinConduits (cs its) limits-      incrementCounter dataAddrTxCount (length txs)+      incrementCounter (.dataAddrTxCount) (length txs)       return txs     where-      cs = map (uncurry c) . zip addrs-      c a = addressConduit a (start limits)+      cs = zipWith c addrs+      c a = addressConduit a limits.start    getAddressesUnspents addrs limits = do-    db <- asks databaseHandle+    db <- asks (.db)+    ctx <- asks (.ctx)     withManyIters db (addrOutCF db) (length addrs) $ \its -> do-      uns <- joinConduits (cs its) limits-      incrementCounter dataUnspentCount (length uns)+      uns <- joinConduits (cs ctx its) limits+      incrementCounter (.dataUnspentCount) (length uns)       return uns     where-      cs = map (uncurry c) . zip addrs-      c a = unspentConduit a (start limits)+      cs ctx = zipWith (c ctx) addrs+      c ctx a = unspentConduit ctx a limits.start    getAddressUnspents a limits = do-    db <- asks databaseHandle+    db <- asks (.db)+    ctx <- asks (.ctx)     us <- withIterCF db (addrOutCF db) $ \it ->       runConduit $-        unspentConduit a (start limits) it+        unspentConduit ctx a limits.start it           .| applyLimitsC limits           .| sinkList-    incrementCounter dataUnspentCount (length us)+    incrementCounter (.dataUnspentCount) (length us)     return us    getAddressTxs a limits = do-    db <- asks databaseHandle+    db <- asks (.db)     txs <- withIterCF db (addrTxCF db) $ \it ->       runConduit $-        addressConduit a (start limits) it+        addressConduit a limits.start it           .| applyLimitsC limits           .| sinkList-    incrementCounter dataAddrTxCount (length txs)+    incrementCounter (.dataAddrTxCount) (length txs)     return txs -  getMaxGap = asks databaseMaxGap+  getMaxGap = asks (.maxGap) -  getInitialGap = asks databaseInitialGap+  getInitialGap = asks (.initGap)    getNumTxData i = do-    db <- asks databaseHandle+    db <- asks (.db)     let (sk, w) = decodeTxKey i     ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk)     let f t =-          let bs = encode $ txHash (txData t)+          let bs = encode $ txHash t.tx               b = BS.head (BS.drop 6 bs)               w' = b .&. 0xf8            in w == w'         txs = filter f $ map snd ls-    incrementCounter dataTxCount (length txs)+    incrementCounter (.dataTxCount) (length txs)     return txs    getBalances as = do@@ -375,25 +387,26 @@       f _ (Just b) = b    xPubBals xpub = do+    ctx <- asks (.ctx)     igap <- getInitialGap     gap <- getMaxGap-    ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0))-    if all (nullBalance . xPubBal) ext1+    ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv ctx 0 0))+    if all (nullBalance . (.balance)) ext1       then do-        incrementCounter dataXPubBals (length ext1)+        incrementCounter (.dataXPubBals) (length ext1)         return ext1       else do-        ext2 <- derive_until_gap gap 0 (aderiv 0 igap)-        chg <- derive_until_gap gap 1 (aderiv 1 0)+        ext2 <- derive_until_gap gap 0 (aderiv ctx 0 igap)+        chg <- derive_until_gap gap 1 (aderiv ctx 1 0)         let bals = ext1 <> ext2 <> chg-        incrementCounter dataXPubBals (length bals)+        incrementCounter (.dataXPubBals) (length bals)         return bals     where-      aderiv m =+      aderiv ctx m =         deriveAddresses-          (deriveFunction (xPubDeriveType xpub))-          (pubSubKey (xPubSpecKey xpub) m)-      xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+          (deriveFunction ctx xpub.deriv)+          (pubSubKey ctx xpub.key m)+      xbalance m b n = XPubBal {path = [m, n], balance = b}       derive_until_gap _ _ [] = return []       derive_until_gap gap m as = do         let (as1, as2) = splitAt (fromIntegral gap) as@@ -405,26 +418,24 @@    xPubUnspents _xspec xbals limits = do     us <- concat <$> mapM h cs-    incrementCounter dataXPubUnspents (length us)+    incrementCounter (.dataXPubUnspents) (length us)     return . applyLimits limits $ sortOn Down us     where       l = deOffset limits-      cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals-      i b = do-        us <- getAddressUnspents (balanceAddress (xPubBal b)) l-        return us-      f b t = XPubUnspent {xPubUnspentPath = xPubBalPath b, xPubUnspent = t}+      cs = filter ((> 0) . (.balance.utxo)) xbals+      i b = getAddressUnspents b.balance.address l+      f b t = XPubUnspent {path = b.path, unspent = t}       h b = map (f b) <$> i b    xPubTxs _xspec xbals limits = do     let as =-          map balanceAddress $+          map (.address) $             filter (not . nullBalance) $-              map xPubBal xbals+              map (.balance) xbals     txs <- getAddressesTxs as limits-    incrementCounter dataXPubTxs (length txs)+    incrementCounter (.dataXPubTxs) (length txs)     return txs    xPubTxCount xspec xbals = do-    incrementCounter dataXPubTxCount 1+    incrementCounter (.dataXPubTxCount) 1     fromIntegral . length <$> xPubTxs xspec xbals def

@@ -1,7 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Haskoin.Store.Database.Types   ( AddrTxKey (..),@@ -37,7 +41,7 @@     (.|.),   ) import Data.ByteString (ByteString)-import qualified Data.ByteString as BS+import Data.ByteString qualified as BS import Data.Default (Default (..)) import Data.Either (fromRight) import Data.Hashable (Hashable)@@ -67,6 +71,7 @@     eitherToMaybe,     scriptToAddressBS,   )+import Haskoin.Crypto import Haskoin.Store.Data   ( Balance (..),     BlockData,@@ -82,14 +87,16 @@ data AddrTxKey   = -- | key for a transaction affecting an address     AddrTxKey-      { addrTxKeyA :: !Address,-        addrTxKeyT :: !TxRef+      { address :: !Address,+        tx :: !TxRef       }   | -- | short key that matches all entries-    AddrTxKeyA {addrTxKeyA :: !Address}+    AddrTxKeyA+      { address :: !Address+      }   | AddrTxKeyB-      { addrTxKeyA :: !Address,-        addrTxKeyB :: !BlockRef+      { address :: !Address,+        block :: !BlockRef       }   | AddrTxKeyS   deriving (Show, Eq, Ord, Generic, Hashable)@@ -99,18 +106,18 @@    put     AddrTxKey-      { addrTxKeyA = a,-        addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t}+      { address = a,+        tx = TxRef {block = b, txid = t}       } = do-      put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b}+      put AddrTxKeyB {address = a, block = b}       put t   -- 0x05 · Address-  put AddrTxKeyA {addrTxKeyA = a} = do+  put AddrTxKeyA {address = a} = do     put AddrTxKeyS     put a   -- 0x05 · Address · BlockRef-  put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do-    put AddrTxKeyA {addrTxKeyA = a}+  put AddrTxKeyB {address = a, block = b} = do+    put AddrTxKeyA {address = a}     put b   -- 0x05   put AddrTxKeyS = putWord8 0x05@@ -121,8 +128,8 @@     t <- get     return       AddrTxKey-        { addrTxKeyA = a,-          addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t}+        { address = a,+          tx = TxRef {block = b, txid = t}         }  instance Key AddrTxKey@@ -133,15 +140,17 @@ data AddrOutKey   = -- | full key     AddrOutKey-      { addrOutKeyA :: !Address,-        addrOutKeyB :: !BlockRef,-        addrOutKeyP :: !OutPoint+      { address :: !Address,+        block :: !BlockRef,+        outpoint :: !OutPoint       }   | -- | short key for all spent or unspent outputs-    AddrOutKeyA {addrOutKeyA :: !Address}+    AddrOutKeyA+      { address :: !Address+      }   | AddrOutKeyB-      { addrOutKeyA :: !Address,-        addrOutKeyB :: !BlockRef+      { address :: !Address,+        block :: !BlockRef       }   | AddrOutKeyS   deriving (Show, Read, Eq, Ord, Generic, Hashable)@@ -149,15 +158,15 @@ instance Serialize AddrOutKey where   -- 0x06 · StoreAddr · BlockRef · OutPoint -  put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do-    put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b}+  put AddrOutKey {address = a, block = b, outpoint = p} = do+    put AddrOutKeyB {address = a, block = b}     put p   -- 0x06 · StoreAddr · BlockRef-  put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do-    put AddrOutKeyA {addrOutKeyA = a}+  put AddrOutKeyB {address = a, block = b} = do+    put AddrOutKeyA {address = a}     put b   -- 0x06 · StoreAddr-  put AddrOutKeyA {addrOutKeyA = a} = do+  put AddrOutKeyA {address = a} = do     put AddrOutKeyS     put a   -- 0x06@@ -169,8 +178,8 @@ instance Key AddrOutKey  data OutVal = OutVal-  { outValAmount :: !Word64,-    outValScript :: !ByteString+  { value :: !Word64,+    script :: !ByteString   }   deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) @@ -178,8 +187,8 @@  -- | Transaction database key. data TxKey-  = TxKey {txKey :: TxHash}-  | TxKeyS {txKeyShort :: (Word32, Word16)}+  = TxKey {txid :: TxHash}+  | TxKeyS {short :: (Word32, Word16)}   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize TxKey where@@ -213,19 +222,19 @@  -- | Unspent output database key. data UnspentKey-  = UnspentKey {unspentKey :: !OutPoint}-  | UnspentKeyS {unspentKeyS :: !TxHash}+  = UnspentKey {outpoint :: !OutPoint}+  | UnspentKeyS {txid :: !TxHash}   | UnspentKeyB   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize UnspentKey where   -- 0x09 · TxHash · Index-  put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do+  put UnspentKey {outpoint = OutPoint {hash = h, index = i}} = do     putWord8 0x09     put h     put i   -- 0x09 · TxHash-  put UnspentKeyS {unspentKeyS = t} = do+  put UnspentKeyS {txid = t} = do     putWord8 0x09     put t   -- 0x09@@ -234,20 +243,20 @@     guard . (== 0x09) =<< getWord8     h <- get     i <- get-    return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i}+    return $ UnspentKey OutPoint {hash = h, index = i}  instance Key UnspentKey  instance KeyValue UnspentKey UnspentVal -toUnspent :: AddrOutKey -> OutVal -> Unspent-toUnspent b v =+toUnspent :: Ctx -> AddrOutKey -> OutVal -> Unspent+toUnspent ctx AddrOutKey {..} OutVal {..} =   Unspent-    { unspentBlock = addrOutKeyB b,-      unspentAmount = outValAmount v,-      unspentScript = outValScript v,-      unspentPoint = addrOutKeyP b,-      unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v))+    { block = block,+      value = value,+      script = script,+      outpoint = outpoint,+      address = eitherToMaybe (scriptToAddressBS ctx script)     }  -- | Mempool transaction database key.@@ -268,7 +277,7 @@  -- | Block entry database key. newtype BlockKey = BlockKey-  { blockKey :: BlockHash+  { hash :: BlockHash   }   deriving (Show, Read, Eq, Ord, Generic, Hashable) @@ -287,15 +296,15 @@  -- | Block height database key. newtype HeightKey = HeightKey-  { heightKey :: BlockHeight+  { height :: BlockHeight   }   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize HeightKey where   -- 0x03 · BlockHeight-  put (HeightKey height) = do+  put (HeightKey h) = do     putWord8 0x03-    put height+    put h   get = do     guard . (== 0x03) =<< getWord8     HeightKey <$> get@@ -307,14 +316,14 @@ -- | Address balance database key. data BalKey   = BalKey-      { balanceKey :: !Address+      { address :: !Address       }   | BalKeyS   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize BalKey where   -- 0x04 · Address-  put BalKey {balanceKey = a} = do+  put (BalKey a) = do     putWord8 0x04     put a   -- 0x04@@ -360,96 +369,45 @@ instance KeyValue VersionKey Word32  data BalVal = BalVal-  { balValAmount :: !Word64,-    balValZero :: !Word64,-    balValUnspentCount :: !Word64,-    balValTxCount :: !Word64,-    balValTotalReceived :: !Word64+  { confirmed :: !Word64,+    unconfirmed :: !Word64,+    utxo :: !Word64,+    txs :: !Word64,+    received :: !Word64   }   deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)  valToBalance :: Address -> BalVal -> Balance-valToBalance-  a-  BalVal-    { balValAmount = v,-      balValZero = z,-      balValUnspentCount = u,-      balValTxCount = t,-      balValTotalReceived = r-    } =-    Balance-      { balanceAddress = a,-        balanceAmount = v,-        balanceZero = z,-        balanceUnspentCount = u,-        balanceTxCount = t,-        balanceTotalReceived = r-      }+valToBalance address BalVal {..} =+  Balance {..}  balanceToVal :: Balance -> BalVal-balanceToVal-  Balance-    { balanceAmount = v,-      balanceZero = z,-      balanceUnspentCount = u,-      balanceTxCount = t,-      balanceTotalReceived = r-    } =-    BalVal-      { balValAmount = v,-        balValZero = z,-        balValUnspentCount = u,-        balValTxCount = t,-        balValTotalReceived = r-      }+balanceToVal Balance {..} =+  BalVal {..}  -- | Default balance for an address. instance Default BalVal where   def =     BalVal-      { balValAmount = 0,-        balValZero = 0,-        balValUnspentCount = 0,-        balValTxCount = 0,-        balValTotalReceived = 0+      { confirmed = 0,+        unconfirmed = 0,+        utxo = 0,+        txs = 0,+        received = 0       }  data UnspentVal = UnspentVal-  { unspentValBlock :: !BlockRef,-    unspentValAmount :: !Word64,-    unspentValScript :: !ByteString+  { block :: !BlockRef,+    value :: !Word64,+    script :: !ByteString   }   deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)  unspentToVal :: Unspent -> (OutPoint, UnspentVal)-unspentToVal-  Unspent-    { unspentBlock = b,-      unspentPoint = p,-      unspentAmount = v,-      unspentScript = s-    } =-    ( p,-      UnspentVal-        { unspentValBlock = b,-          unspentValAmount = v,-          unspentValScript = s-        }-    )+unspentToVal Unspent {..} = (outpoint, UnspentVal {..}) -valToUnspent :: OutPoint -> UnspentVal -> Unspent-valToUnspent-  p-  UnspentVal-    { unspentValBlock = b,-      unspentValAmount = v,-      unspentValScript = s-    } =-    Unspent-      { unspentBlock = b,-        unspentPoint = p,-        unspentAmount = v,-        unspentScript = s,-        unspentAddress = eitherToMaybe (scriptToAddressBS s)-      }+valToUnspent :: Ctx -> OutPoint -> UnspentVal -> Unspent+valToUnspent ctx outpoint UnspentVal {..} =+  Unspent {..}+  where+    address = eitherToMaybe (scriptToAddressBS ctx script)

@@ -1,18 +1,22 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Haskoin.Store.Database.Writer (WriterT, runWriter) where  import Control.Monad (join) import Control.Monad.Reader (ReaderT (..))-import qualified Control.Monad.Reader as R+import Control.Monad.Reader qualified as R import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import qualified Data.HashTable.IO as H-import qualified Data.IntMap.Strict as IntMap+import Data.HashMap.Strict qualified as M+import Data.HashTable.IO qualified as H+import Data.IntMap.Strict qualified as IntMap import Data.List (sortOn) import Data.Ord (Down (..)) import Data.Tuple (swap)@@ -28,6 +32,7 @@   ( Address,     BlockHash,     BlockHeight,+    Ctx,     Network,     OutPoint (..),     TxHash,@@ -54,14 +59,15 @@   )  data Writer = Writer-  { getReader :: !DatabaseReader,-    getState :: !Memory+  { reader :: !DatabaseReader,+    memory :: !Memory   }  type WriterT = ReaderT Writer -instance MonadIO m => StoreReadBase (WriterT m) where-  getNetwork = getNetworkI+instance (MonadIO m) => StoreReadBase (WriterT m) where+  getNetwork = R.asks (.reader.net)+  getCtx = R.asks (.reader.ctx)   getBestBlock = getBestBlockI   getBlocksAtHeight = getBlocksAtHeightI   getBlock = getBlockI@@ -92,149 +98,152 @@ type MempoolTable = H.BasicHashTable TxHash UnixTime  data Memory = Memory-  { hNet :: !NetRef,-    hBest :: !BestRef,-    hBlock :: !BlockTable,-    hHeight :: !HeightTable,-    hTx :: !TxTable,-    hUnspent :: !UnspentTable,-    hBalance :: !BalanceTable,-    hAddrTx :: !AddrTxTable,-    hAddrOut :: !AddrOutTable,-    hMempool :: !MempoolTable+  { net :: !Network,+    ctx :: !Ctx,+    best :: !BestRef,+    blockTable :: !BlockTable,+    heightTable :: !HeightTable,+    txTable :: !TxTable,+    unspentTable :: !UnspentTable,+    balanceTable :: !BalanceTable,+    addressTable :: !AddrTxTable,+    outputTable :: !AddrOutTable,+    mempoolTable :: !MempoolTable   } -instance MonadIO m => StoreWrite (WriterT m) where+instance (MonadIO m) => StoreWrite (WriterT m) where   setBest h =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ writeIORef (hBest s) (Just (Just h))+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ writeIORef best (Just (Just h))   insertBlock b =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hBlock s) (headerHash (blockDataHeader b)) (Just b)+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert blockTable (headerHash b.header) (Just b)   setBlocksAtHeight h g =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hHeight s) g h+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert heightTable g h   insertTx t =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hTx s) (txHash (txData t)) (Just t)+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert txTable (txHash t.tx) (Just t)   insertAddrTx a t =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hAddrTx s) (a, t) (Just ())+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert addressTable (a, t) (Just ())   deleteAddrTx a t =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hAddrTx s) (a, t) Nothing+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert addressTable (a, t) Nothing   insertAddrUnspent a u =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hAddrOut s) k (Just v)+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert outputTable k (Just v)     where-      k = (a, unspentBlock u, unspentPoint u)-      v = OutVal {outValAmount = unspentAmount u, outValScript = unspentScript u}+      k = (a, u.block, u.outpoint)+      v = OutVal {value = u.value, script = u.script}   deleteAddrUnspent a u =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hAddrOut s) k Nothing+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert outputTable k Nothing     where-      k = (a, unspentBlock u, unspentPoint u)+      k = (a, u.block, u.outpoint)   addToMempool x t =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hMempool s) x t+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert mempoolTable x t   deleteFromMempool x =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.delete (hMempool s) x+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.delete mempoolTable x   setBalance b =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hBalance s) (balanceAddress b) (Just b)+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert balanceTable b.address (Just b)   insertUnspent u =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hUnspent s) (fst (unspentToVal u)) (Just u)+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert unspentTable (fst (unspentToVal u)) (Just u)   deleteUnspent p =-    ReaderT $ \Writer {getState = s} ->-      liftIO $ H.insert (hUnspent s) p Nothing+    ReaderT $ \Writer {memory = Memory {..}} ->+      liftIO $ H.insert unspentTable p Nothing  getLayered ::-  MonadIO m =>+  (MonadIO m) =>   (Memory -> IO (Maybe a)) ->   DatabaseReaderT m a ->   WriterT m a getLayered f g =-  ReaderT $ \Writer {getReader = db, getState = s} ->+  ReaderT $ \Writer {reader = db, memory = s} ->     liftIO (f s) >>= \case       Just x -> return x       Nothing -> runReaderT g db  runWriter ::-  MonadIO m =>+  (MonadIO m) =>+  Network ->+  Ctx ->   DatabaseReader ->   WriterT m a ->   m a-runWriter bdb@DatabaseReader {databaseHandle = db} f = do+runWriter net ctx bdb@DatabaseReader {db} f = do   mempool <- runReaderT getMempool bdb-  hm <- newMemory mempool-  x <- R.runReaderT f Writer {getReader = bdb, getState = hm}+  hm <- newMemory net ctx mempool+  x <- R.runReaderT f Writer {reader = bdb, memory = hm}   ops <- hashMapOps db hm   writeBatch db ops   return x -hashMapOps :: MonadIO m => DB -> Memory -> m [BatchOp]-hashMapOps db mem =+hashMapOps :: (MonadIO m) => DB -> Memory -> m [BatchOp]+hashMapOps db Memory {..} =   mconcat     <$> sequence-      [ bestBlockOp (hBest mem),-        blockHashOps db (hBlock mem),-        blockHeightOps db (hHeight mem),-        txOps db (hTx mem),-        balOps db (hBalance mem),-        addrTxOps db (hAddrTx mem),-        addrOutOps db (hAddrOut mem),-        mempoolOp (hMempool mem),-        unspentOps db (hUnspent mem)+      [ bestBlockOp best,+        blockHashOps db blockTable,+        blockHeightOps db heightTable,+        txOps db txTable,+        balOps db balanceTable,+        addrTxOps db addressTable,+        addrOutOps db outputTable,+        mempoolOp mempoolTable,+        unspentOps db unspentTable       ] -bestBlockOp :: MonadIO m => BestRef -> m [BatchOp]+bestBlockOp :: (MonadIO m) => BestRef -> m [BatchOp] bestBlockOp r =   readIORef r >>= \case     Nothing -> return []     Just Nothing -> return [deleteOp BestKey]     Just (Just b) -> return [insertOp BestKey b] -blockHashOps :: MonadIO m => DB -> BlockTable -> m [BatchOp]+blockHashOps :: (MonadIO m) => DB -> BlockTable -> m [BatchOp] blockHashOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f k (Just d) = insertOpCF (blockCF db) (BlockKey k) d     f k Nothing = deleteOpCF (blockCF db) (BlockKey k) -blockHeightOps :: MonadIO m => DB -> HeightTable -> m [BatchOp]+blockHeightOps :: (MonadIO m) => DB -> HeightTable -> m [BatchOp] blockHeightOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f = insertOpCF (heightCF db) . HeightKey -txOps :: MonadIO m => DB -> TxTable -> m [BatchOp]+txOps :: (MonadIO m) => DB -> TxTable -> m [BatchOp] txOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f k (Just t) = insertOpCF (txCF db) (TxKey k) t     f k Nothing = deleteOpCF (txCF db) (TxKey k) -balOps :: MonadIO m => DB -> BalanceTable -> m [BatchOp]+balOps :: (MonadIO m) => DB -> BalanceTable -> m [BatchOp] balOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f a (Just b) = insertOpCF (balanceCF db) (BalKey a) (balanceToVal b)     f a Nothing = deleteOpCF (balanceCF db) (BalKey a) -addrTxOps :: MonadIO m => DB -> AddrTxTable -> m [BatchOp]+addrTxOps :: (MonadIO m) => DB -> AddrTxTable -> m [BatchOp] addrTxOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f (a, t) (Just ()) = insertOpCF (addrTxCF db) (AddrTxKey a t) ()     f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t) -addrOutOps :: MonadIO m => DB -> AddrOutTable -> m [BatchOp]+addrOutOps :: (MonadIO m) => DB -> AddrOutTable -> m [BatchOp] addrOutOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f (a, b, p) (Just l) =       insertOpCF         (addrOutCF db)         ( AddrOutKey-            { addrOutKeyA = a,-              addrOutKeyB = b,-              addrOutKeyP = p+            { address = a,+              block = b,+              outpoint = p             }         )         l@@ -242,16 +251,16 @@       deleteOpCF         (addrOutCF db)         AddrOutKey-          { addrOutKeyA = a,-            addrOutKeyB = b,-            addrOutKeyP = p+          { address = a,+            block = b,+            outpoint = p           } -mempoolOp :: MonadIO m => MempoolTable -> m [BatchOp]+mempoolOp :: (MonadIO m) => MempoolTable -> m [BatchOp] mempoolOp t =   return . insertOp MemKey . sortOn Down . map swap <$> liftIO (H.toList t) -unspentOps :: MonadIO m => DB -> UnspentTable -> m [BatchOp]+unspentOps :: (MonadIO m) => DB -> UnspentTable -> m [BatchOp] unspentOps db t = map (uncurry f) <$> liftIO (H.toList t)   where     f p (Just u) =@@ -259,73 +268,80 @@     f p Nothing =       deleteOpCF (unspentCF db) (UnspentKey p) -getNetworkI :: MonadIO m => WriterT m Network-getNetworkI = getLayered (liftIO . readIORef . hNet) getNetwork--getBestBlockI :: MonadIO m => WriterT m (Maybe BlockHash)+getBestBlockI :: (MonadIO m) => WriterT m (Maybe BlockHash) getBestBlockI = getLayered getBestBlockH getBestBlock -getBlocksAtHeightI :: MonadIO m => BlockHeight -> WriterT m [BlockHash]+getBlocksAtHeightI :: (MonadIO m) => BlockHeight -> WriterT m [BlockHash] getBlocksAtHeightI bh =   getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh) -getBlockI :: MonadIO m => BlockHash -> WriterT m (Maybe BlockData)+getBlockI :: (MonadIO m) => BlockHash -> WriterT m (Maybe BlockData) getBlockI bh = getLayered (getBlockH bh) (getBlock bh) -getTxDataI :: MonadIO m => TxHash -> WriterT m (Maybe TxData)+getTxDataI :: (MonadIO m) => TxHash -> WriterT m (Maybe TxData) getTxDataI th = getLayered (getTxDataH th) (getTxData th) -getSpenderI :: MonadIO m => OutPoint -> WriterT m (Maybe Spender)+getSpenderI :: (MonadIO m) => OutPoint -> WriterT m (Maybe Spender) getSpenderI op = getLayered (getSpenderH op) (getSpender op) -getBalanceI :: MonadIO m => Address -> WriterT m (Maybe Balance)+getBalanceI :: (MonadIO m) => Address -> WriterT m (Maybe Balance) getBalanceI a = getLayered (getBalanceH a) (getBalance a) -getUnspentI :: MonadIO m => OutPoint -> WriterT m (Maybe Unspent)+getUnspentI :: (MonadIO m) => OutPoint -> WriterT m (Maybe Unspent) getUnspentI op = getLayered (getUnspentH op) (getUnspent op) -getMempoolI :: MonadIO m => WriterT m [(UnixTime, TxHash)]+getMempoolI :: (MonadIO m) => WriterT m [(UnixTime, TxHash)] getMempoolI =-  ReaderT $ \Writer {getState = s} ->-    liftIO $ map swap <$> H.toList (hMempool s)+  ReaderT $ \Writer {memory = Memory {..}} ->+    liftIO $ map swap <$> H.toList mempoolTable -newMemory :: MonadIO m => [(UnixTime, TxHash)] -> m Memory-newMemory mempool = do-  hNet <- newIORef Nothing-  hBest <- newIORef Nothing-  hBlock <- liftIO H.new-  hHeight <- liftIO H.new-  hTx <- liftIO H.new-  hUnspent <- liftIO H.new-  hBalance <- liftIO H.new-  hAddrTx <- liftIO H.new-  hAddrOut <- liftIO H.new-  hMempool <- liftIO $ H.fromList (map swap mempool)+newMemory ::+  (MonadIO m) =>+  Network ->+  Ctx ->+  [(UnixTime, TxHash)] ->+  m Memory+newMemory net ctx mempool = do+  best <- newIORef Nothing+  blockTable <- liftIO H.new+  heightTable <- liftIO H.new+  txTable <- liftIO H.new+  unspentTable <- liftIO H.new+  balanceTable <- liftIO H.new+  addressTable <- liftIO H.new+  outputTable <- liftIO H.new+  mempoolTable <- liftIO $ H.fromList (map swap mempool)   return Memory {..} +getNetworkH :: (Monad m) => Memory -> m Network+getNetworkH Memory {net} = return net++getCtxH :: (Monad m) => Memory -> m Ctx+getCtxH Memory {ctx} = return ctx+ getBestBlockH :: Memory -> IO (Maybe (Maybe BlockHash))-getBestBlockH = readIORef . hBest+getBestBlockH = readIORef . (.best)  getBlocksAtHeightH :: BlockHeight -> Memory -> IO (Maybe [BlockHash])-getBlocksAtHeightH h s = H.lookup (hHeight s) h+getBlocksAtHeightH h s = H.lookup s.heightTable h  getBlockH :: BlockHash -> Memory -> IO (Maybe (Maybe BlockData))-getBlockH h s = H.lookup (hBlock s) h+getBlockH h s = H.lookup s.blockTable h  getTxDataH :: TxHash -> Memory -> IO (Maybe (Maybe TxData))-getTxDataH t s = H.lookup (hTx s) t+getTxDataH t s = H.lookup s.txTable t  getSpenderH :: OutPoint -> Memory -> IO (Maybe (Maybe Spender)) getSpenderH op s = do-  fmap (join . fmap f) <$> getTxDataH (outPointHash op) s+  fmap (f =<<) <$> getTxDataH op.hash s   where-    f = IntMap.lookup (fromIntegral (outPointIndex op)) . txDataSpenders+    f = IntMap.lookup (fromIntegral op.index) . (.spenders)  getBalanceH :: Address -> Memory -> IO (Maybe (Maybe Balance))-getBalanceH a s = H.lookup (hBalance s) a+getBalanceH a s = H.lookup s.balanceTable a  getMempoolH :: Memory -> IO [(UnixTime, TxHash)]-getMempoolH s = sortOn Down . map swap <$> H.toList (hMempool s)+getMempoolH Memory {..} = sortOn Down . map swap <$> H.toList mempoolTable  getUnspentH :: OutPoint -> Memory -> IO (Maybe (Maybe Unspent))-getUnspentH p s = H.lookup (hUnspent s) p+getUnspentH p Memory {..} = H.lookup unspentTable p

@@ -1,10 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}  module Haskoin.Store.Logic   ( ImportException (..),@@ -54,6 +59,7 @@     BlockHash,     BlockHeader (..),     BlockNode (..),+    Ctx,     Network (..),     OutPoint (..),     Tx (..),@@ -74,19 +80,6 @@   ) import Haskoin.Store.Common import Haskoin.Store.Data-  ( Balance (..),-    BlockData (..),-    BlockRef (..),-    Prev (..),-    Spender (..),-    TxData (..),-    TxRef (..),-    UnixTime,-    Unspent (..),-    confirmed,-    isCoinbaseTx,-    txDataFee,-  ) import UnliftIO (Exception)  type MonadImport m =@@ -123,16 +116,17 @@   show DuplicatePrevOutput = "Duplicate previous output"   show TxSpent = "Transaction is spent" -initBest :: MonadImport m => m ()+initBest :: (MonadImport m) => m () initBest = do+  ctx <- getCtx   $(logDebugS) "BlockStore" "Initializing best block"   net <- getNetwork   m <- getBestBlock   when (isNothing m) . void $ do     $(logDebugS) "BlockStore" "Importing Genesis block"-    importBlock (genesisBlock net) (genesisNode net)+    importBlock (genesisBlock net ctx) (genesisNode net) -newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool+newMempoolTx :: (MonadImport m) => Tx -> UnixTime -> m Bool newMempoolTx tx w =   getActiveTxData (txHash tx) >>= \case     Just _ ->@@ -144,7 +138,7 @@       importTx (MemRef w) w rbf tx       return True -bestBlockData :: MonadImport m => m BlockData+bestBlockData :: (MonadImport m) => m BlockData bestBlockData = do   h <-     getBestBlock >>= \case@@ -158,11 +152,11 @@       throwError BestBlockNotFound     Just b -> return b -revertBlock :: MonadImport m => BlockHash -> m ()+revertBlock :: (MonadImport m) => BlockHash -> m () revertBlock bh = do   bd <-     bestBlockData >>= \b ->-      if headerHash (blockDataHeader b) == bh+      if headerHash b.header == bh         then return b         else do           $(logErrorS) "BlockStore" $@@ -170,49 +164,49 @@           throwError BlockNotBest   $(logDebugS) "BlockStore" $     "Obtained block data for " <> blockHashToHex bh-  tds <- mapM getImportTxData (blockDataTxs bd)+  tds <- mapM getImportTxData bd.txs   $(logDebugS) "BlockStore" $     "Obtained import tx data for block " <> blockHashToHex bh-  setBest (prevBlock (blockDataHeader bd))+  setBest bd.header.prev   $(logDebugS) "BlockStore" $     "Set parent as best block "-      <> blockHashToHex (prevBlock (blockDataHeader bd))-  insertBlock bd {blockDataMainChain = False}+      <> blockHashToHex bd.header.prev+  insertBlock bd {main = False}   $(logDebugS) "BlockStore" $     "Updated as not in main chain: " <> blockHashToHex bh   forM_ (tail tds) unConfirmTx   $(logDebugS) "BlockStore" $     "Unconfirmed " <> cs (show (length tds)) <> " transactions"-  deleteConfirmedTx (txHash (txData (head tds)))+  deleteConfirmedTx (txHash (head tds).tx)   $(logDebugS) "BlockStore" $-    "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds)))+    "Deleted coinbase: " <> txHashToHex (txHash (head tds).tx) -checkNewBlock :: MonadImport m => Block -> BlockNode -> m ()+checkNewBlock :: (MonadImport m) => Block -> BlockNode -> m () checkNewBlock b n =   getBestBlock >>= \case     Nothing       | isGenesis n -> return ()       | otherwise -> do-        $(logErrorS) "BlockStore" $-          "Cannot import non-genesis block: "-            <> blockHashToHex (headerHash (blockHeader b))-        throwError BestBlockNotFound+          $(logErrorS) "BlockStore" $+            "Cannot import non-genesis block: "+              <> blockHashToHex (headerHash b.header)+          throwError BestBlockNotFound     Just h-      | prevBlock (blockHeader b) == h -> return ()+      | b.header.prev == h -> return ()       | otherwise -> do-        $(logErrorS) "BlockStore" $-          "Block does not build on head: "-            <> blockHashToHex (headerHash (blockHeader b))-        throwError PrevBlockNotBest+          $(logErrorS) "BlockStore" $+            "Block does not build on head: "+              <> blockHashToHex (headerHash b.header)+          throwError PrevBlockNotBest -importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m [TxData]+importOrConfirm :: (MonadImport m) => BlockNode -> [Tx] -> m [TxData] importOrConfirm bn txns = do   mapM_ (freeOutputs True False . snd) (reverse txs)   mapM (uncurry action) txs   where     txs = sortTxs txns-    br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i}-    bn_time = fromIntegral . blockTimestamp $ nodeHeader bn+    br i = BlockRef {height = bn.height, position = i}+    bn_time = fromIntegral $ bn.header.timestamp     action i tx =       testPresent tx >>= \case         False -> import_it i tx@@ -234,57 +228,57 @@         "Importing tx: " <> txHashToHex (txHash tx)       importTx (br i) bn_time False tx -importBlock :: MonadImport m => Block -> BlockNode -> m (BlockData, [TxData])+importBlock :: (MonadImport m) => Block -> BlockNode -> m (BlockData, [TxData]) importBlock b n = do   $(logDebugS) "BlockStore" $     "Checking new block: "-      <> blockHashToHex (headerHash (nodeHeader n))+      <> blockHashToHex (headerHash n.header)   checkNewBlock b n   $(logDebugS) "BlockStore" "Passed check"   net <- getNetwork-  let subsidy = computeSubsidy net (nodeHeight n)-  bs <- getBlocksAtHeight (nodeHeight n)+  let subsidy = computeSubsidy net n.height+  bs <- getBlocksAtHeight n.height   $(logDebugS) "BlockStore" $     "Inserting block entries for: "-      <> blockHashToHex (headerHash (nodeHeader n))+      <> blockHashToHex (headerHash n.header)   setBlocksAtHeight-    (nub (headerHash (nodeHeader n) : bs))-    (nodeHeight n)-  setBest (headerHash (nodeHeader n))-  tds <- importOrConfirm n (blockTxns b)+    (nub (headerHash n.header : bs))+    n.height+  setBest (headerHash n.header)+  tds <- importOrConfirm n b.txs   let bd =         BlockData-          { blockDataHeight = nodeHeight n,-            blockDataMainChain = True,-            blockDataWork = nodeWork n,-            blockDataHeader = nodeHeader n,-            blockDataSize = fromIntegral (B.length (encode b)),-            blockDataTxs = map txHash (blockTxns b),-            blockDataWeight = if getSegWit net then w else 0,-            blockDataSubsidy = subsidy,-            blockDataFees = sum $ map txDataFee tds,-            blockDataOutputs = ts_out_val+          { height = n.height,+            main = True,+            work = n.work,+            header = n.header,+            size = fromIntegral (B.length (encode b)),+            txs = map txHash b.txs,+            weight = if net.segWit then w else 0,+            subsidy = subsidy,+            fee = sum $ map txDataFee tds,+            outputs = ts_out_val           }   insertBlock bd   $(logDebugS) "BlockStore" $     "Finished importing block: "-      <> blockHashToHex (headerHash (nodeHeader n))+      <> blockHashToHex (headerHash n.header)   return (bd, tds)   where     cb_out_val =-      sum $ map outValue $ txOut $ head $ blockTxns b+      sum $ map (.value) $ (head b.txs).outputs     ts_out_val =-      sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b+      sum $ map (sum . map (.value) . (.outputs)) $ tail $ b.txs     w =-      let f t = t {txWitness = []}-          b' = b {blockTxns = map f (blockTxns b)}+      let f t = (t :: Tx) {witness = []}+          b' = (b :: Block) {txs = map f b.txs}           x = B.length (encode b)           s = B.length (encode b')        in fromIntegral $ s * 3 + x -checkNewTx :: MonadImport m => Tx -> m ()+checkNewTx :: (MonadImport m) => Tx -> m () checkNewTx tx = do-  when (unique_inputs < length (txIn tx)) $ do+  when (unique_inputs < length tx.inputs) $ do     $(logErrorS) "BlockStore" $       "Transaction spends same output twice: "         <> txHashToHex (txHash tx)@@ -308,30 +302,30 @@       "Insufficient funds for tx: " <> txHashToHex (txHash tx)     throwError InsufficientFunds   where-    unspents = sum . map unspentAmount . catMaybes-    outputs = sum (map outValue (txOut tx))-    unique_inputs = length (nub' (map prevOutput (txIn tx)))+    unspents = sum . map (.value) . catMaybes+    outputs = sum (map (.value) tx.outputs)+    unique_inputs = length (nub' (map (.outpoint) tx.inputs)) -getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent]+getUnspentOutputs :: (StoreReadBase m) => Tx -> m [Maybe Unspent] getUnspentOutputs tx = mapM getUnspent (prevOuts tx)  prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData prepareTxData rbf br tt tx us =   TxData-    { txDataBlock = br,-      txData = tx,-      txDataPrevs = ps,-      txDataDeleted = False,-      txDataRBF = rbf,-      txDataTime = tt,-      txDataSpenders = I.empty+    { block = br,+      tx = tx,+      prevs = ps,+      deleted = False,+      rbf = rbf,+      timestamp = tt,+      spenders = I.empty     }   where-    mkprv u = Prev (unspentScript u) (unspentAmount u)+    mkprv Unspent {..} = Prev script value     ps = I.fromList $ zip [0 ..] $ map mkprv us  importTx ::-  MonadImport m =>+  (MonadImport m) =>   BlockRef ->   -- | unix time   Word64 ->@@ -352,94 +346,98 @@   commitAddTx td   return td -unConfirmTx :: MonadImport m => TxData -> m TxData+unConfirmTx :: (MonadImport m) => TxData -> m TxData unConfirmTx t = confTx t Nothing -confirmTx :: MonadImport m => TxData -> BlockRef -> m TxData+confirmTx :: (MonadImport m) => TxData -> BlockRef -> m TxData confirmTx t br = confTx t (Just br) -replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m ()-replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do-  deleteAddrTx-    a-    TxRef-      { txRefBlock = txDataBlock t,-        txRefHash = txHash (txData t)-      }-  insertAddrTx-    a-    TxRef-      { txRefBlock = new,-        txRefHash = txHash (txData t)-      }+replaceAddressTx :: (MonadImport m) => TxData -> BlockRef -> m ()+replaceAddressTx t new = do+  ctx <- getCtx+  forM_ (txDataAddresses ctx t) $ \a -> do+    deleteAddrTx+      a+      TxRef+        { block = t.block,+          txid = txHash t.tx+        }+    insertAddrTx+      a+      TxRef+        { block = new,+          txid = txHash t.tx+        }  adjustAddressOutput ::-  MonadImport m =>+  (MonadImport m) =>   OutPoint ->   TxOut ->   BlockRef ->   BlockRef ->   m () adjustAddressOutput op o old new = do-  let pk = scriptOutput o+  let pk = o.script   getUnspent op >>= \case     Nothing -> return ()     Just u -> do-      unless (unspentBlock u == old) $-        error $ "Existing unspent block bad for output: " <> show op+      unless (u.block == old) $+        error $+          "Existing unspent block bad for output: " <> show op       replace_unspent pk   where     replace_unspent pk = do-      let ma = eitherToMaybe (scriptToAddressBS pk)+      ctx <- getCtx+      let ma = eitherToMaybe (scriptToAddressBS ctx pk)       deleteUnspent op       insertUnspent         Unspent-          { unspentBlock = new,-            unspentPoint = op,-            unspentAmount = outValue o,-            unspentScript = pk,-            unspentAddress = ma+          { block = new,+            outpoint = op,+            value = o.value,+            script = pk,+            address = ma           }       forM_ ma $ replace_addr_unspent pk     replace_addr_unspent pk a = do       deleteAddrUnspent         a         Unspent-          { unspentBlock = old,-            unspentPoint = op,-            unspentAmount = outValue o,-            unspentScript = pk,-            unspentAddress = Just a+          { block = old,+            outpoint = op,+            value = o.value,+            script = pk,+            address = Just a           }       insertAddrUnspent         a         Unspent-          { unspentBlock = new,-            unspentPoint = op,-            unspentAmount = outValue o,-            unspentScript = pk,-            unspentAddress = Just a+          { block = new,+            outpoint = op,+            value = o.value,+            script = pk,+            address = Just a           }-      decreaseBalance (confirmed old) a (outValue o)-      increaseBalance (confirmed new) a (outValue o)+      decreaseBalance (confirmed old) a o.value+      increaseBalance (confirmed new) a o.value -confTx :: MonadImport m => TxData -> Maybe BlockRef -> m TxData+confTx :: (MonadImport m) => TxData -> Maybe BlockRef -> m TxData confTx t mbr = do   replaceAddressTx t new-  forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do-    let op = OutPoint (txHash (txData t)) n+  forM_ (zip [0 ..] t.tx.outputs) $ \(n, o) -> do+    let op = OutPoint (txHash t.tx) n     adjustAddressOutput op o old new-  rbf <- isRBF new (txData t)-  let td = t {txDataBlock = new, txDataRBF = rbf}+  rbf <- isRBF new t.tx+  let td = (t :: TxData) {block = new, rbf = rbf}   insertTx td   updateMempool td   return td   where-    new = fromMaybe (MemRef (txDataTime t)) mbr-    old = txDataBlock t+    new = fromMaybe (MemRef t.timestamp) mbr+    old = t.block  freeOutputs ::-  MonadImport m =>+  (MonadImport m) =>   -- | only delete transaction if unconfirmed   Bool ->   -- | only delete RBF@@ -451,13 +449,13 @@   unspents <- mapM getUnspent prevs   let spents = [p | (p, Nothing) <- zip prevs unspents]   spndrs <- catMaybes <$> mapM getSpender spents-  let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs+  let txids = HashSet.fromList $ filter (/= txHash tx) $ map (.txid) spndrs   mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids -deleteConfirmedTx :: MonadImport m => TxHash -> m ()+deleteConfirmedTx :: (MonadImport m) => TxHash -> m () deleteConfirmedTx = deleteTx False False -deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m ()+deleteUnconfirmedTx :: (MonadImport m) => Bool -> TxHash -> m () deleteUnconfirmedTx rbfcheck th =   getActiveTxData th >>= \case     Just _ -> deleteTx True rbfcheck th@@ -466,7 +464,7 @@         "Not found or already deleted: " <> txHashToHex th  deleteTx ::-  MonadImport m =>+  (MonadImport m) =>   -- | only delete transaction if unconfirmed   Bool ->   -- | only delete RBF@@ -476,7 +474,8 @@ deleteTx memonly rbfcheck th = do   chain <- getChain memonly rbfcheck th   $(logDebugS) "BlockStore" $-    "Deleting " <> cs (show (length chain))+    "Deleting "+      <> cs (show (length chain))       <> " txs from chain leading to "       <> txHashToHex th   mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain@@ -502,34 +501,34 @@             "Transaction not found: " <> txHashToHex th           return Nothing         Just td-          | memonly && confirmed (txDataBlock td) -> do-            $(logErrorS) "BlockStore" $-              "Transaction already confirmed: "-                <> txHashToHex th-            throwError TxConfirmed+          | memonly && confirmed td.block -> do+              $(logErrorS) "BlockStore" $+                "Transaction already confirmed: "+                  <> txHashToHex th+              throwError TxConfirmed           | rbfcheck ->-            isRBF (txDataBlock td) (txData td) >>= \case-              True -> return $ Just td-              False -> do-                $(logErrorS) "BlockStore" $-                  "Double-spending transaction: "-                    <> txHashToHex th-                throwError DoubleSpend+              isRBF td.block td.tx >>= \case+                True -> return $ Just td+                False -> do+                  $(logErrorS) "BlockStore" $+                    "Double-spending transaction: "+                      <> txHashToHex th+                  throwError DoubleSpend           | otherwise -> return $ Just td     go txs pdg = do       tds <- catMaybes <$> mapM get_tx (HashSet.toList pdg)-      let txsn = HashSet.fromList $ fmap txData tds+      let txsn = HashSet.fromList $ fmap (.tx) tds           pdgn =             HashSet.fromList-              . concatMap (map spenderHash . I.elems)-              $ fmap txDataSpenders tds+              . concatMap (map (.txid) . I.elems)+              $ fmap (.spenders) tds           txs' = txsn <> txs           pdg' = pdgn `HashSet.difference` HashSet.map txHash txs'       if HashSet.null pdg'         then return $ HashSet.toList txs'         else go txs' pdg' -deleteSingleTx :: MonadImport m => TxHash -> m ()+deleteSingleTx :: (MonadImport m) => TxHash -> m () deleteSingleTx th =   getActiveTxData th >>= \case     Nothing -> do@@ -537,7 +536,7 @@         "Already deleted: " <> txHashToHex th       throwError TxNotFound     Just td ->-      if I.null (txDataSpenders td)+      if I.null td.spenders         then do           $(logDebugS) "BlockStore" $             "Deleting tx: " <> txHashToHex th@@ -548,31 +547,32 @@               <> txHashToHex th           throwError TxSpent -commitDelTx :: MonadImport m => TxData -> m ()+commitDelTx :: (MonadImport m) => TxData -> m () commitDelTx = commitModTx False -commitAddTx :: MonadImport m => TxData -> m ()+commitAddTx :: (MonadImport m) => TxData -> m () commitAddTx = commitModTx True -commitModTx :: MonadImport m => Bool -> TxData -> m ()+commitModTx :: (MonadImport m) => Bool -> TxData -> m () commitModTx add tx_data = do-  mapM_ mod_addr_tx (txDataAddresses td)+  ctx <- getCtx+  mapM_ mod_addr_tx (txDataAddresses ctx td)   mod_outputs   mod_unspent   insertTx td   updateMempool td   where-    tx = txData td-    br = txDataBlock td-    td = tx_data {txDataDeleted = not add}+    tx = td.tx+    br = td.block+    td = (tx_data :: TxData) {deleted = not add}     tx_ref = TxRef br (txHash tx)     mod_addr_tx a       | add = do-        insertAddrTx a tx_ref-        modAddressCount add a+          insertAddrTx a tx_ref+          modAddressCount add a       | otherwise = do-        deleteAddrTx a tx_ref-        modAddressCount add a+          deleteAddrTx a tx_ref+          modAddressCount add a     mod_unspent       | add = spendOutputs tx       | otherwise = unspendOutputs tx@@ -580,90 +580,97 @@       | add = addOutputs br tx       | otherwise = delOutputs br tx -updateMempool :: MonadImport m => TxData -> m ()-updateMempool td@TxData {txDataDeleted = True} =-  deleteFromMempool (txHash (txData td))-updateMempool td@TxData {txDataBlock = MemRef t} =-  addToMempool (txHash (txData td)) t-updateMempool td@TxData {txDataBlock = BlockRef {}} =-  deleteFromMempool (txHash (txData td))+updateMempool :: (MonadImport m) => TxData -> m ()+updateMempool td@TxData {deleted = True} =+  deleteFromMempool (txHash td.tx)+updateMempool td@TxData {block = MemRef t} =+  addToMempool (txHash td.tx) t+updateMempool td@TxData {block = BlockRef {}} =+  deleteFromMempool (txHash td.tx) -spendOutputs :: MonadImport m => Tx -> m ()+spendOutputs :: (MonadImport m) => Tx -> m () spendOutputs tx =   zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx) -addOutputs :: MonadImport m => BlockRef -> Tx -> m ()+addOutputs :: (MonadImport m) => BlockRef -> Tx -> m () addOutputs br tx =-  zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx)+  zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] tx.outputs  isRBF ::-  StoreReadBase m =>+  (StoreReadBase m) =>   BlockRef ->   Tx ->   m Bool isRBF br tx   | confirmed br = return False   | otherwise =-    getNetwork >>= \net ->-      if getReplaceByFee net-        then go-        else return False+      getNetwork >>= \net ->+        if net.replaceByFee+          then go+          else return False   where     go-      | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True+      | any ((< 0xffffffff - 1) . (.sequence)) tx.inputs = return True       | otherwise = carry_on     carry_on =-      let hs = nub' $ map (outPointHash . prevOutput) (txIn tx)+      let hs = nub' $ map (.outpoint.hash) tx.inputs           ck [] = return False           ck (h : hs') =             getActiveTxData h >>= \case               Nothing -> return False               Just t-                | confirmed (txDataBlock t) -> ck hs'-                | txDataRBF t -> return True+                | confirmed t.block -> ck hs'+                | t.rbf -> return True                 | otherwise -> ck hs'        in ck hs -addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()+addOutput :: (MonadImport m) => BlockRef -> OutPoint -> TxOut -> m () addOutput = modOutput True -delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()+delOutput :: (MonadImport m) => BlockRef -> OutPoint -> TxOut -> m () delOutput = modOutput False -modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m ()+modOutput ::+  (MonadImport m) =>+  Bool ->+  BlockRef ->+  OutPoint ->+  TxOut ->+  m () modOutput add br op o = do-  mod_unspent-  forM_ ma $ \a -> do-    mod_addr_unspent a u-    modBalance (confirmed br) add a (outValue o)+  ctx <- getCtx+  mod_unspent ctx+  forM_ (ma ctx) $ \a -> do+    mod_addr_unspent a (u ctx)+    modBalance (confirmed br) add a o.value     modifyReceived a v   where     v-      | add = (+ outValue o)-      | otherwise = subtract (outValue o)-    ma = eitherToMaybe (scriptToAddressBS (scriptOutput o))-    u =+      | add = (+ o.value)+      | otherwise = subtract o.value+    ma ctx = eitherToMaybe (scriptToAddressBS ctx o.script)+    u ctx =       Unspent-        { unspentScript = scriptOutput o,-          unspentBlock = br,-          unspentPoint = op,-          unspentAmount = outValue o,-          unspentAddress = ma+        { script = o.script,+          block = br,+          outpoint = op,+          value = o.value,+          address = ma ctx         }-    mod_unspent-      | add = insertUnspent u+    mod_unspent ctx+      | add = insertUnspent (u ctx)       | otherwise = deleteUnspent op     mod_addr_unspent       | add = insertAddrUnspent       | otherwise = deleteAddrUnspent -delOutputs :: MonadImport m => BlockRef -> Tx -> m ()+delOutputs :: (MonadImport m) => BlockRef -> Tx -> m () delOutputs br tx =-  forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do+  forM_ (zip [0 ..] tx.outputs) $ \(i, o) -> do     let op = OutPoint (txHash tx) i     delOutput br op o -getImportTxData :: MonadImport m => TxHash -> m TxData+getImportTxData :: (MonadImport m) => TxHash -> m TxData getImportTxData th =   getActiveTxData th >>= \case     Nothing -> do@@ -673,26 +680,26 @@  getTxOut :: Word32 -> Tx -> Maybe TxOut getTxOut i tx = do-  guard (fromIntegral i < length (txOut tx))-  return $ txOut tx !! fromIntegral i+  guard (fromIntegral i < length tx.outputs)+  return $ tx.outputs !! fromIntegral i -insertSpender :: MonadImport m => OutPoint -> Spender -> m ()+insertSpender :: (MonadImport m) => OutPoint -> Spender -> m () insertSpender op s = do-  td <- getImportTxData (outPointHash op)-  let p = txDataSpenders td-      p' = I.insert (fromIntegral (outPointIndex op)) s p-      td' = td {txDataSpenders = p'}+  td <- getImportTxData op.hash+  let p = td.spenders+      p' = I.insert (fromIntegral op.index) s p+      td' = (td :: TxData) {spenders = p'}   insertTx td' -deleteSpender :: MonadImport m => OutPoint -> m ()+deleteSpender :: (MonadImport m) => OutPoint -> m () deleteSpender op = do-  td <- getImportTxData (outPointHash op)-  let p = txDataSpenders td-      p' = I.delete (fromIntegral (outPointIndex op)) p-      td' = td {txDataSpenders = p'}+  td <- getImportTxData op.hash+  let p = td.spenders+      p' = I.delete (fromIntegral op.index) p+      td' = (td :: TxData) {spenders = p'}   insertTx td' -spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m ()+spendOutput :: (MonadImport m) => TxHash -> Word32 -> OutPoint -> m () spendOutput th ix op = do   u <-     getUnspent op >>= \case@@ -700,55 +707,54 @@       Nothing -> error $ "Could not find UTXO to spend: " <> show op   deleteUnspent op   insertSpender op (Spender th ix)-  let pk = unspentScript u-  forM_ (scriptToAddressBS pk) $ \a -> do-    decreaseBalance-      (confirmed (unspentBlock u))-      a-      (unspentAmount u)+  let pk = u.script+  ctx <- getCtx+  forM_ (scriptToAddressBS ctx pk) $ \a -> do+    decreaseBalance (confirmed u.block) a u.value     deleteAddrUnspent a u -unspendOutputs :: MonadImport m => Tx -> m ()+unspendOutputs :: (MonadImport m) => Tx -> m () unspendOutputs = mapM_ unspendOutput . prevOuts -unspendOutput :: MonadImport m => OutPoint -> m ()+unspendOutput :: (MonadImport m) => OutPoint -> m () unspendOutput op = do+  ctx <- getCtx   t <--    getActiveTxData (outPointHash op) >>= \case-      Nothing -> error $ "Could not find tx data: " <> show (outPointHash op)+    getActiveTxData op.hash >>= \case+      Nothing -> error $ "Could not find tx data: " <> show op.hash       Just t -> return t   let o =         fromMaybe           (error ("Could not find output: " <> show op))-          (getTxOut (outPointIndex op) (txData t))-      m = eitherToMaybe (scriptToAddressBS (scriptOutput o))+          (getTxOut op.index t.tx)+      m = eitherToMaybe (scriptToAddressBS ctx o.script)       u =         Unspent-          { unspentAmount = outValue o,-            unspentBlock = txDataBlock t,-            unspentScript = scriptOutput o,-            unspentPoint = op,-            unspentAddress = m+          { value = o.value,+            block = t.block,+            script = o.script,+            outpoint = op,+            address = m           }   deleteSpender op   insertUnspent u   forM_ m $ \a -> do     insertAddrUnspent a u-    increaseBalance (confirmed (unspentBlock u)) a (outValue o)+    increaseBalance (confirmed u.block) a o.value -modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m ()+modifyReceived :: (MonadImport m) => Address -> (Word64 -> Word64) -> m () modifyReceived a f = do   b <- getDefaultBalance a-  setBalance b {balanceTotalReceived = f (balanceTotalReceived b)}+  setBalance b {received = f b.received} -decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()+decreaseBalance :: (MonadImport m) => Bool -> Address -> Word64 -> m () decreaseBalance conf = modBalance conf False -increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()+increaseBalance :: (MonadImport m) => Bool -> Address -> Word64 -> m () increaseBalance conf = modBalance conf True  modBalance ::-  MonadImport m =>+  (MonadImport m) =>   -- | confirmed   Bool ->   -- | add@@ -760,38 +766,38 @@   b <- getDefaultBalance a   setBalance $ (g . f) b   where-    g b = b {balanceUnspentCount = m 1 (balanceUnspentCount b)}+    g b = (b :: Balance) {utxo = m 1 b.utxo}     f b-      | conf = b {balanceAmount = m val (balanceAmount b)}-      | otherwise = b {balanceZero = m val (balanceZero b)}+      | conf = (b :: Balance) {confirmed = m val b.confirmed}+      | otherwise = (b :: Balance) {unconfirmed = m val b.unconfirmed}     m       | add = (+)       | otherwise = subtract -modAddressCount :: MonadImport m => Bool -> Address -> m ()+modAddressCount :: (MonadImport m) => Bool -> Address -> m () modAddressCount add a = do   b <- getDefaultBalance a-  setBalance b {balanceTxCount = f (balanceTxCount b)}+  setBalance b {txs = f b.txs}   where     f       | add = (+ 1)       | otherwise = subtract 1 -txOutAddrs :: [TxOut] -> [Address]-txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput)+txOutAddrs :: Ctx -> [TxOut] -> [Address]+txOutAddrs ctx = nub' . rights . map (scriptToAddressBS ctx . (.script)) -txInAddrs :: [Prev] -> [Address]-txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript)+txInAddrs :: Ctx -> [Prev] -> [Address]+txInAddrs ctx = nub' . rights . map (scriptToAddressBS ctx . (.script)) -txDataAddresses :: TxData -> [Address]-txDataAddresses t =-  nub' $ txInAddrs prevs <> txOutAddrs outs+txDataAddresses :: Ctx -> TxData -> [Address]+txDataAddresses ctx t =+  nub' $ txInAddrs ctx prevs <> txOutAddrs ctx outs   where-    prevs = I.elems (txDataPrevs t)-    outs = txOut (txData t)+    prevs = I.elems t.prevs+    outs = t.tx.outputs  prevOuts :: Tx -> [OutPoint]-prevOuts tx = filter (/= nullOutPoint) (map prevOutput (txIn tx))+prevOuts tx = filter (/= nullOutPoint) (map (.outpoint) tx.inputs) -testPresent :: StoreReadBase m => Tx -> m Bool+testPresent :: (StoreReadBase m) => Tx -> m Bool testPresent tx = isJust <$> getActiveTxData (txHash tx)