diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,1764 +0,0 @@ -# Changelog -All notable changes to this project will be documented in this file. - -The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) -and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) - -## [1.0.1] - 2023-08-03 - -### Changed - -- Add compatibility with latest nightly LTS Haskell. - -## [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 deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,57 +0,0 @@ -# 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,6 +1,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -10,10 +11,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoFieldSelectors #-} -module Main where +module Main (main) where import Control.Applicative ((<|>)) -import Control.Arrow (second) import Control.Monad (when) import Control.Monad.Cont (ContT (ContT), runContT) import Control.Monad.Logger @@ -30,18 +30,9 @@ 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, ) @@ -50,15 +41,12 @@ ( StoreConfig (..), WebConfig (..), WebLimits (..), - WebTimeouts (..), runWeb, withStore, ) -import Haskoin.Store.Stats (withStats) import Options.Applicative ( Parser, auto, - eitherReader, execParser, flag, fullDesc, @@ -79,7 +67,11 @@ ) import System.Exit (exitSuccess) import System.FilePath (()) -import System.IO.Unsafe (unsafePerformIO) +import System.Metrics.StatsD + ( defStatConfig, + withStats, + StatConfig(statsdPort, statsdServer, namespace, reportSamples, + reportStats) ) import Text.Read (readMaybe) import UnliftIO (MonadIO) import UnliftIO.Directory @@ -88,12 +80,12 @@ ) import UnliftIO.Environment (lookupEnv) -version :: String +haskoinStoreVersion :: String #ifdef CURRENT_PACKAGE_VERSION -version = CURRENT_PACKAGE_VERSION +haskoinStoreVersion = CURRENT_PACKAGE_VERSION #else -version = "Unavailable" +haskoinStoreVersion = "Unavailable" #endif data Config = Config @@ -109,7 +101,6 @@ maxLaggingBlocks :: !Int, minPeers :: !Int, webLimits :: !WebLimits, - webTimeouts :: !WebTimeouts, redis :: !Bool, redisURL :: !String, redisMinAddrs :: !Int, @@ -125,6 +116,8 @@ statsdHost :: !String, statsdPort :: !Int, statsdPrefix :: !String, + statsdNoEvents :: Bool, + statsdAggregates :: Bool, tickerRefresh :: !Int, tickerURL :: !String, priceHistoryURL :: !String, @@ -162,8 +155,6 @@ env "MIN_PEERS" 1 readMaybe webLimits <- getWebLimits - webTimeouts <- - getWebTimeouts redis <- env "REDIS" False parseBool redisURL <- @@ -192,6 +183,10 @@ env "STATSD_HOST" "localhost" pure statsdPort <- env "STATSD_PORT" 8125 readMaybe + statsdNoEvents <- + env "STATSD_NO_EVENTS" False parseBool + statsdAggregates <- + env "STATSD_AGGREGATES" False parseBool statsdPrefix <- getStatsdPrefix tickerRefresh <- @@ -216,31 +211,24 @@ getAppUserDataDirectory "haskoin-store" >>= \d -> env "DIR" d pure getWebLimits = do - let WebLimits {..} = def + let d = def :: WebLimits maxItemCount <- - env "MAX_ITEM_COUNT" maxItemCount readMaybe + env "MAX_ITEM_COUNT" d.maxItemCount readMaybe maxFullItemCount <- - env "MAX_FULL_ITEM_COUNT" maxFullItemCount readMaybe + env "MAX_FULL_ITEM_COUNT" d.maxFullItemCount readMaybe maxOffset <- - env "MAX_OFFSET" maxOffset readMaybe + env "MAX_OFFSET" d.maxOffset readMaybe defItemCount <- - env "DEF_ITEM_COUNT" defItemCount readMaybe + env "DEF_ITEM_COUNT" d.defItemCount readMaybe xpubGap <- - env "XPUB_GAP" xpubGap readMaybe + env "XPUB_GAP" d.xpubGap readMaybe xpubGapInit <- - env "XPUB_GAP_INIT" xpubGapInit readMaybe - maxBodySize <- - env "MAX_BODY_SIZE" maxBodySize readMaybe - requestTimeout <- - env "REQUEST_TIMEOUT" requestTimeout readMaybe + env "XPUB_GAP_INIT" d.xpubGapInit readMaybe + blockTimeout <- + env "BLOCK_TIMEOUT" d.blockTimeout readMaybe + txTimeout <- + env "TX_TIMEOUT" d.txTimeout 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 = @@ -385,37 +373,21 @@ <> 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 <- + blockTimeout <- option auto $ metavar "SECONDS" <> long "block-timeout" <> help "Block lag health timeout" <> showDefault - <> value c.webTimeouts.block - tx <- + <> value c.webLimits.blockTimeout + txTimeout <- option auto $ metavar "SECONDS" <> long "tx-timeout" <> help "Last tx received health timeout" <> showDefault - <> value c.webTimeouts.tx - return WebTimeouts {..} + <> value c.webLimits.txTimeout + return WebLimits {..} redis <- flag c.redis True $ long "redis" @@ -505,6 +477,14 @@ <> help "Prefix for statsd metrics" <> showDefault <> value c.statsdPrefix + statsdNoEvents <- + flag c.statsdNoEvents True $ + long "statsd-no-events" + <> help "Do not report individual events to statsd" + statsdAggregates <- + flag c.statsdAggregates True $ + long "statsd-aggregates" + <> help "Send statistical aggregate reports to statsd every second" tickerRefresh <- option auto $ metavar "MICROSECONDS" @@ -549,15 +529,11 @@ 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 + putStrLn haskoinStoreVersion exitSuccess if null c.peers && not c.discover then run $ let Config {..} = c in Config {discover = True, ..} @@ -568,14 +544,14 @@ fullDesc <> progDesc "Bitcoin (BCH & BTC) block chain index with HTTP API" <> Options.Applicative.header - ("haskoin-store version " <> version) + ("haskoin-store version " <> haskoinStoreVersion) 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 + stats <- ContT $ with_stats net let dir = cfg.dir net.name $(logInfoS) "haskoin-store" $ "Creating working directory (if not found): " <> cs dir @@ -601,7 +577,7 @@ peerTimeout = fromIntegral cfg.peerTimeout, maxPeerLife = fromIntegral cfg.maxPeerLife, connect = withConnection, - statsStore = stats, + stats = stats, redisSyncInterval = cfg.redisSyncInterval } lift $ @@ -611,13 +587,12 @@ port = cfg.port, store = store, limits = cfg.webLimits, - timeouts = cfg.webTimeouts, maxPendingTxs = cfg.maxPendingTxs, maxLaggingBlocks = cfg.maxLaggingBlocks, minPeers = cfg.minPeers, - version = version, + version = haskoinStoreVersion, noMempool = cfg.noMempool, - statsStore = stats, + stats = stats, tickerRefresh = cfg.tickerRefresh, tickerURL = cfg.tickerURL, priceHistoryURL = cfg.priceHistoryURL, @@ -626,7 +601,7 @@ healthCheckInterval = cfg.healthCheckInterval } where - with_stats go + with_stats net go | cfg.statsd = do $(logInfoS) "Main" $ "Sending stats to " @@ -636,9 +611,13 @@ <> " with prefix: " <> T.pack cfg.statsdPrefix withStats - (T.pack cfg.statsdHost) - cfg.statsdPort - (T.pack cfg.statsdPrefix) + defStatConfig + { statsdServer = cfg.statsdHost, + statsdPort = cfg.statsdPort, + namespace = cfg.statsdPrefix <> "." <> net.name, + reportSamples = not cfg.statsdNoEvents, + reportStats = cfg.statsdAggregates + } (go . Just) | otherwise = go Nothing l _ lvl diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.0.1 +version: 1.1.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -17,9 +17,6 @@ license: MIT license-file: LICENSE build-type: Simple -extra-source-files: - README.md - CHANGELOG.md source-repository head type: git @@ -36,12 +33,12 @@ Haskoin.Store.Database.Writer Haskoin.Store.Logic Haskoin.Store.Manager - Haskoin.Store.Stats Haskoin.Store.Web other-modules: Paths_haskoin_store hs-source-dirs: src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: aeson >=1.4.7.1 , aeson-pretty >=0.8.8 @@ -54,14 +51,11 @@ , containers >=0.6.2.1 , data-default >=0.7.1.1 , deepseq >=1.4.4.0 - , ekg-core >=0.1.1.7 - , ekg-statsd >=0.2.5 - , foldl >=1.4.10 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 , haskoin-core >=1.0.0 , haskoin-node >=1.0.0 - , haskoin-store-data ==1.0.1 + , haskoin-store-data ==1.1.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -74,6 +68,7 @@ , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 , scotty >=0.11.5 + , statsd-rupp >=0.4 , stm >=2.5.0.0 , string-conversions >=0.4.0.1 , text >=1.2.3.0 @@ -83,7 +78,6 @@ , unordered-containers >=0.2.10.0 , vault >=0.3.1.5 , wai >=3.2.2.1 - , wai-extra >=3.1.6 , wai-websockets >=3.0.1.2 , warp >=3.3.10 , websockets >=0.12.4 @@ -96,7 +90,7 @@ Paths_haskoin_store hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.4.7.1 , aeson-pretty >=0.8.8 @@ -109,16 +103,13 @@ , containers >=0.6.2.1 , data-default >=0.7.1.1 , deepseq >=1.4.4.0 - , ekg-core >=0.1.1.7 - , ekg-statsd >=0.2.5 , filepath - , foldl >=1.4.10 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 , haskoin-core >=1.0.0 , haskoin-node >=1.0.0 , haskoin-store - , haskoin-store-data ==1.0.1 + , haskoin-store-data ==1.1.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -132,6 +123,7 @@ , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 , scotty >=0.11.5 + , statsd-rupp >=0.4 , stm >=2.5.0.0 , string-conversions >=0.4.0.1 , text >=1.2.3.0 @@ -141,7 +133,6 @@ , unordered-containers >=0.2.10.0 , vault >=0.3.1.5 , wai >=3.2.2.1 - , wai-extra >=3.1.6 , wai-websockets >=3.0.1.2 , warp >=3.3.10 , websockets >=0.12.4 @@ -157,7 +148,7 @@ Paths_haskoin_store hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck >=2.13.2 , aeson >=1.4.7.1 @@ -172,15 +163,12 @@ , containers >=0.6.2.1 , data-default >=0.7.1.1 , deepseq >=1.4.4.0 - , ekg-core >=0.1.1.7 - , ekg-statsd >=0.2.5 - , foldl >=1.4.10 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 , haskoin-core >=1.0.0 , haskoin-node >=1.0.0 , haskoin-store - , haskoin-store-data ==1.0.1 + , haskoin-store-data ==1.1.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 @@ -194,6 +182,7 @@ , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 , scotty >=0.11.5 + , statsd-rupp >=0.4 , stm >=2.5.0.0 , string-conversions >=0.4.0.1 , text >=1.2.3.0 @@ -203,7 +192,6 @@ , unordered-containers >=0.2.10.0 , vault >=0.3.1.5 , wai >=3.2.2.1 - , wai-extra >=3.1.6 , wai-websockets >=3.0.1.2 , warp >=3.3.10 , websockets >=0.12.4 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 @@ -150,9 +150,9 @@ newMempoolTx, revertBlock, ) -import Haskoin.Store.Stats import NQE - ( Listen, + ( InChan, + Listen, Mailbox, Publisher, inboxToMailbox, @@ -163,9 +163,7 @@ send, sendSTM, ) -import System.Metrics qualified as Metrics -import System.Metrics.Gauge qualified as Metrics (Gauge) -import System.Metrics.Gauge qualified as Metrics.Gauge +import System.Metrics.StatsD import System.Random (randomRIO) import UnliftIO ( Exception, @@ -229,69 +227,60 @@ } data StoreMetrics = StoreMetrics - { storeHeight :: !Metrics.Gauge, - headersHeight :: !Metrics.Gauge, - pendingTxs :: !Metrics.Gauge, - connectedPeers :: !Metrics.Gauge, - mempoolSize :: !Metrics.Gauge + { blocks :: !StatGauge, + headers :: !StatGauge, + queuedTxs :: !StatGauge, + peers :: !StatGauge, + mempool :: !StatGauge } -newStoreMetrics :: (MonadIO m) => Metrics.Store -> m StoreMetrics -newStoreMetrics s = liftIO $ do - storeHeight <- g "blockchain.height" - headersHeight <- g "blockchain.headers" - pendingTxs <- g "mempool.pending_txs" - connectedPeers <- g "network.peers_connected" - mempoolSize <- g "mempool.size" - return StoreMetrics {..} +newStoreMetrics :: (MonadIO m) => BlockStoreConfig -> m (Maybe StoreMetrics) +newStoreMetrics cfg = + forM cfg.stats $ \s -> liftIO $ do + m <- withDB cfg.db getMempool + b <- fmap (maybe 0 (.height)) $ withDB cfg.db $ runMaybeT $ + MaybeT getBestBlock >>= MaybeT . getBlock + h <- chainGetBest cfg.chain + p <- getPeers cfg.peerMgr + blocks <- g s "blocks" (fromIntegral b) + headers <- g s "headers" (fromIntegral h.height) + queuedTxs <- g s "queued_txs" 0 + peers <- g s "peers" (length p) + mempool <- g s "mempool" (length m) + return StoreMetrics {..} where - g x = Metrics.createGauge ("store." <> x) s + g s x = newStatGauge s ("store." <> x) setStoreHeight :: (MonadIO m) => BlockT m () -setStoreHeight = - asks (.metrics) >>= \case - Nothing -> return () - Just m -> - getBestBlock >>= \case - Nothing -> setit m 0 - Just bb -> - getBlock bb >>= \case - Nothing -> setit m 0 - Just b -> setit m b.height - where - setit m i = liftIO $ m.storeHeight `Metrics.Gauge.set` fromIntegral i +setStoreHeight = void $ runMaybeT $ do + m <- MaybeT (asks (.metrics)) + h <- MaybeT getBestBlock + b <- MaybeT (getBlock h) + setGauge m.blocks (fromIntegral b.height) setHeadersHeight :: (MonadIO m) => BlockT m () -setHeadersHeight = - asks (.metrics) >>= \case - Nothing -> return () - Just m -> do - h <- fmap (.height) $ chainGetBest =<< asks (.config.chain) - liftIO $ m.headersHeight `Metrics.Gauge.set` fromIntegral h +setHeadersHeight = void $ runMaybeT $ do + m <- MaybeT (asks (.metrics)) + n <- chainGetBest =<< asks (.config.chain) + setGauge m.headers (fromIntegral n.height) setPendingTxs :: (MonadIO m) => BlockT m () -setPendingTxs = - asks (.metrics) >>= \case - Nothing -> return () - Just m -> do - s <- asks (.txs) >>= \t -> atomically (HashMap.size <$> readTVar t) - liftIO $ m.pendingTxs `Metrics.Gauge.set` fromIntegral s +setPendingTxs = void $ runMaybeT $ do + m <- MaybeT (asks (.metrics)) + p <- readTVarIO =<< asks (.txs) + setGauge m.queuedTxs (HashMap.size p) setPeersConnected :: (MonadIO m) => BlockT m () -setPeersConnected = - asks (.metrics) >>= \case - Nothing -> return () - Just m -> do - ps <- fmap length $ getPeers =<< asks (.config.peerMgr) - liftIO $ m.connectedPeers `Metrics.Gauge.set` fromIntegral ps +setPeersConnected = void $ runMaybeT $ do + m <- MaybeT (asks (.metrics)) + p <- getPeers =<< asks (.config.peerMgr) + setGauge m.peers (length p) setMempoolSize :: (MonadIO m) => BlockT m () -setMempoolSize = - asks (.metrics) >>= \case - Nothing -> return () - Just m -> do - s <- length <$> getMempool - liftIO $ m.mempoolSize `Metrics.Gauge.set` fromIntegral s +setMempoolSize = void $ runMaybeT $ do + m <- MaybeT (asks (.metrics)) + p <- lift getMempool + setGauge m.mempool (length p) -- | Configuration for a block store. data BlockStoreConfig = BlockStoreConfig @@ -314,7 +303,7 @@ syncMempool :: !Bool, -- | disconnect syncing peer if inactive for this long peerTimeout :: !NominalDiffTime, - statsStore :: !(Maybe Metrics.Store) + stats :: !(Maybe Stats) } type BlockT m = ReaderT BlockStore m @@ -391,7 +380,7 @@ ts <- newTVarIO HashMap.empty rq <- newTVarIO HashSet.empty inbox <- newInbox - metrics <- mapM newStoreMetrics cfg.statsStore + metrics <- newStoreMetrics cfg let r = BlockStore { mailbox = inboxToMailbox inbox, @@ -442,6 +431,10 @@ withAsync (pingMe (inboxToMailbox inbox)) $ \a -> link a >> runBlockStoreLoop inbox +runBlockStoreLoop :: + (InChan mbox, MonadUnliftIO m, MonadLoggerIO m) => + mbox BlockStoreMessage -> + ReaderT BlockStore m b runBlockStoreLoop inbox = forever $ do $(logDebugS) "BlockStore" "Waiting for new event..." @@ -470,8 +463,8 @@ s <- asks (.config.syncMempool) when s f -mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () -mempool p = +requestMempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () +requestMempool p = guardMempool . syncMempool $ isInSync >>= \s -> when s $ do $(logDebugS) "BlockStore" $ @@ -529,7 +522,7 @@ False -> syncMe True -> do updateOrphans - mempool peer + requestMempool peer failure e = do $(logErrorS) "BlockStore" $ "Error importing block " @@ -633,7 +626,6 @@ atomically $ do modifyTVar ts $ HashMap.insert th p modifyTVar rq $ HashSet.delete th - HashMap.size <$> readTVar ts setPendingTxs where th = txHash p.tx @@ -765,9 +757,9 @@ new_mempool_tx = do t <- newMempoolTx tx seconds $(logInfoS) "BlockStore" $ - "Tx " + bool "Already have" "Imported" t + <> " tx " <> txHashToHex (txHash tx) - <> bool " was already imported" " imported" t when t $ fulfillOrphans block_read tx_hash return t @@ -797,9 +789,7 @@ unless (null txs) (import_txs block_read txs) where run_import block_read p = - let t = p.tx - h = txHash t - in importMempoolTx block_read p.time p.tx + importMempoolTx block_read p.time p.tx import_txs block_read txs = let r = mapM (run_import block_read) txs in do @@ -1097,7 +1087,7 @@ trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () trySyncingPeer p = isInSync >>= \case - True -> mempool p + True -> requestMempool p False -> trySetPeer p >>= \case False -> return () 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 @@ -37,46 +37,34 @@ where import Control.DeepSeq (NFData) -import Control.Monad (forM, forM_, forever, guard, unless, void, when, (>=>)) +import Control.Monad (forM, forM_, forever, unless, void, when) import Control.Monad.Logger ( MonadLoggerIO, logDebugS, logErrorS, logInfoS, - logWarnS, ) -import Control.Monad.Reader (ReaderT (..), ask, asks) +import Control.Monad.Reader (ReaderT (..), asks) import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Bits (complement, shift, (.&.), (.|.)) +import Data.Bits (shift, (.&.), (.|.)) import Data.ByteString (ByteString) -import Data.ByteString qualified as B import Data.Default (def) import Data.Either (fromRight, isRight, rights) import Data.Functor ((<&>)) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap -import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet import Data.IntMap.Strict qualified as I import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Maybe ( catMaybes, - fromMaybe, - isJust, - isNothing, mapMaybe, ) import Data.Serialize (Serialize, decode, encode) import Data.String.Conversions (cs) import Data.Text (Text) -import Data.Time.Clock (NominalDiffTime, diffUTCTime) -import Data.Time.Clock.System - ( getSystemTime, - systemSeconds, - systemToUTCTime, - ) +import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import Database.Redis ( Connection, @@ -93,12 +81,10 @@ zrem, ) import Database.Redis qualified as Redis -import Database.Redis qualified as Reids import GHC.Generics (Generic) import Haskoin ( Address, BlockHash, - BlockHeader (..), BlockNode (..), Ctx, DerivPathI (..), @@ -124,8 +110,6 @@ ) import Haskoin.Node ( Chain, - chainBlockMain, - chainGetAncestor, chainGetBest, chainGetBlock, chainGetParents, @@ -133,49 +117,35 @@ ) import Haskoin.Store.Common import Haskoin.Store.Data -import Haskoin.Store.Stats +import Haskoin.Store.Database.Reader (DatabaseReader, withDB) import NQE ( Inbox, Listen, Mailbox, - inboxToMailbox, query, receive, send, ) -import System.Metrics qualified as Metrics -import System.Metrics.Counter qualified as Metrics (Counter) -import System.Metrics.Counter qualified as Metrics.Counter -import System.Metrics.Distribution qualified as Metrics (Distribution) -import System.Metrics.Distribution qualified as Metrics.Distribution -import System.Metrics.Gauge qualified as Metrics (Gauge) -import System.Metrics.Gauge qualified as Metrics.Gauge -import System.Random (randomIO, randomRIO) +import System.Metrics.StatsD import UnliftIO ( Exception, MonadIO, MonadUnliftIO, - TQueue, - TVar, atomically, bracket, liftIO, - link, - modifyTVar, - newTVarIO, - readTQueue, - readTVar, throwIO, - wait, withAsync, - writeTQueue, - writeTVar, ) import UnliftIO.Concurrent (threadDelay) runRedis :: (MonadLoggerIO m) => Redis (Either Reply a) -> CacheX m a runRedis action = do conn <- asks (.redis) + withRedis conn action + +withRedis :: (MonadLoggerIO m) => Connection -> Redis (Either Reply a) -> m a +withRedis conn action = liftIO (Redis.runRedis conn action) >>= \case Right x -> return x Left e -> do @@ -191,64 +161,69 @@ } data CacheMetrics = CacheMetrics - { cacheHits :: !Metrics.Counter, - cacheMisses :: !Metrics.Counter, - lockAcquired :: !Metrics.Counter, - lockReleased :: !Metrics.Counter, - lockFailed :: !Metrics.Counter, - xPubBals :: !Metrics.Counter, - xPubUnspents :: !Metrics.Counter, - xPubTx :: !Metrics.Counter, - xPubTxCount :: !Metrics.Counter, - indexTime :: !StatDist + { hits :: !StatCounter, + misses :: !StatCounter, + lockAcquired :: !StatCounter, + lockReleased :: !StatCounter, + lockFailed :: !StatCounter, + xBalances :: !StatCounter, + xUnspents :: !StatCounter, + xTxs :: !StatCounter, + xTxCount :: !StatCounter, + indexTime :: !StatTiming, + height :: !StatGauge } -newCacheMetrics :: (MonadIO m) => Metrics.Store -> m CacheMetrics -newCacheMetrics s = liftIO $ do - cacheHits <- c "cache.hits" - cacheMisses <- c "cache.misses" +newCacheMetrics :: + (MonadLoggerIO m) => + Stats -> + Connection -> + DatabaseReader -> + m CacheMetrics +newCacheMetrics s r db = do + h <- redisBest + hits <- c "cache.hits" + misses <- c "cache.misses" 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" + xBalances <- c "cache.xpub_balances" + xUnspents <- c "cache.xpub_unspents" + xTxs <- c "cache.xpub_txs" + xTxCount <- c "cache.xpub_tx_count" + height <- newStatGauge s "cache.height" h return CacheMetrics {..} where - c x = Metrics.createCounter x s - d x = createStatDist x s + redisBest = + maybe dbBest dbBlock =<< withRedis r redisGetHead + dbBlock h = + maybe 0 (fromIntegral . (.height)) <$> withDB db (getBlock h) + dbBest = + maybe (return 0) dbBlock =<< withDB db getBestBlock + c x = newStatCounter s x 10 + d x = newStatTiming s x 10 -withMetrics :: +withTiming :: (MonadUnliftIO m) => - (CacheMetrics -> StatDist) -> + (CacheMetrics -> StatTiming) -> CacheX m a -> CacheX m a -withMetrics df go = +withTiming df go = asks (.metrics) >>= \case Nothing -> go Just m -> bracket - (systemToUTCTime <$> liftIO getSystemTime) + time (end m) (const go) where - end metrics t1 = do - t2 <- systemToUTCTime <$> liftIO getSystemTime - let diff = round $ diffUTCTime t2 t1 * 1000 - df metrics `addStatTime` diff - addStatQuery (df metrics) + time = round . (* 1000) <$> liftIO getPOSIXTime + end m t1 = time >>= addTiming (df m) . subtract t1 -incrementCounter :: - (MonadIO m) => - (CacheMetrics -> Metrics.Counter) -> - Int -> - CacheX m () -incrementCounter f i = - asks (.metrics) >>= \case - Just s -> liftIO $ Metrics.Counter.add (f s) (fromIntegral i) - Nothing -> return () +withMetrics :: + (MonadIO m) => (CacheMetrics -> CacheX m a) -> CacheX m () +withMetrics go = asks (.metrics) >>= mapM_ go type CacheT = ReaderT (Maybe CacheConfig) @@ -271,7 +246,22 @@ liftIO (checkedConnect conninfo) instance - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + (MonadUnliftIO m, StoreReadBase m) => + StoreReadBase (CacheX m) + where + getCtx = lift getCtx + getNetwork = lift getNetwork + getBestBlock = lift getBestBlock + getBlocksAtHeight = lift . getBlocksAtHeight + getBlock = lift . getBlock + getTxData = lift . getTxData + getSpender = lift . getSpender + getBalance = lift . getBalance + getUnspent = lift . getUnspent + getMempool = lift getMempool + +instance + (MonadUnliftIO m, StoreReadBase m) => StoreReadBase (CacheT m) where getCtx = lift getCtx @@ -287,6 +277,23 @@ instance (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + StoreReadExtra (CacheX m) + where + getBalances = lift . getBalances + getAddressesTxs addrs = lift . getAddressesTxs addrs + getAddressTxs addr = lift . getAddressTxs addr + getAddressUnspents addr = lift . getAddressUnspents addr + getAddressesUnspents addrs = lift . getAddressesUnspents addrs + getMaxGap = lift getMaxGap + getInitialGap = lift getInitialGap + getNumTxData = lift . getNumTxData + xPubTxs = getXPubTxs + xPubTxCount = getXPubTxCount + xPubBals = getXPubBalances + xPubUnspents = getXPubUnspents + +instance + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => StoreReadExtra (CacheT m) where getBalances = lift . getBalances @@ -298,39 +305,23 @@ getInitialGap = lift getInitialGap getNumTxData = lift . getNumTxData xPubBals xpub = - ask >>= \case - Nothing -> - lift $ - xPubBals xpub - Just cfg -> - lift $ - runReaderT (getXPubBalances xpub) cfg + ReaderT $ \case + Nothing -> xPubBals xpub + Just cfg -> runReaderT (xPubBals xpub) cfg xPubUnspents xpub xbals limits = - ask >>= \case - Nothing -> - lift $ - xPubUnspents xpub xbals limits - Just cfg -> - lift $ - runReaderT (getXPubUnspents xpub xbals limits) cfg + ReaderT $ \case + Nothing -> xPubUnspents xpub xbals limits + Just cfg -> runReaderT (xPubUnspents xpub xbals limits) cfg xPubTxs xpub xbals limits = - ask >>= \case - Nothing -> - lift $ - xPubTxs xpub xbals limits - Just cfg -> - lift $ - runReaderT (getXPubTxs xpub xbals limits) cfg + ReaderT $ \case + Nothing -> xPubTxs xpub xbals limits + Just cfg -> runReaderT (xPubTxs xpub xbals limits) cfg xPubTxCount xpub xbals = - ask >>= \case - Nothing -> - lift $ - xPubTxCount xpub xbals - Just cfg -> - lift $ - runReaderT (getXPubTxCount xpub xbals) cfg + ReaderT $ \case + Nothing -> xPubTxCount xpub xbals + Just cfg -> runReaderT (xPubTxCount xpub xbals) cfg -withCache :: (StoreReadBase m) => Maybe CacheConfig -> CacheT m a -> m a +withCache :: Maybe CacheConfig -> CacheT m a -> m a withCache s f = runReaderT f s balancesPfx :: ByteString @@ -353,40 +344,41 @@ CacheX m [TxRef] getXPubTxs xpub xbals limits = go False where - go m = - 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 + go recursed = do + cached <- isXPubCached recursed xpub + if cached + then do + txs <- cacheGetXPubTxs xpub limits + withMetrics $ \s -> + incrementCounter s.xTxs (length txs) + return txs + else do + if recursed + then lift $ xPubTxs xpub xbals limits + else do + newXPubC xpub xbals + go True getXPubTxCount :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => XPubSpec -> [XPubBal] -> CacheX m Word32 -getXPubTxCount xpub xbals = - go False +getXPubTxCount xpub xbals = go False where - go t = - 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 + go recursed = do + cached <- isXPubCached recursed xpub + if cached + then do + withMetrics $ \s -> + incrementCounter s.xTxCount 1 + cacheGetXPubTxCount xpub + else do + if recursed + then lift $ xPubTxCount xpub xbals + else do + newXPubC xpub xbals + go True getXPubUnspents :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => @@ -397,70 +389,69 @@ getXPubUnspents xpub xbals limits = go False where - xm = - let f x = (x.balance.address, x) - g = (> 0) . (.balance.utxo) - in HashMap.fromList $ map f $ filter g xbals - go m = - 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 ctx u.script) - g a = HashMap.lookup a xm - h u x = - XPubUnspent - { unspent = u, - path = x.path - } - us = mapMaybe f uns - i a u = h u <$> g a - incrementCounter (.xPubUnspents) (length us) - return $ mapMaybe (uncurry i) us + go recursed = do + cached <- isXPubCached recursed xpub + if cached + then 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 ctx u.script) + xm = + let j x = (x.balance.address, x) + k = (> 0) . (.balance.utxo) + in HashMap.fromList $ map j $ filter k xbals + g a = HashMap.lookup a xm + h u x = + XPubUnspent + { unspent = u, + path = x.path + } + us = mapMaybe f uns + i a u = h u <$> g a + withMetrics $ \s -> incrementCounter s.xUnspents (length us) + return $ mapMaybe (uncurry i) us + else do + if recursed + then lift $ xPubUnspents xpub xbals limits + else do + newXPubC xpub xbals + go True getXPubBalances :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => XPubSpec -> CacheX m [XPubBal] -getXPubBalances xpub = - 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 +getXPubBalances xpub = do + cached <- isXPubCached False xpub + if cached + then do + xbals <- cacheGetXPubBalances xpub + withMetrics $ \s -> incrementCounter s.xBalances (length xbals) + return xbals + else do + bals <- lift $ xPubBals xpub + newXPubC xpub bals + return bals isInCache :: (MonadLoggerIO m) => XPubSpec -> CacheT m Bool isInCache xpub = - ask >>= \case + ReaderT $ \case Nothing -> return False - Just cfg -> runReaderT (isXPubCached xpub) cfg + Just cfg -> runReaderT (isXPubCached True xpub) cfg -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 +isXPubCached :: (MonadLoggerIO m) => Bool -> XPubSpec -> CacheX m Bool +isXPubCached silent xpub = do + cached <- runRedis (redisIsXPubCached xpub) + unless silent $ withMetrics $ \s -> + if cached + then incrementCounter s.hits 1 + else incrementCounter s.misses 1 + return cached redisIsXPubCached :: (RedisCtx m f) => XPubSpec -> m (f Bool) redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub) @@ -472,7 +463,7 @@ return bals cacheGetXPubTxCount :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + (MonadUnliftIO m, MonadLoggerIO m) => XPubSpec -> CacheX m Word32 cacheGetXPubTxCount xpub = do @@ -666,8 +657,8 @@ return [ (k, v) | (k', v') <- xs, - let Right k = decode k', - let Right v = decode v' + let k = fromRight undefined $ decode k', + let v = fromRight undefined $ decode v' ] data CacheWriterMessage @@ -723,28 +714,28 @@ go >>= \case Right Redis.Ok -> do $(logDebugS) "Cache" "Acquired lock" - incrementCounter (.lockAcquired) 1 + withMetrics $ \s -> incrementCounter s.lockAcquired 1 return True Right Redis.Pong -> do $(logErrorS) "Cache" "Unexpected pong when acquiring lock" - incrementCounter (.lockFailed) 1 + withMetrics $ \s -> incrementCounter s.lockFailed 1 return False Right (Redis.Status s) -> do $(logErrorS) "Cache" $ "Unexpected status acquiring lock: " <> cs s - incrementCounter (.lockFailed) 1 + withMetrics $ \m -> incrementCounter m.lockFailed 1 return False Left (Redis.Bulk Nothing) -> do $(logDebugS) "Cache" "Lock already taken" - incrementCounter (.lockFailed) 1 + withMetrics $ \s -> incrementCounter s.lockFailed 1 return False Left e -> do $(logErrorS) "Cache" "Error when trying to acquire lock" - incrementCounter (.lockFailed) 1 + withMetrics $ \s -> incrementCounter s.lockFailed 1 throwIO (RedisError e) where go = do @@ -786,37 +777,19 @@ threadDelay (150 * 1000 * 1000) refreshLock -isFull :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - CacheX m Bool -isFull = do - x <- asks (.maxKeys) - s <- runRedis Redis.dbsize - return $ s > x - pruneDB :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - CacheX m Integer + (MonadLoggerIO m, StoreReadBase m) => CacheX m () pruneDB = do - x <- asks (((`div` 10) . (* 8)) . (.maxKeys)) - -- Prune to 80% of max + x <- asks (.maxKeys) s <- runRedis Redis.dbsize - if s > x then flush (s - x) else return 0 - where - flush n = - case n `div` 64 of - 0 -> return 0 - x -> do - ks <- - fmap (map fst) . runRedis $ - getFromSortedSet maxKey Nothing 0 (fromIntegral x) - $(logDebugS) "Cache" $ - "Pruning " <> cs (show (length ks)) <> " old xpubs" - delXPubKeys ks + $(logDebugS) "Cache" "Pruning old xpubs" + when (s > x) $ + void . delXPubKeys . map fst + =<< runRedis (getFromSortedSet maxKey Nothing 0 32) touchKeys :: (MonadLoggerIO m) => [XPubSpec] -> CacheX m () touchKeys xpubs = do - now <- systemSeconds <$> liftIO getSystemTime + now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int runRedis $ redisTouchKeys now xpubs redisTouchKeys :: (Monad f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f ()) @@ -853,7 +826,7 @@ newXPubC xpub xbals = should_index >>= \i -> when i $ bracket set_index unset_index $ \j -> when j $ - withMetrics (.indexTime) $ do + withTiming (.indexTime) $ do xpubtxt <- xpubText xpub $(logDebugS) "Cache" $ "Caching " @@ -877,7 +850,7 @@ <> ": " <> cs (show (length xtxs)) <> " txs" - now <- systemSeconds <$> liftIO getSystemTime + now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int runRedis $ do b <- redisTouchKeys now [xpub] c <- redisAddXPubBalances xpub xbals @@ -893,7 +866,7 @@ then inSync >>= \s -> if s - then not <$> isFull + then pruneDB >> return True else return False else return False key = idxPfx <> encode xpub @@ -910,7 +883,7 @@ liftIO (Redis.runRedis conn red) <&> isRight inSync :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + (MonadUnliftIO m, StoreReadExtra m) => CacheX m Bool inSync = lift getBestBlock >>= \case @@ -983,7 +956,7 @@ <> cs (show (length tds)) <> " transactions from block " <> blockHashToHex bh - cacheSetHead bh + cacheSetHead bd Nothing -> do $(logErrorS) "Cache" $ "Could not get block: " @@ -1016,7 +989,7 @@ <> " outputs" unspentmap <- getunspents ctx gap <- lift getMaxGap - now <- systemSeconds <$> liftIO getSystemTime + now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int let xpubs = allxpubsls addrmap forM_ (zip [(1 :: Int) ..] xpubs) $ \(i, xpub) -> do xpubtxt <- xpubText xpub @@ -1266,16 +1239,16 @@ cacheGetMempool :: (MonadLoggerIO m) => CacheX m [(UnixTime, TxHash)] cacheGetMempool = runRedis redisGetMempool -cacheIsInMempool :: (MonadLoggerIO m) => TxHash -> CacheX m Bool -cacheIsInMempool = runRedis . redisIsInMempool - cacheGetHead :: (MonadLoggerIO m) => CacheX m (Maybe BlockHash) cacheGetHead = runRedis redisGetHead -cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m () -cacheSetHead bh = do +cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockData -> CacheX m () +cacheSetHead bd = do $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh void $ runRedis (redisSetHead bh) + withMetrics $ \s -> setGauge s.height (fromIntegral bd.height) + where + bh = headerHash bd.header cacheGetAddrsInfo :: (MonadLoggerIO m) => [Address] -> CacheX m [Maybe AddressXPub] @@ -1289,10 +1262,6 @@ (\btx -> (blockRefScore btx.block, encode btx.txid)) btxs -redisIsInMempool :: (Applicative f, RedisCtx m f) => TxHash -> m (f Bool) -redisIsInMempool txid = - fmap isJust <$> Redis.zrank mempoolSetKey (encode txid) - redisRemFromMempool :: (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer) redisRemFromMempool [] = return (pure 0) @@ -1303,7 +1272,7 @@ redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i) cacheDelXPubs :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + (MonadLoggerIO m, StoreReadBase m) => [XPubSpec] -> CacheT m Integer cacheDelXPubs xpubs = ReaderT $ \case @@ -1311,7 +1280,7 @@ Nothing -> return 0 delXPubKeys :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + (MonadLoggerIO m, StoreReadBase m) => [XPubSpec] -> CacheX m Integer delXPubKeys [] = return 0 @@ -1414,10 +1383,10 @@ | null fbals = [] | not haschange = - zipWith f (addrs ctx) list - <> zipWith f (changeaddrs ctx) changelist + zipWith f addrs list + <> zipWith f changeaddrs changelist | otherwise = - zipWith f (addrs ctx) list + zipWith f addrs list where haschange = any ((== 1) . head . (.path)) xbals f a p = (a, AddressXPub {spec = xpub, path = p}) @@ -1431,12 +1400,12 @@ then [maxidx + 1 .. aidx + gap] else [] paths = map (Deriv :/ dchain :/) ixs - keys ctx = map (\p -> derivePubPath ctx p xpub.key) + keys = map (\p -> derivePubPath ctx p xpub.key) list = map pathToList paths - xpubf ctx = xPubAddrFunction ctx xpub.deriv - addrs ctx = map (xpubf ctx) (keys ctx paths) + xpubf = xPubAddrFunction ctx xpub.deriv + addrs = map xpubf (keys paths) changepaths = map (Deriv :/ 1 :/) [0 .. gap - 1] - changeaddrs ctx = map (xpubf ctx) (keys ctx changepaths) + changeaddrs = map xpubf (keys changepaths) changelist = map pathToList changepaths sortTxData :: [TxData] -> [TxData] @@ -1484,9 +1453,7 @@ f t s = ((scoreBlockRef s).timestamp, t) xpubText :: - ( MonadUnliftIO m, - MonadLoggerIO m, - StoreReadBase m + ( StoreReadBase m ) => XPubSpec -> CacheX m Text 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 @@ -19,7 +19,6 @@ StoreWrite (..), StoreEvent (..), PubExcept (..), - DataMetrics (..), getActiveBlock, getActiveTxData, getDefaultBalance, @@ -41,7 +40,6 @@ microseconds, streamThings, joinDescStreams, - createDataMetrics, ) where @@ -57,7 +55,6 @@ ) import Control.DeepSeq (NFData) import Control.Exception (Exception) -import Control.Monad (forM) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Monad.Trans.Reader (runReaderT) @@ -65,12 +62,8 @@ import Data.Default (Default (..)) import Data.HashSet qualified as H import Data.Hashable (Hashable) -import Data.IntMap.Strict (IntMap) -import Data.IntMap.Strict qualified as I -import Data.List (sortOn) import Data.Map.Strict qualified as Map -import Data.Maybe (catMaybes, mapMaybe) -import Data.Ord (Down (..)) +import Data.Maybe (mapMaybe) import Data.Serialize (Serialize (..)) import Data.Time.Clock.System ( getSystemTime, @@ -99,9 +92,6 @@ toTransaction, zeroBalance, ) -import System.Metrics qualified as Metrics -import System.Metrics.Counter (Counter) -import System.Metrics.Counter qualified as Counter import UnliftIO (MonadIO, liftIO) type DeriveAddr = XPubKey -> KeyIndex -> Address @@ -111,8 +101,8 @@ type Limit = Word32 data Start - = AtTx {atTxHash :: !TxHash} - | AtBlock {atBlockHeight :: !BlockHeight} + = AtTx !TxHash + | AtBlock !BlockHeight deriving (Eq, Show) data Limits = Limits @@ -214,13 +204,13 @@ rx = sum [b.balance.received | b <- xt] getTransaction :: - (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) + ( StoreReadBase m) =>TxHash -> m (Maybe Transaction) getTransaction h = do ctx <- getCtx fmap (toTransaction ctx) <$> getTxData h getNumTransaction :: - (Monad m, StoreReadExtra m) => Word64 -> m [Transaction] + ( StoreReadExtra m) =>Word64 -> m [Transaction] getNumTransaction i = getCtx >>= \ctx -> map (toTransaction ctx) <$> getNumTxData i @@ -341,7 +331,7 @@ 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' :: (Hashable a) => [a] -> [a] nub' = H.toList . H.fromList microseconds :: (MonadIO m) => m Integer @@ -398,32 +388,3 @@ let mp2 = Map.deleteMax mp mp' = Map.unionWith (++) mp1 mp2 go (Just x) mp' - -data DataMetrics = DataMetrics - { dataBestCount :: !Counter, - dataBlockCount :: !Counter, - dataTxCount :: !Counter, - dataMempoolCount :: !Counter, - dataBalanceCount :: !Counter, - dataUnspentCount :: !Counter, - dataAddrTxCount :: !Counter, - dataXPubBals :: !Counter, - dataXPubUnspents :: !Counter, - dataXPubTxs :: !Counter, - dataXPubTxCount :: !Counter - } - -createDataMetrics :: (MonadIO m) => Metrics.Store -> m DataMetrics -createDataMetrics s = liftIO $ do - dataBestCount <- Metrics.createCounter "data.best_block" s - dataBlockCount <- Metrics.createCounter "data.blocks" s - dataTxCount <- Metrics.createCounter "data.txs" s - dataMempoolCount <- Metrics.createCounter "data.mempool" s - dataBalanceCount <- Metrics.createCounter "data.balances" s - dataUnspentCount <- Metrics.createCounter "data.unspents" s - dataAddrTxCount <- Metrics.createCounter "data.address_txs" s - dataXPubBals <- Metrics.createCounter "data.xpub_balances" s - dataXPubUnspents <- Metrics.createCounter "data.xpub_unspents" s - dataXPubTxs <- Metrics.createCounter "data.xpub_txs" s - dataXPubTxCount <- Metrics.createCounter "data.xpub_tx_count" s - return DataMetrics {..} 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 @@ -5,12 +5,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} module Haskoin.Store.Database.Reader ( -- * RocksDB Database Access DatabaseReader (..), DatabaseReaderT, + DataMetrics, + withDB, + createDataMetrics, withDatabaseReader, addrTxCF, addrOutCF, @@ -24,28 +28,25 @@ import Conduit ( ConduitT, - dropC, dropWhileC, lift, mapC, runConduit, sinkList, - takeC, (.|), ) import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) +import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits ((.&.)) import Data.ByteString qualified as BS import Data.Default (def) -import Data.Function (on) import Data.IntMap.Strict qualified as IntMap import Data.List (sortOn) import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) import Data.Serialize (encode) -import Data.Word (Word32, Word64) +import Data.Word (Word32) import Database.RocksDB ( ColumnFamily, Config (..), @@ -63,23 +64,11 @@ retrieveCF, ) import Haskoin - ( Address, - BlockHash, - BlockHeight, - Ctx, - Network, - OutPoint (..), - TxHash, - pubSubKey, - txHash, - ) import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types -import System.Metrics qualified as Metrics -import System.Metrics.Counter (Counter) -import System.Metrics.Counter qualified as Counter -import UnliftIO (MonadIO, MonadUnliftIO, liftIO) +import System.Metrics.StatsD +import UnliftIO (MonadIO, MonadUnliftIO, bracket_, liftIO) type DatabaseReaderT = ReaderT DatabaseReader @@ -92,19 +81,48 @@ ctx :: !Ctx } -incrementCounter :: - (MonadIO m) => - (DataMetrics -> Counter) -> - Int -> - ReaderT DatabaseReader m () -incrementCounter f i = - asks (.metrics) >>= \case - Just s -> liftIO $ Counter.add (f s) (fromIntegral i) - Nothing -> return () +data DataMetrics = DataMetrics + { dataBestCount :: !StatCounter, + dataBlockCount :: !StatCounter, + dataTxCount :: !StatCounter, + dataMempoolCount :: !StatCounter, + dataBalanceCount :: !StatCounter, + dataUnspentCount :: !StatCounter, + dataAddrTxCount :: !StatCounter, + dataXPubBals :: !StatCounter, + dataXPubUnspents :: !StatCounter, + dataXPubTxs :: !StatCounter, + dataXPubTxCount :: !StatCounter, + dataIters :: !StatGauge + } +createDataMetrics :: (MonadIO m) => Stats -> m DataMetrics +createDataMetrics s = do + dataBestCount <- newStatCounter s "db.best_block" n + dataBlockCount <- newStatCounter s "db.blocks" n + dataTxCount <- newStatCounter s "db.txs" n + dataMempoolCount <- newStatCounter s "db.mempool" n + dataBalanceCount <- newStatCounter s "db.balances" n + dataUnspentCount <- newStatCounter s "db.unspents" n + dataAddrTxCount <- newStatCounter s "db.address_txs" n + dataXPubBals <- newStatCounter s "db.xpub_balances" n + dataXPubUnspents <- newStatCounter s "db.xpub_unspents" n + dataXPubTxs <- newStatCounter s "db.xpub_txs" n + dataXPubTxCount <- newStatCounter s "db.xpub_tx_count" n + dataIters <- newStatGauge s "db.iterators" 0 + return DataMetrics {..} + where + n = 10 + +withMetrics :: (MonadReader DatabaseReader m) => (DataMetrics -> m a) -> m () +withMetrics go = asks (.metrics) >>= mapM_ go + dataVersion :: Word32 dataVersion = 18 +withDB :: DatabaseReader -> DatabaseReaderT m a -> m a +withDB = flip runReaderT + withDatabaseReader :: (MonadUnliftIO m) => Network -> @@ -129,7 +147,7 @@ initRocksDB bdb runReaderT f bdb where - cfg = def {createIfMissing = True, maxFiles = Just (-1)} + cfg = def {createIfMissing = True} columnFamilyConfig :: [(String, Config)] columnFamilyConfig = @@ -204,10 +222,9 @@ Just TxData {block = b@BlockRef {}} -> matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) Just TxData {block = MemRef {}} -> - let cond (AddrTxKey _a (TxRef MemRef {} th)) = - th /= txh - cond (AddrTxKey _a (TxRef BlockRef {} _th)) = - False + let cond (AddrTxKey _ (TxRef MemRef {} th)) = th /= txh + cond (AddrTxKey _ (TxRef BlockRef {} _)) = False + cond _ = undefined in matching it (AddrTxKeyA a) .| (dropWhileC (cond . fst) >> mapC id) Nothing -> return () @@ -235,25 +252,35 @@ Just TxData {block = b@BlockRef {}} -> matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) Just TxData {block = MemRef {}} -> - let cond (AddrOutKey _a MemRef {} p) = - p.hash /= txh - cond (AddrOutKey _a BlockRef {} _p) = - False + let cond (AddrOutKey _ MemRef {} p) = p.hash /= txh + cond (AddrOutKey _ BlockRef {} _) = False + cond _ = undefined in matching it (AddrOutKeyA a) .| (dropWhileC (cond . fst) >> mapC id) Nothing -> return () +withIterCFStat :: + (MonadUnliftIO m) => + DB -> + ColumnFamily -> + (Iterator -> DatabaseReaderT m a) -> + DatabaseReaderT m a +withIterCFStat db cf = bracket_ open close . withIterCF db cf + where + open = asks (.metrics) >>= mapM_ (\m -> incrementGauge m.dataIters 1) + close = asks (.metrics) >>= mapM_ (\m -> decrementGauge m.dataIters 1) + withManyIters :: (MonadUnliftIO m) => DB -> ColumnFamily -> Int -> - ([Iterator] -> m a) -> - m a + ([Iterator] -> DatabaseReaderT m a) -> + DatabaseReaderT m a withManyIters db cf i f = go [] i where go acc 0 = f acc - go acc n = withIterCF db cf $ \it -> go (it : acc) (n - 1) + go acc n = withIterCFStat db cf $ \it -> go (it : acc) (n - 1) joinConduits :: (Monad m, Ord o) => @@ -272,7 +299,7 @@ retrieveCF db (txCF db) (TxKey th) >>= \case Nothing -> return Nothing Just t -> do - incrementCounter (.dataTxCount) 1 + withMetrics $ \s -> incrementCounter s.dataTxCount 1 return (Just t) getSpender op = runMaybeT $ do @@ -287,21 +314,21 @@ case fmap (valToUnspent ctx p) val of Nothing -> return Nothing Just u -> do - incrementCounter (.dataUnspentCount) 1 + withMetrics $ \s -> incrementCounter s.dataUnspentCount 1 return (Just u) getBalance a = do db <- asks (.db) - incrementCounter (.dataBalanceCount) 1 + withMetrics $ \s -> incrementCounter s.dataBalanceCount 1 fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) getMempool = do db <- asks (.db) - incrementCounter (.dataMempoolCount) 1 + withMetrics $ \s -> incrementCounter s.dataMempoolCount 1 fromMaybe [] <$> retrieve db MemKey getBestBlock = do - incrementCounter (.dataBestCount) 1 + withMetrics $ \s -> incrementCounter s.dataBestCount 1 asks (.db) >>= (`retrieve` BestKey) getBlocksAtHeight h = do @@ -309,7 +336,7 @@ retrieveCF db (heightCF db) (HeightKey h) >>= \case Nothing -> return [] Just ls -> do - incrementCounter (.dataBlockCount) (length ls) + withMetrics $ \s -> incrementCounter s.dataBlockCount (length ls) return ls getBlock h = do @@ -317,7 +344,7 @@ retrieveCF db (blockCF db) (BlockKey h) >>= \case Nothing -> return Nothing Just b -> do - incrementCounter (.dataBlockCount) 1 + withMetrics $ \s -> incrementCounter s.dataBlockCount 1 return (Just b) instance (MonadUnliftIO m) => StoreReadExtra (DatabaseReaderT m) where @@ -325,7 +352,7 @@ db <- asks (.db) withManyIters db (addrTxCF db) (length addrs) $ \its -> do txs <- joinConduits (cs its) limits - incrementCounter (.dataAddrTxCount) (length txs) + withMetrics $ \s -> incrementCounter s.dataAddrTxCount (length txs) return txs where cs = zipWith c addrs @@ -336,7 +363,7 @@ ctx <- asks (.ctx) withManyIters db (addrOutCF db) (length addrs) $ \its -> do uns <- joinConduits (cs ctx its) limits - incrementCounter (.dataUnspentCount) (length uns) + withMetrics $ \s -> incrementCounter s.dataUnspentCount (length uns) return uns where cs ctx = zipWith (c ctx) addrs @@ -345,22 +372,22 @@ getAddressUnspents a limits = do db <- asks (.db) ctx <- asks (.ctx) - us <- withIterCF db (addrOutCF db) $ \it -> + us <- withIterCFStat db (addrOutCF db) $ \it -> runConduit $ unspentConduit ctx a limits.start it .| applyLimitsC limits .| sinkList - incrementCounter (.dataUnspentCount) (length us) + withMetrics $ \s -> incrementCounter s.dataUnspentCount (length us) return us getAddressTxs a limits = do db <- asks (.db) - txs <- withIterCF db (addrTxCF db) $ \it -> + txs <- withIterCFStat db (addrTxCF db) $ \it -> runConduit $ addressConduit a limits.start it .| applyLimitsC limits .| sinkList - incrementCounter (.dataAddrTxCount) (length txs) + withMetrics $ \s -> incrementCounter s.dataAddrTxCount (length txs) return txs getMaxGap = asks (.maxGap) @@ -377,7 +404,7 @@ w' = b .&. 0xf8 in w == w' txs = filter f $ map snd ls - incrementCounter (.dataTxCount) (length txs) + withMetrics $ \s -> incrementCounter s.dataTxCount (length txs) return txs getBalances as = do @@ -391,34 +418,44 @@ igap <- getInitialGap gap <- getMaxGap ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv ctx 0 0)) - if all (nullBalance . (.balance)) ext1 + if all nullxb ext1 then do - incrementCounter (.dataXPubBals) (length ext1) + withMetrics $ \s -> incrementCounter s.dataXPubBals (length ext1) return ext1 else do 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) + withMetrics $ \s -> incrementCounter s.dataXPubBals (length bals) return bals where + nullxb b = nullBalance b.balance aderiv ctx m = deriveAddresses (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 - bs <- getBalances (map snd as1) - let xbs = zipWith (xbalance m) bs (map fst as1) - if all nullBalance bs - then return xbs - else (xbs <>) <$> derive_until_gap gap m as2 + derive_until_gap gap m adrs = + let xb b n = XPubBal {path = [m, n], balance = b} + ig = fromIntegral gap + test acc = + let ns = takeWhile nullxb acc + in length ns > ig + go acc [] = return $ reverse acc + go acc as + | test acc = + let (ns, ys) = span nullxb acc + xs = take ig $ reverse ns + in return $ reverse ys <> xs + | otherwise = do + let (as', as'') = splitAt ig as + bs <- getBalances (map snd as') + let xs = reverse $ zipWith xb bs (map fst as') + go (xs <> acc) as'' + in go [] adrs xPubUnspents _xspec xbals limits = do us <- concat <$> mapM h cs - incrementCounter (.dataXPubUnspents) (length us) + withMetrics $ \s -> incrementCounter s.dataXPubUnspents (length us) return . applyLimits limits $ sortOn Down us where l = deOffset limits @@ -433,9 +470,9 @@ filter (not . nullBalance) $ map (.balance) xbals txs <- getAddressesTxs as limits - incrementCounter (.dataXPubTxs) (length txs) + withMetrics $ \s -> incrementCounter s.dataXPubTxs (length txs) return txs xPubTxCount xspec xbals = do - incrementCounter (.dataXPubTxCount) 1 + withMetrics $ \s -> incrementCounter s.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 @@ -33,27 +33,19 @@ import Control.DeepSeq (NFData) import Control.Monad (guard) import Data.Bits - ( Bits, - shift, - shiftL, - shiftR, + ( shift, (.&.), - (.|.), ) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Default (Default (..)) -import Data.Either (fromRight) import Data.Hashable (Hashable) import Data.Serialize ( Serialize (..), - decode, - encode, getBytes, getWord16be, getWord32be, getWord8, - putWord32be, putWord64be, putWord8, runGet, @@ -76,7 +68,6 @@ ( Balance (..), BlockData, BlockRef, - Spender, TxData, TxRef (..), UnixTime, 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 @@ -10,11 +10,8 @@ module Haskoin.Store.Database.Writer (WriterT, runWriter) where -import Control.Monad (join) import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Reader qualified as R -import Data.HashMap.Strict (HashMap) -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) @@ -46,15 +43,9 @@ import UnliftIO ( IORef, MonadIO, - TVar, - atomically, liftIO, - modifyIORef, - modifyTVar, newIORef, - newTVarIO, readIORef, - readTVarIO, writeIORef, ) @@ -77,8 +68,6 @@ getBalance = getBalanceI getMempool = getMempoolI -type NetRef = IORef (Maybe Network) - type BestRef = IORef (Maybe (Maybe BlockHash)) type BlockTable = H.BasicHashTable BlockHash (Maybe BlockData) @@ -219,7 +208,7 @@ 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 (Just t') = insertOpCF (txCF db) (TxKey k) t' f k Nothing = deleteOpCF (txCF db) (TxKey k) balOps :: (MonadIO m) => DB -> BalanceTable -> m [BatchOp] @@ -231,8 +220,8 @@ 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) + 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 db t = map (uncurry f) <$> liftIO (H.toList t) @@ -313,12 +302,6 @@ 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 . (.best) @@ -339,9 +322,6 @@ getBalanceH :: Address -> Memory -> IO (Maybe (Maybe Balance)) getBalanceH a s = H.lookup s.balanceTable a - -getMempoolH :: Memory -> IO [(UnixTime, TxHash)] -getMempoolH Memory {..} = sortOn Down . map swap <$> H.toList mempoolTable getUnspentH :: OutPoint -> Memory -> IO (Maybe (Maybe Unspent)) 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 @@ -30,7 +30,6 @@ void, when, zipWithM_, - (<=<), ) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Logger @@ -40,7 +39,6 @@ ) import qualified Data.ByteString as B import Data.Either (rights) -import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import qualified Data.IntMap.Strict as I import Data.List (nub) @@ -135,7 +133,7 @@ freeOutputs True True tx rbf <- isRBF (MemRef w) tx checkNewTx tx - importTx (MemRef w) w rbf tx + _ <- importTx (MemRef w) w rbf tx return True bestBlockData :: (MonadImport m) => m BlockData @@ -265,8 +263,6 @@ <> blockHashToHex (headerHash n.header) return (bd, tds) where - cb_out_val = - sum $ map (.value) $ (head b.txs).outputs ts_out_val = sum $ map (sum . map (.value) . (.outputs)) $ tail $ b.txs w = @@ -481,7 +477,7 @@ mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain getChain :: - (MonadImport m, MonadLoggerIO m) => + (MonadImport m) => -- | only delete transaction if unconfirmed Bool -> -- | only delete RBF 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,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE NoFieldSelectors #-} @@ -12,12 +11,9 @@ ) where -import Control.Monad (forever, unless, when) +import Control.Monad (forever, unless) import Control.Monad.Cont ( ContT (..), - MonadCont (callCC), - cont, - runCont, runContT, ) import Control.Monad.Logger (MonadLoggerIO) @@ -78,11 +74,11 @@ ) import Haskoin.Store.Common ( StoreEvent (..), - createDataMetrics, ) import Haskoin.Store.Database.Reader ( DatabaseReader (..), DatabaseReaderT, + createDataMetrics, withDatabaseReader, ) import NQE @@ -96,7 +92,7 @@ withSubscription, ) import Network.Socket (SockAddr (..)) -import System.Metrics qualified as Metrics (Store) +import System.Metrics.StatsD import UnliftIO ( MonadIO, MonadUnliftIO, @@ -155,8 +151,8 @@ maxPeerLife :: !NominalDiffTime, -- | connect to peers using the function 'withConnection' connect :: !(SockAddr -> WithConnection), - -- | stats store - statsStore :: !(Maybe Metrics.Store), + -- | StatsD + stats :: !(Maybe Stats), -- | sync mempool against cache every this many seconds redisSyncInterval :: !Int } @@ -196,7 +192,7 @@ DatabaseReaderT m a -> m a connectDB cfg f = do - stats <- mapM createDataMetrics cfg.statsStore + stats <- mapM createDataMetrics cfg.stats withDatabaseReader cfg.net cfg.ctx @@ -224,7 +220,7 @@ wipeMempool = cfg.wipeMempool, syncMempool = cfg.syncMempool, peerTimeout = cfg.peerTimeout, - statsStore = cfg.statsStore + stats = cfg.stats } nodeCfg :: @@ -263,8 +259,8 @@ Nothing -> action Nothing Just redisurl -> do - metrics <- mapM newCacheMetrics cfg.statsStore conn <- connectRedis redisurl + metrics <- mapM (\s -> newCacheMetrics s conn db) cfg.stats withSubscription pub $ \evts -> let conf = c conn metrics in withProcess (f conf) $ \p -> diff --git a/src/Haskoin/Store/Stats.hs b/src/Haskoin/Store/Stats.hs deleted file mode 100644 --- a/src/Haskoin/Store/Stats.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoFieldSelectors #-} - -module Haskoin.Store.Stats - ( StatDist, - withStats, - createStatDist, - addStatTime, - addClientError, - addServerError, - addStatQuery, - addStatItems, - ) -where - -import Control.Concurrent.STM.TQueue - ( TQueue, - flushTQueue, - writeTQueue, - ) -import Control.Foldl qualified as L -import Control.Monad (forever) -import Data.Function (on) -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as HashMap -import Data.Int (Int64) -import Data.List (sort, sortBy, sortOn) -import Data.Maybe (fromMaybe) -import Data.Ord (Down (..), comparing) -import Data.String.Conversions (cs) -import Data.Text (Text) -import System.Metrics - ( Store, - Value (..), - newStore, - registerGcMetrics, - registerGroup, - sampleAll, - ) -import System.Remote.Monitoring.Statsd - ( defaultStatsdOptions, - flushInterval, - forkStatsd, - host, - port, - prefix, - ) -import UnliftIO - ( MonadIO, - TVar, - atomically, - liftIO, - modifyTVar, - newTQueueIO, - newTVarIO, - readTVar, - withAsync, - ) -import UnliftIO.Concurrent (threadDelay) - -withStats :: (MonadIO m) => Text -> Int -> Text -> (Store -> m a) -> m a -withStats h p pfx go = do - store <- liftIO newStore - _statsd <- - liftIO $ - forkStatsd - defaultStatsdOptions - { prefix = pfx, - host = h, - port = p - } - store - liftIO $ registerGcMetrics store - go store - -data StatData = StatData - { times :: ![Int64], - queries :: !Int64, - items :: !Int64, - clientErrors :: !Int64, - serverErrors :: !Int64 - } - -data StatDist = StatDist - { queue :: !(TQueue Int64), - queries :: !(TVar Int64), - items :: !(TVar Int64), - clientErrors :: !(TVar Int64), - serverErrors :: !(TVar Int64) - } - -createStatDist :: (MonadIO m) => Text -> Store -> m StatDist -createStatDist t store = liftIO $ do - queue <- newTQueueIO - queries <- newTVarIO 0 - items <- newTVarIO 0 - clientErrors <- newTVarIO 0 - serverErrors <- newTVarIO 0 - let metrics = - HashMap.fromList - [ ( t <> ".request_count", - Counter . (.queries) - ), - ( t <> ".item_count", - Counter . (.items) - ), - ( t <> ".client_errors", - Counter . (.clientErrors) - ), - ( t <> ".server_errors", - Counter . (.serverErrors) - ), - ( t <> ".mean_ms", - Gauge . mean . (.times) - ), - ( t <> ".avg_ms", - Gauge . avg . (.times) - ), - ( t <> ".max_ms", - Gauge . maxi . (.times) - ), - ( t <> ".min_ms", - Gauge . mini . (.times) - ), - ( t <> ".p90max_ms", - Gauge . p90max . (.times) - ), - ( t <> ".p90avg_ms", - Gauge . p90avg . (.times) - ), - ( t <> ".var_ms", - Gauge . var . (.times) - ) - ] - let sd = StatDist {..} - registerGroup metrics (flush sd) store - return sd - -toDouble :: Int64 -> Double -toDouble = fromIntegral - -addStatTime :: (MonadIO m) => StatDist -> Int64 -> m () -addStatTime q = - liftIO . atomically . writeTQueue q.queue - -addStatQuery :: (MonadIO m) => StatDist -> m () -addStatQuery q = - liftIO . atomically $ modifyTVar q.queries (+ 1) - -addStatItems :: (MonadIO m) => StatDist -> Int64 -> m () -addStatItems q = - liftIO . atomically . modifyTVar q.items . (+) - -addClientError :: (MonadIO m) => StatDist -> m () -addClientError q = - liftIO . atomically $ modifyTVar q.clientErrors (+ 1) - -addServerError :: (MonadIO m) => StatDist -> m () -addServerError q = - liftIO . atomically $ modifyTVar q.serverErrors (+ 1) - -flush :: (MonadIO m) => StatDist -> m StatData -flush StatDist {..} = atomically $ do - 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 = (/) <$> L.sum <*> L.genericLength - -avg :: [Int64] -> Int64 -avg = round . L.fold average . map toDouble - -mean :: [Int64] -> Int64 -mean = round . L.fold L.mean . map toDouble - -maxi :: [Int64] -> Int64 -maxi = fromMaybe 0 . L.fold L.maximum - -mini :: [Int64] -> Int64 -mini = fromMaybe 0 . L.fold L.minimum - -var :: [Int64] -> Int64 -var = round . L.fold L.variance . map toDouble - -p90max :: [Int64] -> Int64 -p90max ls = - case chopped of - [] -> 0 - h : _ -> h - where - sorted = sortOn Down ls - len = length sorted - chopped = drop (length sorted `div` 10) sorted - -p90avg :: [Int64] -> Int64 -p90avg ls = - avg chopped - where - sorted = sortOn Down ls - len = length 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 @@ -20,3165 +20,2766 @@ 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 - res = responseLBS sta [hdr] (A.encode err) - sta = errStatus err - hdr = (hContentType, "application/json") - -fmtReq :: ByteString -> Request -> Text -fmtReq bs req = - let m = requestMethod req - v = httpVersion req - p = rawPathInfo req - q = rawQueryString req - txt = case T.decodeUtf8' bs of - Left _ -> " {invalid utf8}" - Right "" -> "" - Right t -> " [" <> t <> "]" - in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt + runWeb, + ) +where + +import Conduit + ( ConduitT, + await, + concatMapC, + concatMapMC, + dropC, + dropWhileC, + headC, + mapC, + runConduit, + sinkList, + takeC, + takeWhileC, + yield, + (.|), + ) +import Control.Applicative ((<|>)) +import Control.Lens ((.~), (^.)) +import Control.Monad + ( forM_, + forever, + unless, + when, + (<=<), + ) +import Control.Monad.Logger + ( MonadLoggerIO, + logDebugS, + logErrorS, + ) +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.Base16 (decodeBase16, isBase16) +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, + 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.POSIX (getPOSIXTime) +import Data.Word (Word32, Word64) +import Database.RocksDB + ( Property (..), + getProperty, + ) +import Haskoin.Address +import Haskoin.Block qualified as H +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.WebCommon +import Haskoin.Transaction +import Haskoin.Util +import NQE + ( Inbox, + receive, + withSubscription, + ) +import Network.HTTP.Types + ( Status (..), + status400, + status404, + status409, + status413, + status500, + status503, + statusIsClientError, + statusIsServerError, + statusIsSuccessful, + ) +import Network.Wai + ( Middleware, + Request (..), + responseStatus, + ) +import Network.Wai.Handler.Warp + ( defaultSettings, + setHost, + setPort, + ) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.WebSockets + ( 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.Metrics.StatsD +import UnliftIO + ( MonadIO, + MonadUnliftIO, + TVar, + askRunInIO, + atomically, + bracket, + bracket_, + handleAny, + liftIO, + newTVarIO, + readTVarIO, + timeout, + withAsync, + 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, + txTimeout :: !Word64, + blockTimeout :: !Word64 + } + deriving (Eq, Show) + +instance Default WebLimits where + def = + WebLimits + { maxItemCount = 200000, + maxFullItemCount = 5000, + maxOffset = 50000, + defItemCount = 100, + xpubGap = 32, + xpubGapInit = 20, + txTimeout = 3600 `div` 2, + blockTimeout = 4 * 3600 + } + +data WebConfig = WebConfig + { host :: !String, + port :: !Int, + store :: !Store, + maxLaggingBlocks :: !Int, + maxPendingTxs :: !Int, + minPeers :: !Int, + limits :: !WebLimits, + version :: !String, + noMempool :: !Bool, + stats :: !(Maybe Stats), + 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 + { -- Addresses + addressTx :: !StatTiming, + addressTxFull :: !StatTiming, + addressBalance :: !StatTiming, + addressUnspent :: !StatTiming, + xpub :: !StatTiming, + xpubDelete :: !StatTiming, + xpubTxFull :: !StatTiming, + xpubTx :: !StatTiming, + xpubBalance :: !StatTiming, + xpubUnspent :: !StatTiming, + -- Transactions + tx :: !StatTiming, + txRaw :: !StatTiming, + txAfter :: !StatTiming, + txBlock :: !StatTiming, + txBlockRaw :: !StatTiming, + txPost :: !StatTiming, + mempool :: !StatTiming, + -- Blocks + block :: !StatTiming, + blockRaw :: !StatTiming, + -- Blockchain + binfoMultiaddr :: !StatTiming, + binfoBalance :: !StatTiming, + binfoAddressRaw :: !StatTiming, + binfoUnspent :: !StatTiming, + binfoTxRaw :: !StatTiming, + binfoBlock :: !StatTiming, + binfoBlockHeight :: !StatTiming, + binfoBlockLatest :: !StatTiming, + binfoBlockRaw :: !StatTiming, + binfoMempool :: !StatTiming, + binfoExportHistory :: !StatTiming, + -- Blockchain /q endpoints + binfoQaddresstohash :: !StatTiming, + binfoQhashtoaddress :: !StatTiming, + binfoQaddrpubkey :: !StatTiming, + binfoQpubkeyaddr :: !StatTiming, + binfoQhashpubkey :: !StatTiming, + binfoQgetblockcount :: !StatTiming, + binfoQlatesthash :: !StatTiming, + binfoQbcperblock :: !StatTiming, + binfoQtxtotalbtcoutput :: !StatTiming, + binfoQtxtotalbtcinput :: !StatTiming, + binfoQtxfee :: !StatTiming, + binfoQtxresult :: !StatTiming, + binfoQgetreceivedbyaddress :: !StatTiming, + binfoQgetsentbyaddress :: !StatTiming, + binfoQaddressbalance :: !StatTiming, + binfoQaddressfirstseen :: !StatTiming, + -- Errors + serverErrors :: StatCounter, + clientErrors :: StatCounter, + -- Others + health :: !StatTiming, + peers :: !StatTiming, + db :: !StatTiming, + events :: !StatGauge + } + +createMetrics :: (MonadIO m) => Stats -> m WebMetrics +createMetrics s = liftIO $ do + -- 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" + + -- Errors + serverErrors <- c "server_errors" + clientErrors <- c "client_errors" + + -- Others + health <- d "health" + peers <- d "peers" + db <- d "dbstats" + + events <- g "events_connected" + return WebMetrics {..} + where + d x = newStatTiming s ("web." <> x) 10 + g x = newStatGauge s ("web." <> x) 0 + c x = newStatCounter s ("web." <> x) 10 + +withGaugeIO :: (MonadUnliftIO m) => StatGauge -> m a -> m a +withGaugeIO g = bracket_ (incrementGauge g 1) (decrementGauge g 1) + +withGaugeIncrease :: + (MonadUnliftIO m) => + (WebMetrics -> StatGauge) -> + 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 + +withMetrics :: + (MonadUnliftIO m) => (WebMetrics -> StatTiming) -> WebT m a -> WebT m a +withMetrics df go = + asks (.metrics) >>= \case + Nothing -> go + Just m -> + restoreT . return + =<< liftWith (\run -> bracket time (stop m) (const (run go))) + where + time = round . (* 1000) <$> liftIO getPOSIXTime + stop m t1 = do + t2 <- time + let ms = t2 - t1 + liftIO $ addTiming (df m) ms + +data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON + deriving (Eq, Show) + +instance + (MonadUnliftIO 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) => 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.stats + session <- liftIO Wreq.Session.newAPISession + health <- runHealthCheck >>= newTVarIO + let state = WebState {..} + withAsync (priceUpdater session ticker) $ \_a1 -> + withAsync (healthCheckLoop health) $ \_a2 -> do + logger <- logIt + runner <- askRunInIO + S.scottyOptsT opts (runner . flip runReaderT state) $ do + S.middleware $ webSocketEvents state + S.middleware logger + 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 + 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 = do + asks (.metrics) >>= mapM_ \m -> do + let status = errStatus err + liftIO $ + mapM_ (`incrementCounter` 1) $ + if + | statusIsClientError status -> Just m.clientErrors + | statusIsServerError status -> Just m.serverErrors + | otherwise -> Nothing + 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) => ActionT e m () +setHeaders = S.setHeader "Access-Control-Allow-Origin" "*" + +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) => GetBlock -> WebT m BlockData +scottyBlock (GetBlock h (NoTx noTx)) = withMetrics (.block) $ do + getBlock h >>= \case + Nothing -> + raise ThingNotFound + Just b -> do + return $ pruneTx noTx b + +getBlocks :: + (MonadUnliftIO m) => + [H.BlockHash] -> + Bool -> + WebT m [BlockData] +getBlocks hs notx = + (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs) + +scottyBlocks :: + (MonadUnliftIO m) => GetBlocks -> WebT m [BlockData] +scottyBlocks (GetBlocks hs (NoTx notx)) = + withMetrics (.block) $ + getBlocks hs notx + +pruneTx :: Bool -> BlockData -> BlockData +pruneTx False b = b +pruneTx True BlockData {..} = BlockData {txs = take 1 txs, ..} + +-- GET BlockRaw -- + +scottyBlockRaw :: + (MonadUnliftIO m) => + GetBlockRaw -> + WebT m (RawResult H.Block) +scottyBlockRaw (GetBlockRaw h) = + withMetrics (.blockRaw) $ + RawResult <$> getRawBlock h + +getRawBlock :: + (MonadUnliftIO m) => + H.BlockHash -> + WebT m H.Block +getRawBlock h = + getBlock h >>= maybe (raise ThingNotFound) return >>= lift . toRawBlock + +toRawBlock :: (StoreReadBase m) => BlockData -> m H.Block +toRawBlock b = do + txs <- map transactionData . catMaybes <$> mapM getTransaction b.txs + return H.Block {header = b.header, txs} + +-- GET BlockBest / BlockBestRaw -- + +scottyBlockBest :: + (MonadUnliftIO m) => GetBlockBest -> WebT m BlockData +scottyBlockBest (GetBlockBest (NoTx notx)) = + withMetrics (.block) $ + maybe (raise ThingNotFound) (return . pruneTx notx) <=< runMaybeT $ + MaybeT getBestBlock >>= MaybeT . getBlock + +scottyBlockBestRaw :: + (MonadUnliftIO m) => + GetBlockBestRaw -> + WebT m (RawResult H.Block) +scottyBlockBestRaw _ = + withMetrics (.blockRaw) $ + maybe (raise ThingNotFound) (return . RawResult) <=< runMaybeT $ + MaybeT getBestBlock >>= lift . getRawBlock + +-- GET BlockLatest -- + +scottyBlockLatest :: + (MonadUnliftIO m) => + GetBlockLatest -> + WebT m [BlockData] +scottyBlockLatest (GetBlockLatest (NoTx noTx)) = + withMetrics (.block) $ + getBestBlock >>= maybe (raise ThingNotFound) (go [] <=< getBlock) + 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) => GetBlockHeight -> WebT m [BlockData] +scottyBlockHeight (GetBlockHeight h (NoTx notx)) = + withMetrics (.block) $ + getBlocksAtHeight (fromIntegral h) + >>= (`getBlocks` notx) + +scottyBlockHeights :: + (MonadUnliftIO m) => + GetBlockHeights -> + WebT m [BlockData] +scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = + withMetrics (.block) $ + mapM (getBlocksAtHeight . fromIntegral) heights + >>= (`getBlocks` notx) . concat + +scottyBlockHeightRaw :: + (MonadUnliftIO m) => + GetBlockHeightRaw -> + WebT m (RawResultList H.Block) +scottyBlockHeightRaw (GetBlockHeightRaw h) = + withMetrics (.blockRaw) $ + fmap RawResultList $ + mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) + +-- GET BlockTime / BlockTimeRaw -- + +scottyBlockTime :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockTime -> + WebT m BlockData +scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = + withMetrics (.block) $ do + ch <- asks (.config.store.chain) + blockAtOrBefore ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> return $ pruneTx notx b + +scottyBlockMTP :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockMTP -> + WebT m BlockData +scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = + withMetrics (.block) $ do + ch <- asks (.config.store.chain) + blockAtOrAfterMTP ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> return $ pruneTx notx b + +scottyBlockTimeRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockTimeRaw -> + WebT m (RawResult H.Block) +scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = + withMetrics (.blockRaw) $ do + ch <- asks (.config.store.chain) + blockAtOrBefore ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> RawResult <$> lift (toRawBlock b) + +scottyBlockMTPRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockMTPRaw -> + WebT m (RawResult H.Block) +scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = + withMetrics (.blockRaw) $ do + ch <- asks (.config.store.chain) + blockAtOrAfterMTP ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> RawResult <$> lift (toRawBlock b) + +-- GET Transactions -- + +scottyTx :: (MonadUnliftIO m) => GetTx -> WebT m Transaction +scottyTx (GetTx txid) = + withMetrics (.tx) $ + getTransaction txid >>= maybe (raise ThingNotFound) return + +scottyTxs :: + (MonadUnliftIO m) => GetTxs -> WebT m [Transaction] +scottyTxs (GetTxs txids) = + withMetrics (.tx) $ + catMaybes <$> mapM getTransaction (nub txids) + +scottyTxRaw :: + (MonadUnliftIO m) => GetTxRaw -> WebT m (RawResult Tx) +scottyTxRaw (GetTxRaw txid) = + withMetrics (.txRaw) $ + getTransaction txid + >>= \case + Nothing -> raise ThingNotFound + Just tx -> return $ RawResult (transactionData tx) + +scottyTxsRaw :: + (MonadUnliftIO m) => + GetTxsRaw -> + WebT m (RawResultList Tx) +scottyTxsRaw (GetTxsRaw txids) = + withMetrics (.txRaw) $ + RawResultList . map transactionData . catMaybes + <$> mapM getTransaction (nub txids) + +getTxsBlock :: + (MonadUnliftIO m) => + H.BlockHash -> + WebT m [Transaction] +getTxsBlock h = + getBlock h >>= \case + Nothing -> raise ThingNotFound + Just b -> catMaybes <$> mapM getTransaction b.txs + +scottyTxsBlock :: + (MonadUnliftIO m) => + GetTxsBlock -> + WebT m [Transaction] +scottyTxsBlock (GetTxsBlock h) = + withMetrics (.txBlock) $ getTxsBlock h + +scottyTxsBlockRaw :: + (MonadUnliftIO m) => + GetTxsBlockRaw -> + WebT m (RawResultList Tx) +scottyTxsBlockRaw (GetTxsBlockRaw h) = + withMetrics (.txBlockRaw) $ + RawResultList . map transactionData <$> getTxsBlock h + +-- GET TransactionAfterHeight -- + +scottyTxAfter :: + (MonadUnliftIO m) => + GetTxAfter -> + WebT m (GenericResult (Maybe Bool)) +scottyTxAfter (GetTxAfter txid height) = + withMetrics (.txAfter) $ + GenericResult . fst <$> cbAfterHeight (fromIntegral height) txid + +-- | 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 :: + (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) => PostTx -> WebT m TxId +scottyPostTx (PostTx tx) = + withMetrics (.txPost) $ do + cfg <- asks (.config) + 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, 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) => GetMempool -> WebT m [TxHash] +scottyMempool (GetMempool limitM (OffsetParam o)) = + withMetrics (.mempool) $ do + WebLimits {..} <- asks (.config.limits) + let wl' = WebLimits {maxItemCount = 0, ..} + l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing + map snd . applyLimits l <$> getMempool + +webSocketEvents :: WebState -> Middleware +webSocketEvents s = + websocketsOr defaultConnectionOptions (wrap . events) + where + pub = s.config.store.pub + gauge = (.events) <$> s.metrics + wrap f = case gauge of + Nothing -> f + Just g -> withGaugeIO g f + 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) => 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) = + withMetrics (.addressTx) $ + getAddressTxs addr =<< paramToLimits False pLimits + +scottyAddrsTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef] +scottyAddrsTxs (GetAddrsTxs addrs pLimits) = + withMetrics (.addressTx) $ + getAddressesTxs addrs =<< paramToLimits False pLimits + +scottyAddrTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrTxsFull -> + WebT m [Transaction] +scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = + withMetrics (.addressTxFull) $ do + txs <- getAddressTxs addr =<< paramToLimits True pLimits + catMaybes <$> mapM (getTransaction . (.txid)) txs + +scottyAddrsTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrsTxsFull -> + WebT m [Transaction] +scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = + withMetrics (.addressTxFull) $ do + txs <- getAddressesTxs addrs =<< paramToLimits True pLimits + catMaybes <$> mapM (getTransaction . (.txid)) txs + +scottyAddrBalance :: (MonadUnliftIO m) => GetAddrBalance -> WebT m Balance +scottyAddrBalance (GetAddrBalance addr) = + withMetrics (.addressBalance) $ getDefaultBalance addr + +scottyAddrsBalance :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance] +scottyAddrsBalance (GetAddrsBalance addrs) = + withMetrics (.addressBalance) $ getBalances addrs + +scottyAddrUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent] +scottyAddrUnspent (GetAddrUnspent addr pLimits) = + withMetrics (.addressUnspent) $ + getAddressUnspents addr =<< paramToLimits False pLimits + +scottyAddrsUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent] +scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = + withMetrics (.addressUnspent) $ + getAddressesUnspents addrs =<< paramToLimits False pLimits + +-- GET XPubs -- + +scottyXPub :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary +scottyXPub (GetXPub xpub deriv (NoCache noCache)) = + withMetrics (.xpub) $ + let xs = XPubSpec xpub deriv + in xPubSummary xs <$> lift (runNoCache noCache $ xPubBals xs) + +scottyDelXPub :: + (MonadUnliftIO m, MonadLoggerIO m) => + DelCachedXPub -> + WebT m (GenericResult Bool) +scottyDelXPub (DelCachedXPub xpub deriv) = + withMetrics (.xpubDelete) $ do + c <- asks (.config.store.cache) + n <- lift (withCache c $ cacheDelXPubs [XPubSpec xpub deriv]) + 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 xs = XPubSpec xpub deriv + xbals <- xPubBals xs + lift $ runNoCache nocache $ xPubTxs xs xbals limits + +scottyXPubTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef] +scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = + withMetrics (.xpubTx) $ + getXPubTxs xpub deriv plimits nocache + +scottyXPubTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetXPubTxsFull -> + WebT m [Transaction] +scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = + withMetrics (.xpubTxFull) $ + fmap catMaybes $ + lift . runNoCache nocache . mapM (getTransaction . (.txid)) + =<< getXPubTxs xpub deriv plimits nocache + +scottyXPubBalances :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal] +scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = + withMetrics (.xpubBalance) $ + lift $ + runNoCache noCache $ + xPubBals (XPubSpec xpub deriv) + +scottyXPubUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetXPubUnspent -> + WebT m [XPubUnspent] +scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = + withMetrics (.xpubUnspent) $ do + limits <- paramToLimits False pLimits + let xspec = XPubSpec xpub deriv + xbals <- xPubBals xspec + lift $ runNoCache noCache $ xPubUnspents xspec xbals limits + +--------------------------------------- +-- 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 <- asks (.config.store.net) + ctx <- 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) => WebT m H.BlockHeight +getChainHeight = fmap (.height) $ chainGetBest =<< asks (.config.store.chain) + +scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoUnspent = + withMetrics (.binfoUnspent) $ do + (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 u = min_conf > u.confirmations + xbals <- lift $ getXBals xspecs + bus <- + lift . runConduit $ + getBinfoUnspents 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) => + Bool -> + H.BlockHeight -> + HashMap XPubSpec [XPubBal] -> + HashSet XPubSpec -> + HashSet Address -> + ConduitT () BinfoUnspent m () +getBinfoUnspents numtxid height xbals xspecs addrs = do + cs' <- conduits + joinDescStreams cs' .| mapC (uncurry binfo) + where + binfo u xp = + let conf = case u.block of + MemRef _ -> 0 + BlockRef h _ -> height - h + 1 + in BinfoUnspent + { txid = u.outpoint.hash, + index = u.outpoint.index, + script = u.script, + value = u.value, + confirmations = fromIntegral conf, + txidx = encodeBinfoTxId numtxid u.outpoint.hash, + 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 = xPubUnspents x (xBals x xbals) + 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 = getAddressUnspents + 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) => + 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 + 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 = xPubTxs x (xBals x xbals) + l = Limits {limit = 16, offset = 0, start = Nothing} + lift . return $ + streamThings f (Just (.txid)) l + addr_c a = do + let l = Limits {limit = 16, offset = 0, start = Nothing} + streamThings (getAddressTxs a) (Just (.txid)) l + binfo_tx = toBinfoTx numtxid abook prune + compute_bal_change t = + let ins = map (.output) t.inputs + out = t.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 + 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 :: (MonadUnliftIO m) => TL.Text -> WebT m Address +getAddress param' = do + txt <- S.param param' + net <- 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 <- asks (.config.store.net) + ctx <- 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 = + withMetrics (.binfoExportHistory) $ do + (xspecs, addrs) <- getBinfoActive + (startM, endM) <- get_dates + (code, price') <- getPrice + xbals <- getXBals xspecs + let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) + aaddrs = xaddrs <> addrs + cur = price'.fifteen + cs' = conduits (HashMap.toList xbals) addrs endM + txs <- + lift $ + runConduit $ + joinDescStreams cs' + .| takeWhileC (is_newer startM) + .| concatMapMC get_transaction + .| sinkList + let times = map (\Transaction {..} -> timestamp) txs + net <- asks (.config.store.net) + url <- asks (.config.priceHistoryURL) + session <- asks (.session) + rates <- map (.price) <$> lift (getRates net session url code times) + let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) + setHeaders + streamEncoding $ toEncoding hs + where + is_newer + (Just BlockData {height = bh}) + TxRef {block = BlockRef {height = th}} = + bh <= th + 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 xpubs addrs endM = + map (uncurry (xpub_c endM)) xpubs + <> map (addr_c endM) (HashSet.toList addrs) + lim endM = + Limits + { limit = 16, + offset = 0, + start = AtBlock . (.height) <$> endM + } + addr_c endM a = + streamThings (getAddressTxs a) (Just (.txid)) (lim endM) + xpub_c endM x bs = + streamThings (xPubTxs x bs) (Just (.txid)) (lim endM) + +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 = + withMetrics (.binfoBlock) $ do + t <- min h . (`div` 1000) <$> S.param "milliseconds" + ch <- asks (.config.store.chain) + m <- blockAtOrBefore ch t + bs <- go (d t) m + 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 = + withMetrics (.binfoMultiaddr) $ do + (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 + xtxns <- get_xpub_tx_count xbals xspecs + let sxbals = only_show_xbals sxpubs xbals + xabals = compute_xabals xbals + addrs = addrs' `HashSet.difference` HashMap.keysSet xabals + abals <- get_abals addrs + 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 + ftxs <- + lift . runConduit $ + getBinfoTxs + xbals + abook + sxspecs + saddrs + salladdrs + fltr + numtxid + prune + ibal + .| (dropC offset >> takeC n .| sinkList) + net <- asks (.config.store.net) + ctx <- asks (.config.store.ctx) + best <- get_best_block + peers <- get_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 xs xb = + let a = xb.balance.address + e = error "lions and tigers and bears" + s = toSoft (listToPath xb.path) + in (a, Just (BinfoXPubPath xs.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) => TL.Text -> WebT m Int +getBinfoCount str = do + d <- asks (.config.limits.defItemCount) + x <- asks (.config.limits.maxFullItemCount) + i <- min x <$> (S.param str `S.rescue` const (return d)) + return (fromIntegral i :: Int) + +getBinfoOffset :: + (MonadUnliftIO m) => + WebT m Int +getBinfoOffset = do + x <- 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 = + withMetrics (.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 + 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 + txs <- + lift $ + runConduit $ + getBinfoTxs + 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 xb = + let a = xb.balance.address + e = error "black hole swallows all your code" + s = toSoft $ listToPath xb.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 + net <- lift $ asks (.config.store.net) + let abook = HashMap.singleton addr Nothing + xspecs = HashSet.empty + saddrs = HashSet.singleton addr + bfilter = BinfoFilterAll + balance = bal.confirmed + bal.unconfirmed + txs <- + lift . runConduit $ + getBinfoTxs + HashMap.empty + abook + xspecs + saddrs + saddrs + bfilter + numtxid + False + (fromIntegral balance) + .| (dropC off >> takeC n .| sinkList) + let ra = + BinfoRawAddr + { address = BinfoAddr addr, + balance, + ntx = bal.txs, + utxo = bal.utxo, + received = bal.received, + sent = fromIntegral bal.received - fromIntegral balance, + txs + } + setHeaders + ctx <- asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) ra + +scottyBinfoReceived :: (MonadUnliftIO m) => WebT m () +scottyBinfoReceived = + withMetrics (.binfoQgetreceivedbyaddress) $ do + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + S.text $ cs $ show b.received + +scottyBinfoSent :: (MonadUnliftIO m) => WebT m () +scottyBinfoSent = + withMetrics (.binfoQgetsentbyaddress) $ do + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + S.text $ cs $ show $ b.received - b.confirmed - b.unconfirmed + +scottyBinfoAddrBalance :: (MonadUnliftIO m) => WebT m () +scottyBinfoAddrBalance = + withMetrics (.binfoQaddressbalance) $ do + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + S.text $ cs $ show $ b.confirmed + b.unconfirmed + +scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyFirstSeen = + withMetrics (.binfoQaddressfirstseen) $ do + a <- getAddress "addr" + ch <- asks (.config.store.chain) + bb <- chainGetBest ch + let top = bb.height + bot = 0 + i <- go ch bb a bot top + setHeaders + 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 = + chainGetAncestor h bb ch >>= \case + Just b -> return b.header.timestamp + Nothing -> do + lift . $(logErrorS) "Web" $ + "Could not get ancestor at height " + <> cs (show h) + <> " for block " + <> H.blockHashToHex (H.headerHash bb.header) + error "Block ancestor retreival error" + 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 = + withMetrics (.binfoBalance) $ do + (xspecs, addrs) <- getBinfoActive + cashaddr <- getCashAddr + net <- asks (.config.store.net) + abals <- catMaybes <$> mapM (getabal net cashaddr) (HashSet.toList addrs) + xbals <- mapM (getxbal net) (HashSet.toList xspecs) + let res = HashMap.fromList (abals <> xbals) + setHeaders + streamEncoding $ toEncoding res + where + shorten bal = + BinfoShortBal + { final = bal.confirmed + bal.unconfirmed, + ntx = bal.txs, + received = bal.received + } + getabal 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', shorten (zeroBalance a)) + Just b -> return $ Just (a', shorten b) + getxbal net xpub = do + xbals <- xPubBals xpub + ntx <- fromIntegral <$> xPubTxCount xpub xbals + let val = sum $ map (.balance.confirmed) xbals + zro = sum $ map (.balance.unconfirmed) xbals + exs = [x | x@XPubBal {path = 0 : _} <- xbals] + final = val + zro + received = sum $ map (.balance.received) exs + sbl = BinfoShortBal {final, ntx, received} + 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) => WebT m () +scottyBinfoBlockHeight = + withMetrics (.binfoBlockHeight) $ do + numtxid <- getNumTxId + height <- S.param "height" + bs <- fmap catMaybes $ getBlocksAtHeight height >>= mapM getBlock + ns <- fmap catMaybes $ getBlocksAtHeight (height + 1) >>= mapM getBlock + is <- mapM (get_binfo_blocks numtxid ns) bs + setHeaders + net <- asks (.config.store.net) + ctx <- asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) is + where + get_binfo_blocks numtxid ns b = do + txs <- catMaybes <$> mapM getTransaction b.txs + let h x = H.headerHash x.header + nbs = [h n | n <- ns, n.header.prev == h b] + bts = map (toBinfoTxSimple numtxid) txs + return $ toBinfoBlock b bts nbs + +scottyBinfoLatest :: (MonadUnliftIO m) => WebT m () +scottyBinfoLatest = + withMetrics (.binfoBlockLatest) $ do + numtxid <- getNumTxId + mb <- runMaybeT $ MaybeT getBestBlock >>= MaybeT . getBlock + b <- maybe (raise ThingNotFound) return mb + streamEncoding $ + toEncoding + BinfoHeader + { hash = H.headerHash b.header, + timestamp = b.header.timestamp, + index = b.height, + height = b.height, + txids = map (encodeBinfoTxId numtxid) b.txs + } + +scottyBinfoBlock :: (MonadUnliftIO m) => WebT m () +scottyBinfoBlock = + withMetrics (.binfoBlockRaw) $ do + numtxid <- getNumTxId + hex <- getBinfoHex + S.param "block" >>= \case + BinfoBlockHash bh -> go numtxid hex bh + BinfoBlockIndex i -> + getBlocksAtHeight i >>= \case + [] -> raise ThingNotFound + bh : _ -> go numtxid hex bh + where + go numtxid hex bh = do + b <- maybe (raise ThingNotFound) return =<< getBlock bh + txs <- catMaybes <$> mapM getTransaction b.txs + nhs <- fmap catMaybes $ getBlocksAtHeight (b.height + 1) >>= mapM getBlock + let h x = H.headerHash x.header + nxt = [h n | n <- nhs, n.header.prev == h b] + if hex + then do + let x = H.Block b.header (map transactionData txs) + setHeaders + S.text . encodeHexLazy . runPutL $ serialize x + else do + let bts = map (toBinfoTxSimple numtxid) txs + y = toBinfoBlock b bts nxt + setHeaders + net <- asks (.config.store.net) + ctx <- 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 = + withMetrics (.binfoTxRaw) $ do + numtxid <- getNumTxId + hex <- getBinfoHex + txid <- S.param "txid" + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + if hex then hx tx else js numtxid tx + where + js numtxid t = do + net <- asks (.config.store.net) + ctx <- 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 = + withMetrics (.binfoQtxtotalbtcoutput) $ do + txid <- S.param "txid" + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + S.text $ cs $ show $ sum $ map (.value) tx.outputs + +scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTxFees = + withMetrics (.binfoQtxfee) $ do + txid <- S.param "txid" + 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 + S.text . cs . show $ i - o + where + f StoreInput {} = True + f StoreCoinbase {} = False + +scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTxResult = + withMetrics (.binfoQtxresult) $ do + txid <- S.param "txid" + addr <- getAddress "addr" + 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 + 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 = + withMetrics (.binfoQtxtotalbtcinput) $ do + txid <- S.param "txid" + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + S.text $ cs $ show $ sum $ map (.value) $ filter f $ tx.inputs + where + f StoreInput {} = True + f StoreCoinbase {} = False + +scottyBinfoMempool :: (MonadUnliftIO m) => WebT m () +scottyBinfoMempool = + withMetrics (.binfoMempool) $ do + 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 + ctx <- lift $ asks (.config.store.ctx) + streamEncoding $ marshalEncoding (net, ctx) mem + +scottyBinfoGetBlockCount :: (MonadUnliftIO m) => WebT m () +scottyBinfoGetBlockCount = + withMetrics (.binfoQgetblockcount) $ do + ch <- asks (.config.store.chain) + bn <- chainGetBest ch + setHeaders + S.text $ cs $ show bn.height + +scottyBinfoLatestHash :: (MonadUnliftIO m) => WebT m () +scottyBinfoLatestHash = + withMetrics (.binfoQlatesthash) $ do + ch <- asks (.config.store.chain) + bn <- chainGetBest ch + setHeaders + S.text $ TL.fromStrict $ H.blockHashToHex $ H.headerHash bn.header + +scottyBinfoSubsidy :: (MonadUnliftIO m) => WebT m () +scottyBinfoSubsidy = + withMetrics (.binfoQbcperblock) $ do + ch <- asks (.config.store.chain) + net <- asks (.config.store.net) + bn <- chainGetBest ch + setHeaders + S.text $ + cs $ + show $ + (/ (100 * 1000 * 1000 :: Double)) $ + fromIntegral $ + H.computeSubsidy net (bn.height + 1) + +scottyBinfoAddrToHash :: (MonadUnliftIO m) => WebT m () +scottyBinfoAddrToHash = + withMetrics (.binfoQaddresstohash) $ do + addr <- getAddress "addr" + setHeaders + S.text $ encodeHexLazy $ runPutL $ serialize addr.hash160 + +scottyBinfoHashToAddr :: (MonadUnliftIO m) => WebT m () +scottyBinfoHashToAddr = + withMetrics (.binfoQhashtoaddress) $ do + 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 + S.text $ TL.fromStrict addr + +scottyBinfoAddrPubkey :: (MonadUnliftIO m) => WebT m () +scottyBinfoAddrPubkey = + withMetrics (.binfoQaddrpubkey) $ do + hex <- S.param "pubkey" + ctx <- asks (.config.store.ctx) + pubkey <- + maybe S.next (return . pubKeyAddr ctx) $ + eitherToMaybe . unmarshal ctx =<< decodeHex hex + net <- asks (.config.store.net) + setHeaders + case addrToText net pubkey of + Nothing -> raise ThingNotFound + Just a -> do + S.text $ TL.fromStrict a + +scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoPubKeyAddr = + withMetrics (.binfoQpubkeyaddr) $ do + 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 + runConduit $ do + let l = Limits {limit = 8, offset = 0, start = Nothing} + streamThings (getAddressTxs addr) (Just (.txid)) l + .| concatMapMC (getTransaction . (.txid)) + .| 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) => WebT m () +scottyBinfoHashPubkey = + withMetrics (.binfoQhashpubkey) $ do + ctx <- 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 + S.text $ encodeHexLazy $ runPutL $ serialize addr.hash160 + +-- GET Network Information -- + +scottyPeers :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetPeers -> + WebT m [PeerInfo] +scottyPeers _ = + withMetrics (.peers) $ do + lift . getPeersInformation =<< asks (.config.store.peerMgr) + +-- | 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) => GetHealth -> WebT m HealthCheck +scottyHealth _ = + withMetrics (.health) $ do + h <- asks (.health) >>= readTVarIO + unless (isOK h) $ S.status status503 + return h + +blockHealthCheck :: + (MonadUnliftIO 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, StoreReadBase m) => + Chain -> + WebLimits -> + m TimeHealth +lastBlockHealthCheck ch WebLimits {blockTimeout} = do + n <- round <$> liftIO getPOSIXTime + t <- fromIntegral . (.header.timestamp) <$> chainGetBest ch + return + TimeHealth + { age = n - t, + max = fromIntegral blockTimeout + } + +lastTxHealthCheck :: + (MonadUnliftIO m, StoreReadBase m) => + WebConfig -> + m TimeHealth +lastTxHealthCheck WebConfig {noMempool, store, limits} = do + n <- round <$> liftIO getPOSIXTime + 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 limits.blockTimeout + else limits.txTimeout + +pendingTxsHealthCheck :: + (MonadUnliftIO 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, 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.limits + lastTx <- lastTxHealthCheck cfg + pendingTxs <- pendingTxsHealthCheck cfg + peers <- peerHealthCheck cfg + time <- round <$> liftIO getPOSIXTime + 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) => WebT m () +scottyDbStats = + withMetrics (.db) $ do + setHeaders + db <- lift $ asks (.config.store.db.db) + statsM <- lift (getProperty db Stats) + 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 = id +runNoCache True = local $ \s -> + s {config = s.config {store = s.config.store {cache = Nothing}}} + +logIt :: + (MonadUnliftIO m, MonadLoggerIO m) => + m Middleware +logIt = do + runner <- askRunInIO + return $ \app req respond -> + app req $ \res -> do + let s = responseStatus res + msg = fmtReq req <> ": " <> fmtStatus s + if statusIsSuccessful s + then runner $ $(logDebugS) "Web" msg + else runner $ $(logErrorS) "Web" msg + respond res + +fmtReq :: Request -> Text +fmtReq req = + let m = requestMethod req + v = httpVersion req + p = rawPathInfo req + q = rawQueryString req + in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) fmtStatus :: Status -> Text fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s) diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -110,7 +110,7 @@ peerTimeout = 60, maxPeerLife = 48 * 3600, connect = dummyPeerConnect net ad, - statsStore = Nothing, + stats = Nothing, redisSyncInterval = 30 } withStore cfg $ \Store {..} ->