diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,1758 @@ +# Changelog +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) + +## [1.0.0] - 2023-07-28 + +### Changed + +- Compatibility with latest haskoin-core and haskoin-node packages. +- Use DuplicateRecordFields and OverloadedRecordDot language extensions. +- Modernize package in a backwards-incompatible manner. +- Refactor package extensively. + +## [0.65.10] - 2023-05-12 + +### Changed + +- Revert to older LTS Haskell to attempt to resolve memory leak. + +### Removed + +- Remove unnecessary lock release. + +## [0.65.9] - 2023-05-09 + +### Changed + +- Be more aggressive caching individual transactions. +- Introduce a periodic cache mempool sync task. + +## [0.65.8] - 2023-05-08 + +### Changed + +- Perform health check in separate thread. + +## [0.65.7] - 2023-05-05 + +### Changed + +- Do not sync mempool to Redis if node is not up-to-date. + +## [0.65.6] - 2023-05-04 + +### Changed + +- Improve caching ingestion performance. + +## [0.65.5] - 2022-09-19 + +### Added + +- Fee field added to Blockchain.info-style export-history endpoint. + +### Changed + +- Bump version due to Git mistake. + +## [0.65.3] - 2022-04-13 + +### Added + +- IPv6 peer support. + +## [0.65.2] - 2022-04-13 + +### Fixed + +- Correct lazy bytestring deserialization algorithm for web client. + +## [0.65.1] - 2022-04-13 + +### Changed + +- Simplify function in Cache module. +- Bump depenedencies. + +## [0.65.0] - 2022-02-03 + +### Changed + +- Spenders now embedded into tx objects in database for performance. +- Use faster IORef instead of slow TVar when ingesting. +- Use mutable hash tables when ingesting. +- Allow to disable unscalable API endpoints. + +## [0.64.19] - 2022-02-01 + +### Added + +- Allow to set query timeouts. + +## [0.64.18] - 2022-01-21 + +### Fixed + +- Off-by-one error when importing change addresses to cache. + +## [0.64.17] - 2022-01-21 + +### Fixed + +- Add change addresses to cache when necessary. + +## [0.64.16] - 2022-01-10 + +### Fixed + +- Correct fee calculation for blocks that do not claim all rewards. + +## [0.64.15] - 2022-01-07 + +### Fixed + +- Correct scale of cache pruning code. + +## [0.64.14] - 2022-01-07 + +### Fixed + +- Always prune to 80% of max cache size. + +## [0.64.13] - 2022-01-07 + +### Fixed + +- Avoid doing a hissy fit on transient cache issue. + +## [0.64.12] - 2022-01-07 + +### Fixed + +- Prune a little more cache to allow for new keys. + +## [0.64.11] - 2022-01-06 + +### Fixed + +- Prune cache more often. + +## [0.64.10] - 2021-12-30 + +### Changed + +- Return empty addresses in xpub balances call. + +## [0.64.9] - 2021-12-29 + +### Fixed + +- Avoid notifying same transactions in mempool. + +## [0.64.8] - 2021-12-26 + +### Changed + +- Use better Fourmolu format. +- Be more precise when counting retrieved items. + +### Fixed + +- Avoid transactions duplicated in xpub data. +- Refactor some functions to make them more robust. + +## [0.64.7] - 2021-12-26 + +### Fixed + +- Optimisations for various Blockchain endpoints. +- More accurate item counts for various web endpoints. + +## [0.64.6] - 2021-12-25 + +### Fixed + +- Record cache index time just once per xpub. + +## [0.64.5] - 2021-12-25 + +### Changed + +- Add suffix cached to cache entries to avoid conflicts with data entries. + +## [0.64.4] - 2021-12-25 + +### Fixed +- Bring dots back and avoid stats hacks. + +## [0.64.3] - 2021-12-25 + +### Fixed + +- Fix typo. + +## [0.64.2] - 2021-12-25 + +### Changed + +- Replace dots for underscores in metrics. + +## [0.64.1] - 2021-12-25 + +### Changed + +- Automatic formatting. +- Improve cache debug logging. + +### Fixed + +- Add item count to 'all' query metrics. + +## [0.64.0] - 2021-12-25 + +### Changed + +- Improve metrics. + +### Fixed + +- Get lock before importing transactions to cache. + +## 0.63.0 +### Fixed +- Make cache updates lightweight. + +## 0.62.1 +### Fixed +- Fix idempotent transaction elimination bug. + +## 0.62.0 +### Added +- Configurable Blockchain price URLs. +- Reuse HTTP connections with wreq sessions. + +## 0.61.1 +### Changed +- Upstream improvements on Base58 performance. + +## 0.61.0 +### Fixed +- Fixed recursion bug in Blockchain format conversion function. + +## 0.60.0 +### Fixed +- Correct notifications subsystem. + +## 0.59.0 +### Fixed +- Correct internal dependency. + +## 0.58.0 +### Fixed +- Correct output freeing algorithm. + +## 0.57.0 +### Changed +- Report errors freeing outputs. + +## 0.56.0 +### Changed +- Report all deleted mempool transactions. +- Crash on certain data corruption. + +## 0.55.0 +### Changed +- Always have a previous output object in Blockchain inputs. + +## 0.54.0 +### Added +- WebSocket support. +- Testnet4 support. + +## 0.53.11 +### Changed +- Dummy version increase to signal upstream update of Haskoin Core. + +## 0.53.10 +### Fixed +- Correct test that was reversed in previous version. + +## 0.53.9 +### Removed +- Mempool is no longer synced by default to fix public Bitcoin Core regression. + +## 0.53.8 +### Changed +- Put derivations stat inside database. + +## 0.53.7 +### Added +- Added counters for database retrievals. +- Added counter for xpub derivations. + +### Changed +- Removed some buggy or unnecessary stats. + +## 0.53.6 +### Changed +- Improve web server statistics. + +## 0.53.5 +### Addded +- Endpoint to delete an xpub from cache. + +## 0.53.4 +### Added +- Debugging when reverting block. + +### Fixed +- Negative (headers - blocks) diff shown incorrectly. +- Infinite loop when removing a block's coinbase transaction. + +## 0.53.3 +### Added +- Blockchain.info endpoint: `q/pubkeyhash/:addr`. +- Blockchain.info endpoint: `q/getsentbyaddress/:addr`. +- Blockchain.info endpoint: `q/pubkeyaddr/:addr`. +- Configurable request body limit size. + +## 0.53.2 +### Fixed +- Return output in satoshi for some endpoints. + +## 0.53.1 +### Fixed +- Return 404 in case of bad address. + +## 0.53.0 +### Added +- Blockchain.info endpoint: `q/addresstohash/:addr`. +- Blockchain.info endpoint: `q/addrpubkey/:pubkey`. +- Blockchain.info endpoint: `q/hashpubkey/:pubkey`. +- Blockchain.info endpoint: `q/getblockcount`. +- Blockchain.info endpoint: `q/latesthash`. +- Blockchain.info endpoint: `q/bcperblock`. +- Blockchain.info endpoint: `q/txtotalbtcoutput/:txid`. +- Blockchain.info endpoint: `q/txtotalbtcinput/:txid`. +- Blockchain.info endpoint: `q/txfee/:txid`. +- Blockchain.info endpoint: `q/txresult/:txhash/:addr`. +- Blockchain.info endpoint: `q/getreceivedbyaddress/:addr`. +- Blockchain.info endpoint: `q/addressbalance/:addr`. +- Blockchain.info endpoint: `q/addressfirstseen/:addr`. +- Support xpubs in `blockchain/rawaddr` endpoint. + +### Fixed +- Various latest blocks endpoint fixes. +- Allow empty parameters in Blockchain.info POST requests. + +## 0.52.13 +### Fixed +- Upstream fixes for unknown inv types. + +## 0.52.12 +### Fixed +- Fix limits for legacy endpoints. + +## 0.52.11 +### Added +- Alias for Blockchain.info raw address endpoint. + +### Fixed +- Fix unknown message types without payload upstream. +- Randomise peer timeouts upstream. + +## 0.52.10 +### Fixed +- Fix binary search algorithm for blocks upstream. + +## 0.52.9 +### Added +- Add Blockchain.info latest block endpoint. +- Add Blockchain.info unconfirmed-transactions endpoint. +- Add Blockchain.info blocks for one day endpoint. + +## 0.52.8 +### Fixed +- Fix special case for zero limit. + +## 0.52.7 +### Fixed +- Fix cache bug when too many transactions in mempool. + +## 0.52.6 +### Changed +- Use rationals for Blockchain.info export-history endpoint arithmetics. + +## 0.52.5 +### Added +- Support for Blockchain.info export-history endpoint. + +### Fixed +- Use strict bytestring decoder for HTTP API client. + +## 0.52.4 +### Fixed +- Use Base58 addresses by default in Blockchain.info balance querios. + +## 0.52.3 +### Fixed +- Errors should also contain CORS headers. + +## 0.52.2 +### Fixed +- Blockchain.info raw address limit should use `limit` parametre and not `n`. + +## 0.52.1 +### Changed +- Stream multiple transactions when requested. + +### Fixed +- Fix missing unspent outputs. + +## 0.52.0 +### Changed +- Remove unnecessary performance optimisations. + +### Fixed +- Reduce balance retrievals for xpubs. +- Hack UTXO ordering to avoid unwanted behaviours. +- Do not merge conduits when there are too many. + +## 0.51.0 +### Fixed +- Data type for RequestTooLarge was missing. + +## 0.50.3 +### Added +- Log HTTP request bodies. + +### Removed +- Remove web request timeout. + +### Fixed +- Do not ignore unknown start tx anchors in conduits. +- Use fast transaction counting in cache. + +### Changed +- Use WAI middlewares to manage stats. + +## 0.50.2 +### Fixed +- Do not use lazy parsers for incoming data that may throw exceptions. + +## 0.50.1 +### Fixed +- Do not allow incoming POST requests of unlimited body size. + +## 0.50.0 +### Added +- Limit number of simultaneous xpubs being cached. + +## 0.49.0 +### Changed +- Improve conduit merging algorithm. + +## 0.48.0 +### Added +- Timeouts and token bucket for web requests. +- Configurable price fetch interval. + +## 0.47.6 +### Fixed +- Fix web.all stat. + +## 0.47.5 +### Changed +- Simplify stats. + +## 0.47.4 +### Added +- Implement Blockchain.info block height. +- Implement Blockchain.info raw address. +- Implement Blockchain.info balances. + +### Fixed +- Make Blockchain.info unspent endpoint more efficient. +- Make Blockchain.info xpubs endpoint more efficient. + +### Changed +- Use compact JSON serialization by default everywhere. + +## 0.47.3 +### Fixed +- Fix serialization bug with unspents. + +## 0.47.2 +### Fixed +- Fix serialization bug for health check. + +## 0.47.1 +### Fixed +- Fix serialization bugs for web data types. + +## 0.47.0 +### Added +- Support for legacy block endpoints. + +### Changed +- Serialization now uses bytes library and does interleaved IO. + +## 0.46.6 +### Added +- Allow comma-separated values in multiaddr. + +## 0.46.5 +### Changed +- Throw error when offset exceeded instead of truncating it. + +## 0.46.4 +### Fixed +- Do not compute balances separately for loose addresses when part of an xpub. + +### Changed +- Do not fetch entire transaction list for loose addresses. +- Transaction count in wallet object is just a synonym for filtered tx count. +- Use conduits to prevent over-fetching transactions from database. + +## 0.46.3 +### Fixed +- Make hex value encoding compatible with Java BigInteger decoder. + +## 0.46.2 +### Changed +- Allow negative confirmations for compatibility with old API. + +## 0.46.1 +### Added +- Filters for transactions in multiaddr endpoint. + +## 0.46.0 +### Fixed +- Release to fix unintentional upload. + +## 0.45.0 +### Added +- Using a tx_index that results in a txid conflict returns a 409 - Conflict. + +## 0.44.0 +### Changed +- Numeric txid now 53 bits long and doesn't return transactions when hashes collide. + +## 0.43.1 +### Fixed +- Do not overcount statistics. + +## 0.43.0 +### Changed +- Transaction index now simply encodes txid as a long number (sorry JS users). + +## 0.42.4 +### Changed +- Optimise encoding of JSON data for Blockchain.info API. + +## 0.42.3 +### Changed +- Narrow down the balance for transactions to onlyShow set. + +## 0.42.2 +### Changed +- Make unspent algorithm more efficient. + +## 0.42.1 +### Added +- Support for Blockchain.info API unspent endpoint. + +### Fixed +- Fix RBF transactions on Blockchain.info API. + +## 0.42.0 +### Removed +- No more pruning of old mempool transactions. + +## 0.41.4 +### Fixed +- Correct error computing wallet balances. + +## 0.41.3 +### Changed +- Use whole active set when computing results for multiaddr. +- Compute correct count of transactions for wallet. + +## 0.41.2 +### Changed +- Caching mempool is not much slower when pruning, so reversing that change. + +## 0.41.1 +### Changed +- Only prune mempool every ten minutes or so. + +## 0.41.0 +### Removed +- No more cache eviction endpoint. + +## 0.40.22 +### Added +- More metrics for cache. + +## 0.40.21 +### Added +- Support HTTP GET for multiaddr endpoint. + +## 0.40.20 +### Added +- Prefix 'app.' in statsd when using Nomad variables. + +## 0.40.19 +### Added +- Statsd support and pleny of statistics. + +### Removed +- Removed use of sync lock for importing xpubs in cache due to volume. + +## 0.40.18 +### Added +- New options to control cache lock retry count and delay. + +### Changed +- Cache xpubs asyncrhonously. +- Mempool syncs fully every refresh cycle. + +## 0.40.17 +### Changed +- Delete more than 1000 xpubs from Redis if needed. +- Attempt to get lock ten times in order to index a new xpub. + +## 0.40.16 +### Fixed +- Fix best block not set. + +## 0.40.15 +### Fixed +- Do not update cache best block if it is higher. + +## 0.40.14 +### Fixed +- Always respond to cache pings to avoid getting stuck. + +## 0.40.13 +### Added +- Be more careful about importing blocks to the cache. + +### Removed +- Reduce excessive cache logging. + +## 0.40.12 +### Fixed +- Correct bad arithmetics in cache cooldown. + +## 0.40.11 +### Added +- Debug log cache cooldown. + +### Fixed +- Unlimited retry lock acquisition now works. +- Make locking tighter + +## 0.40.10 +### Changed +- Reduce the number of things that cache do when pinged. + +## 0.40.9 +### Fixed +- Avoid filling the cache actor mailbox with pings. + +## 0.40.8 +### Fixed +- Correct a typo in cache code. + +## 0.40.7 +### Changed +- Improve cache mempool sync algorithm. + +## 0.40.6 +### Changed +- Make cache cooldown a number. + +## 0.40.5 +### Added +- Log every non-successful query. + +## 0.40.4 +### Fixed +- Use Redis TTL for cache cooldown. + +## 0.40.3 +### Fixed +- Mempool no longer gets saved in cache when node is not in sync. + +## 0.40.2 +### Changed +- Change source of price data to https://blockchain.info/ticker. + +## 0.40.1 +### Removed +- Do not expose Paths_haskoin_store module explicitly. + +## 0.40.0 +### Added +- Blockchain.info API compatibility for multiaddr and rawtx endpoints. + +### Changed +- Segwit fields are no longer omitted on incompatible networks. + +## 0.39.0 +### Changed +- Upgrade Haskoin Core to support higher version on witness addresses. + +## 0.38.4 +### Fixed +- Fix block search by timestamp. + +## 0.38.3 +### Changed +- Disable low latency garbage collector by default. + +## 0.38.2 +### Changed +- Use GHC 8.10 and its low latency garbage collector. + +## 0.38.1 +### Changed +- Optimise algorithm for fork safety check. + +## 0.38.0 +### Added +- Support for Bitcoin Cash hard fork. + +## 0.37.5 +### Added +- Configurable cache refresh time. + +## 0.37.4 +### Fixed +- Now request mempool when connecting even if already in sync. + +### Changed +- Add a delay to mempool sync to allow for block headers to catch up. +- Attempt to sync mempool whenever syncing is done or a new peer connects. + +## 0.37.3 +### Changed +- Correct logic error when deleting superseded transactions. + +## 0.37.2 +### Changed +- Simplify multiple algorithms to hopefully solve corruption bug. +- Allow to disable mempool transaction indexing via command line. + +## 0.37.1 +### Changed +- Better locking around caching operations. +- Have a global cooldown on cache mempool updates. + +### Fixed +- Fix address unspent retrieval using correct column family. + +## 0.37.0 +### Added +- Add support for column families and prefixes breaking database backwards compatibility. + +## 0.36.2 +### Fixed +- Fix another place where mempool sorting was wrong. + +## 0.36.1 +### Fixed +- Fix wrong sorting of mempool transactions in database. + +## 0.36.0 +### Changed +- Do not use STM transactions because it is impossible to reason about preloading. +- Make importing blocks after mempool is populated faster. + +## 0.35.2 +### Changed +- Reduce frequency of cache mempool updates. + +## 0.35.1 +### Changed +- Remove cache lock retries. +- Do not use lock when caching a new xpub. + +## 0.35.0 +### Changed +- Use new RocksDB Haskell bindings. +- Make headers - blocks diff configurable in health check. +- Simplify locking in cache. + +## 0.34.8 +### Changed +- Minor refactoring. +- Only send one mempool message ever. + +## 0.34.7 +### Changed +- Fix block heights endpoint URL. + +## 0.34.6 +### Removed +- Remove asynchronous database retrieval permanently due to instability. + +## 0.34.5 +### Added +- Preload memory before freeing outputs. + +## 0.34.4 +### Added +- Asynchronous preloading only for blocks. + +## 0.34.3 +### Removed +- Disable asynchronous preloading to prevent segmentation fault error. + +## 0.34.2 +### Removed +- No more upper limit for mempool call. + +### Fixed +- Health check uses minimum between last block and mempool tx. + +## 0.34.1 +### Added +- Pending mempool transactions health check. + +### Removed +- No more upper limit for mempool call. + +## 0.34.0 +### Changed +- New format for health check. + +## 0.33.1 +### Changed +- Upload with updated Cabal files. + +## 0.33.0 +### Fixed +- Fix outputs showing up as both spent and unspent. + +### Changed +- Simplify data structures used to hold uncommitted changes. +- Split StoreRead class in two. +- Improve pre-loading algorithms. + +## 0.32.3 +### Fixed +- Fix command line argument mappings to env vars. + +## 0.32.2 +### Fixed +- Do not complain when deleting non-existent unconfirmed txs. + +## 0.32.1 +### Fixed +- Fix corruption bug when deleting transactions during some reorgs. +- Fix tests on data package. +- Rename upstream address string functions. + +## 0.32.0 +### Changed +- Concurrently load dependencies when importing transaction data. +- Import each transaction using STM. +- Rework logging. +- Refactor all block chain importing algorithms. +- Use peer locking when importing data. +- Change license to MIT. + +### Added +- Make max peer count configurable. + +### Fixed +- Prevent premature peer timeouts when importing blocks. + +## 0.31.0 +### Added +- Add Haskell web client code to data library. +- Use type-safe definitions for web paths and parameters. +- Support JSON pretty encoding and enable by default for some endpoints. +- Allow environment variables for configuration. + +### Changed +- Change command-line arguments to better fit GNU style. +- Refactor code to manipulate address balances. +- Improve logging. +- Rate-limit mempool importing. +- Do not add xpubs to cache if node not in sync. +- Do not import transactions to cache if no xpubs in cache. +- Refactor transaction importing logic extremely. +- Refactor memory database and writer. + +### Fixed +- Fix BTC double-count transaction bug. +- Add missing xpub derive parameter to xpub evict documentation. + +## 0.30.1 +### Changed +- Limit mempool API endpoint list. + +## 0.30.0 +### Changed +- Raw JSON values are now wrapped in an object with a result property. +- Better logging when importing transactions into mempool. + +### Fixed +- Transaction limit by block height works now. + +## 0.29.3 +### Changed +- Revert concurrent retrieval changes from 0.29.1 and 0.29.0 to solve stability + issues. +- Bitcoin Cash (BCH) replaces BTC as default network in CLI. +- Peer discovery enabled automatically if no peers specified in CLI. +- Use separate Stack configuration file for data package. + +## 0.29.2 +### Changed +- Increase timeouts for manager and chain health checks. + +## 0.29.1 +### Added +- Perform xpub operations concurrently. + +## 0.29.0 +### Changed +- BlockTx renamed to TxRef. +- Remove unnecessary monad transformers to simplify import code. + +### Added +- Retrieve balances and unspent outputs concurrently when importing. +- Coin instance for Unspent in data package. + +## 0.28.0 +### Changed +- Change the way that limits, start, and offset values are handled. + +### Fixed +- Fix incorrect limit responses. + +## 0.27.0 +### Added +- Complete support for offset. + +### Changed +- Improve monad stack for cache. + +## 0.26.6 +### Added +- Support for offset in all endpoints where it makes sense. + +## 0.26.5 +### Fixed +- Sort after using the nub function or use Data.List.nub in exceptional cases. + +## 0.26.4 +### Changed +- Don't do certain validity checks on confirmed transactions. + +### Fixed +- Do not crash when syncing the blockchain from scratch on a populated cache. + +## 0.26.3 +### Changed +- Replace nub function everywhere with faster version written using hash sets. + +### Fixed +- Fix shared cache locking. + +## 0.26.2 +### Changed +- Simplify cache block import code. +- Improve cache import performance. + +## 0.26.1 +### Fixed +- Do not call zadd or zrem in Redis with incorrect argument count. + +### Changed +- Do not use slow Transaction type in Logic. +- Improve logging while importing blocks. +- Better transaction import algorithm. + +## 0.26.0 +### Changed +- Add information to some binary types for feature parity with JSON. + +## 0.25.4 +### Changed +- Hide segwit data on non-segwit networks. + +### Fixed +- Fix work which now always serialises as a number literal. + +## 0.25.3 +### Changed +- Fix version display on health check. + +## 0.25.2 +### Changed +- Fix wrong version of Haskoin Store Data dependency. + +## 0.25.1 +### Changed +- Improve code organisation. +- Split data definitions and serialisation into its own package. + +## 0.24.0 +### Changed +- Use mocking to simulate peers instead of connecting to the network while testing. +- Depend on latest version of Haskoin Core for faster JSON serialisation. +- Clean up confusing JSON encoding/decoding codebase. + +## 0.23.24 +### Changed +- Implement faster JSON encoding using toEncoding from the Aeson library. + +## 0.23.23 +### Changed +- Do not read full mempool so often from cache code. + +## 0.23.22 +### Changed +- Depend on latest Haskoin Node that fixes debugging regression. + +## 0.23.21 +### Changed +- Reduce non-debug log verbosity. + +## 0.23.20 +### Changed +- Better Haskoin Node logging. + +## 0.23.19 +### Changed +- Use set peer timeout instead of constant in block store. + +## 0.23.18 +### Changed +- Allow setting peer timeouts in command line. + +### Fixed +- Bump Haskoin Node dependency to fix another premature timeout condition. + +## 0.23.17 +### Fixed +- Touch syncing peer whenever we process one of its blocks to avoid premature timeout. + +## 0.23.16 +### Changed +- Better algorithm to avoid importing transaction multiple times in cache. +- Depend on latest Haskoin Node. + +## 0.23.15 +### Changed +- Do not storm the cache with mempool transactions. + +## 0.23.13 +### Fixed +- Do not ignore deleted incoming transactions. + +## 0.23.12 +### Fixed +- Do not do RBF checks when replacing a mempool transaction with a confirmed one. + +## 0.23.11 +### Fixed +- Streamline mempool transaction importing. + +## 0.23.10 +### Fixed +- Fix transactions not recorded in cache mempool set. +- Fix transactions being downloaded multiple times. + +### Removed +- Do not store orphan transactions in database. + +### Changed +- Use sets for incoming transactions instead of lists. +- Do not do anything to the cache if there are no xpubs in it. + +## 0.23.9 +### Fixed +- Wiping mempool fixed. + +## 0.23.8 +### Added +- Chunk transactions to be deleted from mempool. + +## 0.23.7 +### Added +- Mempool improvements. + +## 0.23.6 +### Added +- Ability to wipe mempool at start. +- Improvements to mempool processing code. + +## 0.23.5 +### Changed +- Tighten the locking loop to avoid slow cache building. + +## 0.23.5 +### Fixed +- Wrong error in cache when acquiring lock. + +## 0.23.4 +### Added +- Add extra debug logging for cache code. + +### Fixed +- Fix a bug with xpub growing algorithm. + +### Changed +- Use locks instead of transactions to update cache. + +## 0.23.3 +### Fixed +- Reduce contention when many instances of Haskoin Store share a cache. + +## 0.23.2 +### Added +- Allow retrieving xpub data without using cache. + +## 0.23.1 +### Added +- Allow xpub eviction from cache via API. +- Clarify cache address addition code. + +### Fixed +- Balances were incorrectly computed in cache when new transactions arrived. + +## 0.23.0 +### Added +- Support for Redis transactions. +- Use a smaller initial gap for empty xpubs. + +### Changed +- Remove custom JSON encoding class. +- Refactor and code simplification. + +## 0.22.5 +### Fixed +- Cache was being completely pruned. + +## 0.22.4 +### Fixed +- Cache now prunes correctly. + +## 0.22.3 +### Fixed +- Bug was making cache get stuck when pruning. + +## 0.22.2 +### Changed +- More efficient algorithms for caching and cache misses. +- Better debug logging of cache hits and misses. + +## 0.22.1 +### Added +- More debug logging for cache hits. + +### Fixed +- Bug using maximum against empty list. + +## 0.22.0 +### Changed +- Extreme code refactoring. +- Move all code to Haskoin and drop Network from modules. + +### Added +- Use Redis pipelining when importing multiple transactions into cache. +- Implement configurable LRU for Redis cache. +- Import xpubs directly into cache from web worker thread when a key is requested. + +### Removed +- Only expose a few modules to external API. + +## 0.21.7 +### Changed +- Improve build configuration. + +### Fixed +- Use minimum used addresses instead of minimum index for xpub cache decision. + +## 0.21.6 +### Fixed +- Fix missing xpub unspent outputs when using cache. + +## 0.21.5 +### Added +- Only store xpubs in cache if they have more than a threshold addresses used. + +## 0.21.4 +### Fixed +- Fix shared cache case where head is set beyond header chain by another node. + +## 0.21.3 +### Fixed +- Fix bug where best head was not being registered in cache. +- Fix best head in cache being decoded incorrectly. + +## 0.21.2 +### Added +- Complete support for Redis xpub cache. + +## 0.21.1 +### Fixed +- Latest version of secp256k1-haskell works with Debian 9. + +## 0.21.0 +### Fixed +- Fix output of web API calls when issuing limits with offsets. + +### Changed +- Massive refactoring of entire codebase. + +### Added +- Work in progress Redis caching for extended public keys. + +## 0.20.2 +### Changed +- Filter xpub address balances on web API to show only addresses that have been used. + +### Removed +- Remove paths and addresses from xpub summary. + +## 0.20.1 +### Changed +- Refactor code greatly. +- Depend on new Haskoin Store package to avoid missing tx broadcasts. +- Merge StoreStream class into StoreRead. +- Move former streaming functions to use lists instead of conduits. +- Remove excessively verbose debugging. + +## 0.20.0 +### Added +- Set minimum version bounds for some dependencies. +- Now compatible with GHC 8.8. +- Extended key caching system using Redis. + +### Changed +- Massively refactored codebase. +- Less verbose debug logging. + +### Removed +- Removed conduits for faster queries. + +## 0.19.6 +### Added +- Use a parallel strategy to compute key derivations. + +### Fixed +- Do not fail health check upon transaction timeout while syncing. + +### Changed +- Do not use conduits for xpub balance streams. +- Multiple minor refactorings. + +## 0.19.5 +### Changed +- Minor refactor to block import code. + +### Fixed +- Minor fix to transaction timeout check. + +## 0.19.4 +### Fixed +- Clarify and correct health check algorithm. + +## 0.19.3 +### Changed +- Add address transactions to cache. +- Improve multi-address transaction retrieval algorithms. + +## 0.19.2 +### Removed +- Cache-Control header turned out to be unnecessary. + +### Fixed +- Fix some minor errors in web module. + +## 0.19.1 +### Added +- Set Cache-Control header to no-cache. + +## 0.19.0 +### Changed +- Store mempool in single key/value pair. + +## 0.18.11 +### Changed +- Do not stream mempool. + +## 0.18.10 +### Removed +- Disable timeout checks for testnets. + +## 0.18.9 +### Added +- Endpoint to locate a block by unix timestamp. + +### Removed +- No more persistence for peers due to dependency on newest haskoin-node. + +## 0.18.8 +### Added +- Transaction and block timeouts for health check. +- Raw blocks. + +## 0.18.7 +### Fixed +- Missing tranasctions on xpub listings. + +## 0.18.6 +### Removed +- Follow Stack advise removing `-O2` GHC option. + +## 0.18.5 +### Added +- Compatibility with SegWit on extended public key endpoints. + +### Changed +- Fix syncing peer not reset after timeout. +- Use simpler monad for streaming data. + +## 0.18.4 +### Changed +- Bump Haskoin Node to fix peers not stored and excessively verbose logging. + +## 0.18.3 +### Changed +- Configurable HTTP request logging. Disabled by default. + +## 0.18.2 +### Changed +- Fix for memory leak. + +## 0.18.1 +### Removed +- Remove transaction count from xpub summary object. + +## 0.18.0 +### Changed +- Simplified limits and start point handling on web API. +- Made transaction streaming algorithm faster for xpub transactions. +- Extended public key summary output contains all addresses that have received transactions. + +### Added +- Fine-grained control for maximum limits via command line options. +- Transaction hash as starting point. +- Block hash as starting point. +- Timestamp as starting point. +- Configurable xpub gap limit. +- Transaction count added to xpub summary. +- UTXO count added to xpub summary. + +### Removed +- Mempool endpoint now has no limits or offsets and always returns full list. +- Extended public key summary output no longer includes any transactions. +- Offsets not allowed for transaction lists involving multiple addresses or xpubs. +- Confusing block position parameter no longer part of web API. + +## 0.17.2 +### Changed +- Stream address balances and unspent outputs. +- Add configurable max value for limit and offset which defaults at 10000. + +## 0.17.1 +### Changed +- When posting a transaction to the network, timeout is now five seconds. +- Improve error message when transaction post timeout reached. +- Remove obsolete `not found` error for transaction post. +- Endpoints for retrieving blocks now do streaming for better performance. +- Improve Swagger API documentation. + +## 0.17.0 +### Added +- Endpoints for retrieving block transactions. +- Endpoint for retrieving set of latest blocks. + +### Changed +- Use standardized JSON and binary serialization schemes for raw transaction endpoints. + +## 0.16.6 +### Changed +- Now logging info messages too by default. +- Consolidated web logging in middleware. + +### Removed +- UUIDs for web requests. + +## 0.16.5 +### Removed +- Remove concurrency from xpub balance requests to prevent RocksDB segfaults. + +## 0.16.4 +### Removed +- Remove concurrency from requests using iterators to prevent RocksDB from segfaulting. + +## 0.16.3 +### Added +- Debugging information for web API. + +## 0.16.2 +### Changed +- Debugging disabled by default (use `--debug` to enable). + +## 0.16.1 +### Added +- Cache mempool transactions. +- Improve initial syncing performance. + +## 0.16.0 +### Added +- Orphan transaction support. +- Full address balance cache in RocksDB. +- Full unspent output cache in RocksDB. + +### Changed +- Significantly refactor code. +- Move web stuff to its own module. +- Change types related to databases. +- Make xpub balance, transaction and unspent queries fetch data in parallel. + +## 0.15.2 +### Added +- Internal data types to support orphan transactions. + +### Changed +- Do not spam block actor with pings. +- Fix balance/unspent cache not reverting when importing fails. +- Fix transaction sorting algorithm not including transaction position information. +- Fix conflicting mempool transaction preventing block from importing. + +## 0.15.1 +### Changed +- Fix duplicate coinbase transaction id bug. + +## 0.15.0 +### Removed +- Removed `PreciseUnixTime` data type. + +### Changed +- Use 64 bits for Unix time representation. +- Data model now uses simplified Unix time representation. + +## 0.14.9 +### Added +- Last external/change index information to xpub summary object. + +## 0.14.8 +### Added +- Endpoint for xpub summaries. +- Endpoints for full transactions. +- Ability to query by offset/limit. +- More API documentation. + +## 0.14.7 +### Added +- Debug information for `publishTx`. + +### Changed +- Transaction publishing no longer requests mempool. +- Fixed serialization for `TxId` freezing the entire program by infinitely recursing. + +## 0.14.6 +### Changed +- Enable full threading again as it was deemed not responsible for the freezing behaviour. + +## 0.14.5 +### Changed +- Enable threading but leave it at a single thread to be able to open more than 1024 files. + +## 0.14.4 +### Changed +- Target LTS Haskell 13.20 and disable threading in new attempt to fix freezing bug. + +## 0.14.3 +### Changed +- Remove `-O2`. + +## 0.14.2 +### Changed +- Target LTS Haskell 12.26 to attempt to fix freezing bug. + +## 0.14.1 +### Added +- Extra debugging around code that freezes. + +### Changed +- Bump dependency on `haskoin-node`. + +## 0.14.0 +### Removed +- Dump slow protobuf serialization. + +### Added +- Add custom serialization. +- Extra debug logging. + +### Changed +- Bump `haskoin-core` and `haskoin-node`. + +## 0.13.1 +### Changed +- Bump `haskoin-node` in `stack.yaml`. +- Do not send empty `getdata` messages. + +## 0.13.0 +### Added +- Primitive content negotiation for web exceptions. +- Protobuf support for errors. +- Protobuf support for tranasction ids. + +### Changed +- Protobuf format changed in non-backwards-compatible manner for transaction ids. + +## 0.12.0 +### Added +- Support for binary serialization using Protocol Buffers. +- New endpoints for binary raw transactions (not hex-encoded). + +### Changed +- Services field now a hex string instead of a number to avoid overflowing signed 64-bit integer. +- Flatten list of block data objects when responding to request for multiple block heights. +- Errors now reported in plain text without container JSON object. +- Transaction broadcasts are responded to with transaction id in plaintext hex (no JSON). +- Remove database snapshots to improve performance. + +## 0.11.2 +### Changed +- Fix duplicate mempool transaction announcements in event stream. + +## 0.11.1 +### Removed +- Removed latest block time check. + +## 0.11.0 +### Changed +- Improve post transactions endpoint. + +## 0.10.1 +### Changed +- Fix bug where transaction lists from multiple addresses would sort incorrectly. +- Address gap reduced to 20. + +## 0.10.0 +### Removed +- Remove addresses from transaction lists. +- No longer use container objects for xpub transactions. + +## 0.9.3 +### Added +- Permissive CORS headers to allow queries from any domain. +- Improved documentation using real-world examples from the BCH testnet. + +## 0.9.2 +### Added +- HTTP JSON API switch to turn off transaction list when retrieving blocks. + +## 0.9.1 +### Added +- Total block fees. +- Total block outputs. +- Block subsidy. + +### Changed +- Do not consider the blocks less one block away from headers as out of sync in health check. +- Health check now returns HTTP 503 when not OK or out of sync. + +## 0.9.0 +### Added +- Version to health check output. +- Block weight for segwit. +- Transaction weight for segwit. + +## 0.8.1 +### Added +- Health check endpoint. + +## 0.8.0 +### Added +- Limits and skips. +- Add timestamps to transactions. +- Add transaction count to address balance object. +- Add Merkle root to block data. +- Total funds received by an address now shows up in balance. +- Balances for any address that ever had funds show up in xpub endpoints. + +### Changed +- Data model update. +- Performance improvement for xpub calls. +- Transactions are returned in reverse mempool/block order (highest or most recent first). +- Balance objects do not get deleted from database ever. + +## 0.6.9 +### Changed +- Reduce number of coinbase checks to 10,000 ancestors. + +## 0.6.8 +### Changed +- Further optimize coinbase after height checks. + +## 0.6.7 +### Changed +- Impose restrictions on recursion for coinbase after height checks. + +## 0.6.6 +### Added +- Check whether a transaction can be traced back to a coinbase after certain height. + +## 0.6.5 +### Changed +- Delete transactions in reverse topological order when reverting a block. + +## 0.6.4 +### Changed +- Do not fail silently when importing orphan transactions into the mempool. + +## 0.6.3 +### Changed +- Dummy release to bump haskoin-node in stack.yaml. + +## 0.6.2 +### Changed +- Correct bug where coinbase transactions weren't properly flagged. + +## 0.6.1 +### Changed +- Compatibility with Bitcoin Cash hard fork. +- Various bug fixes. + +## 0.6.0 +### Added +- Address balance cache in memory. + +### Changed +- Simplify data model further. +- Fix bug importing outputs with UTXO cache. +- Unspent balances cannot be negative. + +## 0.5.0 +### Added +- Add UTXO cache in memory. +- Get transactions with witness data in segwit networks. + +### Changed +- Paths for derivations in xpubs is a list and no longer a string. +- Various bug fixes. + +## 0.4.2 +### Removed +- Remove extended public key itself from output of relevant endpoints to save bandwidth. + +## 0.4.1 +### Changed +- Fix bug when deleting coinbase transactions. +- Extended public key API support. + +## 0.4.0 +### Changed +- Generate events for mempool transactions. +- Respond with entire block data when querying blocks by height. + +## 0.3.1 +### Changed +- Do not import transactions to mempool while not synced. +- Only sync mempool against a single peer. +- Allow duplicate transactions to fix re-introduced sync bug. + +## 0.3.0 +### Added +- Update dependencies. +- Keep orphan blocks and deleted transactions in database. +- Add a `mainchain` field for block data and a `deleted` field for transactions. +- Stream records for performance. +- Show witness data for transaction inputs in SegWit network. +- Support RBF in SegWit network. + +### Changed +- Refactor all data access code away from actor. +- Refactor import logic away from actor. +- Abstract data access using typeclasses. +- Implement data access using clean layered architecture. +- Make most of import logic code pure. +- Database now in `db` as opposed to `blocks` directory. +- Use latest `haskoin-node`. + +### Removed +- Remove some data from peer information output. +- Remove full transaction from address transaction data. +- Remove limits from address transaction data. +- Remove block data from previous output. +- Remove spender from JSON response when output not spent. +- Remove block hash from block reference. + +## 0.2.3 +### Removed +- Do not send transaction notifications if a block is being imported. + +## 0.2.2 +### Added +- Peer information endpoint. + +### Changed +- Update `haskoin-node`. + +## 0.2.1 +### Changed +- Fix tests + +## 0.2.0 +### Added +- Documentation everywhere. +- Ability to retrieve address transactions. + +### Changed +- New versions of NQE and Haskoin Node upstream. +- Improve and simplify API. +- Multi-element endpoints return arrays of arrays. +- Database snapshots for all queries are now mandatory. + +### Removed +- Retrieving unspent and spent outputs for an address. +- Redundant API endpoints for multiple elements. + +## 0.1.3 +### Changed +- Fix a bug with transaction notifications. +- Improve handling orphan transactions. + +## 0.1.2 +### Changed +- Specify dependencies better. + +## 0.1.1 +### Changed +- Dependency `secp256k1` is now `secp256k1-haskell`. + +## 0.1.0 +### Added +- New `CHANGELOG.md` file. +- Bitcoin (BTC) and Bitcoin Cash (BCH) compatibility. +- RocksDB database. +- Mempool support. +- HTTP streaming for events. +- CashAddr support. +- Bech32 support. +- Rate limits. + +### Changed +- Split out of former `haskoin` repository. +- Use hpack and `package.yaml`. + +### Removed +- Removed Stylish Haskell configuration file. +- Remvoed `haskoin-core` and `haskoin-wallet` packages from this repository. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +# Haskoin Store + +Block chain store and index featuring: + +- Persistent storage using [RocksDB](https://rocksdb.org/). +- [Bitcoin Cash (BCH)](https://www.bitcoincash.org/) support. +- [Bitcoin Core (BTC)](https://bitcoin.org/) support. +- Indices for address balances, transactions, and unspent outputs (UTXO). +- Persistent mempool. +- Replace Bitcoin Core (BTC) RBF transactions by default. +- Query transactions, balances and UTXO on extended keys (xpub). +- Optional accelerated xpub cache using Redis. +- RESTful API with JSON and binary serialization. +- High performance concurrent architecture. +- Compatibility with Blockchain.info-style endpoints. + +## Install with Nix on any distribution + +* Get [Nix](https://nixos.org/nix/) + +```sh +nix-env --install stack +git clone https://github.com/haskoin/haskoin-store.git +cd haskoin-store +stack --nix build --copy-bins +~/.local/bin/haskoin-store --help +``` + +## Install on Ubuntu or Debian + +```sh +apt install git zlib1g-dev libsecp256k1-dev librocksdb-dev pkg-config haskell-stack +git clone https://github.com/haskoin/haskoin-store.git +cd haskoin-store +stack build --copy-bins +~/.local/bin/haskoin-store --help +``` + +## Install on Fedora + +```sh +dnf install git zlib-devel libsecp256k1-devel rocksdb-devel stack +git clone https://github.com/haskoin/haskoin-store.git +cd haskoin-store +stack build --copy-bins +~/.local/bin/haskoin-store --help +``` + +## Non-Haskell Dependencies + +* [zlib](https://zlib.net/) +* [libsecp256k1](https://github.com/Bitcoin-ABC/secp256k1) +* [RocksDB](https://github.com/facebook/rocksdb) + +## API Documentation + +* [Swagger API Documentation](https://api.haskoin.com/) diff --git a/haskoin-store-data.cabal b/haskoin-store-data.cabal --- a/haskoin-store-data.cabal +++ b/haskoin-store-data.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -- --- hash: 03532ff6fc9ef1e166af059c92a3233d35b358009d28980754f5bbce1abec023 +-- hash: 5c6d0f79cd18954de7032dc7b391fccf7ff90f5afd84f693d4533a84f7a2afcc name: haskoin-store-data -version: 0.65.12 +version: 1.0.0 synopsis: Data for Haskoin Store description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -18,6 +18,9 @@ license: MIT license-file: LICENSE build-type: Simple +extra-source-files: + README.md + CHANGELOG.md source-repository head type: git @@ -43,7 +46,7 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0 - , haskoin-core >=0.21.0 + , haskoin-core >=1.0.0 , http-client >=0.6.4.1 , http-types >=0.12.3 , lens >=4.18.1 @@ -54,10 +57,11 @@ , text >=1.2.3.0 , time >=1.9.3 , unordered-containers >=0.2.10 + , vector >=0.13.0.0 , wreq >=0.5.3.2 default-language: Haskell2010 -test-suite haskoin-store-test +test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: @@ -79,7 +83,7 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0 - , haskoin-core >=0.21.0 + , haskoin-core >=1.0.0 , haskoin-store-data , hspec >=2.7.1 , http-client >=0.6.4.1 @@ -92,6 +96,7 @@ , text >=1.2.3.0 , time >=1.9.3 , unordered-containers >=0.2.10 + , vector >=0.13.0.0 , wreq >=0.5.3.2 default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Haskoin/Store/Data.hs b/src/Haskoin/Store/Data.hs --- a/src/Haskoin/Store/Data.hs +++ b/src/Haskoin/Store/Data.hs @@ -1,3623 +1,3476 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Haskoin.Store.Data - ( -- * Address Balances - Balance (..), - balanceToJSON, - balanceToEncoding, - balanceParseJSON, - zeroBalance, - nullBalance, - - -- * Block Data - BlockData (..), - blockDataToJSON, - blockDataToEncoding, - confirmed, - - -- * Transactions - TxRef (..), - TxData (..), - txDataFee, - isCoinbaseTx, - Transaction (..), - transactionToJSON, - transactionToEncoding, - transactionParseJSON, - transactionData, - fromTransaction, - toTransaction, - StoreInput (..), - storeInputToJSON, - storeInputToEncoding, - storeInputParseJSON, - isCoinbase, - StoreOutput (..), - storeOutputToJSON, - storeOutputToEncoding, - storeOutputParseJSON, - Prev (..), - Spender (..), - BlockRef (..), - UnixTime, - getUnixTime, - putUnixTime, - BlockPos, - - -- * Unspent Outputs - Unspent (..), - unspentToJSON, - unspentToEncoding, - unspentParseJSON, - - -- * Extended Public Keys - XPubSpec (..), - XPubBal (..), - xPubBalToJSON, - xPubBalToEncoding, - xPubBalParseJSON, - XPubUnspent (..), - xPubUnspentToJSON, - xPubUnspentToEncoding, - xPubUnspentParseJSON, - XPubSummary (..), - DeriveType (..), - textToDeriveType, - deriveTypeToText, - - -- * Other Data - TxId (..), - GenericResult (..), - SerialList (..), - RawResult (..), - RawResultList (..), - PeerInformation (..), - Healthy (..), - BlockHealth (..), - TimeHealth (..), - CountHealth (..), - MaxHealth (..), - HealthCheck (..), - Event (..), - Except (..), - - -- * Blockchain.info API - BinfoBlockId (..), - BinfoTxId (..), - encodeBinfoTxId, - BinfoFilter (..), - BinfoMultiAddr (..), - binfoMultiAddrToJSON, - binfoMultiAddrToEncoding, - binfoMultiAddrParseJSON, - BinfoShortBal (..), - BinfoBalance (..), - toBinfoAddrs, - binfoBalanceToJSON, - binfoBalanceToEncoding, - binfoBalanceParseJSON, - BinfoRawAddr (..), - binfoRawAddrToJSON, - binfoRawAddrToEncoding, - binfoRawAddrParseJSON, - BinfoAddr (..), - parseBinfoAddr, - BinfoWallet (..), - BinfoUnspent (..), - binfoUnspentToJSON, - binfoUnspentToEncoding, - binfoUnspentParseJSON, - binfoHexValue, - BinfoUnspents (..), - binfoUnspentsToJSON, - binfoUnspentsToEncoding, - binfoUnspentsParseJSON, - BinfoBlock (..), - toBinfoBlock, - binfoBlockToJSON, - binfoBlockToEncoding, - binfoBlockParseJSON, - binfoBlocksToJSON, - binfoBlocksToEncoding, - binfoBlocksParseJSON, - BinfoTx (..), - relevantTxs, - toBinfoTx, - toBinfoTxSimple, - binfoTxToJSON, - binfoTxToEncoding, - binfoTxParseJSON, - BinfoTxInput (..), - binfoTxInputToJSON, - binfoTxInputToEncoding, - binfoTxInputParseJSON, - BinfoTxOutput (..), - binfoTxOutputToJSON, - binfoTxOutputToEncoding, - binfoTxOutputParseJSON, - BinfoSpender (..), - BinfoXPubPath (..), - binfoXPubPathToJSON, - binfoXPubPathToEncoding, - binfoXPubPathParseJSON, - BinfoInfo (..), - BinfoBlockInfo (..), - toBinfoBlockInfo, - BinfoSymbol (..), - BinfoTicker (..), - BinfoRate (..), - BinfoHistory (..), - toBinfoHistory, - BinfoDate (..), - BinfoHeader (..), - BinfoMempool (..), - binfoMempoolToJSON, - binfoMempoolToEncoding, - binfoMempoolParseJSON, - BinfoBlocks (..), - ) -where - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad (join, mzero, unless, (<=<)) -import Data.Aeson - ( Encoding, - FromJSON (..), - ToJSON (..), - Value (..), - (.!=), - (.:), - (.:?), - (.=), - ) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as AE -import Data.Aeson.Types (Parser) -import Data.Binary (Binary (get, put)) -import Data.Bits (Bits (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BSB -import Data.Bytes.Get -import qualified Data.Bytes.Get as Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Default (Default (..)) -import Data.Foldable (toList) -import Data.Function (on) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Hashable (Hashable (..)) -import Data.Int (Int32, Int64) -import qualified Data.IntMap as IntMap -import Data.IntMap.Strict (IntMap) -import Data.Maybe - ( catMaybes, - fromMaybe, - isJust, - isNothing, - mapMaybe, - maybeToList, - ) -import Data.Serialize (Serialize (..)) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Data.Time.Clock.POSIX - ( posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.Format - ( defaultTimeLocale, - formatTime, - parseTimeM, - ) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Haskoin hiding (inputAddress) -import Web.Scotty.Trans (Parsable (..), ScottyError (..)) - -data DeriveType - = DeriveNormal - | DeriveP2SH - | DeriveP2WPKH - deriving (Show, Eq, Generic, NFData) - -textToDeriveType :: Text -> Maybe DeriveType -textToDeriveType "normal" = Just DeriveNormal -textToDeriveType "compat" = Just DeriveP2SH -textToDeriveType "segwit" = Just DeriveP2WPKH -textToDeriveType _ = Nothing - -deriveTypeToText :: DeriveType -> Text -deriveTypeToText DeriveNormal = "normal" -deriveTypeToText DeriveP2SH = "compat" -deriveTypeToText DeriveP2WPKH = "segwit" - -instance Serial DeriveType where - serialize DeriveNormal = putWord8 0x00 - serialize DeriveP2SH = putWord8 0x01 - serialize DeriveP2WPKH = putWord8 0x02 - - deserialize = - getWord8 >>= \case - 0x00 -> return DeriveNormal - 0x01 -> return DeriveP2SH - 0x02 -> return DeriveP2WPKH - _ -> return DeriveNormal - -instance Binary DeriveType where - put = serialize - get = deserialize - -instance Serialize DeriveType where - put = serialize - get = deserialize - -instance Default DeriveType where - def = DeriveNormal - -instance Parsable DeriveType where - parseParam txt = - case textToDeriveType (TL.toStrict txt) of - Nothing -> Left "invalid derivation type" - Just x -> Right x - -data XPubSpec = XPubSpec - { xPubSpecKey :: !XPubKey, - xPubDeriveType :: !DeriveType - } - deriving (Show, Eq, Generic, NFData) - -instance Hashable XPubSpec where - hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} = - hashWithSalt i pubkey - -instance Serial XPubSpec where - serialize XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do - putWord8 (xPubDepth k) - serialize (xPubParent k) - putWord32be (xPubIndex k) - serialize (xPubChain k) - serialize (wrapPubKey True (xPubKey k)) - serialize t - deserialize = do - d <- getWord8 - p <- deserialize - i <- getWord32be - c <- deserialize - k <- deserialize - t <- deserialize - let x = - XPubKey - { xPubDepth = d, - xPubParent = p, - xPubIndex = i, - xPubChain = c, - xPubKey = pubKeyPoint k - } - return XPubSpec {xPubSpecKey = x, xPubDeriveType = t} - -instance Serialize XPubSpec where - put = serialize - get = deserialize - -instance Binary XPubSpec where - put = serialize - get = deserialize - -type UnixTime = Word64 - -type BlockPos = Word32 - --- | Binary such that ordering is inverted. -putUnixTime :: MonadPut m => Word64 -> m () -putUnixTime w = putWord64be $ maxBound - w - -getUnixTime :: MonadGet m => m Word64 -getUnixTime = (maxBound -) <$> getWord64be - --- | Reference to a block where a transaction is stored. -data BlockRef - = BlockRef - { -- | block height in the chain - blockRefHeight :: !BlockHeight, - -- | position of transaction within the block - blockRefPos :: !Word32 - } - | MemRef - { memRefTime :: !UnixTime - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - --- | Serial entities will sort in reverse order. -instance Serial BlockRef where - serialize MemRef {memRefTime = t} = do - putWord8 0x00 - putUnixTime t - serialize BlockRef {blockRefHeight = h, blockRefPos = p} = do - putWord8 0x01 - putWord32be (maxBound - h) - putWord32be (maxBound - p) - deserialize = - getWord8 >>= \case - 0x00 -> getmemref - 0x01 -> getblockref - _ -> fail "Cannot decode BlockRef" - where - getmemref = do - MemRef <$> getUnixTime - getblockref = do - h <- (maxBound -) <$> getWord32be - p <- (maxBound -) <$> getWord32be - return BlockRef {blockRefHeight = h, blockRefPos = p} - -instance Serialize BlockRef where - put = serialize - get = deserialize - -instance Binary BlockRef where - put = serialize - get = deserialize - -confirmed :: BlockRef -> Bool -confirmed BlockRef {} = True -confirmed MemRef {} = False - -instance ToJSON BlockRef where - toJSON BlockRef {blockRefHeight = h, blockRefPos = p} = - A.object ["height" .= h, "position" .= p] - toJSON MemRef {memRefTime = t} = A.object ["mempool" .= t] - toEncoding BlockRef {blockRefHeight = h, blockRefPos = p} = - AE.pairs ("height" .= h <> "position" .= p) - toEncoding MemRef {memRefTime = t} = AE.pairs ("mempool" .= t) - -instance FromJSON BlockRef where - parseJSON = A.withObject "blockref" $ \o -> b o <|> m o - where - b o = do - height <- o .: "height" - position <- o .: "position" - return BlockRef {blockRefHeight = height, blockRefPos = position} - m o = do - mempool <- o .: "mempool" - return MemRef {memRefTime = mempool} - --- | Transaction in relation to an address. -data TxRef = TxRef - { -- | block information - txRefBlock :: !BlockRef, - -- | transaction hash - txRefHash :: !TxHash - } - deriving (Show, Eq, Ord, Generic, Hashable, NFData) - -instance Serial TxRef where - serialize (TxRef b h) = do - serialize b - serialize h - - deserialize = - TxRef <$> deserialize <*> deserialize - -instance Binary TxRef where - put = serialize - get = deserialize - -instance Serialize TxRef where - put = serialize - get = deserialize - -instance ToJSON TxRef where - toJSON btx = - A.object - [ "txid" .= txRefHash btx, - "block" .= txRefBlock btx - ] - toEncoding btx = - AE.pairs $ - "txid" .= txRefHash btx - <> "block" .= txRefBlock btx - -instance FromJSON TxRef where - parseJSON = - A.withObject "blocktx" $ \o -> do - txid <- o .: "txid" - block <- o .: "block" - return TxRef {txRefBlock = block, txRefHash = txid} - --- | Address balance information. -data Balance = Balance - { -- | address balance - balanceAddress :: !Address, - -- | confirmed balance - balanceAmount :: !Word64, - -- | unconfirmed balance - balanceZero :: !Word64, - -- | number of unspent outputs - balanceUnspentCount :: !Word64, - -- | number of transactions - balanceTxCount :: !Word64, - -- | total amount from all outputs in this address - balanceTotalReceived :: !Word64 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Balance where - serialize Balance {..} = do - serialize balanceAddress - putWord64be balanceAmount - putWord64be balanceZero - putWord64be balanceUnspentCount - putWord64be balanceTxCount - putWord64be balanceTotalReceived - - deserialize = do - balanceAddress <- deserialize - balanceAmount <- getWord64be - balanceZero <- getWord64be - balanceUnspentCount <- getWord64be - balanceTxCount <- getWord64be - balanceTotalReceived <- getWord64be - return Balance {..} - -instance Binary Balance where - put = serialize - get = deserialize - -instance Serialize Balance where - put = serialize - get = deserialize - -zeroBalance :: Address -> Balance -zeroBalance a = - Balance - { balanceAddress = a, - balanceAmount = 0, - balanceUnspentCount = 0, - balanceZero = 0, - balanceTxCount = 0, - balanceTotalReceived = 0 - } - -nullBalance :: Balance -> Bool -nullBalance - Balance - { balanceAmount = 0, - balanceUnspentCount = 0, - balanceZero = 0, - balanceTxCount = 0, - balanceTotalReceived = 0 - } = True -nullBalance _ = False - -balanceToJSON :: Network -> Balance -> Value -balanceToJSON net b = - A.object - [ "address" .= addrToJSON net (balanceAddress b), - "confirmed" .= balanceAmount b, - "unconfirmed" .= balanceZero b, - "utxo" .= balanceUnspentCount b, - "txs" .= balanceTxCount b, - "received" .= balanceTotalReceived b - ] - -balanceToEncoding :: Network -> Balance -> Encoding -balanceToEncoding net b = - AE.pairs $ - "address" `AE.pair` addrToEncoding net (balanceAddress b) - <> "confirmed" .= balanceAmount b - <> "unconfirmed" .= balanceZero b - <> "utxo" .= balanceUnspentCount b - <> "txs" .= balanceTxCount b - <> "received" .= balanceTotalReceived b - -balanceParseJSON :: Network -> Value -> Parser Balance -balanceParseJSON net = - A.withObject "balance" $ \o -> do - amount <- o .: "confirmed" - unconfirmed <- o .: "unconfirmed" - utxo <- o .: "utxo" - txs <- o .: "txs" - received <- o .: "received" - address <- addrFromJSON net =<< o .: "address" - return - Balance - { balanceAddress = address, - balanceAmount = amount, - balanceUnspentCount = utxo, - balanceZero = unconfirmed, - balanceTxCount = txs, - balanceTotalReceived = received - } - --- | Unspent output. -data Unspent = Unspent - { unspentBlock :: !BlockRef, - unspentPoint :: !OutPoint, - unspentAmount :: !Word64, - unspentScript :: !ByteString, - unspentAddress :: !(Maybe Address) - } - deriving (Show, Eq, Generic, Hashable, NFData) - --- | Follow same order as in database and cache by inverting outpoint sort --- order. -instance Ord Unspent where - compare a b = - compare - (unspentBlock a, unspentPoint b) - (unspentBlock b, unspentPoint a) - -instance Serial Unspent where - serialize Unspent {..} = do - serialize unspentBlock - serialize unspentPoint - putWord64be unspentAmount - putLengthBytes unspentScript - putMaybe serialize unspentAddress - - deserialize = do - unspentBlock <- deserialize - unspentPoint <- deserialize - unspentAmount <- getWord64be - unspentScript <- getLengthBytes - unspentAddress <- getMaybe deserialize - return Unspent {..} - -instance Binary Unspent where - put = serialize - get = deserialize - -instance Serialize Unspent where - put = serialize - get = deserialize - -instance Coin Unspent where - coinValue = unspentAmount - -unspentToJSON :: Network -> Unspent -> Value -unspentToJSON net u = - A.object - [ "address" .= (addrToJSON net <$> unspentAddress u), - "block" .= unspentBlock u, - "txid" .= outPointHash (unspentPoint u), - "index" .= outPointIndex (unspentPoint u), - "pkscript" .= encodeHex (unspentScript u), - "value" .= unspentAmount u - ] - -unspentToEncoding :: Network -> Unspent -> Encoding -unspentToEncoding net u = - AE.pairs $ - "address" `AE.pair` maybe AE.null_ (addrToEncoding net) (unspentAddress u) - <> "block" .= unspentBlock u - <> "txid" .= outPointHash (unspentPoint u) - <> "index" .= outPointIndex (unspentPoint u) - <> "pkscript" `AE.pair` AE.text (encodeHex (unspentScript u)) - <> "value" .= unspentAmount u - -unspentParseJSON :: Network -> Value -> Parser Unspent -unspentParseJSON net = - A.withObject "unspent" $ \o -> do - block <- o .: "block" - txid <- o .: "txid" - index <- o .: "index" - value <- o .: "value" - script <- o .: "pkscript" >>= jsonHex - addr <- - o .: "address" >>= \case - Nothing -> return Nothing - Just a -> Just <$> addrFromJSON net a <|> return Nothing - return - Unspent - { unspentBlock = block, - unspentPoint = OutPoint txid index, - unspentAmount = value, - unspentScript = script, - unspentAddress = addr - } - --- | Database value for a block entry. -data BlockData = BlockData - { -- | height of the block in the chain - blockDataHeight :: !BlockHeight, - -- | is this block in the main chain? - blockDataMainChain :: !Bool, - -- | accumulated work in that block - blockDataWork :: !Integer, - -- | block header - blockDataHeader :: !BlockHeader, - -- | size of the block including witnesses - blockDataSize :: !Word32, - -- | weight of this block (for segwit networks) - blockDataWeight :: !Word32, - -- | block transactions - blockDataTxs :: ![TxHash], - -- | sum of all transaction outputs - blockDataOutputs :: !Word64, - -- | sum of all transaction fees - blockDataFees :: !Word64, - -- | block subsidy - blockDataSubsidy :: !Word64 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial BlockData where - serialize BlockData {..} = do - putWord32be blockDataHeight - serialize blockDataMainChain - putInteger blockDataWork - serialize blockDataHeader - putWord32be blockDataSize - putWord32be blockDataWeight - putList serialize blockDataTxs - putWord64be blockDataOutputs - putWord64be blockDataFees - putWord64be blockDataSubsidy - - deserialize = do - blockDataHeight <- getWord32be - blockDataMainChain <- deserialize - blockDataWork <- getInteger - blockDataHeader <- deserialize - blockDataSize <- getWord32be - blockDataWeight <- getWord32be - blockDataTxs <- getList deserialize - blockDataOutputs <- getWord64be - blockDataFees <- getWord64be - blockDataSubsidy <- getWord64be - return BlockData {..} - -instance Serialize BlockData where - put = serialize - get = deserialize - -instance Binary BlockData where - put = serialize - get = deserialize - -blockDataToJSON :: Network -> BlockData -> Value -blockDataToJSON net bv = - A.object $ - [ "hash" .= headerHash (blockDataHeader bv), - "height" .= blockDataHeight bv, - "mainchain" .= blockDataMainChain bv, - "previous" .= prevBlock (blockDataHeader bv), - "time" .= blockTimestamp (blockDataHeader bv), - "version" .= blockVersion (blockDataHeader bv), - "bits" .= blockBits (blockDataHeader bv), - "nonce" .= bhNonce (blockDataHeader bv), - "size" .= blockDataSize bv, - "tx" .= blockDataTxs bv, - "merkle" .= TxHash (merkleRoot (blockDataHeader bv)), - "subsidy" .= blockDataSubsidy bv, - "fees" .= blockDataFees bv, - "outputs" .= blockDataOutputs bv, - "work" .= blockDataWork bv - ] - <> ["weight" .= blockDataWeight bv | getSegWit net] - -blockDataToEncoding :: Network -> BlockData -> Encoding -blockDataToEncoding net bv = - AE.pairs $ - "hash" - `AE.pair` AE.text - (blockHashToHex (headerHash (blockDataHeader bv))) - <> "height" .= blockDataHeight bv - <> "mainchain" .= blockDataMainChain bv - <> "previous" .= prevBlock (blockDataHeader bv) - <> "time" .= blockTimestamp (blockDataHeader bv) - <> "version" .= blockVersion (blockDataHeader bv) - <> "bits" .= blockBits (blockDataHeader bv) - <> "nonce" .= bhNonce (blockDataHeader bv) - <> "size" .= blockDataSize bv - <> "tx" .= blockDataTxs bv - <> "merkle" - `AE.pair` AE.text - (txHashToHex (TxHash (merkleRoot (blockDataHeader bv)))) - <> "subsidy" .= blockDataSubsidy bv - <> "fees" .= blockDataFees bv - <> "outputs" .= blockDataOutputs bv - <> "work" .= blockDataWork bv - <> (if getSegWit net then "weight" .= blockDataWeight bv else mempty) - -instance FromJSON BlockData where - parseJSON = - A.withObject "blockdata" $ \o -> do - height <- o .: "height" - mainchain <- o .: "mainchain" - previous <- o .: "previous" - time <- o .: "time" - version <- o .: "version" - bits <- o .: "bits" - nonce <- o .: "nonce" - size <- o .: "size" - tx <- o .: "tx" - TxHash merkle <- o .: "merkle" - subsidy <- o .: "subsidy" - fees <- o .: "fees" - outputs <- o .: "outputs" - work <- o .: "work" - weight <- o .:? "weight" .!= 0 - return - BlockData - { blockDataHeader = - BlockHeader - { prevBlock = previous, - blockTimestamp = time, - blockVersion = version, - blockBits = bits, - bhNonce = nonce, - merkleRoot = merkle - }, - blockDataMainChain = mainchain, - blockDataWork = work, - blockDataSize = size, - blockDataWeight = weight, - blockDataTxs = tx, - blockDataOutputs = outputs, - blockDataFees = fees, - blockDataHeight = height, - blockDataSubsidy = subsidy - } - -data StoreInput - = StoreCoinbase - { inputPoint :: !OutPoint, - inputSequence :: !Word32, - inputSigScript :: !ByteString, - inputWitness :: !WitnessStack - } - | StoreInput - { inputPoint :: !OutPoint, - inputSequence :: !Word32, - inputSigScript :: !ByteString, - inputPkScript :: !ByteString, - inputAmount :: !Word64, - inputWitness :: !WitnessStack, - inputAddress :: !(Maybe Address) - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial StoreInput where - serialize StoreCoinbase {..} = do - putWord8 0x00 - serialize inputPoint - putWord32be inputSequence - putLengthBytes inputSigScript - putList putLengthBytes inputWitness - serialize StoreInput {..} = do - putWord8 0x01 - serialize inputPoint - putWord32be inputSequence - putLengthBytes inputSigScript - putLengthBytes inputPkScript - putWord64be inputAmount - putList putLengthBytes inputWitness - putMaybe serialize inputAddress - - deserialize = - getWord8 >>= \case - 0x00 -> do - inputPoint <- deserialize - inputSequence <- getWord32be - inputSigScript <- getLengthBytes - inputWitness <- getList getLengthBytes - return StoreCoinbase {..} - 0x01 -> do - inputPoint <- deserialize - inputSequence <- getWord32be - inputSigScript <- getLengthBytes - inputPkScript <- getLengthBytes - inputAmount <- getWord64be - inputWitness <- getList getLengthBytes - inputAddress <- getMaybe deserialize - return StoreInput {..} - x -> fail $ "Unknown input id: " <> cs (show x) - -instance Serialize StoreInput where - put = serialize - get = deserialize - -instance Binary StoreInput where - put = serialize - get = deserialize - -isCoinbaseTx :: Tx -> Bool -isCoinbaseTx = all ((== nullOutPoint) . prevOutput) . txIn - -isCoinbase :: StoreInput -> Bool -isCoinbase StoreCoinbase {} = True -isCoinbase StoreInput {} = False - -storeInputToJSON :: Network -> StoreInput -> Value -storeInputToJSON - net - StoreInput - { inputPoint = OutPoint oph opi, - inputSequence = sq, - inputSigScript = ss, - inputPkScript = ps, - inputAmount = val, - inputWitness = wit, - inputAddress = a - } = - A.object - [ "coinbase" .= False, - "txid" .= oph, - "output" .= opi, - "sigscript" .= String (encodeHex ss), - "sequence" .= sq, - "pkscript" .= String (encodeHex ps), - "value" .= val, - "address" .= (addrToJSON net <$> a), - "witness" .= map encodeHex wit - ] -storeInputToJSON - _ - StoreCoinbase - { inputPoint = OutPoint oph opi, - inputSequence = sq, - inputSigScript = ss, - inputWitness = wit - } = - A.object - [ "coinbase" .= True, - "txid" .= oph, - "output" .= opi, - "sigscript" .= String (encodeHex ss), - "sequence" .= sq, - "pkscript" .= Null, - "value" .= Null, - "address" .= Null, - "witness" .= map encodeHex wit - ] - -storeInputToEncoding :: Network -> StoreInput -> Encoding -storeInputToEncoding - net - StoreInput - { inputPoint = OutPoint oph opi, - inputSequence = sq, - inputSigScript = ss, - inputPkScript = ps, - inputAmount = val, - inputWitness = wit, - inputAddress = a - } = - AE.pairs $ - "coinbase" .= False - <> "txid" .= oph - <> "output" .= opi - <> "sigscript" `AE.pair` AE.text (encodeHex ss) - <> "sequence" .= sq - <> "pkscript" `AE.pair` AE.text (encodeHex ps) - <> "value" .= val - <> "address" `AE.pair` maybe AE.null_ (addrToEncoding net) a - <> "witness" .= map encodeHex wit -storeInputToEncoding - _ - StoreCoinbase - { inputPoint = OutPoint oph opi, - inputSequence = sq, - inputSigScript = ss, - inputWitness = wit - } = - AE.pairs $ - "coinbase" .= True - <> "txid" `AE.pair` AE.text (txHashToHex oph) - <> "output" .= opi - <> "sigscript" `AE.pair` AE.text (encodeHex ss) - <> "sequence" .= sq - <> "pkscript" `AE.pair` AE.null_ - <> "value" `AE.pair` AE.null_ - <> "address" `AE.pair` AE.null_ - <> "witness" .= map encodeHex wit - -storeInputParseJSON :: Network -> Value -> Parser StoreInput -storeInputParseJSON net = - A.withObject "storeinput" $ \o -> do - coinbase <- o .: "coinbase" - outpoint <- OutPoint <$> o .: "txid" <*> o .: "output" - sequ <- o .: "sequence" - witness <- mapM jsonHex =<< o .:? "witness" .!= [] - sigscript <- o .: "sigscript" >>= jsonHex - if coinbase - then - return - StoreCoinbase - { inputPoint = outpoint, - inputSequence = sequ, - inputSigScript = sigscript, - inputWitness = witness - } - else do - pkscript <- o .: "pkscript" >>= jsonHex - value <- o .: "value" - addr <- - o .: "address" >>= \case - Nothing -> return Nothing - Just a -> Just <$> addrFromJSON net a <|> return Nothing - return - StoreInput - { inputPoint = outpoint, - inputSequence = sequ, - inputSigScript = sigscript, - inputPkScript = pkscript, - inputAmount = value, - inputWitness = witness, - inputAddress = addr - } - -jsonHex :: Text -> Parser ByteString -jsonHex s = - case decodeHex s of - Nothing -> fail "Could not decode hex" - Just b -> return b - --- | Information about input spending output. -data Spender = Spender - { -- | input transaction hash - spenderHash :: !TxHash, - -- | input position in transaction - spenderIndex :: !Word32 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Spender where - serialize Spender {..} = do - serialize spenderHash - putWord32be spenderIndex - deserialize = Spender <$> deserialize <*> getWord32be - -instance Serialize Spender where - put = serialize - get = deserialize - -instance Binary Spender where - put = serialize - get = deserialize - -instance ToJSON Spender where - toJSON n = - A.object - [ "txid" .= txHashToHex (spenderHash n), - "input" .= spenderIndex n - ] - toEncoding n = - AE.pairs $ - "txid" .= txHashToHex (spenderHash n) - <> "input" .= spenderIndex n - -instance FromJSON Spender where - parseJSON = - A.withObject "spender" $ \o -> - Spender <$> o .: "txid" <*> o .: "input" - --- | Output information. -data StoreOutput = StoreOutput - { outputAmount :: !Word64, - outputScript :: !ByteString, - outputSpender :: !(Maybe Spender), - outputAddr :: !(Maybe Address) - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial StoreOutput where - serialize StoreOutput {..} = do - putWord64be outputAmount - putLengthBytes outputScript - putMaybe serialize outputSpender - putMaybe serialize outputAddr - deserialize = do - outputAmount <- getWord64be - outputScript <- getLengthBytes - outputSpender <- getMaybe deserialize - outputAddr <- getMaybe deserialize - return StoreOutput {..} - -instance Serialize StoreOutput where - put = serialize - get = deserialize - -instance Binary StoreOutput where - put = serialize - get = deserialize - -storeOutputToJSON :: Network -> StoreOutput -> Value -storeOutputToJSON net d = - A.object - [ "address" .= (addrToJSON net <$> outputAddr d), - "pkscript" .= encodeHex (outputScript d), - "value" .= outputAmount d, - "spent" .= isJust (outputSpender d), - "spender" .= outputSpender d - ] - -storeOutputToEncoding :: Network -> StoreOutput -> Encoding -storeOutputToEncoding net d = - AE.pairs $ - "address" `AE.pair` maybe AE.null_ (addrToEncoding net) (outputAddr d) - <> "pkscript" `AE.pair` AE.text (encodeHex (outputScript d)) - <> "value" .= outputAmount d - <> "spent" .= isJust (outputSpender d) - <> "spender" .= outputSpender d - -storeOutputParseJSON :: Network -> Value -> Parser StoreOutput -storeOutputParseJSON net = - A.withObject "storeoutput" $ \o -> do - value <- o .: "value" - pkscript <- o .: "pkscript" >>= jsonHex - spender <- o .: "spender" - addr <- - o .: "address" >>= \case - Nothing -> return Nothing - Just a -> Just <$> addrFromJSON net a <|> return Nothing - return - StoreOutput - { outputAmount = value, - outputScript = pkscript, - outputSpender = spender, - outputAddr = addr - } - -data Prev = Prev - { prevScript :: !ByteString, - prevAmount :: !Word64 - } - deriving (Show, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Prev where - serialize Prev {..} = do - putLengthBytes prevScript - putWord64be prevAmount - deserialize = do - prevScript <- getLengthBytes - prevAmount <- getWord64be - return Prev {..} - -instance Binary Prev where - put = serialize - get = deserialize - -instance Serialize Prev where - put = serialize - get = deserialize - -toInput :: TxIn -> Maybe Prev -> WitnessStack -> StoreInput -toInput i Nothing w = - StoreCoinbase - { inputPoint = prevOutput i, - inputSequence = txInSequence i, - inputSigScript = scriptInput i, - inputWitness = w - } -toInput i (Just p) w = - StoreInput - { inputPoint = prevOutput i, - inputSequence = txInSequence i, - inputSigScript = scriptInput i, - inputPkScript = prevScript p, - inputAmount = prevAmount p, - inputWitness = w, - inputAddress = eitherToMaybe (scriptToAddressBS (prevScript p)) - } - -toOutput :: TxOut -> Maybe Spender -> StoreOutput -toOutput o s = - StoreOutput - { outputAmount = outValue o, - outputScript = scriptOutput o, - outputSpender = s, - outputAddr = eitherToMaybe (scriptToAddressBS (scriptOutput o)) - } - -data TxData = TxData - { txDataBlock :: !BlockRef, - txData :: !Tx, - txDataPrevs :: !(IntMap Prev), - txDataDeleted :: !Bool, - txDataRBF :: !Bool, - txDataTime :: !Word64, - txDataSpenders :: !(IntMap Spender) - } - deriving (Show, Eq, Ord, Generic, NFData) - -instance Serial TxData where - serialize TxData {..} = do - serialize txDataBlock - serialize txData - putIntMap (putWord64be . fromIntegral) serialize txDataPrevs - serialize txDataDeleted - serialize txDataRBF - putWord64be txDataTime - putIntMap (putWord64be . fromIntegral) serialize txDataSpenders - deserialize = do - txDataBlock <- deserialize - txData <- deserialize - txDataPrevs <- getIntMap (fromIntegral <$> getWord64be) deserialize - txDataDeleted <- deserialize - txDataRBF <- deserialize - txDataTime <- getWord64be - txDataSpenders <- getIntMap (fromIntegral <$> getWord64be) deserialize - return TxData {..} - -instance Serialize TxData where - put = serialize - get = deserialize - -instance Binary TxData where - put = serialize - get = deserialize - -txDataFee :: TxData -> Word64 -txDataFee TxData {..} = - if isCoinbaseTx txData then 0 else inputs - outputs - where - inputs = sum . map prevAmount $ IntMap.elems txDataPrevs - outputs = sum . map outValue $ txOut txData - -toTransaction :: TxData -> Transaction -toTransaction t = - Transaction - { transactionBlock = txDataBlock t, - transactionVersion = txVersion (txData t), - transactionLockTime = txLockTime (txData t), - transactionInputs = ins, - transactionOutputs = outs, - transactionDeleted = txDataDeleted t, - transactionRBF = txDataRBF t, - transactionTime = txDataTime t, - transactionId = txid, - transactionSize = txsize, - transactionWeight = txweight, - transactionFees = fees - } - where - txid = txHash (txData t) - txsize = fromIntegral $ BS.length (runPutS (serialize (txData t))) - txweight = - let b = BS.length $ runPutS $ serialize (txData t) {txWitness = []} - x = BS.length $ runPutS $ serialize (txData t) - in fromIntegral $ b * 3 + x - inv = sum (map inputAmount ins) - outv = sum (map outputAmount outs) - fees = if any isCoinbase ins then 0 else inv - outv - ws = take (length (txIn (txData t))) $ txWitness (txData t) <> repeat [] - f n i = toInput i (IntMap.lookup n (txDataPrevs t)) (ws !! n) - ins = zipWith f [0 ..] (txIn (txData t)) - g n o = toOutput o (IntMap.lookup n (txDataSpenders t)) - outs = zipWith g [0 ..] (txOut (txData t)) - -fromTransaction :: Transaction -> TxData -fromTransaction t = - TxData - { txDataBlock = transactionBlock t, - txData = transactionData t, - txDataPrevs = ps, - txDataDeleted = transactionDeleted t, - txDataRBF = transactionRBF t, - txDataTime = transactionTime t, - txDataSpenders = sm - } - where - f _ StoreCoinbase {} = Nothing - f n StoreInput {inputPkScript = s, inputAmount = v} = - Just (n, Prev {prevScript = s, prevAmount = v}) - ps = IntMap.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) - g _ StoreOutput {outputSpender = Nothing} = Nothing - g n StoreOutput {outputSpender = Just s} = Just (n, s) - sm = IntMap.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) - --- | Detailed transaction information. -data Transaction = Transaction - { -- | block information for this transaction - transactionBlock :: !BlockRef, - -- | transaction version - transactionVersion :: !Word32, - -- | lock time - transactionLockTime :: !Word32, - -- | transaction inputs - transactionInputs :: ![StoreInput], - -- | transaction outputs - transactionOutputs :: ![StoreOutput], - -- | this transaction has been deleted and is no longer valid - transactionDeleted :: !Bool, - -- | this transaction can be replaced in the mempool - transactionRBF :: !Bool, - -- | time the transaction was first seen or time of block - transactionTime :: !Word64, - -- | transaction id - transactionId :: !TxHash, - -- | serialized transaction size (includes witness data) - transactionSize :: !Word32, - -- | transaction weight - transactionWeight :: !Word32, - -- | fees that this transaction pays (0 for coinbase) - transactionFees :: !Word64 - } - deriving (Show, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Transaction where - serialize Transaction {..} = do - serialize transactionBlock - putWord32be transactionVersion - putWord32be transactionLockTime - putList serialize transactionInputs - putList serialize transactionOutputs - serialize transactionDeleted - serialize transactionRBF - putWord64be transactionTime - serialize transactionId - putWord32be transactionSize - putWord32be transactionWeight - putWord64be transactionFees - deserialize = do - transactionBlock <- deserialize - transactionVersion <- getWord32be - transactionLockTime <- getWord32be - transactionInputs <- getList deserialize - transactionOutputs <- getList deserialize - transactionDeleted <- deserialize - transactionRBF <- deserialize - transactionTime <- getWord64be - transactionId <- deserialize - transactionSize <- getWord32be - transactionWeight <- getWord32be - transactionFees <- getWord64be - return Transaction {..} - -instance Serialize Transaction where - put = serialize - get = deserialize - -instance Binary Transaction where - put = serialize - get = deserialize - -transactionData :: Transaction -> Tx -transactionData t = - Tx - { txVersion = transactionVersion t, - txIn = map i (transactionInputs t), - txOut = map o (transactionOutputs t), - txWitness = w $ map inputWitness (transactionInputs t), - txLockTime = transactionLockTime t - } - where - i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} = - TxIn {prevOutput = p, scriptInput = s, txInSequence = q} - i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} = - TxIn {prevOutput = p, scriptInput = s, txInSequence = q} - o StoreOutput {outputAmount = v, outputScript = s} = - TxOut {outValue = v, scriptOutput = s} - w xs - | all null xs = [] - | otherwise = xs - -transactionToJSON :: Network -> Transaction -> Value -transactionToJSON net dtx = - A.object - [ "txid" .= transactionId dtx, - "size" .= transactionSize dtx, - "version" .= transactionVersion dtx, - "locktime" .= transactionLockTime dtx, - "fee" .= transactionFees dtx, - "inputs" .= map (storeInputToJSON net) (transactionInputs dtx), - "outputs" .= map (storeOutputToJSON net) (transactionOutputs dtx), - "block" .= transactionBlock dtx, - "deleted" .= transactionDeleted dtx, - "time" .= transactionTime dtx, - "rbf" .= transactionRBF dtx, - "weight" .= transactionWeight dtx - ] - -transactionToEncoding :: Network -> Transaction -> Encoding -transactionToEncoding net dtx = - AE.pairs $ - "txid" .= transactionId dtx - <> "size" .= transactionSize dtx - <> "version" .= transactionVersion dtx - <> "locktime" .= transactionLockTime dtx - <> "fee" .= transactionFees dtx - <> "inputs" - `AE.pair` AE.list - (storeInputToEncoding net) - (transactionInputs dtx) - <> "outputs" - `AE.pair` AE.list - (storeOutputToEncoding net) - (transactionOutputs dtx) - <> "block" .= transactionBlock dtx - <> "deleted" .= transactionDeleted dtx - <> "time" .= transactionTime dtx - <> "rbf" .= transactionRBF dtx - <> "weight" .= transactionWeight dtx - -transactionParseJSON :: Network -> Value -> Parser Transaction -transactionParseJSON net = A.withObject "transaction" $ \o -> do - version <- o .: "version" - locktime <- o .: "locktime" - inputs <- o .: "inputs" >>= mapM (storeInputParseJSON net) - outputs <- o .: "outputs" >>= mapM (storeOutputParseJSON net) - block <- o .: "block" - deleted <- o .: "deleted" - time <- o .: "time" - rbf <- o .:? "rbf" .!= False - weight <- o .:? "weight" .!= 0 - size <- o .: "size" - txid <- o .: "txid" - fees <- o .: "fee" - return - Transaction - { transactionBlock = block, - transactionVersion = version, - transactionLockTime = locktime, - transactionInputs = inputs, - transactionOutputs = outputs, - transactionDeleted = deleted, - transactionTime = time, - transactionRBF = rbf, - transactionWeight = weight, - transactionSize = size, - transactionId = txid, - transactionFees = fees - } - --- | Information about a connected peer. -data PeerInformation = PeerInformation - { -- | user agent string - peerUserAgent :: !ByteString, - -- | network address - peerAddress :: !String, - -- | version number - peerVersion :: !Word32, - -- | services field - peerServices :: !Word64, - -- | will relay transactions - peerRelay :: !Bool - } - deriving (Show, Eq, Ord, Generic, NFData) - -instance Serial PeerInformation where - serialize PeerInformation {..} = do - putLengthBytes peerUserAgent - putLengthBytes (TE.encodeUtf8 (T.pack peerAddress)) - putWord32be peerVersion - putWord64be peerServices - serialize peerRelay - deserialize = do - peerUserAgent <- getLengthBytes - peerAddress <- T.unpack . TE.decodeUtf8 <$> getLengthBytes - peerVersion <- getWord32be - peerServices <- getWord64be - peerRelay <- deserialize - return PeerInformation {..} - -instance Serialize PeerInformation where - put = serialize - get = deserialize - -instance Binary PeerInformation where - put = serialize - get = deserialize - -instance ToJSON PeerInformation where - toJSON p = - A.object - [ "useragent" .= String (cs (peerUserAgent p)), - "address" .= peerAddress p, - "version" .= peerVersion p, - "services" - .= String (encodeHex (runPutS (serialize (peerServices p)))), - "relay" .= peerRelay p - ] - toEncoding p = - AE.pairs $ - "useragent" `AE.pair` AE.text (cs (peerUserAgent p)) - <> "address" .= peerAddress p - <> "version" .= peerVersion p - <> "services" - `AE.pair` AE.text - (encodeHex (runPutS (serialize (peerServices p)))) - <> "relay" .= peerRelay p - -instance FromJSON PeerInformation where - parseJSON = - A.withObject "peerinformation" $ \o -> do - String useragent <- o .: "useragent" - address <- o .: "address" - version <- o .: "version" - services <- - o .: "services" >>= jsonHex >>= \b -> - case runGetS deserialize b of - Left e -> fail $ "Could not decode services: " <> e - Right s -> return s - relay <- o .: "relay" - return - PeerInformation - { peerUserAgent = cs useragent, - peerAddress = address, - peerVersion = version, - peerServices = services, - peerRelay = relay - } - --- | Address balances for an extended public key. -data XPubBal = XPubBal - { xPubBalPath :: ![KeyIndex], - xPubBal :: !Balance - } - deriving (Show, Ord, Eq, Generic, NFData) - -instance Serial XPubBal where - serialize XPubBal {..} = do - putList putWord32be xPubBalPath - serialize xPubBal - deserialize = do - xPubBalPath <- getList getWord32be - xPubBal <- deserialize - return XPubBal {..} - -instance Serialize XPubBal where - put = serialize - get = deserialize - -instance Binary XPubBal where - put = serialize - get = deserialize - -xPubBalToJSON :: Network -> XPubBal -> Value -xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} = - A.object ["path" .= p, "balance" .= balanceToJSON net b] - -xPubBalToEncoding :: Network -> XPubBal -> Encoding -xPubBalToEncoding net XPubBal {xPubBalPath = p, xPubBal = b} = - AE.pairs ("path" .= p <> "balance" `AE.pair` balanceToEncoding net b) - -xPubBalParseJSON :: Network -> Value -> Parser XPubBal -xPubBalParseJSON net = - A.withObject "xpubbal" $ \o -> do - path <- o .: "path" - balance <- balanceParseJSON net =<< o .: "balance" - return XPubBal {xPubBalPath = path, xPubBal = balance} - --- | Unspent transaction for extended public key. -data XPubUnspent = XPubUnspent - { xPubUnspent :: !Unspent, - xPubUnspentPath :: ![KeyIndex] - } - deriving (Show, Eq, Ord, Generic, NFData) - -instance Serial XPubUnspent where - serialize XPubUnspent {..} = do - putList putWord32be xPubUnspentPath - serialize xPubUnspent - deserialize = do - xPubUnspentPath <- getList getWord32be - xPubUnspent <- deserialize - return XPubUnspent {..} - -instance Serialize XPubUnspent where - put = serialize - get = deserialize - -instance Binary XPubUnspent where - put = serialize - get = deserialize - -xPubUnspentToJSON :: Network -> XPubUnspent -> Value -xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = - A.object ["unspent" .= unspentToJSON net u, "path" .= p] - -xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding -xPubUnspentToEncoding net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = - AE.pairs $ "unspent" `AE.pair` unspentToEncoding net u <> "path" .= p - -xPubUnspentParseJSON :: Network -> Value -> Parser XPubUnspent -xPubUnspentParseJSON net = - A.withObject "xpubunspent" $ \o -> do - u <- o .: "unspent" >>= unspentParseJSON net - p <- o .: "path" - return XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} - -data XPubSummary = XPubSummary - { xPubSummaryConfirmed :: !Word64, - xPubSummaryZero :: !Word64, - xPubSummaryReceived :: !Word64, - xPubUnspentCount :: !Word64, - xPubExternalIndex :: !Word32, - xPubChangeIndex :: !Word32 - } - deriving (Eq, Show, Generic, NFData) - -instance Serial XPubSummary where - serialize XPubSummary {..} = do - putWord64be xPubSummaryConfirmed - putWord64be xPubSummaryZero - putWord64be xPubSummaryReceived - putWord64be xPubUnspentCount - putWord32be xPubExternalIndex - putWord32be xPubChangeIndex - deserialize = do - xPubSummaryConfirmed <- getWord64be - xPubSummaryZero <- getWord64be - xPubSummaryReceived <- getWord64be - xPubUnspentCount <- getWord64be - xPubExternalIndex <- getWord32be - xPubChangeIndex <- getWord32be - return XPubSummary {..} - -instance Binary XPubSummary where - put = serialize - get = deserialize - -instance Serialize XPubSummary where - put = serialize - get = deserialize - -instance ToJSON XPubSummary where - toJSON - XPubSummary - { xPubSummaryConfirmed = c, - xPubSummaryZero = z, - xPubSummaryReceived = r, - xPubUnspentCount = u, - xPubExternalIndex = ext, - xPubChangeIndex = ch - } = - A.object - [ "balance" - .= A.object - [ "confirmed" .= c, - "unconfirmed" .= z, - "received" .= r, - "utxo" .= u - ], - "indices" - .= A.object - [ "change" .= ch, - "external" .= ext - ] - ] - toEncoding - XPubSummary - { xPubSummaryConfirmed = c, - xPubSummaryZero = z, - xPubSummaryReceived = r, - xPubUnspentCount = u, - xPubExternalIndex = ext, - xPubChangeIndex = ch - } = - AE.pairs $ - "balance" - `AE.pair` AE.pairs - ( "confirmed" .= c - <> "unconfirmed" .= z - <> "received" .= r - <> "utxo" .= u - ) - <> "indices" - `AE.pair` AE.pairs - ( "change" .= ch - <> "external" .= ext - ) - -instance FromJSON XPubSummary where - parseJSON = - A.withObject "xpubsummary" $ \o -> do - b <- o .: "balance" - i <- o .: "indices" - conf <- b .: "confirmed" - unconfirmed <- b .: "unconfirmed" - received <- b .: "received" - utxo <- b .: "utxo" - change <- i .: "change" - external <- i .: "external" - return - XPubSummary - { xPubSummaryConfirmed = conf, - xPubSummaryZero = unconfirmed, - xPubSummaryReceived = received, - xPubUnspentCount = utxo, - xPubExternalIndex = external, - xPubChangeIndex = change - } - -class Healthy a where - isOK :: a -> Bool - -data BlockHealth = BlockHealth - { blockHealthHeaders :: !BlockHeight, - blockHealthBlocks :: !BlockHeight, - blockHealthMaxDiff :: !Int32 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial BlockHealth where - serialize h@BlockHealth {..} = do - serialize (isOK h) - putWord32be blockHealthHeaders - putWord32be blockHealthBlocks - putInt32be blockHealthMaxDiff - deserialize = do - k <- deserialize - blockHealthHeaders <- getWord32be - blockHealthBlocks <- getWord32be - blockHealthMaxDiff <- getInt32be - let h = BlockHealth {..} - unless (k == isOK h) $ fail "Inconsistent health check" - return h - -instance Serialize BlockHealth where - put = serialize - get = deserialize - -instance Binary BlockHealth where - put = serialize - get = deserialize - -instance Healthy BlockHealth where - isOK BlockHealth {..} = - h - b <= blockHealthMaxDiff - where - h = fromIntegral blockHealthHeaders - b = fromIntegral blockHealthBlocks - -instance ToJSON BlockHealth where - toJSON h@BlockHealth {..} = - A.object - [ "headers" .= blockHealthHeaders, - "blocks" .= blockHealthBlocks, - "diff" .= diff, - "max" .= blockHealthMaxDiff, - "ok" .= isOK h - ] - where - diff = toInteger blockHealthHeaders - toInteger blockHealthBlocks - -instance FromJSON BlockHealth where - parseJSON = - A.withObject "BlockHealth" $ \o -> do - blockHealthHeaders <- o .: "headers" - blockHealthBlocks <- o .: "blocks" - blockHealthMaxDiff <- o .: "max" - return BlockHealth {..} - -data TimeHealth = TimeHealth - { timeHealthAge :: !Int64, - timeHealthMax :: !Int64 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial TimeHealth where - serialize h@TimeHealth {..} = do - serialize (isOK h) - putInt64be timeHealthAge - putInt64be timeHealthMax - deserialize = do - k <- deserialize - timeHealthAge <- getInt64be - timeHealthMax <- getInt64be - let t = TimeHealth {..} - unless (k == isOK t) $ fail "Inconsistent health check" - return t - -instance Binary TimeHealth where - put = serialize - get = deserialize - -instance Serialize TimeHealth where - put = serialize - get = deserialize - -instance Healthy TimeHealth where - isOK TimeHealth {..} = - timeHealthAge <= timeHealthMax - -instance ToJSON TimeHealth where - toJSON h@TimeHealth {..} = - A.object - [ "age" .= timeHealthAge, - "max" .= timeHealthMax, - "ok" .= isOK h - ] - -instance FromJSON TimeHealth where - parseJSON = - A.withObject "TimeHealth" $ \o -> do - timeHealthAge <- o .: "age" - timeHealthMax <- o .: "max" - return TimeHealth {..} - -data CountHealth = CountHealth - { countHealthNum :: !Int64, - countHealthMin :: !Int64 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial CountHealth where - serialize h@CountHealth {..} = do - serialize (isOK h) - putInt64be countHealthNum - putInt64be countHealthMin - deserialize = do - k <- deserialize - countHealthNum <- getInt64be - countHealthMin <- getInt64be - let c = CountHealth {..} - unless (k == isOK c) $ fail "Inconsistent health check" - return c - -instance Serialize CountHealth where - put = serialize - get = deserialize - -instance Binary CountHealth where - put = serialize - get = deserialize - -instance Healthy CountHealth where - isOK CountHealth {..} = - countHealthMin <= countHealthNum - -instance ToJSON CountHealth where - toJSON h@CountHealth {..} = - A.object - [ "count" .= countHealthNum, - "min" .= countHealthMin, - "ok" .= isOK h - ] - -instance FromJSON CountHealth where - parseJSON = - A.withObject "CountHealth" $ \o -> do - countHealthNum <- o .: "count" - countHealthMin <- o .: "min" - return CountHealth {..} - -data MaxHealth = MaxHealth - { maxHealthNum :: !Int64, - maxHealthMax :: !Int64 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial MaxHealth where - serialize h@MaxHealth {..} = do - serialize $ isOK h - putInt64be maxHealthNum - putInt64be maxHealthMax - deserialize = do - k <- deserialize - maxHealthNum <- getInt64be - maxHealthMax <- getInt64be - let h = MaxHealth {..} - unless (k == isOK h) $ fail "Inconsistent health check" - return h - -instance Binary MaxHealth where - put = serialize - get = deserialize - -instance Serialize MaxHealth where - put = serialize - get = deserialize - -instance Healthy MaxHealth where - isOK MaxHealth {..} = maxHealthNum <= maxHealthMax - -instance ToJSON MaxHealth where - toJSON h@MaxHealth {..} = - A.object - [ "count" .= maxHealthNum, - "max" .= maxHealthMax, - "ok" .= isOK h - ] - -instance FromJSON MaxHealth where - parseJSON = - A.withObject "MaxHealth" $ \o -> do - maxHealthNum <- o .: "count" - maxHealthMax <- o .: "max" - return MaxHealth {..} - -data HealthCheck = HealthCheck - { healthBlocks :: !BlockHealth, - healthLastBlock :: !TimeHealth, - healthLastTx :: !TimeHealth, - healthPendingTxs :: !MaxHealth, - healthPeers :: !CountHealth, - healthNetwork :: !String, - healthVersion :: !String - } - deriving (Show, Eq, Generic, NFData) - -instance Serial HealthCheck where - serialize h@HealthCheck {..} = do - serialize (isOK h) - serialize healthBlocks - serialize healthLastBlock - serialize healthLastTx - serialize healthPendingTxs - serialize healthPeers - putLengthBytes ((TE.encodeUtf8 . T.pack) healthNetwork) - putLengthBytes ((TE.encodeUtf8 . T.pack) healthVersion) - deserialize = do - k <- deserialize - healthBlocks <- deserialize - healthLastBlock <- deserialize - healthLastTx <- deserialize - healthPendingTxs <- deserialize - healthPeers <- deserialize - healthNetwork <- T.unpack . TE.decodeUtf8 <$> getLengthBytes - healthVersion <- T.unpack . TE.decodeUtf8 <$> getLengthBytes - let h = HealthCheck {..} - unless (k == isOK h) $ fail "Inconsistent health check" - return h - -instance Binary HealthCheck where - put = serialize - get = deserialize - -instance Serialize HealthCheck where - put = serialize - get = deserialize - -instance Healthy HealthCheck where - isOK HealthCheck {..} = - isOK healthBlocks - && isOK healthLastBlock - && isOK healthLastTx - && isOK healthPendingTxs - && isOK healthPeers - -instance ToJSON HealthCheck where - toJSON h@HealthCheck {..} = - A.object - [ "blocks" .= healthBlocks, - "last-block" .= healthLastBlock, - "last-tx" .= healthLastTx, - "pending-txs" .= healthPendingTxs, - "peers" .= healthPeers, - "net" .= healthNetwork, - "version" .= healthVersion, - "ok" .= isOK h - ] - -instance FromJSON HealthCheck where - parseJSON = - A.withObject "HealthCheck" $ \o -> do - healthBlocks <- o .: "blocks" - healthLastBlock <- o .: "last-block" - healthLastTx <- o .: "last-tx" - healthPendingTxs <- o .: "pending-txs" - healthPeers <- o .: "peers" - healthNetwork <- o .: "net" - healthVersion <- o .: "version" - return HealthCheck {..} - -data Event - = EventBlock !BlockHash - | EventTx !TxHash - deriving (Show, Eq, Generic, NFData) - -instance Serial Event where - serialize (EventBlock bh) = putWord8 0x00 >> serialize bh - serialize (EventTx th) = putWord8 0x01 >> serialize th - deserialize = - getWord8 >>= \case - 0x00 -> EventBlock <$> deserialize - 0x01 -> EventTx <$> deserialize - _ -> fail "Not an Event" - -instance Serialize Event where - put = serialize - get = deserialize - -instance Binary Event where - put = serialize - get = deserialize - -instance ToJSON Event where - toJSON (EventTx h) = - A.object - [ "type" .= String "tx", - "id" .= h - ] - toJSON (EventBlock h) = - A.object - [ "type" .= String "block", - "id" .= h - ] - toEncoding (EventTx h) = - AE.pairs $ - "type" `AE.pair` AE.text "tx" - <> "id" `AE.pair` AE.text (txHashToHex h) - toEncoding (EventBlock h) = - AE.pairs $ - "type" `AE.pair` AE.text "block" - <> "id" `AE.pair` AE.text (blockHashToHex h) - -instance FromJSON Event where - parseJSON = - A.withObject "event" $ \o -> do - t <- o .: "type" - case t of - "tx" -> do - i <- o .: "id" - return $ EventTx i - "block" -> do - i <- o .: "id" - return $ EventBlock i - _ -> fail $ "Could not recognize event type: " <> t - -newtype GenericResult a = GenericResult - { getResult :: a - } - deriving (Show, Eq, Generic, NFData) - -instance Serial a => Serial (GenericResult a) where - serialize (GenericResult x) = serialize x - deserialize = GenericResult <$> deserialize - -instance Serial a => Serialize (GenericResult a) where - put = serialize - get = deserialize - -instance Serial a => Binary (GenericResult a) where - put = serialize - get = deserialize - -instance ToJSON a => ToJSON (GenericResult a) where - toJSON (GenericResult b) = A.object ["result" .= b] - toEncoding (GenericResult b) = AE.pairs ("result" .= b) - -instance FromJSON a => FromJSON (GenericResult a) where - parseJSON = - A.withObject "GenericResult" $ \o -> - GenericResult <$> o .: "result" - -newtype RawResult a = RawResult - { getRawResult :: a - } - deriving (Show, Eq, Generic, NFData) - -instance Serial a => Serial (RawResult a) where - serialize (RawResult x) = serialize x - deserialize = RawResult <$> deserialize - -instance Serial a => Serialize (RawResult a) where - put = serialize - get = deserialize - -instance Serial a => Binary (RawResult a) where - put = serialize - get = deserialize - -instance Serial a => ToJSON (RawResult a) where - toJSON (RawResult b) = - A.object ["result" .= x b] - where - x = - TLE.decodeUtf8 - . BSB.toLazyByteString - . BSB.lazyByteStringHex - . runPutL - . serialize - toEncoding (RawResult b) = - AE.pairs $ "result" `AE.pair` AE.unsafeToEncoding str - where - str = - BSB.char7 '"' - <> BSB.lazyByteStringHex (runPutL (serialize b)) - <> BSB.char7 '"' - -instance Serial a => FromJSON (RawResult a) where - parseJSON = - A.withObject "RawResult" $ \o -> do - res <- o .: "result" - let m = - eitherToMaybe . Bytes.Get.runGetS deserialize - =<< decodeHex res - maybe mzero (return . RawResult) m - -newtype SerialList a = SerialList {getSerialList :: [a]} - deriving (Show, Eq, Generic, NFData) - -instance Semigroup (SerialList a) where - SerialList a <> SerialList b = SerialList (a <> b) - -instance Monoid (SerialList a) where - mempty = SerialList mempty - -instance Serial a => Serial (SerialList a) where - serialize (SerialList ls) = putList serialize ls - deserialize = SerialList <$> getList deserialize - -instance ToJSON a => ToJSON (SerialList a) where - toJSON (SerialList ls) = toJSON ls - toEncoding (SerialList ls) = toEncoding ls - -instance FromJSON a => FromJSON (SerialList a) where - parseJSON = fmap SerialList . parseJSON - -newtype RawResultList a = RawResultList - { getRawResultList :: [a] - } - deriving (Show, Eq, Generic, NFData) - -instance Serial a => Serial (RawResultList a) where - serialize (RawResultList xs) = - mapM_ serialize xs - deserialize = RawResultList <$> go - where - go = - isEmpty >>= \case - True -> return [] - False -> (:) <$> deserialize <*> go - -instance Serial a => Serialize (RawResultList a) where - put = serialize - get = deserialize - -instance Serial a => Binary (RawResultList a) where - put = serialize - get = deserialize - -instance Semigroup (RawResultList a) where - (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b - -instance Monoid (RawResultList a) where - mempty = RawResultList mempty - -instance Serial a => ToJSON (RawResultList a) where - toJSON (RawResultList xs) = - toJSON $ - TLE.decodeUtf8 - . BSB.toLazyByteString - . BSB.lazyByteStringHex - . runPutL - . serialize - <$> xs - toEncoding (RawResultList xs) = - AE.list (AE.unsafeToEncoding . str) xs - where - str x = - BSB.char7 '"' - <> BSB.lazyByteStringHex (runPutL (serialize x)) - <> BSB.char7 '"' - -instance Serial a => FromJSON (RawResultList a) where - parseJSON = - A.withArray "RawResultList" $ \vec -> - RawResultList <$> mapM parseElem (toList vec) - where - parseElem = A.withText "RawResultListElem" $ maybe mzero return . f - f = eitherToMaybe . Bytes.Get.runGetS deserialize <=< decodeHex - -newtype TxId - = TxId TxHash - deriving (Show, Eq, Generic, NFData) - -instance Serial TxId where - serialize (TxId h) = serialize h - deserialize = TxId <$> deserialize - -instance Serialize TxId where - put = serialize - get = deserialize - -instance Binary TxId where - put = serialize - get = deserialize - -instance ToJSON TxId where - toJSON (TxId h) = A.object ["txid" .= h] - toEncoding (TxId h) = AE.pairs ("txid" `AE.pair` AE.text (txHashToHex h)) - -instance FromJSON TxId where - parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid" - -data Except - = ThingNotFound - | ServerError - | BadRequest - | UserError !String - | StringError !String - | TxIndexConflict ![TxHash] - | ServerTimeout - | RequestTooLarge - deriving (Show, Eq, Ord, Generic, NFData) - -instance Exception Except - -instance ScottyError Except where - stringError = StringError - showError = TL.pack . show - -instance ToJSON Except where - toJSON e = - A.object $ - case e of - ThingNotFound -> - [ "error" .= String "not-found-or-invalid-arg", - "message" .= String "Item not found or argument invalid" - ] - ServerError -> - [ "error" .= String "server-error", - "message" .= String "Server error" - ] - BadRequest -> - [ "error" .= String "bad-request", - "message" .= String "Invalid request" - ] - UserError msg' -> - [ "error" .= String "user-error", - "message" .= String (cs msg') - ] - StringError msg' -> - [ "error" .= String "string-error", - "message" .= String (cs msg') - ] - TxIndexConflict txids -> - [ "error" .= String "multiple-tx-index", - "message" .= String "Multiple txs match that index", - "txids" .= txids - ] - ServerTimeout -> - [ "error" .= String "server-timeout", - "message" .= String "Request is taking too long" - ] - RequestTooLarge -> - [ "error" .= String "request-too-large", - "message" .= String "Request body too large" - ] - -instance FromJSON Except where - parseJSON = - A.withObject "Except" $ \o -> do - ctr <- o .: "error" - msg' <- o .:? "message" .!= "" - case ctr of - String "not-found-or-invalid-arg" -> - return ThingNotFound - String "server-error" -> - return ServerError - String "bad-request" -> - return BadRequest - String "user-error" -> - return $ UserError msg' - String "string-error" -> - return $ StringError msg' - String "multiple-tx-index" -> do - txids <- o .: "txids" - return $ TxIndexConflict txids - String "server-timeout" -> - return ServerTimeout - String "request-too-large" -> - return RequestTooLarge - _ -> mzero - -toIntTxId :: TxHash -> Word64 -toIntTxId h = - let bs = runPutS (serialize h) - Right w64 = runGetS getWord64be bs - in w64 `shift` (-11) - ---------------------------------------- --- Blockchain.info API Compatibility -- ---------------------------------------- - -data BinfoBlockId - = BinfoBlockHash !BlockHash - | BinfoBlockIndex !Word32 - deriving (Eq, Show, Read, Generic, NFData) - -instance Parsable BinfoBlockId where - parseParam t = - hex <> igr - where - hex = case hexToBlockHash (TL.toStrict t) of - Nothing -> Left "could not decode txid" - Just h -> Right $ BinfoBlockHash h - igr = BinfoBlockIndex <$> parseParam t - -data BinfoTxId - = BinfoTxIdHash !TxHash - | BinfoTxIdIndex !Word64 - deriving (Eq, Show, Read, Generic, NFData) - -encodeBinfoTxId :: Bool -> TxHash -> BinfoTxId -encodeBinfoTxId False = BinfoTxIdHash -encodeBinfoTxId True = BinfoTxIdIndex . toIntTxId - -instance Parsable BinfoTxId where - parseParam t = - hex <> igr - where - hex = - case hexToTxHash (TL.toStrict t) of - Nothing -> Left "could not decode txid" - Just h -> Right $ BinfoTxIdHash h - igr = BinfoTxIdIndex <$> parseParam t - -instance ToJSON BinfoTxId where - toJSON (BinfoTxIdHash h) = toJSON h - toJSON (BinfoTxIdIndex i) = toJSON i - toEncoding (BinfoTxIdHash h) = toEncoding h - toEncoding (BinfoTxIdIndex i) = toEncoding i - -instance FromJSON BinfoTxId where - parseJSON v = - BinfoTxIdHash <$> parseJSON v - <|> BinfoTxIdIndex <$> parseJSON v - -data BinfoFilter - = BinfoFilterAll - | BinfoFilterSent - | BinfoFilterReceived - | BinfoFilterMoved - | BinfoFilterConfirmed - | BinfoFilterMempool - deriving (Eq, Show, Generic, NFData) - -instance Parsable BinfoFilter where - parseParam t = - parseParam t >>= \case - (0 :: Int) -> return BinfoFilterAll - 1 -> return BinfoFilterSent - 2 -> return BinfoFilterReceived - 3 -> return BinfoFilterMoved - 5 -> return BinfoFilterConfirmed - 6 -> return BinfoFilterAll - 7 -> return BinfoFilterMempool - _ -> Left "could not parse filter parameter" - -data BinfoMultiAddr = BinfoMultiAddr - { getBinfoMultiAddrAddresses :: ![BinfoBalance], - getBinfoMultiAddrWallet :: !BinfoWallet, - getBinfoMultiAddrTxs :: ![BinfoTx], - getBinfoMultiAddrInfo :: !BinfoInfo, - getBinfoMultiAddrRecommendFee :: !Bool, - getBinfoMultiAddrCashAddr :: !Bool - } - deriving (Eq, Show, Generic, NFData) - -binfoMultiAddrToJSON :: Network -> BinfoMultiAddr -> Value -binfoMultiAddrToJSON net' BinfoMultiAddr {..} = - A.object $ - [ "addresses" .= map (binfoBalanceToJSON net) getBinfoMultiAddrAddresses, - "wallet" .= getBinfoMultiAddrWallet, - "txs" .= map (binfoTxToJSON net) getBinfoMultiAddrTxs, - "info" .= getBinfoMultiAddrInfo, - "recommend_include_fee" .= getBinfoMultiAddrRecommendFee - ] - ++ ["cash_addr" .= True | getBinfoMultiAddrCashAddr] - where - net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' - -binfoMultiAddrParseJSON :: Network -> Value -> Parser BinfoMultiAddr -binfoMultiAddrParseJSON net = A.withObject "multiaddr" $ \o -> do - getBinfoMultiAddrAddresses <- - mapM (binfoBalanceParseJSON net) =<< o .: "addresses" - getBinfoMultiAddrWallet <- o .: "wallet" - getBinfoMultiAddrTxs <- - mapM (binfoTxParseJSON net) =<< o .: "txs" - getBinfoMultiAddrInfo <- o .: "info" - getBinfoMultiAddrRecommendFee <- o .: "recommend_include_fee" - getBinfoMultiAddrCashAddr <- o .:? "cash_addr" .!= False - return BinfoMultiAddr {..} - -binfoMultiAddrToEncoding :: Network -> BinfoMultiAddr -> Encoding -binfoMultiAddrToEncoding net' BinfoMultiAddr {..} = - AE.pairs - ( "addresses" `AE.pair` as - <> "wallet" .= getBinfoMultiAddrWallet - <> "txs" `AE.pair` ts - <> "info" .= getBinfoMultiAddrInfo - <> "recommend_include_fee" .= getBinfoMultiAddrRecommendFee - <> if getBinfoMultiAddrCashAddr then "cash_addr" .= True else mempty - ) - where - as = AE.list (binfoBalanceToEncoding net) getBinfoMultiAddrAddresses - ts = AE.list (binfoTxToEncoding net) getBinfoMultiAddrTxs - net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' - -data BinfoRawAddr = BinfoRawAddr - { binfoRawAddr :: !BinfoAddr, - binfoRawBalance :: !Word64, - binfoRawTxCount :: !Word64, - binfoRawUnredeemed :: !Word64, - binfoRawReceived :: !Word64, - binfoRawSent :: !Int64, - binfoRawTxs :: ![BinfoTx] - } - deriving (Eq, Show, Generic, NFData) - -binfoRawAddrToJSON :: Network -> BinfoRawAddr -> Value -binfoRawAddrToJSON net BinfoRawAddr {..} = - A.object - [ "hash160" .= h160, - "address" .= address, - "n_tx" .= binfoRawTxCount, - "n_unredeemed" .= binfoRawUnredeemed, - "total_received" .= binfoRawReceived, - "total_sent" .= binfoRawSent, - "final_balance" .= binfoRawBalance, - "txs" .= map (binfoTxToJSON net) binfoRawTxs - ] - where - address = case binfoRawAddr of - BinfoAddr a -> addrToJSON net a - BinfoXpub x -> xPubToJSON net x - h160 = - encodeHex . runPutS . serialize - <$> case binfoRawAddr of - BinfoAddr a -> case a of - PubKeyAddress h -> Just h - ScriptAddress h -> Just h - WitnessPubKeyAddress h -> Just h - _ -> Nothing - _ -> Nothing - -binfoRawAddrToEncoding :: Network -> BinfoRawAddr -> Encoding -binfoRawAddrToEncoding net BinfoRawAddr {..} = - AE.pairs $ - "hash160" .= h160 - <> "address" `AE.pair` address - <> "n_tx" .= binfoRawTxCount - <> "n_unredeemed" .= binfoRawUnredeemed - <> "total_received" .= binfoRawReceived - <> "total_sent" .= binfoRawSent - <> "final_balance" .= binfoRawBalance - <> "txs" `AE.pair` AE.list (binfoTxToEncoding net) binfoRawTxs - where - address = case binfoRawAddr of - BinfoAddr a -> addrToEncoding net a - BinfoXpub x -> xPubToEncoding net x - h160 = - encodeHex . runPutS . serialize - <$> case binfoRawAddr of - BinfoAddr a -> case a of - PubKeyAddress h -> Just h - ScriptAddress h -> Just h - WitnessPubKeyAddress h -> Just h - _ -> Nothing - _ -> Nothing - -binfoRawAddrParseJSON :: Network -> Value -> Parser BinfoRawAddr -binfoRawAddrParseJSON net = A.withObject "balancetxs" $ \o -> do - addr <- o .: "address" - binfoRawAddr <- - BinfoAddr <$> addrFromJSON net addr - <|> BinfoXpub <$> xPubFromJSON net addr - binfoRawBalance <- o .: "final_balance" - binfoRawUnredeemed <- o .: "n_unredeemed" - binfoRawTxCount <- o .: "n_tx" - binfoRawReceived <- o .: "total_received" - binfoRawSent <- o .: "total_sent" - binfoRawTxs <- mapM (binfoTxParseJSON net) =<< o .: "txs" - return BinfoRawAddr {..} - -data BinfoShortBal = BinfoShortBal - { binfoShortBalFinal :: !Word64, - binfoShortBalTxCount :: !Word64, - binfoShortBalReceived :: !Word64 - } - deriving (Eq, Show, Read, Generic, NFData) - -instance ToJSON BinfoShortBal where - toJSON BinfoShortBal {..} = - A.object - [ "final_balance" .= binfoShortBalFinal, - "n_tx" .= binfoShortBalTxCount, - "total_received" .= binfoShortBalReceived - ] - toEncoding BinfoShortBal {..} = - AE.pairs $ - "final_balance" .= binfoShortBalFinal - <> "n_tx" .= binfoShortBalTxCount - <> "total_received" .= binfoShortBalReceived - -instance FromJSON BinfoShortBal where - parseJSON = A.withObject "short_balance" $ \o -> do - binfoShortBalFinal <- o .: "final_balance" - binfoShortBalTxCount <- o .: "n_tx" - binfoShortBalReceived <- o .: "total_received" - return BinfoShortBal {..} - -data BinfoBalance - = BinfoAddrBalance - { getBinfoAddress :: !Address, - getBinfoAddrTxCount :: !Word64, - getBinfoAddrReceived :: !Word64, - getBinfoAddrSent :: !Word64, - getBinfoAddrBalance :: !Word64 - } - | BinfoXPubBalance - { getBinfoXPubKey :: !XPubKey, - getBinfoAddrTxCount :: !Word64, - getBinfoAddrReceived :: !Word64, - getBinfoAddrSent :: !Word64, - getBinfoAddrBalance :: !Word64, - getBinfoXPubAccountIndex :: !Word32, - getBinfoXPubChangeIndex :: !Word32 - } - deriving (Eq, Show, Generic, NFData) - -binfoBalanceToJSON :: Network -> BinfoBalance -> Value -binfoBalanceToJSON net BinfoAddrBalance {..} = - A.object - [ "address" .= addrToJSON net getBinfoAddress, - "final_balance" .= getBinfoAddrBalance, - "n_tx" .= getBinfoAddrTxCount, - "total_received" .= getBinfoAddrReceived, - "total_sent" .= getBinfoAddrSent - ] -binfoBalanceToJSON net BinfoXPubBalance {..} = - A.object - [ "address" .= xPubToJSON net getBinfoXPubKey, - "change_index" .= getBinfoXPubChangeIndex, - "account_index" .= getBinfoXPubAccountIndex, - "final_balance" .= getBinfoAddrBalance, - "n_tx" .= getBinfoAddrTxCount, - "total_received" .= getBinfoAddrReceived, - "total_sent" .= getBinfoAddrSent - ] - -binfoBalanceParseJSON :: Network -> Value -> Parser BinfoBalance -binfoBalanceParseJSON net = A.withObject "address" $ \o -> x o <|> a o - where - x o = do - getBinfoXPubKey <- xPubFromJSON net =<< o .: "address" - getBinfoXPubChangeIndex <- o .: "change_index" - getBinfoXPubAccountIndex <- o .: "account_index" - getBinfoAddrBalance <- o .: "final_balance" - getBinfoAddrTxCount <- o .: "n_tx" - getBinfoAddrReceived <- o .: "total_received" - getBinfoAddrSent <- o .: "total_sent" - return BinfoXPubBalance {..} - a o = do - getBinfoAddress <- addrFromJSON net =<< o .: "address" - getBinfoAddrBalance <- o .: "final_balance" - getBinfoAddrTxCount <- o .: "n_tx" - getBinfoAddrReceived <- o .: "total_received" - getBinfoAddrSent <- o .: "total_sent" - return BinfoAddrBalance {..} - -binfoBalanceToEncoding :: Network -> BinfoBalance -> Encoding -binfoBalanceToEncoding net BinfoAddrBalance {..} = - AE.pairs - ( "address" `AE.pair` addrToEncoding net getBinfoAddress - <> "final_balance" .= getBinfoAddrBalance - <> "n_tx" .= getBinfoAddrTxCount - <> "total_received" .= getBinfoAddrReceived - <> "total_sent" .= getBinfoAddrSent - ) -binfoBalanceToEncoding net BinfoXPubBalance {..} = - AE.pairs - ( "address" `AE.pair` xPubToEncoding net getBinfoXPubKey - <> "change_index" .= getBinfoXPubChangeIndex - <> "account_index" .= getBinfoXPubAccountIndex - <> "final_balance" .= getBinfoAddrBalance - <> "n_tx" .= getBinfoAddrTxCount - <> "total_received" .= getBinfoAddrReceived - <> "total_sent" .= getBinfoAddrSent - ) - -data BinfoWallet = BinfoWallet - { getBinfoWalletBalance :: !Word64, - getBinfoWalletTxCount :: !Word64, - getBinfoWalletFilteredCount :: !Word64, - getBinfoWalletTotalReceived :: !Word64, - getBinfoWalletTotalSent :: !Word64 - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoWallet where - toJSON BinfoWallet {..} = - A.object - [ "final_balance" .= getBinfoWalletBalance, - "n_tx" .= getBinfoWalletTxCount, - "n_tx_filtered" .= getBinfoWalletFilteredCount, - "total_received" .= getBinfoWalletTotalReceived, - "total_sent" .= getBinfoWalletTotalSent - ] - toEncoding BinfoWallet {..} = - AE.pairs - ( "final_balance" .= getBinfoWalletBalance - <> "n_tx" .= getBinfoWalletTxCount - <> "n_tx_filtered" .= getBinfoWalletFilteredCount - <> "total_received" .= getBinfoWalletTotalReceived - <> "total_sent" .= getBinfoWalletTotalSent - ) - -instance FromJSON BinfoWallet where - parseJSON = A.withObject "wallet" $ \o -> do - getBinfoWalletBalance <- o .: "final_balance" - getBinfoWalletTxCount <- o .: "n_tx" - getBinfoWalletFilteredCount <- o .: "n_tx_filtered" - getBinfoWalletTotalReceived <- o .: "total_received" - getBinfoWalletTotalSent <- o .: "total_sent" - return BinfoWallet {..} - -binfoHexValue :: Word64 -> Text -binfoHexValue w64 = - let bs = BS.dropWhile (== 0x00) (runPutS (serialize w64)) - in encodeHex $ - if BS.null bs || BS.head bs `testBit` 7 - then BS.cons 0x00 bs - else bs - -data BinfoUnspent = BinfoUnspent - { getBinfoUnspentHash :: !TxHash, - getBinfoUnspentOutputIndex :: !Word32, - getBinfoUnspentScript :: !ByteString, - getBinfoUnspentValue :: !Word64, - getBinfoUnspentConfirmations :: !Int32, - getBinfoUnspentTxIndex :: !BinfoTxId, - getBinfoUnspentXPub :: !(Maybe BinfoXPubPath) - } - deriving (Eq, Show, Generic, NFData) - -binfoUnspentToJSON :: Network -> BinfoUnspent -> Value -binfoUnspentToJSON net BinfoUnspent {..} = - A.object $ - [ "tx_hash_big_endian" .= getBinfoUnspentHash, - "tx_hash" - .= encodeHex (runPutS (serialize (getTxHash getBinfoUnspentHash))), - "tx_output_n" .= getBinfoUnspentOutputIndex, - "script" .= encodeHex getBinfoUnspentScript, - "value" .= getBinfoUnspentValue, - "value_hex" .= binfoHexValue getBinfoUnspentValue, - "confirmations" .= getBinfoUnspentConfirmations, - "tx_index" .= getBinfoUnspentTxIndex - ] - <> [ "xpub" .= binfoXPubPathToJSON net x - | x <- maybeToList getBinfoUnspentXPub - ] - -binfoUnspentToEncoding :: Network -> BinfoUnspent -> Encoding -binfoUnspentToEncoding net BinfoUnspent {..} = - AE.pairs $ - "tx_hash_big_endian" .= getBinfoUnspentHash - <> "tx_hash" - .= encodeHex (runPutS (serialize (getTxHash getBinfoUnspentHash))) - <> "tx_output_n" - .= getBinfoUnspentOutputIndex - <> "script" - .= encodeHex getBinfoUnspentScript - <> "value" - .= getBinfoUnspentValue - <> "value_hex" - .= binfoHexValue getBinfoUnspentValue - <> "confirmations" - .= getBinfoUnspentConfirmations - <> "tx_index" - .= getBinfoUnspentTxIndex - <> maybe - mempty - (("xpub" `AE.pair`) . binfoXPubPathToEncoding net) - getBinfoUnspentXPub - -binfoUnspentParseJSON :: Network -> Value -> Parser BinfoUnspent -binfoUnspentParseJSON net = A.withObject "unspent" $ \o -> do - getBinfoUnspentHash <- o .: "tx_hash_big_endian" - getBinfoUnspentOutputIndex <- o .: "tx_output_n" - getBinfoUnspentScript <- maybe mzero return . decodeHex =<< o .: "script" - getBinfoUnspentValue <- o .: "value" - getBinfoUnspentConfirmations <- o .: "confirmations" - getBinfoUnspentTxIndex <- o .: "tx_index" - getBinfoUnspentXPub <- mapM (binfoXPubPathParseJSON net) =<< o .:? "xpub" - return BinfoUnspent {..} - -newtype BinfoUnspents = BinfoUnspents [BinfoUnspent] - deriving (Eq, Show, Generic, NFData) - -binfoUnspentsToJSON :: Network -> BinfoUnspents -> Value -binfoUnspentsToJSON net (BinfoUnspents us) = - A.object - [ "notice" .= T.empty, - "unspent_outputs" .= map (binfoUnspentToJSON net) us - ] - -binfoUnspentsToEncoding :: Network -> BinfoUnspents -> Encoding -binfoUnspentsToEncoding net (BinfoUnspents us) = - AE.pairs $ - "notice" .= T.empty - <> "unspent_outputs" `AE.pair` AE.list (binfoUnspentToEncoding net) us - -binfoUnspentsParseJSON :: Network -> Value -> Parser BinfoUnspents -binfoUnspentsParseJSON net = A.withObject "unspents" $ \o -> do - us <- mapM (binfoUnspentParseJSON net) =<< o .: "unspent_outputs" - return (BinfoUnspents us) - -binfoBlocksToJSON :: Network -> [BinfoBlock] -> Value -binfoBlocksToJSON net blocks = - A.object ["blocks" .= map (binfoBlockToJSON net) blocks] - -binfoBlocksToEncoding :: Network -> [BinfoBlock] -> Encoding -binfoBlocksToEncoding net blocks = - AE.pairs $ "blocks" `AE.pair` AE.list (binfoBlockToEncoding net) blocks - -binfoBlocksParseJSON :: Network -> Value -> Parser [BinfoBlock] -binfoBlocksParseJSON net = - A.withObject "blocks" $ \o -> - mapM (binfoBlockParseJSON net) =<< o .: "blocks" - -toBinfoBlock :: BlockData -> [BinfoTx] -> [BlockHash] -> BinfoBlock -toBinfoBlock BlockData {..} txs next_blocks = - BinfoBlock - { getBinfoBlockHash = headerHash blockDataHeader, - getBinfoBlockVer = blockVersion blockDataHeader, - getBinfoPrevBlock = prevBlock blockDataHeader, - getBinfoMerkleRoot = merkleRoot blockDataHeader, - getBinfoBlockTime = blockTimestamp blockDataHeader, - getBinfoBlockBits = blockBits blockDataHeader, - getBinfoNextBlock = next_blocks, - getBinfoBlockFee = blockDataFees, - getBinfoBlockNonce = bhNonce blockDataHeader, - getBinfoBlockTxCount = fromIntegral (length txs), - getBinfoBlockSize = blockDataSize, - getBinfoBlockIndex = blockDataHeight, - getBinfoBlockMain = blockDataMainChain, - getBinfoBlockHeight = blockDataHeight, - getBinfoBlockWeight = blockDataWeight, - getBinfoBlockTx = txs - } - -data BinfoBlock = BinfoBlock - { getBinfoBlockHash :: !BlockHash, - getBinfoBlockVer :: !Word32, - getBinfoPrevBlock :: !BlockHash, - getBinfoMerkleRoot :: !Hash256, - getBinfoBlockTime :: !Word32, - getBinfoBlockBits :: !Word32, - getBinfoNextBlock :: ![BlockHash], - getBinfoBlockFee :: !Word64, - getBinfoBlockNonce :: !Word32, - getBinfoBlockTxCount :: !Word32, - getBinfoBlockSize :: !Word32, - getBinfoBlockIndex :: !Word32, - getBinfoBlockMain :: !Bool, - getBinfoBlockHeight :: !Word32, - getBinfoBlockWeight :: !Word32, - getBinfoBlockTx :: ![BinfoTx] - } - deriving (Eq, Show, Generic, NFData) - -binfoBlockToJSON :: Network -> BinfoBlock -> Value -binfoBlockToJSON net BinfoBlock {..} = - A.object - [ "hash" .= getBinfoBlockHash, - "ver" .= getBinfoBlockVer, - "prev_block" .= getBinfoPrevBlock, - "mrkl_root" .= TxHash getBinfoMerkleRoot, - "time" .= getBinfoBlockTime, - "bits" .= getBinfoBlockBits, - "next_block" .= getBinfoNextBlock, - "fee" .= getBinfoBlockFee, - "nonce" .= getBinfoBlockNonce, - "n_tx" .= getBinfoBlockTxCount, - "size" .= getBinfoBlockSize, - "block_index" .= getBinfoBlockIndex, - "main_chain" .= getBinfoBlockMain, - "height" .= getBinfoBlockHeight, - "weight" .= getBinfoBlockWeight, - "tx" .= map (binfoTxToJSON net) getBinfoBlockTx - ] - -binfoBlockToEncoding :: Network -> BinfoBlock -> Encoding -binfoBlockToEncoding net BinfoBlock {..} = - AE.pairs $ - "hash" .= getBinfoBlockHash - <> "ver" .= getBinfoBlockVer - <> "prev_block" .= getBinfoPrevBlock - <> "mrkl_root" .= TxHash getBinfoMerkleRoot - <> "time" .= getBinfoBlockTime - <> "bits" .= getBinfoBlockBits - <> "next_block" .= getBinfoNextBlock - <> "fee" .= getBinfoBlockFee - <> "nonce" .= getBinfoBlockNonce - <> "n_tx" .= getBinfoBlockTxCount - <> "size" .= getBinfoBlockSize - <> "block_index" .= getBinfoBlockIndex - <> "main_chain" .= getBinfoBlockMain - <> "height" .= getBinfoBlockHeight - <> "weight" .= getBinfoBlockWeight - <> "tx" `AE.pair` AE.list (binfoTxToEncoding net) getBinfoBlockTx - -binfoBlockParseJSON :: Network -> Value -> Parser BinfoBlock -binfoBlockParseJSON net = A.withObject "block" $ \o -> do - getBinfoBlockHash <- o .: "hash" - getBinfoBlockVer <- o .: "ver" - getBinfoPrevBlock <- o .: "prev_block" - getBinfoMerkleRoot <- getTxHash <$> o .: "mrkl_root" - getBinfoBlockTime <- o .: "time" - getBinfoBlockBits <- o .: "bits" - getBinfoNextBlock <- o .: "next_block" - getBinfoBlockFee <- o .: "fee" - getBinfoBlockNonce <- o .: "nonce" - getBinfoBlockTxCount <- o .: "n_tx" - getBinfoBlockSize <- o .: "size" - getBinfoBlockIndex <- o .: "block_index" - getBinfoBlockMain <- o .: "main_chain" - getBinfoBlockHeight <- o .: "height" - getBinfoBlockWeight <- o .: "weight" - getBinfoBlockTx <- o .: "tx" >>= mapM (binfoTxParseJSON net) - return BinfoBlock {..} - -data BinfoTx = BinfoTx - { getBinfoTxHash :: !TxHash, - getBinfoTxVer :: !Word32, - getBinfoTxVinSz :: !Word32, - getBinfoTxVoutSz :: !Word32, - getBinfoTxSize :: !Word32, - getBinfoTxWeight :: !Word32, - getBinfoTxFee :: !Word64, - getBinfoTxRelayedBy :: !ByteString, - getBinfoTxLockTime :: !Word32, - getBinfoTxIndex :: !BinfoTxId, - getBinfoTxDoubleSpend :: !Bool, - getBinfoTxRBF :: !Bool, - getBinfoTxResultBal :: !(Maybe (Int64, Int64)), - getBinfoTxTime :: !Word64, - getBinfoTxBlockIndex :: !(Maybe Word32), - getBinfoTxBlockHeight :: !(Maybe Word32), - getBinfoTxInputs :: [BinfoTxInput], - getBinfoTxOutputs :: [BinfoTxOutput] - } - deriving (Eq, Show, Generic, NFData) - -binfoTxToJSON :: Network -> BinfoTx -> Value -binfoTxToJSON net BinfoTx {..} = - A.object $ - [ "hash" .= getBinfoTxHash, - "ver" .= getBinfoTxVer, - "vin_sz" .= getBinfoTxVinSz, - "vout_sz" .= getBinfoTxVoutSz, - "size" .= getBinfoTxSize, - "weight" .= getBinfoTxWeight, - "fee" .= getBinfoTxFee, - "relayed_by" .= TE.decodeUtf8 getBinfoTxRelayedBy, - "lock_time" .= getBinfoTxLockTime, - "tx_index" .= getBinfoTxIndex, - "double_spend" .= getBinfoTxDoubleSpend, - "time" .= getBinfoTxTime, - "block_index" .= getBinfoTxBlockIndex, - "block_height" .= getBinfoTxBlockHeight, - "inputs" .= map (binfoTxInputToJSON net) getBinfoTxInputs, - "out" .= map (binfoTxOutputToJSON net) getBinfoTxOutputs - ] - ++ bal - ++ rbf - where - bal = - case getBinfoTxResultBal of - Nothing -> [] - Just (res, bal') -> ["result" .= res, "balance" .= bal'] - rbf = ["rbf" .= True | getBinfoTxRBF] - -binfoTxToEncoding :: Network -> BinfoTx -> Encoding -binfoTxToEncoding net BinfoTx {..} = - AE.pairs $ - "hash" .= getBinfoTxHash - <> "ver" .= getBinfoTxVer - <> "vin_sz" .= getBinfoTxVinSz - <> "vout_sz" .= getBinfoTxVoutSz - <> "size" .= getBinfoTxSize - <> "weight" .= getBinfoTxWeight - <> "fee" .= getBinfoTxFee - <> "relayed_by" .= TE.decodeUtf8 getBinfoTxRelayedBy - <> "lock_time" .= getBinfoTxLockTime - <> "tx_index" .= getBinfoTxIndex - <> "double_spend" .= getBinfoTxDoubleSpend - <> "time" .= getBinfoTxTime - <> "block_index" .= getBinfoTxBlockIndex - <> "block_height" .= getBinfoTxBlockHeight - <> "inputs" `AE.pair` AE.list (binfoTxInputToEncoding net) getBinfoTxInputs - <> "out" `AE.pair` AE.list (binfoTxOutputToEncoding net) getBinfoTxOutputs - <> bal - <> rbf - where - bal = - case getBinfoTxResultBal of - Nothing -> mempty - Just (res, bal') -> "result" .= res <> "balance" .= bal' - rbf = if getBinfoTxRBF then "rbf" .= True else mempty - -binfoTxParseJSON :: Network -> Value -> Parser BinfoTx -binfoTxParseJSON net = A.withObject "tx" $ \o -> do - getBinfoTxHash <- o .: "hash" - getBinfoTxVer <- o .: "ver" - getBinfoTxVinSz <- o .: "vin_sz" - getBinfoTxVoutSz <- o .: "vout_sz" - getBinfoTxSize <- o .: "size" - getBinfoTxWeight <- o .: "weight" - getBinfoTxFee <- o .: "fee" - getBinfoTxRelayedBy <- TE.encodeUtf8 <$> o .: "relayed_by" - getBinfoTxLockTime <- o .: "lock_time" - getBinfoTxIndex <- o .: "tx_index" - getBinfoTxDoubleSpend <- o .: "double_spend" - getBinfoTxTime <- o .: "time" - getBinfoTxBlockIndex <- o .: "block_index" - getBinfoTxBlockHeight <- o .: "block_height" - getBinfoTxInputs <- o .: "inputs" >>= mapM (binfoTxInputParseJSON net) - getBinfoTxOutputs <- o .: "out" >>= mapM (binfoTxOutputParseJSON net) - getBinfoTxRBF <- o .:? "rbf" .!= False - res <- o .:? "result" - bal <- o .:? "balance" - let getBinfoTxResultBal = (,) <$> res <*> bal - return BinfoTx {..} - -data BinfoTxInput = BinfoTxInput - { getBinfoTxInputSeq :: !Word32, - getBinfoTxInputWitness :: !ByteString, - getBinfoTxInputScript :: !ByteString, - getBinfoTxInputIndex :: !Word32, - getBinfoTxInputPrevOut :: !BinfoTxOutput - } - deriving (Eq, Show, Generic, NFData) - -binfoTxInputToJSON :: Network -> BinfoTxInput -> Value -binfoTxInputToJSON net BinfoTxInput {..} = - A.object - [ "sequence" .= getBinfoTxInputSeq, - "witness" .= encodeHex getBinfoTxInputWitness, - "script" .= encodeHex getBinfoTxInputScript, - "index" .= getBinfoTxInputIndex, - "prev_out" .= binfoTxOutputToJSON net getBinfoTxInputPrevOut - ] - -binfoTxInputToEncoding :: Network -> BinfoTxInput -> Encoding -binfoTxInputToEncoding net BinfoTxInput {..} = - AE.pairs - ( "sequence" .= getBinfoTxInputSeq - <> "witness" .= encodeHex getBinfoTxInputWitness - <> "script" .= encodeHex getBinfoTxInputScript - <> "index" .= getBinfoTxInputIndex - <> "prev_out" .= binfoTxOutputToJSON net getBinfoTxInputPrevOut - ) - -binfoTxInputParseJSON :: Network -> Value -> Parser BinfoTxInput -binfoTxInputParseJSON net = A.withObject "txin" $ \o -> do - getBinfoTxInputSeq <- o .: "sequence" - getBinfoTxInputWitness <- - maybe mzero return . decodeHex - =<< o .: "witness" - getBinfoTxInputScript <- - maybe mzero return . decodeHex - =<< o .: "script" - getBinfoTxInputIndex <- o .: "index" - getBinfoTxInputPrevOut <- - o .: "prev_out" - >>= binfoTxOutputParseJSON net - return BinfoTxInput {..} - -data BinfoTxOutput = BinfoTxOutput - { getBinfoTxOutputType :: !Int, - getBinfoTxOutputSpent :: !Bool, - getBinfoTxOutputValue :: !Word64, - getBinfoTxOutputIndex :: !Word32, - getBinfoTxOutputTxIndex :: !BinfoTxId, - getBinfoTxOutputScript :: !ByteString, - getBinfoTxOutputSpenders :: ![BinfoSpender], - getBinfoTxOutputAddress :: !(Maybe Address), - getBinfoTxOutputXPub :: !(Maybe BinfoXPubPath) - } - deriving (Eq, Show, Generic, NFData) - -binfoTxOutputToJSON :: Network -> BinfoTxOutput -> Value -binfoTxOutputToJSON net BinfoTxOutput {..} = - A.object $ - [ "type" .= getBinfoTxOutputType, - "spent" .= getBinfoTxOutputSpent, - "value" .= getBinfoTxOutputValue, - "spending_outpoints" .= getBinfoTxOutputSpenders, - "n" .= getBinfoTxOutputIndex, - "tx_index" .= getBinfoTxOutputTxIndex, - "script" .= encodeHex getBinfoTxOutputScript - ] - <> [ "addr" .= addrToJSON net a - | a <- maybeToList getBinfoTxOutputAddress - ] - <> [ "xpub" .= binfoXPubPathToJSON net x - | x <- maybeToList getBinfoTxOutputXPub - ] - -binfoTxOutputToEncoding :: Network -> BinfoTxOutput -> Encoding -binfoTxOutputToEncoding net BinfoTxOutput {..} = - AE.pairs $ - mconcat $ - [ "type" .= getBinfoTxOutputType, - "spent" .= getBinfoTxOutputSpent, - "value" .= getBinfoTxOutputValue, - "spending_outpoints" .= getBinfoTxOutputSpenders, - "n" .= getBinfoTxOutputIndex, - "tx_index" .= getBinfoTxOutputTxIndex, - "script" .= encodeHex getBinfoTxOutputScript - ] - <> [ "addr" .= addrToJSON net a - | a <- maybeToList getBinfoTxOutputAddress - ] - <> [ "xpub" .= binfoXPubPathToJSON net x - | x <- maybeToList getBinfoTxOutputXPub - ] - -binfoTxOutputParseJSON :: Network -> Value -> Parser BinfoTxOutput -binfoTxOutputParseJSON net = A.withObject "txout" $ \o -> do - getBinfoTxOutputType <- o .: "type" - getBinfoTxOutputSpent <- o .: "spent" - getBinfoTxOutputValue <- o .: "value" - getBinfoTxOutputSpenders <- o .: "spending_outpoints" - getBinfoTxOutputIndex <- o .: "n" - getBinfoTxOutputTxIndex <- o .: "tx_index" - getBinfoTxOutputScript <- maybe mzero return . decodeHex =<< o .: "script" - getBinfoTxOutputAddress <- o .:? "addr" >>= mapM (addrFromJSON net) - getBinfoTxOutputXPub <- o .:? "xpub" >>= mapM (binfoXPubPathParseJSON net) - return BinfoTxOutput {..} - -data BinfoSpender = BinfoSpender - { getBinfoSpenderTxIndex :: !BinfoTxId, - getBinfoSpenderIndex :: !Word32 - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoSpender where - toJSON BinfoSpender {..} = - A.object - [ "tx_index" .= getBinfoSpenderTxIndex, - "n" .= getBinfoSpenderIndex - ] - toEncoding BinfoSpender {..} = - AE.pairs - ( "tx_index" .= getBinfoSpenderTxIndex - <> "n" .= getBinfoSpenderIndex - ) - -instance FromJSON BinfoSpender where - parseJSON = A.withObject "spender" $ \o -> do - getBinfoSpenderTxIndex <- o .: "tx_index" - getBinfoSpenderIndex <- o .: "n" - return BinfoSpender {..} - -data BinfoXPubPath = BinfoXPubPath - { getBinfoXPubPathKey :: !XPubKey, - getBinfoXPubPathDeriv :: !SoftPath - } - deriving (Eq, Show, Generic, NFData) - -instance Ord BinfoXPubPath where - compare = compare `on` f - where - f b = - ( xPubParent (getBinfoXPubPathKey b), - getBinfoXPubPathDeriv b - ) - -binfoXPubPathToJSON :: Network -> BinfoXPubPath -> Value -binfoXPubPathToJSON net BinfoXPubPath {..} = - A.object - [ "m" .= xPubToJSON net getBinfoXPubPathKey, - "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) - ] - -binfoXPubPathToEncoding :: Network -> BinfoXPubPath -> Encoding -binfoXPubPathToEncoding net BinfoXPubPath {..} = - AE.pairs $ - "m" `AE.pair` xPubToEncoding net getBinfoXPubPathKey - <> "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) - -binfoXPubPathParseJSON :: Network -> Value -> Parser BinfoXPubPath -binfoXPubPathParseJSON net = A.withObject "xpub" $ \o -> do - getBinfoXPubPathKey <- o .: "m" >>= xPubFromJSON net - getBinfoXPubPathDeriv <- - fromMaybe "bad xpub path" . parseSoft <$> o .: "path" - return BinfoXPubPath {..} - -data BinfoInfo = BinfoInfo - { getBinfoConnected :: !Word32, - getBinfoConversion :: !Double, - getBinfoLocal :: !BinfoSymbol, - getBinfoBTC :: !BinfoSymbol, - getBinfoLatestBlock :: !BinfoBlockInfo - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoInfo where - toJSON BinfoInfo {..} = - A.object - [ "nconnected" .= getBinfoConnected, - "conversion" .= getBinfoConversion, - "symbol_local" .= getBinfoLocal, - "symbol_btc" .= getBinfoBTC, - "latest_block" .= getBinfoLatestBlock - ] - toEncoding BinfoInfo {..} = - AE.pairs - ( "nconnected" .= getBinfoConnected - <> "conversion" .= getBinfoConversion - <> "symbol_local" .= getBinfoLocal - <> "symbol_btc" .= getBinfoBTC - <> "latest_block" .= getBinfoLatestBlock - ) - -instance FromJSON BinfoInfo where - parseJSON = A.withObject "info" $ \o -> do - getBinfoConnected <- o .: "nconnected" - getBinfoConversion <- o .: "conversion" - getBinfoLocal <- o .: "symbol_local" - getBinfoBTC <- o .: "symbol_btc" - getBinfoLatestBlock <- o .: "latest_block" - return BinfoInfo {..} - -data BinfoBlockInfo = BinfoBlockInfo - { getBinfoBlockInfoHash :: !BlockHash, - getBinfoBlockInfoHeight :: !BlockHeight, - getBinfoBlockInfoTime :: !Word32, - getBinfoBlockInfoIndex :: !BlockHeight - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoBlockInfo where - toJSON BinfoBlockInfo {..} = - A.object - [ "hash" .= getBinfoBlockInfoHash, - "height" .= getBinfoBlockInfoHeight, - "time" .= getBinfoBlockInfoTime, - "block_index" .= getBinfoBlockInfoIndex - ] - toEncoding BinfoBlockInfo {..} = - AE.pairs - ( "hash" .= getBinfoBlockInfoHash - <> "height" .= getBinfoBlockInfoHeight - <> "time" .= getBinfoBlockInfoTime - <> "block_index" .= getBinfoBlockInfoIndex - ) - -instance FromJSON BinfoBlockInfo where - parseJSON = A.withObject "block_info" $ \o -> do - getBinfoBlockInfoHash <- o .: "hash" - getBinfoBlockInfoHeight <- o .: "height" - getBinfoBlockInfoTime <- o .: "time" - getBinfoBlockInfoIndex <- o .: "block_index" - return BinfoBlockInfo {..} - -toBinfoBlockInfo :: BlockData -> BinfoBlockInfo -toBinfoBlockInfo BlockData {..} = - BinfoBlockInfo - { getBinfoBlockInfoHash = headerHash blockDataHeader, - getBinfoBlockInfoHeight = blockDataHeight, - getBinfoBlockInfoTime = blockTimestamp blockDataHeader, - getBinfoBlockInfoIndex = blockDataHeight - } - -data BinfoRate = BinfoRate - { binfoRateTime :: !Word64, - binfoRatePrice :: !Double, - binfoRateVol24 :: !Double - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoRate where - toJSON BinfoRate {..} = - A.object - [ "timestamp" .= binfoRateTime, - "price" .= binfoRatePrice, - "volume24h" .= binfoRateVol24 - ] - -instance FromJSON BinfoRate where - parseJSON = A.withObject "price" $ \o -> do - binfoRateTime <- o .: "timestamp" - binfoRatePrice <- o .: "price" - binfoRateVol24 <- o .: "volume24h" - return BinfoRate {..} - -data BinfoHistory = BinfoHistory - { binfoHistoryDate :: !Text, - binfoHistoryTime :: !Text, - binfoHistoryType :: !Text, - binfoHistoryAmount :: !Double, - binfoHistoryValueThen :: !Double, - binfoHistoryValueNow :: !Double, - binfoHistoryExchangeRateThen :: !Double, - binfoHistoryTx :: !TxHash, - binfoHistoryFee :: !Double - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoHistory where - toJSON BinfoHistory {..} = - A.object - [ "date" .= binfoHistoryDate, - "time" .= binfoHistoryTime, - "type" .= binfoHistoryType, - "amount" .= binfoHistoryAmount, - "value_then" .= binfoHistoryValueThen, - "value_now" .= binfoHistoryValueNow, - "exchange_rate_then" .= binfoHistoryExchangeRateThen, - "tx" .= binfoHistoryTx, - "fee" .= binfoHistoryFee - ] - -instance FromJSON BinfoHistory where - parseJSON = A.withObject "history" $ \o -> do - binfoHistoryDate <- o .: "date" - binfoHistoryTime <- o .: "time" - binfoHistoryType <- o .: "type" - binfoHistoryAmount <- o .: "amount" - binfoHistoryValueThen <- o .: "value_then" - binfoHistoryValueNow <- o .: "value_now" - binfoHistoryExchangeRateThen <- o .: "exchange_rate_then" - binfoHistoryTx <- o .: "tx" - binfoHistoryFee <- o .: "fee" - return BinfoHistory {..} - -toBinfoHistory :: - Int64 -> - Word64 -> - Double -> - Double -> - Word64 -> - TxHash -> - BinfoHistory -toBinfoHistory satoshi timestamp rate_then rate_now fee txhash = - BinfoHistory - { binfoHistoryDate = - T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" t, - binfoHistoryTime = - T.pack $ formatTime defaultTimeLocale "%H:%M:%S GMT %Ez" t, - binfoHistoryType = - if satoshi <= 0 then "sent" else "received", - binfoHistoryAmount = - fromRational v, - binfoHistoryValueThen = - fromRational v1, - binfoHistoryValueNow = - fromRational v2, - binfoHistoryExchangeRateThen = - rate_then, - binfoHistoryTx = - txhash, - binfoHistoryFee = - fromRational f - } - where - t = posixSecondsToUTCTime (realToFrac timestamp) - v = toRational satoshi / (100 * 1000 * 1000) - r1 = toRational rate_then - r2 = toRational rate_now - f = toRational fee / (100 * 1000 * 1000) - v1 = v * r1 - v2 = v * r2 - -newtype BinfoDate = BinfoDate Word64 - deriving (Eq, Show, Read, Generic, NFData) - -instance Parsable BinfoDate where - parseParam t = - maybeToEither "Cannot parse date" - . fmap (BinfoDate . round . utcTimeToPOSIXSeconds) - $ p "%d-%m-%Y" <|> p "%d/%m/%Y" - where - s = TL.unpack t - p fmt = parseTimeM False defaultTimeLocale fmt s - -data BinfoTicker = BinfoTicker - { binfoTicker15m :: !Double, - binfoTickerLast :: !Double, - binfoTickerBuy :: !Double, - binfoTickerSell :: !Double, - binfoTickerSymbol :: !Text - } - deriving (Eq, Show, Generic, NFData) - -instance Default BinfoTicker where - def = - BinfoTicker - { binfoTickerSymbol = "XXX", - binfoTicker15m = 0.0, - binfoTickerLast = 0.0, - binfoTickerBuy = 0.0, - binfoTickerSell = 0.0 - } - -instance ToJSON BinfoTicker where - toJSON BinfoTicker {..} = - A.object - [ "symbol" .= binfoTickerSymbol, - "sell" .= binfoTickerSell, - "buy" .= binfoTickerBuy, - "last" .= binfoTickerLast, - "15m" .= binfoTicker15m - ] - toEncoding BinfoTicker {..} = - AE.pairs $ - "symbol" .= binfoTickerSymbol - <> "sell" .= binfoTickerSell - <> "buy" .= binfoTickerBuy - <> "last" .= binfoTickerLast - <> "15m" .= binfoTicker15m - -instance FromJSON BinfoTicker where - parseJSON = A.withObject "ticker" $ \o -> do - binfoTickerSymbol <- o .: "symbol" - binfoTicker15m <- o .: "15m" - binfoTickerSell <- o .: "sell" - binfoTickerBuy <- o .: "buy" - binfoTickerLast <- o .: "last" - return BinfoTicker {..} - -data BinfoSymbol = BinfoSymbol - { getBinfoSymbolCode :: !Text, - getBinfoSymbolString :: !Text, - getBinfoSymbolName :: !Text, - getBinfoSymbolConversion :: !Double, - getBinfoSymbolAfter :: !Bool, - getBinfoSymbolLocal :: !Bool - } - deriving (Eq, Show, Generic, NFData) - -instance Default BinfoSymbol where - def = - BinfoSymbol - { getBinfoSymbolCode = "XXX", - getBinfoSymbolString = "ยค", - getBinfoSymbolName = "No currency", - getBinfoSymbolConversion = 0.0, - getBinfoSymbolAfter = False, - getBinfoSymbolLocal = True - } - -instance ToJSON BinfoSymbol where - toJSON BinfoSymbol {..} = - A.object - [ "code" .= getBinfoSymbolCode, - "symbol" .= getBinfoSymbolString, - "name" .= getBinfoSymbolName, - "conversion" .= getBinfoSymbolConversion, - "symbolAppearsAfter" .= getBinfoSymbolAfter, - "local" .= getBinfoSymbolLocal - ] - toEncoding BinfoSymbol {..} = - AE.pairs - ( "code" .= getBinfoSymbolCode - <> "symbol" .= getBinfoSymbolString - <> "name" .= getBinfoSymbolName - <> "conversion" .= getBinfoSymbolConversion - <> "symbolAppearsAfter" .= getBinfoSymbolAfter - <> "local" .= getBinfoSymbolLocal - ) - -instance FromJSON BinfoSymbol where - parseJSON = A.withObject "symbol" $ \o -> do - getBinfoSymbolCode <- o .: "code" - getBinfoSymbolString <- o .: "symbol" - getBinfoSymbolName <- o .: "name" - getBinfoSymbolConversion <- o .: "conversion" - getBinfoSymbolAfter <- o .: "symbolAppearsAfter" - getBinfoSymbolLocal <- o .: "local" - return BinfoSymbol {..} - -relevantTxs :: - HashSet Address -> - Bool -> - Transaction -> - HashSet TxHash -relevantTxs addrs prune t@Transaction {..} = - let p a = prune && getTxResult addrs t > 0 && not (HashSet.member a addrs) - f StoreOutput {..} = - case outputSpender of - Nothing -> Nothing - Just Spender {..} -> - case outputAddr of - Nothing -> Nothing - Just a - | p a -> Nothing - | otherwise -> Just spenderHash - outs = mapMaybe f transactionOutputs - g StoreCoinbase {} = Nothing - g StoreInput {inputPoint = OutPoint {..}} = Just outPointHash - ins = mapMaybe g transactionInputs - in HashSet.fromList $ ins <> outs - -toBinfoAddrs :: - HashMap Address Balance -> - HashMap XPubSpec [XPubBal] -> - HashMap XPubSpec Word64 -> - [BinfoBalance] -toBinfoAddrs only_addrs only_xpubs xpub_txs = - xpub_bals <> addr_bals - where - xpub_bal k xs = - let f x = case xPubBalPath x of - [0, _] -> balanceTotalReceived (xPubBal x) - _ -> 0 - g x = balanceAmount (xPubBal x) + balanceZero (xPubBal x) - i m x = case xPubBalPath x of - [m', n] | m == m' -> n + 1 - _ -> 0 - received = sum (map f xs) - bal = fromIntegral (sum (map g xs)) - sent = if bal <= received then received - bal else 0 - count = HashMap.lookupDefault 0 k xpub_txs - ax = foldl max 0 (map (i 0) xs) - cx = foldl max 0 (map (i 1) xs) - in BinfoXPubBalance - { getBinfoXPubKey = xPubSpecKey k, - getBinfoAddrTxCount = count, - getBinfoAddrReceived = received, - getBinfoAddrSent = sent, - getBinfoAddrBalance = bal, - getBinfoXPubAccountIndex = ax, - getBinfoXPubChangeIndex = cx - } - xpub_bals = map (uncurry xpub_bal) (HashMap.toList only_xpubs) - addr_bals = - let f Balance {..} = - let addr = balanceAddress - sent = recv - bal - recv = balanceTotalReceived - tx_count = balanceTxCount - bal = balanceAmount + balanceZero - in BinfoAddrBalance - { getBinfoAddress = addr, - getBinfoAddrTxCount = tx_count, - getBinfoAddrReceived = recv, - getBinfoAddrSent = sent, - getBinfoAddrBalance = bal - } - in map f $ HashMap.elems only_addrs - -toBinfoTxSimple :: - Bool -> - Transaction -> - BinfoTx -toBinfoTxSimple numtxid = - toBinfoTx numtxid HashMap.empty False 0 - -toBinfoTxInputs :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Transaction -> - [BinfoTxInput] -toBinfoTxInputs numtxid abook t = - zipWith f [0 ..] (transactionInputs t) - where - f n i = - BinfoTxInput - { getBinfoTxInputIndex = n, - getBinfoTxInputSeq = inputSequence i, - getBinfoTxInputScript = inputSigScript i, - getBinfoTxInputWitness = wit i, - getBinfoTxInputPrevOut = prev n i - } - wit i = - case inputWitness i of - [] -> BS.empty - ws -> runPutS (put_witness ws) - prev = inputToBinfoTxOutput numtxid abook t - put_witness ws = do - putVarInt (length ws) - mapM_ put_item ws - put_item bs = do - putVarInt (BS.length bs) - putByteString bs - -toBinfoBlockIndex :: Transaction -> Maybe BlockHeight -toBinfoBlockIndex Transaction {transactionDeleted = True} = Nothing -toBinfoBlockIndex Transaction {transactionBlock = MemRef _} = Nothing -toBinfoBlockIndex Transaction {transactionBlock = BlockRef h _} = Just h - -toBinfoTx :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Bool -> - Int64 -> - Transaction -> - BinfoTx -toBinfoTx numtxid abook prune bal t@Transaction {..} = - BinfoTx - { getBinfoTxHash = txHash (transactionData t), - getBinfoTxVer = transactionVersion, - getBinfoTxVinSz = fromIntegral (length transactionInputs), - getBinfoTxVoutSz = fromIntegral (length transactionOutputs), - getBinfoTxSize = transactionSize, - getBinfoTxWeight = transactionWeight, - getBinfoTxFee = transactionFees, - getBinfoTxRelayedBy = "0.0.0.0", - getBinfoTxLockTime = transactionLockTime, - getBinfoTxIndex = - encodeBinfoTxId numtxid (txHash (transactionData t)), - getBinfoTxDoubleSpend = transactionDeleted, - getBinfoTxRBF = transactionRBF, - getBinfoTxTime = transactionTime, - getBinfoTxBlockIndex = toBinfoBlockIndex t, - getBinfoTxBlockHeight = toBinfoBlockIndex t, - getBinfoTxInputs = toBinfoTxInputs numtxid abook t, - getBinfoTxOutputs = outs, - getBinfoTxResultBal = resbal - } - where - simple = HashMap.null abook && bal == 0 - resbal = if simple then Nothing else Just (getTxResult aset t, bal) - aset = HashMap.keysSet abook - outs = - let p = prune && getTxResult aset t > 0 - f = toBinfoTxOutput numtxid abook p t - in catMaybes $ zipWith f [0 ..] transactionOutputs - -getTxResult :: HashSet Address -> Transaction -> Int64 -getTxResult aset Transaction {..} = - let input_sum = sum $ map input_value transactionInputs - input_value StoreCoinbase {} = 0 - input_value StoreInput {..} = - case inputAddress of - Nothing -> 0 - Just a -> - if test_addr a - then negate $ fromIntegral inputAmount - else 0 - test_addr a = HashSet.member a aset - output_sum = sum $ map out_value transactionOutputs - out_value StoreOutput {..} = - case outputAddr of - Nothing -> 0 - Just a -> - if test_addr a - then fromIntegral outputAmount - else 0 - in input_sum + output_sum - -toBinfoTxOutput :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Bool -> - Transaction -> - Word32 -> - StoreOutput -> - Maybe BinfoTxOutput -toBinfoTxOutput numtxid abook prune t n StoreOutput {..} = - let getBinfoTxOutputType = 0 - getBinfoTxOutputSpent = isJust outputSpender - getBinfoTxOutputValue = outputAmount - getBinfoTxOutputIndex = n - getBinfoTxOutputTxIndex = - encodeBinfoTxId numtxid (txHash (transactionData t)) - getBinfoTxOutputScript = outputScript - getBinfoTxOutputSpenders = - maybeToList $ toBinfoSpender numtxid <$> outputSpender - getBinfoTxOutputAddress = outputAddr - getBinfoTxOutputXPub = - outputAddr >>= join . (`HashMap.lookup` abook) - in if prune && isNothing (outputAddr >>= (`HashMap.lookup` abook)) - then Nothing - else Just BinfoTxOutput {..} - -toBinfoSpender :: Bool -> Spender -> BinfoSpender -toBinfoSpender numtxid Spender {..} = - let getBinfoSpenderTxIndex = encodeBinfoTxId numtxid spenderHash - getBinfoSpenderIndex = spenderIndex - in BinfoSpender {..} - -inputToBinfoTxOutput :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Transaction -> - Word32 -> - StoreInput -> - BinfoTxOutput -inputToBinfoTxOutput numtxid abook t n i = - BinfoTxOutput - { getBinfoTxOutputIndex = out_index, - getBinfoTxOutputType = 0, - getBinfoTxOutputSpent = True, - getBinfoTxOutputValue = inputAmount, - getBinfoTxOutputTxIndex = encodeBinfoTxId numtxid out_hash, - getBinfoTxOutputScript = inputPkScript, - getBinfoTxOutputSpenders = [spender], - getBinfoTxOutputAddress = inputAddress, - getBinfoTxOutputXPub = xpub - } - where - inputAmount = - case i of - StoreCoinbase {} -> 0 - StoreInput {..} -> inputAmount - inputPkScript = - case i of - StoreCoinbase {} -> BS.empty - StoreInput {..} -> inputPkScript - inputAddress = - case i of - StoreCoinbase {} -> Nothing - StoreInput {..} -> inputAddress - OutPoint out_hash out_index = inputPoint i - spender = - BinfoSpender - (encodeBinfoTxId numtxid (txHash (transactionData t))) - n - xpub = inputAddress >>= join . (`HashMap.lookup` abook) - -data BinfoAddr - = BinfoAddr !Address - | BinfoXpub !XPubKey - deriving (Eq, Show, Generic, Hashable, NFData) - -parseBinfoAddr :: Network -> Text -> Maybe [BinfoAddr] -parseBinfoAddr _ "" = Just [] -parseBinfoAddr net s = - mapM f $ - filter (not . T.null) $ - concatMap (T.splitOn ",") (T.splitOn "|" s) - where - f x = BinfoAddr <$> textToAddr net x <|> BinfoXpub <$> xPubImport net x - -data BinfoHeader = BinfoHeader - { binfoHeaderHash :: !BlockHash, - binfoHeaderTime :: !Timestamp, - binfoHeaderIndex :: !Word32, - binfoHeaderHeight :: !BlockHeight, - binfoTxIndices :: ![BinfoTxId] - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoHeader where - toJSON BinfoHeader {..} = - A.object - [ "hash" .= binfoHeaderHash, - "time" .= binfoHeaderTime, - "block_index" .= binfoHeaderIndex, - "height" .= binfoHeaderHeight, - "txIndexes" .= binfoTxIndices - ] - -instance FromJSON BinfoHeader where - parseJSON = A.withObject "header" $ \o -> do - binfoHeaderHash <- o .: "hash" - binfoHeaderTime <- o .: "time" - binfoHeaderIndex <- o .: "block_index" - binfoHeaderHeight <- o .: "height" - binfoTxIndices <- o .: "txIndexes" - return BinfoHeader {..} - -newtype BinfoMempool = BinfoMempool {getBinfoMempool :: [BinfoTx]} - deriving (Eq, Show, Generic, NFData) - -binfoMempoolToJSON :: Network -> BinfoMempool -> Value -binfoMempoolToJSON net (BinfoMempool txs) = - A.object ["txs" .= map (binfoTxToJSON net) txs] - -binfoMempoolToEncoding :: Network -> BinfoMempool -> Encoding -binfoMempoolToEncoding net (BinfoMempool txs) = - AE.pairs $ AE.pair "txs" (AE.list (binfoTxToEncoding net) txs) - -binfoMempoolParseJSON :: Network -> Value -> Parser BinfoMempool -binfoMempoolParseJSON net = - A.withObject "mempool" $ \o -> - BinfoMempool <$> (mapM (binfoTxParseJSON net) =<< o .: "txs") - -newtype BinfoBlocks = BinfoBlocks {binfoBlocks :: [BinfoBlockInfo]} - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoBlocks where - toJSON BinfoBlocks {..} = A.object ["blocks" .= binfoBlocks] - -instance FromJSON BinfoBlocks where - parseJSON = A.withObject "blocks" $ \o -> BinfoBlocks <$> o .: "blocks" +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Haskoin.Store.Data + ( -- * Address Balances + Balance (..), + zeroBalance, + nullBalance, + + -- * Block Data + BlockData (..), + confirmed, + + -- * Transactions + TxRef (..), + TxData (..), + txDataFee, + isCoinbaseTx, + Transaction (..), + transactionData, + fromTransaction, + toTransaction, + StoreInput (..), + isCoinbase, + StoreOutput (..), + Prev (..), + Spender (..), + BlockRef (..), + UnixTime, + getUnixTime, + putUnixTime, + BlockPos, + + -- * Unspent Outputs + Unspent (..), + + -- * Extended Public Keys + XPubSpec (..), + XPubBal (..), + XPubUnspent (..), + XPubSummary (..), + DeriveType (..), + textToDeriveType, + deriveTypeToText, + + -- * Other Data + TxId (..), + GenericResult (..), + SerialList (..), + RawResult (..), + RawResultList (..), + PeerInfo (..), + Healthy (..), + BlockHealth (..), + TimeHealth (..), + CountHealth (..), + MaxHealth (..), + HealthCheck (..), + Event (..), + Except (..), + + -- * Blockchain.info API + BinfoInfo (..), + BinfoBlockId (..), + BinfoTxId (..), + encodeBinfoTxId, + BinfoFilter (..), + BinfoMultiAddr (..), + BinfoShortBal (..), + BinfoBalance (..), + toBinfoAddrs, + BinfoRawAddr (..), + BinfoAddr (..), + parseBinfoAddr, + BinfoWallet (..), + BinfoUnspent (..), + binfoHexValue, + BinfoUnspents (..), + BinfoBlock (..), + toBinfoBlock, + BinfoTx (..), + relevantTxs, + toBinfoTx, + toBinfoTxSimple, + BinfoTxInput (..), + BinfoTxOutput (..), + BinfoSpender (..), + BinfoXPubPath (..), + BinfoBlockInfo (..), + toBinfoBlockInfo, + BinfoSymbol (..), + BinfoTicker (..), + BinfoRate (..), + BinfoHistory (..), + toBinfoHistory, + BinfoDate (..), + BinfoHeader (..), + BinfoMempool (..), + BinfoBlockInfos (..), + ) +where + +import Control.Applicative (optional, (<|>)) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad (guard, join, mzero, unless, (<=<)) +import Data.Aeson + ( Encoding, + FromJSON (..), + ToJSON (..), + Value (..), + (.!=), + (.:), + (.:?), + (.=), + ) +import Data.Aeson qualified as A +import Data.Aeson.Encoding qualified as A +import Data.Aeson.Types (Parser) +import Data.Binary (Binary (get, put)) +import Data.Bits (Bits (..)) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Builder qualified as Builder +import Data.Bytes.Get +import Data.Bytes.Get qualified as Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Default (Default (..)) +import Data.Foldable (toList) +import Data.Function (on) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Hashable (Hashable (..)) +import Data.Int (Int32, Int64) +import Data.IntMap qualified as IntMap +import Data.IntMap.Strict (IntMap) +import Data.Maybe + ( catMaybes, + fromMaybe, + isJust, + isNothing, + mapMaybe, + maybeToList, + ) +import Data.Serialize (Serialize (..)) +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 qualified as LazyText +import Data.Text.Lazy.Encoding qualified as LazyText +import Data.Time (UTCTime (UTCTime), rfc822DateFormat) +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.Format + ( defaultTimeLocale, + formatTime, + parseTimeM, + ) +import Data.Time.Format.ISO8601 + ( iso8601ParseM, + iso8601Show, + ) +import Data.Vector qualified as V +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin +import Web.Scotty.Trans (Parsable (..), ScottyError (..)) + +data DeriveType + = DeriveNormal + | DeriveP2SH + | DeriveP2WPKH + deriving (Show, Eq, Generic, NFData) + +textToDeriveType :: Text -> Maybe DeriveType +textToDeriveType "normal" = Just DeriveNormal +textToDeriveType "compat" = Just DeriveP2SH +textToDeriveType "segwit" = Just DeriveP2WPKH +textToDeriveType _ = Nothing + +deriveTypeToText :: DeriveType -> Text +deriveTypeToText DeriveNormal = "normal" +deriveTypeToText DeriveP2SH = "compat" +deriveTypeToText DeriveP2WPKH = "segwit" + +instance Serial DeriveType where + serialize DeriveNormal = putWord8 0x00 + serialize DeriveP2SH = putWord8 0x01 + serialize DeriveP2WPKH = putWord8 0x02 + + deserialize = + getWord8 >>= \case + 0x00 -> return DeriveNormal + 0x01 -> return DeriveP2SH + 0x02 -> return DeriveP2WPKH + _ -> return DeriveNormal + +instance Binary DeriveType where + put = serialize + get = deserialize + +instance Serialize DeriveType where + put = serialize + get = deserialize + +instance Default DeriveType where + def = DeriveNormal + +instance Parsable DeriveType where + parseParam txt = + case textToDeriveType (LazyText.toStrict txt) of + Nothing -> Left "invalid derivation type" + Just x -> Right x + +data XPubSpec = XPubSpec + { key :: !XPubKey, + deriv :: !DeriveType + } + deriving (Show, Eq, Generic, NFData) + +instance Hashable XPubSpec where + hashWithSalt i = hashWithSalt i . (.key.key) + +instance Serial XPubSpec where + serialize XPubSpec {key = k, deriv = t} = do + putWord8 k.depth + serialize k.parent + putWord32be k.index + serialize k.chain + putByteString k.key.get + serialize t + deserialize = do + depth <- getWord8 + parent <- deserialize + index <- getWord32be + chain <- deserialize + key <- PubKey <$> getByteString 64 + deriv <- deserialize + return XPubSpec {key = XPubKey {..}, deriv} + +instance Serialize XPubSpec where + put = serialize + get = deserialize + +instance Binary XPubSpec where + put = serialize + get = deserialize + +type UnixTime = Word64 + +type BlockPos = Word32 + +-- | Binary such that ordering is inverted. +putUnixTime :: (MonadPut m) => Word64 -> m () +putUnixTime w = putWord64be $ maxBound - w + +getUnixTime :: (MonadGet m) => m Word64 +getUnixTime = (maxBound -) <$> getWord64be + +-- | Reference to a block where a transaction is stored. +data BlockRef + = BlockRef + { -- | block height in the chain + height :: !BlockHeight, + -- | position of transaction within the block + position :: !Word32 + } + | MemRef + { timestamp :: !UnixTime + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | Serial entities will sort in reverse order. +instance Serial BlockRef where + serialize MemRef {timestamp = t} = do + putWord8 0x00 + putUnixTime t + serialize BlockRef {height = h, position = p} = do + putWord8 0x01 + putWord32be (maxBound - h) + putWord32be (maxBound - p) + deserialize = + getWord8 >>= \case + 0x00 -> getmemref + 0x01 -> getblockref + _ -> fail "Cannot decode BlockRef" + where + getmemref = do + MemRef <$> getUnixTime + getblockref = do + h <- (maxBound -) <$> getWord32be + p <- (maxBound -) <$> getWord32be + return BlockRef {height = h, position = p} + +instance Serialize BlockRef where + put = serialize + get = deserialize + +instance Binary BlockRef where + put = serialize + get = deserialize + +confirmed :: BlockRef -> Bool +confirmed BlockRef {} = True +confirmed MemRef {} = False + +instance ToJSON BlockRef where + toJSON BlockRef {height = h, position = p} = + A.object + [ "height" .= h, + "position" .= p + ] + toJSON MemRef {timestamp = t} = + A.object ["mempool" .= t] + toEncoding BlockRef {height = h, position = p} = + A.pairs $ + mconcat + [ "height" `A.pair` A.word32 h, + "position" `A.pair` A.word32 p + ] + toEncoding MemRef {timestamp = t} = + A.pairs $ "mempool" `A.pair` A.word64 t + +instance FromJSON BlockRef where + parseJSON = + A.withObject "BlockRef" $ \o -> b o <|> m o + where + b o = do + height <- o .: "height" + position <- o .: "position" + return BlockRef {..} + m o = + MemRef <$> o .: "mempool" + +-- | Transaction in relation to an address. +data TxRef = TxRef + { -- | block information + block :: !BlockRef, + -- | transaction hash + txid :: !TxHash + } + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serial TxRef where + serialize (TxRef b h) = do + serialize b + serialize h + + deserialize = + TxRef <$> deserialize <*> deserialize + +instance Binary TxRef where + put = serialize + get = deserialize + +instance Serialize TxRef where + put = serialize + get = deserialize + +instance ToJSON TxRef where + toJSON x = + A.object + [ "txid" .= x.txid, + "block" .= x.block + ] + toEncoding btx = + A.pairs $ + mconcat + [ "txid" `A.pair` toEncoding btx.txid, + "block" `A.pair` toEncoding btx.block + ] + +instance FromJSON TxRef where + parseJSON = + A.withObject "TxRef" $ \o -> do + txid <- o .: "txid" + block <- o .: "block" + return TxRef {..} + +-- | Address balance information. +data Balance = Balance + { -- | address balance + address :: !Address, + -- | confirmed balance + confirmed :: !Word64, + -- | unconfirmed balance + unconfirmed :: !Word64, + -- | number of unspent outputs + utxo :: !Word64, + -- | number of transactions + txs :: !Word64, + -- | total amount from all outputs in this address + received :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Balance where + serialize b = do + serialize b.address + putWord64be b.confirmed + putWord64be b.unconfirmed + putWord64be b.utxo + putWord64be b.txs + putWord64be b.received + + deserialize = do + address <- deserialize + confirmed <- getWord64be + unconfirmed <- getWord64be + utxo <- getWord64be + txs <- getWord64be + received <- getWord64be + return Balance {..} + +instance Binary Balance where + put = serialize + get = deserialize + +instance Serialize Balance where + put = serialize + get = deserialize + +zeroBalance :: Address -> Balance +zeroBalance a = + Balance + { address = a, + confirmed = 0, + unconfirmed = 0, + utxo = 0, + txs = 0, + received = 0 + } + +nullBalance :: Balance -> Bool +nullBalance + Balance + { confirmed = 0, + unconfirmed = 0, + utxo = 0, + txs = 0, + received = 0 + } = True +nullBalance _ = False + +instance MarshalJSON Network Balance where + marshalValue net b = + A.object + [ "address" .= marshalValue net b.address, + "confirmed" .= b.confirmed, + "unconfirmed" .= b.unconfirmed, + "utxo" .= b.utxo, + "txs" .= b.txs, + "received" .= b.received + ] + + marshalEncoding net b = + A.pairs $ + mconcat + [ "address" `A.pair` marshalEncoding net b.address, + "confirmed" `A.pair` A.word64 b.confirmed, + "unconfirmed" `A.pair` A.word64 b.unconfirmed, + "utxo" `A.pair` A.word64 b.utxo, + "txs" `A.pair` A.word64 b.txs, + "received" `A.pair` A.word64 b.received + ] + + unmarshalValue net = + A.withObject "Balance" $ \o -> do + confirmed <- o .: "confirmed" + unconfirmed <- o .: "unconfirmed" + utxo <- o .: "utxo" + txs <- o .: "txs" + received <- o .: "received" + address <- unmarshalValue net =<< o .: "address" + return Balance {..} + +-- | Unspent output. +data Unspent = Unspent + { block :: !BlockRef, + outpoint :: !OutPoint, + value :: !Word64, + script :: !ByteString, + address :: !(Maybe Address) + } + deriving (Show, Eq, Generic, Hashable, NFData) + +-- | Follow same order as in database and cache by inverting outpoint sort +-- order. +instance Ord Unspent where + compare a b = + compare + (a.block, b.block) + (b.block, a.block) + +instance Serial Unspent where + serialize u = do + serialize u.block + serialize u.outpoint + putWord64be u.value + putLengthBytes u.script + putMaybe serialize u.address + + deserialize = do + block <- deserialize + outpoint <- deserialize + value <- getWord64be + script <- getLengthBytes + address <- getMaybe deserialize + return Unspent {..} + +instance Binary Unspent where + put = serialize + get = deserialize + +instance Serialize Unspent where + put = serialize + get = deserialize + +instance Coin Unspent where + coinValue = (.value) + +instance MarshalJSON Network Unspent where + marshalValue net u = + A.object + [ "address" .= fmap (marshalValue net) u.address, + "block" .= u.block, + "txid" .= u.outpoint.hash, + "index" .= u.outpoint.index, + "pkscript" .= encodeHex u.script, + "value" .= u.value + ] + + marshalEncoding net u = + A.pairs $ + mconcat + [ "address" `A.pair` maybe A.null_ (marshalEncoding net) u.address, + "block" `A.pair` toEncoding u.block, + "txid" `A.pair` toEncoding u.outpoint.hash, + "index" `A.pair` A.word32 u.outpoint.index, + "pkscript" `A.pair` hexEncoding (B.fromStrict u.script), + "value" `A.pair` A.word64 u.value + ] + + unmarshalValue net = + A.withObject "Unspent" $ \o -> do + block <- o .: "block" + hash <- o .: "txid" + index <- o .: "index" + value <- o .: "value" + script <- o .: "pkscript" >>= jsonHex + address <- + o .: "address" + >>= maybe (return Nothing) (optional . unmarshalValue net) + return Unspent {outpoint = OutPoint {..}, ..} + +-- | Database value for a block entry. +data BlockData = BlockData + { -- | height of the block in the chain + height :: !BlockHeight, + -- | is this block in the main chain? + main :: !Bool, + -- | accumulated work in that block + work :: !Integer, + -- | block header + header :: !BlockHeader, + -- | size of the block including witnesses + size :: !Word32, + -- | weight of this block (for segwit networks) + weight :: !Word32, + -- | block transactions + txs :: ![TxHash], + -- | sum of all transaction outputs + outputs :: !Word64, + -- | sum of all transaction fee + fee :: !Word64, + -- | block subsidy + subsidy :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial BlockData where + serialize b = do + putWord32be b.height + serialize b.main + putInteger b.work + serialize b.header + putWord32be b.size + putWord32be b.weight + putList serialize b.txs + putWord64be b.outputs + putWord64be b.fee + putWord64be b.subsidy + + deserialize = do + height <- getWord32be + main <- deserialize + work <- getInteger + header <- deserialize + size <- getWord32be + weight <- getWord32be + txs <- getList deserialize + outputs <- getWord64be + fee <- getWord64be + subsidy <- getWord64be + return BlockData {..} + +instance Serialize BlockData where + put = serialize + get = deserialize + +instance Binary BlockData where + put = serialize + get = deserialize + +instance FromJSON BlockData where + parseJSON = + A.withObject "BlockData" $ \o -> do + height <- o .: "height" + main <- o .: "mainchain" + prev <- o .: "previous" + timestamp <- o .: "time" + version <- o .: "version" + bits <- o .: "bits" + nonce <- o .: "nonce" + size <- o .: "size" + txs <- o .: "tx" + TxHash merkle <- o .: "merkle" + subsidy <- o .: "subsidy" + fee <- o .: "fees" + outputs <- o .: "outputs" + work <- o .: "work" + weight <- o .:? "weight" .!= 0 + return BlockData {header = BlockHeader {..}, ..} + +instance MarshalJSON Network BlockData where + marshalValue net b = + A.object $ + [ "hash" .= headerHash b.header, + "height" .= b.height, + "mainchain" .= b.main, + "previous" .= b.header.prev, + "time" .= b.header.timestamp, + "version" .= b.header.version, + "bits" .= b.header.bits, + "nonce" .= b.header.nonce, + "size" .= b.size, + "tx" .= b.txs, + "merkle" .= TxHash b.header.merkle, + "subsidy" .= b.subsidy, + "fees" .= b.fee, + "outputs" .= b.outputs, + "work" .= b.work + ] + <> ["weight" .= b.weight | net.segWit] + + marshalEncoding net b = + A.pairs $ + mconcat + [ "hash" `A.pair` toEncoding (headerHash b.header), + "height" `A.pair` A.word32 b.height, + "mainchain" `A.pair` A.bool b.main, + "previous" `A.pair` toEncoding b.header.prev, + "time" `A.pair` A.word32 b.header.timestamp, + "version" `A.pair` A.word32 b.header.version, + "bits" `A.pair` A.word32 b.header.bits, + "nonce" `A.pair` A.word32 b.header.nonce, + "size" `A.pair` A.word32 b.size, + "tx" `A.pair` A.list toEncoding b.txs, + "merkle" `A.pair` toEncoding (TxHash b.header.merkle), + "subsidy" `A.pair` A.word64 b.subsidy, + "fees" `A.pair` A.word64 b.fee, + "outputs" `A.pair` A.word64 b.outputs, + "work" `A.pair` A.integer b.work, + bool mempty ("weight" `A.pair` A.word32 b.weight) net.segWit + ] + + unmarshalValue net = parseJSON + +data StoreInput + = StoreCoinbase + { outpoint :: !OutPoint, + sequence :: !Word32, + script :: !ByteString, + witness :: !WitnessStack + } + | StoreInput + { outpoint :: !OutPoint, + sequence :: !Word32, + script :: !ByteString, + pkscript :: !ByteString, + value :: !Word64, + witness :: !WitnessStack, + address :: !(Maybe Address) + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial StoreInput where + serialize i@StoreCoinbase {} = do + putWord8 0x00 + serialize i.outpoint + putWord32be i.sequence + putLengthBytes i.script + putList putLengthBytes i.witness + serialize i@StoreInput {} = do + putWord8 0x01 + serialize i.outpoint + putWord32be i.sequence + putLengthBytes i.script + putLengthBytes i.pkscript + putWord64be i.value + putList putLengthBytes i.witness + putMaybe serialize i.address + + deserialize = + getWord8 >>= \case + 0x00 -> do + outpoint <- deserialize + sequence <- getWord32be + script <- getLengthBytes + witness <- getList getLengthBytes + return StoreCoinbase {..} + 0x01 -> do + outpoint <- deserialize + sequence <- getWord32be + script <- getLengthBytes + pkscript <- getLengthBytes + value <- getWord64be + witness <- getList getLengthBytes + address <- getMaybe deserialize + return StoreInput {..} + x -> fail $ "Unknown input id: " <> cs (show x) + +instance Serialize StoreInput where + put = serialize + get = deserialize + +instance Binary StoreInput where + put = serialize + get = deserialize + +isCoinbaseTx :: Tx -> Bool +isCoinbaseTx = all ((== nullOutPoint) . (.outpoint)) . (.inputs) + +isCoinbase :: StoreInput -> Bool +isCoinbase StoreCoinbase {} = True +isCoinbase StoreInput {} = False + +instance MarshalJSON Network StoreInput where + marshalValue net i@StoreInput {} = + A.object + [ "coinbase" .= False, + "txid" .= i.outpoint.hash, + "output" .= i.outpoint.index, + "sigscript" .= String (encodeHex i.script), + "sequence" .= i.sequence, + "pkscript" .= String (encodeHex i.pkscript), + "value" .= i.value, + "address" .= (marshalValue net <$> i.address), + "witness" .= map encodeHex i.witness + ] + marshalValue net i@StoreCoinbase {} = + A.object + [ "coinbase" .= True, + "txid" .= i.outpoint.hash, + "output" .= i.outpoint.index, + "sigscript" .= String (encodeHex i.script), + "sequence" .= i.sequence, + "pkscript" .= Null, + "value" .= Null, + "address" .= Null, + "witness" .= map encodeHex i.witness + ] + + marshalEncoding net i@StoreInput {} = + A.pairs $ + mconcat + [ "coinbase" `A.pair` A.bool False, + "txid" `A.pair` toEncoding i.outpoint.hash, + "output" `A.pair` A.word32 i.outpoint.index, + "sigscript" `A.pair` hexEncoding (B.fromStrict i.script), + "sequence" `A.pair` A.word32 i.sequence, + "pkscript" `A.pair` hexEncoding (B.fromStrict i.pkscript), + "value" `A.pair` A.word64 i.value, + "address" `A.pair` maybe A.null_ (marshalEncoding net) i.address, + "witness" `A.pair` A.list (hexEncoding . B.fromStrict) i.witness + ] + marshalEncoding net i@StoreCoinbase {} = + A.pairs $ + mconcat + [ "coinbase" .= True, + "txid" `A.pair` toEncoding i.outpoint.hash, + "output" `A.pair` A.word32 i.outpoint.index, + "sigscript" `A.pair` hexEncoding (B.fromStrict i.script), + "sequence" `A.pair` A.word32 i.sequence, + "pkscript" `A.pair` A.null_, + "value" `A.pair` A.null_, + "address" `A.pair` A.null_, + "witness" `A.pair` A.list (hexEncoding . B.fromStrict) i.witness + ] + + unmarshalValue net = + A.withObject "StoreInput" $ \o -> do + coinbase <- o .: "coinbase" + outpoint <- OutPoint <$> o .: "txid" <*> o .: "output" + sequence <- o .: "sequence" + witness <- mapM jsonHex =<< o .:? "witness" .!= [] + script <- o .: "sigscript" >>= jsonHex + if coinbase + then return StoreCoinbase {..} + else do + pkscript <- o .: "pkscript" >>= jsonHex + value <- o .: "value" + address <- + o .: "address" + >>= maybe (return Nothing) (optional . unmarshalValue net) + return StoreInput {..} + +jsonHex :: Text -> Parser ByteString +jsonHex s = + case decodeHex s of + Nothing -> fail "Could not decode hex" + Just b -> return b + +-- | Information about input spending output. +data Spender = Spender + { -- | input transaction hash + txid :: !TxHash, + -- | input position in transaction + index :: !Word32 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Spender where + serialize s = do + serialize s.txid + putWord32be s.index + deserialize = Spender <$> deserialize <*> getWord32be + +instance Serialize Spender where + put = serialize + get = deserialize + +instance Binary Spender where + put = serialize + get = deserialize + +instance ToJSON Spender where + toJSON s = + A.object + [ "txid" .= s.txid, + "input" .= s.index + ] + toEncoding s = + A.pairs $ + mconcat + [ "txid" `A.pair` toEncoding s.txid, + "input" `A.pair` A.word32 s.index + ] + +instance FromJSON Spender where + parseJSON = + A.withObject "Spender" $ \o -> + Spender <$> o .: "txid" <*> o .: "input" + +-- | Output information. +data StoreOutput = StoreOutput + { value :: !Word64, + script :: !ByteString, + spender :: !(Maybe Spender), + address :: !(Maybe Address) + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial StoreOutput where + serialize o = do + putWord64be o.value + putLengthBytes o.script + putMaybe serialize o.spender + putMaybe serialize o.address + deserialize = do + value <- getWord64be + script <- getLengthBytes + spender <- getMaybe deserialize + address <- getMaybe deserialize + return StoreOutput {..} + +instance Serialize StoreOutput where + put = serialize + get = deserialize + +instance Binary StoreOutput where + put = serialize + get = deserialize + +instance MarshalJSON Network StoreOutput where + marshalValue net o = + A.object + [ "address" .= (marshalValue net <$> o.address), + "pkscript" .= encodeHex o.script, + "value" .= o.value, + "spent" .= isJust o.spender, + "spender" .= o.spender + ] + + marshalEncoding net o = + A.pairs $ + mconcat + [ "address" `A.pair` maybe A.null_ (marshalEncoding net) o.address, + "pkscript" `A.pair` hexEncoding (B.fromStrict o.script), + "value" `A.pair` A.word64 o.value, + "spent" `A.pair` A.bool (isJust o.spender), + "spender" `A.pair` toEncoding o.spender + ] + + unmarshalValue net = + A.withObject "StoreOutput" $ \o -> do + value <- o .: "value" + script <- o .: "pkscript" >>= jsonHex + spender <- o .: "spender" + address <- + o .: "address" + >>= maybe (return Nothing) (optional . unmarshalValue net) + return StoreOutput {..} + +data Prev = Prev + { script :: !ByteString, + value :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Prev where + serialize p = do + putLengthBytes p.script + putWord64be p.value + deserialize = do + script <- getLengthBytes + value <- getWord64be + return Prev {..} + +instance Binary Prev where + put = serialize + get = deserialize + +instance Serialize Prev where + put = serialize + get = deserialize + +toInput :: Ctx -> TxIn -> Maybe Prev -> WitnessStack -> StoreInput +toInput ctx i Nothing w = + StoreCoinbase + { outpoint = i.outpoint, + sequence = i.sequence, + script = i.script, + witness = w + } +toInput ctx i (Just p) w = + StoreInput + { outpoint = i.outpoint, + sequence = i.sequence, + script = i.script, + pkscript = p.script, + value = p.value, + witness = w, + address = eitherToMaybe (scriptToAddressBS ctx p.script) + } + +toOutput :: Ctx -> TxOut -> Maybe Spender -> StoreOutput +toOutput ctx o s = + StoreOutput + { value = o.value, + script = o.script, + spender = s, + address = eitherToMaybe (scriptToAddressBS ctx o.script) + } + +data TxData = TxData + { block :: !BlockRef, + tx :: !Tx, + prevs :: !(IntMap Prev), + deleted :: !Bool, + rbf :: !Bool, + timestamp :: !Word64, + spenders :: !(IntMap Spender) + } + deriving (Show, Eq, Ord, Generic, NFData) + +instance Serial TxData where + serialize t = do + serialize t.block + serialize t.tx + putIntMap (putWord64be . fromIntegral) serialize t.prevs + serialize t.deleted + serialize t.rbf + putWord64be t.timestamp + putIntMap (putWord64be . fromIntegral) serialize t.spenders + deserialize = do + block <- deserialize + tx <- deserialize + prevs <- getIntMap (fromIntegral <$> getWord64be) deserialize + deleted <- deserialize + rbf <- deserialize + timestamp <- getWord64be + spenders <- getIntMap (fromIntegral <$> getWord64be) deserialize + return TxData {..} + +instance Serialize TxData where + put = serialize + get = deserialize + +instance Binary TxData where + put = serialize + get = deserialize + +txDataFee :: TxData -> Word64 +txDataFee t = + if isCoinbaseTx t.tx + then 0 + else inputs - outputs + where + inputs = sum $ map (.value) $ IntMap.elems t.prevs + outputs = sum $ map (.value) t.tx.outputs + +toTransaction :: Ctx -> TxData -> Transaction +toTransaction ctx t = + Transaction + { version = t.tx.version, + locktime = t.tx.locktime, + block = t.block, + deleted = t.deleted, + rbf = t.rbf, + timestamp = t.timestamp, + txid = txHash t.tx, + inputs = ins, + outputs = outs, + size = + fromIntegral $ + B.length $ + runPutS $ + serialize t.tx, + weight = + let b = B.length $ runPutS $ serialize witless + x = B.length $ runPutS $ serialize t.tx + in fromIntegral $ b * 3 + x, + fee = + if any isCoinbase ins + then 0 + else inv - outv + } + where + ins = zipWith f [0 ..] t.tx.inputs + witless = + let Tx {..} = t.tx + in Tx {witness = [], ..} + inv = sum (map (.value) ins) + outs = zipWith g [0 ..] t.tx.outputs + outv = sum $ map (.value) outs + ws = take (length t.tx.inputs) $ t.tx.witness <> repeat [] + f n i = toInput ctx i (IntMap.lookup n t.prevs) (ws !! n) + g n o = toOutput ctx o $ IntMap.lookup n t.spenders + +fromTransaction :: Transaction -> TxData +fromTransaction t = + TxData + { block = t.block, + tx = tx, + deleted = t.deleted, + rbf = t.rbf, + timestamp = t.timestamp, + prevs = + IntMap.fromList $ + catMaybes $ + zipWith f [0 ..] t.inputs, + spenders = + IntMap.fromList $ + catMaybes $ + zipWith g [0 ..] t.outputs + } + where + tx = transactionData t + f _ StoreCoinbase {} = Nothing + f n StoreInput {script = s, value = v} = + Just (n, Prev {script = s, value = v}) + g _ StoreOutput {spender = Nothing} = Nothing + g n StoreOutput {spender = Just s} = Just (n, s) + +-- | Detailed transaction information. +data Transaction = Transaction + { -- | block information for this transaction + block :: !BlockRef, + -- | transaction version + version :: !Word32, + -- | lock time + locktime :: !Word32, + -- | transaction inputs + inputs :: ![StoreInput], + -- | transaction outputs + outputs :: ![StoreOutput], + -- | this transaction has been deleted and is no longer valid + deleted :: !Bool, + -- | this transaction can be replaced in the mempool + rbf :: !Bool, + -- | time the transaction was first seen or time of block + timestamp :: !Word64, + -- | transaction id + txid :: !TxHash, + -- | serialized transaction size (includes witness data) + size :: !Word32, + -- | transaction weight + weight :: !Word32, + -- | fees that this transaction pays (0 for coinbase) + fee :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Transaction where + serialize t = do + serialize t.block + putWord32be t.version + putWord32be t.locktime + putList serialize t.inputs + putList serialize t.outputs + serialize t.deleted + serialize t.rbf + putWord64be t.timestamp + serialize t.txid + putWord32be t.size + putWord32be t.weight + putWord64be t.fee + deserialize = do + block <- deserialize + version <- getWord32be + locktime <- getWord32be + inputs <- getList deserialize + outputs <- getList deserialize + deleted <- deserialize + rbf <- deserialize + timestamp <- getWord64be + txid <- deserialize + size <- getWord32be + weight <- getWord32be + fee <- getWord64be + return Transaction {..} + +instance Serialize Transaction where + put = serialize + get = deserialize + +instance Binary Transaction where + put = serialize + get = deserialize + +transactionData :: Transaction -> Tx +transactionData t = + Tx + { inputs = map i t.inputs, + outputs = map o t.outputs, + version = t.version, + locktime = t.locktime, + witness = w $ map (.witness) t.inputs + } + where + i StoreCoinbase {..} = TxIn {..} + i StoreInput {..} = TxIn {..} + o StoreOutput {..} = TxOut {..} + w xs + | all null xs = [] + | otherwise = xs + +instance MarshalJSON Network Transaction where + marshalValue net t = + A.object + [ "txid" .= t.txid, + "size" .= t.size, + "version" .= t.version, + "locktime" .= t.locktime, + "fee" .= t.fee, + "inputs" .= map (marshalValue net) t.inputs, + "outputs" .= map (marshalValue net) t.outputs, + "block" .= t.block, + "deleted" .= t.deleted, + "time" .= t.timestamp, + "rbf" .= t.rbf, + "weight" .= t.weight + ] + + marshalEncoding net t = + A.pairs $ + mconcat + [ "txid" `A.pair` toEncoding t.txid, + "size" `A.pair` A.word32 t.size, + "version" `A.pair` A.word32 t.version, + "locktime" `A.pair` A.word32 t.locktime, + "fee" `A.pair` A.word64 t.fee, + "inputs" `A.pair` A.list (marshalEncoding net) t.inputs, + "outputs" `A.pair` A.list (marshalEncoding net) t.outputs, + "block" `A.pair` toEncoding t.block, + "deleted" `A.pair` A.bool t.deleted, + "time" `A.pair` A.word64 t.timestamp, + "rbf" `A.pair` A.bool t.rbf, + "weight" `A.pair` A.word32 t.weight + ] + + unmarshalValue net = A.withObject "Transaction" $ \o -> do + version <- o .: "version" + locktime <- o .: "locktime" + inputs <- o .: "inputs" >>= mapM (unmarshalValue net) + outputs <- o .: "outputs" >>= mapM (unmarshalValue net) + block <- o .: "block" + deleted <- o .: "deleted" + timestamp <- o .: "time" + rbf <- o .:? "rbf" .!= False + weight <- o .:? "weight" .!= 0 + size <- o .: "size" + txid <- o .: "txid" + fee <- o .: "fee" + return Transaction {..} + +-- | Information about a connected peer. +data PeerInfo = PeerInfo + { -- | user agent string + userAgent :: !ByteString, + -- | network address + address :: !String, + -- | version number + version :: !Word32, + -- | services field + services :: !Word64, + -- | will relay transactions + relay :: !Bool + } + deriving (Show, Eq, Ord, Generic, NFData) + +instance Serial PeerInfo where + serialize p = do + putLengthBytes p.userAgent + putLengthBytes $ T.encodeUtf8 $ T.pack p.address + putWord32be p.version + putWord64be p.services + serialize p.relay + deserialize = do + userAgent <- getLengthBytes + address <- T.unpack . T.decodeUtf8 <$> getLengthBytes + version <- getWord32be + services <- getWord64be + relay <- deserialize + return PeerInfo {..} + +instance Serialize PeerInfo where + put = serialize + get = deserialize + +instance Binary PeerInfo where + put = serialize + get = deserialize + +instance ToJSON PeerInfo where + toJSON p = + A.object + [ "useragent" .= String (T.decodeUtf8 p.userAgent), + "address" .= p.address, + "version" .= p.version, + "services" + .= String (encodeHex $ runPutS $ serialize p.services), + "relay" .= p.relay + ] + toEncoding p = + A.pairs $ + mconcat + [ "useragent" `A.pair` A.text (T.decodeUtf8 p.userAgent), + "address" `A.pair` toEncoding p.address, + "version" `A.pair` A.word32 p.version, + "services" `A.pair` hexEncoding (runPutL $ serialize p.services), + "relay" `A.pair` A.bool p.relay + ] + +instance FromJSON PeerInfo where + parseJSON = + A.withObject "PeerInfo" $ \o -> do + String userAgentText <- o .: "useragent" + let userAgent = T.encodeUtf8 userAgentText + address <- o .: "address" + version <- o .: "version" + services <- + o .: "services" >>= jsonHex >>= \b -> + case runGetS deserialize b of + Left e -> fail $ "Could not decode services: " <> e + Right s -> return s + relay <- o .: "relay" + return PeerInfo {..} + +-- | Address balances for an extended public key. +data XPubBal = XPubBal + { path :: ![KeyIndex], + balance :: !Balance + } + deriving (Show, Ord, Eq, Generic, NFData) + +instance Serial XPubBal where + serialize b = do + putList putWord32be b.path + serialize b.balance + deserialize = do + path <- getList getWord32be + balance <- deserialize + return XPubBal {..} + +instance Serialize XPubBal where + put = serialize + get = deserialize + +instance Binary XPubBal where + put = serialize + get = deserialize + +instance MarshalJSON Network XPubBal where + marshalValue net b = + A.object + [ "path" .= b.path, + "balance" .= marshalValue net b.balance + ] + + marshalEncoding net b = + A.pairs $ + mconcat + [ "path" `A.pair` A.list A.word32 b.path, + "balance" `A.pair` marshalEncoding net b.balance + ] + + unmarshalValue net = + A.withObject "XPubBal" $ \o -> do + path <- o .: "path" + balance <- unmarshalValue net =<< o .: "balance" + return XPubBal {..} + +-- | Unspent transaction for extended public key. +data XPubUnspent = XPubUnspent + { unspent :: !Unspent, + path :: ![KeyIndex] + } + deriving (Show, Eq, Ord, Generic, NFData) + +instance Serial XPubUnspent where + serialize u = do + putList putWord32be u.path + serialize u.unspent + deserialize = do + path <- getList getWord32be + unspent <- deserialize + return XPubUnspent {..} + +instance Serialize XPubUnspent where + put = serialize + get = deserialize + +instance Binary XPubUnspent where + put = serialize + get = deserialize + +instance MarshalJSON Network XPubUnspent where + marshalValue net u = + A.object + [ "unspent" .= marshalValue net u.unspent, + "path" .= u.path + ] + + marshalEncoding net u = + A.pairs $ + mconcat + [ "unspent" `A.pair` marshalEncoding net u.unspent, + "path" `A.pair` A.list A.word32 u.path + ] + + unmarshalValue net = + A.withObject "XPubUnspent" $ \o -> do + unspent <- o .: "unspent" >>= unmarshalValue net + path <- o .: "path" + return XPubUnspent {..} + +data XPubSummary = XPubSummary + { confirmed :: !Word64, + unconfirmed :: !Word64, + received :: !Word64, + utxo :: !Word64, + external :: !Word32, + change :: !Word32 + } + deriving (Eq, Show, Generic, NFData) + +instance Serial XPubSummary where + serialize s = do + putWord64be s.confirmed + putWord64be s.unconfirmed + putWord64be s.received + putWord64be s.utxo + putWord32be s.external + putWord32be s.change + deserialize = do + confirmed <- getWord64be + unconfirmed <- getWord64be + received <- getWord64be + utxo <- getWord64be + external <- getWord32be + change <- getWord32be + return XPubSummary {..} + +instance Binary XPubSummary where + put = serialize + get = deserialize + +instance Serialize XPubSummary where + put = serialize + get = deserialize + +instance ToJSON XPubSummary where + toJSON s = + A.object + [ "balance" + .= A.object + [ "confirmed" .= s.confirmed, + "unconfirmed" .= s.unconfirmed, + "received" .= s.received, + "utxo" .= s.utxo + ], + "indices" + .= A.object + [ "change" .= s.change, + "external" .= s.external + ] + ] + toEncoding s = + A.pairs $ + mconcat + [ A.pair "balance" $ + A.pairs $ + mconcat + [ "confirmed" `A.pair` A.word64 s.confirmed, + "unconfirmed" `A.pair` A.word64 s.unconfirmed, + "received" `A.pair` A.word64 s.received, + "utxo" `A.pair` A.word64 s.utxo + ], + A.pair "indices" $ + A.pairs $ + mconcat + [ "change" `A.pair` A.word32 s.change, + "external" `A.pair` A.word32 s.external + ] + ] + +instance FromJSON XPubSummary where + parseJSON = + A.withObject "XPubSummary" $ \o -> do + b <- o .: "balance" + i <- o .: "indices" + confirmed <- b .: "confirmed" + unconfirmed <- b .: "unconfirmed" + received <- b .: "received" + utxo <- b .: "utxo" + change <- i .: "change" + external <- i .: "external" + return XPubSummary {..} + +class Healthy a where + isOK :: a -> Bool + +data BlockHealth = BlockHealth + { headers :: !BlockHeight, + blocks :: !BlockHeight, + max :: !Int32 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial BlockHealth where + serialize h = do + serialize (isOK h) + putWord32be h.headers + putWord32be h.blocks + putInt32be h.max + deserialize = do + k <- deserialize + headers <- getWord32be + blocks <- getWord32be + max <- getInt32be + let h = BlockHealth {..} + unless (k == isOK h) $ fail "Inconsistent health check" + return h + +instance Serialize BlockHealth where + put = serialize + get = deserialize + +instance Binary BlockHealth where + put = serialize + get = deserialize + +instance Healthy BlockHealth where + isOK x = + h - b <= x.max + where + h = fromIntegral x.headers + b = fromIntegral x.blocks + +instance ToJSON BlockHealth where + toJSON h = + A.object + [ "headers" .= h.headers, + "blocks" .= h.blocks, + "diff" .= diff, + "max" .= h.max, + "ok" .= isOK h + ] + where + diff = toInteger h.headers - toInteger h.blocks + +instance FromJSON BlockHealth where + parseJSON = + A.withObject "BlockHealth" $ \o -> do + headers <- o .: "headers" + blocks <- o .: "blocks" + max <- o .: "max" + return BlockHealth {..} + +data TimeHealth = TimeHealth + { age :: !Int64, + max :: !Int64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial TimeHealth where + serialize h = do + serialize (isOK h) + putInt64be h.age + putInt64be h.max + deserialize = do + k <- deserialize + age <- getInt64be + max <- getInt64be + let t = TimeHealth {..} + unless (k == isOK t) $ fail "Inconsistent health check" + return t + +instance Binary TimeHealth where + put = serialize + get = deserialize + +instance Serialize TimeHealth where + put = serialize + get = deserialize + +instance Healthy TimeHealth where + isOK TimeHealth {..} = + age <= max + +instance ToJSON TimeHealth where + toJSON h = + A.object + [ "age" .= h.age, + "max" .= h.max, + "ok" .= isOK h + ] + +instance FromJSON TimeHealth where + parseJSON = + A.withObject "TimeHealth" $ \o -> do + age <- o .: "age" + max <- o .: "max" + return TimeHealth {..} + +data CountHealth = CountHealth + { count :: !Int64, + min :: !Int64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial CountHealth where + serialize h = do + serialize (isOK h) + putInt64be h.count + putInt64be h.min + deserialize = do + k <- deserialize + count <- getInt64be + min <- getInt64be + let c = CountHealth {..} + unless (k == isOK c) $ fail "Inconsistent health check" + return c + +instance Serialize CountHealth where + put = serialize + get = deserialize + +instance Binary CountHealth where + put = serialize + get = deserialize + +instance Healthy CountHealth where + isOK CountHealth {..} = min <= count + +instance ToJSON CountHealth where + toJSON h = + A.object + [ "count" .= h.count, + "min" .= h.min, + "ok" .= isOK h + ] + +instance FromJSON CountHealth where + parseJSON = + A.withObject "CountHealth" $ \o -> do + count <- o .: "count" + min <- o .: "min" + return CountHealth {..} + +data MaxHealth = MaxHealth + { count :: !Int64, + max :: !Int64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial MaxHealth where + serialize h = do + serialize $ isOK h + putInt64be h.count + putInt64be h.max + deserialize = do + k <- deserialize + count <- getInt64be + max <- getInt64be + let h = MaxHealth {..} + unless (k == isOK h) $ fail "Inconsistent health check" + return h + +instance Binary MaxHealth where + put = serialize + get = deserialize + +instance Serialize MaxHealth where + put = serialize + get = deserialize + +instance Healthy MaxHealth where + isOK MaxHealth {..} = count <= max + +instance ToJSON MaxHealth where + toJSON h = + A.object + [ "count" .= h.count, + "max" .= h.max, + "ok" .= isOK h + ] + +instance FromJSON MaxHealth where + parseJSON = + A.withObject "MaxHealth" $ \o -> do + count <- o .: "count" + max <- o .: "max" + return MaxHealth {..} + +data HealthCheck = HealthCheck + { blocks :: !BlockHealth, + lastBlock :: !TimeHealth, + lastTx :: !TimeHealth, + pendingTxs :: !MaxHealth, + peers :: !CountHealth, + network :: !String, + version :: !String, + time :: !Word64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial HealthCheck where + serialize h = do + serialize $ isOK h + serialize h.blocks + serialize h.lastBlock + serialize h.lastTx + serialize h.pendingTxs + serialize h.peers + putLengthBytes $ T.encodeUtf8 $ T.pack h.network + putLengthBytes $ T.encodeUtf8 $ T.pack h.version + putWord64be h.time + deserialize = do + k <- deserialize + blocks <- deserialize + lastBlock <- deserialize + lastTx <- deserialize + pendingTxs <- deserialize + peers <- deserialize + network <- T.unpack . T.decodeUtf8 <$> getLengthBytes + version <- T.unpack . T.decodeUtf8 <$> getLengthBytes + time <- getWord64be + let h = HealthCheck {..} + unless (k == isOK h) $ fail "Inconsistent health check" + return h + +instance Binary HealthCheck where + put = serialize + get = deserialize + +instance Serialize HealthCheck where + put = serialize + get = deserialize + +instance Healthy HealthCheck where + isOK h = + and + [ isOK h.blocks, + isOK h.lastBlock, + isOK h.lastTx, + isOK h.pendingTxs, + isOK h.peers + ] + +instance ToJSON HealthCheck where + toJSON h = + A.object + [ "blocks" .= h.blocks, + "last-block" .= h.lastBlock, + "last-tx" .= h.lastTx, + "pending-txs" .= h.pendingTxs, + "peers" .= h.peers, + "net" .= h.network, + "version" .= h.version, + "time" .= show (posixSecondsToUTCTime $ fromIntegral h.time), + "ok" .= isOK h + ] + +instance FromJSON HealthCheck where + parseJSON = + A.withObject "HealthCheck" $ \o -> do + blocks <- o .: "blocks" + lastBlock <- o .: "last-block" + lastTx <- o .: "last-tx" + pendingTxs <- o .: "pending-txs" + peers <- o .: "peers" + network <- o .: "net" + version <- o .: "version" + utcTime <- read <$> o .: "time" + let time = round $ utcTimeToPOSIXSeconds utcTime + return HealthCheck {..} + +data Event + = EventBlock !BlockHash + | EventTx !TxHash + deriving (Show, Eq, Generic, NFData) + +instance Serial Event where + serialize (EventBlock bh) = putWord8 0x00 >> serialize bh + serialize (EventTx th) = putWord8 0x01 >> serialize th + deserialize = + getWord8 >>= \case + 0x00 -> EventBlock <$> deserialize + 0x01 -> EventTx <$> deserialize + _ -> fail "Not an Event" + +instance Serialize Event where + put = serialize + get = deserialize + +instance Binary Event where + put = serialize + get = deserialize + +instance ToJSON Event where + toJSON (EventTx h) = + A.object ["type" .= String "tx", "id" .= h] + toJSON (EventBlock h) = + A.object ["type" .= String "block", "id" .= h] + toEncoding (EventTx h) = + A.pairs ("type" `A.pair` A.text "tx" <> "id" `A.pair` toEncoding h) + toEncoding (EventBlock h) = + A.pairs ("type" `A.pair` A.text "block" <> "id" `A.pair` toEncoding h) + +instance FromJSON Event where + parseJSON = + A.withObject "event" $ \o -> do + t <- o .: "type" + case t of + "tx" -> do + i <- o .: "id" + return $ EventTx i + "block" -> do + i <- o .: "id" + return $ EventBlock i + _ -> fail $ "Could not recognize event type: " <> t + +newtype GenericResult a = GenericResult {get :: a} + deriving (Show, Eq, Generic, NFData) + +instance (Serial a) => Serial (GenericResult a) where + serialize (GenericResult x) = serialize x + deserialize = GenericResult <$> deserialize + +instance (Serial a) => Serialize (GenericResult a) where + put = serialize + get = deserialize + +instance (Serial a) => Binary (GenericResult a) where + put = serialize + get = deserialize + +instance (ToJSON a) => ToJSON (GenericResult a) where + toJSON (GenericResult b) = A.object ["result" .= b] + toEncoding (GenericResult b) = A.pairs ("result" `A.pair` toEncoding b) + +instance (FromJSON a) => FromJSON (GenericResult a) where + parseJSON = + A.withObject "GenericResult" $ \o -> GenericResult <$> o .: "result" + +newtype RawResult a = RawResult {get :: a} + deriving (Show, Eq, Generic, NFData) + +instance (Serial a) => Serial (RawResult a) where + serialize (RawResult x) = serialize x + deserialize = RawResult <$> deserialize + +instance (Serial a) => Serialize (RawResult a) where + put = serialize + get = deserialize + +instance (Serial a) => Binary (RawResult a) where + put = serialize + get = deserialize + +instance (Serial a) => ToJSON (RawResult a) where + toJSON (RawResult b) = + A.object ["result" .= String (encodeHex $ runPutS $ serialize b)] + toEncoding (RawResult b) = + A.pairs $ "result" `A.pair` hexEncoding (runPutL $ serialize b) + +instance (Serial a) => FromJSON (RawResult a) where + parseJSON = + A.withObject "RawResult" $ \o -> do + res <- o .: "result" + let m = + eitherToMaybe . Bytes.Get.runGetS deserialize + =<< decodeHex res + maybe mzero (return . RawResult) m + +newtype SerialList a = SerialList {get :: [a]} + deriving (Show, Eq, Generic, NFData) + +instance Semigroup (SerialList a) where + SerialList a <> SerialList b = SerialList (a <> b) + +instance Monoid (SerialList a) where + mempty = SerialList mempty + +instance (Serial a) => Serial (SerialList a) where + serialize (SerialList ls) = putList serialize ls + deserialize = SerialList <$> getList deserialize + +instance (ToJSON a) => ToJSON (SerialList a) where + toJSON (SerialList ls) = toJSON ls + toEncoding (SerialList ls) = A.list toEncoding ls + +instance (FromJSON a) => FromJSON (SerialList a) where + parseJSON = fmap SerialList . parseJSON + +newtype RawResultList a = RawResultList {get :: [a]} + deriving (Show, Eq, Generic, NFData) + +instance (Serial a) => Serial (RawResultList a) where + serialize (RawResultList xs) = + mapM_ serialize xs + deserialize = RawResultList <$> go + where + go = + isEmpty >>= \case + True -> return [] + False -> (:) <$> deserialize <*> go + +instance (Serial a) => Serialize (RawResultList a) where + put = serialize + get = deserialize + +instance (Serial a) => Binary (RawResultList a) where + put = serialize + get = deserialize + +instance Semigroup (RawResultList a) where + (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b + +instance Monoid (RawResultList a) where + mempty = RawResultList mempty + +instance (Serial a) => ToJSON (RawResultList a) where + toJSON (RawResultList xs) = + toJSON $ String . encodeHex . runPutS . serialize <$> xs + toEncoding (RawResultList xs) = + A.list (hexEncoding . runPutL . serialize) xs + +instance (Serial a) => FromJSON (RawResultList a) where + parseJSON = + A.withArray "RawResultList" $ \vec -> + RawResultList <$> mapM parseElem (toList vec) + where + deser = eitherToMaybe . runGetS deserialize + parseElem = + A.withText "RawResultListItem" $ \t -> + maybe mzero return (decodeHex t >>= deser) + +newtype TxId + = TxId TxHash + deriving (Show, Eq, Generic, NFData) + +instance Serial TxId where + serialize (TxId h) = serialize h + deserialize = TxId <$> deserialize + +instance Serialize TxId where + put = serialize + get = deserialize + +instance Binary TxId where + put = serialize + get = deserialize + +instance ToJSON TxId where + toJSON (TxId h) = A.object ["txid" .= h] + toEncoding (TxId h) = A.pairs ("txid" `A.pair` toEncoding h) + +instance FromJSON TxId where + parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid" + +data Except + = ThingNotFound + | ServerError + | BadRequest + | UserError !String + | StringError !String + | TxIndexConflict ![TxHash] + | ServerTimeout + | RequestTooLarge + deriving (Show, Eq, Ord, Generic, NFData) + +instance Exception Except + +instance ScottyError Except where + stringError = StringError + showError = LazyText.pack . show + +instance ToJSON Except where + toJSON e = + A.object $ + case e of + ThingNotFound -> + [ "error" .= String "not-found-or-invalid-arg", + "message" .= String "Item not found or argument invalid" + ] + ServerError -> + [ "error" .= String "server-error", + "message" .= String "Server error" + ] + BadRequest -> + [ "error" .= String "bad-request", + "message" .= String "Invalid request" + ] + UserError msg' -> + [ "error" .= String "user-error", + "message" .= String (cs msg') + ] + StringError msg' -> + [ "error" .= String "string-error", + "message" .= String (cs msg') + ] + TxIndexConflict txids -> + [ "error" .= String "multiple-tx-index", + "message" .= String "Multiple txs match that index", + "txids" .= txids + ] + ServerTimeout -> + [ "error" .= String "server-timeout", + "message" .= String "Request is taking too long" + ] + RequestTooLarge -> + [ "error" .= String "request-too-large", + "message" .= String "Request body too large" + ] + +instance FromJSON Except where + parseJSON = + A.withObject "Except" $ \o -> do + ctr <- o .: "error" + msg' <- o .:? "message" .!= "" + case ctr of + String "not-found-or-invalid-arg" -> + return ThingNotFound + String "server-error" -> + return ServerError + String "bad-request" -> + return BadRequest + String "user-error" -> + return $ UserError msg' + String "string-error" -> + return $ StringError msg' + String "multiple-tx-index" -> do + txids <- o .: "txids" + return $ TxIndexConflict txids + String "server-timeout" -> + return ServerTimeout + String "request-too-large" -> + return RequestTooLarge + _ -> mzero + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +toIntTxId :: TxHash -> Word64 +toIntTxId h = + let bs = runPutS (serialize h) + Right w64 = runGetS getWord64be bs + in w64 `shift` (-11) + +data BinfoBlockId + = BinfoBlockHash !BlockHash + | BinfoBlockIndex !Word32 + deriving (Eq, Show, Read, Generic, NFData) + +instance Parsable BinfoBlockId where + parseParam t = + hex <> igr + where + hex = case hexToBlockHash (LazyText.toStrict t) of + Nothing -> Left "could not decode txid" + Just h -> Right $ BinfoBlockHash h + igr = BinfoBlockIndex <$> parseParam t + +data BinfoTxId + = BinfoTxIdHash !TxHash + | BinfoTxIdIndex !Word64 + deriving (Eq, Show, Read, Generic, NFData) + +encodeBinfoTxId :: Bool -> TxHash -> BinfoTxId +encodeBinfoTxId False = BinfoTxIdHash +encodeBinfoTxId True = BinfoTxIdIndex . toIntTxId + +instance Parsable BinfoTxId where + parseParam t = + hex <> igr + where + hex = + case hexToTxHash (LazyText.toStrict t) of + Nothing -> Left "could not decode txid" + Just h -> Right $ BinfoTxIdHash h + igr = BinfoTxIdIndex <$> parseParam t + +instance ToJSON BinfoTxId where + toJSON (BinfoTxIdHash h) = toJSON h + toJSON (BinfoTxIdIndex i) = toJSON i + toEncoding (BinfoTxIdHash h) = toEncoding h + toEncoding (BinfoTxIdIndex i) = A.word64 i + +instance FromJSON BinfoTxId where + parseJSON v = + BinfoTxIdHash <$> parseJSON v + <|> BinfoTxIdIndex <$> parseJSON v + +data BinfoFilter + = BinfoFilterAll + | BinfoFilterSent + | BinfoFilterReceived + | BinfoFilterMoved + | BinfoFilterConfirmed + | BinfoFilterMempool + deriving (Eq, Show, Generic, NFData) + +instance Parsable BinfoFilter where + parseParam t = + parseParam t >>= \case + (0 :: Int) -> return BinfoFilterAll + 1 -> return BinfoFilterSent + 2 -> return BinfoFilterReceived + 3 -> return BinfoFilterMoved + 5 -> return BinfoFilterConfirmed + 6 -> return BinfoFilterAll + 7 -> return BinfoFilterMempool + _ -> Left "could not parse filter parameter" + +data BinfoMultiAddr = BinfoMultiAddr + { addresses :: ![BinfoBalance], + wallet :: !BinfoWallet, + txs :: ![BinfoTx], + info :: !BinfoInfo, + recommendFee :: !Bool, + cashAddr :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoMultiAddr where + marshalValue (net', ctx) m = + A.object $ + [ "addresses" .= map (marshalValue (net, ctx)) m.addresses, + "wallet" .= m.wallet, + "txs" .= map (marshalValue (net, ctx)) m.txs, + "info" .= m.info, + "recommend_include_fee" .= m.recommendFee + ] + ++ ["cash_addr" .= True | m.cashAddr] + where + net = if not m.cashAddr && net' == bch then btc else net' + + unmarshalValue (net, ctx) = + A.withObject "BinfoMultiAddr" $ \o -> do + addresses <- mapM (unmarshalValue (net, ctx)) =<< o .: "addresses" + wallet <- o .: "wallet" + txs <- mapM (unmarshalValue (net, ctx)) =<< o .: "txs" + info <- o .: "info" + recommendFee <- o .: "recommend_include_fee" + cashAddr <- o .:? "cash_addr" .!= False + return BinfoMultiAddr {..} + + marshalEncoding (net', ctx) m = + A.pairs $ + mconcat + [ "addresses" `A.pair` A.list (marshalEncoding (net, ctx)) m.addresses, + "wallet" `A.pair` toEncoding m.wallet, + "txs" `A.pair` A.list (marshalEncoding (net, ctx)) m.txs, + "info" `A.pair` toEncoding m.info, + "recommend_include_fee" `A.pair` A.bool m.recommendFee, + if m.cashAddr then "cash_addr" `A.pair` A.bool True else mempty + ] + where + net = if not m.cashAddr && net' == bch then btc else net' + +data BinfoRawAddr = BinfoRawAddr + { address :: !BinfoAddr, + balance :: !Word64, + ntx :: !Word64, + utxo :: !Word64, + received :: !Word64, + sent :: !Int64, + txs :: ![BinfoTx] + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoRawAddr where + marshalValue (net, ctx) r = + A.object + [ "hash160" .= h160, + "address" .= address, + "n_tx" .= r.ntx, + "n_unredeemed" .= r.utxo, + "total_received" .= r.received, + "total_sent" .= r.sent, + "final_balance" .= r.balance, + "txs" .= map (marshalValue (net, ctx)) r.txs + ] + where + address = case r.address of + BinfoAddr a -> marshalValue net a + BinfoXpub x -> marshalValue (net, ctx) x + h160 = + encodeHex . runPutS . serialize + <$> case r.address of + BinfoAddr a -> case a of + PubKeyAddress h -> Just h + ScriptAddress h -> Just h + WitnessPubKeyAddress h -> Just h + _ -> Nothing + _ -> Nothing + + marshalEncoding (net, ctx) r = + A.pairs $ + mconcat + [ "hash160" `A.pair` fromMaybe A.null_ h160, + "address" `A.pair` address, + "n_tx" `A.pair` A.word64 r.ntx, + "n_unredeemed" `A.pair` A.word64 r.utxo, + "total_received" `A.pair` A.word64 r.received, + "total_sent" `A.pair` A.int64 r.sent, + "final_balance" `A.pair` A.word64 r.balance, + "txs" `A.pair` A.list (marshalEncoding (net, ctx)) r.txs + ] + where + address = case r.address of + BinfoAddr a -> marshalEncoding net a + BinfoXpub x -> marshalEncoding (net, ctx) x + h160 = + hexEncoding . runPutL . serialize + <$> case r.address of + BinfoAddr a -> case a of + PubKeyAddress h -> Just h + ScriptAddress h -> Just h + WitnessPubKeyAddress h -> Just h + _ -> Nothing + _ -> Nothing + + unmarshalValue (net, ctx) = + A.withObject "BinfoRawAddr" $ \o -> do + addr <- o .: "address" + address <- + BinfoAddr <$> unmarshalValue net addr + <|> BinfoXpub <$> unmarshalValue (net, ctx) addr + balance <- o .: "final_balance" + utxo <- o .: "n_unredeemed" + ntx <- o .: "n_tx" + received <- o .: "total_received" + sent <- o .: "total_sent" + txs <- mapM (unmarshalValue (net, ctx)) =<< o .: "txs" + return BinfoRawAddr {..} + +data BinfoShortBal = BinfoShortBal + { final :: !Word64, + ntx :: !Word64, + received :: !Word64 + } + deriving (Eq, Show, Read, Generic, NFData) + +instance ToJSON BinfoShortBal where + toJSON b = + A.object + [ "final_balance" .= b.final, + "n_tx" .= b.ntx, + "total_received" .= b.received + ] + toEncoding b = + A.pairs $ + mconcat + [ "final_balance" `A.pair` A.word64 b.final, + "n_tx" `A.pair` A.word64 b.ntx, + "total_received" `A.pair` A.word64 b.received + ] + +instance FromJSON BinfoShortBal where + parseJSON = + A.withObject "BinfoShortBal" $ \o -> do + final <- o .: "final_balance" + ntx <- o .: "n_tx" + received <- o .: "total_received" + return BinfoShortBal {..} + +data BinfoBalance + = BinfoAddrBalance + { address :: !Address, + txs :: !Word64, + received :: !Word64, + sent :: !Word64, + balance :: !Word64 + } + | BinfoXPubBalance + { xpub :: !XPubKey, + txs :: !Word64, + received :: !Word64, + sent :: !Word64, + balance :: !Word64, + external :: !Word32, + change :: !Word32 + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoBalance where + marshalValue (net, ctx) b@BinfoAddrBalance {} = + A.object + [ "address" .= marshalValue net b.address, + "final_balance" .= b.balance, + "n_tx" .= b.txs, + "total_received" .= b.received, + "total_sent" .= b.sent + ] + marshalValue (net, ctx) b@BinfoXPubBalance {} = + A.object + [ "address" .= marshalValue (net, ctx) b.xpub, + "change_index" .= b.change, + "account_index" .= b.external, + "final_balance" .= b.balance, + "n_tx" .= b.txs, + "total_received" .= b.received, + "total_sent" .= b.sent + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoBalance" $ \o -> x o <|> a o + where + x o = do + xpub <- unmarshalValue (net, ctx) =<< o .: "address" + change <- o .: "change_index" + external <- o .: "account_index" + balance <- o .: "final_balance" + txs <- o .: "n_tx" + received <- o .: "total_received" + sent <- o .: "total_sent" + return BinfoXPubBalance {..} + a o = do + address <- unmarshalValue net =<< o .: "address" + balance <- o .: "final_balance" + txs <- o .: "n_tx" + received <- o .: "total_received" + sent <- o .: "total_sent" + return BinfoAddrBalance {..} + + marshalEncoding (net, ctx) b@BinfoAddrBalance {} = + A.pairs $ + mconcat + [ "address" `A.pair` marshalEncoding net b.address, + "final_balance" `A.pair` A.word64 b.balance, + "n_tx" `A.pair` A.word64 b.txs, + "total_received" `A.pair` A.word64 b.received, + "total_sent" `A.pair` A.word64 b.sent + ] + marshalEncoding (net, ctx) b@BinfoXPubBalance {} = + A.pairs $ + mconcat + [ "address" `A.pair` marshalEncoding (net, ctx) b.xpub, + "change_index" `A.pair` A.word32 b.change, + "account_index" `A.pair` A.word32 b.external, + "final_balance" `A.pair` A.word64 b.balance, + "n_tx" `A.pair` A.word64 b.txs, + "total_received" `A.pair` A.word64 b.received, + "total_sent" `A.pair` A.word64 b.sent + ] + +instance MarshalJSON (Network, Ctx) [BinfoBalance] where + marshalValue (net, ctx) addrs = + toJSON $ map (marshalValue (net, ctx)) addrs + marshalEncoding (net, ctx) = + A.list (marshalEncoding (net, ctx)) + unmarshalValue (net, ctx) = + A.withArray "[BinfoBalance]" $ + fmap V.toList . mapM (unmarshalValue (net, ctx)) + +data BinfoWallet = BinfoWallet + { balance :: !Word64, + txs :: !Word64, + filtered :: !Word64, + received :: !Word64, + sent :: !Word64 + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoWallet where + toJSON w = + A.object + [ "final_balance" .= w.balance, + "n_tx" .= w.txs, + "n_tx_filtered" .= w.filtered, + "total_received" .= w.received, + "total_sent" .= w.sent + ] + toEncoding w = + A.pairs $ + mconcat + [ "final_balance" `A.pair` A.word64 w.balance, + "n_tx" `A.pair` A.word64 w.txs, + "n_tx_filtered" `A.pair` A.word64 w.filtered, + "total_received" `A.pair` A.word64 w.received, + "total_sent" `A.pair` A.word64 w.sent + ] + +instance FromJSON BinfoWallet where + parseJSON = + A.withObject "BinfoWallet" $ \o -> do + balance <- o .: "final_balance" + txs <- o .: "n_tx" + filtered <- o .: "n_tx_filtered" + received <- o .: "total_received" + sent <- o .: "total_sent" + return BinfoWallet {..} + +binfoHexValue :: Word64 -> Text +binfoHexValue w64 = + encodeHex $ + if B.null bs || B.head bs `testBit` 7 + then B.cons 0x00 bs + else bs + where + bs = + B.dropWhile (== 0x00) $ + runPutS $ + serialize w64 + +data BinfoUnspent = BinfoUnspent + { txid :: !TxHash, + index :: !Word32, + script :: !ByteString, + value :: !Word64, + confirmations :: !Int32, + txidx :: !BinfoTxId, + xpub :: !(Maybe BinfoXPubPath) + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoUnspent where + marshalValue (net, ctx) u = + A.object $ + [ "tx_hash_big_endian" .= u.txid, + "tx_hash" .= encodeHex (runPutS (serialize u.txid.get)), + "tx_output_n" .= u.index, + "script" .= encodeHex u.script, + "value" .= u.value, + "value_hex" .= binfoHexValue u.value, + "confirmations" .= u.confirmations, + "tx_index" .= u.txidx + ] + <> [ "xpub" .= marshalValue (net, ctx) x + | x <- maybeToList u.xpub + ] + + marshalEncoding (net, ctx) u = + A.pairs $ + mconcat + [ "tx_hash_big_endian" `A.pair` toEncoding u.txid, + "tx_hash" `A.pair` hexEncoding (runPutL (serialize u.txid.get)), + "tx_output_n" `A.pair` A.word32 u.index, + "script" `A.pair` hexEncoding (B.fromStrict u.script), + "value" `A.pair` A.word64 u.value, + "value_hex" `A.pair` A.text (binfoHexValue u.value), + "confirmations" `A.pair` A.int32 u.confirmations, + "tx_index" `A.pair` toEncoding u.txidx, + maybe mempty (("xpub" `A.pair`) . marshalEncoding (net, ctx)) u.xpub + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoUnspent" $ \o -> do + txid <- o .: "tx_hash_big_endian" + index <- o .: "tx_output_n" + script <- maybe mzero return . decodeHex =<< o .: "script" + value <- o .: "value" + confirmations <- o .: "confirmations" + txidx <- o .: "tx_index" + xpub <- mapM (unmarshalValue (net, ctx)) =<< o .:? "xpub" + return BinfoUnspent {..} + +newtype BinfoUnspents = BinfoUnspents [BinfoUnspent] + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoUnspents where + marshalValue (net, ctx) (BinfoUnspents us) = + A.object + [ "notice" .= T.empty, + "unspent_outputs" .= map (marshalValue (net, ctx)) us + ] + + marshalEncoding (net, ctx) (BinfoUnspents us) = + A.pairs $ + mconcat + [ "notice" `A.pair` A.text T.empty, + "unspent_outputs" `A.pair` A.list (marshalEncoding (net, ctx)) us + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoUnspents" $ \o -> do + us <- mapM (unmarshalValue (net, ctx)) =<< o .: "unspent_outputs" + return (BinfoUnspents us) + +toBinfoBlock :: BlockData -> [BinfoTx] -> [BlockHash] -> BinfoBlock +toBinfoBlock b transactions next_blocks = + BinfoBlock + { hash = headerHash b.header, + version = b.header.version, + prev = b.header.prev, + merkle = b.header.merkle, + timestamp = b.header.timestamp, + bits = b.header.bits, + next = next_blocks, + fee = b.fee, + nonce = b.header.nonce, + ntx = fromIntegral (length transactions), + size = b.size, + index = b.height, + main = b.main, + height = b.height, + weight = b.weight, + txs = transactions + } + +data BinfoBlock = BinfoBlock + { hash :: !BlockHash, + version :: !Word32, + prev :: !BlockHash, + merkle :: !Hash256, + timestamp :: !Word32, + bits :: !Word32, + next :: ![BlockHash], + fee :: !Word64, + nonce :: !Word32, + ntx :: !Word32, + size :: !Word32, + index :: !Word32, + main :: !Bool, + height :: !Word32, + weight :: !Word32, + txs :: ![BinfoTx] + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoBlock where + marshalValue (net, ctx) b = + A.object + [ "hash" .= b.hash, + "ver" .= b.version, + "prev_block" .= b.prev, + "mrkl_root" .= TxHash b.merkle, + "time" .= b.timestamp, + "bits" .= b.bits, + "next_block" .= b.next, + "fee" .= b.fee, + "nonce" .= b.nonce, + "n_tx" .= b.ntx, + "size" .= b.size, + "block_index" .= b.index, + "main_chain" .= b.main, + "height" .= b.height, + "weight" .= b.weight, + "tx" .= map (marshalValue (net, ctx)) b.txs + ] + + marshalEncoding (net, ctx) b = + A.pairs $ + mconcat + [ "hash" `A.pair` toEncoding b.hash, + "ver" `A.pair` A.word32 b.version, + "prev_block" `A.pair` toEncoding b.prev, + "mrkl_root" `A.pair` toEncoding (TxHash b.merkle), + "time" `A.pair` A.word32 b.timestamp, + "bits" `A.pair` A.word32 b.bits, + "next_block" `A.pair` toEncoding b.next, + "fee" `A.pair` A.word64 b.fee, + "nonce" `A.pair` A.word32 b.nonce, + "n_tx" `A.pair` A.word32 b.ntx, + "size" `A.pair` A.word32 b.size, + "block_index" `A.pair` A.word32 b.index, + "main_chain" `A.pair` A.bool b.main, + "height" `A.pair` A.word32 b.height, + "weight" `A.pair` A.word32 b.weight, + "tx" `A.pair` A.list (marshalEncoding (net, ctx)) b.txs + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoBlock" $ \o -> do + hash <- o .: "hash" + version <- o .: "ver" + prev <- o .: "prev_block" + merkle <- (\(TxHash h) -> h) <$> o .: "mrkl_root" + timestamp <- o .: "time" + bits <- o .: "bits" + next <- o .: "next_block" + fee <- o .: "fee" + nonce <- o .: "nonce" + ntx <- o .: "n_tx" + size <- o .: "size" + index <- o .: "block_index" + main <- o .: "main_chain" + height <- o .: "height" + weight <- o .: "weight" + txs <- o .: "tx" >>= mapM (unmarshalValue (net, ctx)) + return BinfoBlock {..} + +instance MarshalJSON (Network, Ctx) [BinfoBlock] where + marshalValue (net, ctx) blocks = + A.object ["blocks" .= map (marshalValue (net, ctx)) blocks] + + marshalEncoding (net, ctx) blocks = + A.pairs $ "blocks" `A.pair` A.list (marshalEncoding (net, ctx)) blocks + + unmarshalValue (net, ctx) = + A.withObject "blocks" $ \o -> + mapM (unmarshalValue (net, ctx)) =<< o .: "blocks" + +data BinfoTx = BinfoTx + { txid :: !TxHash, + version :: !Word32, + inputCount :: !Word32, + outputCount :: !Word32, + size :: !Word32, + weight :: !Word32, + fee :: !Word64, + relayed :: !ByteString, + locktime :: !Word32, + index :: !BinfoTxId, + doubleSpend :: !Bool, + rbf :: !Bool, + balance :: !(Maybe (Int64, Int64)), + timestamp :: !Word64, + blockIndex :: !(Maybe Word32), + blockHeight :: !(Maybe Word32), + inputs :: ![BinfoTxInput], + outputs :: ![BinfoTxOutput] + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoTx where + marshalValue (net, ctx) t = + A.object $ + [ "hash" .= t.txid, + "ver" .= t.version, + "vin_sz" .= t.inputCount, + "vout_sz" .= t.outputCount, + "size" .= t.size, + "weight" .= t.weight, + "fee" .= t.fee, + "relayed_by" .= T.decodeUtf8 t.relayed, + "lock_time" .= t.locktime, + "tx_index" .= t.index, + "double_spend" .= t.doubleSpend, + "time" .= t.timestamp, + "block_index" .= t.blockIndex, + "block_height" .= t.blockHeight, + "inputs" .= map (marshalValue (net, ctx)) t.inputs, + "out" .= map (marshalValue (net, ctx)) t.outputs + ] + ++ bal + ++ rbf + where + bal = + case t.balance of + Nothing -> [] + Just (r, b) -> ["result" .= r, "balance" .= b] + rbf = ["rbf" .= True | t.rbf] + + marshalEncoding (net, ctx) t = + A.pairs $ + mconcat + [ "hash" `A.pair` toEncoding t.txid, + "ver" `A.pair` A.word32 t.version, + "vin_sz" `A.pair` A.word32 t.inputCount, + "vout_sz" `A.pair` A.word32 t.outputCount, + "size" `A.pair` A.word32 t.size, + "weight" `A.pair` A.word32 t.weight, + "fee" `A.pair` A.word64 t.fee, + "relayed_by" `A.pair` A.text (T.decodeUtf8 t.relayed), + "lock_time" `A.pair` A.word32 t.locktime, + "tx_index" `A.pair` toEncoding t.index, + "double_spend" `A.pair` A.bool t.doubleSpend, + "time" `A.pair` A.word64 t.timestamp, + "block_index" `A.pair` toEncoding t.blockIndex, + "block_height" `A.pair` maybe A.null_ A.word32 t.blockHeight, + "inputs" `A.pair` A.list (marshalEncoding (net, ctx)) t.inputs, + "out" `A.pair` A.list (marshalEncoding (net, ctx)) t.outputs, + bal, + rbf + ] + where + bal = + case t.balance of + Nothing -> mempty + Just (r, b) -> + "result" `A.pair` A.int64 r <> "balance" `A.pair` A.int64 b + rbf = if t.rbf then "rbf" .= True else mempty + + unmarshalValue (net, ctx) = A.withObject "BinfoTx" $ \o -> do + txid <- o .: "hash" + version <- o .: "ver" + inputCount <- o .: "vin_sz" + outputCount <- o .: "vout_sz" + size <- o .: "size" + weight <- o .: "weight" + fee <- o .: "fee" + relayed <- T.encodeUtf8 <$> o .: "relayed_by" + locktime <- o .: "lock_time" + index <- o .: "tx_index" + doubleSpend <- o .: "double_spend" + timestamp <- o .: "time" + blockIndex <- o .: "block_index" + blockHeight <- o .: "block_height" + inputs <- o .: "inputs" >>= mapM (unmarshalValue (net, ctx)) + outputs <- o .: "out" >>= mapM (unmarshalValue (net, ctx)) + rbf <- o .:? "rbf" .!= False + res <- o .:? "result" + bal <- o .:? "balance" + let balance = (,) <$> res <*> bal + return BinfoTx {..} + +instance MarshalJSON (Network, Ctx) [BinfoTx] where + marshalValue (net, ctx) txs = + toJSON $ map (marshalValue (net, ctx)) txs + marshalEncoding (net, ctx) = + A.list (marshalEncoding (net, ctx)) + unmarshalValue (net, ctx) = + A.withArray "[BinfoTx]" $ + fmap V.toList . mapM (unmarshalValue (net, ctx)) + +data BinfoTxInput = BinfoTxInput + { sequence :: !Word32, + witness :: !ByteString, + script :: !ByteString, + index :: !Word32, + output :: !BinfoTxOutput + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoTxInput where + marshalValue (net, ctx) i = + A.object + [ "sequence" .= i.sequence, + "witness" .= encodeHex i.witness, + "script" .= encodeHex i.script, + "index" .= i.index, + "prev_out" .= marshalValue (net, ctx) i.output + ] + + marshalEncoding (net, ctx) i = + A.pairs $ + mconcat + [ "sequence" `A.pair` A.word32 i.sequence, + "witness" `A.pair` hexEncoding (B.fromStrict i.witness), + "script" `A.pair` hexEncoding (B.fromStrict i.script), + "index" `A.pair` A.word32 i.index, + "prev_out" `A.pair` marshalEncoding (net, ctx) i.output + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoTxInput" $ \o -> do + sequence <- o .: "sequence" + witness <- + maybe mzero return . decodeHex + =<< o .: "witness" + script <- + maybe mzero return . decodeHex + =<< o .: "script" + index <- o .: "index" + output <- + o .: "prev_out" + >>= unmarshalValue (net, ctx) + return BinfoTxInput {..} + +data BinfoTxOutput = BinfoTxOutput + { typ :: !Int, + spent :: !Bool, + value :: !Word64, + index :: !Word32, + txidx :: !BinfoTxId, + script :: !ByteString, + spenders :: ![BinfoSpender], + address :: !(Maybe Address), + xpub :: !(Maybe BinfoXPubPath) + } + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoTxOutput where + marshalValue (net, ctx) o = + A.object $ + [ "type" .= o.typ, + "spent" .= o.spent, + "value" .= o.value, + "spending_outpoints" .= o.spenders, + "n" .= o.index, + "tx_index" .= o.txidx, + "script" .= encodeHex o.script + ] + <> [ "addr" .= marshalValue net a + | a <- maybeToList o.address + ] + <> [ "xpub" .= marshalValue (net, ctx) x + | x <- maybeToList o.xpub + ] + + marshalEncoding (net, ctx) o = + A.pairs $ + mconcat $ + [ "type" `A.pair` A.int o.typ, + "spent" `A.pair` A.bool o.spent, + "value" `A.pair` A.word64 o.value, + "spending_outpoints" `A.pair` A.list toEncoding o.spenders, + "n" `A.pair` A.word32 o.index, + "tx_index" `A.pair` toEncoding o.txidx, + "script" `A.pair` hexEncoding (B.fromStrict o.script) + ] + <> [ "addr" `A.pair` marshalEncoding net a + | a <- maybeToList o.address + ] + <> [ "xpub" `A.pair` marshalEncoding (net, ctx) x + | x <- maybeToList o.xpub + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoTxOutput" $ \o -> do + typ <- o .: "type" + spent <- o .: "spent" + value <- o .: "value" + spenders <- o .: "spending_outpoints" + index <- o .: "n" + txidx <- o .: "tx_index" + script <- maybe mzero return . decodeHex =<< o .: "script" + address <- o .:? "addr" >>= mapM (unmarshalValue net) + xpub <- o .:? "xpub" >>= mapM (unmarshalValue (net, ctx)) + return BinfoTxOutput {..} + +data BinfoSpender = BinfoSpender + { txidx :: !BinfoTxId, + input :: !Word32 + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoSpender where + toJSON s = + A.object + [ "tx_index" .= s.txidx, + "n" .= s.input + ] + toEncoding s = + A.pairs $ + mconcat + [ "tx_index" `A.pair` toEncoding s.txidx, + "n" `A.pair` A.word32 s.input + ] + +instance FromJSON BinfoSpender where + parseJSON = + A.withObject "BinfoSpender" $ \o -> do + txidx <- o .: "tx_index" + input <- o .: "n" + return BinfoSpender {..} + +data BinfoXPubPath = BinfoXPubPath + { key :: !XPubKey, + deriv :: !SoftPath + } + deriving (Eq, Show, Generic, NFData) + +instance Ord BinfoXPubPath where + compare = compare `on` f + where + f b = + ( b.key.parent, + b.deriv + ) + +instance MarshalJSON (Network, Ctx) BinfoXPubPath where + marshalValue (net, ctx) p = + A.object + [ "m" .= marshalValue (net, ctx) p.key, + "path" .= ("M" ++ pathToStr p.deriv) + ] + + marshalEncoding (net, ctx) p = + A.pairs $ + mconcat + [ "m" `A.pair` marshalEncoding (net, ctx) p.key, + "path" `A.pair` A.string ("M" ++ pathToStr p.deriv) + ] + + unmarshalValue (net, ctx) = + A.withObject "BinfoXPubPath" $ \o -> do + key <- o .: "m" >>= unmarshalValue (net, ctx) + deriv <- fromMaybe "bad xpub path" . parseSoft <$> o .: "path" + return BinfoXPubPath {..} + +data BinfoInfo = BinfoInfo + { connected :: !Word32, + conversion :: !Double, + fiat :: !BinfoSymbol, + crypto :: !BinfoSymbol, + head :: !BinfoBlockInfo + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoInfo where + toJSON i = + A.object + [ "nconnected" .= i.connected, + "conversion" .= i.conversion, + "symbol_local" .= i.fiat, + "symbol_btc" .= i.crypto, + "latest_block" .= i.head + ] + toEncoding i = + A.pairs $ + mconcat + [ "nconnected" `A.pair` A.word32 i.connected, + "conversion" `A.pair` A.double i.conversion, + "symbol_local" `A.pair` toEncoding i.fiat, + "symbol_btc" `A.pair` toEncoding i.crypto, + "latest_block" `A.pair` toEncoding i.head + ] + +instance FromJSON BinfoInfo where + parseJSON = + A.withObject "BinfoInfo" $ \o -> do + connected <- o .: "nconnected" + conversion <- o .: "conversion" + fiat <- o .: "symbol_local" + crypto <- o .: "symbol_btc" + head <- o .: "latest_block" + return BinfoInfo {..} + +data BinfoBlockInfo = BinfoBlockInfo + { hash :: !BlockHash, + height :: !BlockHeight, + timestamp :: !Word32, + index :: !BlockHeight + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoBlockInfo where + toJSON i = + A.object + [ "hash" .= i.hash, + "height" .= i.height, + "time" .= i.timestamp, + "block_index" .= i.index + ] + toEncoding i = + A.pairs $ + mconcat + [ "hash" `A.pair` toEncoding i.hash, + "height" `A.pair` A.word32 i.height, + "time" `A.pair` A.word32 i.timestamp, + "block_index" `A.pair` A.word32 i.index + ] + +instance FromJSON BinfoBlockInfo where + parseJSON = + A.withObject "BinfoBlockInfo" $ \o -> do + hash <- o .: "hash" + height <- o .: "height" + timestamp <- o .: "time" + index <- o .: "block_index" + return BinfoBlockInfo {..} + +toBinfoBlockInfo :: BlockData -> BinfoBlockInfo +toBinfoBlockInfo d = + BinfoBlockInfo + { hash = headerHash d.header, + height = d.height, + timestamp = d.header.timestamp, + index = d.height + } + +data BinfoRate = BinfoRate + { timestamp :: !Word64, + price :: !Double, + vol24 :: !Double + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoRate where + toJSON r = + A.object + [ "timestamp" .= r.timestamp, + "price" .= r.price, + "volume24h" .= r.vol24 + ] + toEncoding r = + A.pairs $ + mconcat + [ "timestamp" `A.pair` A.word64 r.timestamp, + "price" `A.pair` A.double r.price, + "volume24h" `A.pair` A.double r.vol24 + ] + +instance FromJSON BinfoRate where + parseJSON = + A.withObject "BinfoRate" $ \o -> do + timestamp <- o .: "timestamp" + price <- o .: "price" + vol24 <- o .: "volume24h" + return BinfoRate {..} + +data BinfoHistory = BinfoHistory + { date :: !Text, + time :: !Text, + typ :: !Text, + amount :: !Double, + valueThen :: !Double, + valueNow :: !Double, + rateThen :: !Double, + txid :: !TxHash, + fee :: !Double + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoHistory where + toJSON h = + A.object + [ "date" .= h.date, + "time" .= h.time, + "type" .= h.typ, + "amount" .= h.amount, + "value_then" .= h.valueThen, + "value_now" .= h.valueNow, + "exchange_rate_then" .= h.rateThen, + "tx" .= h.txid, + "fee" .= h.fee + ] + toEncoding h = + A.pairs $ + mconcat + [ "date" `A.pair` A.text h.date, + "time" `A.pair` A.text h.time, + "type" `A.pair` A.text h.typ, + "amount" `A.pair` A.double h.amount, + "value_then" `A.pair` A.double h.valueThen, + "value_now" `A.pair` A.double h.valueNow, + "exchange_rate_then" `A.pair` A.double h.rateThen, + "tx" `A.pair` toEncoding h.txid, + "fee" `A.pair` A.double h.fee + ] + +instance FromJSON BinfoHistory where + parseJSON = + A.withObject "BinfoHistory" $ \o -> do + date <- o .: "date" + time <- o .: "time" + typ <- o .: "type" + amount <- o .: "amount" + valueThen <- o .: "value_then" + valueNow <- o .: "value_now" + rateThen <- o .: "exchange_rate_then" + txid <- o .: "tx" + fee <- o .: "fee" + return BinfoHistory {..} + +toBinfoHistory :: + Int64 -> + Word64 -> + Double -> + Double -> + Word64 -> + TxHash -> + BinfoHistory +toBinfoHistory satoshi timestamp rateThen rateNow fee txid = + BinfoHistory + { date = T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" t, + time = T.pack $ formatTime defaultTimeLocale "%H:%M:%S GMT %Ez" t, + typ = if satoshi <= 0 then "sent" else "received", + amount = fromRational v, + fee = fromRational f, + valueThen = fromRational v1, + valueNow = fromRational v2, + rateThen, + txid + } + where + t = posixSecondsToUTCTime (realToFrac timestamp) + v = toRational satoshi / (100 * 1000 * 1000) + r1 = toRational rateThen + r2 = toRational rateNow + f = toRational fee / (100 * 1000 * 1000) + v1 = v * r1 + v2 = v * r2 + +newtype BinfoDate = BinfoDate Word64 + deriving (Eq, Show, Read, Generic, NFData) + +instance Parsable BinfoDate where + parseParam t = + maybeToEither "Cannot parse date" + . fmap (BinfoDate . round . utcTimeToPOSIXSeconds) + $ p "%d-%m-%Y" <|> p "%d/%m/%Y" + where + s = LazyText.unpack t + p fmt = parseTimeM False defaultTimeLocale fmt s + +data BinfoTicker = BinfoTicker + { fifteen :: !Double, + last :: !Double, + buy :: !Double, + sell :: !Double, + symbol :: !Text + } + deriving (Eq, Show, Generic, NFData) + +instance Default BinfoTicker where + def = + BinfoTicker + { symbol = "XXX", + fifteen = 0.0, + last = 0.0, + buy = 0.0, + sell = 0.0 + } + +instance ToJSON BinfoTicker where + toJSON t = + A.object + [ "symbol" .= t.symbol, + "sell" .= t.sell, + "buy" .= t.buy, + "last" .= t.last, + "15m" .= t.fifteen + ] + toEncoding t = + A.pairs $ + mconcat + [ "symbol" `A.pair` A.text t.symbol, + "sell" `A.pair` A.double t.sell, + "buy" `A.pair` A.double t.buy, + "last" `A.pair` A.double t.last, + "15m" `A.pair` A.double t.fifteen + ] + +instance FromJSON BinfoTicker where + parseJSON = + A.withObject "BinfoTicker" $ \o -> do + symbol <- o .: "symbol" + fifteen <- o .: "15m" + sell <- o .: "sell" + buy <- o .: "buy" + last <- o .: "last" + return BinfoTicker {..} + +data BinfoSymbol = BinfoSymbol + { code :: !Text, + symbol :: !Text, + name :: !Text, + conversion :: !Double, + after :: !Bool, + local :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +instance Default BinfoSymbol where + def = + BinfoSymbol + { code = "XXX", + symbol = "ยค", + name = "No currency", + conversion = 0.0, + after = False, + local = True + } + +instance ToJSON BinfoSymbol where + toJSON s = + A.object + [ "code" .= s.code, + "symbol" .= s.symbol, + "name" .= s.name, + "conversion" .= s.conversion, + "symbolAppearsAfter" .= s.after, + "local" .= s.local + ] + toEncoding s = + A.pairs $ + mconcat + [ "code" `A.pair` A.text s.code, + "symbol" `A.pair` A.text s.symbol, + "name" `A.pair` A.text s.name, + "conversion" `A.pair` A.double s.conversion, + "symbolAppearsAfter" `A.pair` A.bool s.after, + "local" `A.pair` A.bool s.local + ] + +instance FromJSON BinfoSymbol where + parseJSON = + A.withObject "BinfoSymbol" $ \o -> do + code <- o .: "code" + symbol <- o .: "symbol" + name <- o .: "name" + conversion <- o .: "conversion" + after <- o .: "symbolAppearsAfter" + local <- o .: "local" + return BinfoSymbol {..} + +relevantTxs :: + HashSet Address -> + Bool -> + Transaction -> + HashSet TxHash +relevantTxs addrs prune t = + HashSet.fromList $ ins <> outs + where + p a = + prune + && getTxResult addrs t > 0 + && not (HashSet.member a addrs) + f o = do + Spender {..} <- o.spender + a <- o.address + guard $ p a + return txid + outs = mapMaybe f t.outputs + g StoreCoinbase {} = Nothing + g StoreInput {outpoint = OutPoint h i} = Just h + ins = mapMaybe g t.inputs + +toBinfoAddrs :: + HashMap Address Balance -> + HashMap XPubSpec [XPubBal] -> + HashMap XPubSpec Word64 -> + [BinfoBalance] +toBinfoAddrs onlyAddrs onlyXpubs xpubTxs = + xpubBals <> addrBals + where + xpubBal k xs = + let f x = + case x.path of + [0, _] -> x.balance.received + _ -> 0 + g x = x.balance.confirmed + x.balance.unconfirmed + i m x = + case x.path of + [m', n] | m == m' -> n + 1 + _ -> 0 + received = sum $ map f xs + bal = fromIntegral $ sum $ map g xs + sent = if bal <= received then received - bal else 0 + count = HashMap.lookupDefault 0 k xpubTxs + ax = foldl max 0 $ map (i 0) xs + cx = foldl max 0 $ map (i 1) xs + in BinfoXPubBalance + { xpub = k.key, + txs = count, + received = received, + sent = sent, + balance = bal, + external = ax, + change = cx + } + xpubBals = map (uncurry xpubBal) $ HashMap.toList onlyXpubs + addrBals = + let f Balance {..} = + let sent = received - balance + balance = confirmed + unconfirmed + in BinfoAddrBalance {..} + in map f $ HashMap.elems onlyAddrs + +toBinfoTxSimple :: + Bool -> + Transaction -> + BinfoTx +toBinfoTxSimple numtxid = + toBinfoTx numtxid HashMap.empty False 0 + +toBinfoTxInputs :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Transaction -> + [BinfoTxInput] +toBinfoTxInputs numtxid abook t = + zipWith f [0 ..] t.inputs + where + f n i = + BinfoTxInput + { index = n, + sequence = i.sequence, + script = i.script, + witness = wit i, + output = prev n i + } + wit i = + case i.witness of + [] -> B.empty + ws -> runPutS (put_witness ws) + prev = inputToBinfoTxOutput numtxid abook t + put_witness ws = do + putVarInt (length ws) + mapM_ put_item ws + put_item bs = do + putVarInt (B.length bs) + putByteString bs + +transactionHeight :: Transaction -> Maybe BlockHeight +transactionHeight Transaction {deleted = True} = Nothing +transactionHeight Transaction {block = MemRef _} = Nothing +transactionHeight Transaction {block = BlockRef h _} = Just h + +toBinfoTx :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Bool -> + Int64 -> + Transaction -> + BinfoTx +toBinfoTx numtxid abook prune bal t = + BinfoTx + { version = t.version, + weight = t.weight, + relayed = "0.0.0.0", + txid = txHash tx, + index = encodeBinfoTxId numtxid (txHash tx), + inputCount = fromIntegral $ length t.inputs, + outputCount = fromIntegral $ length t.outputs, + blockIndex = transactionHeight t, + blockHeight = transactionHeight t, + doubleSpend = t.deleted, + balance = + if simple + then Nothing + else Just (getTxResult aset t, bal), + outputs = + let p = prune && getTxResult aset t > 0 + f = toBinfoTxOutput numtxid abook p t + in catMaybes $ zipWith f [0 ..] t.outputs, + inputs = toBinfoTxInputs numtxid abook t, + size = t.size, + rbf = t.rbf, + fee = t.fee, + locktime = t.locktime, + timestamp = t.timestamp + } + where + tx = transactionData t + aset = HashMap.keysSet abook + simple = HashMap.null abook && bal == 0 + +getTxResult :: HashSet Address -> Transaction -> Int64 +getTxResult aset t = + inputSum + outputSum + where + inputSum = sum $ map inputValue t.inputs + inputValue StoreCoinbase {} = 0 + inputValue StoreInput {..} = + case address of + Nothing -> 0 + Just a -> + if testAddr a + then negate $ fromIntegral value + else 0 + testAddr a = HashSet.member a aset + outputSum = sum $ map outValue t.outputs + outValue StoreOutput {..} = + case address of + Nothing -> 0 + Just a -> + if testAddr a + then fromIntegral value + else 0 + +toBinfoTxOutput :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Bool -> + Transaction -> + Word32 -> + StoreOutput -> + Maybe BinfoTxOutput +toBinfoTxOutput numtxid abook prune t index o = + if prune && notInBook + then Nothing + else + Just + BinfoTxOutput + { typ = 0, + spent = isJust o.spender, + value = o.value, + index = index, + txidx = encodeBinfoTxId numtxid $ txHash $ transactionData t, + script = o.script, + spenders = maybeToList $ toBinfoSpender numtxid <$> o.spender, + address = o.address, + xpub = o.address >>= join . flip HashMap.lookup abook + } + where + notInBook = isNothing $ o.address >>= flip HashMap.lookup abook + +toBinfoSpender :: Bool -> Spender -> BinfoSpender +toBinfoSpender numtxid s = + BinfoSpender + { txidx = encodeBinfoTxId numtxid s.txid, + input = s.index + } + +inputToBinfoTxOutput :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Transaction -> + Word32 -> + StoreInput -> + BinfoTxOutput +inputToBinfoTxOutput numtxid abook t n i = + BinfoTxOutput + { typ = 0, + spent = True, + txidx = encodeBinfoTxId numtxid i.outpoint.hash, + value = + case i of + StoreCoinbase {} -> 0 + StoreInput {value} -> value, + script = + case i of + StoreCoinbase {} -> B.empty + StoreInput {pkscript} -> pkscript, + address = + case i of + StoreCoinbase {} -> Nothing + StoreInput {address} -> address, + index = i.outpoint.index, + spenders = + [ BinfoSpender + (encodeBinfoTxId numtxid (txHash (transactionData t))) + n + ], + xpub = i.address >>= join . flip HashMap.lookup abook + } + +data BinfoAddr + = BinfoAddr !Address + | BinfoXpub !XPubKey + deriving (Eq, Show, Generic, Hashable, NFData) + +parseBinfoAddr :: Network -> Ctx -> Text -> Maybe [BinfoAddr] +parseBinfoAddr net ctx "" = Just [] +parseBinfoAddr net ctx s = + mapM f $ + filter (not . T.null) $ + concatMap (T.splitOn ",") (T.splitOn "|" s) + where + f x = + BinfoAddr <$> textToAddr net x + <|> BinfoXpub <$> xPubImport net ctx x + +data BinfoHeader = BinfoHeader + { hash :: !BlockHash, + timestamp :: !Timestamp, + index :: !Word32, + height :: !BlockHeight, + txids :: ![BinfoTxId] + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoHeader where + toJSON h = + A.object + [ "hash" .= h.hash, + "time" .= h.timestamp, + "block_index" .= h.index, + "height" .= h.height, + "txIndexes" .= h.txids + ] + toEncoding h = + A.pairs $ + mconcat + [ "hash" `A.pair` toEncoding h.hash, + "time" `A.pair` A.word32 h.timestamp, + "block_index" `A.pair` A.word32 h.index, + "height" `A.pair` A.word32 h.height, + "txIndexes" `A.pair` A.list toEncoding h.txids + ] + +instance FromJSON BinfoHeader where + parseJSON = + A.withObject "BinfoHeader" $ \o -> do + hash <- o .: "hash" + timestamp <- o .: "time" + index <- o .: "block_index" + height <- o .: "height" + txids <- o .: "txIndexes" + return BinfoHeader {..} + +newtype BinfoMempool = BinfoMempool {get :: [BinfoTx]} + deriving (Eq, Show, Generic, NFData) + +instance MarshalJSON (Network, Ctx) BinfoMempool where + marshalValue (net, ctx) (BinfoMempool txs) = + A.object ["txs" .= map (marshalValue (net, ctx)) txs] + + marshalEncoding (net, ctx) (BinfoMempool txs) = + A.pairs $ A.pair "txs" $ A.list (marshalEncoding (net, ctx)) txs + + unmarshalValue (net, ctx) = + A.withObject "BinfoMempool" $ \o -> + BinfoMempool <$> (mapM (unmarshalValue (net, ctx)) =<< o .: "txs") + +newtype BinfoBlockInfos = BinfoBlockInfos {get :: [BinfoBlockInfo]} + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoBlockInfos where + toJSON b = A.object ["blocks" .= b.get] + toEncoding b = + A.pairs $ A.pair "blocks" $ A.list toEncoding b.get + +instance FromJSON BinfoBlockInfos where + parseJSON = + A.withObject "BinfoBlockInfos" $ \o -> + BinfoBlockInfos <$> o .: "blocks" diff --git a/src/Haskoin/Store/WebClient.hs b/src/Haskoin/Store/WebClient.hs --- a/src/Haskoin/Store/WebClient.hs +++ b/src/Haskoin/Store/WebClient.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} module Haskoin.Store.WebClient ( ApiConfig (..), @@ -67,8 +71,8 @@ import Control.Exception import Control.Lens ((.~), (?~), (^.)) import Control.Monad.Except -import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy as BL +import Data.Aeson qualified as A +import Data.ByteString.Lazy qualified as BL import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -76,17 +80,17 @@ import Data.Monoid (Endo (..), appEndo) import Data.String.Conversions (cs) import Data.Text (Text) -import qualified Data.Text as Text -import Haskoin.Constants -import Haskoin.Data -import qualified Haskoin.Store.Data as Store +import Data.Text qualified as Text +import Haskoin.Crypto (Ctx) +import Haskoin.Network +import Haskoin.Store.Data qualified as Store import Haskoin.Store.WebCommon import Haskoin.Transaction import Haskoin.Util import Network.HTTP.Client (Request (..)) import Network.HTTP.Types (StdMethod (..)) import Network.HTTP.Types.Status -import qualified Network.Wreq as HTTP +import Network.Wreq qualified as HTTP import Network.Wreq.Types (ResponseChecker) import Numeric.Natural (Natural) @@ -95,40 +99,41 @@ -- -- @ -- ApiConfig --- { configNetwork = bch --- , configHost = "https://api.haskoin.com/" +-- { net = bch +-- , host = "https://api.haskoin.com/" -- } -- @ data ApiConfig = ApiConfig - { configNetwork :: !Network, - configHost :: !String + { net :: !Network, + host :: !String } deriving (Eq, Show) instance Default ApiConfig where def = ApiConfig - { configNetwork = bch, - configHost = "https://api.haskoin.com/" + { net = bch, + host = "https://api.haskoin.com/" } -- | Make a call to the haskoin-store API. -- -- Usage (default options): -- --- > apiCall def $ GetAddrsTxs addrs def +-- > apiCall ctx def $ GetAddrsTxs addrs def -- -- With options: -- --- > apiCall def $ GetAddrsUnspent addrs def{ paramLimit = Just 10 } +-- > apiCall ctx def $ GetAddrsUnspent addrs def{ paramLimit = Just 10 } apiCall :: (ApiResource a b, MonadIO m, MonadError Store.Except m) => + Ctx -> ApiConfig -> a -> m b -apiCall (ApiConfig net apiHost) res = do - args <- liftEither $ toOptions net res - let url = apiHost <> getNetworkName net <> cs (queryPath net res) +apiCall ctx (ApiConfig net apiHost) res = do + args <- liftEither $ toOptions net ctx res + let url = apiHost <> net.name <> cs (queryPath net ctx res) case resourceMethod $ asProxy res of GET -> liftEither =<< liftIO (getBinary args url) POST -> @@ -143,11 +148,13 @@ -- > apiBatch 20 def (GetAddrsTxs addrs def) apiBatch :: (Batchable a b, MonadIO m, MonadError Store.Except m) => + Ctx -> Natural -> ApiConfig -> a -> m b -apiBatch i conf res = mconcat <$> mapM (apiCall conf) (resourceBatch i res) +apiBatch ctx i conf res = + mconcat <$> mapM (apiCall ctx conf) (resourceBatch i res) class (ApiResource a b, Monoid b) => Batchable a b where resourceBatch :: Natural -> a -> [a] @@ -190,22 +197,33 @@ ------------------ toOptions :: - ApiResource a b => Network -> a -> Either Store.Except (Endo HTTP.Options) -toOptions net res = + (ApiResource a b) => + Network -> + Ctx -> + a -> + Either Store.Except (Endo HTTP.Options) +toOptions net ctx res = mconcat <$> mapM f (snd $ queryParams res) where - f (ParamBox p) = toOption net p + f (ParamBox p) = toOption net ctx p -toOption :: Param a => Network -> a -> Either Store.Except (Endo HTTP.Options) -toOption net a = do - res <- maybeToEither (Store.UserError "Invalid Param") $ encodeParam net a +toOption :: + (Param a) => + Network -> + Ctx -> + a -> + Either Store.Except (Endo HTTP.Options) +toOption net ctx a = do + res <- + maybeToEither (Store.UserError "Invalid Param") $ + encodeParam net ctx a return $ applyOpt (paramLabel a) res applyOpt :: Text -> [Text] -> Endo HTTP.Options applyOpt p t = Endo $ HTTP.param p .~ [Text.intercalate "," t] getBinary :: - Serial a => + (Serial a) => Endo HTTP.Options -> String -> IO (Either Store.Except a) @@ -239,11 +257,11 @@ | statusIsSuccessful status = return () | isHealthPath && code == 503 = return () -- Ignore health checks | otherwise = do - e <- A.decodeStrict <$> res ^. HTTP.responseBody - throwIO $ - case e of - Just except -> except :: Store.Except - Nothing -> Store.StringError "could not decode error" + e <- A.decodeStrict <$> res ^. HTTP.responseBody + throwIO $ + case e of + Just except -> except :: Store.Except + Nothing -> Store.StringError "could not decode error" where code = res ^. HTTP.responseStatus . HTTP.statusCode message = res ^. HTTP.responseStatus . HTTP.statusMessage @@ -258,4 +276,4 @@ chunksOf n xs | null xs = [] | otherwise = - uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs + uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs diff --git a/src/Haskoin/Store/WebCommon.hs b/src/Haskoin/Store/WebCommon.hs --- a/src/Haskoin/Store/WebCommon.hs +++ b/src/Haskoin/Store/WebCommon.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} module Haskoin.Store.WebCommon where @@ -16,7 +20,7 @@ import Data.String (IsString (..)) import Data.String.Conversions (cs) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Haskoin.Address import Haskoin.Block ( Block, @@ -24,22 +28,21 @@ blockHashToHex, hexToBlockHash, ) -import Haskoin.Constants -import Haskoin.Crypto (Hash256) -import Haskoin.Data -import Haskoin.Keys -import qualified Haskoin.Store.Data as Store +import Haskoin.Crypto (Ctx, Hash256) +import Haskoin.Crypto.Keys +import Haskoin.Network.Data +import Haskoin.Store.Data qualified as Store import Haskoin.Transaction import Network.HTTP.Types (StdMethod (..)) import Numeric.Natural (Natural) import Text.Read (readMaybe) -import qualified Web.Scotty.Trans as Scotty +import Web.Scotty.Trans qualified as Scotty ------------------- -- API Resources -- ------------------- -class Serial b => ApiResource a b | a -> b where +class (Serial b) => ApiResource a b | a -> b where resourceMethod :: Proxy a -> StdMethod resourceMethod _ = GET resourcePath :: Proxy a -> ([Text] -> Text) @@ -50,11 +53,11 @@ resourceBody :: a -> Maybe PostBox resourceBody = const Nothing -data PostBox = forall s. Serial s => PostBox !s +data PostBox = forall s. (Serial s) => PostBox !s data ParamBox = forall p. (Eq p, Param p) => ParamBox !p -data ProxyBox = forall p. Param p => ProxyBox !(Proxy p) +data ProxyBox = forall p. (Param p) => ProxyBox !(Proxy p) -------------------- -- Resource Paths -- @@ -352,7 +355,7 @@ -- Network -- ------------- -instance ApiResource GetPeers (Store.SerialList Store.PeerInformation) where +instance ApiResource GetPeers (Store.SerialList Store.PeerInfo) where resourcePath _ _ = "/peers" instance ApiResource GetHealth Store.HealthCheck where @@ -386,23 +389,23 @@ asProxy :: a -> Proxy a asProxy = const Proxy -queryPath :: ApiResource a b => Network -> a -> Text -queryPath net a = f $ encParam <$> fst (queryParams a) +queryPath :: (ApiResource a b) => Network -> Ctx -> a -> Text +queryPath net ctx a = f $ encParam <$> fst (queryParams a) where f = resourcePath $ asProxy a encParam (ParamBox p) = - case encodeParam net p of + case encodeParam net ctx p of Just [res] -> res _ -> error "Invalid query param" -capturePath :: ApiResource a b => Proxy a -> Scotty.RoutePattern +capturePath :: (ApiResource a b) => Proxy a -> Scotty.RoutePattern capturePath proxy = fromString $ cs $ f $ toLabel <$> captureParams proxy where f = resourcePath proxy toLabel (ProxyBox p) = ":" <> proxyLabel p -paramLabel :: Param p => p -> Text +paramLabel :: (Param p) => p -> Text paramLabel = proxyLabel . asProxy ------------- @@ -411,35 +414,29 @@ class Param a where proxyLabel :: Proxy a -> Text - encodeParam :: Network -> a -> Maybe [Text] - parseParam :: Network -> [Text] -> Maybe a + encodeParam :: Network -> Ctx -> a -> Maybe [Text] + parseParam :: Network -> Ctx -> [Text] -> Maybe a instance Param Address where proxyLabel = const "address" - encodeParam net a = (: []) <$> addrToText net a - parseParam net [a] = textToAddr net a - parseParam _ _ = Nothing + encodeParam net ctx a = (: []) <$> addrToText net a + parseParam net ctx [a] = textToAddr net a + parseParam net ctx _ = Nothing instance Param [Address] where proxyLabel = const "addresses" - encodeParam = mapM . addrToText - parseParam = mapM . textToAddr + encodeParam net ctx = mapM (addrToText net) + parseParam net ctx = mapM (textToAddr net) data StartParam - = StartParamHash - { startParamHash :: Hash256 - } - | StartParamHeight - { startParamHeight :: Natural - } - | StartParamTime - { startParamTime :: Store.UnixTime - } + = StartParamHash {hash :: Hash256} + | StartParamHeight {height :: Natural} + | StartParamTime {time :: Store.UnixTime} deriving (Eq, Show) instance Param StartParam where proxyLabel = const "height" - encodeParam _ p = + encodeParam net ctx p = case p of StartParamHash h -> return [txHashToHex (TxHash h)] StartParamHeight h -> do @@ -448,7 +445,8 @@ StartParamTime t -> do guard $ t > 1230768000 return [cs $ show t] - parseParam _ [s] = parseHash <|> parseHeight <|> parseUnix + parseParam net ctx [s] = + parseHash <|> parseHeight <|> parseUnix where parseHash = do guard (T.length s == 32 * 2) @@ -462,11 +460,9 @@ x <- readMaybe $ cs s guard $ x > 1230768000 return $ StartParamTime x - parseParam _ _ = Nothing + parseParam net ctx _ = Nothing -newtype OffsetParam = OffsetParam - { getOffsetParam :: Natural - } +newtype OffsetParam = OffsetParam {get :: Natural} deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Default OffsetParam where @@ -474,84 +470,74 @@ instance Param OffsetParam where proxyLabel = const "offset" - encodeParam _ (OffsetParam o) = Just [cs $ show o] - parseParam _ [s] = OffsetParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + encodeParam net ctx (OffsetParam o) = Just [cs $ show o] + parseParam net ctx [s] = OffsetParam <$> readMaybe (cs s) + parseParam net ctx _ = Nothing -newtype LimitParam = LimitParam - { getLimitParam :: Natural - } +newtype LimitParam = LimitParam {get :: Natural} deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Param LimitParam where proxyLabel = const "limit" - encodeParam _ (LimitParam l) = Just [cs $ show l] - parseParam _ [s] = LimitParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + encodeParam net ctx (LimitParam l) = Just [cs $ show l] + parseParam net ctx [s] = LimitParam <$> readMaybe (cs s) + parseParam net ctx _ = Nothing data LimitsParam = LimitsParam - { paramLimit :: Maybe LimitParam, -- 0 means maximum - paramOffset :: OffsetParam, - paramStart :: Maybe StartParam + { limit :: Maybe LimitParam, -- 0 means maximum + offset :: OffsetParam, + start :: Maybe StartParam } deriving (Eq, Show) instance Default LimitsParam where def = LimitsParam Nothing def Nothing -newtype HeightParam = HeightParam - { getHeightParam :: Natural - } +newtype HeightParam = HeightParam {get :: Natural} deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Param HeightParam where proxyLabel = const "height" - encodeParam _ (HeightParam h) = Just [cs $ show h] - parseParam _ [s] = HeightParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + encodeParam net ctx (HeightParam h) = Just [cs $ show h] + parseParam net ctx [s] = HeightParam <$> readMaybe (cs s) + parseParam net ctx _ = Nothing -newtype HeightsParam = HeightsParam - { getHeightsParam :: [Natural] - } +newtype HeightsParam = HeightsParam {get :: [Natural]} deriving (Eq, Show, Read) instance Param HeightsParam where proxyLabel = const "heights" - encodeParam _ (HeightsParam hs) = Just $ cs . show <$> hs - parseParam _ xs = HeightsParam <$> mapM (readMaybe . cs) xs + encodeParam net ctx (HeightsParam hs) = Just $ cs . show <$> hs + parseParam net ctx xs = HeightsParam <$> mapM (readMaybe . cs) xs -newtype TimeParam = TimeParam - { getTimeParam :: Store.UnixTime - } +newtype TimeParam = TimeParam {get :: Store.UnixTime} deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Param TimeParam where proxyLabel = const "time" - encodeParam _ (TimeParam t) = Just [cs $ show t] - parseParam _ [s] = TimeParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + encodeParam net ctx (TimeParam t) = Just [cs $ show t] + parseParam net ctx [s] = TimeParam <$> readMaybe (cs s) + parseParam net ctx _ = Nothing instance Param XPubKey where proxyLabel = const "xpub" - encodeParam net p = Just [xPubExport net p] - parseParam net [s] = xPubImport net s - parseParam _ _ = Nothing + encodeParam net ctx p = Just [xPubExport net ctx p] + parseParam net ctx [s] = xPubImport net ctx s + parseParam net ctx _ = Nothing instance Param Store.DeriveType where proxyLabel = const "derive" - encodeParam net p = do - guard (getSegWit net || p == Store.DeriveNormal) + encodeParam net ctx p = do + guard (net.segWit || p == Store.DeriveNormal) Just [Store.deriveTypeToText p] - parseParam net d = do + parseParam net ctx d = do res <- case d of [x] -> Store.textToDeriveType x _ -> Nothing - guard (getSegWit net || res == Store.DeriveNormal) + guard (net.segWit || res == Store.DeriveNormal) return res -newtype NoCache = NoCache - { getNoCache :: Bool - } +newtype NoCache = NoCache {get :: Bool} deriving (Eq, Show, Read) instance Default NoCache where @@ -559,16 +545,14 @@ instance Param NoCache where proxyLabel = const "nocache" - encodeParam _ (NoCache True) = Just ["true"] - encodeParam _ (NoCache False) = Just ["false"] - parseParam _ = \case + encodeParam net ctx (NoCache True) = Just ["true"] + encodeParam net ctx (NoCache False) = Just ["false"] + parseParam net ctx = \case ["true"] -> Just $ NoCache True ["false"] -> Just $ NoCache False _ -> Nothing -newtype NoTx = NoTx - { getNoTx :: Bool - } +newtype NoTx = NoTx {get :: Bool} deriving (Eq, Show, Read) instance Default NoTx where @@ -576,31 +560,31 @@ instance Param NoTx where proxyLabel = const "notx" - encodeParam _ (NoTx True) = Just ["true"] - encodeParam _ (NoTx False) = Just ["false"] - parseParam _ = \case + encodeParam net ctx (NoTx True) = Just ["true"] + encodeParam net ctx (NoTx False) = Just ["false"] + parseParam net ctx = \case ["true"] -> Just $ NoTx True ["false"] -> Just $ NoTx False _ -> Nothing instance Param BlockHash where proxyLabel = const "block" - encodeParam _ b = Just [blockHashToHex b] - parseParam _ [s] = hexToBlockHash s - parseParam _ _ = Nothing + encodeParam net ctx b = Just [blockHashToHex b] + parseParam net ctx [s] = hexToBlockHash s + parseParam net ctx _ = Nothing instance Param [BlockHash] where proxyLabel = const "blocks" - encodeParam _ bs = Just $ blockHashToHex <$> bs - parseParam _ = mapM hexToBlockHash + encodeParam net ctx bs = Just $ blockHashToHex <$> bs + parseParam net ctx = mapM hexToBlockHash instance Param TxHash where proxyLabel = const "txid" - encodeParam _ t = Just [txHashToHex t] - parseParam _ [s] = hexToTxHash s - parseParam _ _ = Nothing + encodeParam net ctx t = Just [txHashToHex t] + parseParam net ctx [s] = hexToTxHash s + parseParam net ctx _ = Nothing instance Param [TxHash] where proxyLabel = const "txids" - encodeParam _ ts = Just $ txHashToHex <$> ts - parseParam _ = mapM hexToTxHash + encodeParam net ctx ts = Just $ txHashToHex <$> ts + parseParam net ctx = mapM hexToTxHash diff --git a/test/Haskoin/Store/DataSpec.hs b/test/Haskoin/Store/DataSpec.hs --- a/test/Haskoin/Store/DataSpec.hs +++ b/test/Haskoin/Store/DataSpec.hs @@ -1,29 +1,33 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Haskoin.Store.DataSpec - ( spec, - ) -where +module Haskoin.Store.DataSpec (spec) where +import Control.Arrow (second) import Control.Monad (forM_) import Data.Aeson (FromJSON (..)) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.String.Conversions (cs) import Haskoin import Haskoin.Store.Data +import Haskoin.Util import Haskoin.Util.Arbitrary -import Test.Hspec (Spec, describe) +import Test.Hspec import Test.QuickCheck -serialVals :: [SerialBox] -serialVals = +serialVals :: Ctx -> [SerialBox] +serialVals ctx = [ SerialBox (arbitrary :: Gen DeriveType), - SerialBox (arbitrary :: Gen XPubSpec), + SerialBox (arbitraryXPubSpec ctx :: Gen XPubSpec), SerialBox (arbitrary :: Gen BlockRef), SerialBox (arbitrary :: Gen TxRef), SerialBox (arbitrary :: Gen Balance), @@ -33,7 +37,7 @@ SerialBox (arbitrary :: Gen Spender), SerialBox (arbitrary :: Gen StoreOutput), SerialBox (arbitrary :: Gen Prev), - SerialBox (arbitrary :: Gen TxData), + SerialBox (arbitraryTxData ctx :: Gen TxData), SerialBox (arbitrary :: Gen Transaction), SerialBox (arbitrary :: Gen XPubBal), SerialBox (arbitrary :: Gen XPubUnspent), @@ -41,7 +45,7 @@ SerialBox (arbitrary :: Gen HealthCheck), SerialBox (arbitrary :: Gen Event), SerialBox (arbitrary :: Gen TxId), - SerialBox (arbitrary :: Gen PeerInformation), + SerialBox (arbitrary :: Gen PeerInfo), SerialBox (arbitrary :: Gen (GenericResult BlockData)), SerialBox (arbitrary :: Gen (RawResult BlockData)), SerialBox (arbitrary :: Gen (RawResultList BlockData)) @@ -56,7 +60,7 @@ JsonBox (arbitrary :: Gen HealthCheck), JsonBox (arbitrary :: Gen Event), JsonBox (arbitrary :: Gen TxId), - JsonBox (arbitrary :: Gen PeerInformation), + JsonBox (arbitrary :: Gen PeerInfo), JsonBox (arbitrary :: Gen (GenericResult XPubSummary)), JsonBox (arbitrary :: Gen (RawResult BlockData)), JsonBox (arbitrary :: Gen (RawResultList BlockData)), @@ -72,135 +76,138 @@ JsonBox (arbitrary :: Gen BinfoShortBal), JsonBox (arbitrary :: Gen BinfoHistory), JsonBox (arbitrary :: Gen BinfoHeader), - JsonBox (arbitrary :: Gen BinfoBlocks) + JsonBox (arbitrary :: Gen BinfoBlockInfos) ] -netVals :: [NetBox] -netVals = +netVals :: Ctx -> [NetBox] +netVals ctx = [ NetBox - ( balanceToJSON, - balanceToEncoding, - balanceParseJSON, - arbitraryNetData + ( marshalValue, + marshalEncoding, + unmarshalValue, + arbitraryNetData :: Gen (Network, Balance) ), NetBox - ( storeOutputToJSON, - storeOutputToEncoding, - storeOutputParseJSON, - arbitraryNetData + ( marshalValue, + marshalEncoding, + unmarshalValue, + arbitraryNetData :: Gen (Network, StoreOutput) ), NetBox - ( unspentToJSON, - unspentToEncoding, - unspentParseJSON, - arbitraryNetData + ( marshalValue, + marshalEncoding, + unmarshalValue, + arbitraryNetData :: Gen (Network, Unspent) ), NetBox - ( xPubBalToJSON, - xPubBalToEncoding, - xPubBalParseJSON, - arbitraryNetData + ( marshalValue, + marshalEncoding, + unmarshalValue, + arbitraryNetData :: Gen (Network, XPubBal) ), NetBox - ( xPubUnspentToJSON, - xPubUnspentToEncoding, - xPubUnspentParseJSON, - arbitraryNetData + ( marshalValue, + marshalEncoding, + unmarshalValue, + arbitraryNetData :: Gen (Network, XPubUnspent) ), NetBox - ( storeInputToJSON, - storeInputToEncoding, - storeInputParseJSON, + ( marshalValue, + marshalEncoding, + unmarshalValue, arbitraryStoreInputNet ), NetBox - ( blockDataToJSON, - blockDataToEncoding, - const parseJSON, + ( marshalValue, + marshalEncoding, + unmarshalValue, arbitraryBlockDataNet ), NetBox - ( transactionToJSON, - transactionToEncoding, - transactionParseJSON, - arbitraryNetData + ( marshalValue, + marshalEncoding, + unmarshalValue, + arbitraryNetData :: Gen (Network, Transaction) ), NetBox - ( binfoMultiAddrToJSON, - binfoMultiAddrToEncoding, - binfoMultiAddrParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoMultiAddr ctx) ), NetBox - ( binfoBalanceToJSON, - binfoBalanceToEncoding, - binfoBalanceParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoBalance ctx) ), NetBox - ( binfoBlockToJSON, - binfoBlockToEncoding, - binfoBlockParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoBlock ctx) ), NetBox - ( binfoTxToJSON, - binfoTxToEncoding, - binfoTxParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoTx ctx) ), NetBox - ( binfoTxInputToJSON, - binfoTxInputToEncoding, - binfoTxInputParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoTxInput ctx) ), NetBox - ( binfoTxOutputToJSON, - binfoTxOutputToEncoding, - binfoTxOutputParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoTxOutput ctx) ), NetBox - ( binfoXPubPathToJSON, - binfoXPubPathToEncoding, - binfoXPubPathParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoXPubPath ctx) ), NetBox - ( binfoUnspentToJSON, - binfoUnspentToEncoding, - binfoUnspentParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoUnspent ctx) ), NetBox - ( binfoBlocksToJSON, - binfoBlocksToEncoding, - binfoBlocksParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (listOf (arbitraryBinfoBlock ctx)) ), NetBox - ( binfoRawAddrToJSON, - binfoRawAddrToEncoding, - binfoRawAddrParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoRawAddr ctx) ), NetBox - ( binfoMempoolToJSON, - binfoMempoolToEncoding, - binfoMempoolParseJSON, - arbitraryNetData + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (arbitraryBinfoMempool ctx) ) ] spec :: Spec -spec = do +spec = prepareContext $ \ctx -> do describe "Binary Encoding" $ - forM_ serialVals $ \(SerialBox g) -> testSerial g + forM_ (serialVals ctx) $ + \(SerialBox g) -> testSerial g describe "JSON Encoding" $ - forM_ jsonVals $ \(JsonBox g) -> testJson g + forM_ jsonVals $ + \(JsonBox g) -> testJson g describe "JSON Encoding with Network" $ - forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g + forM_ (netVals ctx) $ + \(NetBox (j, e, p, g)) -> testNetJson j e p g instance Arbitrary BlockRef where arbitrary = @@ -209,16 +216,16 @@ instance Arbitrary Prev where arbitrary = Prev <$> arbitraryBS1 <*> arbitrary -instance Arbitrary TxData where - arbitrary = - TxData - <$> arbitrary - <*> arbitraryTx btc - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary +arbitraryTxData :: Ctx -> Gen TxData +arbitraryTxData ctx = + TxData + <$> arbitrary + <*> arbitraryTx btc ctx + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary StoreInput where arbitrary = @@ -243,9 +250,12 @@ net <- arbitraryNetwork store <- arbitrary let res - | getSegWit net = store - | otherwise = store {inputWitness = []} + | net.segWit = store + | otherwise = witless store return (net, res) + where + witless StoreInput {..} = StoreInput {witness = [], ..} + witless StoreCoinbase {..} = StoreCoinbase {witness = [], ..} instance Arbitrary Spender where arbitrary = Spender <$> arbitraryTxHash <*> arbitrary @@ -274,9 +284,9 @@ <*> arbitrary <*> arbitrary -instance Arbitrary PeerInformation where +instance Arbitrary PeerInfo where arbitrary = - PeerInformation + PeerInfo <$> (cs <$> listOf arbitraryUnicodeChar) <*> listOf arbitraryPrintableChar <*> arbitrary @@ -318,6 +328,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary instance Arbitrary RejectCode where arbitrary = @@ -332,8 +343,8 @@ RejectCheckpoint ] -instance Arbitrary XPubSpec where - arbitrary = XPubSpec <$> (snd <$> arbitraryXPubKey) <*> arbitrary +arbitraryXPubSpec :: Ctx -> Gen XPubSpec +arbitraryXPubSpec ctx = XPubSpec <$> (snd <$> arbitraryXPubKey ctx) <*> arbitrary instance Arbitrary DeriveType where arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH] @@ -380,19 +391,19 @@ arbitraryBlockDataNet :: Gen (Network, BlockData) arbitraryBlockDataNet = do net <- arbitraryNetwork - dat <- arbitrary + dat@BlockData {..} <- arbitrary let res - | getSegWit net = dat - | otherwise = dat {blockDataWeight = 0} + | net.segWit = dat + | otherwise = BlockData {weight = 0, ..} return (net, res) -instance Arbitrary a => Arbitrary (GenericResult a) where +instance (Arbitrary a) => Arbitrary (GenericResult a) where arbitrary = GenericResult <$> arbitrary -instance Arbitrary a => Arbitrary (RawResult a) where +instance (Arbitrary a) => Arbitrary (RawResult a) where arbitrary = RawResult <$> arbitrary -instance Arbitrary a => Arbitrary (RawResultList a) where +instance (Arbitrary a) => Arbitrary (RawResultList a) where arbitrary = RawResultList <$> arbitrary instance Arbitrary XPubBal where @@ -441,157 +452,156 @@ BinfoTxIdIndex <$> arbitrary ] -instance Arbitrary BinfoMultiAddr where - arbitrary = do - getBinfoMultiAddrAddresses <- arbitrary - getBinfoMultiAddrWallet <- arbitrary - getBinfoMultiAddrTxs <- resize 10 arbitrary - getBinfoMultiAddrInfo <- arbitrary - getBinfoMultiAddrRecommendFee <- arbitrary - getBinfoMultiAddrCashAddr <- arbitrary - return BinfoMultiAddr {..} +arbitraryBinfoMultiAddr :: Ctx -> Gen BinfoMultiAddr +arbitraryBinfoMultiAddr ctx = do + addresses <- listOf1 $ arbitraryBinfoBalance ctx + wallet <- arbitrary + txs <- listOf $ arbitraryBinfoTx ctx + info <- arbitrary + recommendFee <- arbitrary + cashAddr <- arbitrary + return BinfoMultiAddr {..} -instance Arbitrary BinfoRawAddr where - arbitrary = do - binfoRawAddr <- - oneof - [ BinfoAddr <$> arbitraryAddress, - BinfoXpub . snd <$> arbitraryXPubKey - ] - binfoRawBalance <- arbitrary - binfoRawTxCount <- arbitrary - binfoRawUnredeemed <- arbitrary - binfoRawReceived <- arbitrary - binfoRawSent <- arbitrary - binfoRawTxs <- arbitrary - return $ BinfoRawAddr {..} +arbitraryBinfoRawAddr :: Ctx -> Gen BinfoRawAddr +arbitraryBinfoRawAddr ctx = do + address <- + oneof + [ BinfoAddr <$> arbitraryAddress, + BinfoXpub . snd <$> arbitraryXPubKey ctx + ] + balance <- arbitrary + ntx <- arbitrary + utxo <- arbitrary + received <- arbitrary + sent <- arbitrary + txs <- listOf $ arbitraryBinfoTx ctx + return $ BinfoRawAddr {..} instance Arbitrary BinfoShortBal where arbitrary = BinfoShortBal <$> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary BinfoBalance where - arbitrary = do - getBinfoAddress <- arbitraryAddress - getBinfoAddrTxCount <- arbitrary - getBinfoAddrReceived <- arbitrary - getBinfoAddrSent <- arbitrary - getBinfoAddrBalance <- arbitrary - getBinfoXPubKey <- snd <$> arbitraryXPubKey - getBinfoXPubAccountIndex <- arbitrary - getBinfoXPubChangeIndex <- arbitrary - elements [BinfoAddrBalance {..}, BinfoXPubBalance {..}] +arbitraryBinfoBalance :: Ctx -> Gen BinfoBalance +arbitraryBinfoBalance ctx = do + address <- arbitraryAddress + txs <- arbitrary + received <- arbitrary + sent <- arbitrary + balance <- arbitrary + xpub <- snd <$> arbitraryXPubKey ctx + external <- arbitrary + change <- arbitrary + elements [BinfoAddrBalance {..}, BinfoXPubBalance {..}] instance Arbitrary BinfoWallet where arbitrary = do - getBinfoWalletBalance <- arbitrary - getBinfoWalletTxCount <- arbitrary - getBinfoWalletFilteredCount <- arbitrary - getBinfoWalletTotalReceived <- arbitrary - getBinfoWalletTotalSent <- arbitrary + balance <- arbitrary + txs <- arbitrary + filtered <- arbitrary + received <- arbitrary + sent <- arbitrary return BinfoWallet {..} -instance Arbitrary BinfoBlock where - arbitrary = do - getBinfoBlockHash <- arbitraryBlockHash - getBinfoBlockVer <- arbitrary - getBinfoPrevBlock <- arbitraryBlockHash - getBinfoMerkleRoot <- getTxHash <$> arbitraryTxHash - getBinfoBlockTime <- arbitrary - getBinfoBlockBits <- arbitrary - getBinfoNextBlock <- listOf arbitraryBlockHash - getBinfoBlockTxCount <- arbitrary - getBinfoBlockFee <- arbitrary - getBinfoBlockNonce <- arbitrary - getBinfoBlockSize <- arbitrary - getBinfoBlockIndex <- arbitrary - getBinfoBlockMain <- arbitrary - getBinfoBlockHeight <- arbitrary - getBinfoBlockWeight <- arbitrary - getBinfoBlockTx <- resize 5 arbitrary - return BinfoBlock {..} +arbitraryBinfoBlock :: Ctx -> Gen BinfoBlock +arbitraryBinfoBlock ctx = do + hash <- arbitraryBlockHash + version <- arbitrary + prev <- arbitraryBlockHash + merkle <- (.get) <$> arbitraryTxHash + timestamp <- arbitrary + bits <- arbitrary + next <- listOf arbitraryBlockHash + ntx <- arbitrary + fee <- arbitrary + nonce <- arbitrary + size <- arbitrary + index <- arbitrary + main <- arbitrary + height <- arbitrary + weight <- arbitrary + txs <- resize 5 $ listOf $ arbitraryBinfoTx ctx + return BinfoBlock {..} -instance Arbitrary BinfoTx where - arbitrary = do - getBinfoTxHash <- arbitraryTxHash - getBinfoTxVer <- arbitrary - getBinfoTxInputs <- resize 5 $ listOf1 arbitrary - getBinfoTxOutputs <- resize 5 $ listOf1 arbitrary - let getBinfoTxVinSz = fromIntegral (length getBinfoTxInputs) - getBinfoTxVoutSz = fromIntegral (length getBinfoTxOutputs) - getBinfoTxSize <- arbitrary - getBinfoTxWeight <- arbitrary - getBinfoTxFee <- arbitrary - getBinfoTxRelayedBy <- cs <$> listOf arbitraryUnicodeChar - getBinfoTxLockTime <- arbitrary - getBinfoTxIndex <- arbitrary - getBinfoTxDoubleSpend <- arbitrary - getBinfoTxRBF <- arbitrary - getBinfoTxTime <- arbitrary - getBinfoTxBlockIndex <- arbitrary - getBinfoTxBlockHeight <- arbitrary - getBinfoTxResultBal <- arbitrary - return BinfoTx {..} +arbitraryBinfoTx :: Ctx -> Gen BinfoTx +arbitraryBinfoTx ctx = do + txid <- arbitraryTxHash + version <- arbitrary + inputs <- resize 5 $ listOf1 $ arbitraryBinfoTxInput ctx + outputs <- resize 5 $ listOf1 $ arbitraryBinfoTxOutput ctx + let inputCount = fromIntegral $ length inputs + outputCount = fromIntegral $ length outputs + size <- arbitrary + weight <- arbitrary + fee <- arbitrary + relayed <- cs <$> listOf arbitraryUnicodeChar + locktime <- arbitrary + index <- arbitrary + doubleSpend <- arbitrary + rbf <- arbitrary + timestamp <- arbitrary + blockIndex <- arbitrary + blockHeight <- arbitrary + balance <- arbitrary + return BinfoTx {..} -instance Arbitrary BinfoTxInput where - arbitrary = do - getBinfoTxInputSeq <- arbitrary - getBinfoTxInputWitness <- B.pack <$> listOf arbitrary - getBinfoTxInputScript <- B.pack <$> listOf arbitrary - getBinfoTxInputIndex <- arbitrary - getBinfoTxInputPrevOut <- arbitrary - return BinfoTxInput {..} +arbitraryBinfoTxInput :: Ctx -> Gen BinfoTxInput +arbitraryBinfoTxInput ctx = do + sequence <- arbitrary + witness <- B.pack <$> listOf arbitrary + script <- B.pack <$> listOf arbitrary + index <- arbitrary + output <- arbitraryBinfoTxOutput ctx + return BinfoTxInput {..} -instance Arbitrary BinfoTxOutput where - arbitrary = do - getBinfoTxOutputType <- arbitrary - getBinfoTxOutputSpent <- arbitrary - getBinfoTxOutputValue <- arbitrary - getBinfoTxOutputIndex <- arbitrary - getBinfoTxOutputTxIndex <- arbitrary - getBinfoTxOutputScript <- B.pack <$> listOf arbitrary - getBinfoTxOutputSpenders <- arbitrary - getBinfoTxOutputAddress <- - oneof [return Nothing, Just <$> arbitraryAddress] - getBinfoTxOutputXPub <- arbitrary - return BinfoTxOutput {..} +arbitraryBinfoTxOutput :: Ctx -> Gen BinfoTxOutput +arbitraryBinfoTxOutput ctx = do + typ <- arbitrary + spent <- arbitrary + value <- arbitrary + index <- arbitrary + txidx <- arbitrary + script <- B.pack <$> listOf arbitrary + spenders <- arbitrary + address <- arbitraryMaybe arbitraryAddress + xpub <- arbitraryMaybe $ arbitraryBinfoXPubPath ctx + return BinfoTxOutput {..} instance Arbitrary BinfoSpender where arbitrary = do - getBinfoSpenderTxIndex <- arbitrary - getBinfoSpenderIndex <- arbitrary + txidx <- arbitrary + input <- arbitrary return BinfoSpender {..} -instance Arbitrary BinfoXPubPath where - arbitrary = do - getBinfoXPubPathKey <- snd <$> arbitraryXPubKey - getBinfoXPubPathDeriv <- arbitrarySoftPath - return BinfoXPubPath {..} +arbitraryBinfoXPubPath :: Ctx -> Gen BinfoXPubPath +arbitraryBinfoXPubPath ctx = do + key <- snd <$> arbitraryXPubKey ctx + deriv <- arbitrarySoftPath + return BinfoXPubPath {..} instance Arbitrary BinfoInfo where arbitrary = do - getBinfoConnected <- arbitrary - getBinfoConversion <- arbitrary - getBinfoLocal <- arbitrary - getBinfoBTC <- arbitrary - getBinfoLatestBlock <- arbitrary + connected <- arbitrary + conversion <- arbitrary + fiat <- arbitrary + crypto <- arbitrary + head <- arbitrary return BinfoInfo {..} instance Arbitrary BinfoBlockInfo where arbitrary = do - getBinfoBlockInfoHash <- arbitraryBlockHash - getBinfoBlockInfoHeight <- arbitrary - getBinfoBlockInfoTime <- arbitrary - getBinfoBlockInfoIndex <- arbitrary + hash <- arbitraryBlockHash + height <- arbitrary + timestamp <- arbitrary + index <- arbitrary return BinfoBlockInfo {..} instance Arbitrary BinfoSymbol where arbitrary = do - getBinfoSymbolCode <- cs <$> listOf1 arbitraryUnicodeChar - getBinfoSymbolString <- cs <$> listOf1 arbitraryUnicodeChar - getBinfoSymbolName <- cs <$> listOf1 arbitraryUnicodeChar - getBinfoSymbolConversion <- arbitrary - getBinfoSymbolAfter <- arbitrary - getBinfoSymbolLocal <- arbitrary + code <- cs <$> listOf1 arbitraryUnicodeChar + symbol <- cs <$> listOf1 arbitraryUnicodeChar + name <- cs <$> listOf1 arbitraryUnicodeChar + conversion <- arbitrary + after <- arbitrary + local <- arbitrary return BinfoSymbol {..} instance Arbitrary BinfoRate where @@ -599,39 +609,40 @@ instance Arbitrary BinfoTicker where arbitrary = do - binfoTicker15m <- arbitrary - binfoTickerSell <- arbitrary - binfoTickerBuy <- arbitrary - binfoTickerLast <- arbitrary - binfoTickerSymbol <- cs <$> listOf1 arbitraryUnicodeChar + fifteen <- arbitrary + sell <- arbitrary + buy <- arbitrary + last <- arbitrary + symbol <- cs <$> listOf1 arbitraryUnicodeChar return BinfoTicker {..} instance Arbitrary BinfoHistory where arbitrary = do - binfoHistoryDate <- cs <$> listOf1 arbitraryUnicodeChar - binfoHistoryTime <- cs <$> listOf1 arbitraryUnicodeChar - binfoHistoryType <- cs <$> listOf1 arbitraryUnicodeChar - binfoHistoryAmount <- arbitrary - binfoHistoryValueThen <- arbitrary - binfoHistoryValueNow <- arbitrary - binfoHistoryExchangeRateThen <- arbitrary - binfoHistoryTx <- arbitraryTxHash - binfoHistoryFee <- arbitrary + date <- cs <$> listOf1 arbitraryUnicodeChar + time <- cs <$> listOf1 arbitraryUnicodeChar + typ <- cs <$> listOf1 arbitraryUnicodeChar + amount <- arbitrary + valueThen <- arbitrary + valueNow <- arbitrary + rateThen <- arbitrary + txid <- arbitraryTxHash + fee <- arbitrary return BinfoHistory {..} -instance Arbitrary BinfoUnspent where - arbitrary = do - getBinfoUnspentHash <- arbitraryTxHash - getBinfoUnspentOutputIndex <- arbitrary - getBinfoUnspentScript <- B.pack <$> listOf arbitrary - getBinfoUnspentValue <- arbitrary - getBinfoUnspentConfirmations <- arbitrary - getBinfoUnspentTxIndex <- arbitrary - getBinfoUnspentXPub <- arbitrary - return BinfoUnspent {..} +arbitraryBinfoUnspent :: Ctx -> Gen BinfoUnspent +arbitraryBinfoUnspent ctx = do + txid <- arbitraryTxHash + index <- arbitrary + script <- B.pack <$> listOf arbitrary + value <- arbitrary + confirmations <- arbitrary + txidx <- arbitrary + xpub <- arbitraryMaybe $ arbitraryBinfoXPubPath ctx + return BinfoUnspent {..} -instance Arbitrary BinfoUnspents where - arbitrary = BinfoUnspents <$> arbitrary +arbitraryBinfoUnspents :: Ctx -> Gen BinfoUnspents +arbitraryBinfoUnspents ctx = + fmap BinfoUnspents $ listOf $ arbitraryBinfoUnspent ctx instance Arbitrary BinfoHeader where arbitrary = @@ -642,8 +653,9 @@ <*> arbitrary <*> arbitrary -instance Arbitrary BinfoMempool where - arbitrary = BinfoMempool <$> arbitrary +arbitraryBinfoMempool :: Ctx -> Gen BinfoMempool +arbitraryBinfoMempool ctx = + fmap BinfoMempool $ listOf $ arbitraryBinfoTx ctx -instance Arbitrary BinfoBlocks where - arbitrary = BinfoBlocks <$> arbitrary +instance Arbitrary BinfoBlockInfos where + arbitrary = BinfoBlockInfos <$> arbitrary diff --git a/test/Haskoin/Store/WebCommonSpec.hs b/test/Haskoin/Store/WebCommonSpec.hs --- a/test/Haskoin/Store/WebCommonSpec.hs +++ b/test/Haskoin/Store/WebCommonSpec.hs @@ -1,14 +1,13 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Haskoin.Store.WebCommonSpec - ( spec, - ) -where +module Haskoin.Store.WebCommonSpec (spec) where import Control.Monad (forM_) import Data.Proxy @@ -18,6 +17,7 @@ import Haskoin.Store.Data import Haskoin.Store.DataSpec () import Haskoin.Store.WebCommon +import Haskoin.Util import Haskoin.Util.Arbitrary import Test.Hspec import Test.Hspec.QuickCheck @@ -25,8 +25,8 @@ data GenBox = forall p. (Show p, Eq p, Param p) => GenBox (Gen p) -params :: [GenBox] -params = +params :: Ctx -> [GenBox] +params ctx = [ GenBox arbitraryAddress, GenBox (listOf arbitraryAddress), GenBox (arbitrary :: Gen StartParam), @@ -35,7 +35,7 @@ GenBox (arbitrarySizedNatural :: Gen HeightParam), GenBox (arbitrary :: Gen HeightsParam), GenBox (arbitrarySizedNatural :: Gen TimeParam), - GenBox (snd <$> arbitraryXPubKey :: Gen XPubKey), + GenBox (snd <$> arbitraryXPubKey ctx :: Gen XPubKey), GenBox (arbitrary :: Gen DeriveType), GenBox (NoCache <$> arbitrary :: Gen NoCache), GenBox (NoTx <$> arbitrary :: Gen NoTx), @@ -46,16 +46,17 @@ ] spec :: Spec -spec = +spec = prepareContext $ \ctx -> describe "Parameter encoding" $ - forM_ params $ \(GenBox g) -> testParam g + forM_ (params ctx) $ + \(GenBox g) -> testParam ctx g -testParam :: (Eq a, Show a, Param a) => Gen a -> Spec -testParam pGen = +testParam :: (Eq a, Show a, Param a) => Ctx -> Gen a -> Spec +testParam ctx pGen = prop ("encodeParam/parseParam identity for parameter " <> name) $ forAll pGen $ \p -> - case encodeParam btc p of - Just txts -> parseParam btc txts `shouldBe` Just p + case encodeParam btc ctx p of + Just txts -> parseParam btc ctx txts `shouldBe` Just p _ -> expectationFailure "Param encoding failed" where name = cs $ proxyLabel $ proxy pGen