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