diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 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 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -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 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -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 diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -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) diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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) diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} module Haskoin.Store.Manager ( StoreConfig (..), @@ -9,6 +13,14 @@ where import Control.Monad (forever, unless, when) +import Control.Monad.Cont + ( ContT (..), + MonadCont (callCC), + cont, + lift, + runCont, + runContT, + ) import Control.Monad.Logger (MonadLoggerIO) import Control.Monad.Reader (ReaderT (ReaderT), runReaderT) import Data.Serialize (decode) @@ -16,6 +28,7 @@ import Data.Word (Word32) import Haskoin ( BlockHash (..), + Ctx, Inv (..), InvType (..), InvVector (..), @@ -37,7 +50,7 @@ NodeConfig (..), NodeEvent (..), PeerEvent (..), - PeerManager, + PeerMgr, WithConnection, withNode, ) @@ -96,53 +109,56 @@ -- | Store mailboxes. data Store = Store - { storeManager :: !PeerManager, - storeChain :: !Chain, - storeBlock :: !BlockStore, - storeDB :: !DatabaseReader, - storeCache :: !(Maybe CacheConfig), - storePublisher :: !(Publisher StoreEvent), - storeNetwork :: !Network + { peerMgr :: !PeerMgr, + chain :: !Chain, + block :: !BlockStore, + db :: !DatabaseReader, + cache :: !(Maybe CacheConfig), + pub :: !(Publisher StoreEvent), + net :: !Network, + ctx :: !Ctx } -- | Configuration for a 'Store'. data StoreConfig = StoreConfig { -- | max peers to connect to - storeConfMaxPeers :: !Int, + maxPeers :: !Int, -- | static set of peers to connect to - storeConfInitPeers :: ![String], + initPeers :: ![String], -- | discover new peers - storeConfDiscover :: !Bool, + discover :: !Bool, -- | RocksDB database path - storeConfDB :: !FilePath, + db :: !FilePath, -- | network constants - storeConfNetwork :: !Network, + net :: !Network, -- | Redis cache configuration - storeConfCache :: !(Maybe String), + redis :: !(Maybe String), + -- | Secp256k1 context + ctx :: !Ctx, -- | gap on extended public key with no transactions - storeConfInitialGap :: !Word32, + initGap :: !Word32, -- | gap for extended public keys - storeConfGap :: !Word32, + gap :: !Word32, -- | cache xpubs with more than this many used addresses - storeConfCacheMin :: !Int, + redisMinAddrs :: !Int, -- | maximum number of keys in Redis cache - storeConfMaxKeys :: !Integer, + redisMaxKeys :: !Integer, -- | do not index new mempool transactions - storeConfNoMempool :: !Bool, + noMempool :: !Bool, -- | wipe mempool when starting - storeConfWipeMempool :: !Bool, + wipeMempool :: !Bool, -- | sync mempool from peers - storeConfSyncMempool :: !Bool, + syncMempool :: !Bool, -- | disconnect peer if message not received for this many seconds - storeConfPeerTimeout :: !NominalDiffTime, + peerTimeout :: !NominalDiffTime, -- | disconnect peer if it has been connected this long - storeConfPeerMaxLife :: !NominalDiffTime, + maxPeerLife :: !NominalDiffTime, -- | connect to peers using the function 'withConnection' - storeConfConnect :: !(SockAddr -> WithConnection), + connect :: !(SockAddr -> WithConnection), -- | stats store - storeConfStats :: !(Maybe Metrics.Store), + statsStore :: !(Maybe Metrics.Store), -- | sync mempool against cache every this many seconds - storeConfCacheMempoolSync :: !Int + redisSyncInterval :: !Int } withStore :: @@ -152,34 +168,41 @@ m a withStore cfg action = connectDB cfg $ - ReaderT $ \db -> - withPublisher $ \pub -> - withPublisher $ \node_pub -> - withSubscription node_pub $ \node_sub -> - withNode (nodeCfg cfg db node_pub) $ \node -> - withCache cfg (nodeChain node) db pub $ \mcache -> - withBlockStore (blockStoreCfg cfg node pub db) $ \b -> - withAsync (nodeForwarder b pub node_sub) $ \a1 -> - link a1 - >> action - Store - { storeManager = nodeManager node, - storeChain = nodeChain node, - storeBlock = b, - storeDB = db, - storeCache = mcache, - storePublisher = pub, - storeNetwork = storeConfNetwork cfg - } + ReaderT $ \db -> flip runContT return $ do + pub <- ContT withPublisher + node_pub <- ContT withPublisher + node_sub <- ContT $ withSubscription node_pub + node <- ContT $ withNode $ nodeCfg cfg db node_pub + cache_cfg <- ContT $ withCache cfg node.chain db pub + block_store <- ContT $ withBlockStore $ blockStoreCfg cfg node pub db + fwd <- ContT $ withAsync $ nodeForwarder block_store pub node_sub + link fwd + lift $ + action + Store + { peerMgr = node.peerMgr, + chain = node.chain, + block = block_store, + db = db, + cache = cache_cfg, + pub = pub, + net = cfg.net, + ctx = cfg.ctx + } -connectDB :: MonadUnliftIO m => StoreConfig -> DatabaseReaderT m a -> m a +connectDB :: + (MonadUnliftIO m) => + StoreConfig -> + DatabaseReaderT m a -> + m a connectDB cfg f = do - stats <- mapM createDataMetrics (storeConfStats cfg) + stats <- mapM createDataMetrics cfg.statsStore withDatabaseReader - (storeConfNetwork cfg) - (storeConfInitialGap cfg) - (storeConfGap cfg) - (storeConfDB cfg) + cfg.net + cfg.ctx + cfg.initGap + cfg.gap + cfg.db stats f @@ -191,16 +214,17 @@ BlockStoreConfig blockStoreCfg cfg node pub db = BlockStoreConfig - { blockConfChain = nodeChain node, - blockConfManager = nodeManager node, - blockConfListener = pub, - blockConfDB = db, - blockConfNet = storeConfNetwork cfg, - blockConfNoMempool = storeConfNoMempool cfg, - blockConfWipeMempool = storeConfWipeMempool cfg, - blockConfSyncMempool = storeConfSyncMempool cfg, - blockConfPeerTimeout = storeConfPeerTimeout cfg, - blockConfStats = storeConfStats cfg + { chain = node.chain, + peerMgr = node.peerMgr, + pub = pub, + db = db, + net = cfg.net, + ctx = cfg.ctx, + noMempool = cfg.noMempool, + wipeMempool = cfg.wipeMempool, + syncMempool = cfg.syncMempool, + peerTimeout = cfg.peerTimeout, + statsStore = cfg.statsStore } nodeCfg :: @@ -210,20 +234,20 @@ NodeConfig nodeCfg cfg db pub = NodeConfig - { nodeConfMaxPeers = storeConfMaxPeers cfg, - nodeConfDB = databaseHandle db, - nodeConfColumnFamily = Nothing, - nodeConfPeers = storeConfInitPeers cfg, - nodeConfDiscover = storeConfDiscover cfg, - nodeConfEvents = pub, - nodeConfNetAddr = + { maxPeers = cfg.maxPeers, + db = db.db, + cf = Nothing, + peers = cfg.initPeers, + discover = cfg.discover, + pub = pub, + address = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)), - nodeConfNet = storeConfNetwork cfg, - nodeConfTimeout = storeConfPeerTimeout cfg, - nodeConfPeerMaxLife = storeConfPeerMaxLife cfg, - nodeConfConnect = storeConfConnect cfg + net = cfg.net, + timeout = cfg.peerTimeout, + maxPeerLife = cfg.maxPeerLife, + connect = cfg.connect } withCache :: @@ -235,31 +259,33 @@ (Maybe CacheConfig -> m a) -> m a withCache cfg chain db pub action = - case storeConfCache cfg of + case cfg.redis of Nothing -> action Nothing - Just redisurl -> - mapM newCacheMetrics (storeConfStats cfg) >>= \metrics -> - connectRedis redisurl >>= \conn -> - withSubscription pub $ \evts -> - let conf = c conn metrics - in withProcess (f conf) $ \p -> - cacheWriterProcesses interval evts (getProcessMailbox p) $ do - action (Just conf) + Just redisurl -> do + metrics <- mapM newCacheMetrics cfg.statsStore + conn <- connectRedis redisurl + withSubscription pub $ \evts -> + let conf = c conn metrics + in withProcess (f conf) $ \p -> + cacheWriterProcesses + cfg.redisSyncInterval + evts + (getProcessMailbox p) + $ action (Just conf) where - interval = storeConfCacheMempoolSync cfg f conf cwinbox = runReaderT (cacheWriter conf cwinbox) db c conn metrics = CacheConfig - { cacheConn = conn, - cacheMin = storeConfCacheMin cfg, - cacheChain = chain, - cacheMax = storeConfMaxKeys cfg, - cacheMetrics = metrics + { redis = conn, + minAddrs = cfg.redisMinAddrs, + chain = chain, + maxKeys = cfg.redisMaxKeys, + metrics = metrics } cacheWriterProcesses :: - MonadUnliftIO m => + (MonadUnliftIO m) => Int -> Inbox StoreEvent -> CacheWriter -> @@ -268,7 +294,7 @@ cacheWriterProcesses interval evts cwm action = withAsync (cacheWriterEvents interval evts cwm) $ \a1 -> link a1 >> action -cacheWriterEvents :: MonadUnliftIO m => Int -> Inbox StoreEvent -> CacheWriter -> m () +cacheWriterEvents :: (MonadUnliftIO m) => Int -> Inbox StoreEvent -> CacheWriter -> m () cacheWriterEvents interval evts cwm = withAsync mempool . const $ forever $ @@ -279,14 +305,14 @@ threadDelay (interval * 1000 * 1000) cacheSyncMempool cwm -cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m () +cacheWriterDispatch :: (MonadIO m) => StoreEvent -> CacheWriter -> m () cacheWriterDispatch (StoreBestBlock _) = cacheNewBlock cacheWriterDispatch (StoreMempoolNew t) = cacheNewTx t cacheWriterDispatch (StoreMempoolDelete t) = cacheNewTx t cacheWriterDispatch _ = const (return ()) nodeForwarder :: - MonadIO m => + (MonadIO m) => BlockStore -> Publisher StoreEvent -> Inbox NodeEvent -> @@ -300,44 +326,49 @@ Publisher StoreEvent -> NodeEvent -> STM () -storeDispatch b pub (PeerEvent (PeerConnected p)) = do - publishSTM (StorePeerConnected p) pub - blockStorePeerConnectSTM p b -storeDispatch b pub (PeerEvent (PeerDisconnected p)) = do - publishSTM (StorePeerDisconnected p) pub - blockStorePeerDisconnectSTM p b +storeDispatch b pub (PeerEvent pe) = + case pe of + PeerConnected p -> do + publishSTM (StorePeerConnected p) pub + blockStorePeerConnectSTM p b + PeerDisconnected p -> do + publishSTM (StorePeerDisconnected p) pub + blockStorePeerDisconnectSTM p b + PeerMessage p msg -> + case msg of + MPong (Pong n) -> + publishSTM (StorePeerPong p n) pub + MBlock block -> + blockStoreBlockSTM p block b + MTx tx -> + blockStoreTxSTM p tx b + MNotFound (NotFound is) -> do + let blocks = + [ BlockHash h + | InvVector t h <- is, + t == InvBlock || t == InvWitnessBlock + ] + unless (null blocks) $ blockStoreNotFoundSTM p blocks b + MInv (Inv is) -> do + let txs = + [ TxHash h + | InvVector t h <- is, + t == InvTx || t == InvWitnessTx + ] + publishSTM (StoreTxAnnounce p txs) pub + unless (null txs) $ blockStoreTxHashSTM p txs b + MReject Reject {message = MCTx, extra, code, reason} -> + case decode extra of + Left _ -> return () + Right th -> + let reject = + StoreTxReject + p + th + code + reason.get + in publishSTM reject pub + _ -> return () storeDispatch b _ (ChainEvent (ChainBestBlock bn)) = blockStoreHeadSTM bn b -storeDispatch _ _ (ChainEvent _) = - return () -storeDispatch _ pub (PeerMessage p (MPong (Pong n))) = - publishSTM (StorePeerPong p n) pub -storeDispatch b _ (PeerMessage p (MBlock block)) = - blockStoreBlockSTM p block b -storeDispatch b _ (PeerMessage p (MTx tx)) = - blockStoreTxSTM p tx b -storeDispatch b _ (PeerMessage p (MNotFound (NotFound is))) = do - let blocks = - [ BlockHash h - | InvVector t h <- is, - t == InvBlock || t == InvWitnessBlock - ] - unless (null blocks) $ blockStoreNotFoundSTM p blocks b -storeDispatch b pub (PeerMessage p (MInv (Inv is))) = do - let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx] - publishSTM (StoreTxAnnounce p txs) pub - unless (null txs) $ blockStoreTxHashSTM p txs b -storeDispatch _ pub (PeerMessage p (MReject r)) = - when (rejectMessage r == MCTx) $ - case decode (rejectData r) of - Left _ -> return () - Right th -> - let reject = - StoreTxReject - p - th - (rejectCode r) - (getVarString (rejectReason r)) - in publishSTM reject pub -storeDispatch _ _ _ = - return () +storeDispatch _ _ (ChainEvent _) = return () diff --git a/src/Haskoin/Store/Stats.hs b/src/Haskoin/Store/Stats.hs --- a/src/Haskoin/Store/Stats.hs +++ b/src/Haskoin/Store/Stats.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} module Haskoin.Store.Stats ( StatDist, @@ -18,13 +22,13 @@ flushTQueue, writeTQueue, ) -import qualified Control.Foldl as L +import Control.Foldl qualified as L import Control.Monad (forever) import Data.Function (on) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict qualified as HashMap import Data.Int (Int64) -import Data.List (sort, sortBy) +import Data.List (sort, sortBy, sortOn) import Data.Maybe (fromMaybe) import Data.Ord (Down (..), comparing) import Data.String.Conversions (cs) @@ -58,7 +62,7 @@ ) import UnliftIO.Concurrent (threadDelay) -withStats :: MonadIO m => Text -> Int -> Text -> (Store -> m a) -> m a +withStats :: (MonadIO m) => Text -> Int -> Text -> (Store -> m a) -> m a withStats h p pfx go = do store <- liftIO newStore _statsd <- @@ -74,62 +78,62 @@ go store data StatData = StatData - { statTimes :: ![Int64], - statQueries :: !Int64, - statItems :: !Int64, - statClientErrors :: !Int64, - statServerErrors :: !Int64 + { times :: ![Int64], + queries :: !Int64, + items :: !Int64, + clientErrors :: !Int64, + serverErrors :: !Int64 } data StatDist = StatDist - { distQueue :: !(TQueue Int64), - distQueries :: !(TVar Int64), - distItems :: !(TVar Int64), - distClientErrors :: !(TVar Int64), - distServerErrors :: !(TVar Int64) + { queue :: !(TQueue Int64), + queries :: !(TVar Int64), + items :: !(TVar Int64), + clientErrors :: !(TVar Int64), + serverErrors :: !(TVar Int64) } -createStatDist :: MonadIO m => Text -> Store -> m StatDist +createStatDist :: (MonadIO m) => Text -> Store -> m StatDist createStatDist t store = liftIO $ do - distQueue <- newTQueueIO - distQueries <- newTVarIO 0 - distItems <- newTVarIO 0 - distClientErrors <- newTVarIO 0 - distServerErrors <- newTVarIO 0 + queue <- newTQueueIO + queries <- newTVarIO 0 + items <- newTVarIO 0 + clientErrors <- newTVarIO 0 + serverErrors <- newTVarIO 0 let metrics = HashMap.fromList [ ( t <> ".request_count", - Counter . statQueries + Counter . (.queries) ), ( t <> ".item_count", - Counter . statItems + Counter . (.items) ), ( t <> ".client_errors", - Counter . statClientErrors + Counter . (.clientErrors) ), ( t <> ".server_errors", - Counter . statServerErrors + Counter . (.serverErrors) ), ( t <> ".mean_ms", - Gauge . mean . statTimes + Gauge . mean . (.times) ), ( t <> ".avg_ms", - Gauge . avg . statTimes + Gauge . avg . (.times) ), ( t <> ".max_ms", - Gauge . maxi . statTimes + Gauge . maxi . (.times) ), ( t <> ".min_ms", - Gauge . mini . statTimes + Gauge . mini . (.times) ), ( t <> ".p90max_ms", - Gauge . p90max . statTimes + Gauge . p90max . (.times) ), ( t <> ".p90avg_ms", - Gauge . p90avg . statTimes + Gauge . p90avg . (.times) ), ( t <> ".var_ms", - Gauge . var . statTimes + Gauge . var . (.times) ) ] let sd = StatDist {..} @@ -139,36 +143,36 @@ toDouble :: Int64 -> Double toDouble = fromIntegral -addStatTime :: MonadIO m => StatDist -> Int64 -> m () +addStatTime :: (MonadIO m) => StatDist -> Int64 -> m () addStatTime q = - liftIO . atomically . writeTQueue (distQueue q) + liftIO . atomically . writeTQueue q.queue -addStatQuery :: MonadIO m => StatDist -> m () +addStatQuery :: (MonadIO m) => StatDist -> m () addStatQuery q = - liftIO . atomically $ modifyTVar (distQueries q) (+ 1) + liftIO . atomically $ modifyTVar q.queries (+ 1) -addStatItems :: MonadIO m => StatDist -> Int64 -> m () +addStatItems :: (MonadIO m) => StatDist -> Int64 -> m () addStatItems q = - liftIO . atomically . modifyTVar (distItems q) . (+) + liftIO . atomically . modifyTVar q.items . (+) -addClientError :: MonadIO m => StatDist -> m () +addClientError :: (MonadIO m) => StatDist -> m () addClientError q = - liftIO . atomically $ modifyTVar (distClientErrors q) (+ 1) + liftIO . atomically $ modifyTVar q.clientErrors (+ 1) -addServerError :: MonadIO m => StatDist -> m () +addServerError :: (MonadIO m) => StatDist -> m () addServerError q = - liftIO . atomically $ modifyTVar (distServerErrors q) (+ 1) + liftIO . atomically $ modifyTVar q.serverErrors (+ 1) -flush :: MonadIO m => StatDist -> m StatData +flush :: (MonadIO m) => StatDist -> m StatData flush StatDist {..} = atomically $ do - statTimes <- flushTQueue distQueue - statQueries <- readTVar distQueries - statItems <- readTVar distItems - statClientErrors <- readTVar distClientErrors - statServerErrors <- readTVar distServerErrors + times <- flushTQueue queue + queries <- readTVar queries + items <- readTVar items + clientErrors <- readTVar clientErrors + serverErrors <- readTVar serverErrors return $ StatData {..} -average :: Fractional a => L.Fold a a +average :: (Fractional a) => L.Fold a a average = (/) <$> L.sum <*> L.genericLength avg :: [Int64] -> Int64 @@ -192,14 +196,14 @@ [] -> 0 h : _ -> h where - sorted = sortBy (comparing Down) ls + sorted = sortOn Down ls len = length sorted - chopped = drop (length sorted * 1 `div` 10) sorted + chopped = drop (length sorted `div` 10) sorted p90avg :: [Int64] -> Int64 p90avg ls = avg chopped where - sorted = sortBy (comparing Down) ls + sorted = sortOn Down ls len = length sorted - chopped = drop (length sorted * 1 `div` 10) sorted + chopped = drop (length sorted `div` 10) sorted diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -1,3194 +1,3166 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Haskoin.Store.Web - ( -- * Web - WebConfig (..), - Except (..), - WebLimits (..), - WebTimeouts (..), - runWeb, - ) -where - -import Conduit - ( ConduitT, - await, - concatMapC, - concatMapMC, - dropC, - dropWhileC, - headC, - iterMC, - mapC, - runConduit, - sinkList, - takeC, - takeWhileC, - yield, - (.|), - ) -import Control.Applicative ((<|>)) -import Control.Arrow (second) -import Control.Lens ((.~), (^.)) -import Control.Monad - ( forM_, - forever, - join, - unless, - when, - (<=<), - (>=>), - ) -import Control.Monad.Logger - ( MonadLoggerIO, - logDebugS, - logErrorS, - logWarnS, - ) -import Control.Monad.Reader - ( ReaderT, - asks, - local, - runReaderT, - ) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Control (liftWith, restoreT) -import Control.Monad.Trans.Maybe - ( MaybeT (..), - runMaybeT, - ) -import Data.Aeson - ( Encoding, - ToJSON (..), - Value, - ) -import Data.Aeson qualified as A -import Data.Aeson.Encode.Pretty - ( Config (..), - defConfig, - encodePretty', - ) -import Data.Aeson.Encoding - ( encodingToLazyByteString, - list, - ) -import Data.Aeson.Text (encodeToLazyText) -import Data.ByteString (ByteString) -import Data.ByteString qualified as B -import Data.ByteString.Base16 qualified as B16 -import Data.ByteString.Builder (lazyByteString) -import Data.ByteString.Char8 qualified as C -import Data.ByteString.Lazy qualified as L -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char (isSpace) -import Data.Default (Default (..)) -import Data.Function ((&)) -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Int (Int64) -import Data.List (nub) -import Data.Maybe - ( catMaybes, - fromJust, - fromMaybe, - isJust, - mapMaybe, - maybeToList, - ) -import Data.Proxy (Proxy (..)) -import Data.Serialize (decode) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy qualified as TL -import Data.Time.Clock (diffUTCTime) -import Data.Time.Clock.System - ( getSystemTime, - systemSeconds, - systemToUTCTime, - ) -import Data.Vault.Lazy qualified as V -import Data.Word (Word32, Word64) -import Database.RocksDB - ( Property (..), - getProperty, - ) -import GHC.RTS.Flags (ConcFlags (ConcFlags)) -import Haskoin.Address -import Haskoin.Block qualified as H -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys -import Haskoin.Network -import Haskoin.Node - ( Chain, - OnlinePeer (..), - PeerManager, - chainGetAncestor, - chainGetBest, - getPeers, - sendMessage, - ) -import Haskoin.Script -import Haskoin.Store.BlockStore -import Haskoin.Store.Cache -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Database.Reader -import Haskoin.Store.Manager -import Haskoin.Store.Stats -import Haskoin.Store.WebCommon -import Haskoin.Transaction -import Haskoin.Util -import NQE - ( Inbox, - Publisher, - receive, - withSubscription, - ) -import Network.HTTP.Types - ( Status (..), - hContentType, - requestEntityTooLarge413, - status400, - status404, - status409, - status413, - status500, - status503, - statusIsClientError, - statusIsServerError, - statusIsSuccessful, - ) -import Network.Wai - ( Middleware, - Request (..), - Response, - getRequestBodyChunk, - responseLBS, - responseStatus, - ) -import Network.Wai.Handler.Warp - ( defaultSettings, - setHost, - setPort, - ) -import Network.Wai.Handler.WebSockets (websocketsOr) -import Network.Wai.Middleware.RequestSizeLimit -import Network.Wai.Middleware.Timeout -import Network.WebSockets - ( ServerApp, - acceptRequest, - defaultConnectionOptions, - pendingRequest, - rejectRequestWith, - requestPath, - sendTextData, - ) -import Network.WebSockets qualified as WebSockets -import Network.Wreq qualified as Wreq -import Network.Wreq.Session as Wreq (Session) -import Network.Wreq.Session qualified as Wreq.Session -import System.IO.Unsafe (unsafeInterleaveIO) -import System.Metrics qualified as Metrics -import System.Metrics.Gauge qualified as Metrics (Gauge) -import System.Metrics.Gauge qualified as Metrics.Gauge -import UnliftIO - ( MonadIO, - MonadUnliftIO, - TVar, - askRunInIO, - atomically, - bracket, - bracket_, - handleAny, - liftIO, - modifyTVar, - newTVarIO, - readTVarIO, - timeout, - withAsync, - withRunInIO, - writeTVar, - ) -import UnliftIO.Concurrent (threadDelay) -import Web.Scotty.Internal.Types (ActionT) -import Web.Scotty.Trans qualified as S - -type WebT m = ActionT Except (ReaderT WebState m) - -data WebLimits = WebLimits - { maxLimitCount :: !Word32, - maxLimitFull :: !Word32, - maxLimitOffset :: !Word32, - maxLimitDefault :: !Word32, - maxLimitGap :: !Word32, - maxLimitInitialGap :: !Word32, - maxLimitBody :: !Word32, - maxLimitTimeout :: !Word32 - } - deriving (Eq, Show) - -instance Default WebLimits where - def = - WebLimits - { maxLimitCount = 200000, - maxLimitFull = 5000, - maxLimitOffset = 50000, - maxLimitDefault = 100, - maxLimitGap = 32, - maxLimitInitialGap = 20, - maxLimitBody = 1024 * 1024, - maxLimitTimeout = 0 - } - -data WebConfig = WebConfig - { webHost :: !String, - webPort :: !Int, - webStore :: !Store, - webMaxDiff :: !Int, - webMaxPending :: !Int, - webMaxLimits :: !WebLimits, - webTimeouts :: !WebTimeouts, - webVersion :: !String, - webNoMempool :: !Bool, - webStats :: !(Maybe Metrics.Store), - webPriceGet :: !Int, - webTickerURL :: !String, - webHistoryURL :: !String, - webSlow :: !Bool, - webBlockchain :: !Bool, - webHealthCheckInterval :: !Int - } - -data WebState = WebState - { webConfig :: !WebConfig, - webTicker :: !(TVar (HashMap Text BinfoTicker)), - webMetrics :: !(Maybe WebMetrics), - webWreqSession :: !Wreq.Session, - webHealthCheck :: !(TVar HealthCheck) - } - -data WebMetrics = WebMetrics - { statAll :: !StatDist, - -- Addresses - statAddressTransactions :: !StatDist, - statAddressTransactionsFull :: !StatDist, - statAddressBalance :: !StatDist, - statAddressUnspent :: !StatDist, - statXpub :: !StatDist, - statXpubDelete :: !StatDist, - statXpubTransactionsFull :: !StatDist, - statXpubTransactions :: !StatDist, - statXpubBalances :: !StatDist, - statXpubUnspent :: !StatDist, - -- Transactions - statTransaction :: !StatDist, - statTransactionRaw :: !StatDist, - statTransactionAfter :: !StatDist, - statTransactionsBlock :: !StatDist, - statTransactionsBlockRaw :: !StatDist, - statTransactionPost :: !StatDist, - statMempool :: !StatDist, - -- Blocks - statBlock :: !StatDist, - statBlockRaw :: !StatDist, - -- Blockchain - statBlockchainMultiaddr :: !StatDist, - statBlockchainBalance :: !StatDist, - statBlockchainRawaddr :: !StatDist, - statBlockchainUnspent :: !StatDist, - statBlockchainRawtx :: !StatDist, - statBlockchainRawblock :: !StatDist, - statBlockchainMempool :: !StatDist, - statBlockchainBlockHeight :: !StatDist, - statBlockchainBlocks :: !StatDist, - statBlockchainLatestblock :: !StatDist, - statBlockchainExportHistory :: !StatDist, - -- Blockchain /q endpoints - statBlockchainQaddresstohash :: !StatDist, - statBlockchainQhashtoaddress :: !StatDist, - statBlockchainQaddrpubkey :: !StatDist, - statBlockchainQpubkeyaddr :: !StatDist, - statBlockchainQhashpubkey :: !StatDist, - statBlockchainQgetblockcount :: !StatDist, - statBlockchainQlatesthash :: !StatDist, - statBlockchainQbcperblock :: !StatDist, - statBlockchainQtxtotalbtcoutput :: !StatDist, - statBlockchainQtxtotalbtcinput :: !StatDist, - statBlockchainQtxfee :: !StatDist, - statBlockchainQtxresult :: !StatDist, - statBlockchainQgetreceivedbyaddress :: !StatDist, - statBlockchainQgetsentbyaddress :: !StatDist, - statBlockchainQaddressbalance :: !StatDist, - statBlockchainQaddressfirstseen :: !StatDist, - -- Others - statHealth :: !StatDist, - statPeers :: !StatDist, - statDbstats :: !StatDist, - statEvents :: !Metrics.Gauge.Gauge, - -- Request - statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist)))) - } - -createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics -createMetrics s = liftIO $ do - statAll <- d "all" - - -- Addresses - statAddressTransactions <- d "address_transactions" - statAddressTransactionsFull <- d "address_transactions_full" - statAddressBalance <- d "address_balance" - statAddressUnspent <- d "address_unspent" - statXpub <- d "xpub" - statXpubDelete <- d "xpub_delete" - statXpubTransactionsFull <- d "xpub_transactions_full" - statXpubTransactions <- d "xpub_transactions" - statXpubBalances <- d "xpub_balances" - statXpubUnspent <- d "xpub_unspent" - - -- Transactions - statTransaction <- d "transaction" - statTransactionRaw <- d "transaction_raw" - statTransactionAfter <- d "transaction_after" - statTransactionPost <- d "transaction_post" - statTransactionsBlock <- d "transactions_block" - statTransactionsBlockRaw <- d "transactions_block_raw" - statMempool <- d "mempool" - - -- Blocks - statBlockBest <- d "block_best" - statBlockLatest <- d "block_latest" - statBlock <- d "block" - statBlockRaw <- d "block_raw" - statBlockHeight <- d "block_height" - statBlockHeightRaw <- d "block_height_raw" - statBlockTime <- d "block_time" - statBlockTimeRaw <- d "block_time_raw" - statBlockMtp <- d "block_mtp" - statBlockMtpRaw <- d "block_mtp_raw" - - -- Blockchain - statBlockchainMultiaddr <- d "blockchain_multiaddr" - statBlockchainBalance <- d "blockchain_balance" - statBlockchainRawaddr <- d "blockchain_rawaddr" - statBlockchainUnspent <- d "blockchain_unspent" - statBlockchainRawtx <- d "blockchain_rawtx" - statBlockchainRawblock <- d "blockchain_rawblock" - statBlockchainLatestblock <- d "blockchain_latestblock" - statBlockchainMempool <- d "blockchain_mempool" - statBlockchainBlockHeight <- d "blockchain_block_height" - statBlockchainBlocks <- d "blockchain_blocks" - statBlockchainExportHistory <- d "blockchain_export_history" - - -- Blockchain /q endpoints - statBlockchainQaddresstohash <- d "blockchain_q_addresstohash" - statBlockchainQhashtoaddress <- d "blockchain_q_hashtoaddress" - statBlockchainQaddrpubkey <- d "blockckhain_q_addrpubkey" - statBlockchainQpubkeyaddr <- d "blockchain_q_pubkeyaddr" - statBlockchainQhashpubkey <- d "blockchain_q_hashpubkey" - statBlockchainQgetblockcount <- d "blockchain_q_getblockcount" - statBlockchainQlatesthash <- d "blockchain_q_latesthash" - statBlockchainQbcperblock <- d "blockchain_q_bcperblock" - statBlockchainQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput" - statBlockchainQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput" - statBlockchainQtxfee <- d "blockchain_q_txfee" - statBlockchainQtxresult <- d "blockchain_q_txresult" - statBlockchainQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress" - statBlockchainQgetsentbyaddress <- d "blockchain_q_getsentbyaddress" - statBlockchainQaddressbalance <- d "blockchain_q_addressbalance" - statBlockchainQaddressfirstseen <- d "blockchain_q_addressfirstseen" - - -- Others - statHealth <- d "health" - statPeers <- d "peers" - statDbstats <- d "dbstats" - - statEvents <- g "events_connected" - statKey <- V.newKey - return WebMetrics {..} - where - d x = createStatDist ("web." <> x) s - g x = Metrics.createGauge ("web." <> x) s - -withGaugeIO :: MonadUnliftIO m => Metrics.Gauge -> m a -> m a -withGaugeIO g = - bracket_ - (liftIO $ Metrics.Gauge.inc g) - (liftIO $ Metrics.Gauge.dec g) - -withGaugeIncrease :: - MonadUnliftIO m => - (WebMetrics -> Metrics.Gauge) -> - WebT m a -> - WebT m a -withGaugeIncrease gf go = - lift (asks webMetrics) >>= \case - Nothing -> go - Just m -> do - s <- liftWith $ \run -> withGaugeIO (gf m) (run go) - restoreT $ return s - -setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> WebT m () -setMetrics df = - asks webMetrics >>= mapM_ go - where - go m = do - req <- S.request - let t = fromMaybe e $ V.lookup (statKey m) (vault req) - atomically $ writeTVar t (Just df) - e = error "the ways of the warrior are yet to be mastered" - -addItemCount :: MonadUnliftIO m => Int -> WebT m () -addItemCount i = - asks webMetrics >>= mapM_ \m -> do - addStatItems (statAll m) (fromIntegral i) - req <- S.request - forM_ (V.lookup (statKey m) (vault req)) $ - readTVarIO >=> mapM_ \s -> addStatItems (s m) (fromIntegral i) - -getItemCounter :: (MonadIO m, MonadIO n) => WebT m (Int -> n ()) -getItemCounter = - fromMaybe (\_ -> return ()) <$> runMaybeT do - q <- lift S.request - m <- MaybeT $ asks webMetrics - t <- MaybeT . return $ V.lookup (statKey m) (vault q) - s <- MaybeT $ readTVarIO t - return $ addStatItems (s m) . fromIntegral - -data WebTimeouts = WebTimeouts - { txTimeout :: !Word64, - blockTimeout :: !Word64 - } - deriving (Eq, Show) - -data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON - deriving (Eq, Show) - -instance Default WebTimeouts where - def = WebTimeouts {txTimeout = 300, blockTimeout = 7200} - -instance - (MonadUnliftIO m, MonadLoggerIO m) => - StoreReadBase (ReaderT WebState m) - where - getNetwork = runInWebReader getNetwork - getBestBlock = runInWebReader getBestBlock - getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) - getBlock bh = runInWebReader (getBlock bh) - getTxData th = runInWebReader (getTxData th) - getSpender op = runInWebReader (getSpender op) - getUnspent op = runInWebReader (getUnspent op) - getBalance a = runInWebReader (getBalance a) - getMempool = runInWebReader getMempool - -instance - (MonadUnliftIO m, MonadLoggerIO m) => - StoreReadExtra (ReaderT WebState m) - where - getMaxGap = runInWebReader getMaxGap - getInitialGap = runInWebReader getInitialGap - getBalances as = runInWebReader (getBalances as) - getAddressesTxs as = runInWebReader . getAddressesTxs as - getAddressTxs a = runInWebReader . getAddressTxs a - getAddressUnspents a = runInWebReader . getAddressUnspents a - getAddressesUnspents as = runInWebReader . getAddressesUnspents as - xPubBals = runInWebReader . xPubBals - xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals - xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals - xPubTxCount xpub = runInWebReader . xPubTxCount xpub - getNumTxData = runInWebReader . getNumTxData - -instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where - getNetwork = lift getNetwork - getBestBlock = lift getBestBlock - getBlocksAtHeight = lift . getBlocksAtHeight - getBlock = lift . getBlock - getTxData = lift . getTxData - getSpender = lift . getSpender - getUnspent = lift . getUnspent - getBalance = lift . getBalance - getMempool = lift getMempool - -instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where - getBalances = lift . getBalances - getAddressesTxs as = lift . getAddressesTxs as - getAddressTxs a = lift . getAddressTxs a - getAddressUnspents a = lift . getAddressUnspents a - getAddressesUnspents as = lift . getAddressesUnspents as - xPubBals = lift . xPubBals - xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals - xPubTxs xpub xbals = lift . xPubTxs xpub xbals - xPubTxCount xpub = lift . xPubTxCount xpub - getMaxGap = lift getMaxGap - getInitialGap = lift getInitialGap - getNumTxData = lift . getNumTxData - -------------------- --- Path Handlers -- -------------------- - -runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m () -runWeb - cfg@WebConfig - { webHost = host, - webPort = port, - webStore = store', - webStats = stats, - webPriceGet = pget, - webTickerURL = turl, - webMaxLimits = WebLimits {..}, - webSlow = slow, - webBlockchain = blockchain, - webHealthCheckInterval = healthint - } = do - ticker <- newTVarIO HashMap.empty - metrics <- mapM createMetrics stats - session <- liftIO Wreq.Session.newAPISession - health' <- hcheck >>= newTVarIO - let st = - WebState - { webConfig = cfg, - webTicker = ticker, - webMetrics = metrics, - webWreqSession = session, - webHealthCheck = health' - } - net = storeNetwork store' - withAsync (when blockchain $ price net session turl pget ticker) - . const - . withAsync (health health') - . const - $ do - reqLogger <- logIt metrics - runner <- askRunInIO - S.scottyOptsT opts (runner . (`runReaderT` st)) $ do - S.middleware (webSocketEvents st) - S.middleware reqLogger - S.middleware (reqSizeLimit maxLimitBody) - when (maxLimitTimeout > 0) $ S.middleware (reqTimeout maxLimitTimeout) - S.defaultHandler defHandler - handlePaths slow blockchain - S.notFound $ raise ThingNotFound - where - hcheck = runReaderT (healthCheck cfg) (storeDB store') - health v = forever $ do - threadDelay (healthint * 1000 * 1000) - hcheck >>= atomically . writeTVar v - opts = def {S.settings = settings defaultSettings} - settings = setPort port . setHost (fromString host) - -getRates :: - (MonadUnliftIO m, MonadLoggerIO m) => - Network -> - Wreq.Session -> - String -> - Text -> - [Word64] -> - m [BinfoRate] -getRates net session url currency times = do - handleAny err $ do - r <- - liftIO $ - Wreq.asJSON - =<< Wreq.Session.postWith opts session url body - return $ r ^. Wreq.responseBody - where - err _ = do - $(logErrorS) "Web" "Could not get historic prices" - return [] - body = toJSON times - base = - Wreq.defaults - & Wreq.param "base" .~ [T.toUpper (T.pack (getNetworkName net))] - opts = base & Wreq.param "quote" .~ [currency] - -price :: - (MonadUnliftIO m, MonadLoggerIO m) => - Network -> - Wreq.Session -> - String -> - Int -> - TVar (HashMap Text BinfoTicker) -> - m () -price net session url pget v = forM_ purl $ \u -> forever $ do - let err e = $(logErrorS) "Price" $ cs (show e) - handleAny err $ do - r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u - atomically . writeTVar v $ r ^. Wreq.responseBody - threadDelay pget - where - purl = case code of - Nothing -> Nothing - Just x -> Just (url <> "?base=" <> x) - where - code - | net == btc = Just "btc" - | net == bch = Just "bch" - | otherwise = Nothing - -raise :: MonadIO m => Except -> WebT m a -raise err = - lift (asks webMetrics) >>= \case - Nothing -> S.raise err - Just m -> do - req <- S.request - mM <- case V.lookup (statKey m) (vault req) of - Nothing -> return Nothing - Just t -> readTVarIO t - let status = errStatus err - if - | statusIsClientError status -> - liftIO $ do - addClientError (statAll m) - forM_ mM $ \f -> addClientError (f m) - | statusIsServerError status -> - liftIO $ do - addServerError (statAll m) - forM_ mM $ \f -> addServerError (f m) - | otherwise -> - return () - S.raise err - -errStatus :: Except -> Status -errStatus ThingNotFound = status404 -errStatus BadRequest = status400 -errStatus UserError {} = status400 -errStatus StringError {} = status400 -errStatus ServerError = status500 -errStatus TxIndexConflict {} = status409 -errStatus ServerTimeout = status500 -errStatus RequestTooLarge = status413 - -defHandler :: Monad m => Except -> WebT m () -defHandler e = do - setHeaders - S.status $ errStatus e - S.json e - -handlePaths :: - (MonadUnliftIO m, MonadLoggerIO m) => - Bool -> - Bool -> - S.ScottyT Except (ReaderT WebState m) () -handlePaths slow blockchain = do - -- Block Paths - pathCompact - (GetBlock <$> paramLazy <*> paramDef) - scottyBlock - blockDataToEncoding - blockDataToJSON - when slow $ - pathCompact - (GetBlocks <$> param <*> paramDef) - (fmap SerialList . scottyBlocks) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - when slow $ - pathCompact - (GetBlockRaw <$> paramLazy) - scottyBlockRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockBest <$> paramDef) - scottyBlockBest - blockDataToEncoding - blockDataToJSON - when slow $ - pathCompact - (GetBlockBestRaw & return) - scottyBlockBestRaw - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetBlockLatest <$> paramDef) - (fmap SerialList . scottyBlockLatest) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact - (GetBlockHeight <$> paramLazy <*> paramDef) - (fmap SerialList . scottyBlockHeight) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - when slow $ - pathCompact - (GetBlockHeights <$> param <*> paramDef) - (fmap SerialList . scottyBlockHeights) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - when slow $ - pathCompact - (GetBlockHeightRaw <$> paramLazy) - scottyBlockHeightRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockTime <$> paramLazy <*> paramDef) - scottyBlockTime - blockDataToEncoding - blockDataToJSON - when slow $ - pathCompact - (GetBlockTimeRaw <$> paramLazy) - scottyBlockTimeRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockMTP <$> paramLazy <*> paramDef) - scottyBlockMTP - blockDataToEncoding - blockDataToJSON - when slow $ - pathCompact - (GetBlockMTPRaw <$> paramLazy) - scottyBlockMTPRaw - (const toEncoding) - (const toJSON) - -- Transaction Paths - pathCompact - (GetTx <$> paramLazy) - scottyTx - transactionToEncoding - transactionToJSON - when slow $ - pathCompact - (GetTxs <$> param) - (fmap SerialList . scottyTxs) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetTxRaw <$> paramLazy) - scottyTxRaw - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetTxsRaw <$> param) - scottyTxsRaw - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetTxsBlock <$> paramLazy) - (fmap SerialList . scottyTxsBlock) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - when slow $ - pathCompact - (GetTxsBlockRaw <$> paramLazy) - scottyTxsBlockRaw - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetTxAfter <$> paramLazy <*> paramLazy) - scottyTxAfter - (const toEncoding) - (const toJSON) - pathCompact - (PostTx <$> parseBody) - scottyPostTx - (const toEncoding) - (const toJSON) - pathCompact - (GetMempool <$> paramOptional <*> parseOffset) - (fmap SerialList . scottyMempool) - (const toEncoding) - (const toJSON) - -- Address Paths - pathCompact - (GetAddrTxs <$> paramLazy <*> parseLimits) - (fmap SerialList . scottyAddrTxs) - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetAddrsTxs <$> param <*> parseLimits) - (fmap SerialList . scottyAddrsTxs) - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetAddrTxsFull <$> paramLazy <*> parseLimits) - (fmap SerialList . scottyAddrTxsFull) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - when slow $ - pathCompact - (GetAddrsTxsFull <$> param <*> parseLimits) - (fmap SerialList . scottyAddrsTxsFull) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetAddrBalance <$> paramLazy) - scottyAddrBalance - balanceToEncoding - balanceToJSON - when slow $ - pathCompact - (GetAddrsBalance <$> param) - (fmap SerialList . scottyAddrsBalance) - (\n -> list (balanceToEncoding n) . getSerialList) - (\n -> json_list balanceToJSON n . getSerialList) - pathCompact - (GetAddrUnspent <$> paramLazy <*> parseLimits) - (fmap SerialList . scottyAddrUnspent) - (\n -> list (unspentToEncoding n) . getSerialList) - (\n -> json_list unspentToJSON n . getSerialList) - when slow $ - pathCompact - (GetAddrsUnspent <$> param <*> parseLimits) - (fmap SerialList . scottyAddrsUnspent) - (\n -> list (unspentToEncoding n) . getSerialList) - (\n -> json_list unspentToJSON n . getSerialList) - -- XPubs - when slow $ - pathCompact - (GetXPub <$> paramLazy <*> paramDef <*> paramDef) - scottyXPub - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubTxs) - (const toEncoding) - (const toJSON) - when slow $ - pathCompact - (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubTxsFull) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - when slow $ - pathCompact - (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef) - (fmap SerialList . scottyXPubBalances) - (\n -> list (xPubBalToEncoding n) . getSerialList) - (\n -> json_list xPubBalToJSON n . getSerialList) - when slow $ - pathCompact - (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubUnspent) - (\n -> list (xPubUnspentToEncoding n) . getSerialList) - (\n -> json_list xPubUnspentToJSON n . getSerialList) - when slow $ - pathCompact - (DelCachedXPub <$> paramLazy <*> paramDef) - scottyDelXPub - (const toEncoding) - (const toJSON) - -- Network - pathCompact - (GetPeers & return) - (fmap SerialList . scottyPeers) - (const toEncoding) - (const toJSON) - pathCompact - (GetHealth & return) - scottyHealth - (const toEncoding) - (const toJSON) - S.get "/events" scottyEvents - S.get "/dbstats" scottyDbStats - -- Blockchain.info - when blockchain $ do - S.post "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/balance" scottyShortBal - S.post "/blockchain/balance" scottyShortBal - S.get "/blockchain/rawaddr/:addr" scottyRawAddr - S.get "/blockchain/address/:addr" scottyRawAddr - S.get "/blockchain/xpub/:addr" scottyRawAddr - S.post "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/rawtx/:txid" scottyBinfoTx - S.get "/blockchain/rawblock/:block" scottyBinfoBlock - S.get "/blockchain/latestblock" scottyBinfoLatest - S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool - S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight - S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay - S.get "/blockchain/export-history" scottyBinfoHistory - S.post "/blockchain/export-history" scottyBinfoHistory - S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash - S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr - S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey - S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr - S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey - S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount - S.get "/blockchain/q/latesthash" scottyBinfoLatestHash - S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy - S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut - S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput - S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees - S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult - S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived - S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent - S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance - S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen - where - json_list f net = toJSONList . map (f net) - -pathCompact :: - (ApiResource a b, MonadIO m) => - WebT m a -> - (a -> WebT m b) -> - (Network -> b -> Encoding) -> - (Network -> b -> Value) -> - S.ScottyT Except (ReaderT WebState m) () -pathCompact parser action encJson encValue = - pathCommon parser action encJson encValue False - -pathCommon :: - (ApiResource a b, MonadIO m) => - WebT m a -> - (a -> WebT m b) -> - (Network -> b -> Encoding) -> - (Network -> b -> Value) -> - Bool -> - S.ScottyT Except (ReaderT WebState m) () -pathCommon parser action encJson encValue pretty = - S.addroute (resourceMethod proxy) (capturePath proxy) $ do - setHeaders - proto <- setupContentType pretty - net <- lift $ asks (storeNetwork . webStore . webConfig) - apiRes <- parser - res <- action apiRes - S.raw $ protoSerial proto (encJson net) (encValue net) res - where - toProxy :: WebT m a -> Proxy a - toProxy = const Proxy - proxy = toProxy parser - -streamEncoding :: Monad m => Encoding -> WebT m () -streamEncoding e = do - S.setHeader "Content-Type" "application/json; charset=utf-8" - S.raw (encodingToLazyByteString e) - -protoSerial :: - Serial a => - SerialAs -> - (a -> Encoding) -> - (a -> Value) -> - a -> - L.ByteString -protoSerial SerialAsBinary _ _ = runPutL . serialize -protoSerial SerialAsJSON f _ = encodingToLazyByteString . f -protoSerial SerialAsPrettyJSON _ g = - encodePretty' defConfig {confTrailingNewline = True} . g - -setHeaders :: (Monad m, S.ScottyError e) => ActionT e m () -setHeaders = S.setHeader "Access-Control-Allow-Origin" "*" - -waiExcept :: Status -> Except -> Response -waiExcept s e = - responseLBS s hs e' - where - hs = - [ ("Access-Control-Allow-Origin", "*"), - ("Content-Type", "application/json") - ] - e' = A.encode e - -setupJSON :: Monad m => Bool -> ActionT Except m SerialAs -setupJSON pretty = do - S.setHeader "Content-Type" "application/json" - p <- S.param "pretty" `S.rescue` const (return pretty) - return $ if p then SerialAsPrettyJSON else SerialAsJSON - -setupBinary :: Monad m => ActionT Except m SerialAs -setupBinary = do - S.setHeader "Content-Type" "application/octet-stream" - return SerialAsBinary - -setupContentType :: Monad m => Bool -> ActionT Except m SerialAs -setupContentType pretty = do - accept <- S.header "accept" - maybe (setupJSON pretty) setType accept - where - setType "application/octet-stream" = setupBinary - setType _ = setupJSON pretty - --- GET Block / GET Blocks -- - -scottyBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData -scottyBlock (GetBlock h (NoTx noTx)) = do - setMetrics statBlock - getBlock h >>= \case - Nothing -> - raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx noTx b - -getBlocks :: - (MonadUnliftIO m, MonadLoggerIO m) => - [H.BlockHash] -> - Bool -> - WebT m [BlockData] -getBlocks hs notx = - (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs) - -scottyBlocks :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData] -scottyBlocks (GetBlocks hs (NoTx notx)) = do - setMetrics statBlock - bs <- getBlocks hs notx - addItemCount (length bs) - return bs - -pruneTx :: Bool -> BlockData -> BlockData -pruneTx False b = b -pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)} - --- GET BlockRaw -- - -scottyBlockRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockRaw -> - WebT m (RawResult H.Block) -scottyBlockRaw (GetBlockRaw h) = do - setMetrics statBlockRaw - b <- getRawBlock h - addItemCount (1 + length (H.blockTxns b)) - return $ RawResult b - -getRawBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - H.BlockHash -> - WebT m H.Block -getRawBlock h = do - b <- getBlock h >>= maybe (raise ThingNotFound) return - lift (toRawBlock b) - -toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block -toRawBlock b = do - let ths = blockDataTxs b - txs <- mapM f ths - return H.Block {H.blockHeader = blockDataHeader b, H.blockTxns = txs} - where - f x = withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x >>= \case - Nothing -> undefined - Just t -> return $ transactionData t - --- GET BlockBest / BlockBestRaw -- - -scottyBlockBest :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData -scottyBlockBest (GetBlockBest (NoTx notx)) = do - setMetrics statBlock - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bb -> - getBlock bb >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx notx b - -scottyBlockBestRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockBestRaw -> - WebT m (RawResult H.Block) -scottyBlockBestRaw _ = do - setMetrics statBlockRaw - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bb -> do - b <- getRawBlock bb - addItemCount (1 + length (H.blockTxns b)) - return $ RawResult b - --- GET BlockLatest -- - -scottyBlockLatest :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockLatest -> - WebT m [BlockData] -scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do - setMetrics statBlock - blocks <- - getBestBlock - >>= maybe - (raise ThingNotFound) - (go [] <=< getBlock) - addItemCount (length blocks) - return blocks - where - go acc Nothing = return $ reverse acc - go acc (Just b) - | blockDataHeight b <= 0 = return $ reverse acc - | length acc == 99 = return . reverse $ pruneTx noTx b : acc - | otherwise = do - let prev = H.prevBlock (blockDataHeader b) - go (pruneTx noTx b : acc) =<< getBlock prev - --- GET BlockHeight / BlockHeights / BlockHeightRaw -- - -scottyBlockHeight :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData] -scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do - setMetrics statBlock - blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h) - addItemCount (length blocks) - return blocks - -scottyBlockHeights :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockHeights -> - WebT m [BlockData] -scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do - setMetrics statBlock - bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights) - blocks <- getBlocks bhs notx - addItemCount (length blocks) - return blocks - -scottyBlockHeightRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockHeightRaw -> - WebT m (RawResultList H.Block) -scottyBlockHeightRaw (GetBlockHeightRaw h) = do - setMetrics statBlockRaw - blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) - addItemCount (length blocks + sum (map (length . H.blockTxns) blocks)) - return $ RawResultList blocks - --- GET BlockTime / BlockTimeRaw -- - -scottyBlockTime :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockTime -> - WebT m BlockData -scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do - setMetrics statBlock - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrBefore ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx notx b - -scottyBlockMTP :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockMTP -> - WebT m BlockData -scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do - setMetrics statBlock - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrAfterMTP ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx notx b - -scottyBlockTimeRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockTimeRaw -> - WebT m (RawResult H.Block) -scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do - setMetrics statBlockRaw - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrBefore ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - raw <- lift $ toRawBlock b - addItemCount (1 + length (H.blockTxns raw)) - return $ RawResult raw - -scottyBlockMTPRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockMTPRaw -> - WebT m (RawResult H.Block) -scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do - setMetrics statBlockRaw - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrAfterMTP ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - raw <- lift $ toRawBlock b - addItemCount (1 + length (H.blockTxns raw)) - return $ RawResult raw - --- GET Transactions -- - -scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction -scottyTx (GetTx txid) = do - setMetrics statTransaction - getTransaction txid >>= \case - Nothing -> raise ThingNotFound - Just tx -> do - addItemCount 1 - return tx - -scottyTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction] -scottyTxs (GetTxs txids) = do - setMetrics statTransaction - txs <- catMaybes <$> mapM f (nub txids) - addItemCount (length txs) - return txs - where - f x = lift $ - withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x - -scottyTxRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx) -scottyTxRaw (GetTxRaw txid) = do - setMetrics statTransactionRaw - getTransaction txid >>= \case - Nothing -> raise ThingNotFound - Just tx -> do - addItemCount 1 - return $ RawResult (transactionData tx) - -scottyTxsRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxsRaw -> - WebT m (RawResultList Tx) -scottyTxsRaw (GetTxsRaw txids) = do - setMetrics statTransactionRaw - txs <- catMaybes <$> mapM f (nub txids) - addItemCount (length txs) - return $ RawResultList $ transactionData <$> txs - where - f x = lift $ - withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x - -getTxsBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - H.BlockHash -> - WebT m [Transaction] -getTxsBlock h = - getBlock h >>= \case - Nothing -> raise ThingNotFound - Just b -> do - txs <- mapM f (blockDataTxs b) - addItemCount (length txs) - return txs - where - f x = lift $ - withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x >>= \case - Nothing -> undefined - Just t -> return t - -scottyTxsBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxsBlock -> - WebT m [Transaction] -scottyTxsBlock (GetTxsBlock h) = do - setMetrics statTransactionsBlock - txs <- getTxsBlock h - addItemCount (length txs) - return txs - -scottyTxsBlockRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxsBlockRaw -> - WebT m (RawResultList Tx) -scottyTxsBlockRaw (GetTxsBlockRaw h) = do - setMetrics statTransactionsBlockRaw - txs <- fmap transactionData <$> getTxsBlock h - addItemCount (length txs) - return $ RawResultList txs - --- GET TransactionAfterHeight -- - -scottyTxAfter :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxAfter -> - WebT m (GenericResult (Maybe Bool)) -scottyTxAfter (GetTxAfter txid height) = do - setMetrics statTransactionAfter - (result, count) <- cbAfterHeight (fromIntegral height) txid - addItemCount count - return $ GenericResult result - --- | Check if any of the ancestors of this transaction is a coinbase after the --- specified height. Returns 'Nothing' if answer cannot be computed before --- hitting limits. -cbAfterHeight :: - (MonadIO m, StoreReadBase m) => - H.BlockHeight -> - TxHash -> - m (Maybe Bool, Int) -cbAfterHeight height txid = - inputs n HashSet.empty HashSet.empty [txid] - where - n = 10000 - inputs 0 _ _ [] = return (Nothing, 10000) - inputs i is ns [] = - let is' = HashSet.union is ns - ns' = HashSet.empty - ts = HashSet.toList (HashSet.difference ns is) - in case ts of - [] -> return (Just False, n - i) - _ -> inputs i is' ns' ts - inputs i is ns (t : ts) = - getTransaction t >>= \case - Nothing -> return (Nothing, n - i) - Just tx - | height_check tx -> - if cb_check tx - then return (Just True, n - i + 1) - else - let ns' = HashSet.union (ins tx) ns - in inputs (i - 1) is ns' ts - | otherwise -> inputs (i - 1) is ns ts - cb_check = any isCoinbase . transactionInputs - ins = HashSet.fromList . map (outPointHash . inputPoint) . transactionInputs - height_check tx = - case transactionBlock tx of - BlockRef h _ -> h > height - _ -> True - --- POST Transaction -- - -scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId -scottyPostTx (PostTx tx) = do - setMetrics statTransactionPost - addItemCount 1 - lift (asks webConfig) >>= \cfg -> - lift (publishTx cfg tx) >>= \case - Right () -> return (TxId (txHash tx)) - Left e@(PubReject _) -> raise $ UserError (show e) - _ -> raise ServerError - --- | Publish a new transaction to the network. -publishTx :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - Tx -> - m (Either PubExcept ()) -publishTx cfg tx = - withSubscription pub $ \s -> - getTransaction (txHash tx) >>= \case - Just _ -> return $ Right () - Nothing -> go s - where - pub = storePublisher (webStore cfg) - mgr = storeManager (webStore cfg) - net = storeNetwork (webStore cfg) - go s = - getPeers mgr >>= \case - [] -> return $ Left PubNoPeers - OnlinePeer {onlinePeerMailbox = p} : _ -> do - MTx tx `sendMessage` p - let v = - if getSegWit net - then InvWitnessTx - else InvTx - sendMessage - (MGetData (GetData [InvVector v (getTxHash (txHash tx))])) - p - f p s - t = 5 * 1000 * 1000 - f p s - | webNoMempool cfg = return $ Right () - | otherwise = - liftIO (UnliftIO.timeout t (g p s)) >>= \case - Nothing -> return $ Left PubTimeout - Just (Left e) -> return $ Left e - Just (Right ()) -> return $ Right () - g p s = - receive s >>= \case - StoreTxReject p' h' c _ - | p == p' && h' == txHash tx -> return . Left $ PubReject c - StorePeerDisconnected p' - | p == p' -> return $ Left PubPeerDisconnected - StoreMempoolNew h' - | h' == txHash tx -> return $ Right () - _ -> g p s - --- GET Mempool / Events -- - -scottyMempool :: - (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash] -scottyMempool (GetMempool limitM (OffsetParam o)) = do - setMetrics statMempool - wl <- lift $ asks (webMaxLimits . webConfig) - let wl' = wl {maxLimitCount = 0} - l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing - ths <- map snd . applyLimits l <$> getMempool - addItemCount 1 - return ths - -webSocketEvents :: WebState -> Middleware -webSocketEvents s = - websocketsOr defaultConnectionOptions events - where - pub = (storePublisher . webStore . webConfig) s - gauge = statEvents <$> webMetrics s - events pending = withSubscription pub $ \sub -> do - let path = requestPath $ pendingRequest pending - if path == "/events" - then do - conn <- acceptRequest pending - forever $ - receiveEvent sub >>= \case - Nothing -> return () - Just event -> sendTextData conn (A.encode event) - else - rejectRequestWith - pending - WebSockets.defaultRejectRequest - { WebSockets.rejectBody = L.toStrict $ A.encode ThingNotFound, - WebSockets.rejectCode = 404, - WebSockets.rejectMessage = "Not Found", - WebSockets.rejectHeaders = [("Content-Type", "application/json")] - } - -scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyEvents = - withGaugeIncrease statEvents $ do - setHeaders - proto <- setupContentType False - pub <- lift $ asks (storePublisher . webStore . webConfig) - S.stream $ \io flush' -> - withSubscription pub $ \sub -> - forever $ - flush' >> receiveEvent sub >>= maybe (return ()) (io . serial proto) - where - serial proto e = - lazyByteString $ protoSerial proto toEncoding toJSON e <> newLine proto - newLine SerialAsBinary = mempty - newLine SerialAsJSON = "\n" - newLine SerialAsPrettyJSON = mempty - -receiveEvent :: Inbox StoreEvent -> IO (Maybe Event) -receiveEvent sub = - go <$> receive sub - where - go = \case - StoreBestBlock b -> Just (EventBlock b) - StoreMempoolNew t -> Just (EventTx t) - StoreMempoolDelete t -> Just (EventTx t) - _ -> Nothing - --- GET Address Transactions -- - -scottyAddrTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef] -scottyAddrTxs (GetAddrTxs addr pLimits) = do - setMetrics statAddressTransactions - txs <- getAddressTxs addr =<< paramToLimits False pLimits - addItemCount (length txs) - return txs - -scottyAddrsTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef] -scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do - setMetrics statAddressTransactions - txs <- getAddressesTxs addrs =<< paramToLimits False pLimits - addItemCount (length txs) - return txs - -scottyAddrTxsFull :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetAddrTxsFull -> - WebT m [Transaction] -scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do - setMetrics statAddressTransactionsFull - txs <- getAddressTxs addr =<< paramToLimits True pLimits - ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs - addItemCount (length ts) - return ts - -scottyAddrsTxsFull :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetAddrsTxsFull -> - WebT m [Transaction] -scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do - setMetrics statAddressTransactionsFull - txs <- getAddressesTxs addrs =<< paramToLimits True pLimits - ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs - addItemCount (length ts) - return ts - -scottyAddrBalance :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetAddrBalance -> - WebT m Balance -scottyAddrBalance (GetAddrBalance addr) = do - setMetrics statAddressBalance - addItemCount 1 - getDefaultBalance addr - -scottyAddrsBalance :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance] -scottyAddrsBalance (GetAddrsBalance addrs) = do - setMetrics statAddressBalance - balances <- getBalances addrs - addItemCount (length balances) - return balances - -scottyAddrUnspent :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent] -scottyAddrUnspent (GetAddrUnspent addr pLimits) = do - setMetrics statAddressUnspent - unspents <- getAddressUnspents addr =<< paramToLimits False pLimits - addItemCount (length unspents) - return unspents - -scottyAddrsUnspent :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent] -scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do - setMetrics statAddressUnspent - unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits - addItemCount (length unspents) - return unspents - --- GET XPubs -- - -scottyXPub :: - (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary -scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do - setMetrics statXpub - let xspec = XPubSpec xpub deriv - xbals <- lift . runNoCache noCache $ xPubBals xspec - addItemCount (length xbals) - return $ xPubSummary xspec xbals - -scottyDelXPub :: - (MonadUnliftIO m, MonadLoggerIO m) => - DelCachedXPub -> - WebT m (GenericResult Bool) -scottyDelXPub (DelCachedXPub xpub deriv) = do - setMetrics statXpubDelete - let xspec = XPubSpec xpub deriv - cacheM <- lift (asks (storeCache . webStore . webConfig)) - n <- lift $ withCache cacheM (cacheDelXPubs [xspec]) - addItemCount (fromIntegral n) - return (GenericResult (n > 0)) - -getXPubTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => - XPubKey -> - DeriveType -> - LimitsParam -> - Bool -> - WebT m [TxRef] -getXPubTxs xpub deriv plimits nocache = do - limits <- paramToLimits False plimits - let xspec = XPubSpec xpub deriv - xbals <- xPubBals xspec - addItemCount (length xbals) - lift . runNoCache nocache $ xPubTxs xspec xbals limits - -scottyXPubTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef] -scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do - setMetrics statXpubTransactions - txs <- getXPubTxs xpub deriv plimits nocache - addItemCount (length txs) - return txs - -scottyXPubTxsFull :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetXPubTxsFull -> - WebT m [Transaction] -scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do - setMetrics statXpubTransactionsFull - refs <- getXPubTxs xpub deriv plimits nocache - txs <- - fmap catMaybes $ - lift . runNoCache nocache $ - mapM (getTransaction . txRefHash) refs - addItemCount (length txs) - return txs - -scottyXPubBalances :: - (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal] -scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do - setMetrics statXpubBalances - balances <- lift (runNoCache noCache (xPubBals spec)) - addItemCount (length balances) - return balances - where - spec = XPubSpec xpub deriv - -scottyXPubUnspent :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetXPubUnspent -> - WebT m [XPubUnspent] -scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do - setMetrics statXpubUnspent - limits <- paramToLimits False pLimits - let xspec = XPubSpec xpub deriv - xbals <- xPubBals xspec - addItemCount (length xbals) - unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits - addItemCount (length unspents) - return unspents - ---------------------------------------- --- Blockchain.info API Compatibility -- ---------------------------------------- - -netBinfoSymbol :: Network -> BinfoSymbol -netBinfoSymbol net - | net == btc = - BinfoSymbol - { getBinfoSymbolCode = "BTC", - getBinfoSymbolString = "BTC", - getBinfoSymbolName = "Bitcoin", - getBinfoSymbolConversion = 100 * 1000 * 1000, - getBinfoSymbolAfter = True, - getBinfoSymbolLocal = False - } - | net == bch = - BinfoSymbol - { getBinfoSymbolCode = "BCH", - getBinfoSymbolString = "BCH", - getBinfoSymbolName = "Bitcoin Cash", - getBinfoSymbolConversion = 100 * 1000 * 1000, - getBinfoSymbolAfter = True, - getBinfoSymbolLocal = False - } - | otherwise = - BinfoSymbol - { getBinfoSymbolCode = "XTS", - getBinfoSymbolString = "ยค", - getBinfoSymbolName = "Test", - getBinfoSymbolConversion = 100 * 1000 * 1000, - getBinfoSymbolAfter = False, - getBinfoSymbolLocal = False - } - -binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol -binfoTickerToSymbol code BinfoTicker {..} = - BinfoSymbol - { getBinfoSymbolCode = code, - getBinfoSymbolString = binfoTickerSymbol, - getBinfoSymbolName = name, - getBinfoSymbolConversion = - 100 * 1000 * 1000 / binfoTicker15m, -- sat/usd - getBinfoSymbolAfter = False, - getBinfoSymbolLocal = True - } - where - name = case code of - "EUR" -> "Euro" - "USD" -> "U.S. dollar" - "GBP" -> "British pound" - x -> x - -getBinfoAddrsParam :: - MonadIO m => - Text -> - WebT m (HashSet BinfoAddr) -getBinfoAddrsParam name = do - net <- lift (asks (storeNetwork . webStore . webConfig)) - p <- S.param (cs name) `S.rescue` const (return "") - if T.null p - then return HashSet.empty - else case parseBinfoAddr net p of - Nothing -> raise (UserError "invalid address") - Just xs -> return $ HashSet.fromList xs - -getBinfoActive :: - MonadIO m => - WebT m (HashSet XPubSpec, HashSet Address) -getBinfoActive = do - active <- getBinfoAddrsParam "active" - p2sh <- getBinfoAddrsParam "activeP2SH" - bech32 <- getBinfoAddrsParam "activeBech32" - let xspec d b = (`XPubSpec` d) <$> xpub b - xspecs = - HashSet.fromList $ - concat - [ mapMaybe (xspec DeriveNormal) (HashSet.toList active), - mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh), - mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32) - ] - addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active - return (xspecs, addrs) - where - addr (BinfoAddr a) = Just a - addr (BinfoXpub _) = Nothing - xpub (BinfoXpub x) = Just x - xpub (BinfoAddr _) = Nothing - -getNumTxId :: MonadIO m => WebT m Bool -getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False) - -getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight -getChainHeight = do - ch <- lift $ asks (storeChain . webStore . webConfig) - H.nodeHeight <$> chainGetBest ch - -scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoUnspent = do - setMetrics statBlockchainUnspent - (xspecs, addrs) <- getBinfoActive - numtxid <- getNumTxId - limit <- get_limit - min_conf <- get_min_conf - net <- lift $ asks (storeNetwork . webStore . webConfig) - height <- getChainHeight - let mn BinfoUnspent {..} = min_conf > getBinfoUnspentConfirmations - xbals <- lift $ getXBals xspecs - addItemCount . sum . map length $ HashMap.elems xbals - counter <- getItemCounter - bus <- - lift . runConduit $ - getBinfoUnspents counter numtxid height xbals xspecs addrs - .| (dropWhileC mn >> takeC limit .| sinkList) - setHeaders - streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus)) - where - get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250) - get_min_conf = S.param "confirmations" `S.rescue` const (return 0) - -getBinfoUnspents :: - (StoreReadExtra m, MonadIO m) => - (Int -> m ()) -> - Bool -> - H.BlockHeight -> - HashMap XPubSpec [XPubBal] -> - HashSet XPubSpec -> - HashSet Address -> - ConduitT () BinfoUnspent m () -getBinfoUnspents counter numtxid height xbals xspecs addrs = do - cs' <- conduits - joinDescStreams cs' .| mapC (uncurry binfo) - where - binfo Unspent {..} xp = - let conf = case unspentBlock of - MemRef {} -> 0 - BlockRef h _ -> height - h + 1 - hash = outPointHash unspentPoint - idx = outPointIndex unspentPoint - val = unspentAmount - script = unspentScript - txi = encodeBinfoTxId numtxid hash - in BinfoUnspent - { getBinfoUnspentHash = hash, - getBinfoUnspentOutputIndex = idx, - getBinfoUnspentScript = script, - getBinfoUnspentValue = val, - getBinfoUnspentConfirmations = fromIntegral conf, - getBinfoUnspentTxIndex = txi, - getBinfoUnspentXPub = xp - } - conduits = (<>) <$> xconduits <*> pure acounduits - xconduits = lift $ do - let f x (XPubUnspent u p) = - let path = toSoft (listToPath p) - xp = BinfoXPubPath (xPubSpecKey x) <$> path - in (u, xp) - g x = do - return $ - streamThings - ( \l -> do - us <- xPubUnspents x (xBals x xbals) l - counter (length us) - return us - ) - Nothing - def {limit = 16} - .| mapC (f x) - mapM g (HashSet.toList xspecs) - acounduits = - let f u = (u, Nothing) - g a = - streamThings - ( \l -> do - us <- getAddressUnspents a l - counter (length us) - return us - ) - Nothing - def {limit = 16} - .| mapC f - in map g (HashSet.toList addrs) - -getXBals :: StoreReadExtra m => HashSet XPubSpec -> m (HashMap XPubSpec [XPubBal]) -getXBals = - fmap HashMap.fromList - . mapM - ( \x -> - (x,) . filter (not . nullBalance . xPubBal) - <$> (xPubBals x) - ) - . HashSet.toList - -xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal] -xBals = HashMap.findWithDefault [] - -getBinfoTxs :: - (StoreReadExtra m, MonadIO m) => - (Int -> m ()) -> -- counter - HashMap XPubSpec [XPubBal] -> -- xpub balances - HashMap Address (Maybe BinfoXPubPath) -> -- address book - HashSet XPubSpec -> -- show xpubs - HashSet Address -> -- show addrs - HashSet Address -> -- balance addresses - BinfoFilter -> - Bool -> -- numtxid - Bool -> -- prune outputs - Int64 -> -- starting balance - ConduitT () BinfoTx m () -getBinfoTxs - counter - xbals - abook - sxspecs - saddrs - baddrs - bfilter - numtxid - prune - bal = do - cs' <- conduits - joinDescStreams cs' .| go bal - where - sxspecs_ls = HashSet.toList sxspecs - saddrs_ls = HashSet.toList saddrs - conduits = (<>) <$> mapM xpub_c sxspecs_ls <*> pure (map addr_c saddrs_ls) - xpub_c x = - lift . return $ - streamThings - ( \l -> do - ts <- xPubTxs x (xBals x xbals) l - counter (length ts) - return ts - ) - (Just txRefHash) - def {limit = 16} - addr_c a = - streamThings - ( \l -> do - as <- getAddressTxs a l - counter (length as) - return as - ) - (Just txRefHash) - def {limit = 16} - binfo_tx b = toBinfoTx numtxid abook prune b - compute_bal_change BinfoTx {..} = - let ins = map getBinfoTxInputPrevOut getBinfoTxInputs - out = getBinfoTxOutputs - f b BinfoTxOutput {..} = - let val = fromIntegral getBinfoTxOutputValue - in case getBinfoTxOutputAddress of - Nothing -> 0 - Just a - | a `HashSet.member` baddrs -> - if b then val else negate val - | otherwise -> 0 - in sum $ map (f False) ins <> map (f True) out - go b = - await >>= \case - Nothing -> return () - Just (TxRef _ t) -> - lift (getTransaction t) >>= \case - Nothing -> go b - Just x -> do - lift $ counter 1 - let a = binfo_tx b x - b' = b - compute_bal_change a - c = isJust (getBinfoTxBlockHeight a) - Just (d, _) = getBinfoTxResultBal a - r = d + fromIntegral (getBinfoTxFee a) - case bfilter of - BinfoFilterAll -> - yield a >> go b' - BinfoFilterSent - | 0 > r -> yield a >> go b' - | otherwise -> go b' - BinfoFilterReceived - | r > 0 -> yield a >> go b' - | otherwise -> go b' - BinfoFilterMoved - | r == 0 -> yield a >> go b' - | otherwise -> go b' - BinfoFilterConfirmed - | c -> yield a >> go b' - | otherwise -> go b' - BinfoFilterMempool - | c -> return () - | otherwise -> yield a >> go b' - -getCashAddr :: Monad m => WebT m Bool -getCashAddr = S.param "cashaddr" `S.rescue` const (return False) - -getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address -getAddress param' = do - txt <- S.param param' - net <- lift $ asks (storeNetwork . webStore . webConfig) - case textToAddr net txt of - Nothing -> raise ThingNotFound - Just a -> return a - -getBinfoAddr :: Monad m => TL.Text -> WebT m BinfoAddr -getBinfoAddr param' = do - txt <- S.param param' - net <- lift $ asks (storeNetwork . webStore . webConfig) - let x = - BinfoAddr <$> textToAddr net txt - <|> BinfoXpub <$> xPubImport net txt - maybe S.next return x - -scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoHistory = do - setMetrics statBlockchainExportHistory - (xspecs, addrs) <- getBinfoActive - (startM, endM) <- get_dates - (code, price') <- getPrice - xbals <- getXBals xspecs - addItemCount . sum . map length $ HashMap.elems xbals - counter <- getItemCounter - let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) - aaddrs = xaddrs <> addrs - cur = binfoTicker15m price' - cs' = conduits counter (HashMap.toList xbals) addrs endM - txs <- - lift . runConduit $ - joinDescStreams cs' - .| takeWhileC (is_newer startM) - .| concatMapMC get_transaction - .| sinkList - addItemCount (length txs) - let times = map transactionTime txs - net <- lift $ asks (storeNetwork . webStore . webConfig) - url <- lift $ asks (webHistoryURL . webConfig) - session <- lift $ asks webWreqSession - rates <- map binfoRatePrice <$> lift (getRates net session url code times) - addItemCount (length rates) - let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) - setHeaders - streamEncoding $ toEncoding hs - where - is_newer (Just BlockData {..}) TxRef {txRefBlock = BlockRef {..}} = - blockRefHeight >= blockDataHeight - is_newer _ _ = True - get_addr = balanceAddress . xPubBal - get_transaction TxRef {txRefHash = h} = - getTransaction h - convert cur addrs tx rate = - let ins = transactionInputs tx - outs = transactionOutputs tx - fins = filter (input_addr addrs) ins - fouts = filter (output_addr addrs) outs - vin = fromIntegral . sum $ map inputAmount fins - vout = fromIntegral . sum $ map outputAmount fouts - fee = transactionFees tx - v = vout - vin - t = transactionTime tx - h = txHash $ transactionData tx - in toBinfoHistory v t rate cur fee h - input_addr addrs' StoreInput {inputAddress = Just a} = - a `HashSet.member` addrs' - input_addr _ _ = False - output_addr addrs' StoreOutput {outputAddr = Just a} = - a `HashSet.member` addrs' - output_addr _ _ = False - get_dates = do - BinfoDate start <- S.param "start" - BinfoDate end' <- S.param "end" - let end = end' + 24 * 60 * 60 - ch <- lift $ asks (storeChain . webStore . webConfig) - startM <- blockAtOrAfter ch start - endM <- blockAtOrBefore ch end - return (startM, endM) - conduits counter xpubs addrs endM = - map (uncurry (xpub_c counter endM)) xpubs - <> map (addr_c counter endM) (HashSet.toList addrs) - addr_c counter endM a = - streamThings - ( \l -> do - ts <- getAddressTxs a l - counter (length ts) - return ts - ) - (Just txRefHash) - def - { limit = 16, - start = AtBlock . blockDataHeight <$> endM - } - xpub_c counter endM x bs = - streamThings - ( \l -> do - ts <- xPubTxs x bs l - counter (length ts) - return ts - ) - (Just txRefHash) - def - { limit = 16, - start = AtBlock . blockDataHeight <$> endM - } - -getPrice :: MonadIO m => WebT m (Text, BinfoTicker) -getPrice = do - code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD") - ticker <- lift $ asks webTicker - prices <- readTVarIO ticker - case HashMap.lookup code prices of - Nothing -> return (code, def) - Just p -> return (code, p) - -getSymbol :: MonadIO m => WebT m BinfoSymbol -getSymbol = uncurry binfoTickerToSymbol <$> getPrice - -scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoBlocksDay = do - setMetrics statBlockchainBlocks - t <- min h . (`div` 1000) <$> S.param "milliseconds" - ch <- lift $ asks (storeChain . webStore . webConfig) - m <- blockAtOrBefore ch t - bs <- go (d t) m - addItemCount (length bs) - streamEncoding $ toEncoding $ map toBinfoBlockInfo bs - where - h = fromIntegral (maxBound :: H.Timestamp) - d = subtract (24 * 3600) - go _ Nothing = return [] - go t (Just b) - | H.blockTimestamp (blockDataHeader b) <= fromIntegral t = - return [] - | otherwise = do - b' <- getBlock (H.prevBlock (blockDataHeader b)) - (b :) <$> go t b' - -scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyMultiAddr = do - setMetrics statBlockchainMultiaddr - (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs - numtxid <- getNumTxId - cashaddr <- getCashAddr - local' <- getSymbol - offset <- getBinfoOffset - n <- getBinfoCount "n" - prune <- get_prune - fltr <- get_filter - xbals <- getXBals xspecs - addItemCount . sum . map length $ HashMap.elems xbals - xtxns <- get_xpub_tx_count xbals xspecs - addItemCount (length xtxns) - let sxbals = only_show_xbals sxpubs xbals - xabals = compute_xabals xbals - addrs = addrs' `HashSet.difference` HashMap.keysSet xabals - abals <- get_abals addrs - addItemCount (length abals) - let sxspecs = only_show_xspecs sxpubs xspecs - sxabals = compute_xabals sxbals - sabals = only_show_abals saddrs abals - sallbals = sabals <> sxabals - sbal = compute_bal sallbals - allbals = abals <> xabals - abook = compute_abook addrs xbals - sxaddrs = compute_xaddrs sxbals - salladdrs = saddrs <> sxaddrs - bal = compute_bal allbals - ibal = fromIntegral sbal - counter <- getItemCounter - ftxs <- - lift . runConduit $ - getBinfoTxs - counter - xbals - abook - sxspecs - saddrs - salladdrs - fltr - numtxid - prune - ibal - .| (dropC offset >> takeC n .| sinkList) - best <- get_best_block - addItemCount 1 - peers <- get_peers - addItemCount (fromIntegral peers) - net <- lift $ asks (storeNetwork . webStore . webConfig) - let baddrs = toBinfoAddrs sabals sxbals xtxns - abaddrs = toBinfoAddrs abals xbals xtxns - recv = sum $ map getBinfoAddrReceived abaddrs - sent' = sum $ map getBinfoAddrSent abaddrs - txn = fromIntegral $ length ftxs - wallet = - BinfoWallet - { getBinfoWalletBalance = bal, - getBinfoWalletTxCount = txn, - getBinfoWalletFilteredCount = txn, - getBinfoWalletTotalReceived = recv, - getBinfoWalletTotalSent = sent' - } - coin = netBinfoSymbol net - block = - BinfoBlockInfo - { getBinfoBlockInfoHash = H.headerHash (blockDataHeader best), - getBinfoBlockInfoHeight = blockDataHeight best, - getBinfoBlockInfoTime = H.blockTimestamp (blockDataHeader best), - getBinfoBlockInfoIndex = blockDataHeight best - } - info = - BinfoInfo - { getBinfoConnected = peers, - getBinfoConversion = 100 * 1000 * 1000, - getBinfoLocal = local', - getBinfoBTC = coin, - getBinfoLatestBlock = block - } - setHeaders - streamEncoding $ - binfoMultiAddrToEncoding - net - BinfoMultiAddr - { getBinfoMultiAddrAddresses = baddrs, - getBinfoMultiAddrWallet = wallet, - getBinfoMultiAddrTxs = ftxs, - getBinfoMultiAddrInfo = info, - getBinfoMultiAddrRecommendFee = True, - getBinfoMultiAddrCashAddr = cashaddr - } - where - get_xpub_tx_count xbals = - fmap HashMap.fromList - . mapM - ( \x -> - (x,) - . fromIntegral - <$> xPubTxCount x (xBals x xbals) - ) - . HashSet.toList - get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll) - get_best_block = - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bh -> - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> return b - get_prune = - fmap not $ - S.param "no_compact" - `S.rescue` const (return False) - only_show_xbals sxpubs = HashMap.filterWithKey (\k _ -> xPubSpecKey k `HashSet.member` sxpubs) - only_show_xspecs sxpubs = HashSet.filter (\k -> xPubSpecKey k `HashSet.member` sxpubs) - only_show_abals saddrs = HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs) - addr (BinfoAddr a) = Just a - addr (BinfoXpub _) = Nothing - xpub (BinfoXpub x) = Just x - xpub (BinfoAddr _) = Nothing - get_addrs = do - (xspecs, addrs) <- getBinfoActive - sh <- getBinfoAddrsParam "onlyShow" - let xpubs = HashSet.map xPubSpecKey xspecs - actives = - HashSet.map BinfoAddr addrs - <> HashSet.map BinfoXpub xpubs - sh' = if HashSet.null sh then actives else sh - saddrs = HashSet.fromList . mapMaybe addr $ HashSet.toList sh' - sxpubs = HashSet.fromList . mapMaybe xpub $ HashSet.toList sh' - return (addrs, xpubs, saddrs, sxpubs, xspecs) - get_abals = - let f b = (balanceAddress b, b) - g = HashMap.fromList . map f - in fmap g . getBalances . HashSet.toList - get_peers = do - ps <- - lift $ - getPeersInformation - =<< asks (storeManager . webStore . webConfig) - return (fromIntegral (length ps)) - compute_xabals = - let f b = (balanceAddress (xPubBal b), xPubBal b) - in HashMap.fromList . concatMap (map f) . HashMap.elems - compute_bal = - let f b = balanceAmount b + balanceZero b - in sum . map f . HashMap.elems - compute_abook addrs xbals = - let f XPubSpec {..} XPubBal {..} = - let a = balanceAddress xPubBal - e = error "lions and tigers and bears" - s = toSoft (listToPath xPubBalPath) - in (a, Just (BinfoXPubPath xPubSpecKey (fromMaybe e s))) - amap = - HashMap.map (const Nothing) $ - HashSet.toMap addrs - xmap = - HashMap.fromList - . concatMap (uncurry (map . f)) - $ HashMap.toList xbals - in amap <> xmap - compute_xaddrs = - let f = map (balanceAddress . xPubBal) - in HashSet.fromList . concatMap f . HashMap.elems - -getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int -getBinfoCount str = do - d <- lift (asks (maxLimitDefault . webMaxLimits . webConfig)) - x <- lift (asks (maxLimitFull . webMaxLimits . webConfig)) - i <- min x <$> (S.param str `S.rescue` const (return d)) - return (fromIntegral i :: Int) - -getBinfoOffset :: - (MonadUnliftIO m, MonadLoggerIO m) => - WebT m Int -getBinfoOffset = do - x <- lift (asks (maxLimitOffset . webMaxLimits . webConfig)) - o <- S.param "offset" `S.rescue` const (return 0) - when (o > x) $ - raise $ - UserError $ - "offset exceeded: " <> show o <> " > " <> show x - return (fromIntegral o :: Int) - -scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyRawAddr = - setMetrics statBlockchainRawaddr - >> getBinfoAddr "addr" - >>= \case - BinfoAddr addr -> do_addr addr - BinfoXpub xpub -> do_xpub xpub - where - do_xpub xpub = do - numtxid <- getNumTxId - derive <- S.param "derive" `S.rescue` const (return DeriveNormal) - let xspec = XPubSpec xpub derive - n <- getBinfoCount "limit" - off <- getBinfoOffset - xbals <- getXBals $ HashSet.singleton xspec - addItemCount . sum . map length $ HashMap.elems xbals - net <- lift $ asks (storeNetwork . webStore . webConfig) - let summary = xPubSummary xspec (xBals xspec xbals) - abook = compute_abook xpub (xBals xspec xbals) - xspecs = HashSet.singleton xspec - saddrs = HashSet.empty - baddrs = HashMap.keysSet abook - bfilter = BinfoFilterAll - amnt = - xPubSummaryConfirmed summary - + xPubSummaryZero summary - counter <- getItemCounter - txs <- - lift . runConduit $ - getBinfoTxs - counter - xbals - abook - xspecs - saddrs - baddrs - bfilter - numtxid - False - (fromIntegral amnt) - .| (dropC off >> takeC n .| sinkList) - let ra = - BinfoRawAddr - { binfoRawAddr = BinfoXpub xpub, - binfoRawBalance = amnt, - binfoRawTxCount = fromIntegral $ length txs, - binfoRawUnredeemed = xPubUnspentCount summary, - binfoRawReceived = xPubSummaryReceived summary, - binfoRawSent = - fromIntegral (xPubSummaryReceived summary) - - fromIntegral amnt, - binfoRawTxs = txs - } - setHeaders - streamEncoding $ binfoRawAddrToEncoding net ra - compute_abook xpub xbals = - let f XPubBal {..} = - let a = balanceAddress xPubBal - e = error "black hole swallows all your code" - s = toSoft (listToPath xPubBalPath) - m = fromMaybe e s - in (a, Just (BinfoXPubPath xpub m)) - in HashMap.fromList $ map f xbals - do_addr addr = do - numtxid <- getNumTxId - n <- getBinfoCount "limit" - off <- getBinfoOffset - bal <- fromMaybe (zeroBalance addr) <$> getBalance addr - addItemCount 1 - net <- lift $ asks (storeNetwork . webStore . webConfig) - let abook = HashMap.singleton addr Nothing - xspecs = HashSet.empty - saddrs = HashSet.singleton addr - bfilter = BinfoFilterAll - amnt = balanceAmount bal + balanceZero bal - counter <- getItemCounter - txs <- - lift . runConduit $ - getBinfoTxs - counter - HashMap.empty - abook - xspecs - saddrs - saddrs - bfilter - numtxid - False - (fromIntegral amnt) - .| (dropC off >> takeC n .| sinkList) - let ra = - BinfoRawAddr - { binfoRawAddr = BinfoAddr addr, - binfoRawBalance = amnt, - binfoRawTxCount = balanceTxCount bal, - binfoRawUnredeemed = balanceUnspentCount bal, - binfoRawReceived = balanceTotalReceived bal, - binfoRawSent = - fromIntegral (balanceTotalReceived bal) - - fromIntegral amnt, - binfoRawTxs = txs - } - setHeaders - streamEncoding $ binfoRawAddrToEncoding net ra - -scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoReceived = do - setMetrics statBlockchainQgetreceivedbyaddress - a <- getAddress "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - addItemCount 1 - S.text . cs . show $ balanceTotalReceived b - -scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoSent = do - setMetrics statBlockchainQgetsentbyaddress - a <- getAddress "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - addItemCount 1 - S.text . cs . show $ balanceTotalReceived b - balanceAmount b - balanceZero b - -scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoAddrBalance = do - setMetrics statBlockchainQaddressbalance - a <- getAddress "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - addItemCount 1 - S.text . cs . show $ balanceAmount b + balanceZero b - -scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyFirstSeen = do - setMetrics statBlockchainQaddressfirstseen - a <- getAddress "addr" - ch <- lift $ asks (storeChain . webStore . webConfig) - bb <- chainGetBest ch - let top = H.nodeHeight bb - bot = 0 - i <- go ch bb a bot top - setHeaders - addItemCount 1 - S.text . cs $ show i - where - go ch bb a bot top = do - let mid = bot + (top - bot) `div` 2 - n = top - bot < 2 - x <- hasone a bot - y <- hasone a mid - z <- hasone a top - if - | x -> getblocktime ch bb bot - | n -> getblocktime ch bb top - | y -> go ch bb a bot mid - | z -> go ch bb a mid top - | otherwise -> return 0 - getblocktime ch bb h = - H.blockTimestamp . H.nodeHeader . fromJust - <$> chainGetAncestor h bb ch - hasone a h = do - let l = Limits 1 0 (Just (AtBlock h)) - not . null <$> getAddressTxs a l - -scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyShortBal = do - setMetrics statBlockchainBalance - (xspecs, addrs) <- getBinfoActive - cashaddr <- getCashAddr - net <- lift $ asks (storeNetwork . webStore . webConfig) - abals <- - catMaybes - <$> mapM (get_addr_balance net cashaddr) (HashSet.toList addrs) - addItemCount (length abals) - xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs) - let res = HashMap.fromList (abals <> xbals) - setHeaders - streamEncoding $ toEncoding res - where - to_short_bal Balance {..} = - BinfoShortBal - { binfoShortBalFinal = balanceAmount + balanceZero, - binfoShortBalTxCount = balanceTxCount, - binfoShortBalReceived = balanceTotalReceived - } - get_addr_balance net cashaddr a = - let net' = - if - | cashaddr -> net - | net == bch -> btc - | net == bchTest -> btcTest - | net == bchTest4 -> btcTest - | otherwise -> net - in case addrToText net' a of - Nothing -> return Nothing - Just a' -> - getBalance a >>= \case - Nothing -> return $ Just (a', to_short_bal (zeroBalance a)) - Just b -> return $ Just (a', to_short_bal b) - is_ext XPubBal {xPubBalPath = 0 : _} = True - is_ext _ = False - get_xspec_balance net xpub = do - xbals <- xPubBals xpub - xts <- xPubTxCount xpub xbals - addItemCount (length xbals + 1) - let val = sum $ map (balanceAmount . xPubBal) xbals - zro = sum $ map (balanceZero . xPubBal) xbals - exs = filter is_ext xbals - rcv = sum $ map (balanceTotalReceived . xPubBal) exs - sbl = - BinfoShortBal - { binfoShortBalFinal = val + zro, - binfoShortBalTxCount = fromIntegral xts, - binfoShortBalReceived = rcv - } - return (xPubExport net (xPubSpecKey xpub), sbl) - -getBinfoHex :: Monad m => WebT m Bool -getBinfoHex = - (== ("hex" :: Text)) - <$> S.param "format" `S.rescue` const (return "json") - -scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoBlockHeight = do - numtxid <- getNumTxId - height <- S.param "height" - setMetrics statBlockchainBlockHeight - block_hashes <- getBlocksAtHeight height - block_headers <- catMaybes <$> mapM getBlock block_hashes - addItemCount (length block_headers) - next_block_hashes <- getBlocksAtHeight (height + 1) - next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes - addItemCount (length next_block_headers) - binfo_blocks <- - mapM (get_binfo_blocks numtxid next_block_headers) block_headers - setHeaders - net <- lift $ asks (storeNetwork . webStore . webConfig) - streamEncoding $ binfoBlocksToEncoding net binfo_blocks - where - get_tx th = - withRunInIO $ \run -> - unsafeInterleaveIO $ - run $ - fromJust <$> getTransaction th - get_binfo_blocks numtxid next_block_headers block_header = do - let my_hash = H.headerHash (blockDataHeader block_header) - get_prev = H.prevBlock . blockDataHeader - get_hash = H.headerHash . blockDataHeader - txs <- lift $ mapM get_tx (blockDataTxs block_header) - addItemCount (length txs) - let next_blocks = - map get_hash $ - filter - ((== my_hash) . get_prev) - next_block_headers - binfo_txs = map (toBinfoTxSimple numtxid) txs - binfo_block = toBinfoBlock block_header binfo_txs next_blocks - return binfo_block - -scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoLatest = do - numtxid <- getNumTxId - setMetrics statBlockchainLatestblock - best <- get_best_block - let binfoTxIndices = map (encodeBinfoTxId numtxid) (blockDataTxs best) - binfoHeaderHash = H.headerHash (blockDataHeader best) - binfoHeaderTime = H.blockTimestamp (blockDataHeader best) - binfoHeaderIndex = binfoHeaderTime - binfoHeaderHeight = blockDataHeight best - addItemCount 1 - streamEncoding $ toEncoding BinfoHeader {..} - where - get_best_block = - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bh -> - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> return b - -scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoBlock = do - numtxid <- getNumTxId - hex <- getBinfoHex - setMetrics statBlockchainRawblock - S.param "block" >>= \case - BinfoBlockHash bh -> go numtxid hex bh - BinfoBlockIndex i -> - getBlocksAtHeight i >>= \case - [] -> raise ThingNotFound - bh : _ -> go numtxid hex bh - where - get_tx th = - withRunInIO $ \run -> - unsafeInterleaveIO $ - run $ - fromJust <$> getTransaction th - go numtxid hex bh = - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - txs <- lift $ mapM get_tx (blockDataTxs b) - addItemCount (length txs) - let my_hash = H.headerHash (blockDataHeader b) - get_prev = H.prevBlock . blockDataHeader - get_hash = H.headerHash . blockDataHeader - nxt_headers <- - fmap catMaybes $ - mapM getBlock - =<< getBlocksAtHeight (blockDataHeight b + 1) - addItemCount (length nxt_headers) - let nxt = - map get_hash $ - filter - ((== my_hash) . get_prev) - nxt_headers - if hex - then do - let x = H.Block (blockDataHeader b) (map transactionData txs) - setHeaders - S.text . encodeHexLazy . runPutL $ serialize x - else do - let btxs = map (toBinfoTxSimple numtxid) txs - y = toBinfoBlock b btxs nxt - setHeaders - net <- lift $ asks (storeNetwork . webStore . webConfig) - streamEncoding $ binfoBlockToEncoding net y - -getBinfoTx :: - (MonadLoggerIO m, MonadUnliftIO m) => - BinfoTxId -> - WebT m (Either Except Transaction) -getBinfoTx txid = do - tx <- case txid of - BinfoTxIdHash h -> maybeToList <$> getTransaction h - BinfoTxIdIndex i -> getNumTransaction i - case tx of - [t] -> return $ Right t - [] -> return $ Left ThingNotFound - ts -> - let tids = map (txHash . transactionData) ts - in return $ Left (TxIndexConflict tids) - -scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTx = do - numtxid <- getNumTxId - hex <- getBinfoHex - txid <- S.param "txid" - setMetrics statBlockchainRawtx - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - addItemCount 1 - if hex then hx tx else js numtxid tx - where - js numtxid t = do - net <- lift $ asks (storeNetwork . webStore . webConfig) - setHeaders - streamEncoding $ binfoTxToEncoding net $ toBinfoTxSimple numtxid t - hx t = do - setHeaders - S.text . encodeHexLazy . runPutL . serialize $ transactionData t - -scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTotalOut = do - txid <- S.param "txid" - setMetrics statBlockchainQtxtotalbtcoutput - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - addItemCount 1 - S.text . cs . show . sum . map outputAmount $ transactionOutputs tx - -scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTxFees = do - txid <- S.param "txid" - setMetrics statBlockchainQtxfee - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - let i = - sum . map inputAmount . filter f $ - transactionInputs tx - o = sum . map outputAmount $ transactionOutputs tx - addItemCount 1 - S.text . cs . show $ i - o - where - f StoreInput {} = True - f StoreCoinbase {} = False - -scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTxResult = do - txid <- S.param "txid" - addr <- getAddress "addr" - setMetrics statBlockchainQtxresult - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - let i = - toInteger . sum . map inputAmount . filter (f addr) $ - transactionInputs tx - o = - toInteger . sum . map outputAmount . filter (g addr) $ - transactionOutputs tx - addItemCount 1 - S.text . cs . show $ o - i - where - f addr StoreInput {inputAddress = Just a} = a == addr - f _ _ = False - g addr StoreOutput {outputAddr = Just a} = a == addr - g _ _ = False - -scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTotalInput = do - txid <- S.param "txid" - setMetrics statBlockchainQtxtotalbtcinput - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - addItemCount 1 - S.text . cs . show . sum . map inputAmount . filter f $ transactionInputs tx - where - f StoreInput {} = True - f StoreCoinbase {} = False - -scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoMempool = do - setMetrics statBlockchainMempool - numtxid <- getNumTxId - offset <- getBinfoOffset - n <- getBinfoCount "limit" - mempool <- getMempool - let txids = map snd $ take n $ drop offset mempool - txs <- catMaybes <$> mapM getTransaction txids - net <- lift $ asks (storeNetwork . webStore . webConfig) - setHeaders - let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs - addItemCount (length txs) - streamEncoding $ binfoMempoolToEncoding net mem - -scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoGetBlockCount = do - setMetrics statBlockchainQgetblockcount - ch <- asks (storeChain . webStore . webConfig) - bn <- chainGetBest ch - setHeaders - addItemCount 1 - S.text . cs . show $ H.nodeHeight bn - -scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoLatestHash = do - setMetrics statBlockchainQlatesthash - ch <- asks (storeChain . webStore . webConfig) - bn <- chainGetBest ch - setHeaders - addItemCount 1 - S.text . TL.fromStrict . H.blockHashToHex . H.headerHash $ H.nodeHeader bn - -scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoSubsidy = do - setMetrics statBlockchainQbcperblock - ch <- asks (storeChain . webStore . webConfig) - net <- asks (storeNetwork . webStore . webConfig) - bn <- chainGetBest ch - setHeaders - addItemCount 1 - S.text . cs . show . (/ (100 * 1000 * 1000 :: Double)) . fromIntegral $ - H.computeSubsidy net (H.nodeHeight bn + 1) - -scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoAddrToHash = do - setMetrics statBlockchainQaddresstohash - addr <- getAddress "addr" - setHeaders - addItemCount 1 - S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr - -scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoHashToAddr = do - setMetrics statBlockchainQhashtoaddress - bs <- maybe S.next return . decodeHex =<< S.param "hash" - net <- asks (storeNetwork . webStore . webConfig) - hash <- either (const S.next) return (decode bs) - addr <- maybe S.next return (addrToText net (PubKeyAddress hash)) - setHeaders - addItemCount 1 - S.text $ TL.fromStrict addr - -scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoAddrPubkey = do - setMetrics statBlockchainQaddrpubkey - hex <- S.param "pubkey" - pubkey <- - maybe S.next (return . pubKeyAddr) $ - eitherToMaybe . runGetS deserialize =<< decodeHex hex - net <- lift $ asks (storeNetwork . webStore . webConfig) - setHeaders - case addrToText net pubkey of - Nothing -> raise ThingNotFound - Just a -> do - addItemCount 1 - S.text $ TL.fromStrict a - -scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoPubKeyAddr = do - setMetrics statBlockchainQpubkeyaddr - addr <- getAddress "addr" - mi <- strm addr - i <- case mi of - Nothing -> raise ThingNotFound - Just i -> return i - pk <- case extr addr i of - Left e -> raise $ UserError e - Right t -> return t - setHeaders - S.text $ encodeHexLazy $ L.fromStrict pk - where - strm addr = do - counter <- getItemCounter - runConduit $ - streamThings - ( \l -> do - ts <- getAddressTxs addr l - counter (length ts) - return ts - ) - (Just txRefHash) - def {limit = 8} - .| concatMapMC (getTransaction . txRefHash) - .| iterMC (\_ -> counter 1) - .| concatMapC (filter (inp addr) . transactionInputs) - .| headC - inp addr StoreInput {inputAddress = Just a} = a == addr - inp _ _ = False - extr addr StoreInput {inputSigScript, inputPkScript, inputWitness} = do - Script sig <- decode inputSigScript - Script pks <- decode inputPkScript - case addr of - PubKeyAddress {} -> - case sig of - [OP_PUSHDATA _ _, OP_PUSHDATA pub _] -> - Right pub - [OP_PUSHDATA _ _] -> - case pks of - [OP_PUSHDATA pub _, OP_CHECKSIG] -> - Right pub - _ -> Left "Could not parse scriptPubKey" - _ -> Left "Could not parse scriptSig" - WitnessPubKeyAddress {} -> - case inputWitness of - [_, pub] -> return pub - _ -> Left "Could not parse scriptPubKey" - _ -> Left "Address does not have public key" - extr _ _ = Left "Incorrect input type" - -scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoHashPubkey = do - setMetrics statBlockchainQhashpubkey - pkm <- (eitherToMaybe . runGetS deserialize <=< decodeHex) <$> S.param "pubkey" - addr <- case pkm of - Nothing -> raise $ UserError "Could not decode public key" - Just pk -> return $ pubKeyAddr pk - setHeaders - addItemCount 1 - S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr - --- GET Network Information -- - -scottyPeers :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetPeers -> - WebT m [PeerInformation] -scottyPeers _ = do - setMetrics statPeers - ps <- - lift $ - getPeersInformation - =<< asks (storeManager . webStore . webConfig) - addItemCount (length ps) - return ps - --- | Obtain information about connected peers from peer manager process. -getPeersInformation :: - MonadLoggerIO m => PeerManager -> m [PeerInformation] -getPeersInformation mgr = - mapMaybe toInfo <$> getPeers mgr - where - toInfo op = do - ver <- onlinePeerVersion op - let as = onlinePeerAddress op - ua = getVarString $ userAgent ver - vs = version ver - sv = services ver - rl = relay ver - return - PeerInformation - { peerUserAgent = ua, - peerAddress = show as, - peerVersion = vs, - peerServices = sv, - peerRelay = rl - } - -scottyHealth :: - (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck -scottyHealth _ = do - setMetrics statHealth - h <- asks webHealthCheck >>= readTVarIO - unless (isOK h) $ S.status status503 - addItemCount 1 - return h - -blockHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m BlockHealth -blockHealthCheck cfg = do - let ch = storeChain $ webStore cfg - blockHealthMaxDiff = fromIntegral $ webMaxDiff cfg - blockHealthHeaders <- - H.nodeHeight <$> chainGetBest ch - blockHealthBlocks <- - maybe 0 blockDataHeight - <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock) - return BlockHealth {..} - -lastBlockHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - Chain -> - WebTimeouts -> - m TimeHealth -lastBlockHealthCheck ch tos = do - n <- fromIntegral . systemSeconds <$> liftIO getSystemTime - t <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch - let timeHealthAge = n - t - timeHealthMax = fromIntegral $ blockTimeout tos - return TimeHealth {..} - -lastTxHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m TimeHealth -lastTxHealthCheck WebConfig {..} = do - n <- fromIntegral . systemSeconds <$> liftIO getSystemTime - b <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch - t <- - getMempool >>= \case - t : _ -> - let x = fromIntegral $ fst t - in return $ max x b - [] -> return b - let timeHealthAge = n - t - timeHealthMax = fromIntegral to - return TimeHealth {..} - where - ch = storeChain webStore - to = - if webNoMempool - then blockTimeout webTimeouts - else txTimeout webTimeouts - -pendingTxsHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m MaxHealth -pendingTxsHealthCheck cfg = do - let maxHealthMax = fromIntegral $ webMaxPending cfg - maxHealthNum <- - fromIntegral - <$> blockStorePendingTxs (storeBlock (webStore cfg)) - return MaxHealth {..} - -peerHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - PeerManager -> - m CountHealth -peerHealthCheck mgr = do - let countHealthMin = 1 - countHealthNum <- fromIntegral . length <$> getPeers mgr - return CountHealth {..} - -healthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m HealthCheck -healthCheck cfg@WebConfig {..} = do - healthBlocks <- blockHealthCheck cfg - healthLastBlock <- lastBlockHealthCheck (storeChain webStore) webTimeouts - healthLastTx <- lastTxHealthCheck cfg - healthPendingTxs <- pendingTxsHealthCheck cfg - healthPeers <- peerHealthCheck (storeManager webStore) - let healthNetwork = getNetworkName (storeNetwork webStore) - healthVersion = webVersion - hc = HealthCheck {..} - unless (isOK hc) $ do - let t = toStrict $ encodeToLazyText hc - $(logErrorS) "Web" $ "Health check failed: " <> t - return hc - -scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyDbStats = do - setMetrics statDbstats - setHeaders - db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig) - statsM <- lift (getProperty db Stats) - addItemCount 1 - S.text $ maybe "Could not get stats" cs statsM - ------------------------ --- Parameter Parsing -- ------------------------ - --- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on --- parse failure. -paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a) -paramOptional = go Proxy - where - go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a) - go proxy = do - net <- lift $ asks (storeNetwork . webStore . webConfig) - tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing) - case tsM of - Nothing -> return Nothing -- Parameter was not supplied - Just ts -> maybe (raise err) (return . Just) $ parseParam net ts - where - l = proxyLabel proxy - p = Just <$> S.param (cs l) - err = UserError $ "Unable to parse param " <> cs l - --- | Raises an exception if the parameter is not supplied -param :: (Param a, MonadIO m) => WebT m a -param = go Proxy - where - go :: (Param a, MonadIO m) => Proxy a -> WebT m a - go proxy = do - resM <- paramOptional - case resM of - Just res -> return res - _ -> - raise . UserError $ - "The param " <> cs (proxyLabel proxy) <> " was not defined" - --- | Returns the default value of a parameter if it is not supplied. Raises an --- exception on parse failure. -paramDef :: (Default a, Param a, MonadIO m) => WebT m a -paramDef = fromMaybe def <$> paramOptional - --- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is --- not supplied or if parsing fails. -paramLazy :: (Param a, MonadIO m) => WebT m a -paramLazy = do - resM <- paramOptional `S.rescue` const (return Nothing) - maybe S.next return resM - -parseBody :: (MonadIO m, Serial a) => WebT m a -parseBody = do - b <- L.toStrict <$> S.body - case hex b <> bin b of - Left _ -> raise $ UserError "Failed to parse request body" - Right x -> return x - where - bin = runGetS deserialize - hex b = case B16.decodeBase16 $ C.filter (not . isSpace) b of - Right x -> bin x - Left s -> Left (T.unpack s) - -parseOffset :: MonadIO m => WebT m OffsetParam -parseOffset = do - res@(OffsetParam o) <- paramDef - limits <- lift $ asks (webMaxLimits . webConfig) - when (maxLimitOffset limits > 0 && fromIntegral o > maxLimitOffset limits) $ - raise . UserError $ - "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits) - return res - -parseStart :: - (MonadUnliftIO m, MonadLoggerIO m) => - Maybe StartParam -> - WebT m (Maybe Start) -parseStart Nothing = return Nothing -parseStart (Just s) = - runMaybeT $ - case s of - StartParamHash {startParamHash = h} -> start_tx h <|> start_block h - StartParamHeight {startParamHeight = h} -> start_height h - StartParamTime {startParamTime = q} -> start_time q - where - start_height h = return $ AtBlock $ fromIntegral h - start_block h = do - b <- MaybeT $ getBlock (H.BlockHash h) - return $ AtBlock (blockDataHeight b) - start_tx h = do - _ <- MaybeT $ getTxData (TxHash h) - return $ AtTx (TxHash h) - start_time q = do - ch <- lift $ asks (storeChain . webStore . webConfig) - b <- MaybeT $ blockAtOrBefore ch q - let g = blockDataHeight b - return $ AtBlock g - -parseLimits :: MonadIO m => WebT m LimitsParam -parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional - -paramToLimits :: - (MonadUnliftIO m, MonadLoggerIO m) => - Bool -> - LimitsParam -> - WebT m Limits -paramToLimits full (LimitsParam limitM o startM) = do - wl <- lift $ asks (webMaxLimits . webConfig) - Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM - -validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32 -validateLimit wl full limitM = - f m $ maybe d (fromIntegral . getLimitParam) limitM - where - m - | full && maxLimitFull wl > 0 = maxLimitFull wl - | otherwise = maxLimitCount wl - d = maxLimitDefault wl - f a 0 = a - f 0 b = b - f a b = min a b - ---------------- --- Utilities -- ---------------- - -runInWebReader :: - MonadIO m => - CacheT (DatabaseReaderT m) a -> - ReaderT WebState m a -runInWebReader f = do - bdb <- asks (storeDB . webStore . webConfig) - mc <- asks (storeCache . webStore . webConfig) - lift $ runReaderT (withCache mc f) bdb - -runNoCache :: MonadIO m => Bool -> ReaderT WebState m a -> ReaderT WebState m a -runNoCache False f = f -runNoCache True f = local g f - where - g s = s {webConfig = h (webConfig s)} - h c = c {webStore = i (webStore c)} - i s = s {storeCache = Nothing} - -logIt :: - (MonadUnliftIO m, MonadLoggerIO m) => - Maybe WebMetrics -> - m Middleware -logIt metrics = do - runner <- askRunInIO - return $ \app req respond -> do - var <- newTVarIO B.empty - req' <- - let rb = req_body var (getRequestBodyChunk req) - rq = req {requestBody = rb} - in case metrics of - Nothing -> return rq - Just m -> do - stat_var <- newTVarIO Nothing - let vt = - V.insert (statKey m) stat_var $ - vault rq - return rq {vault = vt} - bracket start (end var runner req') $ \_ -> - app req' $ \res -> do - b <- readTVarIO var - let s = responseStatus res - msg = fmtReq b req' <> ": " <> fmtStatus s - if statusIsSuccessful s - then runner $ $(logDebugS) "Web" msg - else runner $ $(logErrorS) "Web" msg - respond res - where - start = systemToUTCTime <$> getSystemTime - req_body var old_body = do - b <- old_body - unless (B.null b) . atomically $ modifyTVar var (<> b) - return b - add_stat d s = do - addStatQuery s - addStatTime s d - end var runner req t1 = do - t2 <- systemToUTCTime <$> getSystemTime - let diff = round $ diffUTCTime t2 t1 * 1000 - case metrics of - Nothing -> return () - Just m -> do - let m_stat_var = V.lookup (statKey m) (vault req) - add_stat diff (statAll m) - case m_stat_var of - Nothing -> return () - Just stat_var -> - readTVarIO stat_var >>= \case - Nothing -> return () - Just f -> add_stat diff (f m) - when (diff > 10000) $ do - b <- readTVarIO var - runner $ - $(logWarnS) "Web" $ - "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req - -reqSizeLimit :: Integral i => i -> Middleware -reqSizeLimit i = requestSizeLimitMiddleware lim - where - max_len _req = return (Just (fromIntegral i)) - lim = - setOnLengthExceeded too_big $ - setMaxLengthForRequest - max_len - defaultRequestSizeLimitSettings - too_big _ = \_app _req send -> - send $ - waiExcept requestEntityTooLarge413 RequestTooLarge - -reqTimeout :: Integral i => i -> Middleware +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Haskoin.Store.Web + ( -- * Web + WebConfig (..), + Except (..), + WebLimits (..), + WebTimeouts (..), + runWeb, + ) +where + +import Conduit + ( ConduitT, + await, + concatMapC, + concatMapMC, + dropC, + dropWhileC, + headC, + iterMC, + mapC, + runConduit, + sinkList, + takeC, + takeWhileC, + yield, + (.|), + ) +import Control.Applicative ((<|>)) +import Control.Arrow (second) +import Control.Lens ((.~), (^.)) +import Control.Monad + ( forM_, + forever, + join, + unless, + when, + (<=<), + (>=>), + ) +import Control.Monad.Logger + ( MonadLoggerIO, + logDebugS, + logErrorS, + logWarnS, + ) +import Control.Monad.Reader + ( ReaderT, + asks, + local, + runReaderT, + ) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Control (liftWith, restoreT) +import Control.Monad.Trans.Maybe + ( MaybeT (..), + runMaybeT, + ) +import Data.Aeson + ( Encoding, + ToJSON (..), + Value, + ) +import Data.Aeson qualified as A +import Data.Aeson.Encode.Pretty + ( Config (..), + defConfig, + encodePretty', + ) +import Data.Aeson.Encoding + ( encodingToLazyByteString, + list, + ) +import Data.Aeson.Text (encodeToLazyText) +import Data.Base16.Types (assertBase16) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Base16 (decodeBase16, isBase16) +import Data.ByteString.Builder (byteString, lazyByteString) +import Data.ByteString.Char8 qualified as C +import Data.ByteString.Lazy qualified as L +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Char (isSpace) +import Data.Default (Default (..)) +import Data.Function ((&)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Int (Int64) +import Data.List (nub) +import Data.Maybe + ( catMaybes, + fromJust, + fromMaybe, + isJust, + mapMaybe, + maybeToList, + ) +import Data.Proxy (Proxy (..)) +import Data.Serialize (decode) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy qualified as TL +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Time.Clock.System + ( getSystemTime, + systemSeconds, + systemToUTCTime, + ) +import Data.Vault.Lazy qualified as V +import Data.Word (Word32, Word64) +import Database.RocksDB + ( Property (..), + getProperty, + ) +import GHC.RTS.Flags (ConcFlags (ConcFlags)) +import Haskoin.Address +import Haskoin.Block qualified as H +import Haskoin.Crypto.Hash (Hash160 (..)) +import Haskoin.Crypto.Keys +import Haskoin.Network +import Haskoin.Node + ( Chain, + OnlinePeer (..), + PeerMgr, + chainGetAncestor, + chainGetBest, + getPeers, + sendMessage, + ) +import Haskoin.Script +import Haskoin.Store.BlockStore +import Haskoin.Store.Cache +import Haskoin.Store.Common +import Haskoin.Store.Data +import Haskoin.Store.Database.Reader +import Haskoin.Store.Manager +import Haskoin.Store.Stats +import Haskoin.Store.WebCommon +import Haskoin.Transaction +import Haskoin.Util +import NQE + ( Inbox, + Publisher, + receive, + withSubscription, + ) +import Network.HTTP.Types + ( Status (..), + hContentType, + requestEntityTooLarge413, + status400, + status404, + status409, + status413, + status500, + status503, + statusIsClientError, + statusIsServerError, + statusIsSuccessful, + ) +import Network.Wai + ( Middleware, + Request (..), + Response, + getRequestBodyChunk, + responseLBS, + responseStatus, + ) +import Network.Wai qualified as S +import Network.Wai.Handler.Warp + ( defaultSettings, + setHost, + setPort, + ) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.Wai.Middleware.RequestSizeLimit +import Network.Wai.Middleware.Timeout +import Network.WebSockets + ( ServerApp, + acceptRequest, + defaultConnectionOptions, + pendingRequest, + rejectRequestWith, + requestPath, + sendTextData, + ) +import Network.WebSockets qualified as WebSockets +import Network.Wreq qualified as Wreq +import Network.Wreq.Session as Wreq (Session) +import Network.Wreq.Session qualified as Wreq.Session +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Metrics qualified as Metrics +import System.Metrics.Gauge qualified as Metrics (Gauge) +import System.Metrics.Gauge qualified as Metrics.Gauge +import UnliftIO + ( MonadIO, + MonadUnliftIO, + TVar, + askRunInIO, + atomically, + bracket, + bracket_, + handleAny, + liftIO, + modifyTVar, + newTVarIO, + readTVarIO, + timeout, + withAsync, + withRunInIO, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) +import Web.Scotty.Internal.Types (ActionT) +import Web.Scotty.Trans qualified as S + +type WebT m = ActionT Except (ReaderT WebState m) + +data WebLimits = WebLimits + { maxItemCount :: !Word32, + maxFullItemCount :: !Word32, + maxOffset :: !Word32, + defItemCount :: !Word32, + xpubGap :: !Word32, + xpubGapInit :: !Word32, + maxBodySize :: !Word32, + requestTimeout :: !Word32 + } + deriving (Eq, Show) + +instance Default WebLimits where + def = + WebLimits + { maxItemCount = 200000, + maxFullItemCount = 5000, + maxOffset = 50000, + defItemCount = 100, + xpubGap = 32, + xpubGapInit = 20, + maxBodySize = 1024 * 1024, + requestTimeout = 0 + } + +data WebConfig = WebConfig + { host :: !String, + port :: !Int, + store :: !Store, + maxLaggingBlocks :: !Int, + maxPendingTxs :: !Int, + minPeers :: !Int, + limits :: !WebLimits, + timeouts :: !WebTimeouts, + version :: !String, + noMempool :: !Bool, + statsStore :: !(Maybe Metrics.Store), + tickerRefresh :: !Int, + tickerURL :: !String, + priceHistoryURL :: !String, + noSlow :: !Bool, + noBlockchainInfo :: !Bool, + healthCheckInterval :: !Int + } + +data WebState = WebState + { config :: !WebConfig, + ticker :: !(TVar (HashMap Text BinfoTicker)), + metrics :: !(Maybe WebMetrics), + session :: !Wreq.Session, + health :: !(TVar HealthCheck) + } + +data WebMetrics = WebMetrics + { all :: !StatDist, + -- Addresses + addressTx :: !StatDist, + addressTxFull :: !StatDist, + addressBalance :: !StatDist, + addressUnspent :: !StatDist, + xpub :: !StatDist, + xpubDelete :: !StatDist, + xpubTxFull :: !StatDist, + xpubTx :: !StatDist, + xpubBalance :: !StatDist, + xpubUnspent :: !StatDist, + -- Transactions + tx :: !StatDist, + txRaw :: !StatDist, + txAfter :: !StatDist, + txBlock :: !StatDist, + txBlockRaw :: !StatDist, + txPost :: !StatDist, + mempool :: !StatDist, + -- Blocks + block :: !StatDist, + blockRaw :: !StatDist, + -- Blockchain + binfoMultiaddr :: !StatDist, + binfoBalance :: !StatDist, + binfoAddressRaw :: !StatDist, + binfoUnspent :: !StatDist, + binfoTxRaw :: !StatDist, + binfoBlock :: !StatDist, + binfoBlockHeight :: !StatDist, + binfoBlockLatest :: !StatDist, + binfoBlockRaw :: !StatDist, + binfoMempool :: !StatDist, + binfoExportHistory :: !StatDist, + -- Blockchain /q endpoints + binfoQaddresstohash :: !StatDist, + binfoQhashtoaddress :: !StatDist, + binfoQaddrpubkey :: !StatDist, + binfoQpubkeyaddr :: !StatDist, + binfoQhashpubkey :: !StatDist, + binfoQgetblockcount :: !StatDist, + binfoQlatesthash :: !StatDist, + binfoQbcperblock :: !StatDist, + binfoQtxtotalbtcoutput :: !StatDist, + binfoQtxtotalbtcinput :: !StatDist, + binfoQtxfee :: !StatDist, + binfoQtxresult :: !StatDist, + binfoQgetreceivedbyaddress :: !StatDist, + binfoQgetsentbyaddress :: !StatDist, + binfoQaddressbalance :: !StatDist, + binfoQaddressfirstseen :: !StatDist, + -- Others + health :: !StatDist, + peers :: !StatDist, + db :: !StatDist, + events :: !Metrics.Gauge.Gauge, + -- Request + key :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist)))) + } + +createMetrics :: (MonadIO m) => Metrics.Store -> m WebMetrics +createMetrics s = liftIO $ do + all <- d "all" + + -- Addresses + addressTx <- d "address_transactions" + addressTxFull <- d "address_transactions_full" + addressBalance <- d "address_balance" + addressUnspent <- d "address_unspent" + xpub <- d "xpub" + xpubDelete <- d "xpub_delete" + xpubTxFull <- d "xpub_transactions_full" + xpubTx <- d "xpub_transactions" + xpubBalance <- d "xpub_balances" + xpubUnspent <- d "xpub_unspent" + + -- Transactions + tx <- d "transaction" + txRaw <- d "transaction_raw" + txAfter <- d "transaction_after" + txPost <- d "transaction_post" + txBlock <- d "transactions_block" + txBlockRaw <- d "transactions_block_raw" + mempool <- d "mempool" + + -- Blocks + block <- d "block" + blockRaw <- d "block_raw" + + -- Blockchain + binfoMultiaddr <- d "blockchain_multiaddr" + binfoBalance <- d "blockchain_balance" + binfoAddressRaw <- d "blockchain_rawaddr" + binfoUnspent <- d "blockchain_unspent" + binfoTxRaw <- d "blockchain_rawtx" + binfoBlock <- d "blockchain_blocks" + binfoBlockHeight <- d "blockchain_block_height" + binfoBlockLatest <- d "blockchain_latestblock" + binfoBlockRaw <- d "blockchain_rawblock" + binfoMempool <- d "blockchain_mempool" + binfoExportHistory <- d "blockchain_export_history" + + -- Blockchain /q endpoints + binfoQaddresstohash <- d "blockchain_q_addresstohash" + binfoQhashtoaddress <- d "blockchain_q_hashtoaddress" + binfoQaddrpubkey <- d "blockckhain_q_addrpubkey" + binfoQpubkeyaddr <- d "blockchain_q_pubkeyaddr" + binfoQhashpubkey <- d "blockchain_q_hashpubkey" + binfoQgetblockcount <- d "blockchain_q_getblockcount" + binfoQlatesthash <- d "blockchain_q_latesthash" + binfoQbcperblock <- d "blockchain_q_bcperblock" + binfoQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput" + binfoQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput" + binfoQtxfee <- d "blockchain_q_txfee" + binfoQtxresult <- d "blockchain_q_txresult" + binfoQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress" + binfoQgetsentbyaddress <- d "blockchain_q_getsentbyaddress" + binfoQaddressbalance <- d "blockchain_q_addressbalance" + binfoQaddressfirstseen <- d "blockchain_q_addressfirstseen" + + -- Others + health <- d "health" + peers <- d "peers" + db <- d "dbstats" + + events <- g "events_connected" + key <- V.newKey + return WebMetrics {..} + where + d x = createStatDist ("web." <> x) s + g x = Metrics.createGauge ("web." <> x) s + +withGaugeIO :: (MonadUnliftIO m) => Metrics.Gauge -> m a -> m a +withGaugeIO g = + bracket_ + (liftIO $ Metrics.Gauge.inc g) + (liftIO $ Metrics.Gauge.dec g) + +withGaugeIncrease :: + (MonadUnliftIO m) => + (WebMetrics -> Metrics.Gauge) -> + WebT m a -> + WebT m a +withGaugeIncrease gf go = + lift (asks (.metrics)) >>= \case + Nothing -> go + Just m -> do + s <- liftWith $ \run -> withGaugeIO (gf m) (run go) + restoreT $ return s + +setMetrics :: (MonadUnliftIO m) => (WebMetrics -> StatDist) -> WebT m () +setMetrics df = + asks (.metrics) >>= mapM_ go + where + go m = do + req <- S.request + let t = fromMaybe e $ V.lookup m.key (vault req) + atomically $ writeTVar t (Just df) + e = error "the ways of the warrior are yet to be mastered" + +addItemCount :: (MonadUnliftIO m) => Int -> WebT m () +addItemCount i = + asks (.metrics) >>= mapM_ \m -> do + addStatItems m.all (fromIntegral i) + req <- S.request + forM_ (V.lookup m.key (vault req)) $ + readTVarIO >=> mapM_ \s -> addStatItems (s m) (fromIntegral i) + +getItemCounter :: (MonadIO m, MonadIO n) => WebT m (Int -> n ()) +getItemCounter = + fromMaybe (\_ -> return ()) <$> runMaybeT do + q <- lift S.request + m <- MaybeT $ asks (.metrics) + t <- MaybeT . return $ V.lookup m.key (vault q) + s <- MaybeT $ readTVarIO t + return $ addStatItems (s m) . fromIntegral + +data WebTimeouts = WebTimeouts + { tx :: !Word64, + block :: !Word64 + } + deriving (Eq, Show) + +data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON + deriving (Eq, Show) + +instance Default WebTimeouts where + def = WebTimeouts {tx = 3600 `div` 2, block = 4 * 3600} + +instance + (MonadUnliftIO m, MonadLoggerIO m) => + StoreReadBase (ReaderT WebState m) + where + getCtx = runInWebReader getCtx + getNetwork = runInWebReader getNetwork + getBestBlock = runInWebReader getBestBlock + getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) + getBlock bh = runInWebReader (getBlock bh) + getTxData th = runInWebReader (getTxData th) + getSpender op = runInWebReader (getSpender op) + getUnspent op = runInWebReader (getUnspent op) + getBalance a = runInWebReader (getBalance a) + getMempool = runInWebReader getMempool + +instance + (MonadUnliftIO m, MonadLoggerIO m) => + StoreReadExtra (ReaderT WebState m) + where + getMaxGap = runInWebReader getMaxGap + getInitialGap = runInWebReader getInitialGap + getBalances as = runInWebReader (getBalances as) + getAddressesTxs as = runInWebReader . getAddressesTxs as + getAddressTxs a = runInWebReader . getAddressTxs a + getAddressUnspents a = runInWebReader . getAddressUnspents a + getAddressesUnspents as = runInWebReader . getAddressesUnspents as + xPubBals = runInWebReader . xPubBals + xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals + xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals + xPubTxCount xpub = runInWebReader . xPubTxCount xpub + getNumTxData = runInWebReader . getNumTxData + +instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where + getCtx = lift getCtx + getNetwork = lift getNetwork + getBestBlock = lift getBestBlock + getBlocksAtHeight = lift . getBlocksAtHeight + getBlock = lift . getBlock + getTxData = lift . getTxData + getSpender = lift . getSpender + getUnspent = lift . getUnspent + getBalance = lift . getBalance + getMempool = lift getMempool + +instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where + getBalances = lift . getBalances + getAddressesTxs as = lift . getAddressesTxs as + getAddressTxs a = lift . getAddressTxs a + getAddressUnspents a = lift . getAddressUnspents a + getAddressesUnspents as = lift . getAddressesUnspents as + xPubBals = lift . xPubBals + xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals + xPubTxs xpub xbals = lift . xPubTxs xpub xbals + xPubTxCount xpub = lift . xPubTxCount xpub + getMaxGap = lift getMaxGap + getInitialGap = lift getInitialGap + getNumTxData = lift . getNumTxData + +------------------- +-- Path Handlers -- +------------------- + +runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m () +runWeb config = do + ticker <- newTVarIO HashMap.empty + metrics <- mapM createMetrics config.statsStore + session <- liftIO Wreq.Session.newAPISession + health <- runHealthCheck >>= newTVarIO + let state = WebState {..} + withAsync (priceUpdater session ticker) $ \_a1 -> + withAsync (healthCheckLoop health) $ \_a2 -> do + logger <- logIt metrics + runner <- askRunInIO + S.scottyOptsT opts (runner . flip runReaderT state) $ do + S.middleware $ webSocketEvents state + S.middleware logger + S.middleware $ reqSizeLimit config.limits.maxBodySize + timeoutMiddleware + S.defaultHandler defHandler + handlePaths config + S.notFound $ raise ThingNotFound + where + priceUpdater session = + unless (config.noSlow || config.noBlockchainInfo) + . price + config.store.net + session + config.tickerURL + config.tickerRefresh + timeoutMiddleware = + when (config.limits.requestTimeout > 0) $ + S.middleware $ + reqTimeout config.limits.requestTimeout + runHealthCheck = runReaderT (healthCheck config) config.store.db + healthCheckLoop v = forever $ do + threadDelay (config.healthCheckInterval * 1000 * 1000) + runHealthCheck >>= atomically . writeTVar v + opts = def {S.settings = settings defaultSettings} + settings = setPort config.port . setHost (fromString config.host) + +getRates :: + (MonadUnliftIO m, MonadLoggerIO m) => + Network -> + Wreq.Session -> + String -> + Text -> + [Word64] -> + m [BinfoRate] +getRates net session url currency times = do + handleAny err $ do + r <- + liftIO $ + Wreq.asJSON + =<< Wreq.Session.postWith opts session url body + return $ r ^. Wreq.responseBody + where + err _ = do + $(logErrorS) "Web" "Could not get historic prices" + return [] + body = toJSON times + base = + Wreq.defaults + & Wreq.param "base" .~ [T.toUpper $ T.pack net.name] + opts = base & Wreq.param "quote" .~ [currency] + +price :: + (MonadUnliftIO m, MonadLoggerIO m) => + Network -> + Wreq.Session -> + String -> + Int -> + TVar (HashMap Text BinfoTicker) -> + m () +price net session url pget v = forM_ purl $ \u -> forever $ do + let err e = $(logErrorS) "Price" $ cs (show e) + handleAny err $ do + r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u + atomically . writeTVar v $ r ^. Wreq.responseBody + threadDelay pget + where + purl = case code of + Nothing -> Nothing + Just x -> Just (url <> "?base=" <> x) + where + code + | net == btc = Just "btc" + | net == bch = Just "bch" + | otherwise = Nothing + +raise :: (MonadIO m) => Except -> WebT m a +raise err = + lift (asks (.metrics)) >>= \case + Nothing -> S.raise err + Just m -> do + req <- S.request + mM <- case V.lookup m.key (vault req) of + Nothing -> return Nothing + Just t -> readTVarIO t + let status = errStatus err + if + | statusIsClientError status -> + liftIO $ do + addClientError m.all + forM_ mM $ \f -> addClientError (f m) + | statusIsServerError status -> + liftIO $ do + addServerError m.all + forM_ mM $ \f -> addServerError (f m) + | otherwise -> + return () + S.raise err + +errStatus :: Except -> Status +errStatus ThingNotFound = status404 +errStatus BadRequest = status400 +errStatus UserError {} = status400 +errStatus StringError {} = status400 +errStatus ServerError = status500 +errStatus TxIndexConflict {} = status409 +errStatus ServerTimeout = status500 +errStatus RequestTooLarge = status413 + +defHandler :: (Monad m) => Except -> WebT m () +defHandler e = do + setHeaders + S.status $ errStatus e + S.json e + +handlePaths :: + (MonadUnliftIO m, MonadLoggerIO m) => + WebConfig -> + S.ScottyT Except (ReaderT WebState m) () +handlePaths WebConfig {..} = do + -- Block Paths + pathCompact + (GetBlock <$> paramLazy <*> paramDef) + scottyBlock + (marshalEncoding net) + (marshalValue net) + pathCompact + (GetBlockBest <$> paramDef) + scottyBlockBest + (marshalEncoding net) + (marshalValue net) + pathCompact + (GetBlockHeight <$> paramLazy <*> paramDef) + (fmap SerialList . scottyBlockHeight) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetBlockTime <$> paramLazy <*> paramDef) + scottyBlockTime + (marshalEncoding net) + (marshalValue net) + pathCompact + (GetBlockMTP <$> paramLazy <*> paramDef) + scottyBlockMTP + (marshalEncoding net) + (marshalValue net) + pathCompact + (GetTx <$> paramLazy) + scottyTx + (marshalEncoding net) + (marshalValue net) + pathCompact + (GetTxRaw <$> paramLazy) + scottyTxRaw + toEncoding + toJSON + pathCompact + (PostTx <$> parseBody) + scottyPostTx + toEncoding + toJSON + pathCompact + (GetMempool <$> paramOptional <*> parseOffset) + (fmap SerialList . scottyMempool) + toEncoding + toJSON + pathCompact + (GetAddrTxs <$> paramLazy <*> parseLimits) + (fmap SerialList . scottyAddrTxs) + toEncoding + toJSON + pathCompact + (GetAddrBalance <$> paramLazy) + scottyAddrBalance + (marshalEncoding net) + (marshalValue net) + pathCompact + (GetAddrUnspent <$> paramLazy <*> parseLimits) + (fmap SerialList . scottyAddrUnspent) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetPeers & return) + (fmap SerialList . scottyPeers) + toEncoding + toJSON + pathCompact + (GetHealth & return) + scottyHealth + toEncoding + toJSON + S.get "/events" scottyEvents + S.get "/dbstats" scottyDbStats + unless noSlow $ do + pathCompact + (GetBlocks <$> param <*> paramDef) + (fmap SerialList . scottyBlocks) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetBlockRaw <$> paramLazy) + scottyBlockRaw + toEncoding + toJSON + pathCompact + (GetBlockBestRaw & return) + scottyBlockBestRaw + toEncoding + toJSON + pathCompact + (GetBlockLatest <$> paramDef) + (fmap SerialList . scottyBlockLatest) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetBlockHeights <$> param <*> paramDef) + (fmap SerialList . scottyBlockHeights) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetBlockHeightRaw <$> paramLazy) + scottyBlockHeightRaw + toEncoding + toJSON + pathCompact + (GetBlockTimeRaw <$> paramLazy) + scottyBlockTimeRaw + toEncoding + toJSON + pathCompact + (GetBlockMTPRaw <$> paramLazy) + scottyBlockMTPRaw + toEncoding + toJSON + pathCompact + (GetTxs <$> param) + (fmap SerialList . scottyTxs) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetTxsRaw <$> param) + scottyTxsRaw + toEncoding + toJSON + pathCompact + (GetTxsBlock <$> paramLazy) + (fmap SerialList . scottyTxsBlock) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetTxsBlockRaw <$> paramLazy) + scottyTxsBlockRaw + toEncoding + toJSON + pathCompact + (GetTxAfter <$> paramLazy <*> paramLazy) + scottyTxAfter + toEncoding + toJSON + pathCompact + (GetAddrsTxs <$> param <*> parseLimits) + (fmap SerialList . scottyAddrsTxs) + toEncoding + toJSON + pathCompact + (GetAddrTxsFull <$> paramLazy <*> parseLimits) + (fmap SerialList . scottyAddrTxsFull) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetAddrsTxsFull <$> param <*> parseLimits) + (fmap SerialList . scottyAddrsTxsFull) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetAddrsBalance <$> param) + (fmap SerialList . scottyAddrsBalance) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetAddrsUnspent <$> param <*> parseLimits) + (fmap SerialList . scottyAddrsUnspent) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetXPub <$> paramLazy <*> paramDef <*> paramDef) + scottyXPub + toEncoding + toJSON + pathCompact + (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) + (fmap SerialList . scottyXPubTxs) + toEncoding + toJSON + pathCompact + (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) + (fmap SerialList . scottyXPubTxsFull) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef) + (fmap SerialList . scottyXPubBalances) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) + (fmap SerialList . scottyXPubUnspent) + (list (marshalEncoding net) . (.get)) + (json_list (marshalValue net) . (.get)) + pathCompact + (DelCachedXPub <$> paramLazy <*> paramDef) + scottyDelXPub + toEncoding + toJSON + unless noBlockchainInfo $ do + S.post "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/balance" scottyShortBal + S.post "/blockchain/balance" scottyShortBal + S.get "/blockchain/rawaddr/:addr" scottyRawAddr + S.get "/blockchain/address/:addr" scottyRawAddr + S.get "/blockchain/xpub/:addr" scottyRawAddr + S.post "/blockchain/unspent" scottyBinfoUnspent + S.get "/blockchain/unspent" scottyBinfoUnspent + S.get "/blockchain/rawtx/:txid" scottyBinfoTx + S.get "/blockchain/rawblock/:block" scottyBinfoBlock + S.get "/blockchain/latestblock" scottyBinfoLatest + S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool + S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight + S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay + S.get "/blockchain/export-history" scottyBinfoHistory + S.post "/blockchain/export-history" scottyBinfoHistory + S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash + S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr + S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey + S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr + S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey + S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount + S.get "/blockchain/q/latesthash" scottyBinfoLatestHash + S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy + S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut + S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput + S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees + S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult + S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived + S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent + S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance + S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen + where + json_list f = toJSONList . map f + net = store.net + +pathCompact :: + (ApiResource a b, MonadIO m) => + WebT m a -> + (a -> WebT m b) -> + (b -> Encoding) -> + (b -> Value) -> + S.ScottyT Except (ReaderT WebState m) () +pathCompact parser action encJson encValue = + pathCommon parser action encJson encValue False + +pathCommon :: + (ApiResource a b, MonadIO m) => + WebT m a -> + (a -> WebT m b) -> + (b -> Encoding) -> + (b -> Value) -> + Bool -> + S.ScottyT Except (ReaderT WebState m) () +pathCommon parser action encJson encValue pretty = + S.addroute (resourceMethod proxy) (capturePath proxy) $ do + setHeaders + proto <- setupContentType pretty + apiRes <- parser + res <- action apiRes + S.raw $ protoSerial proto encJson encValue res + where + toProxy :: WebT m a -> Proxy a + toProxy = const Proxy + proxy = toProxy parser + +streamEncoding :: (Monad m) => Encoding -> WebT m () +streamEncoding e = do + S.setHeader "Content-Type" "application/json; charset=utf-8" + S.raw (encodingToLazyByteString e) + +protoSerial :: + (Serial a) => + SerialAs -> + (a -> Encoding) -> + (a -> Value) -> + a -> + L.ByteString +protoSerial SerialAsBinary _ _ = runPutL . serialize +protoSerial SerialAsJSON f _ = encodingToLazyByteString . f +protoSerial SerialAsPrettyJSON _ g = + encodePretty' defConfig {confTrailingNewline = True} . g + +setHeaders :: (Monad m, S.ScottyError e) => ActionT e m () +setHeaders = S.setHeader "Access-Control-Allow-Origin" "*" + +waiExcept :: Status -> Except -> Response +waiExcept s e = + responseLBS s hs e' + where + hs = + [ ("Access-Control-Allow-Origin", "*"), + ("Content-Type", "application/json") + ] + e' = A.encode e + +setupJSON :: (Monad m) => Bool -> ActionT Except m SerialAs +setupJSON pretty = do + S.setHeader "Content-Type" "application/json" + p <- S.param "pretty" `S.rescue` const (return pretty) + return $ if p then SerialAsPrettyJSON else SerialAsJSON + +setupBinary :: (Monad m) => ActionT Except m SerialAs +setupBinary = do + S.setHeader "Content-Type" "application/octet-stream" + return SerialAsBinary + +setupContentType :: (Monad m) => Bool -> ActionT Except m SerialAs +setupContentType pretty = do + accept <- S.header "accept" + maybe (setupJSON pretty) setType accept + where + setType "application/octet-stream" = setupBinary + setType _ = setupJSON pretty + +-- GET Block / GET Blocks -- + +scottyBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData +scottyBlock (GetBlock h (NoTx noTx)) = do + setMetrics (.block) + getBlock h >>= \case + Nothing -> + raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx noTx b + +getBlocks :: + (MonadUnliftIO m, MonadLoggerIO m) => + [H.BlockHash] -> + Bool -> + WebT m [BlockData] +getBlocks hs notx = + (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs) + +scottyBlocks :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData] +scottyBlocks (GetBlocks hs (NoTx notx)) = do + setMetrics (.block) + bs <- getBlocks hs notx + addItemCount (length bs) + return bs + +pruneTx :: Bool -> BlockData -> BlockData +pruneTx False b = b +pruneTx True BlockData {..} = BlockData {txs = take 1 txs, ..} + +-- GET BlockRaw -- + +scottyBlockRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockRaw -> + WebT m (RawResult H.Block) +scottyBlockRaw (GetBlockRaw h) = do + setMetrics (.blockRaw) + b <- getRawBlock h + addItemCount (1 + length b.txs) + return $ RawResult b + +getRawBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + H.BlockHash -> + WebT m H.Block +getRawBlock h = do + b <- getBlock h >>= maybe (raise ThingNotFound) return + lift (toRawBlock b) + +toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block +toRawBlock b = do + let ths = b.txs + txs <- mapM f ths + return H.Block {header = b.header, txs} + where + f x = withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x >>= \case + Nothing -> undefined + Just t -> return $ transactionData t + +-- GET BlockBest / BlockBestRaw -- + +scottyBlockBest :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData +scottyBlockBest (GetBlockBest (NoTx notx)) = do + setMetrics (.block) + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bb -> + getBlock bb >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx notx b + +scottyBlockBestRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockBestRaw -> + WebT m (RawResult H.Block) +scottyBlockBestRaw _ = do + setMetrics (.blockRaw) + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bb -> do + b <- getRawBlock bb + addItemCount (1 + length b.txs) + return $ RawResult b + +-- GET BlockLatest -- + +scottyBlockLatest :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockLatest -> + WebT m [BlockData] +scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do + setMetrics (.block) + blocks <- + getBestBlock + >>= maybe + (raise ThingNotFound) + (go [] <=< getBlock) + addItemCount (length blocks) + return blocks + where + go acc Nothing = return $ reverse acc + go acc (Just b) + | b.height <= 0 = return $ reverse acc + | length acc == 99 = return . reverse $ pruneTx noTx b : acc + | otherwise = go (pruneTx noTx b : acc) =<< getBlock b.header.prev + +-- GET BlockHeight / BlockHeights / BlockHeightRaw -- + +scottyBlockHeight :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData] +scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do + setMetrics (.block) + blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h) + addItemCount (length blocks) + return blocks + +scottyBlockHeights :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockHeights -> + WebT m [BlockData] +scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do + setMetrics (.block) + bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights) + blocks <- getBlocks bhs notx + addItemCount (length blocks) + return blocks + +scottyBlockHeightRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockHeightRaw -> + WebT m (RawResultList H.Block) +scottyBlockHeightRaw (GetBlockHeightRaw h) = do + setMetrics (.blockRaw) + blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) + addItemCount (length blocks + sum (map (length . (.txs)) blocks)) + return $ RawResultList blocks + +-- GET BlockTime / BlockTimeRaw -- + +scottyBlockTime :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockTime -> + WebT m BlockData +scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do + setMetrics (.block) + ch <- lift $ asks (.config.store.chain) + blockAtOrBefore ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx notx b + +scottyBlockMTP :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockMTP -> + WebT m BlockData +scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do + setMetrics (.block) + ch <- lift $ asks (.config.store.chain) + blockAtOrAfterMTP ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx notx b + +scottyBlockTimeRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockTimeRaw -> + WebT m (RawResult H.Block) +scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do + setMetrics (.blockRaw) + ch <- lift $ asks (.config.store.chain) + blockAtOrBefore ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + raw <- lift $ toRawBlock b + addItemCount (1 + length raw.txs) + return $ RawResult raw + +scottyBlockMTPRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockMTPRaw -> + WebT m (RawResult H.Block) +scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do + setMetrics (.blockRaw) + ch <- lift $ asks (.config.store.chain) + blockAtOrAfterMTP ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + raw <- lift $ toRawBlock b + addItemCount (1 + length raw.txs) + return $ RawResult raw + +-- GET Transactions -- + +scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction +scottyTx (GetTx txid) = do + setMetrics (.tx) + getTransaction txid >>= \case + Nothing -> raise ThingNotFound + Just tx -> do + addItemCount 1 + return tx + +scottyTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction] +scottyTxs (GetTxs txids) = do + setMetrics (.tx) + txs <- catMaybes <$> mapM f (nub txids) + addItemCount (length txs) + return txs + where + f x = lift $ + withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x + +scottyTxRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx) +scottyTxRaw (GetTxRaw txid) = do + setMetrics (.txRaw) + getTransaction txid >>= \case + Nothing -> raise ThingNotFound + Just tx -> do + addItemCount 1 + return $ RawResult (transactionData tx) + +scottyTxsRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxsRaw -> + WebT m (RawResultList Tx) +scottyTxsRaw (GetTxsRaw txids) = do + setMetrics (.txRaw) + txs <- catMaybes <$> mapM f (nub txids) + addItemCount (length txs) + return $ RawResultList $ transactionData <$> txs + where + f x = lift $ + withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x + +getTxsBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + H.BlockHash -> + WebT m [Transaction] +getTxsBlock h = + getBlock h >>= \case + Nothing -> raise ThingNotFound + Just b -> do + txs <- mapM f b.txs + addItemCount (length txs) + return txs + where + f x = lift $ + withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x >>= \case + Nothing -> undefined + Just t -> return t + +scottyTxsBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxsBlock -> + WebT m [Transaction] +scottyTxsBlock (GetTxsBlock h) = do + setMetrics (.txBlock) + txs <- getTxsBlock h + addItemCount (length txs) + return txs + +scottyTxsBlockRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxsBlockRaw -> + WebT m (RawResultList Tx) +scottyTxsBlockRaw (GetTxsBlockRaw h) = do + setMetrics (.txBlockRaw) + txs <- fmap transactionData <$> getTxsBlock h + addItemCount (length txs) + return $ RawResultList txs + +-- GET TransactionAfterHeight -- + +scottyTxAfter :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxAfter -> + WebT m (GenericResult (Maybe Bool)) +scottyTxAfter (GetTxAfter txid height) = do + setMetrics (.txAfter) + (result, count) <- cbAfterHeight (fromIntegral height) txid + addItemCount count + return $ GenericResult result + +-- | Check if any of the ancestors of this transaction is a coinbase after the +-- specified height. Returns 'Nothing' if answer cannot be computed before +-- hitting limits. +cbAfterHeight :: + (MonadIO m, StoreReadBase m) => + H.BlockHeight -> + TxHash -> + m (Maybe Bool, Int) +cbAfterHeight height txid = + inputs n HashSet.empty HashSet.empty [txid] + where + n = 10000 + inputs 0 _ _ [] = return (Nothing, 10000) + inputs i is ns [] = + let is' = HashSet.union is ns + ns' = HashSet.empty + ts = HashSet.toList (HashSet.difference ns is) + in case ts of + [] -> return (Just False, n - i) + _ -> inputs i is' ns' ts + inputs i is ns (t : ts) = + getTransaction t >>= \case + Nothing -> return (Nothing, n - i) + Just tx + | height_check tx -> + if cb_check tx + then return (Just True, n - i + 1) + else + let ns' = HashSet.union (ins tx) ns + in inputs (i - 1) is ns' ts + | otherwise -> inputs (i - 1) is ns ts + cb_check = any isCoinbase . (.inputs) + ins = HashSet.fromList . map (.outpoint.hash) . (.inputs) + height_check tx = + case tx.block of + BlockRef h _ -> h > height + MemRef _ -> True + +-- POST Transaction -- + +scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId +scottyPostTx (PostTx tx) = do + setMetrics (.txPost) + addItemCount 1 + lift (asks (.config)) >>= \cfg -> + lift (publishTx cfg tx) >>= \case + Right () -> return (TxId (txHash tx)) + Left e@(PubReject _) -> raise $ UserError (show e) + _ -> raise ServerError + +-- | Publish a new transaction to the network. +publishTx :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + Tx -> + m (Either PubExcept ()) +publishTx cfg tx = + withSubscription pub $ \s -> + getTransaction (txHash tx) >>= \case + Just _ -> return $ Right () + Nothing -> go s + where + pub = cfg.store.pub + mgr = cfg.store.peerMgr + net = cfg.store.net + go s = + getPeers mgr >>= \case + [] -> return $ Left PubNoPeers + OnlinePeer {mailbox = p} : _ -> do + MTx tx `sendMessage` p + let v = + if net.segWit + then InvWitnessTx + else InvTx + sendMessage + (MGetData (GetData [InvVector v (txHash tx).get])) + p + f p s + t = 5 * 1000 * 1000 + f p s + | cfg.noMempool = return $ Right () + | otherwise = + liftIO (UnliftIO.timeout t (g p s)) >>= \case + Nothing -> return $ Left PubTimeout + Just (Left e) -> return $ Left e + Just (Right ()) -> return $ Right () + g p s = + receive s >>= \case + StoreTxReject p' h' c _ + | p == p' && h' == txHash tx -> return . Left $ PubReject c + StorePeerDisconnected p' + | p == p' -> return $ Left PubPeerDisconnected + StoreMempoolNew h' + | h' == txHash tx -> return $ Right () + _ -> g p s + +-- GET Mempool / Events -- + +scottyMempool :: + (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash] +scottyMempool (GetMempool limitM (OffsetParam o)) = do + setMetrics (.mempool) + WebLimits {..} <- lift $ asks (.config.limits) + let wl' = WebLimits {maxItemCount = 0, ..} + l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing + ths <- map snd . applyLimits l <$> getMempool + addItemCount 1 + return ths + +webSocketEvents :: WebState -> Middleware +webSocketEvents s = + websocketsOr defaultConnectionOptions events + where + pub = s.config.store.pub + gauge = (.events) <$> s.metrics + events pending = withSubscription pub $ \sub -> do + let path = requestPath $ pendingRequest pending + if path == "/events" + then do + conn <- acceptRequest pending + forever $ + receiveEvent sub >>= \case + Nothing -> return () + Just event -> sendTextData conn (A.encode event) + else + rejectRequestWith + pending + WebSockets.defaultRejectRequest + { WebSockets.rejectBody = + L.toStrict $ A.encode ThingNotFound, + WebSockets.rejectCode = + 404, + WebSockets.rejectMessage = + "Not Found", + WebSockets.rejectHeaders = + [("Content-Type", "application/json")] + } + +scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyEvents = + withGaugeIncrease (.events) $ do + setHeaders + proto <- setupContentType False + pub <- lift $ asks (.config.store.pub) + S.stream $ \io flush' -> + withSubscription pub $ \sub -> + forever $ do + flush' + receiveEvent sub >>= \case + Nothing -> return () + Just msg -> io (serial proto msg) + where + serial proto e = + lazyByteString $ + protoSerial proto toEncoding toJSON e <> newLine proto + newLine SerialAsBinary = mempty + newLine SerialAsJSON = "\n" + newLine SerialAsPrettyJSON = mempty + +receiveEvent :: Inbox StoreEvent -> IO (Maybe Event) +receiveEvent sub = + go <$> receive sub + where + go = \case + StoreBestBlock b -> Just (EventBlock b) + StoreMempoolNew t -> Just (EventTx t) + StoreMempoolDelete t -> Just (EventTx t) + _ -> Nothing + +-- GET Address Transactions -- + +scottyAddrTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef] +scottyAddrTxs (GetAddrTxs addr pLimits) = do + setMetrics (.addressTx) + txs <- getAddressTxs addr =<< paramToLimits False pLimits + addItemCount (length txs) + return txs + +scottyAddrsTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef] +scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do + setMetrics (.addressTx) + txs <- getAddressesTxs addrs =<< paramToLimits False pLimits + addItemCount (length txs) + return txs + +scottyAddrTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrTxsFull -> + WebT m [Transaction] +scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do + setMetrics (.addressTxFull) + txs <- getAddressTxs addr =<< paramToLimits True pLimits + ts <- catMaybes <$> mapM (getTransaction . (.txid)) txs + addItemCount (length ts) + return ts + +scottyAddrsTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrsTxsFull -> + WebT m [Transaction] +scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do + setMetrics (.addressTxFull) + txs <- getAddressesTxs addrs =<< paramToLimits True pLimits + ts <- catMaybes <$> mapM (getTransaction . (.txid)) txs + addItemCount (length ts) + return ts + +scottyAddrBalance :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrBalance -> + WebT m Balance +scottyAddrBalance (GetAddrBalance addr) = do + setMetrics (.addressBalance) + addItemCount 1 + getDefaultBalance addr + +scottyAddrsBalance :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance] +scottyAddrsBalance (GetAddrsBalance addrs) = do + setMetrics (.addressBalance) + balances <- getBalances addrs + addItemCount (length balances) + return balances + +scottyAddrUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent] +scottyAddrUnspent (GetAddrUnspent addr pLimits) = do + setMetrics (.addressUnspent) + unspents <- getAddressUnspents addr =<< paramToLimits False pLimits + addItemCount (length unspents) + return unspents + +scottyAddrsUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent] +scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do + setMetrics (.addressUnspent) + unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits + addItemCount (length unspents) + return unspents + +-- GET XPubs -- + +scottyXPub :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary +scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do + setMetrics (.xpub) + let xspec = XPubSpec xpub deriv + xbals <- lift . runNoCache noCache $ xPubBals xspec + addItemCount (length xbals) + return $ xPubSummary xspec xbals + +scottyDelXPub :: + (MonadUnliftIO m, MonadLoggerIO m) => + DelCachedXPub -> + WebT m (GenericResult Bool) +scottyDelXPub (DelCachedXPub xpub deriv) = do + setMetrics (.xpubDelete) + let xspec = XPubSpec xpub deriv + cacheM <- lift $ asks (.config.store.cache) + n <- lift $ withCache cacheM (cacheDelXPubs [xspec]) + addItemCount (fromIntegral n) + return (GenericResult (n > 0)) + +getXPubTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => + XPubKey -> + DeriveType -> + LimitsParam -> + Bool -> + WebT m [TxRef] +getXPubTxs xpub deriv plimits nocache = do + limits <- paramToLimits False plimits + let xspec = XPubSpec xpub deriv + xbals <- xPubBals xspec + addItemCount (length xbals) + lift . runNoCache nocache $ xPubTxs xspec xbals limits + +scottyXPubTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef] +scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do + setMetrics (.xpubTx) + txs <- getXPubTxs xpub deriv plimits nocache + addItemCount (length txs) + return txs + +scottyXPubTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetXPubTxsFull -> + WebT m [Transaction] +scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do + setMetrics (.xpubTxFull) + refs <- getXPubTxs xpub deriv plimits nocache + txs <- + fmap catMaybes $ + lift . runNoCache nocache $ + mapM (getTransaction . (.txid)) refs + addItemCount (length txs) + return txs + +scottyXPubBalances :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal] +scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do + setMetrics (.xpubBalance) + balances <- lift (runNoCache noCache (xPubBals spec)) + addItemCount (length balances) + return balances + where + spec = XPubSpec xpub deriv + +scottyXPubUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetXPubUnspent -> + WebT m [XPubUnspent] +scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do + setMetrics (.xpubUnspent) + limits <- paramToLimits False pLimits + let xspec = XPubSpec xpub deriv + xbals <- xPubBals xspec + addItemCount (length xbals) + unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits + addItemCount (length unspents) + return unspents + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +netBinfoSymbol :: Network -> BinfoSymbol +netBinfoSymbol net + | net == btc = + BinfoSymbol + { code = "BTC", + symbol = "BTC", + name = "Bitcoin", + conversion = 100 * 1000 * 1000, + after = True, + local = False + } + | net == bch = + BinfoSymbol + { code = "BCH", + symbol = "BCH", + name = "Bitcoin Cash", + conversion = 100 * 1000 * 1000, + after = True, + local = False + } + | otherwise = + BinfoSymbol + { code = "XTS", + symbol = "ยค", + name = "Test", + conversion = 100 * 1000 * 1000, + after = False, + local = False + } + +binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol +binfoTickerToSymbol code BinfoTicker {..} = + BinfoSymbol + { code, + symbol, + name, + conversion = 100 * 1000 * 1000 / fifteen, -- sat/usd + after = False, + local = True + } + where + name = case code of + "EUR" -> "Euro" + "USD" -> "U.S. dollar" + "GBP" -> "British pound" + x -> x + +getBinfoAddrsParam :: + (MonadIO m) => + Text -> + WebT m (HashSet BinfoAddr) +getBinfoAddrsParam name = do + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + p <- S.param (cs name) `S.rescue` const (return "") + if T.null p + then return HashSet.empty + else case parseBinfoAddr net ctx p of + Nothing -> raise (UserError "invalid address") + Just xs -> return $ HashSet.fromList xs + +getBinfoActive :: + (MonadIO m) => + WebT m (HashSet XPubSpec, HashSet Address) +getBinfoActive = do + active <- getBinfoAddrsParam "active" + p2sh <- getBinfoAddrsParam "activeP2SH" + bech32 <- getBinfoAddrsParam "activeBech32" + let xspec d b = (`XPubSpec` d) <$> xpub b + xspecs = + HashSet.fromList $ + concat + [ mapMaybe (xspec DeriveNormal) (HashSet.toList active), + mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh), + mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32) + ] + addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active + return (xspecs, addrs) + where + addr (BinfoAddr a) = Just a + addr (BinfoXpub _) = Nothing + xpub (BinfoXpub x) = Just x + xpub (BinfoAddr _) = Nothing + +getNumTxId :: (MonadIO m) => WebT m Bool +getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False) + +getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight +getChainHeight = do + ch <- lift $ asks (.config.store.chain) + (.height) <$> chainGetBest ch + +scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoUnspent = do + setMetrics (.binfoUnspent) + (xspecs, addrs) <- getBinfoActive + numtxid <- getNumTxId + limit <- get_limit + min_conf <- get_min_conf + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + height <- getChainHeight + let mn BinfoUnspent {..} = min_conf > confirmations + xbals <- lift $ getXBals xspecs + addItemCount . sum . map length $ HashMap.elems xbals + counter <- getItemCounter + bus <- + lift . runConduit $ + getBinfoUnspents counter numtxid height xbals xspecs addrs + .| (dropWhileC mn >> takeC limit .| sinkList) + setHeaders + streamEncoding (marshalEncoding (net, ctx) (BinfoUnspents bus)) + where + get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250) + get_min_conf = S.param "confirmations" `S.rescue` const (return 0) + +getBinfoUnspents :: + (StoreReadExtra m, MonadIO m) => + (Int -> m ()) -> + Bool -> + H.BlockHeight -> + HashMap XPubSpec [XPubBal] -> + HashSet XPubSpec -> + HashSet Address -> + ConduitT () BinfoUnspent m () +getBinfoUnspents counter numtxid height xbals xspecs addrs = do + cs' <- conduits + joinDescStreams cs' .| mapC (uncurry binfo) + where + binfo Unspent {..} xp = + let conf = case block of + MemRef _ -> 0 + BlockRef h _ -> height - h + 1 + hash = outpoint.hash + idx = outpoint.index + val = value + script = script + txi = encodeBinfoTxId numtxid hash + in BinfoUnspent + { txid = hash, + index = idx, + script, + value = val, + confirmations = fromIntegral conf, + txidx = txi, + xpub = xp + } + conduits = (<>) <$> xconduits <*> pure acounduits + xconduits = lift $ do + let f x (XPubUnspent u p) = + let path = toSoft (listToPath p) + xp = BinfoXPubPath x.key <$> path + in (u, xp) + g x = do + let h l = do + us <- xPubUnspents x (xBals x xbals) l + counter (length us) + return us + l = let Limits {..} = def in Limits {limit = 16, ..} + return $ streamThings h Nothing l .| mapC (f x) + mapM g (HashSet.toList xspecs) + acounduits = + let f u = (u, Nothing) + h a l = do + us <- getAddressUnspents a l + counter (length us) + return us + l = let Limits {..} = def in Limits {limit = 16, ..} + g a = streamThings (h a) Nothing l .| mapC f + in map g (HashSet.toList addrs) + +getXBals :: + (StoreReadExtra m) => + HashSet XPubSpec -> + m (HashMap XPubSpec [XPubBal]) +getXBals = + fmap HashMap.fromList . mapM f . HashSet.toList + where + f x = (x,) . filter (not . nullBalance . (.balance)) <$> xPubBals x + +xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal] +xBals = HashMap.findWithDefault [] + +getBinfoTxs :: + (StoreReadExtra m, MonadIO m) => + (Int -> m ()) -> -- counter + HashMap XPubSpec [XPubBal] -> -- xpub balances + HashMap Address (Maybe BinfoXPubPath) -> -- address book + HashSet XPubSpec -> -- show xpubs + HashSet Address -> -- show addrs + HashSet Address -> -- balance addresses + BinfoFilter -> + Bool -> -- numtxid + Bool -> -- prune outputs + Int64 -> -- starting balance + ConduitT () BinfoTx m () +getBinfoTxs + counter + xbals + abook + sxspecs + saddrs + baddrs + bfilter + numtxid + prune + bal = do + cs' <- conduits + joinDescStreams cs' .| go bal + where + sxspecs_ls = HashSet.toList sxspecs + saddrs_ls = HashSet.toList saddrs + conduits = + (<>) + <$> mapM xpub_c sxspecs_ls + <*> pure (map addr_c saddrs_ls) + xpub_c x = do + let f l = do + ts <- xPubTxs x (xBals x xbals) l + counter (length ts) + return ts + l = let Limits {..} = def in Limits {limit = 16, ..} + lift . return $ + streamThings f (Just (.txid)) l + addr_c a = do + let f l = do + as <- getAddressTxs a l + counter (length as) + return as + l = let Limits {..} = def in Limits {limit = 16, ..} + streamThings f (Just (.txid)) l + binfo_tx = toBinfoTx numtxid abook prune + compute_bal_change BinfoTx {..} = + let ins = map (.output) inputs + out = outputs + f b BinfoTxOutput {..} = + let val = fromIntegral value + in case address of + Nothing -> 0 + Just a + | a `HashSet.member` baddrs -> + if b then val else negate val + | otherwise -> 0 + in sum $ map (f False) ins <> map (f True) out + go b = + await >>= \case + Nothing -> return () + Just (TxRef _ t) -> + lift (getTransaction t) >>= \case + Nothing -> go b + Just x -> do + lift $ counter 1 + let a = binfo_tx b x + b' = b - compute_bal_change a + c = isJust a.blockHeight + Just (d, _) = a.balance + r = d + fromIntegral a.fee + case bfilter of + BinfoFilterAll -> + yield a >> go b' + BinfoFilterSent + | 0 > r -> yield a >> go b' + | otherwise -> go b' + BinfoFilterReceived + | r > 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMoved + | r == 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterConfirmed + | c -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMempool + | c -> return () + | otherwise -> yield a >> go b' + +getCashAddr :: (Monad m) => WebT m Bool +getCashAddr = S.param "cashaddr" `S.rescue` const (return False) + +getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address +getAddress param' = do + txt <- S.param param' + net <- lift $ asks (.config.store.net) + case textToAddr net txt of + Nothing -> raise ThingNotFound + Just a -> return a + +getBinfoAddr :: (Monad m) => TL.Text -> WebT m BinfoAddr +getBinfoAddr param' = do + txt <- S.param param' + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + let x = + BinfoAddr + <$> textToAddr net txt + <|> BinfoXpub <$> xPubImport net ctx txt + maybe S.next return x + +scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHistory = do + setMetrics (.binfoExportHistory) + (xspecs, addrs) <- getBinfoActive + (startM, endM) <- get_dates + (code, price') <- getPrice + xbals <- getXBals xspecs + addItemCount . sum . map length $ HashMap.elems xbals + counter <- getItemCounter + let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) + aaddrs = xaddrs <> addrs + cur = price'.fifteen + cs' = conduits counter (HashMap.toList xbals) addrs endM + txs <- + lift $ + runConduit $ + joinDescStreams cs' + .| takeWhileC (is_newer startM) + .| concatMapMC get_transaction + .| sinkList + addItemCount (length txs) + let times = map (\Transaction {..} -> timestamp) txs + net <- lift $ asks (.config.store.net) + url <- lift $ asks (.config.priceHistoryURL) + session <- lift $ asks (.session) + rates <- map (.price) <$> lift (getRates net session url code times) + addItemCount (length rates) + let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) + setHeaders + streamEncoding $ toEncoding hs + where + is_newer (Just b@BlockData {}) TxRef {block = t@BlockRef {}} = + b.height <= t.height + is_newer Nothing TxRef {} = True + get_addr = (.balance.address) + get_transaction TxRef {txid = h} = + getTransaction h + convert cur addrs tx rate = + let ins = tx.inputs + outs = tx.outputs + fins = filter (input_addr addrs) ins + fouts = filter (output_addr addrs) outs + vin = fromIntegral . sum $ map (.value) fins + vout = fromIntegral . sum $ map (.value) fouts + fee = tx.fee + v = vout - vin + t = tx.timestamp + h = txHash $ transactionData tx + in toBinfoHistory v t rate cur fee h + input_addr addrs' StoreInput {address = Just a} = + a `HashSet.member` addrs' + input_addr _ _ = False + output_addr addrs' StoreOutput {address = Just a} = + a `HashSet.member` addrs' + output_addr _ _ = False + get_dates = do + BinfoDate start <- S.param "start" + BinfoDate end' <- S.param "end" + let end = end' + 24 * 60 * 60 + ch <- lift $ asks (.config.store.chain) + startM <- blockAtOrAfter ch start + endM <- blockAtOrBefore ch end + return (startM, endM) + conduits counter xpubs addrs endM = + map (uncurry (xpub_c counter endM)) xpubs + <> map (addr_c counter endM) (HashSet.toList addrs) + addr_c counter endM a = do + let f l = do + ts <- getAddressTxs a l + counter (length ts) + return ts + l = + let Limits {..} = def + in Limits + { limit = 16, + start = AtBlock . (.height) <$> endM, + .. + } + streamThings f (Just (.txid)) l + xpub_c counter endM x bs = do + let f l = do + ts <- xPubTxs x bs l + counter (length ts) + return ts + l = + let Limits {..} = def + in Limits + { limit = 16, + start = AtBlock . (.height) <$> endM, + .. + } + streamThings f (Just (.txid)) l + +getPrice :: (MonadIO m) => WebT m (Text, BinfoTicker) +getPrice = do + code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD") + ticker <- lift $ asks (.ticker) + prices <- readTVarIO ticker + case HashMap.lookup code prices of + Nothing -> return (code, def) + Just p -> return (code, p) + +getSymbol :: (MonadIO m) => WebT m BinfoSymbol +getSymbol = uncurry binfoTickerToSymbol <$> getPrice + +scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlocksDay = do + setMetrics (.binfoBlock) + t <- min h . (`div` 1000) <$> S.param "milliseconds" + ch <- lift $ asks (.config.store.chain) + m <- blockAtOrBefore ch t + bs <- go (d t) m + addItemCount (length bs) + streamEncoding $ toEncoding $ map toBinfoBlockInfo bs + where + h = fromIntegral (maxBound :: H.Timestamp) + d = subtract (24 * 3600) + go _ Nothing = return [] + go t (Just b) + | b.header.timestamp <= fromIntegral t = + return [] + | otherwise = do + b' <- getBlock b.header.prev + (b :) <$> go t b' + +scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyMultiAddr = do + setMetrics (.binfoMultiaddr) + (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs + numtxid <- getNumTxId + cashaddr <- getCashAddr + local' <- getSymbol + offset <- getBinfoOffset + n <- getBinfoCount "n" + prune <- get_prune + fltr <- get_filter + xbals <- getXBals xspecs + addItemCount . sum . map length $ HashMap.elems xbals + xtxns <- get_xpub_tx_count xbals xspecs + addItemCount (length xtxns) + let sxbals = only_show_xbals sxpubs xbals + xabals = compute_xabals xbals + addrs = addrs' `HashSet.difference` HashMap.keysSet xabals + abals <- get_abals addrs + addItemCount (length abals) + let sxspecs = only_show_xspecs sxpubs xspecs + sxabals = compute_xabals sxbals + sabals = only_show_abals saddrs abals + sallbals = sabals <> sxabals + sbal = compute_bal sallbals + allbals = abals <> xabals + abook = compute_abook addrs xbals + sxaddrs = compute_xaddrs sxbals + salladdrs = saddrs <> sxaddrs + bal = compute_bal allbals + ibal = fromIntegral sbal + counter <- getItemCounter + ftxs <- + lift . runConduit $ + getBinfoTxs + counter + xbals + abook + sxspecs + saddrs + salladdrs + fltr + numtxid + prune + ibal + .| (dropC offset >> takeC n .| sinkList) + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + best <- get_best_block + addItemCount 1 + peers <- get_peers + addItemCount (fromIntegral peers) + let baddrs = toBinfoAddrs sabals sxbals xtxns + abaddrs = toBinfoAddrs abals xbals xtxns + recv = sum $ map (.received) abaddrs + sent' = sum $ map (.sent) abaddrs + txn = fromIntegral $ length ftxs + wallet = + BinfoWallet + { balance = bal, + txs = txn, + filtered = txn, + received = recv, + sent = sent' + } + coin = netBinfoSymbol net + let block = + BinfoBlockInfo + { hash = H.headerHash best.header, + height = best.height, + timestamp = best.header.timestamp, + index = best.height + } + let info = + BinfoInfo + { connected = peers, + conversion = 100 * 1000 * 1000, + fiat = local', + crypto = coin, + head = block + } + let multiaddr = + BinfoMultiAddr + { addresses = baddrs, + wallet = wallet, + txs = ftxs, + info = info, + recommendFee = True, + cashAddr = cashaddr + } + setHeaders + streamEncoding $ marshalEncoding (net, ctx) multiaddr + where + get_xpub_tx_count xbals = + fmap HashMap.fromList + . mapM + ( \x -> + (x,) + . fromIntegral + <$> xPubTxCount x (xBals x xbals) + ) + . HashSet.toList + get_filter = + S.param "filter" `S.rescue` const (return BinfoFilterAll) + get_best_block = + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bh -> + getBlock bh >>= \case + Nothing -> raise ThingNotFound + Just b -> return b + get_prune = + fmap not $ + S.param "no_compact" + `S.rescue` const (return False) + only_show_xbals sxpubs = + HashMap.filterWithKey (\k _ -> k.key `HashSet.member` sxpubs) + only_show_xspecs sxpubs = + HashSet.filter (\k -> k.key `HashSet.member` sxpubs) + only_show_abals saddrs = + HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs) + addr (BinfoAddr a) = Just a + addr (BinfoXpub _) = Nothing + xpub (BinfoXpub x) = Just x + xpub (BinfoAddr _) = Nothing + get_addrs = do + (xspecs, addrs) <- getBinfoActive + sh <- getBinfoAddrsParam "onlyShow" + let xpubs = HashSet.map (.key) xspecs + actives = + HashSet.map BinfoAddr addrs + <> HashSet.map BinfoXpub xpubs + sh' = if HashSet.null sh then actives else sh + saddrs = HashSet.fromList $ mapMaybe addr $ HashSet.toList sh' + sxpubs = HashSet.fromList $ mapMaybe xpub $ HashSet.toList sh' + return (addrs, xpubs, saddrs, sxpubs, xspecs) + get_abals = + let f b = (b.address, b) + g = HashMap.fromList . map f + in fmap g . getBalances . HashSet.toList + get_peers = do + ps <- lift $ getPeersInformation =<< asks (.config.store.peerMgr) + return (fromIntegral (length ps)) + compute_xabals = + let f b = (b.balance.address, b.balance) + in HashMap.fromList . concatMap (map f) . HashMap.elems + compute_bal = + let f b = b.confirmed + b.unconfirmed + in sum . map f . HashMap.elems + compute_abook addrs xbals = + let f XPubSpec {..} XPubBal {..} = + let a = balance.address + e = error "lions and tigers and bears" + s = toSoft (listToPath path) + in (a, Just (BinfoXPubPath key (fromMaybe e s))) + amap = + HashMap.map (const Nothing) $ + HashSet.toMap addrs + xmap = + HashMap.fromList + . concatMap (uncurry (map . f)) + $ HashMap.toList xbals + in amap <> xmap + compute_xaddrs = + let f = map (.balance.address) + in HashSet.fromList . concatMap f . HashMap.elems + +getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int +getBinfoCount str = do + d <- lift $ asks (.config.limits.defItemCount) + x <- lift $ asks (.config.limits.maxFullItemCount) + i <- min x <$> (S.param str `S.rescue` const (return d)) + return (fromIntegral i :: Int) + +getBinfoOffset :: + (MonadUnliftIO m, MonadLoggerIO m) => + WebT m Int +getBinfoOffset = do + x <- lift $ asks (.config.limits.maxOffset) + o <- S.param "offset" `S.rescue` const (return 0) + when (o > x) $ + raise $ + UserError $ + "offset exceeded: " <> show o <> " > " <> show x + return (fromIntegral o :: Int) + +scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyRawAddr = + setMetrics (.binfoAddressRaw) + >> getBinfoAddr "addr" + >>= \case + BinfoAddr addr -> do_addr addr + BinfoXpub xpub -> do_xpub xpub + where + do_xpub xpub = do + numtxid <- getNumTxId + derive <- S.param "derive" `S.rescue` const (return DeriveNormal) + let xspec = XPubSpec xpub derive + n <- getBinfoCount "limit" + off <- getBinfoOffset + xbals <- getXBals $ HashSet.singleton xspec + addItemCount . sum . map length $ HashMap.elems xbals + net <- lift $ asks (.config.store.net) + let summary = xPubSummary xspec (xBals xspec xbals) + abook = compute_abook xpub (xBals xspec xbals) + xspecs = HashSet.singleton xspec + saddrs = HashSet.empty + baddrs = HashMap.keysSet abook + bfilter = BinfoFilterAll + amnt = summary.confirmed + summary.unconfirmed + counter <- getItemCounter + txs <- + lift $ + runConduit $ + getBinfoTxs + counter + xbals + abook + xspecs + saddrs + baddrs + bfilter + numtxid + False + (fromIntegral amnt) + .| (dropC off >> takeC n .| sinkList) + let ra = + BinfoRawAddr + { address = BinfoXpub xpub, + balance = amnt, + ntx = fromIntegral $ length txs, + utxo = summary.utxo, + received = summary.received, + sent = fromIntegral summary.received - fromIntegral amnt, + txs = txs + } + setHeaders + ctx <- asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) ra + compute_abook xpub xbals = + let f XPubBal {..} = + let a = balance.address + e = error "black hole swallows all your code" + s = toSoft $ listToPath path + m = fromMaybe e s + in (a, Just (BinfoXPubPath xpub m)) + in HashMap.fromList $ map f xbals + do_addr addr = do + numtxid <- getNumTxId + n <- getBinfoCount "limit" + off <- getBinfoOffset + bal <- fromMaybe (zeroBalance addr) <$> getBalance addr + addItemCount 1 + net <- lift $ asks (.config.store.net) + let abook = HashMap.singleton addr Nothing + xspecs = HashSet.empty + saddrs = HashSet.singleton addr + bfilter = BinfoFilterAll + amnt = bal.confirmed + bal.unconfirmed + counter <- getItemCounter + txs <- + lift $ + runConduit $ + getBinfoTxs + counter + HashMap.empty + abook + xspecs + saddrs + saddrs + bfilter + numtxid + False + (fromIntegral amnt) + .| (dropC off >> takeC n .| sinkList) + let ra = + BinfoRawAddr + { address = BinfoAddr addr, + balance = amnt, + ntx = bal.txs, + utxo = bal.utxo, + received = bal.received, + sent = fromIntegral bal.received - fromIntegral amnt, + txs = txs + } + setHeaders + ctx <- asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) ra + +scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoReceived = do + setMetrics (.binfoQgetreceivedbyaddress) + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + addItemCount 1 + S.text $ cs $ show b.received + +scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoSent = do + setMetrics (.binfoQgetsentbyaddress) + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + addItemCount 1 + S.text $ cs $ show $ b.received - b.confirmed - b.unconfirmed + +scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoAddrBalance = do + setMetrics (.binfoQaddressbalance) + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + addItemCount 1 + S.text $ cs $ show $ b.confirmed + b.unconfirmed + +scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyFirstSeen = do + setMetrics (.binfoQaddressfirstseen) + a <- getAddress "addr" + ch <- lift $ asks (.config.store.chain) + bb <- chainGetBest ch + let top = bb.height + bot = 0 + i <- go ch bb a bot top + setHeaders + addItemCount 1 + S.text $ cs $ show i + where + go ch bb a bot top = do + let mid = bot + (top - bot) `div` 2 + n = top - bot < 2 + x <- hasone a bot + y <- hasone a mid + z <- hasone a top + if + | x -> getblocktime ch bb bot + | n -> getblocktime ch bb top + | y -> go ch bb a bot mid + | z -> go ch bb a mid top + | otherwise -> return 0 + getblocktime ch bb h = + (.header.timestamp) . fromJust <$> chainGetAncestor h bb ch + hasone a h = do + let l = Limits 1 0 (Just (AtBlock h)) + not . null <$> getAddressTxs a l + +scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyShortBal = do + setMetrics (.binfoBalance) + (xspecs, addrs) <- getBinfoActive + cashaddr <- getCashAddr + net <- lift $ asks (.config.store.net) + abals <- + catMaybes + <$> mapM + (get_addr_balance net cashaddr) + (HashSet.toList addrs) + addItemCount (length abals) + xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs) + let res = HashMap.fromList (abals <> xbals) + setHeaders + streamEncoding $ toEncoding res + where + to_short_bal Balance {..} = + BinfoShortBal + { final = confirmed + unconfirmed, + ntx = txs, + received = received + } + get_addr_balance net cashaddr a = + let net' = + if + | cashaddr -> net + | net == bch -> btc + | net == bchTest -> btcTest + | net == bchTest4 -> btcTest + | otherwise -> net + in case addrToText net' a of + Nothing -> return Nothing + Just a' -> + getBalance a >>= \case + Nothing -> return $ Just (a', to_short_bal (zeroBalance a)) + Just b -> return $ Just (a', to_short_bal b) + is_ext XPubBal {path = 0 : _} = True + is_ext _ = False + get_xspec_balance net xpub = do + xbals <- xPubBals xpub + xts <- xPubTxCount xpub xbals + addItemCount (length xbals + 1) + let val = sum $ map (.balance.confirmed) xbals + zro = sum $ map (.balance.unconfirmed) xbals + exs = filter is_ext xbals + rcv = sum $ map (.balance.received) exs + sbl = + BinfoShortBal + { final = val + zro, + ntx = fromIntegral xts, + received = rcv + } + ctx <- asks (.config.store.ctx) + return (xPubExport net ctx xpub.key, sbl) + +getBinfoHex :: (Monad m) => WebT m Bool +getBinfoHex = + (== ("hex" :: Text)) + <$> S.param "format" `S.rescue` const (return "json") + +scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlockHeight = do + numtxid <- getNumTxId + height <- S.param "height" + setMetrics (.binfoBlockHeight) + block_hashes <- getBlocksAtHeight height + block_headers <- catMaybes <$> mapM getBlock block_hashes + addItemCount (length block_headers) + next_block_hashes <- getBlocksAtHeight (height + 1) + next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes + addItemCount (length next_block_headers) + binfo_blocks <- + mapM (get_binfo_blocks numtxid next_block_headers) block_headers + setHeaders + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) binfo_blocks + where + get_tx th = + withRunInIO $ \run -> + unsafeInterleaveIO $ + run $ + fromJust <$> getTransaction th + get_binfo_blocks numtxid next_block_headers block_header = do + let my_hash = H.headerHash block_header.header + get_prev = (.header.prev) + get_hash = H.headerHash . (.header) + txs <- lift $ mapM get_tx block_header.txs + addItemCount (length txs) + let next_blocks = + map get_hash $ + filter + ((== my_hash) . get_prev) + next_block_headers + binfo_txs = map (toBinfoTxSimple numtxid) txs + binfo_block = toBinfoBlock block_header binfo_txs next_blocks + return binfo_block + +scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoLatest = do + numtxid <- getNumTxId + setMetrics (.binfoBlockLatest) + best <- get_best_block + addItemCount 1 + streamEncoding $ + toEncoding + BinfoHeader + { hash = H.headerHash best.header, + timestamp = best.header.timestamp, + index = best.height, + height = best.height, + txids = map (encodeBinfoTxId numtxid) best.txs + } + where + get_best_block = + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bh -> + getBlock bh >>= \case + Nothing -> raise ThingNotFound + Just b -> return b + +scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlock = do + numtxid <- getNumTxId + hex <- getBinfoHex + setMetrics (.binfoBlockRaw) + S.param "block" >>= \case + BinfoBlockHash bh -> go numtxid hex bh + BinfoBlockIndex i -> + getBlocksAtHeight i >>= \case + [] -> raise ThingNotFound + bh : _ -> go numtxid hex bh + where + get_tx th = + withRunInIO $ \run -> + unsafeInterleaveIO $ + run $ + fromJust <$> getTransaction th + go numtxid hex bh = + getBlock bh >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + txs <- lift $ mapM get_tx b.txs + addItemCount (length txs) + let my_hash = H.headerHash b.header + get_prev = (.header.prev) + get_hash = H.headerHash . (.header) + nxt_headers <- + fmap catMaybes $ + mapM getBlock + =<< getBlocksAtHeight (b.height + 1) + addItemCount (length nxt_headers) + let nxt = + map get_hash $ + filter + ((== my_hash) . get_prev) + nxt_headers + if hex + then do + let x = H.Block b.header (map transactionData txs) + setHeaders + S.text . encodeHexLazy . runPutL $ serialize x + else do + let btxs = map (toBinfoTxSimple numtxid) txs + y = toBinfoBlock b btxs nxt + setHeaders + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) y + +getBinfoTx :: + (MonadLoggerIO m, MonadUnliftIO m) => + BinfoTxId -> + WebT m (Either Except Transaction) +getBinfoTx txid = do + tx <- case txid of + BinfoTxIdHash h -> maybeToList <$> getTransaction h + BinfoTxIdIndex i -> getNumTransaction i + case tx of + [t] -> return $ Right t + [] -> return $ Left ThingNotFound + ts -> + let tids = map (txHash . transactionData) ts + in return $ Left (TxIndexConflict tids) + +scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTx = do + numtxid <- getNumTxId + hex <- getBinfoHex + txid <- S.param "txid" + setMetrics (.binfoTxRaw) + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + addItemCount 1 + if hex then hx tx else js numtxid tx + where + js numtxid t = do + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + setHeaders + streamEncoding $ marshalEncoding (net, ctx) $ toBinfoTxSimple numtxid t + hx t = do + setHeaders + S.text . encodeHexLazy . runPutL . serialize $ transactionData t + +scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTotalOut = do + txid <- S.param "txid" + setMetrics (.binfoQtxtotalbtcoutput) + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + addItemCount 1 + S.text $ cs $ show $ sum $ map (.value) tx.outputs + +scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTxFees = do + txid <- S.param "txid" + setMetrics (.binfoQtxfee) + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + let i = sum $ map (.value) $ filter f $ tx.inputs + o = sum $ map (.value) $ tx.outputs + addItemCount 1 + S.text . cs . show $ i - o + where + f StoreInput {} = True + f StoreCoinbase {} = False + +scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTxResult = do + txid <- S.param "txid" + addr <- getAddress "addr" + setMetrics (.binfoQtxresult) + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + let i = toInteger $ sum $ map (.value) $ filter (f addr) $ tx.inputs + o = toInteger $ sum $ map (.value) $ filter (g addr) $ tx.outputs + addItemCount 1 + S.text $ cs $ show $ o - i + where + f addr StoreInput {address = Just a} = a == addr + f _ _ = False + g addr StoreOutput {address = Just a} = a == addr + g _ _ = False + +scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTotalInput = do + txid <- S.param "txid" + setMetrics (.binfoQtxtotalbtcinput) + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + addItemCount 1 + S.text $ cs $ show $ sum $ map (.value) $ filter f $ tx.inputs + where + f StoreInput {} = True + f StoreCoinbase {} = False + +scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoMempool = do + setMetrics (.binfoMempool) + numtxid <- getNumTxId + offset <- getBinfoOffset + n <- getBinfoCount "limit" + mempool <- getMempool + let txids = map snd $ take n $ drop offset mempool + txs <- catMaybes <$> mapM getTransaction txids + net <- lift $ asks (.config.store.net) + setHeaders + let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs + addItemCount (length txs) + ctx <- lift $ asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) mem + +scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoGetBlockCount = do + setMetrics (.binfoQgetblockcount) + ch <- asks (.config.store.chain) + bn <- chainGetBest ch + setHeaders + addItemCount 1 + S.text $ cs $ show $ bn.height + +scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoLatestHash = do + setMetrics (.binfoQlatesthash) + ch <- asks (.config.store.chain) + bn <- chainGetBest ch + setHeaders + addItemCount 1 + S.text $ TL.fromStrict $ H.blockHashToHex $ H.headerHash $ bn.header + +scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoSubsidy = do + setMetrics (.binfoQbcperblock) + ch <- asks (.config.store.chain) + net <- asks (.config.store.net) + bn <- chainGetBest ch + setHeaders + addItemCount 1 + S.text $ + cs $ + show $ + (/ (100 * 1000 * 1000 :: Double)) $ + fromIntegral $ + H.computeSubsidy net (bn.height + 1) + +scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoAddrToHash = do + setMetrics (.binfoQaddresstohash) + addr <- getAddress "addr" + setHeaders + addItemCount 1 + S.text $ encodeHexLazy $ runPutL $ serialize $ addr.hash160 + +scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHashToAddr = do + setMetrics (.binfoQhashtoaddress) + bs <- maybe S.next return . decodeHex =<< S.param "hash" + net <- asks (.config.store.net) + hash <- either (const S.next) return (decode bs) + addr <- maybe S.next return (addrToText net (PubKeyAddress hash)) + setHeaders + addItemCount 1 + S.text $ TL.fromStrict addr + +scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoAddrPubkey = do + setMetrics (.binfoQaddrpubkey) + hex <- S.param "pubkey" + ctx <- lift $ asks (.config.store.ctx) + pubkey <- + maybe S.next (return . pubKeyAddr ctx) $ + eitherToMaybe . unmarshal ctx =<< decodeHex hex + net <- lift $ asks (.config.store.net) + setHeaders + case addrToText net pubkey of + Nothing -> raise ThingNotFound + Just a -> do + addItemCount 1 + S.text $ TL.fromStrict a + +scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoPubKeyAddr = do + setMetrics (.binfoQpubkeyaddr) + addr <- getAddress "addr" + mi <- strm addr + i <- case mi of + Nothing -> raise ThingNotFound + Just i -> return i + pk <- case extr addr i of + Left e -> raise $ UserError e + Right t -> return t + setHeaders + S.text $ encodeHexLazy $ L.fromStrict pk + where + strm addr = do + counter <- getItemCounter + runConduit $ do + let f l = do + ts <- getAddressTxs addr l + counter (length ts) + return ts + l = let Limits {..} = def in Limits {limit = 8, ..} + streamThings f (Just (.txid)) l + .| concatMapMC (getTransaction . (.txid)) + .| iterMC (\_ -> counter 1) + .| concatMapC (filter (inp addr) . (.inputs)) + .| headC + inp addr StoreInput {address = Just a} = a == addr + inp _ _ = False + extr addr StoreInput {script, pkscript, witness} = do + Script sig <- decode script + Script pks <- decode pkscript + case addr of + PubKeyAddress {} -> + case sig of + [OP_PUSHDATA _ _, OP_PUSHDATA pub _] -> + Right pub + [OP_PUSHDATA _ _] -> + case pks of + [OP_PUSHDATA pub _, OP_CHECKSIG] -> + Right pub + _ -> Left "Could not parse scriptPubKey" + _ -> Left "Could not parse scriptSig" + WitnessPubKeyAddress {} -> + case witness of + [_, pub] -> return pub + _ -> Left "Could not parse scriptPubKey" + _ -> Left "Address does not have public key" + extr _ _ = Left "Incorrect input type" + +scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHashPubkey = do + setMetrics (.binfoQhashpubkey) + ctx <- lift $ asks (.config.store.ctx) + pkm <- (eitherToMaybe . unmarshal ctx <=< decodeHex) <$> S.param "pubkey" + addr <- case pkm of + Nothing -> raise $ UserError "Could not decode public key" + Just pk -> return $ pubKeyAddr ctx pk + setHeaders + addItemCount 1 + S.text $ encodeHexLazy $ runPutL $ serialize $ addr.hash160 + +-- GET Network Information -- + +scottyPeers :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetPeers -> + WebT m [PeerInfo] +scottyPeers _ = do + setMetrics (.peers) + ps <- lift $ getPeersInformation =<< asks (.config.store.peerMgr) + addItemCount (length ps) + return ps + +-- | Obtain information about connected peers from peer manager process. +getPeersInformation :: + (MonadLoggerIO m) => PeerMgr -> m [PeerInfo] +getPeersInformation mgr = + mapMaybe toInfo <$> getPeers mgr + where + toInfo op = do + ver <- op.version + return + PeerInfo + { userAgent = ver.userAgent.get, + address = show op.address, + version = ver.version, + services = ver.services, + relay = ver.relay + } + +scottyHealth :: + (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck +scottyHealth _ = do + setMetrics (.health) + h <- asks (.health) >>= readTVarIO + unless (isOK h) $ S.status status503 + addItemCount 1 + return h + +blockHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m BlockHealth +blockHealthCheck cfg = do + let ch = cfg.store.chain + headers <- (.height) <$> chainGetBest ch + blocks <- + maybe 0 (.height) + <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock) + return + BlockHealth + { headers, + blocks, + max = fromIntegral cfg.maxLaggingBlocks + } + +lastBlockHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + Chain -> + WebTimeouts -> + m TimeHealth +lastBlockHealthCheck ch tos = do + n <- fromIntegral . systemSeconds <$> liftIO getSystemTime + t <- fromIntegral . (.header.timestamp) <$> chainGetBest ch + return + TimeHealth + { age = n - t, + max = fromIntegral tos.block + } + +lastTxHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m TimeHealth +lastTxHealthCheck WebConfig {..} = do + n <- fromIntegral . systemSeconds <$> liftIO getSystemTime + b <- fromIntegral . (.header.timestamp) <$> chainGetBest ch + t <- + getMempool >>= \case + t : _ -> + let x = fromIntegral $ fst t + in return $ max x b + [] -> return b + return + TimeHealth + { age = n - t, + max = fromIntegral to + } + where + ch = store.chain + to = + if noMempool + then timeouts.block + else timeouts.tx + +pendingTxsHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m MaxHealth +pendingTxsHealthCheck cfg = do + n <- blockStorePendingTxs cfg.store.block + return + MaxHealth + { max = fromIntegral cfg.maxPendingTxs, + count = fromIntegral n + } + +peerHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m CountHealth +peerHealthCheck cfg = do + count <- fromIntegral . length <$> getPeers cfg.store.peerMgr + return CountHealth {min = fromIntegral cfg.minPeers, count} + +healthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m HealthCheck +healthCheck cfg = do + blocks <- blockHealthCheck cfg + lastBlock <- lastBlockHealthCheck cfg.store.chain cfg.timeouts + lastTx <- lastTxHealthCheck cfg + pendingTxs <- pendingTxsHealthCheck cfg + peers <- peerHealthCheck cfg + time <- round . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime + let check = + HealthCheck + { network = cfg.store.net.name, + version = cfg.version, + .. + } + unless (isOK check) $ do + let t = toStrict $ encodeToLazyText check + $(logErrorS) "Web" $ "Health check failed: " <> t + return check + +scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyDbStats = do + setMetrics (.db) + setHeaders + db <- lift $ asks (.config.store.db.db) + statsM <- lift (getProperty db Stats) + addItemCount 1 + S.text $ maybe "Could not get stats" cs statsM + +----------------------- +-- Parameter Parsing -- +----------------------- + +-- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on +-- parse failure. +paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a) +paramOptional = go Proxy + where + go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a) + go proxy = do + net <- lift $ asks (.config.store.net) + ctx <- lift $ asks (.config.store.ctx) + tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing) + case tsM of + Nothing -> return Nothing -- Parameter was not supplied + Just ts -> maybe (raise err) (return . Just) $ parseParam net ctx ts + where + l = proxyLabel proxy + p = Just <$> S.param (cs l) + err = UserError $ "Unable to parse param " <> cs l + +-- | Raises an exception if the parameter is not supplied +param :: (Param a, MonadIO m) => WebT m a +param = go Proxy + where + go :: (Param a, MonadIO m) => Proxy a -> WebT m a + go proxy = do + resM <- paramOptional + case resM of + Just res -> return res + _ -> + raise . UserError $ + "The param " <> cs (proxyLabel proxy) <> " was not defined" + +-- | Returns the default value of a parameter if it is not supplied. Raises an +-- exception on parse failure. +paramDef :: (Default a, Param a, MonadIO m) => WebT m a +paramDef = fromMaybe def <$> paramOptional + +-- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is +-- not supplied or if parsing fails. +paramLazy :: (Param a, MonadIO m) => WebT m a +paramLazy = do + resM <- paramOptional `S.rescue` const (return Nothing) + maybe S.next return resM + +parseBody :: (MonadIO m, Serial a) => WebT m a +parseBody = do + b <- L.toStrict <$> S.body + case hex b <> bin b of + Left _ -> raise $ UserError "Failed to parse request body" + Right x -> return x + where + bin = runGetS deserialize + hex b = + let ns = C.filter (not . isSpace) b + in if isBase16 ns + then bin . decodeBase16 $ assertBase16 ns + else Left "Invalid hex input" + +parseOffset :: (MonadIO m) => WebT m OffsetParam +parseOffset = do + res@(OffsetParam o) <- paramDef + limits <- lift $ asks (.config.limits) + when (limits.maxOffset > 0 && fromIntegral o > limits.maxOffset) $ + raise . UserError $ + "offset exceeded: " <> show o <> " > " <> show limits.maxOffset + return res + +parseStart :: + (MonadUnliftIO m, MonadLoggerIO m) => + Maybe StartParam -> + WebT m (Maybe Start) +parseStart Nothing = return Nothing +parseStart (Just s) = + runMaybeT $ + case s of + StartParamHash {hash = h} -> start_tx h <|> start_block h + StartParamHeight {height = h} -> start_height h + StartParamTime {time = q} -> start_time q + where + start_height h = return $ AtBlock $ fromIntegral h + start_block h = do + b <- MaybeT $ getBlock (H.BlockHash h) + return $ AtBlock b.height + start_tx h = do + _ <- MaybeT $ getTxData (TxHash h) + return $ AtTx (TxHash h) + start_time q = do + ch <- lift $ asks (.config.store.chain) + b <- MaybeT $ blockAtOrBefore ch q + return $ AtBlock b.height + +parseLimits :: (MonadIO m) => WebT m LimitsParam +parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional + +paramToLimits :: + (MonadUnliftIO m, MonadLoggerIO m) => + Bool -> + LimitsParam -> + WebT m Limits +paramToLimits full (LimitsParam limitM o startM) = do + wl <- lift $ asks (.config.limits) + Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM + +validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32 +validateLimit wl full limitM = + f m $ maybe d (fromIntegral . (.get)) limitM + where + m + | full && wl.maxFullItemCount > 0 = wl.maxFullItemCount + | otherwise = wl.maxItemCount + d = wl.defItemCount + f a 0 = a + f 0 b = b + f a b = min a b + +--------------- +-- Utilities -- +--------------- + +runInWebReader :: + (MonadIO m) => + CacheT (DatabaseReaderT m) a -> + ReaderT WebState m a +runInWebReader f = do + bdb <- asks (.config.store.db) + mc <- asks (.config.store.cache) + lift $ runReaderT (withCache mc f) bdb + +runNoCache :: (MonadIO m) => Bool -> ReaderT WebState m a -> ReaderT WebState m a +runNoCache False f = f +runNoCache True f = local g f + where + g s = s {config = h s.config} + h c = c {store = i c.store} + i s = s {cache = Nothing} + +logIt :: + (MonadUnliftIO m, MonadLoggerIO m) => + Maybe WebMetrics -> + m Middleware +logIt metrics = do + runner <- askRunInIO + return $ \app req respond -> do + var <- newTVarIO B.empty + req' <- + let rb = req_body var (getRequestBodyChunk req) + rq = req {requestBody = rb} + in case metrics of + Nothing -> return rq + Just m -> do + stat_var <- newTVarIO Nothing + let vt = + V.insert m.key stat_var $ + vault rq + return rq {vault = vt} + bracket start (end var runner req') $ \_ -> + app req' $ \res -> do + b <- readTVarIO var + let s = responseStatus res + msg = fmtReq b req' <> ": " <> fmtStatus s + if statusIsSuccessful s + then runner $ $(logDebugS) "Web" msg + else runner $ $(logErrorS) "Web" msg + respond res + where + start = systemToUTCTime <$> getSystemTime + req_body var old_body = do + b <- old_body + unless (B.null b) . atomically $ modifyTVar var (<> b) + return b + add_stat d s = do + addStatQuery s + addStatTime s d + end var runner req t1 = do + t2 <- systemToUTCTime <$> getSystemTime + let diff = round $ diffUTCTime t2 t1 * 1000 + case metrics of + Nothing -> return () + Just m -> do + let m_stat_var = V.lookup m.key (vault req) + add_stat diff m.all + case m_stat_var of + Nothing -> return () + Just stat_var -> + readTVarIO stat_var >>= \case + Nothing -> return () + Just f -> add_stat diff (f m) + when (diff > 10000) $ do + b <- readTVarIO var + runner $ + $(logWarnS) "Web" $ + "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req + +reqSizeLimit :: (Integral i) => i -> Middleware +reqSizeLimit i = requestSizeLimitMiddleware lim + where + max_len _req = return (Just (fromIntegral i)) + lim = + setOnLengthExceeded too_big $ + setMaxLengthForRequest + max_len + defaultRequestSizeLimitSettings + too_big _ _app _req send = + send $ + waiExcept requestEntityTooLarge413 RequestTooLarge + +reqTimeout :: (Integral i) => i -> Middleware reqTimeout = timeoutAs res . fromIntegral where err = ServerTimeout diff --git a/test/Haskoin/Store/CacheSpec.hs b/test/Haskoin/Store/CacheSpec.hs --- a/test/Haskoin/Store/CacheSpec.hs +++ b/test/Haskoin/Store/CacheSpec.hs @@ -29,7 +29,7 @@ b = do h <- choose (0, 0x07ffffff) p <- choose (0, 0x03ffffff) - return BlockRef {blockRefHeight = h, blockRefPos = p} + return BlockRef {height = h, position = p} m = do t <- choose (0, 0x001fffffffffffff) - return MemRef {memRefTime = t} + return MemRef {timestamp = t} diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} module Haskoin.StoreSpec (spec) where @@ -9,7 +14,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.ByteString.Base64 import Data.Either import Data.List @@ -37,10 +42,10 @@ } spec :: Spec -spec = do +spec = prepareContext $ \ctx -> do describe "Download" $ do it "gets 8 blocks" $ - withTestStore bchRegTest "eight-blocks" $ \TestStore {..} -> do + withTestStore bchRegTest ctx "eight-blocks" $ \TestStore {..} -> do bs <- replicateM 8 . receiveMatch testStoreEvents $ \case StoreBestBlock b -> Just b _ -> Nothing @@ -48,10 +53,10 @@ bestNodeM <- chainGetBlock bestHash testStoreChain bestNodeM `shouldSatisfy` isJust let bestNode = fromJust bestNodeM - bestHeight = nodeHeight bestNode + bestHeight = bestNode.height bestHeight `shouldBe` 8 it "get a block and its transactions" $ - withTestStore bchRegTest "get-block-txs" $ \TestStore {..} -> + withTestStore bchRegTest ctx "get-block-txs" $ \TestStore {..} -> flip runReaderT testStoreDB $ do let h1 = "5369ef2386c72acdf513ffd80aeba2a1774e2f004d120761e54a8bf614173f3e" get_the_block h = @@ -59,22 +64,27 @@ StoreBestBlock b | h <= 1 -> return b | otherwise -> - get_the_block ((h :: Int) - 1) + get_the_block ((h :: Int) - 1) _ -> get_the_block h bh <- get_the_block 15 m <- getBlock bh let bd = fromMaybe (error "Could not get block") m t1 <- getTransaction h1 lift $ do - blockDataHeight bd `shouldBe` 15 - length (blockDataTxs bd) `shouldBe` 1 - head (blockDataTxs bd) `shouldBe` h1 + bd.height `shouldBe` 15 + length bd.txs `shouldBe` 1 + head bd.txs `shouldBe` h1 t1 `shouldSatisfy` isJust txHash (transactionData (fromJust t1)) `shouldBe` h1 withTestStore :: - MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a -withTestStore net t f = + (MonadUnliftIO m) => + Network -> + Ctx -> + String -> + (TestStore -> m a) -> + m a +withTestStore net ctx t f = withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> runNoLoggingT $ do let ad = @@ -83,33 +93,34 @@ (sockToHostAddress (SockAddrInet 0 0)) cfg = StoreConfig - { storeConfMaxPeers = 20, - storeConfInitPeers = [], - storeConfDiscover = True, - storeConfDB = w, - storeConfNetwork = net, - storeConfCache = Nothing, - storeConfGap = gap, - storeConfInitialGap = 20, - storeConfCacheMin = 100, - storeConfMaxKeys = 100 * 1000 * 1000, - storeConfNoMempool = False, - storeConfWipeMempool = False, - storeConfSyncMempool = False, - storeConfPeerTimeout = 60, - storeConfPeerMaxLife = 48 * 3600, - storeConfConnect = dummyPeerConnect net ad, - storeConfStats = Nothing, - storeConfCacheMempoolSync = 30 + { maxPeers = 20, + initPeers = [], + discover = True, + db = w, + net = net, + ctx = ctx, + redis = Nothing, + gap = gap, + initGap = 20, + redisMinAddrs = 100, + redisMaxKeys = 100 * 1000 * 1000, + noMempool = False, + wipeMempool = False, + syncMempool = False, + peerTimeout = 60, + maxPeerLife = 48 * 3600, + connect = dummyPeerConnect net ad, + statsStore = Nothing, + redisSyncInterval = 30 } withStore cfg $ \Store {..} -> - withSubscription storePublisher $ \sub -> + withSubscription pub $ \sub -> lift $ f TestStore - { testStoreDB = storeDB, - testStoreBlockStore = storeBlock, - testStoreChain = storeChain, + { testStoreDB = db, + testStoreBlockStore = block, + testStoreChain = chain, testStoreEvents = sub } @@ -194,7 +205,9 @@ ver = buildVersion net nonce 0 ad rmt now runPut (putMessage net (MVersion ver)) `send` s runConduit $ - forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact + forever (receive r >>= yield) + .| inc + .| concatMapC mockPeerReact .| outc .| awaitForever (`send` s) outc = mapMC $ \msg' -> return $ runPut (putMessage net msg') @@ -216,11 +229,11 @@ mockPeerReact (MVersion _) = [MVerAck] mockPeerReact (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')] where - f b = (blockHeader b, VarInt (fromIntegral (length (blockTxns b)))) + f b = (b.header, VarInt $ fromIntegral $ length b.txs) hs' = map f allBlocks mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs where f (InvVector InvBlock h) = MBlock <$> find (l h) allBlocks f _ = Nothing - l h b = headerHash (blockHeader b) == BlockHash h + l h b = headerHash b.header == BlockHash h mockPeerReact _ = []